clash-lib-1.8.1/0000755000000000000000000000000007346545000011550 5ustar0000000000000000clash-lib-1.8.1/CHANGELOG.md0000755000000000000000000026574707346545000013411 0ustar0000000000000000# Changelog for the Clash project ## 1.8.1 *Nov 10th 2023* * Bump package dependencies to allow inclusion in stackage-nightly * Bump package dependencies to allow building on GHC 9.8.1 ## 1.8.0 *Nov 10th 2023* 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 * 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. In order to build a snap package, we build .deb packages for Clash with Ubuntu 20.04 LTS. But the interaction between the Debian build system and GHC is problematic, requiring significant effort to support and to upgrade to a more recent Ubuntu release. Additionally, snap packages have their own issues on distributions other than Ubuntu. Given that we no longer recommend people use our snap package and given the effort required to keep supporting them, we have decided to drop the snap package. ## 1.6.5 *Jun 27th 2023* Fixed: * Support building with all combinations of specific versions of our dependencies `hashable` and `primitive`. [#2485](https://github.com/clash-lang/clash-compiler/pull/2485) * The Haskell simulation of the PLL lock signal in `Clash.Clocks` (used by `Clash.Intel.ClockGen`) is fixed: the signal is now unasserted for the time the reset input is asserted and vice versa, and no longer crashes the simulation. HDL generation is unchanged. The PLL functions now have an additional constraint: `KnownDomain pllLock`. [#2420](https://github.com/clash-lang/clash-compiler/pull/2420) Changed: * Export the constructor for the `Wrapping` type in the `Clash.Num.Wrapping` module. See [#2292](https://github.com/clash-lang/clash-compiler/issues/2292) ## 1.6.4 *Aug 30th 2022* Fixed: * Input validation of the used arguments in blackboxes is now complete. [#2184](https://github.com/clash-lang/clash-compiler/pull/2184) * `Clash.Annotations.BitRepresentation.Deriving.deriveAnnotation` no longer has quadratic complexity in the size of the constructors and fields. [#2209](https://github.com/clash-lang/clash-compiler/pull/2209) * Fully resolve type synonyms when deriving bit representations. [#2209](https://github.com/clash-lang/clash-compiler/pull/2209) * Disregard ticks when determining whether terms are shared. Fixes [#2233](https://github.com/clash-lang/clash-compiler/issues/2233). * The blackbox parser will make sure it fully parses its input, and report an error when it can't. [#2237](https://github.com/clash-lang/clash-compiler/issues/2237) * Wrap ~ARG[n] in parentheses. Fixes [#2213](https://github.com/clash-lang/clash-compiler/issues/2213) * The VHDL shift primitives no longer generate bound check failures. Fixes [#2215](https://github.com/clash-lang/clash-compiler/issues/2215) * Evaluator fails impredicative type instantiation of error values [#2272](https://github.com/clash-lang/clash-compiler/issues/2272) * Fix out of bound errors in toEnum/fromSLV for sum types [#2220](https://github.com/clash-lang/clash-compiler/issues/2220) * Netlist generation fails for certain uses of GADTs [#2289](https://github.com/clash-lang/clash-compiler/issues/2289) * The documentation for `ANN TestBench` had it backwards; it now correctly indicates the annotation is on the test bench, not the device under test. [#1750](https://github.com/clash-lang/clash-compiler/issues/1750) Fixes with minor changes: * `reduceXor` now produces a result if the argument has undefined bits instead of throwing an `XException` (the result is an undefined bit). `reduceAnd` and `reduceOr` already always produced a result. [#2244](https://github.com/clash-lang/clash-compiler/pull/2244) Added: * Support for symbols in types while deriving bit representations. [#2209](https://github.com/clash-lang/clash-compiler/pull/2209) * Support for promoted data types while deriving bit representations. [#2209](https://github.com/clash-lang/clash-compiler/pull/2209) * `scanlPar` and `scanrPar` in Clash's Prelude, as well as the `RTree` versions `tscanl` and `tscanr`. These variants of `scanl1` and `scanr1` compile to a binary tree of operations, with a depth of `O(log(n))` (`n` being the length of the vector) rather than a depth of `n` for `scanl1` and `scanr1`. [#2177](https://github.com/clash-lang/clash-compiler/pull/2177) * The GADT constructors for `RTree` (`RLeaf` and `RBranch`) are now exported directly in addition to the patterns `LR` and `BR`. [#2177](https://github.com/clash-lang/clash-compiler/pull/2177) * Added the `~ISSCALAR` template which can be used to check if an argument is rendered to a scalar in HDL. [#2184](https://github.com/clash-lang/clash-compiler/pull/2184) * Added support for records and infix constructors when using `Clash.Annotations.BitRepresentation.Deriving.deriveAnnotation`. [#2191](https://github.com/clash-lang/clash-compiler/pull/2191) * Clash now contains instances for `ShowX`, `NFDataX` and `BitPack` on the newtypes from the Data.Functor modules (`Identity`, `Const`, `Compose`, `Product` and `Sum`). [#2218](https://github.com/clash-lang/clash-compiler/issues/2218) ## 1.6.3 *Apr 7th 2022* Fixed: * Handle `~ISUNDEFINED` hole in black boxes for `BitVector` and for product types. This means that with `-fclash-aggressive-x-optimization-blackboxes`, resets are now omitted for _undefined_ reset values of such types as well. [#2117](https://github.com/clash-lang/clash-compiler/issues/2117) * The `alteraPll` primitive was unusable since commit `d325557750` (release v1.4.0), it now works again. [#2136](https://github.com/clash-lang/clash-compiler/pull/2136) * Simulation/Synthesis mismatch for X-exception to undefined bitvector conversion [#2154](https://github.com/clash-lang/clash-compiler/issues/2154) * The VHDL blackbox for `Signed.fromInteger` can now handle any `Netlist Expr` as input [#2149](https://github.com/clash-lang/clash-compiler/issues/2149) * Clash no longer escapes extended identifiers when rendering SDC files. [#2142](https://github.com/clash-lang/clash-compiler/pull/2142) * The types defined in `clash-prelude-hedgehog` now come with `Show` instances [#2133](https://github.com/clash-lang/clash-compiler/issues/2133) * Extreme values are now generated from the input range instead of the type's bounds [#2138](https://github.com/clash-lang/clash-compiler/issues/2138) 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: * Clash now compiles for users of Clang - i.e., all macOS users. * The `trueDualPortBlockRam` model did not accurately simulate concurrent active ports, thus causing a Haskell/HDL simulation mismatch for `asyncFIFOSynchronizer`. * `trueDualPortBlockRam` Haskell/HDL simulation mismatch for port enable. * Sometimes `trueDualPortBlockRam` swapped the names of the ports in exception messages. [#2102](https://github.com/clash-lang/clash-compiler/pull/2102) * The evaluator rule for unpack{Float,Double}# are now corrected to return boxed float and double instead of unboxed literals. [#2097](https://github.com/clash-lang/clash-compiler/issues/2097) Changed: * The `trueDualPortBlockRam` model now only models read/write conflicts for concurrent active ports * The `trueDualPortBlockRam` model now models write/write conflicts for concurrent active ports ## 1.6.1 *Feb 11th 2022* Changed: * We accidentally released `v1.6.0` with the Cabal flag `multiple-hidden` enabled. This is an experimental feature, supposed to be disabled by default for releases. `v1.6.1` disables it again. Added: * `Clash.Class.HasDomain.TryDomain` instances for Clash sized types ## 1.6.0 *Feb 10th 2022* Added: * `Clash.Class.Counter`: a class that defines a odometer-style supercounter. [#1763](https://github.com/clash-lang/clash-compiler/pull/1763) * `isLike` function for BitPack types. [#1774](https://github.com/clash-lang/clash-compiler/pull/1774) * 'seqErrorX' for catching both `XException` and `ErrorCall`. [#1774](https://github.com/clash-lang/clash-compiler/pull/1774) * `Clash.Explicit.BlockRam.File.memFile`, a function for creating the contents of the data files this blockRAM uses. Can also be imported from `Clash.Prelude.BlockRam.File`, `Clash.Prelude.ROM.File` and `Clash.Explicit.ROM.File`. [#1840](https://github.com/clash-lang/clash-compiler/pull/1840) * Support for Yosys compatible SVA to `Clash.Verification`. This enables formal verification using SymbiYosis for Verilog and SystemVerilog. [#1798](https://github.com/clash-lang/clash-compiler/pull/1798) * `Clash.Explicit.Signal.Delayed.forward`, a function that can be used to retime a `DSignal` into the future without applying any logic. [#1882](https://github.com/clash-lang/clash-compiler/pull/1882) * `Clash.Signal.andEnable` is the `HiddenEnable` version of `Clash.Explicit.Signal.andEnable` (formerly known as `enable`) [#1849](https://github.com/clash-lang/clash-compiler/pull/1849) * `runUntil`, a function to sample a signal until it returns a value that satisfies the user-given test. It is a convenience function that, among others, allow easy running of a `testBench` style function in Haskell simulation, logging assertion failures to stderr. [#1940](https://github.com/clash-lang/clash-compiler/pull/1940) * Support for true dual ported block ram through `Clash.Prelude.BlockRam.trueDualPortBlockRam` and `Clash.Explicit.BlockRam.trueDualPortBlockRam`. [#1726](https://github.com/clash-lang/clash-compiler/pull/1726) [#1975](https://github.com/clash-lang/clash-compiler/pull/1975) * `clash-{prelude,lib}-hedgehog` packages which provide generators for types in `clash-prelude` and `clash-lib`. The former is published on Hackage. [#1976](https://github.com/clash-lang/clash-compiler/pull/1976) * Clash now contains black boxes which are verilator compatible. When running with `--verilog` or `--systemverilog` a C++ shim is automatically produced which can be used to quickly generate a verilated executable. Users who wish to interact with verilator simulations are recommended to use [clashilator](https://github.com/gergoerdi/clashilator). [#2019](https://github.com/clash-lang/clash-compiler/pull/2019) * Support for YAML blackboxes. Clash will now pickup on files with a `.primitives.yaml` extension. While we recommend upgrading your primitive files to the new format, old style primitives are still supported. We've included a tool to automatically upgrade your JSON files, see [#2037](https://github.com/clash-lang/clash-compiler/pull/2037) * `MemBlob`: a datastructure for efficient constants, typically used for initializing memories. [#2041](https://github.com/clash-lang/clash-compiler/pull/2041) Fixed: * BlockRam simulation is now less strict. [#1458](https://github.com/clash-lang/clash-compiler/issues/1458) * Don't overflow VHDL's integer type when addressing RAM/ROM in simulation.Addresses are masked to 32 bits to be sure to keep it within the simulator's range. [#1875](https://github.com/clash-lang/clash-compiler/pull/1875) * `show` on `BitVector 0` no longer results in an empty string. [#1785](https://github.com/clash-lang/clash-compiler/pull/1785) * Clash now preserves transfinite floating numbers (NaN, Infinity) when packing/unpacking [#1803](https://github.com/clash-lang/clash-compiler/issues/1803) * `SynthesisAnnotation`s can now be defined in type synoynms without being excluded from the generated HDL [#1771](https://github.com/clash-lang/clash-compiler/issues/1771) * Manifest files now correctly list bidirectional ports as "inout" rather than "in" [#1843](https://github.com/clash-lang/clash-compiler/issues/1843) * `div`/`rem`/`mod` now avoid division by zero during VHDL simulation. Due to the use of concurrent statements, even unreachable code would previously result in simulation error [#1873](https://github.com/clash-lang/clash-compiler/pull/1873) * Don't overflow the range of VHDL's natural type in shift/rotate, leading to simulation issues. Shift now saturates to a 31-bit shift amount. For rotate, in simulation only, the rotate amount is modulo the word width of the rotated value [#1874](https://github.com/clash-lang/clash-compiler/pull/1874) * `shiftL` for Clash datatypes does not cause a crash anymore when running Clash code with a really large shift amount [#1874](https://github.com/clash-lang/clash-compiler/pull/1874) * VHDL generated for `Signed.fromInteger` now truncates, like the Clash simulation, when the result is smaller than the argument [#1874](https://github.com/clash-lang/clash-compiler/pull/1874) * Clash now preserves boolean combinatorial logic better when generating HDL [#1881](https://github.com/clash-lang/clash-compiler/issues/1881) * `valid` field of `TemplateFunction` is now checked for includes [#1945](https://github.com/clash-lang/clash-compiler/issues/1945) * Clash now generates clock generators that ensure that the amount of time between simulation start and the first active edge of the clock is equal to (/or longer than/) the period of the clock. The first active edges of the clocks do still occur simultaneously. [#2001](https://github.com/clash-lang/clash-compiler/issues/2001) * Expected values in assert become undefined when using `-fclash-compile-ultra` [#2040](https://github.com/clash-lang/clash-compiler/issues/2040) * `toEnum`/`fromEnum` on sized types is now less eager to report warnings about integer functions being used [#2046](https://github.com/clash-lang/clash-compiler/issues/2046) Changed: * `Clash.Verification.PrettyPrinters` has been moved from clash-prelude to to `Clash.Verification.Pretty` in `clash-lib`. [#1798](https://github.com/clash-lang/clash-compiler/pull/1798) * RAM/ROM functions: They now throw `XExeception` for out-of-bounds address inputs, so this condition no longer aborts simulation. [#1875](https://github.com/clash-lang/clash-compiler/pull/1875) * `Vec`'s show instance now generates valid Haskell. [#1776](https://github.com/clash-lang/clash-compiler/issues/1776) * `ShowX` and its functions now produce valid Haskell [#1782](https://github.com/clash-lang/clash-compiler/issues/1782) * `bLit` now infers the size of the generated BitVector from the string given to it. This means you don't have to give it an explicit type signature anymore. This does slightly modify the syntax needed to invoke `bLit`. E.g., `$$(bLit "00..1") :: BitVector 5` should be rewritten as `$(bLit "00..1")`. If you relied on the size inference, wrap the new invocation in `resize`. For example: `resize $(bLit "00..1")`. [#1784](https://github.com/clash-lang/clash-compiler/pull/1784) * `NumericUnderscores` is now enabled by default in `clash`, `clashi`, and starter projects using Clash >=1.6. [#1785](https://github.com/clash-lang/clash-compiler/pull/1785) * `Show` instance of `BitVector` now includes a `0b` prefix, making it a copyable expression for fully defined vectors. [#1785](https://github.com/clash-lang/clash-compiler/pull/1785) * `blockRam` uses `STArray` as the underlying representation to improve simulation performance [#1878](https://github.com/clash-lang/clash-compiler/pull/1878) * `asyncRom` now throws `XException` for out-of-bounds addressing, no longer aborting simulation [#1878](https://github.com/clash-lang/clash-compiler/pull/1878) * Clash now renders ADTs with all zero-width fields as enumerations in VHDL [#1879](https://github.com/clash-lang/clash-compiler/pull/1879) * A warning about possible hard-to-debug issues has been added to the `Clash.Signal` documentation on hidden clocks, resets, and enables, in the form of the section named "Monomorphism restriction leads to surprising behavior" [#1960](https://github.com/clash-lang/clash-compiler/pull/1960) * `Clash.Explicit.Testbench.outputVerifier` and `outputVerifierBitVector` now emit a warning if they are used improperly. This situation only arises when they are used in synthesized code rather than a test bench context. When the clock domains `circuitDom` and `testDom` are two different domains, the clock crossing inside `outputVerifier` is only suitable inside a test bench, not inside a synthesized circuit. Clash now emits a warning for this case. [#1931](https://github.com/clash-lang/clash-compiler/pull/1931) * `resetSynchronizer` now no longer takes an `Enable` argument. The argument was already marked for removal and was ignored. [#1964](https://github.com/clash-lang/clash-compiler/pull/1964) * Clash can now compile multiple entities concurrently, providing speedups to designs with multiple entities to build [#2034](https://github.com/clash-lang/clash-compiler/pull/2034) * All `asyncRam` variants and `asyncFIFOSynchronizer` now require that the data has an `NFDataX` instance. [#2055](https://github.com/clash-lang/clash-compiler/pull/2055) * Clash now respects the `-Werror` option from GHC [#2066](https://github.com/clash-lang/clash-compiler/pull/2066) * `asyncFIFOSynchronizer` now uses the synchronous dual-ported RAM `trueDualPortBlockRam`, where it previously used a dual-ported RAM with an asynchronous read port `asyncRam`. With this change it's nearly guaranteed that `asyncFIFOSynchronizer` actually synthesizes to a circuit that uses the dual-ported RAMs found on most FPGAs. [#2083](https://github.com/clash-lang/clash-compiler/pull/2083) Deprecated: * The function `Clash.Explicit.Signal.enable` is renamed to `andEnable` and the existing name deprecated [#1849](https://github.com/clash-lang/clash-compiler/pull/1849) * '-fclash-float-support': it is now on by default and can't be turned off. [#2048](https://github.com/clash-lang/clash-compiler/pull/2048) Removed: * GHC 8.4 is no longer supported. Users should upgrade to at least GHC 8.6. [#1762](https://github.com/clash-lang/clash-compiler/pull/1762) Internal changes: * `clash-lib` now uses `Data.Monoid.Ap` instead of `Data.Semigroup.Monad.Mon`. This means users defining primitives with `TemplateFunction` will need to replace `Mon`/`getMon` with `Ap`/`getAp`. [#1835](https://github.com/clash-lang/clash-compiler/pull/1835) * Clash now supports more expressive debug options at the command line [#1800](https://github.com/clash-lang/clash-compiler/issues/1800). * Added `zeroWidthSpec` transformation [#1891](https://github.com/clash-lang/clash-compiler/pull/1891) * Added `collapseRHSNoops` inlining stage and `WorkIdentity` constructor [#1896](https://github.com/clash-lang/clash-compiler/pull/1896) * Added `HasType` and `InferType` classes for getting / inferring core types from data representing some typed "thing" [#1915](https://github.com/clash-lang/clash-compiler/pull/1915) * Added `HasFreeVars` class for getting free variables from data "containing" variables [#1917](https://github.com/clash-lang/clash-compiler/pull/1917) * Added the primitive equality type (`~#`) to `Clash.Core.TysPrim`. In order to make this change, `undefinedTy` and `unsafeCoerceTy` were moved from `Clash.Core.Type` to `Clash.Core.Util`. [#1955](https://github.com/clash-lang/clash-compiler/pull/1955) * Clash now keeps information about which let bindings are recursive from GHC core. This can be used to avoid performing free variable calculations, or sorting bindings in normalization. [#1980](https://github.com/clash-lang/clash-compiler/pull/1980) [#2000](https://github.com/clash-lang/clash-compiler/pull/2000) * Manifest files now use SHA256 for a cache invalidation digest [#1985](https://github.com/clash-lang/clash-compiler/pull/1985) ## 1.4.7 *Jan 30th 2022* Fixed: * Clash now shows days in time strings for compile runs which take longer than a day [#1989](https://github.com/clash-lang/clash-compiler/compare/issue-1989). * Types defined in the package head are no longer qualified in the package body when rendering VHDL [#1996](https://github.com/clash-lang/clash-compiler/issues/1996). * `asyncRam` with different read and write clocks no longer produce the wrong results in Haskell simulation. [#2031](https://github.com/clash-lang/clash-compiler/pull/2031) * `Clash.Explicit.RAM.asyncRam#` Haskell simulation incorrectly treated an _undefined_ write enable as asserted. It now causes an _undefined_ value to be written instead. This problem did not propagate to the other `asyncRam` functions, where the same condition would simultaneously lead to an undefined write address, which would be handled correctly. This problem also only affects Haskell simulation, not the generated HDL. [#2031](https://github.com/clash-lang/clash-compiler/pull/2031) * `Clash.Explicit.BlockRam.blockRam#` and `Clash.Explicit.BlockRam.File.blockRamFile#` Haskell simulation incorrectly treated an _undefined_ write enable as asserted. It now causes an _undefined_ value to be written instead. This problem did not propagate to the other `blockRam` functions, where the same condition would simultaneously lead to an undefined write address, which would be handled correctly. This problem also only affects Haskell simulation, not the generated HDL.([#2054](https://github.com/clash-lang/clash-compiler/pull/2054)) Internal changes: * Removed instances of `Hashable Term` and `Hashable Type` [#1986](https://github.com/clash-lang/clash-compiler/pull/1986) * Added structural equality on `Term` (`Clash.Core.Subst.eqTerm`) and `Type` (`Clash.Core.Subst.eqType`) Internal fixes: * Enable used to be a `Bool` in the Blackbox DSL, so we could use `boolToBit`. However it now has its own type in the DSL (`Enable domainName`), so we've added a new conversion function in order to convert it to a Bool. ## 1.4.6 *Oct 26th 2021* Fixed: * Clash tries to cast-specialize non-"global binders" resulting in "specialisation of non-work-free cast" warning [#1933](https://github.com/clash-lang/clash-compiler/issues/1945) * More consistently render bare untyped and unsized literals for `~LIT` tags. This fixes [#1934](https://github.com/clash-lang/clash-compiler/issues/1934) ## 1.4.5 *Oct 13th 2021* Changed: * `clash-lib` now supports prettyprinter 1.7 Documentation: * The documentation on hidden clocks, resets, and enables has been corrected and extended in `Clash.Signal`. ## 1.4.4 *Oct 11th 2021* Changed: * `clash-lib` now supports aeson >= 2.0 Fixed: * Dont' loop on recursive data types hiding behind type families [#1921](https://github.com/clash-lang/clash-compiler/issues/1921) * Recognize `enableGen` as workfree and don't duplicate registers [#1935](https://github.com/clash-lang/clash-compiler/issues/1935) ## 1.4.3 *Aug 8th 2021* Fixed: * Clash no longer generates calls to `{shift,rotate}_{left,right}` in VHDL where the count is a negative number [#1810](https://github.com/clash-lang/clash-compiler/issues/1810). * Clash no longer incurs unnecessary compile-time complexity while compiling Vector indexing operator [#1557](https://github.com/clash-lang/clash-compiler/issues/1557) ## 1.4.2 *May 18th 2021* Fixed: * Erroneous examples in `Clash.Annotation.TopEntity` documentation [#646](https://github.com/clash-lang/clash-compiler/issues/646) and [#654](https://github.com/clash-lang/clash-compiler/issues/654) * `unconcat` cannot be used as initial/reset value for a `register` [#1756](https://github.com/clash-lang/clash-compiler/issues/1756) * `showX` now doesn't crash if a spine of a `Vec` is undefined * `~ISACTIVEENABLE` in blackboxes works again, and now acts on `Signal dom Bool` in addition to `Enable dom`. Since [#1368](https://github.com/clash-lang/clash-compiler/pull/1368), enable lines were always generated even if they were known to be always enabled. Fixes [#1786](https://github.com/clash-lang/clash-compiler/issues/1786). * clash --show-options now shows -fclash-* options in GHC 9.0 [#1787](https://github.com/clash-lang/clash-compiler/issues/1787) * `makeRecursiveGroups` now correctly identifies mutual recursion between global binders ([#1796](https://github.com/clash-lang/clash-compiler/issues/1796)). ## 1.4.1 *April 6th 2021* Fixed: * Broken VHDL primitive template for setSlice# [#1715](https://github.com/clash-lang/clash-compiler/issues/1715) * Unable to reduce nested type families [#1721](https://github.com/clash-lang/clash-compiler/issues/1721) * DEC transformation fails for functions applied to more than 62 arguments [#1669](https://github.com/clash-lang/clash-compiler/issues/1669) * Erroneous examples in BlockRam.File and ROM.File documentation [#1608](https://github.com/clash-lang/clash-compiler/issues/1608) * Blackboxes of `Clash.Sized.Vector` functions error on vectors containing `Clocks`, `Reset`, or `Enable` [#1606](https://github.com/clash-lang/clash-compiler/issues/1606) * `Clash.Signal.Delayed.delayI` cannot be reset, the `HiddenReset` constraint was unintentional. Asserting its reset has never worked. Removed the constraint [#1739](https://github.com/clash-lang/clash-compiler/pull/1739). * Annotate attributes cannot use type families [#1742](https://github.com/clash-lang/clash-compiler/issues/1742) Changed: * `Clash.Prelude.ROM.File.romFile` now takes an `Enum addr => addr` as address argument, making it actually useful. [#407](https://github.com/clash-lang/clash-compiler/issues/407) ## 1.4.0 *March 12th 2021* Highlighted changes (repeated in other categories): * Clash no longer disables the monomorphism restriction. See [#1270](https://github.com/clash-lang/clash-compiler/issues/1270), and mentioned issues, as to why. This can cause, among other things, certain eta-reduced descriptions of sequential circuits to no longer type-check. See [#1349](https://github.com/clash-lang/clash-compiler/pull/1349) for code hints on what kind of changes to make to your own code in case it no longer type-checks due to this change. * Type arguments of `Clash.Sized.Vector.fold` swapped: before `forall a n . (a -> a -> a) -> Vec (n+1) a -> a`, after `forall n a . (a -> a -> a) -> Vec (n+1) a`. This makes it easier to use `fold` in a `1 <= n` context so you can "simply" do `fold @(n-1)` * `Fixed` now obeys the laws for `Enum` as set out in the Haskell Report, and it is now consistent with the documentation for the `Enum` class on Hackage. As `Fixed` is also `Bounded`, the rule in the Report that `succ maxBound` and `pred minBound` should result in a runtime error is interpreted as meaning that `succ` and `pred` result in a runtime error whenever the result cannot be represented, not merely for `minBound` and `maxBound` alone. * Primitives should now be stored in `*.primitives` files instead of `*.json`. While primitive files very much look like JSON files, they're not actually spec complaint as they use newlines in strings. This has recently been brought to our attention by Aeson fixing an oversight in their parser implementation. We've therefore decided to rename the extension to prevent confusion. Fixed: * Result of `Clash.Class.Exp.(^)` has enough bits in order to deal with `x^0`. * Resizes to `Signed 0` (e.g., `resize @(Signed n) @(Signed 0)`) don't throw an error anymore * `satMul` now correctly handles arguments of type `Index 2` * `Clash.Explicit.Reset.resetSynchronizer` now synchronizes on synchronous domains too [#1567](https://github.com/clash-lang/clash-compiler/pull/1567). * `Clash.Explicit.Reset.convertReset`: now converts synchronous domains too, if necessary [#1567](https://github.com/clash-lang/clash-compiler/pull/1567). * `inlineWorkFree` now never inlines a topentity. It previously only respected this invariant in one of the two cases [#1587](https://github.com/clash-lang/clash-compiler/pull/1587). * Clash now reduces recursive type families [#1591](https://github.com/clash-lang/clash-compiler/issues/1591) * Primitive template warning is now retained when a `PrimitiveGuard` annotation is present [#1625](https://github.com/clash-lang/clash-compiler/issues/1625) * `signum` and `RealFrac` for `Fixed` now give the correct results. * Fixed a memory leak in register when used on asynchronous domains. Although the memory leak has always been there, it was only triggered on asserted resets. These periods are typically short, hence typically unnoticable. * `createDomain` will not override user definitions of types, helping users who strive for complete documentation coverage [#1674] https://github.com/clash-lang/clash-compiler/issues/1674 * `fromSNat` is now properly constrained [#1692](https://github.com/clash-lang/clash-compiler/issues/1692) * As part of an internal overhaul on netlist identifier generation [#1265](https://github.com/clash-lang/clash-compiler/pull/1265): * Clash no longer produces "name conflicts" between basic and extended identifiers. I.e., `\x\` and `x` are now considered the same variable in VHDL (likewise for other HDLs). Although the VHDL spec considers them distinct variables, some HDL tools - like Quartus - don't. * Capitalization of Haskell names are now preserved in VHDL. Note that VHDL is a case insensitive languages, so there are measures in place to prevent Clash from generating both `Foo` and `fOO`. This used to be handled by promoting every capitalized identifier to an extended one and wasn't handled for basic ones. * Names generated for testbenches can no longer cause collisions with previously generated entities. * Names generated for components can no longer cause collisions with user specified top entity names. * For (System)Verilog, variables can no longer cause collisions with (to be) generated entity names. * HO blackboxes can no longer cause collisions with identifiers declared in their surrounding architecture block. Changed: * Treat enable lines specially in generated HDL [#1171](https://github.com/clash-lang/clash-compiler/issues/1171) * `Signed`, `Unsigned`, `SFixed`, and `UFixed` now correctly implement the `Enum` law specifying that the predecessor of `minBound` and the successor of `maxBound` should result in an error [#1495](https://github.com/clash-lang/clash-compiler/pull/1495). * `Fixed` now obeys the laws for `Enum` as set out in the Haskell Report, and it is now consistent with the documentation for the `Enum` class on Hackage. As `Fixed` is also `Bounded`, the rule in the Report that `succ maxBound` and `pred minBound` should result in a runtime error is interpreted as meaning that `succ` and `pred` result in a runtime error whenever the result cannot be represented, not merely for `minBound` and `maxBound` alone. * Type arguments of `Clash.Sized.Vector.fold` swapped: before `forall a n . (a -> a -> a) -> Vec (n+1) a -> a`, after `forall n a . (a -> a -> a) -> Vec (n+1) a`. This makes it easier to use `fold` in a `1 <= n` context so you can "simply" do `fold @(n-1)` * Moved `Clash.Core.Evaluator` into `Clash.GHC` and provided generic interface in `Clash.Core.Evalautor.Types`. This removes all GHC specific code from the evaluator in clash-lib. * Clash no longer disables the monomorphism restriction. See [#1270](https://github.com/clash-lang/clash-compiler/issues/1270), and mentioned issues, as to why. This can cause, among other things, certain eta-reduced descriptions of sequential circuits to no longer type-check. See [#1349](https://github.com/clash-lang/clash-compiler/pull/1349) for code hints on what kind of changes to make to your own code in case it no longer type-checks due to this change. * Clash now generates SDC files for each topentity with clock inputs * `deepErrorX` is now equal to `undefined#`, which means that instead of the whole BitVector being undefined, its individual bits are. This makes sure bit operations are possible on it. [#1532](https://github.com/clash-lang/clash-compiler/pull/1532) * From GHC 9.0.1 onwards the following types: `BiSignalOut`, `Index`, `Signed`, `Unsigned`, `File`, `Ref`, and `SimIO` are all encoded as `data` instead of `newtype` to work around an [issue](https://github.com/clash-lang/clash-compiler/pull/1624#discussion_r558333461) where the Clash compiler can no longer recognize primitives over these types. This means you can no longer use `Data.Coerce.coerce` to coerce between these types and their underlying representation. * Signals on different domains used to be coercable because the domain had a type role "phantom". This has been changed to "nominal" to prevent accidental, unsafe coercions. [#1640](https://github.com/clash-lang/clash-compiler/pull/1640) * Size parameters on types in Clash.Sized.Internal.* are now nominal to prevent unsafe coercions. [#1640](https://github.com/clash-lang/clash-compiler/pull/1640) * `hzToPeriod` now takes a `Ratio Natural` rather than a `Double`. It rounds slightly differently, leading to more intuitive results and satisfying the requested change in [#1253](https://github.com/clash-lang/clash-compiler/issues/1253). Clash expresses clock rate as the clock period in picoseconds. If picosecond precision is required for your design, please use the exact method of specifying a clock period rather than a clock frequency. * `periodToHz` now results in a `Ratio Natural` * `createDomain` doesn't override existing definitions anymore, fixing [#1674](https://github.com/clash-lang/clash-compiler/issues/1674) * Manifest files are now stored as `clash-manifest.json` * Manifest files now store hashes of the files Clash generated. This allows Clash to detect user changes on a next run, preventing accidental data loss. * Primitives should now be stored in `*.primitives` files. While primitive files very much look like JSON files, they're not actually spec complaint as they use newlines in strings. This has recently been brought to our attention by Aeson fixing an oversight in their parser implementation. We've therefore decided to rename the extension to prevent confusion. * Each binder marked with a `Synthesize` or `TestBench` pragma will be put in its own directory under their fully qualified Haskell name. For example, two binders `foo` and `bar` in module `A` will be synthesized in `A.foo` and `A.bar`. * Clash will no longer generate vhdl, verilog, or systemverilog subdirectories when using `-fclash-hdldir`. * `Data.Kind.Type` is now exported from `Clash.Prelude` [#1700](https://github.com/clash-lang/clash-compiler/issues/1700) Added: * Support for GHC 9.0.1 * `Clash.Signal.sameDomain`: Allows user obtain evidence whether two domains are equal. * `xToErrorCtx`: makes it easier to track the origin of `XException` where `pack` would hide them [#1461](https://github.com/clash-lang/clash-compiler/pull/1461) * Additional field with synthesis attributes added to `InstDecl` in `Clash.Netlist.Types` [#1482](https://github.com/clash-lang/clash-compiler/pull/1482) * `Data.Ix.Ix` instances for `Signed`, `Unsigned`, and `Index` [#1481](https://github.com/clash-lang/clash-compiler/pull/1481) [#1631](https://github.com/clash-lang/clash-compiler/pull/1631) * Added `nameHint` to allow explicitly naming terms, e.g. `Signal`s. * Checked versions of `resize`, `truncateB`, and `fromIntegral`. Depending on the type `resize`, `truncateB`, and `fromIntegral` either yield an `XException` or silently perform wrap-around if its argument does not fit in the resulting type's bounds. The added functions check the bound condition and fail with an error call if the condition is violated. They do not affect HDL generation. [#1491](https://github.com/clash-lang/clash-compiler/pull/1491) * `HasBiSignalDefault`: constraint to Clash.Signal.BiSignal, `pullUpMode` gives access to the pull-up mode. [#1498](https://github.com/clash-lang/clash-compiler/pull/1498) * Match patterns to bitPattern [#1545](https://github.com/clash-lang/clash-compiler/pull/1545) * Non TH `fromList` and `unsafeFromList` for Vec. These functions allow Vectors to be created from a list without needing to use template haskell, which is not always desirable. The unsafe version of the function does not compare the length of the list to the desired length of the vector, either truncating or padding with undefined if the lengths differ. * `Clash.Explicit.Reset.resetGlitchFilter`: filters glitchy reset signals. Useful when your reset signal is connected to sensitive actuators. * Clash can now generate EDAM for using Edalize. This generates edam.py files in all top entities with the configuration for building that entity. Users still need to edit this file to specify the EDA tool to use, and if necessary the device to target (for Quartus, Vivado etc.). [#1386](https://github.com/clash-lang/clash-compiler/issues/1386) * `-fclash-aggressive-x-optimization-blackboxes`: when enabled primitives can detect undefined values and change their behavior accordingly. For example, if `register` is used in combination with an undefined reset value, it will leave out the reset logic entirely. Related issue: [#1506](https://github.com/clash-lang/clash-compiler/issues/1506). * Automaton-based interface to simulation, to allow interleaving of cyle-by-cycle simulation and external effects [#1261](https://github.com/clash-lang/clash-compiler/pull/1261) New internal features: * `constructProduct` and `deconstructProduct` in `Clash.Primitives.DSL`. Like `tuple` and `untuple`, but on arbitrary product types. * Support for multi result primitives. Primitives can now assign their results to multiple variables. This can help to work around synthesis tools limits in some cases. See [#1560](https://github.com/clash-lang/clash-compiler/pull/1560). * Added a rule for missing `Int` comparisons in `GHC.Classes` in the compile time evaluator. [#1648](https://github.com/clash-lang/clash-compiler/issues/1648) * Clash now creates a mapping from domain names to configurations in `LoadModules`. [#1405](https://github.com/clash-lang/clash-compiler/pull/1405) * The convenience functions in `Clash.Primitives.DSL` now take a list of HDLs, instead of just one. * `Clash.Netlist.Id` overhauls the way identifiers are generated in the Netlist part of Clash. * Added `defaultWithAction` to Clash-as-a-library API to work around/fix issues such as [#1686](https://github.com/clash-lang/clash-compiler/issues/1686) * Manifest files now list files and components in an reverse topological order. This means it can be used when calling EDA tooling without causing compilation issues. Deprecated: * `Clash.Prelude.DataFlow`: see [#1490](https://github.com/clash-lang/clash-compiler/pull/1490). In time, its functionality will be replaced by [clash-protocols](https://github.com/clash-lang/clash-protocols). Removed: * The deprecated function `freqCalc` has been removed. ## 1.2.5 *November 9th 2020* Fixed: * The normalizeType function now fully normalizes types which require calls to reduceTypeFamily [#1469](https://github.com/clash-lang/clash-compiler/issues/1469) * `flogBaseSNat`, `clogBaseSNat` and `logBaseSNat` primitives are now implemented correctly.Previously these primitives would be left unevaluated causing issues as demonstrated in [#1479](https://github.com/clash-lang/clash-compiler/issues/1469) * Specializing on functions with type family arguments no longer fails [#1477](https://github.com/clash-lang/clash-compiler/issues/1477) * `satSucc`, `satPred` correctly handle "small types" such as `Index 1`. * `msb` no longer fails on values larger than 64 bits * `undefined` can now be used as a reset value of `autoReg@Maybe` [#1507](https://github.com/clash-lang/clash-compiler/issues/1507) * Signal's `fmap` is now less strict, preventing infinite loops in very specific situations. See [#1521](https://github.com/clash-lang/clash-compiler/issues/1521) * Clash now uses correct function names in manifest and sdc files [#1533](https://github.com/clash-lang/clash-compiler/issues/1533) * Clash no longer produces erroneous HDL in very specific cases [#1536](https://github.com/clash-lang/clash-compiler/issues/1536) * Usage of `fold` inside other HO primitives (e.g., `map`) no longer fails [#1524](https://github.com/clash-lang/clash-compiler/issues/1524) Changed: * Due to difficulties using `resetSynchronizer` we've decided to make this function always insert a synchronizer. See: [#1528](https://github.com/clash-lang/clash-compiler/issues/1528). ## 1.2.4 *July 28th 2020* * Changed: * Relaxed upper bound versions of `aeson` and `dlist`, in preparation for the new Stack LTS. * Reverted changes to primitive definitions for 'zipWith', 'map', 'foldr', and 'init' introduced in 1.2.2. They have shown to cause problems in very specific circumstances. ## 1.2.3 *July 11th 2020* * Changed: * Upgrade to nixos 20.03. Nix and snap users will now use packages present in 20.03. * Added: * `instance Monoid a => Monoid (Vec n a)` * `instance Text.Printf(Index)` * `instance Text.Printf(Signed)` * `instance Text.Printf(Unsigned)` * Fixed: * Clash renders incorrect VHDL when GHCs Worker/Wrapper transformation is enabled [#1402](https://github.com/clash-lang/clash-compiler/issues/1402) * Minor faults in generated HDL when using annotations from `Clash.Annotations.SynthesisAttributes` * Cabal installed through Snap (`clash.cabal`) can now access the internet to fetch pacakges. [#1411]https://github.com/clash-lang/clash-compiler/issues/1411 * Generated QSys file for `altpll` incompatible with Quartus CLI (did work in Quartus GUI) * Clash no longer uses component names that clash with identifiers imported from: * IEEE.STD_LOGIC_1164.all * IEEE.NUMERIC_STD.all * IEEE.MATH_REAL.all * std.textio.all when generating VHDL. See https://github.com/clash-lang/clash-compiler/issues/1439. ## 1.2.2 *June 12th 2020* * Changed: * The hardwired functions to unroll primitive definitions for 'zipWith', 'map', 'foldr', and 'init' have been changed to only unroll a single step, whereas they would previously unroll the whole definition in one step. This allows Clash to take advantage of the lazy nature of these functions, in turn speeding up compilation speeds significantly in some cases. Part of [PR 1354](https://github.com/clash-lang/clash-compiler/pull/1354). * Added: * Support for GHC 8.10 * Ability to load designs from precompiled modules (i.e., stored in a package database). See [#1172](https://github.com/clash-lang/clash-compiler/pull/1172) * Support for '-main-is' when used with `--vhdl`, `--verilog`, or `--systemverilog` * A partial instance for `NFDataX (Signal domain a)` * Fixed: * Clash's evaluator now inlines work free definitions, preventing [situations where it would otherwise get stuck in an infinite loop](https://github.com/clash-lang/clash-compiler/pull/1354#issuecomment-635430374) * `caseCon` doesn't apply type-substitution correctly [#1340](https://github.com/clash-lang/clash-compiler/issues/1340) * Clash generates illegal SystemVerilog slice [#1313](https://github.com/clash-lang/clash-compiler/issues/1313) * Fix result type of head and tail Verilog blackboxes [#1351](https://github.com/clash-lang/clash-compiler/issues/1351) * Certain recursive let-expressions in side a alternatives of a case-expression throw the Clash compiler into an infinite loop [#1316](https://github.com/clash-lang/clash-compiler/issues/1316) * Fixes issue with one of Clash's transformations, `inlineCleanup`, introducing free variables [#1337](https://github.com/clash-lang/clash-compiler/issues/1337) * Fails to propagate type information of existential type [#1310](https://github.com/clash-lang/clash-compiler/issues/1310) * Certain case-expressions throw the Clash compiler into an infinite loop [#1320](https://github.com/clash-lang/clash-compiler/issues/1320) * Added blackbox implementation for 'Clash.Sized.Vector.iterateI', hence making it usable as a register reset value [#1240](https://github.com/clash-lang/clash-compiler/issues/1240) * `iterate` and `iterateI` can now be used in reset values [#1240](https://github.com/clash-lang/clash-compiler/issues/1240) * Prim evaluation fails on undefined arguments [#1297](https://github.com/clash-lang/clash-compiler/issues/1297) * Missing re-indexing in (Un)Signed fromSLV conversion [#1292](https://github.com/clash-lang/clash-compiler/issues/1292) * VHDL: generate a type qualification inside ~TOBV, fixes [#1360](https://github.com/clash-lang/clash-compiler/issues/1360) ## 1.2.1 *April 23rd 2020* * Changed: * Treat `Signed 0`, `Unsigned 0`, `Index 1`, `BitVector 0` as unit. In effect this means that 'minBound' and 'maxBound' return 0, whereas previously they might crash [#1183](https://github.com/clash-lang/clash-compiler/issues/1183) * Infix use of `deepseqX` is now right-associative * Added: * Add 'natToInteger', 'natToNatural', and 'natToNum'. Similar to 'snatTo*', but works solely on a type argument instead of an SNat. * `Clash.Sized.Vector.unfoldr` and `Clash.Sized.Vector.unfoldrI` to construct vectors from a seed value * Added NFDataX instances for `Data.Monoid.{First,Last}` * Fixed: * The Verilog backend can now deal with non-contiguous ranges in custom bit-representations. * Synthesizing BitPack instances for type with phantom parameter fails [#1242](https://github.com/clash-lang/clash-compiler/issues/1242) * Synthesis of `fromBNat (toBNat d5)` failed due to `unsafeCoerce` coercing from `Any` * Memory leak in register primitives [#1256](https://github.com/clash-lang/clash-compiler/issues/1256) * Illegal VHDL slice when projecting nested SOP type [#1254](https://github.com/clash-lang/clash-compiler/issues/1254) * Vivado VHDL code path (`-fclash-hdlsyn Vivado`) generates illegal VHDL [#1264](https://github.com/clash-lang/clash-compiler/issues/1264) ## 1.2.0 *March 5th 2020* As promised when releasing 1.0, we've tried our best to keep the API stable. We think most designs will continue to compile with this new version, although special care needs to be taken when using: * Use inline blackboxes. Instead of taking a single HDL, inline primitives now take multiple. For example, `InlinePrimitive VHDL ".."` must now be written as `InlinePrimitive [VHDL] ".."`. * Use the `Enum` instance for `BitVector`, `Index`, `Signed`, or `Unsigned`, as they now respect their `maxBound`. See [#1089](https://github.com/clash-lang/clash-compiler/issues/1089). On top of that, we've added a number of new features: * `makeTopEntity`: Template Haskell function for generating TopEntity annotations. See [the documentation on Haddock](http://hackage.haskell.org/package/clash-prelude-1.2.0/docs/Clash-Annotations-TopEntity.html) for more information. * `Clash.Explicit.SimIO`: ((System)Verilog only) I/O actions that can be translated to HDL I/O. See [the documentation on Haddock](http://hackage.haskell.org/package/clash-prelude-1.2.0/docs/Clash-Explicit-SimIO.html) for more information. * `Clash.Class.AutoReg`: A smart register that improves the chances of synthesis tools inferring clock-gated registers, when used. See [the documentation on Haddock](http://hackage.haskell.org/package/clash-prelude-1.2.0/docs/Clash-Class-AutoReg.html) for more information. The full list of changes follows. Happy hacking! * New features (API): * `Clash.Class.Parity` type class replaces Prelude `odd` and `even` functions due to assumptions that don't hold for Clash specific numerical types, see [#970](https://github.com/clash-lang/clash-compiler/pull/970). * `NFDataX.ensureSpine`, see [#748](https://github.com/clash-lang/clash-compiler/pull/803) * `makeTopEntity` Template Haskell function for generating TopEntity annotations intended to cover the majority of use cases. Generation failures should either result in an explicit error, or a valid annotation of an empty `PortProduct`. Any discrepancy between the _shape_ of generated annotations and the _shape_ of the Clash compiler is a bug. See [#795](https://github.com/clash-lang/clash-compiler/pull/795). Known limitations: * Type application (excluding `Signal`s and `:::`) is best effort: * Data types with type parameters will work if the generator can discover a single relevant constructor after attempting type application. * Arbitrary explicit clock/reset/enables are supported, but only a single `HiddenClockResetEnable` constraint is supported. * Data/type family support is best effort. * Added `Bundle ((f :*: g) a)` instance * Added `NFDataX CUShort` instance * Clash's internal type family solver now recognizes `AppendSymbol` and `CmpSymbol` * Added `Clash.Magic.suffixNameFromNat`: can be used in cases where `suffixName` is too slow * Added `Clash.Class.AutoReg`. Improves the chances of synthesis tools inferring clock-gated registers, when used. See [#873](https://github.com/clash-lang/clash-compiler/pull/873). * `Clash.Magic.suffixNameP`, `Clash.Magic.suffixNameFromNatP`: enable prefixing of name suffixes * Added `Clash.Magic.noDeDup`: can be used to instruct Clash to /not/ share a function between multiple branches * A `BitPack a` constraint now implies a `KnownNat (BitSize a)` constraint, so you won't have to add it manually anymore. See [#942](https://github.com/clash-lang/clash-compiler/pull/942). * `Clash.Explicit.SimIO`: ((System)Verilog only) I/O actions that can be translated to HDL I/O; useful for generated test benches. * Export `Clash.Explicit.Testbench.assertBitVector` [#888](https://github.com/clash-lang/clash-compiler/pull/888/files) * Add `Clash.Prelude.Testbench.assertBitVector` to achieve feature parity with `Clash.Explicit.Testbench`. [#891](https://github.com/clash-lang/clash-compiler/pull/891/files) * Add `Clash.XException.NFDataX.ensureSpine` [#803](https://github.com/clash-lang/clash-compiler/pull/803) * Add `Clash.Class.BitPack.bitCoerceMap` [#798](https://github.com/clash-lang/clash-compiler/pull/798) * Add `Clash.Magic.deDup`: instruct Clash to force sharing an operator between multiple branches of a case-expression * `InlinePrimitive` can now support multiple backends simultaneously [#425](https://github.com/clash-lang/clash-compiler/issues/425) * Add `Clash.XException.hwSeqX`: render declarations of an argument, but don't assign it to a result signal * Add `Clash.Signal.Bundle.TaggedEmptyTuple`: allows users to emulate the pre-1.0 behavior of "Bundle ()". See [#1100](https://github.com/clash-lang/clash-compiler/pull/1100) * New features (Compiler): * [#961](https://github.com/clash-lang/clash-compiler/pull/961): Show `-fclash-*` Options in `clash --show-options` * New internal features: * [#918](https://github.com/clash-lang/clash-compiler/pull/935): Add X-Optimization to normalization passes (-fclash-aggressive-x-optimization) * [#821](https://github.com/clash-lang/clash-compiler/pull/821): Add `DebugTry`: print name of all tried transformations, even if they didn't succeed * [#856](https://github.com/clash-lang/clash-compiler/pull/856): Add `-fclash-debug-transformations`: only print debug info for specific transformations * [#911](https://github.com/clash-lang/clash-compiler/pull/911): Add 'RenderVoid' option to blackboxes * [#958](https://github.com/clash-lang/clash-compiler/pull/958): Prefix names of inlined functions * [#947](https://github.com/clash-lang/clash-compiler/pull/947): Add "Clash.Core.TermLiteral" * [#887](https://github.com/clash-lang/clash-compiler/pull/887): Show nicer error messages when failing in TH code * [#884](https://github.com/clash-lang/clash-compiler/pull/884): Teach reduceTypeFamily about AppendSymbol and CmpSymbol * [#784](https://github.com/clash-lang/clash-compiler/pull/784): Print whether `Id` is global or local in ppr output * [#781](https://github.com/clash-lang/clash-compiler/pull/781): Use naming contexts in register names * [#1061](https://github.com/clash-lang/clash-compiler/pull/1061): Add 'usedArguments' to BlackBoxHaskell blackboxes * Fixes issues: * [#974](https://github.com/clash-lang/clash-compiler/issues/974): Fix indirect shadowing in `reduceNonRepPrim` * [#964](https://github.com/clash-lang/clash-compiler/issues/964): SaturatingNum instance of `Index` now behaves correctly when the size of the index overflows an `Int`. * [#810](https://github.com/clash-lang/clash-compiler/issues/810): Verilog backend now correctly specifies type of `BitVector 1` * [#811](https://github.com/clash-lang/clash-compiler/issues/811): Improve module load behavior in clashi * [#439](https://github.com/clash-lang/clash-compiler/issues/439): Template Haskell splices and TopEntity annotations can now be used in clashi * [#662](https://github.com/clash-lang/clash-compiler/issues/662): Clash will now constant specialize partially constant constructs * [#700](https://github.com/clash-lang/clash-compiler/issues/700): Check work content of expression in cast before warning users. Should eliminate a lot of (superfluous) warnings about "specializing on non work-free cast"s. * [#837](https://github.com/clash-lang/clash-compiler/issues/837): Blackboxes will now report clearer error messages if they're given unexpected arguments. * [#869](https://github.com/clash-lang/clash-compiler/issues/869): PLL is no longer duplicated in Blinker.hs example * [#749](https://github.com/clash-lang/clash-compiler/issues/749): Clash's dependencies now all work with GHC 8.8, allowing `clash-{prelude,lib,ghc}` to be compiled from Hackage soon. * [#871](https://github.com/clash-lang/clash-compiler/issues/871): RTree Bundle instance is now properly lazy * [#895](https://github.com/clash-lang/clash-compiler/issues/895): VHDL type error when generating `Maybe (Vec 2 (Signed 8), Index 1)` * [#880](https://github.com/clash-lang/clash-compiler/issues/880): Custom bit representations can now be used on product types too * [#976](https://github.com/clash-lang/clash-compiler/issues/976): Prevent shadowing in Clash's core evaluator * [#1007](https://github.com/clash-lang/clash-compiler/issues/1007): Can't translate domain tagType.Errors.IfStuck... * [#967](https://github.com/clash-lang/clash-compiler/issues/967): Naming registers disconnects their output * [#990](https://github.com/clash-lang/clash-compiler/issues/990): Internal shadowing bug results in incorrect HDL * [#945](https://github.com/clash-lang/clash-compiler/issues/945): Rewrite rules for Vec Applicative Functor * [#919](https://github.com/clash-lang/clash-compiler/issues/919): Clash generating invalid Verilog after Vec operations #919 * [#996](https://github.com/clash-lang/clash-compiler/issues/996): Ambiguous clock when using `ClearOnReset` and `resetGen` together * [#701](https://github.com/clash-lang/clash-compiler/issues/701): Unexpected behaviour with the `Synthesize` annotation * [#694](https://github.com/clash-lang/clash-compiler/issues/694): Custom bit representation error only with VHDL * [#347](https://github.com/clash-lang/clash-compiler/issues/347): topEntity synthesis fails due to insufficient type-level normalisation * [#626](https://github.com/clash-lang/clash-compiler/issues/626): Missing Clash.Explicit.Prelude definitions * [#960](https://github.com/clash-lang/clash-compiler/issues/626): Blackbox Error Caused by Simple map * [#1012](https://github.com/clash-lang/clash-compiler/issues/1012): Case-let doesn't look through ticks * [#430](https://github.com/clash-lang/clash-compiler/issues/430): Issue warning when not compiled with `executable-dynamic: True` * [#374](https://github.com/clash-lang/clash-compiler/issues/1012): Clash.Sized.Fixed: fromInteger and fromRational don't saturate correctly * [#836](https://github.com/clash-lang/clash-compiler/issues/836): Generate warning when `toInteger` blackbox drops MSBs * [#1019](https://github.com/clash-lang/clash-compiler/issues/1019): Clash breaks on constants defined in terms of `GHC.Natural.gcdNatural` * [#1025](https://github.com/clash-lang/clash-compiler/issues/1025): `inlineCleanup`will not produce empty letrecs anymore * [#1030](https://github.com/clash-lang/clash-compiler/issues/1030): `bindConstantVar` will bind (workfree) constructs * [#1034](https://github.com/clash-lang/clash-compiler/issues/1034): Error (10137): object "pllLock" on lhs must have a variable data type * [#1046](https://github.com/clash-lang/clash-compiler/issues/1046): Don't confuse term/type namespaces in 'lookupIdSubst' * [#1041](https://github.com/clash-lang/clash-compiler/issues/1041): Nested product types incorrectly decomposed into ports * [#1058](https://github.com/clash-lang/clash-compiler/issues/1058): Prevent substitution warning when using type equalities in top entities * [#1033](https://github.com/clash-lang/clash-compiler/issues/1033): Fix issue where Clash breaks when using Clock/Reset/Enable in product types in combination with Synthesize annotations * [#1075](https://github.com/clash-lang/clash-compiler/issues/1075): Removed superfluous constraints on 'maybeX' and 'maybeIsX' * [#1085](https://github.com/clash-lang/clash-compiler/issues/1085): Suggest exporting topentities if they can't be found in a module * [#1065](https://github.com/clash-lang/clash-compiler/pull/1065): Report polymorphic topEntities as errors * [#1089](https://github.com/clash-lang/clash-compiler/issues/1089): Respect maxBound in Enum instances for BitVector,Index,Signed,Unsigned * Fixes without issue reports: * Fix bug in `rnfX` defined for `Down` ([baef30e](https://github.com/clash-lang/clash-compiler/commit/baef30eae03dc02ba847ffbb8fae7f365c5287c2)) * Render numbers inside gensym ([bc76f0f](https://github.com/clash-lang/clash-compiler/commit/bc76f0f1934fd6e6ed9c33bcf950dae21e2f7903)) * Report blackbox name when encountering an error in 'setSym' ([#858](https://github.com/clash-lang/clash-compiler/pull/858)) * Fix blackbox issues causing Clash to generate invalid HDL ([#865](https://github.com/clash-lang/clash-compiler/pull/865)) * Treat types with a zero-width custom bit representation like other zero-width constructs ([#874](https://github.com/clash-lang/clash-compiler/pull/874)) * TH code for auto deriving bit representations now produces nicer error messages ([7190793](https://github.com/clash-lang/clash-compiler/commit/7190793928545f85157f9b8d4b8ec2edb2cd8a26)) * Adds '--enable-shared-executables' for nix builds; this should make Clash run _much_ faster ([#894](https://github.com/clash-lang/clash-compiler/pull/894)) * Custom bit representations can now mark fields as zero-width without crashing the compiler ([#898](https://github.com/clash-lang/clash-compiler/pull/898)) * Throw an error if there's data left to parse after successfully parsing a valid JSON construct ([#904](https://github.com/clash-lang/clash-compiler/pull/904)) * `Data.gfoldl` is now manually implemented, in turn fixing issues with `gshow` ([#933](https://github.com/clash-lang/clash-compiler/pull/933)) * Fix a number of issues with blackbox implementations ([#934](https://github.com/clash-lang/clash-compiler/pull/934)) * Don't inline registers with non-constant clock and reset ([#998](https://github.com/clash-lang/clash-compiler/pull/998)) * Inline let-binders called [dsN | N <- [1..]] ([#992](https://github.com/clash-lang/clash-compiler/pull/992)) * ClockGens use their name at the Haskell level [#827](https://github.com/clash-lang/clash-compiler/pull/827) * Render numbers inside gensym [#809](https://github.com/clash-lang/clash-compiler/pull/809) * Don't overwrite existing binders when specializing [#790](https://github.com/clash-lang/clash-compiler/pull/790) * Deshadow in 'caseCase' [#1067](https://github.com/clash-lang/clash-compiler/pull/1067) * Deshadow in 'caseLet' and 'nonRepANF' [#1071](https://github.com/clash-lang/clash-compiler/pull/1071) * Deprecations & removals: * Removed support for GHC 8.2 ([#842](https://github.com/clash-lang/clash-compiler/pull/842)) * Removed support for older cabal versions, only Cabal >=2.2 supported ([#851](https://github.com/clash-lang/clash-compiler/pull/851)) * Reset and Enable constructors are now only exported from Clash.Signal.Internal * [#986](https://github.com/clash-lang/clash-compiler/issues/986) Remove -fclash-allow-zero-width flag ## 1.0.0 *September 3rd 2019* * 10x - 50x faster compile times * New features: * API changes: check the migration guide at the end of `Clash.Tutorial` * All memory elements now have an (implicit) enable line; "Gated" clocks have been removed as the clock wasn't actually gated, but implemented as an enable line. * Circuit domains are now configurable in: * (old) The clock period * (new) Clock edge on which memory elements latch their inputs (rising edge or falling edge) * (new) Whether the reset port of a memory element is level sensitive asynchronous reset) or edge sensitive (synchronous reset) * (new) Whether the reset port of a memory element is active-high or active-low (negated reset) * (new) Whether memory element power on in a configurable/defined state (common on FPGAs) or in an undefined state (ASICs) * See the [blog post](https://clash-lang.org/blog/0005-synthesis-domain/) on this new feature * Data types can now be given custom bit-representations: http://hackage.haskell.org/package/clash-prelude/docs/Clash-Annotations-BitRepresentation.html * Annotate expressions with attributes that persist in the generated HDL, e.g. synthesis directives: http://hackage.haskell.org/package/clash-prelude/docs/Clash-Annotations-SynthesisAttributes.html * Control (System)Verilog module instance, and VHDL entity instantiation names in generated code: http://hackage.haskell.org/package/clash-prelude/docs/Clash-Magic.html * Much improved infrastructure for handling of unknown values: defined spine, but unknown leafs: http://hackage.haskell.org/package/clash-prelude/docs/Clash-XException.html#t:NFDataX * Experimental: Multiple hidden clocks. Can be enabled by compiling `clash-prelude` with `-fmultiple-hidden` * Experimental: Limited GADT support (pattern matching on vectors, or custom GADTs as longs as their usage can be statically removed; no support of recursive GADTs) * Experimental: Use regular Haskell functions to generate HDL black boxes for primitives (in an addition to existing string templates for HDL black boxes) See for example: http://hackage.haskell.org/package/clash-lib/docs/Clash-Primitives-Intel-ClockGen.html * Fixes issues: * [#316](https://github.com/clash-lang/clash-compiler/issues/316) * [#319](https://github.com/clash-lang/clash-compiler/issues/319) * [#323](https://github.com/clash-lang/clash-compiler/issues/323) * [#324](https://github.com/clash-lang/clash-compiler/issues/324) * [#329](https://github.com/clash-lang/clash-compiler/issues/329) * [#331](https://github.com/clash-lang/clash-compiler/issues/331) * [#332](https://github.com/clash-lang/clash-compiler/issues/332) * [#335](https://github.com/clash-lang/clash-compiler/issues/335) * [#348](https://github.com/clash-lang/clash-compiler/issues/348) * [#349](https://github.com/clash-lang/clash-compiler/issues/349) * [#350](https://github.com/clash-lang/clash-compiler/issues/350) * [#351](https://github.com/clash-lang/clash-compiler/issues/351) * [#352](https://github.com/clash-lang/clash-compiler/issues/352) * [#353](https://github.com/clash-lang/clash-compiler/issues/353) * [#358](https://github.com/clash-lang/clash-compiler/issues/358) * [#359](https://github.com/clash-lang/clash-compiler/issues/359) * [#363](https://github.com/clash-lang/clash-compiler/issues/363) * [#364](https://github.com/clash-lang/clash-compiler/issues/364) * [#365](https://github.com/clash-lang/clash-compiler/issues/365) * [#371](https://github.com/clash-lang/clash-compiler/issues/371) * [#372](https://github.com/clash-lang/clash-compiler/issues/372) * [#373](https://github.com/clash-lang/clash-compiler/issues/373) * [#378](https://github.com/clash-lang/clash-compiler/issues/378) * [#380](https://github.com/clash-lang/clash-compiler/issues/380) * [#381](https://github.com/clash-lang/clash-compiler/issues/381) * [#382](https://github.com/clash-lang/clash-compiler/issues/382) * [#383](https://github.com/clash-lang/clash-compiler/issues/383) * [#387](https://github.com/clash-lang/clash-compiler/issues/387) * [#393](https://github.com/clash-lang/clash-compiler/issues/393) * [#396](https://github.com/clash-lang/clash-compiler/issues/396) * [#398](https://github.com/clash-lang/clash-compiler/issues/398) * [#399](https://github.com/clash-lang/clash-compiler/issues/399) * [#401](https://github.com/clash-lang/clash-compiler/issues/401) * [#403](https://github.com/clash-lang/clash-compiler/issues/403) * [#407](https://github.com/clash-lang/clash-compiler/issues/407) * [#412](https://github.com/clash-lang/clash-compiler/issues/412) * [#413](https://github.com/clash-lang/clash-compiler/issues/413) * [#420](https://github.com/clash-lang/clash-compiler/issues/420) * [#422](https://github.com/clash-lang/clash-compiler/issues/422) * [#423](https://github.com/clash-lang/clash-compiler/issues/423) * [#424](https://github.com/clash-lang/clash-compiler/issues/424) * [#438](https://github.com/clash-lang/clash-compiler/issues/438) * [#450](https://github.com/clash-lang/clash-compiler/issues/450) * [#452](https://github.com/clash-lang/clash-compiler/issues/452) * [#455](https://github.com/clash-lang/clash-compiler/issues/455) * [#460](https://github.com/clash-lang/clash-compiler/issues/460) * [#461](https://github.com/clash-lang/clash-compiler/issues/461) * [#463](https://github.com/clash-lang/clash-compiler/issues/463) * [#468](https://github.com/clash-lang/clash-compiler/issues/468) * [#475](https://github.com/clash-lang/clash-compiler/issues/475) * [#476](https://github.com/clash-lang/clash-compiler/issues/476) * [#500](https://github.com/clash-lang/clash-compiler/issues/500) * [#507](https://github.com/clash-lang/clash-compiler/issues/507) * [#512](https://github.com/clash-lang/clash-compiler/issues/512) * [#516](https://github.com/clash-lang/clash-compiler/issues/516) * [#517](https://github.com/clash-lang/clash-compiler/issues/517) * [#526](https://github.com/clash-lang/clash-compiler/issues/526) * [#556](https://github.com/clash-lang/clash-compiler/issues/556) * [#560](https://github.com/clash-lang/clash-compiler/issues/560) * [#566](https://github.com/clash-lang/clash-compiler/issues/566) * [#567](https://github.com/clash-lang/clash-compiler/issues/567) * [#569](https://github.com/clash-lang/clash-compiler/issues/569) * [#573](https://github.com/clash-lang/clash-compiler/issues/573) * [#575](https://github.com/clash-lang/clash-compiler/issues/575) * [#581](https://github.com/clash-lang/clash-compiler/issues/581) * [#582](https://github.com/clash-lang/clash-compiler/issues/582) * [#586](https://github.com/clash-lang/clash-compiler/issues/586) * [#588](https://github.com/clash-lang/clash-compiler/issues/588) * [#591](https://github.com/clash-lang/clash-compiler/issues/591) * [#596](https://github.com/clash-lang/clash-compiler/issues/596) * [#601](https://github.com/clash-lang/clash-compiler/issues/601) * [#607](https://github.com/clash-lang/clash-compiler/issues/607) * [#629](https://github.com/clash-lang/clash-compiler/issues/629) * [#637](https://github.com/clash-lang/clash-compiler/issues/637) * [#644](https://github.com/clash-lang/clash-compiler/issues/644) * [#647](https://github.com/clash-lang/clash-compiler/issues/647) * [#661](https://github.com/clash-lang/clash-compiler/issues/661) * [#668](https://github.com/clash-lang/clash-compiler/issues/668) * [#677](https://github.com/clash-lang/clash-compiler/issues/677) * [#678](https://github.com/clash-lang/clash-compiler/issues/678) * [#682](https://github.com/clash-lang/clash-compiler/issues/682) * [#691](https://github.com/clash-lang/clash-compiler/issues/691) * [#703](https://github.com/clash-lang/clash-compiler/issues/703) * [#713](https://github.com/clash-lang/clash-compiler/issues/713) * [#715](https://github.com/clash-lang/clash-compiler/issues/715) * [#727](https://github.com/clash-lang/clash-compiler/issues/727) * [#730](https://github.com/clash-lang/clash-compiler/issues/730) * [#736](https://github.com/clash-lang/clash-compiler/issues/736) * [#738](https://github.com/clash-lang/clash-compiler/issues/738) ## 0.99.3 *July 28th 2018* * Fixes bugs: * Evaluator recognizes `Bit` literals [#329](https://github.com/clash-lang/clash-compiler/issues/329) * Use existential type-variables in context of GADT pattern match * Do not create zero-bit temporary variables in generated HDL * Use correct arguments in nested primitives [#323](https://github.com/clash-lang/clash-compiler/issues/329) * Zero-constructor data type needs 0 bits [#238](https://github.com/clash-lang/clash-compiler/issues/238) * Create empty component when result needs 0 bits * Evaluator performs BigNat arithmetic * Features: * Bundle and BitPack instances up to and including 62-tuples * Handle undefined writes to RAM properly * Handle undefined clock enables properly ## 0.99.1 *May 12th 2018* * Allow `~NAME[N]` tag inside `~GENSYM[X]` * Support HDL record selector generation [#313](https://github.com/clash-lang/clash-compiler/pull/313) * `InlinePrimitive` support: specify HDL primitives inline with Haskell code * Support for `ghc-typelits-natnormalise-0.6.1` * `Lift` instances for `TopEntity` and `PortName` * `InlinePrimitive` support: specify HDL primitives inline with Haskell code ## 0.99 *March 31st 2018* * New features: * Major API overhaul: check the migration guide at the end of `Clash.Tutorial` * New features: * Explicit clock and reset arguments * Rename `CLaSH` to `Clash` * Implicit/`Hidden` clock and reset arguments using a combination of `reflection` and `ImplicitParams`. * Large overhaul of `TopEntity` annotations * PLL and other clock sources can now be instantiated using regular functions: `Clash.Intel.ClockGen` and `Clash.Xilinx.ClockGen`. * DDR registers: * Generic/ASIC: `Clash.Explicit.DDR` * Intel: `Clash.Intel.DDR` * Xilinx: `Clash.Intel.Xilinx` * `Bit` is now a `newtype` instead of a `type` synonym and will be mapped to a HDL scalar instead of an array of one (e.g `std_logic` instead of `std_logic_vector(0 downto 0)`) * Hierarchies with multiple synthesisable boundaries by allowing more than one function in scope to have a `Synthesize` annotation. * Local caching of functions with a `Synthesize` annotation * `Bit` type is mapped to a HDL scalar type (e.g. `std_logic` in VHDL) * Improved name preservation * Zero-bit values are filtered out of the generated HDL * Improved compile-time computation * Many bug fixes ## Older versions Check out: * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-prelude/CHANGELOG.md * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-lib/CHANGELOG.md * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-ghc/CHANGELOG.md clash-lib-1.8.1/LICENSE0000644000000000000000000000260307346545000012556 0ustar0000000000000000Copyright (c) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2019, QBayLogic B.V., Google Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. clash-lib-1.8.1/README.md0000755000000000000000000000230607346545000013033 0ustar0000000000000000# `clash-lib` - Clash compiler, as a library * See the LICENSE file for license and copyright details # Clash - A functional hardware description language Clash is a functional hardware description language that borrows both its syntax and semantics from the functional programming language Haskell. The Clash compiler transforms these high-level descriptions to low-level synthesizable VHDL, Verilog, or SystemVerilog. Features of Clash: * 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. * Higher-order functions, with type inference, result in designs that are fully parametric by default. * Synchronous sequential circuit design based on streams of values, called `Signal`s, lead to natural descriptions of feedback loops. * Support for multiple clock domains, with type safe clock domain crossing. # Support For updates and questions join the mailing list clash-language+subscribe@googlegroups.com or read the [forum](https://groups.google.com/d/forum/clash-language) clash-lib-1.8.1/Setup.hs0000644000000000000000000000005607346545000013205 0ustar0000000000000000import Distribution.Simple main = defaultMain clash-lib-1.8.1/clash-lib.cabal0000644000000000000000000003651507346545000014404 0ustar0000000000000000Cabal-version: 2.2 Name: clash-lib Version: 1.8.1 Synopsis: Clash: a functional hardware description language - As a library Description: Clash is a functional hardware description language that borrows both its syntax and semantics from the functional programming language Haskell. The Clash compiler transforms these high-level descriptions to low-level synthesizable VHDL, Verilog, or SystemVerilog. . Features of Clash: . * 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. . * Higher-order functions, with type inference, result in designs that are fully parametric by default. . * Synchronous sequential circuit design based on streams of values, called @Signal@s, lead to natural descriptions of feedback loops. . * Support for multiple clock domains, with type safe clock domain crossing. . . This package provides: . * The CoreHW internal language: SystemF + Letrec + Case-decomposition . * The normalisation process that brings CoreHW in a normal form that can be converted to a netlist . * Blackbox/Primitive Handling . . Front-ends (for: parsing, typecheck, etc.) are provided by separate packages: . * . * . . Prelude library: Homepage: https://clash-lang.org/ bug-reports: https://github.com/clash-lang/clash-compiler/issues License: BSD-2-Clause License-file: LICENSE Author: The Clash Authors Maintainer: QBayLogic B.V. Copyright: Copyright © 2012-2016, University of Twente, 2016-2019, Myrtle Software Ltd, 2017-2023, QBayLogic B.V., Google Inc. Category: Hardware Build-type: Simple Extra-source-files: README.md, CHANGELOG.md, src/ClashDebug.h Data-files: data-files/tcl/clashConnector.tcl prims/common/*.primitives.yaml, prims/commonverilog/*.primitives.yaml, prims/verilog/*.primitives.yaml, prims/systemverilog/*.primitives.yaml, prims/vhdl/*.primitives.yaml source-repository head type: git location: https://github.com/clash-lang/clash-compiler.git subdir: clash-lib flag debug description: Build a debug compiler default: False manual: True flag unittests description: You can disable testing with unittests using `-f-unittests`. 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 BinaryLiterals DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies InstanceSigs KindSignatures NoStarIsType PostfixOperators ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeOperators ViewPatterns Library import: common-options HS-Source-Dirs: src ghc-options: -Wall -Wcompat CPP-Options: -DCABAL other-extensions: CPP DeriveAnyClass FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses OverloadedStrings RankNTypes RecordWildCards TemplateHaskell 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 && < 1.1, array, async >= 2.2.0 && < 2.3, attoparsec >= 0.10.4.0 && < 0.15, base >= 4.11 && < 5, base16-bytestring >= 0.1.1 && < 1.1, binary >= 0.8.5 && < 0.11, bytestring >= 0.10.0.2 && < 0.13, clash-prelude == 1.8.1, 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.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.9, ghc-boot-th, hashable >= 1.2.1.0 && < 1.5, haskell-src-meta >= 0.8 && < 0.9, hint >= 0.7 && < 0.10, infinite-list ^>= 0.1, lens >= 4.10 && < 5.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, 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.2, time >= 1.4.0.1 && < 1.14, transformers >= 0.5.2.0 && < 0.7, trifecta >= 1.7.1.1 && < 2.2, vector >= 0.11 && < 1.0, vector-binary-instances >= 0.2.3.5 && < 0.3, 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.4 else build-depends: integer-gmp >=1.0 && <1.1 Autogen-Modules: Paths_clash_lib Exposed-modules: Clash.Annotations.BitRepresentation.ClashLib Clash.Backend Clash.Backend.SystemVerilog Clash.Backend.Verilog Clash.Backend.Verilog.Time Clash.Backend.VHDL Clash.Core.DataCon Clash.Core.EqSolver Clash.Core.Evaluator.Types Clash.Core.FreeVars Clash.Core.HasType Clash.Core.HasFreeVars Clash.Core.Literal Clash.Core.Name Clash.Core.PartialEval Clash.Core.PartialEval.AsTerm Clash.Core.PartialEval.Monad Clash.Core.PartialEval.NormalForm Clash.Core.Pretty Clash.Core.Subst Clash.Core.Term Clash.Core.TermInfo Clash.Core.TermLiteral Clash.Core.TermLiteral.TH Clash.Core.TyCon Clash.Core.Type Clash.Core.TysPrim Clash.Core.Util Clash.Core.Var Clash.Core.VarEnv Clash.Data.UniqMap Clash.DataFiles Clash.Debug Clash.Driver Clash.Driver.Manifest Clash.Driver.Types Clash.Edalize.Edam Clash.Netlist Clash.Netlist.BlackBox 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 Clash.Netlist.Id.SystemVerilog Clash.Netlist.Id.Verilog Clash.Netlist.Id.VHDL Clash.Netlist.Types Clash.Netlist.Util Clash.Normalize Clash.Normalize.PrimitiveReductions Clash.Normalize.Primitives Clash.Normalize.Strategy Clash.Normalize.Transformations Clash.Normalize.Transformations.ANF Clash.Normalize.Transformations.Case Clash.Normalize.Transformations.Cast Clash.Normalize.Transformations.DEC Clash.Normalize.Transformations.EtaExpand Clash.Normalize.Transformations.Inline Clash.Normalize.Transformations.Letrec Clash.Normalize.Transformations.MultiPrim Clash.Normalize.Transformations.Reduce Clash.Normalize.Transformations.SeparateArgs Clash.Normalize.Transformations.Specialize Clash.Normalize.Transformations.XOptimize Clash.Normalize.Types Clash.Normalize.Util Clash.Primitives.DSL 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 Clash.Rewrite.Util Clash.Rewrite.WorkFree Clash.Unique Clash.Util Clash.Util.Eq Clash.Util.Graph Clash.Util.Interpolate Clash.Pretty Clash.Verification.Pretty -- Used in v16-upgrade-primitives to decode our non-standard -- JSON primitive files. Data.Aeson.Extra -- 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 Data.Map.Ordered.Extra Data.Monoid.Extra Data.Primitive.ByteArray.Extra Data.Set.Ordered.Extra Data.Text.Extra GHC.SrcLoc.Extra Paths_clash_lib if flag(debug) cpp-options: -DDEBUG executable v16-upgrade-primitives Main-Is: tools/v16-upgrade-primitives.hs Build-Depends: base, aeson, attoparsec-aeson, deepseq, yaml, bytestring, clash-lib, containers, directory, stringsearch, Glob 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 -- 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) buildable: False else build-depends: clash-prelude, clash-lib, ghc-typelits-knownnat, aeson, attoparsec-aeson, aeson-pretty, base, base16-bytestring, bytestring, containers, concurrent-supply, data-default, deepseq, haskell-src-exts, ghc, lens, pretty-show, quickcheck-text, tasty >= 1.2 && < 1.6, tasty-hunit, tasty-quickcheck, tasty-th, template-haskell, text, transformers, unordered-containers 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 Clash.Tests.Normalize.Transformations Test.Clash.Rewrite clash-lib-1.8.1/data-files/tcl/0000755000000000000000000000000007346545000014343 5ustar0000000000000000clash-lib-1.8.1/data-files/tcl/clashConnector.tcl0000644000000000000000000005275307346545000020030 0ustar0000000000000000# 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 } clash-lib-1.8.1/prims/common/0000755000000000000000000000000007346545000014172 5ustar0000000000000000clash-lib-1.8.1/prims/common/Clash_Annotations_BitRepresentation_Deriving.primitives.yaml0000644000000000000000000000031007346545000030221 0ustar0000000000000000- BlackBox: name: Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL kind: Expression type: 'dontApplyInHDL :: (a -> b) -> a -> b' template: ~ARG[1] workInfo: Never clash-lib-1.8.1/prims/common/Clash_Class_BitPack.primitives.yaml0000644000000000000000000000161207346545000023024 0ustar0000000000000000- BlackBox: name: Clash.Class.BitPack.Internal.packFloat# kind: Expression type: 'packFloat# :: Float -> BitVector 32' template: ~ARG[0] workInfo: Never - BlackBox: name: Clash.Class.BitPack.Internal.unpackFloat# kind: Expression type: 'packFloat# :: BitVector 32 -> Float' template: ~ARG[0] workInfo: Never - BlackBox: name: Clash.Class.BitPack.Internal.packDouble# kind: Expression type: 'packFloat# :: Double -> BitVector 64' template: ~ARG[0] workInfo: Never - BlackBox: name: Clash.Class.BitPack.Internal.unpackDouble# kind: Expression type: 'packFloat# :: BitVector 64 -> Double' template: ~ARG[0] workInfo: Never - BlackBox: name: Clash.Class.BitPack.Internal.xToBV kind: Expression type: 'xToBV :: KnownNat n => BitVector n -> BitVector n' template: ~ARG[1] workInfo: Never clash-lib-1.8.1/prims/common/Clash_Explicit_Signal.primitives.yaml0000644000000000000000000000135707346545000023446 0ustar0000000000000000- BlackBox: name: Clash.Explicit.Signal.veryUnsafeSynchronizer kind: Expression type: |- veryUnsafeSynchronizer :: 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 clash-lib-1.8.1/prims/common/Clash_Explicit_Testbench.primitives.yaml0000644000000000000000000000105507346545000024143 0ustar0000000000000000- BlackBox: name: Clash.Explicit.Testbench.unsafeSimSynchronizer kind: Expression type: |- unsafeSimSynchronizer :: forall dom1 dom2 a . ( 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] warning: Clash.Explicit.Testbench.unsafeSimSynchronizer is not safely synthesizable! workInfo: Never clash-lib-1.8.1/prims/common/Clash_GHC_GHC2Core.primitives.yaml0000644000000000000000000000023207346545000022334 0ustar0000000000000000- Primitive: name: _CO_ primType: Constructor workInfo: Constant - Primitive: name: _TY_ primType: Constructor workInfo: Constant clash-lib-1.8.1/prims/common/Clash_Intel_ClockGen.primitives.yaml0000644000000000000000000000123507346545000023203 0ustar0000000000000000- BlackBox: name: Clash.Intel.ClockGen.unsafeAltpll format: Haskell includes: - name: altpll extension: qsys format: Haskell templateFunction: Clash.Primitives.Intel.ClockGen.altpllQsysTF kind: Declaration templateFunction: Clash.Primitives.Intel.ClockGen.altpllTF workInfo: Always - BlackBox: name: Clash.Intel.ClockGen.unsafeAlteraPll format: Haskell includes: - name: altera_pll extension: qsys format: Haskell templateFunction: Clash.Primitives.Intel.ClockGen.alteraPllQsysTF kind: Declaration templateFunction: Clash.Primitives.Intel.ClockGen.alteraPllTF workInfo: Always clash-lib-1.8.1/prims/common/Clash_Magic.primitives.yaml0000644000000000000000000000107507346545000021405 0ustar0000000000000000- Primitive: name: Clash.Magic.prefixName primType: Function - Primitive: name: Clash.Magic.suffixName primType: Function - Primitive: name: Clash.Magic.suffixNameFromNat primType: Function - Primitive: name: Clash.Magic.suffixNameP primType: Function - Primitive: name: Clash.Magic.suffixNameFromNatP primType: Function - Primitive: name: Clash.Magic.setName primType: Function - BlackBox: name: Clash.Magic.SimOnly kind: Expression type: 'SimOnly :: a -> SimOnly a' template: ~ERRORO workInfo: Constant clash-lib-1.8.1/prims/common/Clash_Normalize_Primitives.primitives.yaml0000644000000000000000000000116607346545000024541 0ustar0000000000000000- BlackBox: name: Clash.Normalize.Primitives.removedArg kind: Expression type: 'removedArg :: a' template: ~ERRORO workInfo: Constant - BlackBox: name: Clash.Normalize.Primitives.undefined kind: Expression type: 'undefined :: forall a . a' template: ~ERRORO workInfo: Constant - BlackBox: name: Clash.Normalize.Primitives.undefinedX kind: Expression type: 'undefinedX :: forall a . a' template: ~ERRORO workInfo: Constant - BlackBox: name: c$multiPrimSelect kind: Expression template: '!__SHOULD NOT BE RENDERED__! ~ARG[0]~ARG[1]' workInfo: Always clash-lib-1.8.1/prims/common/Clash_Promoted_Nat.primitives.yaml0000644000000000000000000000031207346545000022751 0ustar0000000000000000- BlackBox: name: Clash.Promoted.Nat.powSNat kind: Expression type: 'Clash.Promoted.Nat.powSNat :: SNat a -> SNat b -> SNat (a^b)' template: ~LIT[0] ** ~LIT[1] workInfo: Never clash-lib-1.8.1/prims/common/Clash_Promoted_Nat_Unsafe.primitives.yaml0000644000000000000000000000030607346545000024255 0ustar0000000000000000- BlackBox: name: Clash.Promoted.Nat.Unsafe.unsafeSNat kind: Expression type: 'Clash.Promoted.Nat.Unsafe.unsafeSNat :: Integer -> SNat k' template: ~LIT[0] workInfo: Never clash-lib-1.8.1/prims/common/Clash_Promoted_Symbol.primitives.yaml0000644000000000000000000000054507346545000023504 0ustar0000000000000000- BlackBox: name: Clash.Promoted.Symbol.SSymbol kind: Expression type: 'SSymbol :: KnownNat n => Proxy n -> SSymbol n' template: ~LIT[0] workInfo: Never - BlackBox: name: Clash.Promoted.Symbol.symbolToString kind: Expression type: 'symbolToString :: SSymbol n -> String' template: ~LIT[0] workInfo: Never clash-lib-1.8.1/prims/common/Clash_Signal_BiSignal.primitives.yaml0000644000000000000000000000150407346545000023347 0ustar0000000000000000- BlackBox: name: Clash.Signal.BiSignal.veryUnsafeToBiSignalIn kind: Declaration type: |- veryUnsafeToBiSignalIn :: ( HasCallStack -- ARG[0] , KnownNat n -- ARG[1] , Given (SBiSignalDefault ds) -- ARG[2] ) => BiSignalOut ds d n -- ARG[3] -> BiSignalIn ds d n template: ~DEVNULL[~ARG[3]] workInfo: Never - BlackBox: name: Clash.Signal.BiSignal.mergeBiSignalOuts kind: Expression type: |- mergeBiSignalOuts :: ( HasCallStack -- ARG[0] , KnownNat n -- ARG[1] ) => Vec n (BiSignalOut defaultState dom m) -- ARG[2] -> BiSignalOut defaultState dom m template: ~DEVNULL[~ARG[2]] workInfo: Never clash-lib-1.8.1/prims/common/Clash_Signal_Bundle.primitives.yaml0000644000000000000000000000014107346545000023064 0ustar0000000000000000- Primitive: name: Clash.Signal.Bundle.vecBundle# primType: Function workInfo: Never clash-lib-1.8.1/prims/common/Clash_Signal_Internal.primitives.yaml0000644000000000000000000000111307346545000023427 0ustar0000000000000000- Primitive: name: Clash.Signal.Internal.signal# primType: Function workInfo: Never - Primitive: name: Clash.Signal.Internal.mapSignal# primType: Function workInfo: Never - Primitive: name: Clash.Signal.Internal.appSignal# primType: Function workInfo: Never - Primitive: name: Clash.Signal.Internal.foldr# primType: Function workInfo: Never - Primitive: name: Clash.Signal.Internal.traverse# primType: Function workInfo: Never - Primitive: name: Clash.Signal.Internal.joinSignal# primType: Function workInfo: Never clash-lib-1.8.1/prims/common/Clash_Signal_Trace.primitives.yaml0000644000000000000000000000337207346545000022722 0ustar0000000000000000- BlackBox: name: Clash.Signal.Trace.traceSignal1 kind: Expression type: |- traceSignal1 :: ( BitPack a -- ARG[0] , NFDataX a -- ARG[1] , Typeable a ) -- ARG[2] => String -- ARG[3] -> Signal dom a -- ARG[4] -> Signal dom a template: ~ARG[4] workInfo: Never - BlackBox: name: Clash.Signal.Trace.traceVecSignal1 kind: Expression type: |- traceVecSignal1 :: ( KnownNat n -- ARG[0] , BitPack a -- ARG[1] , NFDataX a -- ARG[2] , Typeable a ) -- ARG[3] => String -- ARG[4] -> Signal dom (Vec (n+1) a) -- ARG[5] -> Signal dom (Vec (n+1) a) template: ~ARG[5] workInfo: Never - BlackBox: name: Clash.Signal.Trace.traceSignal kind: Expression type: |- traceSignal :: forall dom a . ( KnownDomain dom -- ARG[0] , BitPack a -- ARG[1] , NFDataX a -- ARG[2] , Typeable a ) -- ARG[3] => String -- ARG[4] -> Signal dom a -- ARG[5] -> Signal dom a template: ~ARG[5] workInfo: Never - BlackBox: name: Clash.Signal.Trace.traceVecSignal kind: Expression type: |- traceVecSignal :: forall dom a n . ( KnownDomain dom -- ARG[0] , KnownNat n -- ARG[1] , BitPack a -- ARG[2] , NFDataX a -- ARG[3] , Typeable a ) -- ARG[4] => String -- ARG[5] -> Signal dom (Vec (n+1) a) -- ARG[6] -> Signal dom (Vec (n+1) a) template: ~ARG[6] workInfo: Never clash-lib-1.8.1/prims/common/Clash_Sized_Internal_BitVector.primitives.yaml0000644000000000000000000000165307346545000025262 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.BitVector.undefined# kind: Expression type: 'undefined# :: forall n . KnownNat n => BitVector n' template: ~ERRORO workInfo: Constant - Primitive: name: Clash.Sized.Internal.BitVector.checkUnpackUndef primType: Function workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.lt## kind: Expression type: 'lt## :: Bit -> Bit -> Bool' template: ~ARG[0] < ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.ge## kind: Expression type: 'ge## :: Bit -> Bit -> Bool' template: ~ARG[0] >= ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.gt## kind: Expression type: 'gt## :: Bit -> Bit -> Bool' template: ~ARG[0] > ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.le## kind: Expression type: 'le## :: Bit -> Bit -> Bool' template: ~ARG[0] <= ~ARG[1] clash-lib-1.8.1/prims/common/Clash_Sized_Internal_Signed.primitives.yaml0000644000000000000000000000054607346545000024572 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.Signed.+# kind: Expression type: '(+#) :: KnownNat n => Signed n -> Signed n -> Signed n' template: ~ARG[1] + ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Signed.-# kind: Expression type: '(-#) :: KnownNat n => Signed n -> Signed n -> Signed n' template: ~ARG[1] - ~ARG[2] clash-lib-1.8.1/prims/common/Clash_Sized_Internal_Unsigned.primitives.yaml0000644000000000000000000000147007346545000025132 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.Unsigned.+# kind: Expression type: '(+#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n' template: ~ARG[1] + ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Unsigned.-# kind: Expression type: '(-#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n' template: ~ARG[1] - ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Unsigned.unsignedToWord kind: Expression template: ~ARG[0] - BlackBox: name: Clash.Sized.Internal.Unsigned.unsigned8toWord8 kind: Expression template: ~ARG[0] - BlackBox: name: Clash.Sized.Internal.Unsigned.unsigned16toWord16 kind: Expression template: ~ARG[0] - BlackBox: name: Clash.Sized.Internal.Unsigned.unsigned32toWord32 kind: Expression template: ~ARG[0] clash-lib-1.8.1/prims/common/Clash_Sized_RTree.primitives.yaml0000644000000000000000000000013307346545000022536 0ustar0000000000000000- Primitive: name: Clash.Sized.RTree.tdfold primType: Function workInfo: Never clash-lib-1.8.1/prims/common/Clash_Sized_Vector.primitives.yaml0000644000000000000000000000142007346545000022757 0ustar0000000000000000- BlackBox: name: Clash.Sized.Vector.lazyV kind: Expression type: 'lazyV :: KnownNat n => Vec n a -> Vec n a' template: ~ARG[1] workInfo: Never - BlackBox: name: Clash.Sized.Vector.seqV kind: Expression type: 'seqV :: KnownNat n => Vec n a -> b -> b' template: ~ARG[2] workInfo: Never - BlackBox: name: Clash.Sized.Vector.seqVX kind: Expression type: 'seqVX :: KnownNat n => Vec n a -> b -> b' template: ~ARG[2] workInfo: Never - Primitive: name: Clash.Sized.Vector.dfold primType: Function workInfo: Never - Primitive: name: Clash.Sized.Vector.dtfold primType: Function workInfo: Never - Primitive: name: Clash.Sized.Vector.traverse# primType: Function workInfo: Never clash-lib-1.8.1/prims/common/Clash_XException.primitives.yaml0000644000000000000000000000155007346545000022451 0ustar0000000000000000- BlackBox: name: Clash.XException.seqX kind: Expression type: 'seqX :: a -> b -> b' template: ~ARG[1] workInfo: Never - BlackBox: name: Clash.XException.seqErrorX kind: Expression type: 'seqErrorX :: a -> b -> b' template: ~ARG[1] workInfo: Never - BlackBox: name: Clash.XException.errorX kind: Expression type: 'errorX :: HasCallStack => String -> a' template: ~ERRORO workInfo: Constant - BlackBox: name: Clash.XException.deepseqX kind: Expression type: 'deepseqX :: NFDataX a => a -> b -> b' template: ~ARG[2] workInfo: Never - BlackBox: name: Clash.XException.hwSeqX kind: Expression type: 'hwSeqX :: a -> b -> b' template: ~DEVNULL[~VAR[x][0]]~ARG[1] workInfo: Never - Primitive: name: Clash.XException.xToErrorCtx primType: Function clash-lib-1.8.1/prims/common/Clash_Xilinx_ClockGen.primitives.yaml0000644000000000000000000000136207346545000023404 0ustar0000000000000000- 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 clash-lib-1.8.1/prims/common/Control_Exception_Base.primitives.yaml0000644000000000000000000000301307346545000023635 0ustar0000000000000000- BlackBox: name: Control.Exception.Base.recSelError kind: Expression type: 'recSelError :: Addr# -> a' template: ~ERRORO workInfo: Constant - BlackBox: name: Control.Exception.Base.recConError kind: Expression type: 'recConError :: Addr# -> a' template: ~ERRORO workInfo: Constant - BlackBox: name: Control.Exception.Base.irrefutPatError kind: Expression type: 'irrefutPatError :: Addr# -> a' template: ~ERRORO workInfo: Constant - BlackBox: name: Control.Exception.Base.runtimeError kind: Expression type: 'runtimeError :: Addr# -> a' template: ~ERRORO workInfo: Constant - BlackBox: name: Control.Exception.Base.nonExhaustiveGuardsError kind: Expression type: 'nonExhaustiveGuardsError :: Addr# -> a' template: ~ERRORO workInfo: Constant - BlackBox: name: Control.Exception.Base.patError kind: Expression type: 'patError :: Addr# -> a' template: ~ERRORO workInfo: Constant - BlackBox: name: Control.Exception.Base.noMethodBindingError kind: Expression type: 'noMethodBindingError :: Addr# -> a' template: ~ERRORO workInfo: Constant - BlackBox: name: Control.Exception.Base.absentError kind: Expression type: 'absentError :: Addr# -> a' template: ~ERRORO workInfo: Constant - BlackBox: name: Control.Exception.Base.typeError kind: Expression type: 'typeError :: Addr# -> a' template: ~ERRORO workInfo: Constant clash-lib-1.8.1/prims/common/Debug_Trace.primitives.yaml0000644000000000000000000000022307346545000021411 0ustar0000000000000000- BlackBox: name: Debug.Trace.trace kind: Expression type: 'trace :: String -> a -> a' template: ~ARG[1] workInfo: Never clash-lib-1.8.1/prims/common/GHC_Base.primitives.yaml0000644000000000000000000000011507346545000020600 0ustar0000000000000000- Primitive: name: GHC.Base.$ primType: Function workInfo: Never clash-lib-1.8.1/prims/common/GHC_CString.primitives.yaml0000644000000000000000000000050607346545000021303 0ustar0000000000000000- BlackBox: name: GHC.CString.unpackCString# kind: Expression template: ~LIT[0] workInfo: Never - BlackBox: name: GHC.CString.unpackFoldrCString# kind: Expression template: ~LIT[0] workInfo: Never - Primitive: name: GHC.CString.unpackCStringUtf8# primType: Function workInfo: Never clash-lib-1.8.1/prims/common/GHC_Classes.primitives.yaml0000644000000000000000000000105607346545000021330 0ustar0000000000000000- BlackBox: name: GHC.Classes.gtInt kind: Expression type: 'gtInt :: Int -> Int -> Bool' template: ~ARG[0] > ~ARG[1] - BlackBox: name: GHC.Classes.geInt kind: Expression type: 'geInt :: Int -> Int -> Bool' template: ~ARG[0] >= ~ARG[1] - BlackBox: name: GHC.Classes.ltInt kind: Expression type: 'ltInt :: Int -> Int -> Bool' template: ~ARG[0] < ~ARG[1] - BlackBox: name: GHC.Classes.leInt kind: Expression type: 'leInt :: Int -> Int -> Bool' template: ~ARG[0] <= ~ARG[1] clash-lib-1.8.1/prims/common/GHC_Err.primitives.yaml0000644000000000000000000000077407346545000020471 0ustar0000000000000000- BlackBox: name: GHC.Err.error kind: Expression type: 'error :: forall r a . HasCallStack => [Char] -> a' template: ~ERRORO workInfo: Constant - BlackBox: name: GHC.Err.errorWithoutStackTrace kind: Expression type: 'errorWithoutStackTrace :: forall r a . [Char] -> a' template: ~ERRORO workInfo: Constant - BlackBox: name: GHC.Err.undefined kind: Expression type: 'undefined :: forall r a . HasCallStack => a' template: ~ERRORO workInfo: Constant clash-lib-1.8.1/prims/common/GHC_IO_Exception.primitives.yaml0000644000000000000000000000104607346545000022257 0ustar0000000000000000- BlackBox: name: GHC.IO.Exception.assertError comment: |- It would be nice if we could use a HDL assertion, however, because in HDL, case alternatives are evaluated concurrently, we would end up with the assertion being triggered, even when the result of that branch is not chosen in the multiplexer kind: Expression type: 'assertError :: HasCallStack => Bool -> a -> a' template: ~ARG[2] workInfo: Never clash-lib-1.8.1/prims/common/GHC_Integer_Type.primitives.yaml0000644000000000000000000000346707346545000022341 0ustar0000000000000000- BlackBox: name: GHC.Integer.Type.plusInteger kind: Expression type: 'plusInteger :: Integer -> Integer -> Integer' template: ~ARG[0] + ~ARG[1] warning: 'GHC.Integer.Type.plusInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.minusInteger kind: Expression type: 'minusInteger :: Integer -> Integer -> Integer' template: ~ARG[0] - ~ARG[1] warning: 'GHC.Integer.Type.minusInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.leInteger kind: Expression type: 'leInteger :: Integer -> Integer -> Bool' template: ~ARG[0] <= ~ARG[1] warning: 'GHC.Integer.Type.leInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.gtInteger kind: Expression type: 'gtInteger :: Integer -> Integer -> Bool' template: ~ARG[0] > ~ARG[1] warning: 'GHC.Integer.Type.gtInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.ltInteger kind: Expression type: 'ltInteger :: Integer -> Integer -> Bool' template: ~ARG[0] < ~ARG[1] warning: 'GHC.Integer.Type.ltInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.geInteger kind: Expression type: 'geInteger :: Integer -> Integer -> Bool' template: ~ARG[0] >= ~ARG[1] warning: 'GHC.Integer.Type.geInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' clash-lib-1.8.1/prims/common/GHC_Magic.primitives.yaml0000644000000000000000000000042407346545000020751 0ustar0000000000000000- Primitive: name: GHC.Magic.lazy primType: Function workInfo: Never - Primitive: name: GHC.Magic.noinline primType: Function type: forall a. a -> a workInfo: Never - Primitive: name: GHC.Magic.runRW# primType: Function workInfo: Never clash-lib-1.8.1/prims/common/GHC_Natural.primitives.yaml0000644000000000000000000000273707346545000021350 0ustar0000000000000000- Primitive: name: GHC.Natural.NatS# comment: Needed to make the evaluator handle this constructor strictly primType: Constructor warning: 'GHC.Natural.NatS#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - Primitive: name: GHC.Natural.naturalToInteger primType: Function warning: 'GHC.Natural.naturalToInteger: No blackbox available without size inference for Natural and Integer' workInfo: Never - BlackBox: name: GHC.Natural.underflowError kind: Expression type: 'underflowError :: a' template: ~ERRORO workInfo: Constant - BlackBox: name: GHC.Natural.plusNatural kind: Expression type: 'plusNatural :: Natural -> Natural -> Natural' template: ~ARG[0] + ~ARG[1] warning: 'GHC.Natural.plusNatural: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Natural.minusNatural kind: Expression type: 'minusNatural :: Natural -> Natural -> Natural' template: ~ARG[0] - ~ARG[1] warning: 'GHC.Natural.minusNatural: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - Primitive: name: GHC.Natural.gcdNatural primType: Function warning: 'GHC.Natural.gcdNatural: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never clash-lib-1.8.1/prims/common/GHC_Num_Integer.primitives.yaml0000644000000000000000000000560607346545000022154 0ustar0000000000000000- Primitive: name: GHC.Num.Integer.IS comment: Needed to make the evaluator handle this constructor strictly primType: Constructor warning: 'GHC.Num.Integer.IS: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - Primitive: name: GHC.Num.Integer.IP comment: Needed to make the evaluator handle this constructor strictly primType: Constructor warning: 'GHC.Num.Integer.IP: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - Primitive: name: GHC.Num.Integer.IN comment: Needed to make the evaluator handle this constructor strictly primType: Constructor warning: 'GHC.Num.Integer.IN: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - Primitive: name: GHC.Num.Integer.integerFromNatural primType: Function warning: 'GHC.Num.Integer.integerFromNatural: No blackbox available without size inference for Natural and Integer' workInfo: Never - BlackBox: name: GHC.Num.Integer.integerAdd kind: Expression type: 'integerAdd :: Integer -> Integer -> Integer' template: ~ARG[0] + ~ARG[1] warning: 'GHC.Num.Integer.integerAdd: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerSub kind: Expression type: 'integerSub :: Integer -> Integer -> Integer' template: ~ARG[0] - ~ARG[1] warning: 'GHC.Num.Integer.integerSub: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerLe kind: Expression type: 'integerLe :: Integer -> Integer -> Bool' template: ~ARG[0] <= ~ARG[1] warning: 'GHC.Num.Integer.integerLe: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerGt kind: Expression type: 'integerGt :: Integer -> Integer -> Bool' template: ~ARG[0] > ~ARG[1] warning: 'GHC.Num.Integer.integerGt: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerLt kind: Expression type: 'integerLt :: Integer -> Integer -> Bool' template: ~ARG[0] < ~ARG[1] warning: 'GHC.Num.Integer.integerLt: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerGe kind: Expression type: 'integerGe :: Integer -> Integer -> Bool' template: ~ARG[0] >= ~ARG[1] warning: 'GHC.Num.Integer.integerGe: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' clash-lib-1.8.1/prims/common/GHC_Num_Natural.primitives.yaml0000644000000000000000000000501607346545000022160 0ustar0000000000000000- Primitive: name: GHC.Num.Natural.NS comment: Needed to make the evaluator handle this constructor strictly primType: Constructor warning: 'GHC.Num.Natural.NS: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - Primitive: name: GHC.Num.Natural.NB comment: Needed to make the evaluator handle this constructor strictly primType: Constructor warning: 'GHC.Num.Natural.NB: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Natural.naturalAdd kind: Expression type: 'naturalSub :: Natural -> Natural -> Natural' template: ~ARG[0] + ~ARG[1] warning: 'GHC.Num.Natural.naturalAdd: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - Primitive: name: GHC.Num.Natural.naturalSub primType: Function warning: 'GHC.Num.Natural.naturalSub: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Natural.naturalSubUnsafe kind: Expression type: 'naturalSubUnsafe :: Natural -> Natural -> Natural' template: ~ARG[0] - ~ARG[1] warning: 'GHC.Num.Natural.naturalSubUnsafe: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalSubThrow kind: Expression type: 'naturalSubThrow :: Natural -> Natural -> Natural' template: ~ARG[0] - ~ARG[1] warning: 'GHC.Num.Natural.naturalSubThrow: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalMul kind: Expression type: 'naturalMul :: Natural -> Natural -> Natural' template: ~ARG[0] * ~ARG[1] warning: 'GHC.Num.Natural.naturalMul: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - Primitive: name: GHC.Num.Natural.naturalGcd primType: Function warning: 'GHC.Num.Natural.naturalGcd: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - Primitive: name: GHC.Num.Natural.naturalLcm primType: Function warning: 'GHC.Num.Natural.naturalLcm: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never clash-lib-1.8.1/prims/common/GHC_Prim.primitives.yaml0000644000000000000000000000447607346545000020653 0ustar0000000000000000- Primitive: name: GHC.Prim.dataToTag# primType: Function - Primitive: name: GHC.Prim.tagToEnum# primType: Function - BlackBox: name: GHC.Prim.unsafeCoerce# kind: Expression type: 'unsafeCoerce# :: a -> b' template: ~ARG[0] workInfo: Never - BlackBox: name: GHC.Prim.+# kind: Expression type: '(+#) :: Int# -> 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] clash-lib-1.8.1/prims/common/GHC_Prim_Panic.primitives.yaml0000644000000000000000000000023707346545000021754 0ustar0000000000000000- BlackBox: name: GHC.Prim.Panic.absentError kind: Expression type: 'absentError :: Addr# -> a' template: ~ERRORO workInfo: Constant clash-lib-1.8.1/prims/common/GHC_Real.primitives.yaml0000644000000000000000000000072207346545000020615 0ustar0000000000000000- BlackBox: name: GHC.Real.divZeroError kind: Expression type: 'divZeroError :: a' template: ~ERRORO workInfo: Constant - BlackBox: name: GHC.Real.ratioZeroDenominatorError kind: Expression type: 'ratioZeroDenominatorError :: a' template: ~ERRORO workInfo: Constant - BlackBox: name: GHC.Real.overflowError kind: Expression type: 'overflowError :: a' template: ~ERRORO workInfo: Constant clash-lib-1.8.1/prims/common/GHC_TypeNats.primitives.yaml0000644000000000000000000000077207346545000021506 0ustar0000000000000000- BlackBox: name: GHC.TypeNats.natVal kind: Expression type: 'natVal :: forall n proxy. KnownNat n => proxy n -> Natural' template: ~ARG[0] workInfo: Never - Primitive: name: GHC.TypeNats.someNatVal 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 clash-lib-1.8.1/prims/common/GHC_Typelits.primitives.yaml0000644000000000000000000000026607346545000021552 0ustar0000000000000000- BlackBox: name: GHC.TypeLits.natVal kind: Expression type: 'natVal :: forall n proxy. KnownNat n => proxy n -> Integer' template: ~ARG[0] workInfo: Never clash-lib-1.8.1/prims/common/GHC_Types.primitives.yaml0000644000000000000000000000076307346545000021043 0ustar0000000000000000- Primitive: 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 clash-lib-1.8.1/prims/common/Unsafe_Coerce.primitives.yaml0000644000000000000000000000023107346545000021745 0ustar0000000000000000- BlackBox: name: Unsafe.Coerce.unsafeCoerce kind: Expression type: 'unsafeCoerce :: a -> b' template: ~ARG[0] workInfo: Never clash-lib-1.8.1/prims/commonverilog/0000755000000000000000000000000007346545000015562 5ustar0000000000000000clash-lib-1.8.1/prims/commonverilog/Clash_Class_Exp.primitives.yaml0000644000000000000000000000250007346545000023630 0ustar0000000000000000- BlackBox: name: Clash.Class.Exp.expIndex# kind: Declaration type: 'expIndex# :: KnownNat m => Index m -> SNat n -> Index (m^n)' template: assign ~RESULT = ~DEVNULL[~ARG[0]]$signed(~ARG[1] ** ~LIT[2]); warning: Exponentiation is only supported on relatively small constructs (< 32 bits). Ideally, Clash should have constant folded your expression. See https://github.com/clash-lang/clash-compiler/issues/593. - BlackBox: name: Clash.Class.Exp.expSigned# kind: Declaration type: 'expSigned# :: KnownNat m => Signed m -> SNat n -> Signed (m*n)' template: assign ~RESULT = ~DEVNULL[~ARG[0]]$signed(~ARG[1] ** ~LIT[2]); warning: Exponentiation is only supported on relatively small constructs (< 32 bits). Ideally, Clash should have constant folded your expression. See https://github.com/clash-lang/clash-compiler/issues/593. - BlackBox: name: Clash.Class.Exp.expUnsigned# kind: Declaration type: 'expUnsigned# :: KnownNat m => Unsigned m -> SNat n -> Unsigned (m*n)' template: assign ~RESULT = ~DEVNULL[~ARG[0]]$unsigned(~ARG[1] ** ~LIT[2]); warning: Exponentiation is only supported on relatively small constructs (< 32 bits). Ideally, Clash should have constant folded your expression. See https://github.com/clash-lang/clash-compiler/issues/593. clash-lib-1.8.1/prims/commonverilog/Clash_Explicit_SimIO.primitives.yaml0000644000000000000000000000467407346545000024606 0ustar0000000000000000- Primitive: name: Clash.Explicit.SimIO.mealyIO primType: Function - BlackBox: name: Clash.Explicit.SimIO.display kind: Declaration renderVoid: RenderVoid template: $display(~ARG[0]); - BlackBox: name: Clash.Explicit.SimIO.finish kind: Declaration renderVoid: RenderVoid template: |- `ifdef VERILATOR $c("std::exit(~LIT[0]);"); `else // NOTE: $finish_and_return is an iverilog extension! $finish_and_return(~LIT[0]); `endif - BlackBox: name: Clash.Explicit.SimIO.reg kind: Expression template: ~ARG[0] - BlackBox: name: Clash.Explicit.SimIO.readReg kind: Expression template: ~ARG[0] - BlackBox: name: Clash.Explicit.SimIO.writeReg kind: Declaration renderVoid: RenderVoid outputUsage: Blocking template: ~ARG[0] = ~ARG[1]; - BlackBox: name: Clash.Explicit.SimIO.openFile kind: Expression template: $fopen(~FILE[~LIT[0]],~LIT[1]) - BlackBox: name: Clash.Explicit.SimIO.closeFile kind: Declaration renderVoid: RenderVoid template: $fclose(~ARG[0]); - BlackBox: name: Clash.Explicit.SimIO.getChar kind: Expression template: $fgetc(~ARG[0]) - BlackBox: name: Clash.Explicit.SimIO.putChar kind: Declaration renderVoid: RenderVoid template: $ungetc(~ARG[0],~ARG[1]); - BlackBox: name: Clash.Explicit.SimIO.getLine kind: Declaration outputUsage: Blocking template: ~RESULT = $fgets(~ARG[2],~ARG[1]); - BlackBox: name: Clash.Explicit.SimIO.isEOF kind: Expression template: $feof(~ARG[0]) - BlackBox: name: Clash.Explicit.SimIO.flush kind: Declaration renderVoid: RenderVoid template: $fflush(~ARG[0]); - 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 kind: Expression template: $ftell(~ARG[0]) - Primitive: name: Clash.Explicit.SimIO.fmapSimIO# primType: Function - Primitive: name: Clash.Explicit.SimIO.pureSimIO# primType: Function - Primitive: name: Clash.Explicit.SimIO.apSimIO# primType: Function - Primitive: name: Clash.Explicit.SimIO.bindSimIO# primType: Function - Primitive: name: Clash.Explicit.SimIO.unSimIO primType: Function clash-lib-1.8.1/prims/commonverilog/Clash_Explicit_Testbench.primitives.yaml0000644000000000000000000000046107346545000025533 0ustar0000000000000000- BlackBox: name: Clash.Explicit.Testbench.tbEnableGen kind: Declaration type: 'tbEnableGen :: Enable dom' template: assign ~RESULT = 1'b1; workInfo: Always - BlackBox: name: Clash.Explicit.Testbench.clockToDiffClock kind: Expression template: '{~ARG[1], ~ ~ARG[1]}' clash-lib-1.8.1/prims/commonverilog/Clash_Intel_DDR.primitives.yaml0000644000000000000000000000276107346545000023524 0ustar0000000000000000- BlackBox: name: Clash.Intel.DDR.altddioOut# kind: Declaration libraries: - altera_mf type: |- altddioOut# :: ( HasCallStack -- ARG[0] , KnownConfi~ fast domf -- ARG[1] , KnownConfi~ slow doms -- ARG[2] , KnownNat m ) -- ARG[3] => SSymbol deviceFamily -- ARG[4] -> Clock slow -- ARG[5] -> Reset slow -- ARG[6] -> Enable slow -- ARG[7] -> Signal slow (BitVector m) -- ARG[8] -> Signal slow (BitVector m) -- ARG[9] -> Signal fast (BitVector m) template: |- // altddioOut begin altddio_out #( .extend_oe_disable ("OFF"), .intended_device_family (~LIT[4]), .invert_output ("OFF"), .lpm_hint ("UNUSED"), .lpm_type ("altddio_out"), .oe_reg ("UNREGISTERED"), .power_up_high ("OFF"), .width (~SIZE[~TYPO]) ) ~GENSYM[~COMPNAME_ALTDDIO_OUT][7] (~IF ~ISSYNC[2] ~THEN .sclr (~ARG[6]), .aclr (1'b0),~ELSE .aclr (~ARG[6]), .sclr (1'b0),~FI .datain_h (~ARG[8]), .datain_l (~ARG[9]), .outclock (~ARG[5]), .outclocken (~IF ~ISACTIVEENABLE[7] ~THEN ~ARG[7] ~ELSE 1'b1 ~FI), .dataout (~RESULT), .aset (1'b0), .sset (1'b0), .oe (1'b1), .oe_out () ); // altddioOut end clash-lib-1.8.1/prims/commonverilog/Clash_Magic.primitives.yaml0000644000000000000000000000037707346545000023001 0ustar0000000000000000- BlackBox: name: Clash.Magic.nameHint kind: Declaration type: |- nameHint :: SSymbol sym -- ARG[0] -> a -- ARG[1] -> a resultName: template: ~NAME[0] template: assign ~RESULT = ~ARG[1]; clash-lib-1.8.1/prims/commonverilog/Clash_Promoted_Nat.primitives.yaml0000644000000000000000000000477207346545000024357 0ustar0000000000000000- BlackBox: name: Clash.Promoted.Nat.flogBaseSNat imports: - ~INCLUDENAME[0].inc includes: - name: flogBase extension: inc template: |- // floor of logBase function integer ~INCLUDENAME[0]; input integer base, value; begin for (~INCLUDENAME[0] = 0; value >= base; ~INCLUDENAME[0]=~INCLUDENAME[0]+1) value = value / base; end endfunction kind: Expression type: |- Clash.Promoted.Nat.flogBaseSNat :: (2 <= base, 1 <= x) => SNat base -- ARG[2] -> SNat x -- ARG[3] -> SNat (FLog base x template: ~INCLUDENAME[0](~LIT[2],~LIT[3]) workInfo: Never - BlackBox: name: Clash.Promoted.Nat.clogBaseSNat imports: - ~INCLUDENAME[0].inc includes: - name: clogBase extension: inc template: |- // ceiling of logBase function integer ~INCLUDENAME[0]; input integer base, value; begin for (~INCLUDENAME[0] = 0; base ** ~INCLUDENAME[0] < value; ~INCLUDENAME[0]=~INCLUDENAME[0]+1); end endfunction kind: Expression type: |- Clash.Promoted.Nat.clogBaseSNat :: (2 <= base, 1 <= x) => SNat base -- ARG[2] -> SNat x -- ARG[3] -> SNat (CLog base x template: ~INCLUDENAME[0](~LIT[2],~LIT[3]) workInfo: Never - BlackBox: name: Clash.Promoted.Nat.logBaseSNat imports: - ~INCLUDENAME[0].inc includes: - name: clogBase extension: inc template: |- // logBaseSNat begin function integer ~INCLUDENAME[0]; input integer base, value; begin for (~INCLUDENAME[0] = 0; value >= base; ~INCLUDENAME[0]=~INCLUDENAME[0]+1) value = value / base; end endfunction kind: Expression type: |- Clash.Promoted.Nat.logBaseSNat :: (FLog base x ~ CLog base x) => SNat base -- ARG[1] -> SNat x -- ARG[2] -> SNat (Log base x) template: ~INCLUDENAME[0](~LIT[1],~LIT[2]) workInfo: Never clash-lib-1.8.1/prims/commonverilog/Clash_Signal_Internal.primitives.yaml0000644000000000000000000000061107346545000025021 0ustar0000000000000000- BlackBox: name: Clash.Signal.Internal.unsafeFromReset kind: Expression type: 'unsafeFromReset :: Reset dom -> Signal dom Bool' template: ~ARG[0] workInfo: Never - BlackBox: name: Clash.Signal.Internal.unsafeToReset kind: Expression type: 'unsafeToReset :: KnownDomain dom => Signal dom Bool -> Reset dom' template: ~ARG[1] workInfo: Never clash-lib-1.8.1/prims/commonverilog/Clash_Sized_Internal_BitVector.primitives.yaml0000644000000000000000000002653607346545000026661 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.BitVector.BV comment: THIS IS ONLY USED WHEN WW EXPOSES BITVECTOR INTERNALS kind: Expression type: 'BV :: Integer -> Integer -> BitVector n' template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[i][1]})~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.Bit comment: THIS IS ONLY USED WHEN WW EXPOSES BIT INTERNALS kind: Expression type: 'Bit :: Integer -> Integer -> BitVector n' template: ~VAR[i][1][0] workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.high kind: Expression type: 'high :: Bit' template: 1'b1 workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.low kind: Expression type: 'low :: Bit' template: 1'b0 workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.pack# kind: Expression type: 'pack# :: Bit -> BitVector 1' template: ~ARG[0] workInfo: Identity 0 [] - BlackBox: name: Clash.Sized.Internal.BitVector.unpack# kind: Expression type: 'unpack# :: BitVector 1 -> Bit' template: ~ARG[0] workInfo: Identity 0 [] - BlackBox: name: Clash.Sized.Internal.BitVector.reduceAnd# kind: Expression type: 'reduceAnd# :: KnownNat n => BitVector n -> Bit' template: ~IF~SIZE[~TYP[1]]~THEN& (~ARG[1])~ELSE1'b1~FI - BlackBox: name: Clash.Sized.Internal.BitVector.reduceOr# kind: Expression type: 'reduceOr# :: KnownNat n => BitVector n -> Bit' template: ~IF~SIZE[~TYP[1]]~THEN| (~ARG[1])~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.BitVector.reduceXor# kind: Expression type: 'reduceXor# :: KnownNat n => BitVector n -> Bit' template: ~IF~SIZE[~TYP[1]]~THEN^ (~ARG[1])~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.BitVector.eq## kind: Expression type: 'eq## :: Bit -> Bit -> Bool' template: ~ARG[0] == ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.neq## kind: Expression type: 'neq## :: Bit -> Bit -> Bool' template: ~ARG[0] != ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.fromInteger## kind: Expression type: 'fromInteger## :: Integer -> Integer -> Bit' template: '~VAR[i][0][0] ? 1''bx : ~VAR[i][1][0]' workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.toEnum## kind: Expression type: 'toEnum## :: Int -> Bit' template: '~VAR[i][0][0] ? 1''b1 : 1''b0' workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.and## kind: Expression type: 'and## :: Bit -> Bit -> Bit' template: ~ARG[0] & ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.or## kind: Expression type: 'or## :: Bit -> Bit -> Bit' template: ~ARG[0] | ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.xor## kind: Expression type: 'xor## :: Bit -> Bit -> Bit' template: ~ARG[0] ^ ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.complement## kind: Expression type: 'complement## :: Bit -> Bit' template: ~ ~ARG[0] - BlackBox: name: Clash.Sized.Internal.BitVector.eq# kind: Expression type: 'eq# :: KnownNat n => BitVector n -> BitVector n -> Bool' template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] == ~ARG[2]~ELSE1'b1~FI - BlackBox: name: Clash.Sized.Internal.BitVector.neq# kind: Expression type: 'neq# :: KnownNat n => BitVector n -> BitVector n -> Bool' template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] != ~ARG[2]~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.BitVector.lt# kind: Expression type: 'lt# :: KnownNat n => BitVector n -> BitVector n -> Bool' template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] < ~ARG[2]~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.BitVector.ge# kind: Expression type: 'ge# :: KnownNat n => BitVector n -> BitVector n -> Bool' template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] >= ~ARG[2]~ELSE1'b1~FI - BlackBox: name: Clash.Sized.Internal.BitVector.gt# kind: Expression type: 'gt# :: KnownNat n => BitVector n -> BitVector n -> Bool' template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] > ~ARG[2]~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.BitVector.le# kind: Expression type: 'le# :: KnownNat n => BitVector n -> BitVector n -> Bool' template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] <= ~ARG[2]~ELSE1'b1~FI - BlackBoxHaskell: name: Clash.Sized.Internal.BitVector.toInteger# templateFunction: Clash.Primitives.Sized.ToInteger.bvToIntegerVerilog workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.fromEnum# kind: Expression type: 'fromEnum# :: KnownNat n => BitVector n -> Int' template: ~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[bv][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[bv][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.size# kind: Expression type: 'size# :: KnownNat n => BitVector n -> Int' template: ~SIZE[~TYPO]'sd~SIZE[~TYP[1]] workInfo: Constant - BlackBox: name: Clash.Sized.Internal.BitVector.maxIndex# kind: Expression type: 'maxIndex# :: KnownNat n => BitVector n -> Int' template: ~SIZE[~TYPO]'sd~SIZE[~TYP[1]] - ~SIZE[~TYPO]'sd1 workInfo: Constant - BlackBox: name: Clash.Sized.Internal.BitVector.++# kind: Expression type: '(++#) :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)' template: ~IF~AND[~SIZE[~TYP[1]],~SIZE[~TYP[2]]]~THEN{~ARG[1],~ARG[2]}~ELSE~IF~SIZE[~TYP[1]]~THEN~ARG[1]~ELSE~ARG[2]~FI~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.index# kind: Expression type: |- index# :: KnownNat n -- ARG[0] => BitVector n -- ARG[1] -> Int -- ARG[2] -> Bit template: ~VAR[bv][1][~ARG[2]] - BlackBox: name: Clash.Sized.Internal.BitVector.slice# kind: Expression type: |- slice# :: BitVector (m + 1 + i) -- ARG[0] -> SNat m -- ARG[1] -> SNat n -- ARG[2] -> BitVector (m + 1 - n) template: '~VAR[bv][0][~LIT[1] : ~LIT[2]]' workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.msb# kind: Expression type: |- msb# :: KnownNat n -- ARG[0] => BitVector n -- ARG[1] -> Bit template: ~IF ~SIZE[~TYP[1]] ~THEN ~VAR[bv][1][~SIZE[~TYP[1]]-1] ~ELSE 1'b0 ~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.lsb# kind: Expression type: |- lsb# :: BitVector n -- ARG[0] -> Bit template: ~IF ~SIZE[~TYP[0]] ~THEN ~VAR[bv][0][0] ~ELSE 1'b0 ~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.minBound# kind: Expression type: 'minBound# :: BitVector n' template: ~SIZE[~TYPO]'d0 workInfo: Constant - BlackBox: name: Clash.Sized.Internal.BitVector.maxBound# kind: Expression type: 'maxBound# :: KnownNat n => BitVector n' template: '{~SIZE[~TYPO] {1''b1}}' workInfo: Constant - BlackBox: name: Clash.Sized.Internal.BitVector.+# kind: Expression type: '(+#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: ~ARG[1] + ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.-# kind: Expression type: '(-#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: ~ARG[1] - ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.*# kind: Expression type: '(*#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: ~ARG[1] * ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.negate# kind: Expression type: 'negate# :: KnownNat n => BitVector n -> BitVector n' template: -~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.fromInteger# kind: Expression type: 'fromInteger# :: KnownNat n => Integer -> Integer -> BitVector n' template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[2]]]~THEN$unsigned(~VAR[i][2][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[2]]) {1'b0}},~VAR[i][2]})~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.toEnum# kind: Expression type: 'toEnum# :: KnownNat n => Int -> BitVector n' template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[i][1]})~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.plus# kind: Declaration type: 'plus# :: (KnownNat m, KnownNat n) => BitVector m -> BitVector n -> BitVector (Max m n + 1)' template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THEN~ARG[2] + ~ARG[3]~ELSE~IF~SIZE[~TYP[2]]~THEN~ARG[2]~ELSE~ARG[3]~FI~FI; - BlackBox: name: Clash.Sized.Internal.BitVector.minus# kind: Declaration type: 'minus# :: (KnownNat m, KnownNat n) => BitVector m -> BitVector n -> BitVector (Max m n + 1)' template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THEN~ARG[2] - ~ARG[3]~ELSE~IF~SIZE[~TYP[2]]~THEN~ARG[2]~ELSE-~ARG[3]~FI~FI; - BlackBox: name: Clash.Sized.Internal.BitVector.times# kind: Declaration type: 'times# :: (KnownNat m, KnownNat n) => BitVector m -> BitVector n -> BitVector (m + n)' template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THEN~ARG[2] * ~ARG[3]~ELSE~SIZE[~TYPO]'d0~FI; - BlackBox: name: Clash.Sized.Internal.BitVector.quot# kind: Expression type: 'quot# :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: ~ARG[1] / ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.rem# kind: Expression type: 'rem# :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: ~ARG[1] % ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.and# kind: Expression type: 'and# :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: ~ARG[1] & ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.or# kind: Expression type: 'or# :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: ~ARG[1] | ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.xor# kind: Expression type: 'xor# :: KnownNat => BitVector n -> BitVector n -> BitVector n' template: ~ARG[1] ^ ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.complement# kind: Expression type: 'complement# :: KnownNat n => BitVector n -> BitVector n' template: ~ ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.shiftL# kind: Expression type: 'shiftL# :: KnownNat n => BitVector n -> Int -> BitVector n' template: ~ARG[1] << ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.shiftR# kind: Expression type: 'shiftR# :: KnownNat n => BitVector n -> Int -> BitVector n' template: ~ARG[1] >> ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.truncateB# kind: Expression type: 'truncateB# :: forall a b . KnownNat a => BitVector (a + b) -> BitVector a' template: ~VAR[bv][1][0+:~SIZE[~TYPO]] workInfo: Never clash-lib-1.8.1/prims/commonverilog/Clash_Sized_Internal_Index.primitives.yaml0000644000000000000000000001115507346545000026016 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.Index.pack# kind: Expression type: 'pack# :: Index n -> BitVector (CLog 2 n)' template: ~ARG[0] workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.unpack# kind: Expression type: 'unpack# :: (KnownNat n, 1 <= n) => BitVector (CLog 2 n) -> Index n' template: ~ARG[2] workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.eq# kind: Expression type: 'eq# :: Index n -> Index n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] == ~ARG[1]~ELSE1'b1~FI - BlackBox: name: Clash.Sized.Internal.Index.neq# kind: Expression type: 'neq# :: Index n -> Index n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] != ~ARG[1]~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.Index.lt# kind: Expression type: 'lt# :: Index n -> Index n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.Index.ge# kind: Expression type: 'ge# :: Index n -> Index n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSE1'b1~FI - BlackBox: name: Clash.Sized.Internal.Index.gt# kind: Expression type: 'gt# :: Index n -> Index n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.Index.le# kind: Expression type: 'le# :: Index n -> Index n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSE1'b1~FI - BlackBox: name: Clash.Sized.Internal.Index.maxBound# kind: Expression type: 'maxBound# :: KnownNat n => Index n' template: ~ARG[0]-~SIZE[~TYPO]'d1 workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Index.fromEnum# kind: Expression type: 'fromEnum# :: KnownNat n => Index n -> Int' template: ~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[i][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.toEnum# kind: Expression type: 'toEnum# :: KnownNat n => Int -> Index n' template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[i][1]})~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.+# kind: Expression type: '(+#) :: KnownNat n => Index n -> Index n -> Index n' template: ~ARG[1] + ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Index.-# kind: Expression type: '(-#) :: KnownNat n => Index n -> Index n -> Index n' template: ~ARG[1] - ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Index.*# kind: Expression type: '(*#) :: KnownNat n => Index n -> Index n -> Index n' template: ~ARG[1] * ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Index.fromInteger# kind: Expression type: 'fromInteger# :: KnownNat n => Integer -> Index n' template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[i][1]})~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.plus# kind: Declaration type: Index m -> Index n -> Index (m + n - 1) template: assign ~RESULT = ~ARG[0] + ~ARG[1]; - BlackBox: name: Clash.Sized.Internal.Index.minus# kind: Declaration type: Index m -> Index n -> Index (m + n - 1) template: assign ~RESULT = ~ARG[0] - ~ARG[1]; - BlackBox: name: Clash.Sized.Internal.Index.times# kind: Declaration type: Index m -> Index n -> Index (((m-1) * (n-1)) + 1) template: assign ~RESULT = ~ARG[0] * ~ARG[1]; - BlackBox: name: Clash.Sized.Internal.Index.rem# kind: Expression type: 'rem# :: Index n -> Index n -> Index n' template: ~ARG[0] % ~ARG[1] - BlackBoxHaskell: name: Clash.Sized.Internal.Index.toInteger# templateFunction: Clash.Primitives.Sized.ToInteger.indexToIntegerVerilog workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.resize# kind: Expression type: 'resize# :: KnownNat m => Index n -> Index m' template: ~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN~VAR[bv][1][0+:~SIZE[~TYPO]]~ELSE{{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~ARG[1]}~FI~ELSE~SIZE[~TYPO]'d0~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.quot# kind: Expression type: 'quot# :: Index n -> Index n -> Index n' template: ~ARG[0] / ~ARG[1] clash-lib-1.8.1/prims/commonverilog/Clash_Sized_Internal_Signed.primitives.yaml0000644000000000000000000001554107346545000026163 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.Signed.eq# kind: Expression type: 'eq# :: Signed n -> Signed n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] == ~ARG[1]~ELSE1'b1~FI - BlackBox: name: Clash.Sized.Internal.Signed.neq# kind: Expression type: 'neq# :: Signed n -> Signed n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] != ~ARG[1]~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.Signed.lt# kind: Expression type: 'lt# :: Signed n -> Signed n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.Signed.ge# kind: Expression type: 'ge# :: Signed n -> Signed n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSE1'b1~FI - BlackBox: name: Clash.Sized.Internal.Signed.gt# kind: Expression type: 'gt# :: Signed n -> Signed n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.Signed.le# kind: Expression type: 'le# :: Signed n -> Signed n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSE1'b1~FI - BlackBoxHaskell: name: Clash.Sized.Internal.Signed.toInteger# templateFunction: Clash.Primitives.Sized.ToInteger.signedToIntegerVerilog workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.fromEnum# kind: Expression type: 'fromEnum# :: KnownNat n => Signed n -> Int' template: ~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$signed(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[i][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.size# kind: Expression type: 'size# :: KnownNat n => Signed n -> Int' template: ~SIZE[~TYPO]'sd~LIT[0] workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Signed.pack# kind: Expression type: 'pack# :: KnownNat n => Signed n -> BitVector n' template: $unsigned(~ARG[1]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.unpack# kind: Expression type: 'unpack# :: KnownNat n => BitVector n -> Signed n' template: $signed(~ARG[1]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.minBound# comment: Generates incorrect SV for n=0 kind: Expression type: 'minBound# :: KnownNat n => Signed n' template: $signed({1'b1, {(~LIT[0]-1) {1'b0}}}) workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Signed.maxBound# comment: Generates incorrect SV for n=0 kind: Expression type: 'maxBound# :: KnownNat n => Signed n' template: $signed({1'b0, {(~LIT[0]-1) {1'b1}}}) workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Signed.*# kind: Expression type: '(*#) :: KnownNat n => Signed n -> Signed n -> Signed n' template: ~ARG[1] * ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Signed.negate# kind: Expression type: 'negate# :: KnownNat n => Signed n -> Signed n' template: -~ARG[1] - BlackBox: name: Clash.Sized.Internal.Signed.abs# kind: Expression type: 'abs# :: KnownNat n => Signed n -> Signed n' template: '(~ARG[1] < ~LIT[0]''sd0) ? -~ARG[1] : ~ARG[1]' - BlackBox: name: Clash.Sized.Internal.Signed.fromInteger# kind: Expression type: 'fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat)' template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$signed(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[i][1]})~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.toEnum# kind: Expression type: 'toEnum# :: KnownNat n => Int -> Signed n' template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$signed(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[i][1]})~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.plus# kind: Declaration type: 'plus# :: Signed m -> Signed n -> Signed (1 + Max m n)' template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN~ARG[0] + ~ARG[1]~ELSE~IF~SIZE[~TYP[0]]~THEN~ARG[0]~ELSE~ARG[1]~FI~FI; - BlackBox: name: Clash.Sized.Internal.Signed.minus# kind: Declaration type: 'minus# :: Signed m -> Signed n -> Signed (1 + Max m n)' template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN ~ARG[0] - ~ARG[1]~ELSE~IF~SIZE[~TYP[0]]~THEN ~ARG[0]~ELSE - ~ARG[1] ~FI~FI; - BlackBox: name: Clash.Sized.Internal.Signed.times# kind: Declaration type: 'times# :: Signed m -> Signed n -> Signed (m + n)' template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN~ARG[0] * ~ARG[1]~ELSE~SIZE[~TYPO]'d0~FI; - BlackBox: name: Clash.Sized.Internal.Signed.rem# kind: Expression type: 'rem# :: Signed n -> Signed n -> Signed n' template: ~ARG[0] % ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Signed.and# kind: Expression type: 'and# :: KnownNat n => Signed n -> Signed n -> Signed n' template: ~ARG[1] & ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Signed.or# kind: Expression type: 'or# :: KnownNat n => Signed n -> Signed n -> Signed n' template: ~ARG[1] | ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Signed.xor# kind: Expression type: 'xor# :: KnownNat n => Signed n -> Signed n -> Signed n' template: ~ARG[1] ^ ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Signed.complement# kind: Expression type: 'complement# :: KnownNat n => Signed n -> Signed n' template: ~ ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Signed.shiftL# kind: Expression type: 'shiftL# :: KnownNat n => Signed n -> Int -> Signed n' template: ~ARG[1] <<< ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Signed.shiftR# kind: Expression type: 'shiftR# :: KnownNat n => Signed n -> Int -> Signed n' template: ~ARG[1] >>> ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Signed.truncateB# kind: Expression type: 'truncateB# :: KnownNat m => Signed (n + m) -> Signed m' template: $signed(~VAR[s][1][0+:~SIZE[~TYPO]]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.resize# kind: Expression type: 'resize# :: (KnownNat n, KnownNat m) => Signed n -> Signed m' template: ~IF~SIZE[~TYP[2]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[2]]]~THEN$signed({~VAR[s][2][~LIT[0]-1],~VAR[s][2][0+:(~SIZE[~TYPO]-1)]})~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[2]]) {~VAR[s][2][~LIT[0]-1]}},~VAR[s][2]})~FI~ELSE~SIZE[~TYPO]'sd0~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.quot# kind: Expression type: 'quot# :: KnownNat n => Signed n -> Signed n -> Signed n' template: ~ARG[1] / ~ARG[2] clash-lib-1.8.1/prims/commonverilog/Clash_Sized_Internal_Unsigned.primitives.yaml0000644000000000000000000001451507346545000026526 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.Unsigned.eq# kind: Expression type: 'eq# :: Unsigned n -> Unsigned n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] == ~ARG[1]~ELSE1'b1~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.neq# kind: Expression type: 'neq# :: Unsigned n -> Unsigned n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] != ~ARG[1]~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.lt# kind: Expression type: 'lt# :: Unsigned n -> Unsigned n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.ge# kind: Expression type: 'ge# :: Unsigned n -> Unsigned n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSE1'b1~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.gt# kind: Expression type: 'gt# :: Unsigned n -> Unsigned n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSE1'b0~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.le# kind: Expression type: 'le# :: Unsigned n -> Unsigned n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSE1'b1~FI - BlackBoxHaskell: name: Clash.Sized.Internal.Unsigned.toInteger# templateFunction: Clash.Primitives.Sized.ToInteger.unsignedToIntegerVerilog workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.fromEnum# kind: Expression type: 'fromEnum# :: KnownNat n => Unsigned n -> Int' template: ~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[i][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.size# kind: Expression type: 'size# :: KnownNat n => Unsigned n -> Int' template: ~SIZE[~TYPO]'sd~LIT[0] workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Unsigned.pack# kind: Expression type: 'pack# :: Unsigned n -> BitVector n' template: ~ARG[0] workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.unpack# kind: Expression type: 'unpack# :: KnownNat n => BitVector n -> Unsigned n' template: ~ARG[1] workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.minBound# kind: Expression type: 'minBound# :: Unsigned n' template: ~SIZE[~TYPO]'d0 workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Unsigned.maxBound# kind: Expression type: 'maxBound# :: KnownNat n => Unsigned n' template: '{~LIT[0] {1''b1}}' workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Unsigned.*# kind: Expression type: '(*#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n' template: ~ARG[1] * ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Unsigned.negate# kind: Expression type: 'negate# :: KnownNat n => Unsigned n -> Unsigned n' template: '- ~ARG[1]' - BlackBox: name: Clash.Sized.Internal.Unsigned.fromInteger# kind: Expression type: 'fromInteger# :: KnownNat n => Integer -> Unsigned n' template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[i][1]})~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.toEnum# kind: Expression type: 'toEnum# :: KnownNat n => Int -> Unsigned n' template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[i][1]})~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.plus# kind: Declaration type: 'plus# :: Unsigned m -> Unsigned n -> Unsigned (1 + Max m n)' template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN~ARG[0] + ~ARG[1]~ELSE~IF~SIZE[~TYP[0]]~THEN~ARG[0]~ELSE~ARG[1]~FI~FI; - BlackBox: name: Clash.Sized.Internal.Unsigned.minus# kind: Declaration type: 'minus# :: (KnownNat m, KnownNat n) => Unsigned m -> Unsigned n -> Unsigned (1 + Max m n)' template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THEN ~ARG[2] - ~ARG[3]~ELSE~IF~SIZE[~TYP[2]]~THEN ~ARG[2]~ELSE - ~ARG[3]~FI~FI; - BlackBox: name: Clash.Sized.Internal.Unsigned.times# kind: Declaration type: 'times# :: Unsigned m -> Unsigned n -> Unsigned (m + n)' template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN~ARG[0] * ~ARG[1]~ELSE~SIZE[~TYPO]'d0~FI; - BlackBox: name: Clash.Sized.Internal.Unsigned.rem# kind: Expression type: 'rem# :: Unsigned n -> Unsigned n -> Unsigned n' template: ~ARG[0] % ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Unsigned.and# kind: Expression type: 'and# :: Unsigned n -> Unsigned n -> Unsigned n' template: ~ARG[0] & ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Unsigned.or# kind: Expression type: 'or# :: Unsigned n -> Unsigned n -> Unsigned n' template: ~ARG[0] | ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Unsigned.xor# kind: Expression type: 'xor# :: Unsigned n -> Unsigned n -> Unsigned n' template: ~ARG[0] ^ ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Unsigned.complement# kind: Expression type: 'complement# :: KnownNat n => Unsigned n -> Unsigned n' template: ~ ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Unsigned.shiftL# kind: Expression type: 'shiftL# :: KnownNat n => Unsigned n -> Int -> Unsigned n' template: ~ARG[1] << ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Unsigned.shiftR# kind: Expression type: 'shiftR# :: KnownNat n => Unsigned n -> Int -> Unsigned n' template: ~ARG[1] >> ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Unsigned.resize# kind: Expression type: 'resize# :: KnownNat m => Unsigned n -> Unsigned m' template: ~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN~VAR[bv][1][0+:~SIZE[~TYPO]]~ELSE{{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~ARG[1]}~FI~ELSE~SIZE[~TYPO]'d0~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.quot# kind: Expression type: 'quot# :: Unsigned n -> Unsigned n -> Unsigned n' template: ~ARG[0] / ~ARG[1] clash-lib-1.8.1/prims/commonverilog/Clash_Sized_Vector.primitives.yaml0000644000000000000000000000061307346545000024352 0ustar0000000000000000- BlackBox: name: Clash.Sized.Vector.maxIndex kind: Expression type: 'maxIndex :: KnownNat n => Vec n a -> Int' template: ~SIZE[~TYPO]'sd~LIT[0] - ~SIZE[~TYPO]'sd1 workInfo: Constant - BlackBox: name: Clash.Sized.Vector.length kind: Expression type: 'length :: KnownNat n => Vec n a -> Int' template: ~SIZE[~TYPO]'sd~LIT[0] workInfo: Constant clash-lib-1.8.1/prims/commonverilog/GHC_Base.primitives.yaml0000644000000000000000000000042407346545000022173 0ustar0000000000000000- BlackBox: name: GHC.Base.remInt kind: Expression type: 'remInt :: Int -> Int -> Int' template: ~ARG[0] % ~ARG[1] - BlackBox: name: GHC.Base.quotInt kind: Expression type: 'quotInt :: Int -> Int -> Int' template: ~ARG[0] / ~ARG[1] clash-lib-1.8.1/prims/commonverilog/GHC_Classes.primitives.yaml0000644000000000000000000000124307346545000022716 0ustar0000000000000000- BlackBox: name: GHC.Classes.eqInt kind: Expression type: 'eqInt :: Int -> Int -> Bool' template: ~ARG[0] == ~ARG[1] - BlackBox: name: GHC.Classes.neInt kind: Expression type: 'neInt :: Int -> Int -> Bool' template: ~ARG[0] != ~ARG[1] - BlackBox: name: GHC.Classes.&& kind: Expression type: '(&&) :: Bool -> Bool -> Bool' template: ~ARG[0] & ~ARG[1] - BlackBox: name: GHC.Classes.|| kind: Expression type: '(||) :: Bool -> Bool -> Bool' template: ~ARG[0] | ~ARG[1] - BlackBox: name: GHC.Classes.not kind: Expression type: 'not :: Bool -> Bool' template: ~ ~ARG[0] clash-lib-1.8.1/prims/commonverilog/GHC_Int.primitives.yaml0000644000000000000000000000071307346545000022054 0ustar0000000000000000- BlackBoxHaskell: name: GHC.Int.I8# templateFunction: Clash.Primitives.GHC.Int.intTF workInfo: Never - BlackBoxHaskell: name: GHC.Int.I16# templateFunction: Clash.Primitives.GHC.Int.intTF workInfo: Never - BlackBoxHaskell: name: GHC.Int.I32# templateFunction: Clash.Primitives.GHC.Int.intTF workInfo: Never - BlackBoxHaskell: name: GHC.Int.I64# templateFunction: Clash.Primitives.GHC.Int.intTF workInfo: Never clash-lib-1.8.1/prims/commonverilog/GHC_Integer_Logarithms.primitives.yaml0000644000000000000000000000135507346545000025113 0ustar0000000000000000- BlackBox: name: GHC.Integer.Logarithms.integerLogBase# imports: - ~INCLUDENAME[0].inc includes: - name: integerLogBase extension: inc template: |- // integer logBase function integer ~INCLUDENAME[0]; input integer base, value; begin for (~INCLUDENAME[0] = 0; value >= base; ~INCLUDENAME[0]=~INCLUDENAME[0]+1) value = value / base; end endfunction kind: Expression type: 'integerLogBase# :: Integer -> Integer -> Int#' template: ~INCLUDENAME[0](~ARG[0],~ARG[1]) warning: 'GHC.Integer.Logarithms.integerLogBase#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' clash-lib-1.8.1/prims/commonverilog/GHC_Integer_Type.primitives.yaml0000644000000000000000000002141707346545000023724 0ustar0000000000000000- BlackBox: name: GHC.Integer.Type.smallInteger kind: Declaration type: 'smallInteger :: Int# -> Integer' template: assign ~RESULT = $signed(~ARG[0]); warning: 'GHC.Integer.Type.smallInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Integer.Type.integerToInt kind: Declaration type: 'integerToInt :: Integer -> Int#' template: assign ~RESULT = $signed(~ARG[0]); warning: 'GHC.Integer.Type.integerToInt: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Integer.Type.timesInteger kind: Expression type: 'timesInteger :: Integer -> Integer -> Integer' template: ~ARG[0] * ~ARG[1] warning: 'GHC.Integer.Type.timesInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.negateInteger kind: Expression type: 'negateInteger :: Integer -> Integer' template: -~ARG[0] warning: 'GHC.Integer.Type.negateInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.absInteger kind: Expression type: 'absInteger :: Integer -> Integer' template: '(~ARG[0] < ~SIZE[~TYPO]''sd0) ? -~ARG[0] : ~ARG[0]' warning: 'GHC.Integer.Type.absInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.remInteger kind: Expression type: 'remInteger :: Integer -> Integer -> Integer' template: ~ARG[0] % ~ARG[1] warning: 'GHC.Integer.Type.remInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.eqInteger kind: Expression type: 'eqInteger :: Integer -> Integer -> Bool' template: ~ARG[0] == ~ARG[1] warning: 'GHC.Integer.Type.eqInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.neqInteger kind: Expression type: 'neqInteger :: Integer -> Integer -> Bool' template: ~ARG[0] != ~ARG[1] warning: 'GHC.Integer.Type.neqInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.eqInteger# kind: Expression type: 'eqInteger :: Integer -> Integer -> Bool' template: '(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' warning: 'GHC.Integer.Type.eqInteger#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.neqInteger# kind: Expression type: 'neqInteger :: Integer -> Integer -> Bool' template: '(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' warning: 'GHC.Integer.Type.neqInteger#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.leInteger# kind: Expression type: 'leInteger :: Integer -> Integer -> Bool' template: '(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' warning: 'GHC.Integer.Type.leInteger#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.gtInteger# kind: Expression type: 'gtInteger :: Integer -> Integer -> Bool' template: '(~ARG[0] > ~ARG[1] ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' warning: 'GHC.Integer.Type.gtInteger#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.ltInteger# kind: Expression type: 'ltInteger :: Integer -> Integer -> Bool' template: '(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' warning: 'GHC.Integer.Type.ltInteger#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.geInteger# kind: Expression type: 'geInteger :: Integer -> Integer -> Bool' template: '(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' warning: 'GHC.Integer.Type.geInteger#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.shiftRInteger kind: Expression type: 'shiftRInteger :: Integer -> Int# -> Integer' template: ~ARG[0] >>> ~ARG[1] warning: 'GHC.Integer.Type.shiftRInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.shiftLInteger kind: Expression type: 'shiftLInteger :: Integer -> Int# -> Integer' template: ~ARG[0] <<< ~ARG[1] warning: 'GHC.Integer.Type.shiftLInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.testBitInteger kind: Expression type: 'testBitInteger :: Integer -> Int# -> Bool' template: ~VAR[input][0][~ARG[1]] == 1'b1 warning: 'GHC.Integer.Type.testBitInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.wordToInteger kind: Declaration type: 'wordToInteger :: Word# -> Integer' template: assign ~RESULT = $signed(~ARG[0]); warning: 'GHC.Integer.Type.wordToInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Integer.Type.integerToWord kind: Declaration type: 'integerToWord :: Integer -> Word#' template: assign ~RESULT = $unsigned(~ARG[0]); warning: 'GHC.Integer.Type.integerToWord: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Integer.Type.integerToWord64 comment: only used by 32 bit GHC kind: Declaration type: 'integerToWord :: Integer -> Word64#' template: assign ~RESULT = $unsigned(~ARG[0]); warning: 'GHC.Integer.Type.integerToWord64: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Integer.Type.bitInteger kind: Expression type: 'bitInteger :: Int -> Integer' template: 1 << ~ARG[0] warning: 'GHC.Integer.Type.bitInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.complementInteger kind: Expression type: 'complementInteger :: Integer -> Integer' template: ~ ~ARG[0] warning: 'GHC.Integer.Type.complementInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.xorInteger kind: Expression type: 'xorInteger :: Integer -> Integer -> Integer' template: ~ARG[0] ^ ~ARG[1] warning: 'GHC.Integer.Type.xorInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.orInteger kind: Expression type: 'orInteger :: Integer -> Integer -> Integer' template: ~ARG[0] | ~ARG[1] warning: 'GHC.Integer.Type.orInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.andInteger kind: Expression type: 'andInteger :: Integer -> Integer -> Integer' template: ~ARG[0] & ~ARG[1] warning: 'GHC.Integer.Type.andInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.$wsignumInteger kind: Expression type: '$wsignumInteger :: Integer -> Integer' template: '(~ARG[0] < ~SIZE[~TYPO]''sd0) ? -~SIZE[~TYPO]''sd1 : ((~ARG[0] == ~SIZE[~TYPO]''sd0) ? ~SIZE[~TYPO]''sd0 : ~SIZE[~TYPO]''sd1)' warning: 'GHC.Integer.Type.$wsignumInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.quotInteger kind: Expression type: 'quotInteger :: Integer -> Integer -> Integer' template: ~ARG[0] / ~ARG[1] warning: 'GHC.Integer.Type.quotInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' clash-lib-1.8.1/prims/commonverilog/GHC_Natural.primitives.yaml0000644000000000000000000000175207346545000022734 0ustar0000000000000000- BlackBox: name: GHC.Natural.naturalFromInteger kind: Expression type: 'naturalFromInteger :: Integer -> Natural' template: $unsigned(~VAR[n][0][(~SIZE[~TYPO]-1):0]) warning: 'GHC.Natural.naturalFromInteger: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Natural.timesNatural kind: Expression type: 'timesNatural :: Natural -> Natural -> Natural' template: ~ARG[0] * ~ARG[1] warning: 'GHC.Natural.timesNatural: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Natural.wordToNatural# kind: Declaration type: 'wordToNatural# :: Word# -> Natural' template: assign ~RESULT = $unsigned(~ARG[0]); warning: 'GHC.Natural.wordToNatural#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never clash-lib-1.8.1/prims/commonverilog/GHC_Num_Integer.primitives.yaml0000644000000000000000000003000707346545000023535 0ustar0000000000000000- BlackBox: name: GHC.Num.Integer.integerToNatural kind: Expression type: 'integerToNatural :: Integer -> Natural' template: $unsigned(~VAR[n][0][(~SIZE[~TYPO]-1):0]) warning: 'GHC.Num.Integer.integerToNatural: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Integer.integerToNaturalThrow kind: Expression type: 'integerToNaturalThrow :: Integer -> Natural' template: '(~ARG[0] < ~SIZE[~TYP[0]]''d0 ? ~ERRORO: $unsigned(~VAR[n][0][(~SIZE[~TYPO]-1):0]))' warning: 'GHC.Num.Integer.integerToNaturalThrow: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Integer.integerToNaturalClamp kind: Expression type: 'integerToNatural :: Integer -> Natural' template: '(~ARG[0] < ~SIZE[~TYP[0]]''d0 ? ~SIZE[~TYPO]''d0 : $unsigned(~VAR[n][0][(~SIZE[~TYPO]-1):0]))' warning: 'GHC.Num.Integer.integerToNaturalClamp: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Integer.integerToInt# kind: Declaration type: 'integerToInt :: Integer -> Int#' template: assign ~RESULT = $signed(~ARG[0]); warning: 'GHC.Num.Integer.integerToInt#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Integer.integerMul kind: Expression type: 'integerMul :: Integer -> Integer -> Integer' template: ~ARG[0] * ~ARG[1] warning: 'GHC.Num.Integer.integerMul: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerNegate kind: Expression type: 'integerNegate :: Integer -> Integer' template: -~ARG[0] warning: 'GHC.Num.Integer.integerNegate: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerAbs kind: Expression type: 'integerAbs :: Integer -> Integer' template: '(~ARG[0] < ~SIZE[~TYPO]''sd0) ? -~ARG[0] : ~ARG[0]' warning: 'GHC.Num.Integer.integerAbs: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerRem kind: Expression type: 'integerRem :: Integer -> Integer -> Integer' template: ~ARG[0] % ~ARG[1] warning: 'GHC.Num.Integer.integerRem: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerEq kind: Expression type: 'integerEq :: Integer -> Integer -> Bool' template: ~ARG[0] == ~ARG[1] warning: 'GHC.Num.Integer.integerEq: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerNe kind: Expression type: 'integerNe :: Integer -> Integer -> Bool' template: ~ARG[0] != ~ARG[1] warning: 'GHC.Num.Integer.integerNe: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerEq# kind: Expression type: 'integerEq :: Integer -> Integer -> Int#' template: '(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' warning: 'GHC.Num.Integer.integerEq#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerNe# kind: Expression type: 'integerNe# :: Integer -> Integer -> Int#' template: '(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' warning: 'GHC.Num.Integer.integerNe#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerLe# kind: Expression type: 'integerLe :: Integer -> Integer -> Int#' template: '(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' warning: 'GHC.Num.Integer.integerLe#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerGt# kind: Expression type: 'integerGt# :: Integer -> Integer -> Int#' template: '(~ARG[0] > ~ARG[1] ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' warning: 'GHC.Num.Integer.integerGt#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerLt# kind: Expression type: 'integerLt# :: Integer -> Integer -> Int#' template: '(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' warning: 'GHC.Num.Integer.integerLt#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerGe# kind: Expression type: 'integerGe# :: Integer -> Integer -> Int#' template: '(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' warning: 'GHC.Num.Integer.integerGe#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerShiftR# kind: Expression type: 'integerShiftR :: Integer -> Word# -> Integer' template: ~ARG[0] >>> ~ARG[1] warning: 'GHC.Num.Integer.integerShiftR#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerShiftL# kind: Expression type: 'integerShiftL :: Integer -> Word# -> Integer' template: ~ARG[0] <<< ~ARG[1] warning: 'GHC.Num.Integer.integerShiftL#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerTestBit# kind: Expression type: 'integerTestBit :: Integer -> Word# -> Bool' template: ~VAR[input][0][~ARG[1]] == 1'b1 warning: 'GHC.Num.Integer.integerTestBit#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerFromWord# kind: Declaration type: 'integerFromWord# :: Word# -> Integer' template: assign ~RESULT = $signed(~ARG[0]); warning: 'GHC.Num.Integer.integerFromWord#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Integer.integerToWord# kind: Declaration type: 'integerToWord# :: Integer -> Word#' template: assign ~RESULT = $unsigned(~ARG[0]); warning: 'GHC.Num.Integer.integerToWord#: Integers are dynamically sized in simulation, 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 type: 'integerToWord64# :: Integer -> Word64#' template: assign ~RESULT = $unsigned(~ARG[0]); warning: 'GHC.Num.Integer.integerToWord64#: Integers are dynamically sized in 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# :: Word# -> Integer' template: 1 << ~ARG[0] warning: 'GHC.Num.Integer.integerBit#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerComplement kind: Expression type: 'integerComplement :: Integer -> Integer' template: ~ ~ARG[0] warning: 'GHC.Num.Integer.integerComplement: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerXor kind: Expression type: 'integerXor :: Integer -> Integer -> Integer' template: ~ARG[0] ^ ~ARG[1] warning: 'GHC.Num.Integer.integerXor: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerOr kind: Expression type: 'integerOr :: Integer -> Integer -> Integer' template: ~ARG[0] | ~ARG[1] warning: 'GHC.Num.Integer.integerOr: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerAnd kind: Expression type: 'andInteger :: Integer -> Integer -> Integer' template: ~ARG[0] & ~ARG[1] warning: 'GHC.Num.Integer.integerAnd: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerSignum kind: Expression type: 'integerSignum :: Integer -> Integer' template: '(~ARG[0] < ~SIZE[~TYPO]''sd0) ? -~SIZE[~TYPO]''sd1 : ((~ARG[0] == ~SIZE[~TYPO]''sd0) ? ~SIZE[~TYPO]''sd0 : ~SIZE[~TYPO]''sd1)' warning: 'GHC.Num.Integer.integerSignum: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.$wintegerSignum kind: Expression type: 'integerSignum :: Integer -> Int#' template: '(~ARG[0] < ~SIZE[~TYPO]''sd0) ? -~SIZE[~TYPO]''sd1 : ((~ARG[0] == ~SIZE[~TYPO]''sd0) ? ~SIZE[~TYPO]''sd0 : ~SIZE[~TYPO]''sd1)' warning: 'GHC.Num.Integer.$wintegerSignum: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerLogBase# imports: - ~INCLUDENAME[0].inc includes: - name: integerLogBase extension: inc template: |- // integer logBase function integer ~INCLUDENAME[0]; input integer base, value; begin for (~INCLUDENAME[0] = 0; value >= base; ~INCLUDENAME[0]=~INCLUDENAME[0]+1) value = value / base; end endfunction kind: Expression type: 'integerLogBase# :: Integer -> Integer -> Word#' template: ~INCLUDENAME[0](~ARG[0],~ARG[1]) warning: 'GHC.Num.Integer.integerLogBase#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerCompare kind: Expression type: 'integerCompare :: Integer -> Integer -> Ordering' template: '(~ARG[0] < ~ARG[1]) ? -~SIZE[~TYPO]''d0 : ((~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d2)' warning: 'GHC.Num.Integer.integerCompare: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerQuot kind: Expression type: 'integerQuot :: Integer -> Integer -> Integer' 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 clash-lib-1.8.1/prims/commonverilog/GHC_Num_Natural.primitives.yaml0000644000000000000000000001204407346545000023547 0ustar0000000000000000- BlackBox: name: GHC.Num.Natural.naturalMul kind: Expression type: 'naturalMul :: Natural -> Natural -> Natural' template: ~ARG[0] * ~ARG[1] warning: 'GHC.Num.Natural.naturalMul: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalFromWord# kind: Declaration type: 'naturalFromWord# :: Word# -> Natural' template: assign ~RESULT = $unsigned(~ARG[0]); warning: 'GHC.Num.Natural.naturalFromWord#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Natural.naturalRem kind: Expression type: 'naturalRem :: Natural -> Natural -> Natural' template: ~ARG[0] % ~ARG[1] warning: 'GHC.Num.Natural.naturalRem: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalLogBase# imports: - ~INCLUDENAME[0].inc includes: - name: naturalLogBase extension: inc template: |- // natural logBase function integer ~INCLUDENAME[0]; input [~SIZE[~TYP[0]]-1:0] base, value; begin for (~INCLUDENAME[0] = 0; value >= base; ~INCLUDENAME[0]=~INCLUDENAME[0]+1) value = value / base; end endfunction kind: Expression type: 'naturalLogBase# :: Natural -> Natural -> Word#' template: ~INCLUDENAME[0](~ARG[0],~ARG[1]) warning: 'GHC.Num.Natural.naturalLogBase#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalEq# kind: Expression type: 'naturalEq :: Natural -> Natural -> Int#' template: '(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d0' warning: 'GHC.Num.Natural.naturalEq#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalNe# kind: Expression type: 'naturalNe# :: Natural -> Natural -> Int#' template: '(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d0' warning: 'GHC.Num.Natural.naturalNe#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalLe# kind: Expression type: 'naturalLe :: Natural -> Natural -> Int#' template: '(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d0' warning: 'GHC.Num.Natural.naturalLe#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalGt# kind: Expression type: 'naturalGt# :: Natural -> Natural -> Int#' template: '(~ARG[0] > ~ARG[1] ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d0' warning: 'GHC.Num.Natural.naturalGt#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalLt# kind: Expression type: 'naturalLt# :: Natural -> Natural -> Int#' template: '(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d0' warning: 'GHC.Num.Natural.naturalLt#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalGe# kind: Expression type: 'naturalGe# :: Natural -> Natural -> Int#' template: '(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d0' warning: 'GHC.Num.Natural.naturalGe#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalShiftL# kind: Expression type: 'naturalShiftL# :: Natural -> Word# -> Natural' template: ~ARG[0] <<< ~ARG[1] warning: 'GHC.Num.Natural.naturalShiftL#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalShiftR# kind: Expression type: 'naturalShiftR# :: Natuarl -> Word# -> Natural' template: ~ARG[0] >>> ~ARG[1] warning: 'GHC.Num.Natural.naturalShiftR#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.NaturalCompare kind: Expression type: 'naturalCompare :: Natural -> Natural -> Ordering' template: '(~ARG[0] < ~ARG[1]) ? -~SIZE[~TYPO]''d0 : ((~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d2)' warning: 'GHC.Num.Natural.naturalCompare: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalQuot kind: Expression type: 'naturalQuot :: Natural -> Natural -> Natural' template: ~ARG[0] / ~ARG[1] warning: 'GHC.Num.Natural.naturalQuot: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' clash-lib-1.8.1/prims/commonverilog/GHC_Prim.primitives.yaml0000644000000000000000000007050307346545000022235 0ustar0000000000000000- BlackBox: name: GHC.Prim.gtChar# kind: Expression type: 'gtChar# :: Char# -> Char# -> Int#' template: '(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.geChar# kind: Expression type: 'geChar# :: Char# -> Char# -> Int#' template: '(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.eqChar# kind: Expression type: 'eqChar# :: Char# -> Char# -> Int#' template: '(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.neChar# kind: Expression type: 'neChar# :: Char# -> Char# -> Int#' template: '(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.ltChar# kind: Expression type: 'ltChar# :: Char# -> Char# -> Int#' template: '(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.leChar# kind: Expression type: 'leChar# :: Char# -> Char# -> Int#' template: '(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.ord# kind: Expression type: 'ord :: Char# -> Int#' template: $signed({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[c][0]}) - BlackBox: name: GHC.Prim.*# kind: Expression type: '(*#) :: Int# -> Int# -> Int#' template: ~ARG[0] * ~ARG[1] - BlackBox: name: GHC.Prim.remInt# kind: Expression type: 'remInt# :: Int# -> Int# -> Int#' template: ~ARG[0] % ~ARG[1] - BlackBox: name: GHC.Prim.andI# kind: Expression type: 'andI# :: Int# -> Int# -> Int#' template: ~ARG[0] & ~ARG[1] - BlackBox: name: GHC.Prim.orI# kind: Expression type: 'orI# :: Int# -> Int# -> Int#' template: ~ARG[0] | ~ARG[1] - BlackBox: name: GHC.Prim.xorI# kind: Expression type: 'xorI# :: Int# -> Int# -> Int#' template: ~ARG[0] ^ ~ARG[1] - BlackBox: name: GHC.Prim.notI# kind: Expression type: 'notI# :: Int# -> Int#' template: ~ ~ARG[0] - BlackBox: name: GHC.Prim.negateInt# kind: Expression type: 'negateInt# :: Int# -> Int#' template: -(~ARG[0]) - BlackBox: name: GHC.Prim.># kind: Expression type: '(>#) :: Int# -> Int# -> Int#' template: '(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.>=# kind: Expression type: '(>=#) :: Int# -> Int# -> Int#' template: '(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.==# kind: Expression type: '(==) :: Int# -> Int# -> Int#' template: '(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim./=# kind: Expression type: '(/=#) :: Int# -> Int# -> Int#' template: '(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.<# kind: Expression type: '(<#) :: Int# -> Int# -> Int#' template: '(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.<=# kind: Expression type: '(<=#) :: Int# -> Int# -> Int#' template: '(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.chr# kind: Expression type: 'ord :: Int# -> Char#' template: $unsigned(~VAR[i][0][0+:~SIZE[~TYPO]]) - BlackBox: name: GHC.Prim.int2Word# kind: Expression type: 'int2Word# :: Int# -> Word#' template: $unsigned(~ARG[0]) workInfo: Never - BlackBox: name: GHC.Prim.uncheckedIShiftL# kind: Expression type: 'uncheckedIShiftL# :: Int# -> Int# -> Int#' template: ~ARG[0] <<< ~ARG[1] - BlackBox: name: GHC.Prim.uncheckedIShiftRA# kind: Expression type: 'uncheckedIShiftRA# :: Int# -> Int# -> Int#' template: ~ARG[0] >>> ~ARG[1] - BlackBox: name: GHC.Prim.uncheckedIShiftRL# kind: Expression type: 'uncheckedIShiftRL# :: Int# -> Int# -> Int#' template: ~ARG[0] >> ~ARG[1] - BlackBox: name: GHC.Prim.timesWord# kind: Expression type: 'timesWord# :: Word# -> Word# -> Word#' template: ~ARG[0] * ~ARG[1] - BlackBox: name: GHC.Prim.remWord# kind: Expression type: 'remWord# :: Word# -> Word# -> Word#' template: ~ARG[0] % ~ARG[1] - BlackBox: name: GHC.Prim.and# kind: Expression type: 'and# :: Word# -> Word# -> Word#' template: ~ARG[0] & ~ARG[1] - BlackBox: name: GHC.Prim.or# kind: Expression type: 'or# :: Word# -> Word# -> Word#' template: ~ARG[0] | ~ARG[1] - BlackBox: name: GHC.Prim.xor# kind: Expression type: 'xor# :: Word# -> Word# -> Word#' template: ~ARG[0] ^ ~ARG[1] - BlackBox: name: GHC.Prim.not# kind: Expression type: 'not# :: Word# -> Word#' template: ~ ~ARG[0] - BlackBox: name: GHC.Prim.uncheckedShiftL# kind: Expression type: 'uncheckedShiftL# :: Word# -> Int# -> Word#' template: ~ARG[0] << ~ARG[1] - BlackBox: name: GHC.Prim.uncheckedShiftRL# kind: Expression type: 'uncheckedShiftRL# :: Word# -> Int# -> Word#' template: ~ARG[0] >> ~ARG[1] - BlackBox: name: GHC.Prim.word2Int# kind: Expression type: 'int2Word# :: Word# -> Int#' template: $signed(~ARG[0]) workInfo: Never - BlackBox: name: GHC.Prim.gtWord# kind: Expression type: 'gtWord# :: Word# -> Word# -> Int#' template: '(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.geWord# kind: Expression type: 'geWord# :: Word# -> Word# -> Int#' template: '(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.eqWord# kind: Expression type: 'eqWord# :: Word# -> Word# -> Int#' template: '(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.neWord# kind: Expression type: 'neWord# :: Word# -> Word# -> Int#' template: '(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.ltWord# kind: Expression type: 'ltWord# :: Word# -> Word# -> Int#' template: '(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.leWord# kind: Expression type: 'leWord# :: Word# -> Word# -> Int#' template: '(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0' - BlackBox: name: GHC.Prim.byteSwap16# kind: Declaration type: 'byteSwap16# :: Word# -> Word#' template: |- // byteSwap16 begin~IF ~IW64 ~THEN assign ~RESULT = {~VAR[w][0][63:16],~VAR[w][0][7:0],~VAR[w][0][15:8]};~ELSE assign ~RESULT = {~VAR[w][0][31:16],~VAR[w][0][7:0],~VAR[w][0][15:8]};~FI // byteSwap16 end workInfo: Never - BlackBox: name: GHC.Prim.byteSwap32# kind: Declaration type: 'byteSwap32# :: Word# -> Word#' template: |- // byteSwap32 begin~IF ~IW64 ~THEN assign ~RESULT = {~VAR[w][0][63:32],~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]};~ELSE assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]};~FI // byteSwap32 end workInfo: Never - BlackBox: name: GHC.Prim.byteSwap64# kind: Declaration type: 'byteSwap64# :: Word# -> Word#' template: |- // byteSwap64 begin assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24] ,~VAR[w][0][39:32],~VAR[w][0][47:40],~VAR[w][0][55:48],~VAR[w][0][63:56]}; // byteSwap64 end workInfo: Never - BlackBox: name: GHC.Prim.byteSwap# kind: Declaration type: 'byteSwap# :: Word# -> Word#' template: |- // byteSwap begin~IF ~IW64 ~THEN assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24] ,~VAR[w][0][39:32],~VAR[w][0][47:40],~VAR[w][0][55:48],~VAR[w][0][63:56]};~ELSE assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]};~FI // byteSwap end workInfo: Never - BlackBox: name: GHC.Prim.narrow8Int# kind: Declaration type: 'narrow8Int# :: Int# -> Int#' template: |- // narrow8Int begin assign ~RESULT = $signed(~VAR[i][0][7:0]); // narrow8Int end workInfo: Never - BlackBox: name: GHC.Prim.narrow16Int# kind: Declaration type: 'narrow16Int# :: Int# -> Int#' template: |- // narrow16Int begin assign ~RESULT = $signed(~VAR[i][0][15:0]); // narrow16Int end workInfo: Never - BlackBox: name: GHC.Prim.narrow32Int# kind: Declaration type: 'narrow32Int# :: Int# -> Int#' template: |- // narrow32Int begin assign ~RESULT = $signed(~VAR[i][0][31:0]); // narrow32Int end workInfo: Never - BlackBox: name: GHC.Prim.narrow8Word# kind: Declaration type: 'narrow8Int# :: Word# -> Word#' template: |- // narrow8Word begin assign ~RESULT = $unsigned(~VAR[w][0][7:0]); // narrow8Word end workInfo: Never - BlackBox: name: GHC.Prim.narrow16Word# kind: Declaration type: 'narrow16Word# :: Word# -> Word#' template: |- // narrow16Word begin assign ~RESULT = $unsigned(~VAR[w][0][15:0]); // narrow16Word end workInfo: Never - BlackBox: name: GHC.Prim.narrow32Word# kind: Declaration type: 'narrow32Int# :: Word# -> Word#' template: |- // narrow32Word begin assign ~RESULT = $unsigned(~VAR[w][0][31:0]); // narrow32Word end workInfo: Never - BlackBox: name: GHC.Prim.bitReverse# kind: Declaration type: 'bitReverse# :: Word# -> Word#' template: |- // bitReverse begin genvar ~GENSYM[i][0]; ~GENERATE for (~SYM[0] = 0; ~SYM[0] < ~IF ~IW64 ~THEN 64 ~ELSE 32 ~FI; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse][2] assign ~RESULT[~SYM[0]] = ~VAR[x][0][~IF ~IW64 ~THEN 63 ~ELSE 31 ~FI-~SYM[0]]; end ~ENDGENERATE // bitReverse end workInfo: Never - BlackBox: name: GHC.Prim.bitReverse8# kind: Declaration type: 'bitReverse8# :: Word# -> Word#' template: |- // bitReverse8 begin genvar ~GENSYM[i][0]; ~GENERATE for (~SYM[0] = 0; ~SYM[0] < 8; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse8][2] assign ~RESULT[~SYM[0]] = ~VAR[x][0][7-~SYM[0]]; end ~ENDGENERATE // bitReverse8 end workInfo: Never - BlackBox: name: GHC.Prim.bitReverse16# kind: Declaration type: 'bitReverse16# :: Word# -> Word#' template: |- // bitReverse16 begin genvar ~GENSYM[i][0]; ~GENERATE for (~SYM[0] = 0; ~SYM[0] < 16; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse16][2] assign ~RESULT[~SYM[0]] = ~VAR[x][0][15-~SYM[0]]; end ~ENDGENERATE // bitReverse16 end workInfo: Never - BlackBox: name: GHC.Prim.bitReverse32# kind: Declaration type: 'bitReverse32# :: Word# -> Word#' template: |- // bitReverse32 begin genvar ~GENSYM[i][0]; ~GENERATE for (~SYM[0] = 0; ~SYM[0] < 32; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse32][2] assign ~RESULT[~SYM[0]] = ~VAR[x][0][31-~SYM[0]]; end ~ENDGENERATE // bitReverse32 end workInfo: Never - BlackBox: name: GHC.Prim.bitReverse64# kind: Declaration type: 'bitReverse64# :: Word# -> Word#' template: |- // bitReverse64 begin genvar ~GENSYM[i][0]; ~GENERATE for (~SYM[0] = 0; ~SYM[0] < 64; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse64][2] assign ~RESULT[~SYM[0]] = ~VAR[x][0][63-~SYM[0]]; end ~ENDGENERATE // bitReverse64 end workInfo: Never - BlackBox: name: GHC.Prim.quotInt# kind: Expression type: 'quotInt# :: Int# -> Int# -> Int#' template: ~ARG[0] / ~ARG[1] - BlackBox: name: GHC.Prim.quotWord# kind: Expression 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" clash-lib-1.8.1/prims/commonverilog/GHC_Word.primitives.yaml0000644000000000000000000000072707346545000022242 0ustar0000000000000000- BlackBoxHaskell: name: GHC.Word.W8# templateFunction: Clash.Primitives.GHC.Word.wordTF workInfo: Never - BlackBoxHaskell: name: GHC.Word.W16# templateFunction: Clash.Primitives.GHC.Word.wordTF workInfo: Never - BlackBoxHaskell: name: GHC.Word.W32# templateFunction: Clash.Primitives.GHC.Word.wordTF workInfo: Never - BlackBoxHaskell: name: GHC.Word.W64# templateFunction: Clash.Primitives.GHC.Word.wordTF workInfo: Never clash-lib-1.8.1/prims/systemverilog/0000755000000000000000000000000007346545000015616 5ustar0000000000000000clash-lib-1.8.1/prims/systemverilog/Clash_Explicit_BlockRam.primitives.yaml0000644000000000000000000001137407346545000025347 0ustar0000000000000000- BlackBox: name: Clash.Explicit.BlockRam.blockRam# kind: Declaration type: |- blockRam# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> Vec n a -- init, ARG[5] -> Signal dom Int -- rd, ARG[6] -> Signal dom Bool -- wren, ARG[7] -> Signal dom Int -- wr, ARG[8] -> Signal dom a -- din, ARG[9] -> Signal dom a template: |- // blockRam begin ~SIGD[~GENSYM[RAM][1]][5]; logic [~SIZE[~TYP[9]]-1:0] ~GENSYM[~RESULT_q][2]; initial begin ~SYM[1] = ~CONST[5]; end~IF ~ISACTIVEENABLE[4] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_blockRam][3]~IF ~VIVADO ~THEN if (~ARG[4]) begin if (~ARG[7]) begin ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]]; end ~SYM[2] <= ~SYM[1][~ARG[6]]; end~ELSE if (~ARG[7] & ~ARG[4]) begin ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]]; end if (~ARG[4]) begin ~SYM[2] <= ~SYM[1][~ARG[6]]; end~FI end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3] if (~ARG[7]) begin ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]]; end ~SYM[2] <= ~SYM[1][~ARG[6]]; end~FI assign ~RESULT = ~FROMBV[~SYM[2]][~TYP[9]]; // blockRam end - BlackBox: name: Clash.Explicit.BlockRam.blockRamU# kind: Declaration type: |- blockRamU# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> SNat n -- len, ARG[5] -> Signal dom Int -- rd, ARG[6] -> Signal dom Bool -- wren, ARG[7] -> Signal dom Int -- wr, ARG[8] -> Signal dom a -- din, ARG[9] -> Signal dom a template: |- // blockRamU begin, ~TYPO ~GENSYM[~RESULT_RAM][1] [0:~LIT[5]-1]; logic [~SIZE[~TYP[9]]-1:0] ~GENSYM[~RESULT_q][2];~IF ~ISACTIVEENABLE[4] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_blockRam][3]~IF ~VIVADO ~THEN if (~ARG[4]) begin if (~ARG[7]) begin ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]]; end ~SYM[2] <= ~SYM[1][~ARG[6]]; end~ELSE if (~ARG[7] & ~ARG[4]) begin ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]]; end if (~ARG[4]) begin ~SYM[2] <= ~SYM[1][~ARG[6]]; end~FI end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3] if (~ARG[7]) begin ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]]; end ~SYM[2] <= ~SYM[1][~ARG[6]]; end~FI assign ~RESULT = ~FROMBV[~SYM[2]][~TYP[9]]; // blockRamU end - BlackBox: name: Clash.Explicit.BlockRam.blockRam1# kind: Declaration type: |- blockRam1# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> SNat n -- len, ARG[5] -> a -- init, ARG[6] -> Signal dom Int -- rd, ARG[7] -> Signal dom Bool -- wren, ARG[8] -> Signal dom Int -- wr, ARG[9] -> Signal dom a -- din, ARG[10] -> Signal dom a template: |- // blockRam1 begin, ~TYPO ~GENSYM[~RESULT_RAM][1] [0:~LIT[5]-1]; logic [~SIZE[~TYP[10]]-1:0] ~GENSYM[~RESULT_q][2]; initial begin ~SYM[1] = '{default: ~CONST[6]}; end~IF ~ISACTIVEENABLE[4] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_blockRam][3]~IF ~VIVADO ~THEN if (~ARG[4]) begin if (~ARG[8]) begin ~SYM[1][~ARG[9]] <= ~TOBV[~ARG[10]][~TYP[10]]; end ~SYM[2] <= ~SYM[1][~ARG[7]]; end~ELSE if (~ARG[8] & ~ARG[4]) begin ~SYM[1][~ARG[9]] <= ~TOBV[~ARG[10]][~TYP[10]]; end if (~ARG[4]) begin ~SYM[2] <= ~SYM[1][~ARG[7]]; end~FI end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3] if (~ARG[8]) begin ~SYM[1][~ARG[9]] <= ~TOBV[~ARG[10]][~TYP[10]]; end ~SYM[2] <= ~SYM[1][~ARG[7]]; end~FI assign ~RESULT = ~FROMBV[~SYM[2]][~TYP[10]]; // blockRam1 end clash-lib-1.8.1/prims/systemverilog/Clash_Explicit_BlockRam_Blob.primitives.yaml0000644000000000000000000000303407346545000026277 0ustar0000000000000000- BlackBox: name: Clash.Explicit.BlockRam.Blob.blockRamBlob# kind: Declaration type: |- blockRamBlob# :: KnownDomain dom -- ARG[0] => Clock dom -- clk, ARG[1] -> Enable dom -- en, ARG[2] -> MemBlob n m -- init, ARG[3] -> Signal dom Int -- rd, ARG[4] -> Signal dom Bool -- wren, ARG[5] -> Signal dom Int -- wr, ARG[6] -> Signal dom (BitVector m) -- din, ARG[7] -> Signal dom (BitVector m) template: |- // blockRamBlob begin ~SIGD[~GENSYM[RAM][1]][3]; logic [~SIZE[~TYP[7]]-1:0] ~GENSYM[~RESULT_q][2]; initial begin ~SYM[1] = ~CONST[3]; end~IF ~ISACTIVEENABLE[2] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~GENSYM[~COMPNAME_blockRam][3]~IF ~VIVADO ~THEN if (~ARG[2]) begin if (~ARG[5]) begin ~SYM[1][~ARG[6]] <= ~ARG[7]; end ~SYM[2] <= ~SYM[1][~ARG[4]]; end~ELSE if (~ARG[5] & ~ARG[2]) begin ~SYM[1][~ARG[6]] <= ~ARG[7]; end if (~ARG[2]) begin ~SYM[2] <= ~SYM[1][~ARG[4]]; end~FI end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~SYM[3] if (~ARG[5]) begin ~SYM[1][~ARG[6]] <= ~ARG[7]; end ~SYM[2] <= ~SYM[1][~ARG[4]]; end~FI assign ~RESULT = ~SYM[2]; // blockRamBlob end clash-lib-1.8.1/prims/systemverilog/Clash_Explicit_BlockRam_File.primitives.yaml0000644000000000000000000000332607346545000026304 0ustar0000000000000000- BlackBox: name: Clash.Explicit.BlockRam.File.blockRamFile# kind: Declaration type: |- blockRamFile# :: ( KnownDomain dom -- ARG[0] , KnownNat m -- ARG[1] , HasCallStack ) -- ARG[2] => Clock dom -- clk, ARG[3] => Enable dom -- en, ARG[4] -> SNat n -- sz, ARG[5] -> FilePath -- file, ARG[6] -> Signal dom Int -- rd, ARG[7] -> Signal dom Bool -- wren, ARG[8] -> Signal dom Int -- wr, ARG[9] -> Signal dom (BitVector m) -- din, ARG[10] -> Signal dom (BitVector m) template: |- // blockRamFile begin ~SIGDO[~GENSYM[RAM][1]] [0:~LIT[5]-1]; ~SIGD[~GENSYM[~RESULT_q][2]][10]; initial begin $readmemb(~FILE[~LIT[6]],~SYM[1]); end ~IF ~ISACTIVEENABLE[4] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_blockRamFile][3]~IF ~VIVADO ~THEN if (~ARG[4]) begin if (~ARG[8]) begin ~SYM[1][~ARG[9]] <= ~ARG[10]; end ~SYM[2] <= ~SYM[1][~ARG[7]]; end~ELSE if (~ARG[8] & ~ARG[4]) begin ~SYM[1][~ARG[9]] <= ~ARG[10]; end if (~ARG[4]) begin ~SYM[2] <= ~SYM[1][~ARG[7]]; end~FI end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3] if (~ARG[8]) begin ~SYM[1][~ARG[9]] <= ~ARG[10]; end ~SYM[2] <= ~SYM[1][~ARG[7]]; end~FI assign ~RESULT = ~SYM[2]; // blockRamFile end clash-lib-1.8.1/prims/systemverilog/Clash_Explicit_DDR.primitives.yaml0000644000000000000000000001016607346545000024264 0ustar0000000000000000- BlackBox: name: Clash.Explicit.DDR.ddrIn# kind: Declaration type: |- ddrIn# :: forall a slow fast n pFast gated synchronous. ( HasCallStack -- ARG[0] , NFDataX a -- ARG[1] , KnownConfi~ fast domf -- ARG[2] , KnownConfi~ slow doms -- ARG[3] => Clock slow -- ARG[4], clk -> Reset slow -- ARG[5], rst -> Enable slow -- ARG[6], en -> a -- ARG[7] -> a -- ARG[8] -> a -- ARG[9] -> Signal fast a -- ARG[10] -> Signal slow (a,a) template: |- // ddrIn begin ~SIGD[~GENSYM[data_Pos][1]][9]; ~SIGD[~GENSYM[data_Neg][2]][9]; ~SIGD[~GENSYM[data_Neg_Latch][3]][9]; 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_ddrIn_pos][6] if (~IF~ISACTIVEHIGH[2]~THEN~ARG[5]~ELSE! ~ARG[5]~FI) begin ~SYM[1] <= ~ARG[8]; end else ~IF ~ISACTIVEENABLE[6] ~THEN if (~ARG[6]) ~ELSE ~FI begin ~SYM[1] <= ~ARG[10]; end end always @(~IF~ACTIVEEDGE[Rising][2]~THENnegedge~ELSEposedge~FI ~ARG[4]~IF~ISSYNC[3]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[5])~FI begin : ~GENSYM[~COMPNAME_ddrIn_neg][7] if (~IF~ISACTIVEHIGH[2]~THEN~ARG[5]~ELSE! ~ARG[5]~FI) begin ~SYM[2] <= ~ARG[9]; end else ~IF ~ISACTIVEENABLE[6] ~THEN if (~ARG[6]) ~ELSE ~FI begin ~SYM[2] <= ~ARG[10]; end end 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_ddrIn_neg_latch][8] if (~IF~ISACTIVEHIGH[2]~THEN~ARG[5]~ELSE! ~ARG[5]~FI) begin ~SYM[3] <= ~ARG[7]; end else ~IF ~ISACTIVEENABLE[6] ~THEN if (~ARG[6]) ~ELSE ~FI begin ~SYM[3] <= ~SYM[2]; end end assign ~RESULT = {~SYM[3], ~SYM[1]}; // ddrIn end - BlackBox: name: Clash.Explicit.DDR.ddrOut# kind: Declaration outputUsage: Blocking type: |- ddrOut# :: ( HasCallStack -- ARG[0] , NFDataX a -- ARG[1] , KnownConfi~ fast domf -- ARG[2] , KnownConfi~ slow doms -- ARG[3] => Clock slow -- ARG[4] -> Reset slow -- ARG[5] -> Enable slow -- ARG[6] -> a -- ARG[7] -> Signal slow a -- ARG[8] -> Signal slow a -- ARG[9] -> Signal fast a template: |- // ddrOut begin ~SIGD[~GENSYM[data_Pos][1]][7]; ~SIGD[~GENSYM[data_Neg][2]][7]; 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]; end else ~IF ~ISACTIVEENABLE[6] ~THEN if (~ARG[6]) ~ELSE ~FI begin ~SYM[1] <= ~ARG[8]; end end 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_neg][6] if (~IF~ISACTIVEHIGH[2]~THEN~ARG[5]~ELSE! ~ARG[5]~FI) begin ~SYM[2] <= ~ARG[7]; end else ~IF ~ISACTIVEENABLE[6] ~THEN if (~ARG[6]) ~ELSE ~FI begin ~SYM[2] <= ~ARG[9]; end end always @(*) begin if (~ARG[4]) begin ~RESULT = ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[1]~ELSE~SYM[2]~FI; end else begin ~RESULT = ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[2]~ELSE~SYM[1]~FI; end end // ddrOut end clash-lib-1.8.1/prims/systemverilog/Clash_Explicit_RAM.primitives.yaml0000644000000000000000000000222407346545000024266 0ustar0000000000000000- BlackBox: name: Clash.Explicit.RAM.asyncRam# kind: Declaration type: |- asyncRam# :: ( HasCallStack -- ARG[0] , KnownDomain wdom -- ARG[1] , KnownDomain rdom -- ARG[2] , NFDataX a ) -- ARG[3] => Clock wdom -- ^ wclk, ARG[4] -> Clock rdom -- ^ rclk, ARG[5] -> Enable wdom -- ^ wen, ARG[6] -> SNat n -- ^ sz, ARG[7] -> Signal rdom Int -- ^ rd, ARG[8] -> Signal wdom Bool -- ^ en, ARG[9] -> Signal wdom Int -- ^ wr, ARG[10] -> Signal wdom a -- ^ din, ARG[11] -> Signal rdom a template: |- // asyncRam begin logic [~SIZE[~TYP[11]]-1:0] ~GENSYM[RAM][0] [0:~LIT[7]-1]; always @(~IF~ACTIVEEDGE[Rising][1]~THENposedge~ELSEnegedge~FI ~ARG[4]) begin : ~GENSYM[~COMPNAME_Ram][1] if (~IF ~ISACTIVEENABLE[6] ~THEN ~ARG[6] & ~ELSE ~FI ~ARG[9]) begin ~SYM[0][~ARG[10]] <= ~TOBV[~ARG[11]][~TYP[11]]; end end assign ~RESULT = ~FROMBV[~SYM[0][\~ARG[8]\]][~TYPO]; // asyncRam end clash-lib-1.8.1/prims/systemverilog/Clash_Explicit_ROM.primitives.yaml0000644000000000000000000000201207346545000024277 0ustar0000000000000000- BlackBox: name: Clash.Explicit.ROM.rom# kind: Declaration type: |- rom# :: ( KnownDomain dom ARG[0] , KnownNat n -- ARG[1] , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] => Enable dom -- en, ARG[4] -> Vec n a -- init, ARG[5] -> Signal dom Int -- rd, ARG[6] -> Signal dom a template: |- // rom begin ~SIGD[~GENSYM[ROM][1]][5]; assign ~SYM[1] = ~LIT[5]; logic [~SIZE[~TYPO]-1:0] ~GENSYM[~RESULT_q][2];~IF ~ISACTIVEENABLE[4] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_rom][3] if (~ARG[4]) begin ~SYM[2] <= ~SYM[1][~ARG[6]]; end end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3] ~SYM[2] <= ~SYM[1][~ARG[6]]; end~FI assign ~RESULT = ~FROMBV[~SYM[2]][~TYPO]; // rom end clash-lib-1.8.1/prims/systemverilog/Clash_Explicit_ROM_Blob.primitives.yaml0000644000000000000000000000166407346545000025251 0ustar0000000000000000- BlackBox: name: Clash.Explicit.ROM.Blob.romBlob# kind: Declaration type: |- romBlob# :: KnownDomain dom -- ARG[0] => Clock dom -- clk, ARG[1] -> Enable dom -- en, ARG[2] -> MemBlob n m -- init, ARG[3] -> Signal dom Int -- rd, ARG[4] -> Signal dom (BitVector m) template: |- // romBlob begin ~SIGD[~GENSYM[ROM][1]][3]; assign ~SYM[1] = ~CONST[3]; logic [~SIZE[~TYPO]-1:0] ~GENSYM[~RESULT_q][2];~IF ~ISACTIVEENABLE[2] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~GENSYM[~COMPNAME_rom][3] if (~ARG[2]) begin ~SYM[2] <= ~SYM[1][~ARG[4]]; end end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~SYM[3] ~SYM[2] <= ~SYM[1][~ARG[4]]; end~FI assign ~RESULT = ~SYM[2]; // rom end clash-lib-1.8.1/prims/systemverilog/Clash_Explicit_ROM_File.primitives.yaml0000644000000000000000000000223707346545000025247 0ustar0000000000000000- BlackBox: name: Clash.Explicit.ROM.File.romFile# kind: Declaration type: |- romFile# :: ( KnownNat m -- ARG[0] , KnownDomain dom ) -- ARG[1] => Clock dom -- clk, ARG[2] -> Enable dom -- en, ARG[3] -> SNat n -- sz, ARG[4] -> FilePath -- file, ARG[5] -> Signal dom Int -- rd, ARG[6] -> Signal dom (BitVector m) template: |- // romFile begin ~SIGDO[~GENSYM[ROM][0]] [0:~LIT[4]-1]; initial begin $readmemb(~FILE[~LIT[5]],~SYM[0]); end ~SIGDO[~GENSYM[~RESULT_q][1]];~IF ~ISACTIVEENABLE[3] ~THEN always @(~IF~ACTIVEEDGE[Rising][1]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~GENSYM[~COMPNAME_romFile][2] if (~ARG[3]) begin ~SYM[1] <= ~SYM[0][~ARG[6]]; end end~ELSE always @(~IF~ACTIVEEDGE[Rising][1]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~SYM[2] ~SYM[1] <= ~SYM[0][~ARG[6]]; end~FI assign ~RESULT = ~SYM[1]; // romFile end clash-lib-1.8.1/prims/systemverilog/Clash_Explicit_Testbench.primitives.yaml0000644000000000000000000000443007346545000025567 0ustar0000000000000000- BlackBox: name: Clash.Explicit.Testbench.assert kind: Declaration type: |- assert :: (KnownDomain dom, Eq a, ShowX a) -- (ARG[0], ARG[1], ARG[2]) => Clock dom -- ARG[3] -> Reset dom -- ARG[4] -> String -- ARG[5] -> Signal dom a -- Checked value (ARG[6]) -> Signal dom a -- Expected value (ARG[7]) -> Signal dom b -- Return valued (ARG[8]) -> Signal dom b template: |- // assert begin // pragma translate_off always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin if (~ARG[6] !== ~ARG[7]) begin $display("@%0tns: %s, expected: %b, actual: %b", $time, ~LIT[5], ~TOBV[~ARG[7]][~TYP[7]], ~TOBV[~ARG[6]][~TYP[6]]); $stop; end end // pragma translate_on assign ~RESULT = ~ARG[8]; // assert end - BlackBox: name: Clash.Explicit.Testbench.assertBitVector kind: Declaration type: |- assertBitVector :: ( KnownDomain dom -- ARG[0] , KnownNat n ) -- ARG[1] => Clock dom -- ARG[2] -> Reset dom -- ARG[3] -> String -- ARG[4] -> Signal dom (BitVector n) -- Checked value (ARG[5]) -> Signal dom (BitVector n) -- Expected value (ARG[6]) -> Signal dom b -- Return valued (ARG[7]) -> Signal dom b template: |- // assertBitVector begin // pragma translate_off wire ~TYP[6] ~GENSYM[maskXor][0] = ~ARG[6] ^ ~ARG[6]; wire ~TYP[6] ~GENSYM[checked][1] = ~ARG[5] ^ ~SYM[0]; wire ~TYP[6] ~GENSYM[expected][2] = ~ARG[6] ^ ~SYM[0]; always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin if (~SYM[1] !== ~SYM[2]) begin $display("@%0tns: %s, expected: %b, actual: %b", $time, ~LIT[4], ~TOBV[~ARG[6]][~TYP[6]], ~TOBV[~ARG[5]][~TYP[5]]); $stop; end end // pragma translate_on assign ~RESULT = ~ARG[7]; // assertBitVector end clash-lib-1.8.1/prims/systemverilog/Clash_Intel_DDR.primitives.yaml0000644000000000000000000000273507346545000023561 0ustar0000000000000000- BlackBox: name: Clash.Intel.DDR.altddioIn kind: Declaration libraries: - altera_mf type: |- altddioIn :: ( HasCallStack -- ARG[0] , KnownConfi~ fast domf -- ARG[1] , KnownConfi~ slow doms -- ARG[2] , KnownNat m ) -- ARG[3] => SSymbol deviceFamily -- ARG[4] -> Clock slow -- ARG[5] -> Reset slow -- ARG[6] -> Enable slow -- ARG[7] -> Signal fast (BitVector m) -- ARG[8] -> Signal slow (BitVector m,BitVector m) template: |- // altddioIn begin ~SIGD[~GENSYM[dataout_l][1]][8]; ~SIGD[~GENSYM[dataout_h][2]][8]; altddio_in #( .intended_device_family (~LIT[4]), .invert_input_clocks ("OFF"), .lpm_hint ("UNUSED"), .lpm_type ("altddio_in"), .power_up_high ("OFF"), .width (~SIZE[~TYP[8]]) ) ~GENSYM[~COMPNAME_ALTDDIO_IN][7] (~IF ~ISSYNC[2] ~THEN .sclr (~ARG[6]), .aclr (1'b0),~ELSE .aclr (~ARG[6]), .sclr (1'b0),~FI .datain (~ARG[8]), .inclock (~ARG[5]), .inclocken (~IF ~ISACTIVEENABLE[7] ~THEN~ARG[7]~ELSE1'b1,~FI), .dataout_h (~SYM[2]), .dataout_l (~SYM[1]), .aset (1'b0), .sset (1'b0) ); assign ~RESULT = {~SYM[1],~SYM[2]}; // altddioIn end clash-lib-1.8.1/prims/systemverilog/Clash_Prelude_ROM.primitives.yaml0000644000000000000000000000067407346545000024132 0ustar0000000000000000- BlackBox: name: Clash.Prelude.ROM.asyncRom# kind: Declaration type: |- 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]][2]; assign ~SYM[0] = ~CONST[2]; assign ~RESULT = ~FROMBV[~SYM[0][\~ARG[3]\]][~TYPO]; // asyncRom end clash-lib-1.8.1/prims/systemverilog/Clash_Prelude_ROM_Blob.primitives.yaml0000644000000000000000000000060107346545000025056 0ustar0000000000000000- BlackBox: name: Clash.Prelude.ROM.Blob.asyncRomBlob# kind: Declaration type: |- asyncRomBlob# :: MemBlob n m -- ARG[0] -> Int -- ARG[1] -> BitVector m template: |- // asyncRomBlob begin ~SIGD[~GENSYM[ROM][0]][0]; assign ~SYM[0] = ~CONST[0]; assign ~RESULT = ~SYM[0][~ARG[1]]; // asyncRomBlob end clash-lib-1.8.1/prims/systemverilog/Clash_Prelude_ROM_File.primitives.yaml0000644000000000000000000000105207346545000025060 0ustar0000000000000000- BlackBox: name: Clash.Prelude.ROM.File.asyncRomFile# kind: Declaration type: |- asyncRomFile :: KnownNat m -- ARG[0] => SNat n -- sz, ARG[1] -> FilePath -- file, ARG[2] -> Int -- rd, ARG[3] -> BitVector m template: |- // asyncRomFile begin ~SIGDO[~GENSYM[ROM][0]] [0:~LIT[1]-1]; initial begin $readmemb(~FILE[~LIT[2]],~SYM[0]); end assign ~RESULT = ~SYM[0][~ARG[3]]; // asyncRomFile end clash-lib-1.8.1/prims/systemverilog/Clash_Signal_BiSignal.primitives.yaml0000644000000000000000000000174407346545000025001 0ustar0000000000000000- BlackBox: name: Clash.Signal.BiSignal.writeToBiSignal# kind: Declaration type: |- writeToBiSignal# :: HasCallStack -- ARG[0] => BiSignalIn ds d n -- ARG[1] -> Signal d (Maybe (BitVector n)) -- ARG[2] -> Signal d Bool -- ARG[3] -> Signal d (BitVector n) -- ARG[4] -> BiSignalOut ds d n renderVoid: RenderVoid template: |- // writeToBiSignal# begin assign ~ARG[1] = (~ARG[3] == 1'b1) ? ~ARG[4] : {~SIZE[~TYP[1]] {1'bz}}; // writeToBiSignal# end - BlackBox: name: Clash.Signal.BiSignal.readFromBiSignal# kind: Declaration type: |- readFromBiSignal# :: ( HasCallStack -- ARG[0] , KnownNat n) -- ARG[1] => BiSignalIn ds d n -- ARG[2] -> Signal d (BitVector n) template: |- // readFromBiSignal begin assign ~RESULT = ~ARG[2]; // readFromBiSignal end workInfo: Never clash-lib-1.8.1/prims/systemverilog/Clash_Signal_Internal.primitives.yaml0000644000000000000000000001740507346545000025066 0ustar0000000000000000- BlackBox: name: Clash.Signal.Internal.delay# kind: Declaration outputUsage: NonBlocking type: |- delay# :: ( KnownDomain dom -- ARG[0] , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Enable dom -- ARG[3] -> a -- ARG[4] -> Signal clk a -- ARG[5] -> Signal clk a resultInit: template: ~IF~ISINITDEFINED[0]~THEN~CONST[4]~ELSE~FI resultName: template: ~CTXNAME template: |- // delay begin~IF ~ISACTIVEENABLE[3] ~THEN always_ff @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~GENSYM[~RESULT_delay][1] if (~ARG[3]) begin ~RESULT <= ~ARG[5]; end end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~SYM[1] ~RESULT <= ~ARG[5]; end~FI // delay end - BlackBox: name: Clash.Signal.Internal.asyncRegister# kind: Declaration outputUsage: NonBlocking type: |- asyncRegister# :: ( KnownDomain dom -- ARG[0] , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Reset dom -- ARG[3] -> Enable dom -- ARG[4] -> a -- ARG[5] (powerup value) -> a -- ARG[6] (reset value) -> Signal clk a -- ARG[7] -> Signal clk a resultInit: template: ~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI resultName: template: ~CTXNAME template: |- // async register begin always_ff @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]~IF ~ISUNDEFINED[6] ~THEN ~ELSE or ~IF ~ISACTIVEHIGH[0] ~THEN posedge ~ELSE negedge ~FI ~VAR[rst][3]~FI) begin : ~GENSYM[~RESULT_register][1] ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI~VAR[rst][3]) begin ~RESULT <= ~CONST[6]; end else ~FI~IF ~ISACTIVEENABLE[4] ~THEN if (~ARG[4]) ~ELSE ~FI begin ~RESULT <= ~ARG[7]; end end // async register end - BlackBox: name: Clash.Signal.Internal.register# kind: Declaration outputUsage: NonBlocking type: |- register# :: ( KnownDomain dom -- ARG[0] , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Reset dom -- ARG[3] -> Enable dom -- ARG[4] -> a -- ARG[5] (powerup value) -> a -- ARG[6] (reset value) -> Signal clk a -- ARG[7] -> Signal clk a resultInit: template: ~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI resultName: template: ~CTXNAME template: |- // register begin always_ff @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]~IF ~ISSYNC[0] ~THEN ~ELSE~IF ~ISUNDEFINED[6] ~THEN ~ELSE or ~IF ~ISACTIVEHIGH[0] ~THEN posedge ~ELSE negedge ~FI ~VAR[rst][3]~FI~FI) begin : ~GENSYM[~RESULT_register][1] ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI~VAR[rst][3]) begin ~RESULT <= ~CONST[6]; end else ~FI~IF ~ISACTIVEENABLE[4] ~THEN if (~ARG[4]) ~ELSE ~FI begin ~RESULT <= ~ARG[7]; end end // register end - BlackBox: name: Clash.Signal.Internal.tbClockGen kind: Declaration outputUsage: Blocking 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~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,",(~ ~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 - 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 // 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: |- // resetGen begin // pragma translate_off localparam ~GENSYM[reset_period][0] = ~LONGESTPERIOD0 - 10 + (~LIT[2] * ~PERIOD[0]0); `ifndef VERILATOR initial begin #1 ~RESULT = ~IF ~ISACTIVEHIGH[0] ~THEN 1 ~ELSE 0 ~FI; #~SYM[0] ~RESULT = ~IF ~ISACTIVEHIGH[0] ~THEN 0 ~ELSE 1 ~FI; end `else always begin // The redundant (~RESULT | ~ ~RESULT) is needed to ensure that this is // calculated in every cycle by verilator. Without it, the reset will stop // being updated and will be stuck as asserted forever. ~RESULT = $c("this->~GENSYM[reset_gen][1](",~SYM[0],",~IF~ISACTIVEHIGH[0]~THENtrue~ELSEfalse~FI)") & (~RESULT | ~ ~RESULT); end `systemc_interface CData ~SYM[1](vluint32_t reset_period, bool active_high) { static vluint32_t to_wait = reset_period; static CData reset = active_high ? 1 : 0; static bool finished = false; if(!finished) { if(to_wait == 0) { reset = reset == 0 ? 1 : 0; finished = true; } else { to_wait = to_wait - 1; } } return reset; } `verilog `endif // pragma translate_on // resetGen end warning: Clash.Signal.Internal.resetGenN can not be synthesized to hardware! workInfo: Always clash-lib-1.8.1/prims/systemverilog/Clash_Sized_Internal_BitVector.primitives.yaml0000644000000000000000000000446007346545000026705 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.BitVector.replaceBit# kind: Declaration outputUsage: Blocking type: |- replaceBit# :: KnownNat n -- ARG[0] => BitVector n -- ARG[1] -> Int -- ARG[2] -> Bit -- ARG[3] -> BitVector n template: |- // replaceBit start always_comb begin ~RESULT = ~ARG[1]; ~RESULT[~ARG[2]] = ~ARG[3]; end // replaceBit end - BlackBox: name: Clash.Sized.Internal.BitVector.setSlice# kind: Declaration outputUsage: Blocking type: |- setSlice# :: SNat (m + 1 + i) -> BitVector (m + 1 + i) -- ARG[1] -> SNat m -- ARG[2] -> SNat n -- ARG[3] -> BitVector (m + 1 - n) -- ARG[4] -> BitVector (m + 1 + i) template: |- // setSlice begin always_comb begin ~RESULT = ~ARG[1]; ~RESULT[~LIT[2] : ~LIT[3]] = ~ARG[4]; end // setSlice end workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.split# kind: Declaration type: |- split# :: KnownNat n -- ARG[0] => BitVector (m + n) -- ARG[1] -> (BitVector m, BitVector n) template: |- // split begin assign ~RESULT = { ~VAR[bv][1][$high(~VAR[bv][1]) : ~LIT[0]] , ~VAR[bv][1][(~LIT[0]-1) : 0] }; // split end workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.rotateL# kind: Declaration type: 'rotateL# :: KnownNat n => BitVector n -> Int -> BitVector n' template: |- // rotateL begin logic [2*~SIZE[~TYPO]-1:0] ~GENSYM[bv][0]; assign ~SYM[0] = {~ARG[1],~ARG[1]} << (~ARG[2] % ~SIZE[~TYPO]); assign ~RESULT = ~SYM[0][2*~SIZE[~TYPO]-1 : ~SIZE[~TYPO]]; // rotateL end - BlackBox: name: Clash.Sized.Internal.BitVector.rotateR# kind: Declaration type: 'rotateR# :: KnownNat n => BitVector n -> Int -> BitVector n' template: |- // rotateR begin logic [2*~SIZE[~TYPO]-1:0] ~GENSYM[bv][0]; assign ~SYM[0] = {~ARG[1],~ARG[1]} >> (~ARG[2] % ~SIZE[~TYPO]); assign ~RESULT = ~SYM[0][~SIZE[~TYPO]-1 : 0]; // rotateR end clash-lib-1.8.1/prims/systemverilog/Clash_Sized_Internal_Signed.primitives.yaml0000644000000000000000000000501607346545000026213 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.Signed.div# kind: Declaration type: 'div# :: KnownNat n => Signed n -> Signed n -> Signed n' template: |- // divSigned begin 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]; assign ~SYM[1] = ~VAR[dividend][1][~SIZE[~TYPO]-1] == ~VAR[divider][2][~SIZE[~TYPO]-1]; assign ~SYM[2] = ~VAR[divider][2][~SIZE[~TYPO]-1] == 1'b1; assign ~SYM[4] = $signed({{~VAR[dividend][1][~SIZE[~TYPO]-1]},~VAR[dividend][1]}); // sign extension assign ~SYM[5] = $signed({{~VAR[divider][2][~SIZE[~TYPO]-1]} ,~VAR[divider][2]} ); // 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]); // divSigned end - BlackBox: name: Clash.Sized.Internal.Signed.mod# kind: Declaration type: 'mod# :: Signed n -> Signed n -> Signed n' template: |- // modSigned begin // remainder ~SIGD[~GENSYM[rem_res][0]][0]; assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; // modulo assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : (~SYM[0] == ~SIZE[~TYPO]'sd0 ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modSigned end - BlackBox: name: Clash.Sized.Internal.Signed.rotateL# kind: Declaration type: 'rotateL# :: KnownNat n => Signed n -> Int -> Signed n' template: |- // rotateL begin logic [2*~SIZE[~TYPO]-1:0] ~GENSYM[s][0]; assign ~SYM[0] = {~ARG[1],~ARG[1]} << (~ARG[2] % ~SIZE[~TYPO]); assign ~RESULT = $signed(~SYM[0][2*~SIZE[~TYPO]-1 : ~SIZE[~TYPO]]); // rotateL end - BlackBox: name: Clash.Sized.Internal.Signed.rotateR# kind: Declaration type: 'rotateR# :: KnownNat n => Signed n -> Int -> Signed n' template: |- // rotateR begin logic [2*~SIZE[~TYPO]-1:0] ~GENSYM[s][0]; assign ~SYM[0] = {~ARG[1],~ARG[1]} >> (~ARG[2] % ~SIZE[~TYPO]); assign ~RESULT = $signed(~SYM[0][~SIZE[~TYPO]-1 : 0]); // rotateR end clash-lib-1.8.1/prims/systemverilog/Clash_Sized_Internal_Unsigned.primitives.yaml0000644000000000000000000000143107346545000026553 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.Unsigned.rotateL# kind: Declaration type: 'rotateL# :: KnownNat n => Unsigned n -> Int -> Unsigned n' template: |- // rotateL begin logic [2*~SIZE[~TYPO]-1:0] ~GENSYM[u][0]; assign ~SYM[0] = {~ARG[1],~ARG[1]} << (~ARG[2] % ~SIZE[~TYPO]); assign ~RESULT = ~SYM[0][2*~SIZE[~TYPO]-1 : ~SIZE[~TYPO]]; // rotateL end - BlackBox: name: Clash.Sized.Internal.Unsigned.rotateR# kind: Declaration type: 'rotateR# :: KnownNat n => Unsigned n -> Int -> Unsigned n' template: |- // rotateR begin logic [2*~SIZE[~TYPO]-1:0] ~GENSYM[u][0]; assign ~SYM[0] = {~ARG[1],~ARG[1]} >> (~ARG[2] % ~SIZE[~TYPO]); assign ~RESULT = ~SYM[0][~SIZE[~TYPO]-1 : 0]; // rotateR end clash-lib-1.8.1/prims/systemverilog/Clash_Sized_RTree.primitives.yaml0000644000000000000000000000111507346545000024163 0ustar0000000000000000- BlackBox: name: Clash.Sized.RTree.treplicate kind: Expression type: 'replicate :: SNat d -> a -> RTree d a' template: '''{(2**~LIT[0]) {~TOBV[~ARG[1]][~TYP[1]]}}' workInfo: Never - BlackBox: name: Clash.Sized.RTree.textract kind: Expression type: 'textract :: RTree 0 a -> a' template: ~FROMBV[~VAR[tree][0][\0\]][~TYPO] workInfo: Never - BlackBox: name: Clash.Sized.RTree.tsplit kind: Expression type: 'tsplit:: RTree (d+1) a -> (RTree d a,RTree d a)' template: ~TOBV[~VAR[tree][0]][~TYP[0]] workInfo: Never clash-lib-1.8.1/prims/systemverilog/Clash_Sized_Vector.primitives.yaml0000644000000000000000000003013207346545000024405 0ustar0000000000000000- BlackBox: name: Clash.Sized.Vector.head kind: Expression type: 'head :: Vec (n + 1) a -> a' template: ~FROMBV[~VAR[vec][0][\0\]][~TYPO] workInfo: Never - BlackBox: name: Clash.Sized.Vector.tail kind: Expression type: 'tail :: Vec (n + 1) a -> Vec n a' template: '~VAR[vec][0][1 : $high(~VAR[vec][0])]' workInfo: Never - BlackBox: name: Clash.Sized.Vector.last kind: Expression type: Vec (n + 1) a -> a template: ~FROMBV[~VAR[vec][0][\$high(~VAR[vec][0])\]][~TYPO] workInfo: Never - BlackBox: name: Clash.Sized.Vector.init kind: Expression type: Vec (n + 1) a -> Vec n a template: '~VAR[vec][0][0 : $high(~VAR[vec][0]) - 1]' workInfo: Never - BlackBox: name: Clash.Sized.Vector.select kind: Declaration type: |- select :: (CmpNat (i + s) (s * n) ~ GT) -- ARG[0] => SNat f -- ARG[1] -> SNat s -- ARG[2] -> SNat n -- ARG[3] -> Vec i a -- ARG[4] -> Vec n a template: |- // select begin genvar ~GENSYM[n][1]; ~GENERATE for (~SYM[1]=0; ~SYM[1] < ~LIT[3]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[select][2] assign ~RESULT[~SYM[1]] = ~VAR[vec][4][~LIT[1] + (~LIT[2] * ~SYM[1])]; end ~ENDGENERATE // select end workInfo: Never - BlackBox: name: Clash.Sized.Vector.++ kind: Expression type: '(++) :: Vec n a -> Vec m a -> Vec (n + m) a' template: ~FROMBV[{~TOBV[~ARG[0]][~TYP[0]],~TOBV[~ARG[1]][~TYP[1]]}][~TYPO] workInfo: Never - BlackBox: name: Clash.Sized.Vector.concat kind: Declaration type: 'concat :: Vec n (Vec m a) -> Vec (n * m) a' template: |- // concat begin genvar ~GENSYM[n][1]; ~GENERATE for (~SYM[1]=0; ~SYM[1] < $size(~VAR[vec][0]); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[concat][2] assign ~RESULT[~SYM[1]*~LENGTH[~TYPEL[~TYP[0]]] : ~SYM[1]*~LENGTH[~TYPEL[~TYP[0]]]+(~LENGTH[~TYPEL[~TYP[0]]]-1)] = ~FROMBV[~VAR[vec][0][\~SYM[1]\]][~TYPEL[~TYP[0]]]; end ~ENDGENERATE // concat end workInfo: Never - BlackBox: name: Clash.Sized.Vector.splitAt kind: Declaration type: 'splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)' template: |- // splitAt begin~IF~LENGTH[~TYPO]~THEN assign ~RESULT = ~ARG[1];~ELSE logic [0:~LENGTH[~TYP[1]]-1] [0:~SIZE[~TYPEL[~TYP[1]]]-1] ~GENSYM[vec][0]; assign ~SYM[0] = ~TOBV[~ARG[1]][~TYP[1]]; ~GENERATE if (~LIT[0] == ~LENGTH[~TYP[1]]) begin : ~GENSYM[no_split][1] assign ~RESULT = {~SYM[0]}; end else begin : ~GENSYM[do_split][2] assign ~RESULT = {~SYM[0][0:~LIT[0]-1] ,~SYM[0][~LIT[0]:~LENGTH[~TYP[1]]-1] }; end ~ENDGENERATE~FI // splitAt end workInfo: Never - BlackBox: name: Clash.Sized.Vector.unconcat kind: Declaration type: |- unconcat :: KnownNat n -- ARG[0] => SNat m -- ARG[1] -> Vec (n * m) a -- ARG[2] -> Vec n (Vec m a) template: |- // unconcat begin~DEVNULL[~ARG[0]] genvar ~GENSYM[n][1]; ~GENERATE for (~SYM[1] = 0; ~SYM[1] < $size(~RESULT); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[unconcat][2] assign ~RESULT[~SYM[1]] = ~TOBV[~VAR[vec][2][\(~SYM[1] * ~LIT[1]) : ((~SYM[1] * ~LIT[1]) + ~LIT[1] - 1)\]][~TYPEL[~TYPO]]; end ~ENDGENERATE // unconcat end workInfo: Never - BlackBox: name: Clash.Sized.Vector.map kind: Declaration type: 'map :: (a -> b) -> Vec n a -> Vec n b' template: |- // map begin genvar ~GENSYM[n][1]; ~GENERATE for (~SYM[1]=0; ~SYM[1] < $size(~RESULT); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[map][2]~IF~SIZE[~TYP[1]]~THEN ~TYPEL[~TYP[1]] ~GENSYM[map_in][3]; assign ~SYM[3] = ~FROMBV[~VAR[vec][1][\~SYM[1]\]][~TYPEL[~TYP[1]]];~ELSE ~FI ~TYPEL[~TYPO] ~GENSYM[map_out][4]; ~INST 0 ~OUTPUT <= ~SYM[4]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[3]~ ~TYPEL[~TYP[1]]~ ~INST assign ~RESULT[~SYM[1]] = ~TOBV[~SYM[4]][~TYPEL[~TYPO]]; end ~ENDGENERATE // map end workInfo: Never - BlackBox: name: Clash.Sized.Vector.imap kind: Declaration type: 'imap :: KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b' template: |- // imap begin genvar ~GENSYM[n][1]; ~GENERATE for (~SYM[1]=0; ~SYM[1] < $size(~RESULT); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[imap][2] ~INDEXTYPE[~LIT[0]] ~GENSYM[i][3]; assign ~SYM[3] = ~SYM[1];~IF~SIZE[~TYP[2]]~THEN ~TYPEL[~TYP[2]] ~GENSYM[imap_in][4]; assign ~SYM[4] = ~FROMBV[~VAR[vec][2][\~SYM[1]\]][~TYPEL[~TYP[2]]];~ELSE ~FI ~TYPEL[~TYPO] ~GENSYM[imap_out][5]; ~INST 1 ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[3]~ ~INDEXTYPE[~LIT[0]]~ ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[2]]~ ~INST assign ~RESULT[~SYM[1]] = ~TOBV[~SYM[5]][~TYPEL[~TYPO]]; end ~ENDGENERATE // imap end workInfo: Never - BlackBox: name: Clash.Sized.Vector.imap_go kind: Declaration type: 'imap_go :: Index n -> (Index n -> a -> b) -> Vec m a -> Vec m b' template: |- // imap begin genvar ~GENSYM[n][1]; ~GENERATE for (~SYM[1]=0; ~SYM[1] < $size(~RESULT); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[imap][2] ~TYP[0] ~GENSYM[i][3]; assign ~SYM[3] = ~SYM[1] + ~ARG[0];~IF~SIZE[~TYP[2]]~THEN ~TYPEL[~TYP[2]] ~GENSYM[imap_in][4]; assign ~SYM[4] = ~FROMBV[~VAR[vec][2][\~SYM[1]\]][~TYPEL[~TYP[2]]];~ELSE ~FI ~TYPEL[~TYPO] ~GENSYM[imap_out][5]; ~INST 1 ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[3]~ ~TYP[0]~ ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[2]]~ ~INST assign ~RESULT[~SYM[1]] = ~TOBV[~SYM[5]][~TYPEL[~TYPO]]; end ~ENDGENERATE // imap end workInfo: Never - BlackBox: name: Clash.Sized.Vector.zipWith kind: Declaration type: 'zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c' template: |- // zipWith begin genvar ~GENSYM[n][2]; ~GENERATE for (~SYM[2] = 0; ~SYM[2] < $size(~RESULT); ~SYM[2] = ~SYM[2] + 1) begin : ~GENSYM[zipWith][3]~IF~SIZE[~TYP[1]]~THEN ~TYPEL[~TYP[1]] ~GENSYM[zipWith_in1][4]; assign ~SYM[4] = ~FROMBV[~VAR[vec1][1][\~SYM[2]\]][~TYPEL[~TYP[1]]];~ELSE ~FI~IF~SIZE[~TYP[2]]~THEN ~TYPEL[~TYP[2]] ~GENSYM[zipWith_in2][5]; assign ~SYM[5] = ~FROMBV[~VAR[vec2][2][\~SYM[2]\]][~TYPEL[~TYP[2]]];~ELSE ~FI ~TYPEL[~TYPO] ~GENSYM[zipWith_out][6]; ~INST 0 ~OUTPUT <= ~SYM[6]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[1]]~ ~INPUT <= ~SYM[5]~ ~TYPEL[~TYP[2]]~ ~INST assign ~RESULT[~SYM[2]] = ~TOBV[~SYM[6]][~TYPEL[~TYPO]]; end ~ENDGENERATE // zipWith end workInfo: Never - BlackBox: name: Clash.Sized.Vector.foldr kind: Declaration type: 'foldr :: (a -> b -> b) -> b -> Vec n a -> b' template: |- // foldr start~IF ~LENGTH[~TYP[2]] ~THEN ~SIGDO[~GENSYM[intermediate][0]] [0:~LENGTH[~TYP[2]]]; assign ~SYM[0][~LENGTH[~TYP[2]]] = ~ARG[1]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0; ~SYM[3] < ~LENGTH[~TYP[2]]; ~SYM[3]=~SYM[3]+1) begin : ~GENSYM[foldr_loop][4]~IF~SIZE[~TYP[2]]~THEN ~TYPEL[~TYP[2]] ~GENSYM[foldr_in][5]; assign ~SYM[5] = ~FROMBV[~VAR[xs][2][\~SYM[3]\]][~TYPEL[~TYP[2]]];~ELSE ~FI ~INST 0 ~OUTPUT <= ~SYM[0][~SYM[3]]~ ~TYP[1]~ ~INPUT <= ~SYM[5]~ ~TYPEL[~TYP[2]]~ ~INPUT <= ~SYM[0][~SYM[3]+1]~ ~TYP[1]~ ~INST end ~ENDGENERATE assign ~RESULT = ~SYM[0][0]; ~ELSE assign ~RESULT = ~ARG[1]; ~FI// foldr end workInfo: Never - BlackBox: name: Clash.Sized.Vector.index_int kind: Expression type: 'index_int :: KnownNat n => Vec n a -> Int -> a' template: ~IF~SIZE[~TYP[1]]~THEN~FROMBV[~VAR[vec][1][\~ARG[2]\]][~TYPO]~ELSE~ERRORO~FI - 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: |- // replaceVec start always_comb begin ~RESULT = ~ARG[1]; ~RESULT[~ARG[2]] = ~TOBV[~ARG[3]][~TYP[3]]; end // replaceVec end - BlackBox: name: Clash.Sized.Vector.replicate kind: Expression type: 'replicate :: SNat n -> a -> Vec n a' template: '''{~LIT[0] {~TOBV[~ARG[1]][~TYP[1]]}}' workInfo: Never - BlackBox: name: Clash.Sized.Vector.transpose kind: Declaration type: 'transpose :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)' template: |- // transpose begin genvar ~GENSYM[row_index][1]; genvar ~GENSYM[col_index][2]; ~GENERATE for (~SYM[1] = 0; ~SYM[1] < $size(~VAR[matrix][1]); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[transpose_outer][3] for (~SYM[2] = 0; ~SYM[2] < $size(~RESULT); ~SYM[2] = ~SYM[2] + 1) begin : ~GENSYM[transpose_inner][4]~IF ~VIVADO ~THEN assign ~RESULT[~SYM[2]][($size(~VAR[matrix][1])-~SYM[1])*~SIZE[~TYPEL[~TYPEL[~TYPO]]]-1 : ($size(~VAR[matrix][1])-~SYM[1]-1)*~SIZE[~TYPEL[~TYPEL[~TYPO]]]] = ~VAR[matrix][1][~SYM[1]][($size(~RESULT)-~SYM[2])*~SIZE[~TYPEL[~TYPEL[~TYPO]]]-1 : ($size(~RESULT)-~SYM[2]-1)*~SIZE[~TYPEL[~TYPEL[~TYPO]]]];~ELSE assign ~RESULT[~SYM[2]][~SYM[1]] = ~VAR[matrix][1][~SYM[1]][~SYM[2]];~FI end end ~ENDGENERATE // transpose end workInfo: Never - BlackBox: name: Clash.Sized.Vector.reverse kind: Declaration type: 'reverse :: Vec n a -> Vec n a' template: |- // reverse begin genvar ~GENSYM[n][1]; ~GENERATE for (~SYM[1] = 0; ~SYM[1] < $size(~VAR[vec][0]); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[reverse][2] assign ~RESULT[$high(~VAR[vec][0]) - ~SYM[1]] = ~VAR[vec][0][~SYM[1]]; end ~ENDGENERATE // reverse end workInfo: Never - BlackBox: name: Clash.Sized.Vector.concatBitVector# kind: Expression type: |- concatBitVector# :: (KnownNat n,KnownNat m) -- (ARG[0],ARG[1]) => Vec n (BitVector m) -- ARG[2] -> BitVector (n * m) template: ~TOBV[~ARG[2]][~TYP[2]] workInfo: Never - BlackBox: name: Clash.Sized.Vector.unconcatBitVector# kind: Expression type: |- unconcatBitVector# :: (KnownNat n, KnownNat m) -- (ARG[0],ARG[1]) => BitVector (n * m) -- ARG[2] -> Vec n (BitVector m) template: ~FROMBV[~ARG[2]][~TYPO] workInfo: Never - BlackBox: name: Clash.Sized.Vector.rotateLeftS kind: Declaration type: 'rotateLeftS :: KnownNat n => Vec n a -> SNat d -> Vec n a' template: |- // rotateLeftS begin localparam ~GENSYM[shift_amount][2] = ~LIT[2] % ~LIT[0]; ~GENERATE if (~SYM[2] == 0) begin : ~GENSYM[no_shift][3] assign ~RESULT = ~VAR[vec][1]; end else begin : ~GENSYM[do_shift][4] assign ~RESULT[0:~LIT[0]-~SYM[2]-1] = ~VAR[vec][1][~SYM[2]:~LIT[0]-1]; assign ~RESULT[~LIT[0]-~SYM[2]:~LIT[0]-1] = ~VAR[vec][1][0:~SYM[2]-1]; end ~ENDGENERATE // rotateLeftS end workInfo: Never - BlackBox: name: Clash.Sized.Vector.rotateRightS kind: Declaration type: 'rotateRightS :: KnownNat n => Vec n a -> SNat d -> Vec n a' template: |- // rotateRightS begin localparam ~GENSYM[shift_amount][2] = ~LIT[2] % ~LIT[0]; ~GENERATE if (~SYM[2] == 0) begin : ~GENSYM[no_shift][3] assign ~RESULT = ~VAR[vec][1]; end else begin : ~GENSYM[do_shift][4] assign ~RESULT[0:~SYM[2]-1] = ~VAR[vec][1][~LIT[0]-~SYM[2]:~LIT[0]-1]; assign ~RESULT[~SYM[2]:~LIT[0]-1] = ~VAR[vec][1][0:~LIT[0]-~SYM[2]-1]; end ~ENDGENERATE // rotateRightS end workInfo: Never clash-lib-1.8.1/prims/systemverilog/Clash_Xilinx_DDR.primitives.yaml0000644000000000000000000000534207346545000023756 0ustar0000000000000000- BlackBox: name: Clash.Xilinx.DDR.iddr kind: Declaration type: |- iddr :: ( HasCallStack -- ARG[0] , KnownConfi~ fast domf -- ARG[1] , KnownConfi~ slow doms -- ARG[2] , KnownNat m ) -- ARG[3] -> Clock slow -- ARG[4] -> Reset slow -- ARG[5] -> Enable slow -- ARG[6] -> Signal fast (BitVector m) -- ARG[7] -> Signal slow (BitVector m,BitVector m) template: |- // iddr begin ~SIGD[~GENSYM[dataout_l][1]][7]; ~SIGD[~GENSYM[dataout_h][2]][7]; ~SIGD[~GENSYM[d][3]][7]; assign ~SYM[3] = ~ARG[7]; genvar ~GENSYM[i][8]; ~GENERATE for (~SYM[8]=0; ~SYM[8] < ~SIZE[~TYP[7]]; ~SYM[8]=~SYM[8]+1) begin : ~GENSYM[ddri_array][7] IDDR #( .DDR_CLK_EDGE("SAME_EDGE"), .INIT_Q1(1'b0), .INIT_Q2(1'b0), .SRTYPE(~IF ~ISSYNC[2] ~THEN "SYNC" ~ELSE "ASYNC" ~FI) ) ~GENSYM[~COMPNAME_IDDR][9] ( .Q1(~SYM[1][~SYM[8]]), .Q2(~SYM[2][~SYM[8]]), .C(~ARG[4]), .CE(~IF ~ISACTIVEENABLE[6] ~THEN ~ARG[6] ~ELSE 1'b1 ~FI), .D(~SYM[3][~SYM[8]]), .R(~ARG[5]), .S(1'b0) ); end ~ENDGENERATE assign ~RESULT = {~SYM[2],~SYM[1]}; // iddr end - BlackBox: name: Clash.Xilinx.DDR.oddr# kind: Declaration type: |- oddr# :: ( KnownConfi~ fast domf -- ARG[0] , KnownConfi~ slow doms -- ARG[1] , KnownNat m ) -- ARG[2] => Clock slow -- ARG[3] -> Reset slow -- ARG[4] -> Enable slow -- ARG[5] -> Signal slow (BitVector m) -- ARG[6] -> Signal slow (BitVector m) -- ARG[7] -> Signal fast (BitVector m) template: |- // oddr begin ~SIGD[~GENSYM[datain_l][1]][7]; ~SIGD[~GENSYM[datain_h][2]][7]; ~SIGD[~GENSYM[q][3]][7]; assign ~SYM[1] = ~ARG[6]; assign ~SYM[2] = ~ARG[7]; genvar ~GENSYM[i][8]; ~GENERATE for (~SYM[8]=0; ~SYM[8] < ~SIZE[~TYP[7]]; ~SYM[8]=~SYM[8]+1) begin : ~GENSYM[ddro_array][7] ODDR #( .DDR_CLK_EDGE("SAME_EDGE"), .INIT(1'b0), .SRTYPE(~IF ~ISSYNC[2] ~THEN "SYNC" ~ELSE "ASYNC" ~FI) ) ~GENSYM[~COMPNAME_ODDR][9] ( .Q(~SYM[3][~SYM[8]]), .C(~ARG[3]), .CE(~IF ~ISACTIVEENABLE[5] ~THEN ~ARG[5] ~ELSE 1'b1 ~FI), .D1(~SYM[1][~SYM[8]]), .D2(~SYM[2][~SYM[8]]), .R(~ARG[4]), .S(1'b0) ); end ~ENDGENERATE assign ~RESULT = ~SYM[3]; // oddr end clash-lib-1.8.1/prims/systemverilog/GHC_Base.primitives.yaml0000644000000000000000000000324507346545000022233 0ustar0000000000000000- BlackBox: name: GHC.Base.divInt kind: Declaration type: 'divInt :: Int -> Int -> Int' template: |- // divInt begin 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]; 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 kind: Declaration type: 'modInt :: Int -> Int -> Int' template: |- // modInt begin // remainder ~SIGD[~GENSYM[rem_res][0]][0]; assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; // modulo assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ((~VAR[dividend][0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modInt end clash-lib-1.8.1/prims/systemverilog/GHC_Classes.primitives.yaml0000644000000000000000000000325707346545000022761 0ustar0000000000000000- BlackBox: name: GHC.Classes.divInt# kind: Declaration type: 'divInt# :: Int# -> Int# -> Int#' template: |- // divInt# begin 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]; 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.Classes.modInt# kind: Declaration type: 'modInt# :: Int# -> Int# -> Int#' template: |- // modInt# begin // remainder ~SIGD[~GENSYM[rem_res][0]][0]; assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; // modulo assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modInt# end clash-lib-1.8.1/prims/systemverilog/GHC_Integer_Type.primitives.yaml0000644000000000000000000001071707346545000023761 0ustar0000000000000000- BlackBox: name: GHC.Integer.Type.divInteger kind: Declaration type: 'divInteger :: Integer -> Integer -> Integer' template: |- // divInteger begin 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]; 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]); // divInteger end warning: 'GHC.Integer.Type.divInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.modInteger kind: Declaration type: 'modInteger :: Integer -> Integer -> Integer' template: |- // modInteger begin // remainder ~SIGD[~GENSYM[rem_res][0]][0]; assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; // modulo assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modInteger end warning: 'GHC.Integer.Type.modInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.divModInteger kind: Declaration type: 'divModInteger :: Integer -> Integer -> (# Integer, Integer #)' template: |- // divModInteger begin logic ~GENSYM[resultPos][1]; logic ~GENSYM[dividerNeg][2]; logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividend2][3]; logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividendE][4]; logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividerE][5]; logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[quot_res][6]; logic signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[div_res][7]; assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1]; assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYP[0]]-1] == 1'b1; assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYP[0]]-1]},~VAR[dividend][0]}); // sign extension assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYP[0]]-1]} ,~VAR[divider][1]} ); // sign extension assign ~SYM[3] = ~SYM[1] ? ~SYM[4] : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYP[0]]'sd1) : (~SYM[4] - ~SYM[5] + ~SIZE[~TYP[0]]'sd1)); assign ~SYM[6] = ~SYM[3] / ~SYM[5]; assign ~SYM[7] = $signed(~SYM[6][~SIZE[~TYP[0]]-1:0]); logic signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[rem_res][8]; logic signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[mod_res][9]; assign ~SYM[8] = ~VAR[dividend][0] % ~VAR[divider][1]; assign ~SYM[9] = (~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1]) ? ~SYM[8] : ((~SYM[8] == ~SIZE[~TYP[0]]'sd0) ? ~SIZE[~TYP[0]]'sd0 : ~SYM[8] + ~VAR[divider][1]); assign ~RESULT = {~SYM[7],~SYM[9]}; // divModInteger end warning: 'GHC.Integer.Type.divModInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.quotRemInteger kind: Declaration type: 'quotRemInteger :: Integer -> Integer -> (# Integer, Integer #)' template: |- // quotRemInteger 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]}; // quotRemInteger end warning: 'GHC.Integer.Type.quotRemInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' clash-lib-1.8.1/prims/systemverilog/GHC_Num_Integer.primitives.yaml0000644000000000000000000001071307346545000023573 0ustar0000000000000000- BlackBox: name: GHC.Num.Integer.integerDiv kind: Declaration type: 'integerDiv :: Integer -> Integer -> Integer' template: |- // integerDiv begin 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]; 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]); // integerDiv end warning: 'GHC.Num.Integer.integerDiv: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerMod kind: Declaration type: 'integerMod :: Integer -> Integer -> Integer' template: |- // integerMod begin // remainder ~SIGD[~GENSYM[rem_res][0]][0]; assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; // modulo assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // integerMod end warning: 'GHC.Num.Integer.integerMod: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerDivMod# kind: Declaration type: 'integerDivMod :: Integer -> Integer -> (# Integer, Integer #)' template: |- // integerDivMod begin logic ~GENSYM[resultPos][1]; logic ~GENSYM[dividerNeg][2]; logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividend2][3]; logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividendE][4]; logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividerE][5]; logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[quot_res][6]; logic signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[div_res][7]; assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1]; assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYP[0]]-1] == 1'b1; assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYP[0]]-1]},~VAR[dividend][0]}); // sign extension assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYP[0]]-1]} ,~VAR[divider][1]} ); // sign extension assign ~SYM[3] = ~SYM[1] ? ~SYM[4] : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYP[0]]'sd1) : (~SYM[4] - ~SYM[5] + ~SIZE[~TYP[0]]'sd1)); assign ~SYM[6] = ~SYM[3] / ~SYM[5]; assign ~SYM[7] = $signed(~SYM[6][~SIZE[~TYP[0]]-1:0]); logic signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[rem_res][8]; logic signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[mod_res][9]; assign ~SYM[8] = ~VAR[dividend][0] % ~VAR[divider][1]; assign ~SYM[9] = (~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1]) ? ~SYM[8] : ((~SYM[8] == ~SIZE[~TYP[0]]'sd0) ? ~SIZE[~TYP[0]]'sd0 : ~SYM[8] + ~VAR[divider][1]); assign ~RESULT = {~SYM[7],~SYM[9]}; // integerDivMod end warning: 'GHC.Num.Integer.integerDivMod#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerQuotRem# kind: Declaration type: 'integerQuotRem :: Integer -> Integer -> (# Integer, Integer #)' template: |- // integerQuotRem 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]}; // integerQuotRem end warning: 'GHC.Num.Integer.integerQuotRem#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' clash-lib-1.8.1/prims/systemverilog/GHC_Prim.primitives.yaml0000644000000000000000000013562507346545000022300 0ustar0000000000000000- BlackBox: name: GHC.Prim.quotRemInt# kind: Declaration type: 'quotRemInt# :: Int# -> Int# -> (#Int#, Int##)' template: |- // quotRemInt 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]}; // quotRemInt end - BlackBox: name: GHC.Prim.quotRemWord# kind: Declaration type: 'quotRemWord# :: Word# -> Word# -> (#Word#, Word##)' template: |- // quotRemWord 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]}; // quotRemWord end - BlackBox: name: GHC.Prim.popCnt8# imports: - ~INCLUDENAME[0].inc includes: - name: depth2Index extension: inc template: |- // given a level and a depth, calculate the corresponding index into the // intermediate array function integer ~INCLUDENAME[0]; input integer levels; input integer depth; ~INCLUDENAME[0] = (2 ** levels) - (2 ** depth); endfunction kind: Declaration type: 'popCnt8# :: Word# -> Word#' template: |- // popCnt8 begin localparam ~GENSYM[width][0] = 8; // depth of the tree localparam ~GENSYM[levels][2] = $clog2(~SYM[0]); logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; // put input into the first half of the intermediate array genvar ~GENSYM[i][4]; ~GENERATE for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]); end ~ENDGENERATE // Create the tree of instantiated components genvar ~GENSYM[d][6]; genvar ~GENSYM[i][7]; ~GENERATE if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] assign ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6])+~SYM[7]] = ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] + ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1]; end end end ~ENDGENERATE // The last element of the intermediate array holds the result assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); // popCnt8 end - BlackBox: name: GHC.Prim.popCnt16# imports: - ~INCLUDENAME[0].inc includes: - name: depth2Index extension: inc template: |- // given a level and a depth, calculate the corresponding index into the // intermediate array function integer ~INCLUDENAME[0]; input integer levels; input integer depth; ~INCLUDENAME[0] = (2 ** levels) - (2 ** depth); endfunction kind: Declaration type: 'popCnt16# :: Word# -> Word#' template: |- // popCnt16 begin localparam ~GENSYM[width][0] = 16; // depth of the tree localparam ~GENSYM[levels][2] = $clog2(~SYM[0]); logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; // put input into the first half of the intermediate array genvar ~GENSYM[i][4]; ~GENERATE for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]); end ~ENDGENERATE // Create the tree of instantiated components genvar ~GENSYM[d][6]; genvar ~GENSYM[i][7]; ~GENERATE if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] assign ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6])+~SYM[7]] = ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] + ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1]; end end end ~ENDGENERATE // The last element of the intermediate array holds the result assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); // popCnt16 end - BlackBox: name: GHC.Prim.popCnt32# imports: - ~INCLUDENAME[0].inc includes: - name: depth2Index extension: inc template: |- // given a level and a depth, calculate the corresponding index into the // intermediate array function integer ~INCLUDENAME[0]; input integer levels; input integer depth; ~INCLUDENAME[0] = (2 ** levels) - (2 ** depth); endfunction kind: Declaration type: 'popCnt32# :: Word# -> Word#' template: |- // popCnt32 begin localparam ~GENSYM[width][0] = 32; // depth of the tree localparam ~GENSYM[levels][2] = $clog2(~SYM[0]); logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; // put input into the first half of the intermediate array genvar ~GENSYM[i][4]; ~GENERATE for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]); end ~ENDGENERATE // Create the tree of instantiated components genvar ~GENSYM[d][6]; genvar ~GENSYM[i][7]; ~GENERATE if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] assign ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6])+~SYM[7]] = ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] + ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1]; end end end ~ENDGENERATE // The last element of the intermediate array holds the result assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); // popCnt32 end - BlackBox: name: GHC.Prim.popCnt64# imports: - ~INCLUDENAME[0].inc includes: - name: depth2Index extension: inc template: |- // given a level and a depth, calculate the corresponding index into the // intermediate array function integer ~INCLUDENAME[0]; input integer levels; input integer depth; ~INCLUDENAME[0] = (2 ** levels) - (2 ** depth); endfunction kind: Declaration type: 'popCnt64# :: Word# -> Word#' template: |- // popCnt64 begin localparam ~GENSYM[width][0] = 64; // depth of the tree localparam ~GENSYM[levels][2] = $clog2(~SYM[0]); logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; // put input into the first half of the intermediate array genvar ~GENSYM[i][4]; ~GENERATE for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]); end ~ENDGENERATE // Create the tree of instantiated components genvar ~GENSYM[d][6]; genvar ~GENSYM[i][7]; ~GENERATE if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] assign ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6])+~SYM[7]] = ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] + ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1]; end end end ~ENDGENERATE // The last element of the intermediate array holds the result assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); // popCnt64 end - BlackBox: name: GHC.Prim.popCnt# imports: - ~INCLUDENAME[0].inc includes: - name: depth2Index extension: inc template: |- // given a level and a depth, calculate the corresponding index into the // intermediate array function integer ~INCLUDENAME[0]; input integer levels; input integer depth; ~INCLUDENAME[0] = (2 ** levels) - (2 ** depth); endfunction kind: Declaration type: 'popCnt# :: Word# -> Word#' template: |- // popCnt begin localparam ~GENSYM[width][0] = ~SIZE[~TYPO]; // depth of the tree localparam ~GENSYM[levels][2] = $clog2(~SYM[0]); logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; // put input into the first half of the intermediate array genvar ~GENSYM[i][4]; ~GENERATE for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]); end ~ENDGENERATE // Create the tree of instantiated components genvar ~GENSYM[d][6]; genvar ~GENSYM[i][7]; ~GENERATE if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] assign ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6])+~SYM[7]] = ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] + ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1]; end end end ~ENDGENERATE // The last element of the intermediate array holds the result assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); // popCnt end - BlackBox: name: GHC.Prim.clz8# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'clz8 :: Word# -> Word#' template: |- // clz8 begin logic [0:7] ~GENSYM[v][1]; assign ~SYM[1] = ~VAR[i][0][7:0]; logic [0:7] ~GENSYM[e][2]; genvar ~GENSYM[n][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<4;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE logic [0:5] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<2;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage1][6] localparam n = 2; logic [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:3] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 3; logic [5:0] i; assign i = ~SYM[4][0:5]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // clz8 end - BlackBox: name: GHC.Prim.clz16# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'clz16 :: Word# -> Word#' template: |- // clz16 begin logic [0:15] ~GENSYM[v][1]; assign ~SYM[1] = ~VAR[i][0][15:0]; logic [0:15] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<8;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE logic [0:11] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<4;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; logic [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:7] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<2;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; logic [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:4] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 4; logic [7:0] i; assign i = ~SYM[9][0:7]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // clz16 end - BlackBox: name: GHC.Prim.clz32# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'clz32 :: Word# -> Word#' template: |- // clz32 begin logic [0:31] ~GENSYM[v][1]; assign ~SYM[1] = ~VAR[i][0][31:0]; logic [0:31] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE logic [0:23] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; logic [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:15] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; logic [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:9] ~GENSYM[c][12]; genvar ~GENSYM[i3][13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] localparam n = 4; logic [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:5] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 5; logic [9:0] i; assign i = ~SYM[12][0:9]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // clz32 end - BlackBox: name: GHC.Prim.clz64# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'clz64 :: Word# -> Word#' template: |- // clz64 begin logic [0:63] ~GENSYM[v][1]; assign ~SYM[1] = ~VAR[i][0][63:0]; logic [0:63] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE logic [0:47] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; logic [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:31] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; logic [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:19] ~GENSYM[c][12]; genvar ~GENSYM[i3][13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] localparam n = 4; logic [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:11] ~GENSYM[d][15]; genvar ~GENSYM[i4][16]; ~GENERATE for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] localparam n = 5; logic [9:0] i; assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:6] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 6; logic [11:0] i; assign i = ~SYM[15][0:11]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // clz64 end - BlackBox: name: GHC.Prim.clz# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'clz :: Word# -> Word#' template: |- // clz begin ~IF ~IW64 ~THEN logic [0:63] ~GENSYM[v][1]; assign ~SYM[1] = ~VAR[i][0][63:0]; logic [0:63] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE logic [0:47] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; logic [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:31] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; logic [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:19] ~GENSYM[c][12]; genvar ~GENSYM[i3][13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] localparam n = 4; logic [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:11] ~GENSYM[d][15]; genvar ~GENSYM[i4][16]; ~GENERATE for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] localparam n = 5; logic [9:0] i; assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:6] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 6; logic [11:0] i; assign i = ~SYM[15][0:11]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE ~ELSE logic [0:31] ~SYM[1]; assign ~SYM[1] = ~VAR[i][0][31:0]; logic [0:31] ~SYM[2]; genvar ~SYM[3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~SYM[8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE logic [0:23] ~SYM[4]; genvar ~SYM[5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~SYM[6] localparam n = 2; logic [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:15] ~SYM[9]; genvar ~SYM[10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~SYM[11] localparam n = 3; logic [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:9] ~SYM[12]; genvar ~SYM[13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~SYM[14] localparam n = 4; logic [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:5] ~SYM[7]; ~GENERATE if (1) begin localparam n = 5; logic [9:0] i; assign i = ~SYM[12][0:9]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE ~FI assign ~RESULT = $unsigned(~SYM[7]); // clz end - BlackBox: name: GHC.Prim.ctz8# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'ctz8 :: Word# -> Word#' template: |- // ctz8 begin logic [0:7] ~GENSYM[v][1]; genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<8;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; end ~ENDGENERATE logic [0:7] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<4;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE logic [0:5] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<2;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; logic [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:3] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 3; logic [5:0] i; assign i = ~SYM[4][0:5]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // ctz8 end - BlackBox: name: GHC.Prim.ctz16# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'ctz16 :: Word# -> Word#' template: |- // ctz16 begin logic [0:15] ~GENSYM[v][1]; genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<16;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; end ~ENDGENERATE logic [0:15] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<8;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE logic [0:11] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<4;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; logic [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:7] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<2;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; logic [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:4] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 4; logic [7:0] i; assign i = ~SYM[9][0:7]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // ctz16 end - BlackBox: name: GHC.Prim.ctz32# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'ctz32 :: Word# -> Word#' template: |- // ctz32 begin logic [0:31] ~GENSYM[v][1]; genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; end ~ENDGENERATE logic [0:31] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE logic [0:23] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; logic [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:15] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; logic [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:9] ~GENSYM[c][12]; genvar ~GENSYM[i3][13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] localparam n = 4; logic [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:5] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 5; logic [9:0] i; assign i = ~SYM[12][0:9]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // ctz32 end - BlackBox: name: GHC.Prim.ctz64# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'ctz64 :: Word# -> Word#' template: |- // ctz64 begin logic [0:63] ~GENSYM[v][1]; genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; end ~ENDGENERATE logic [0:63] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE logic [0:47] a; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; logic [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:31] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; logic [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:19] ~GENSYM[c][12]; genvar ~GENSYM[i3][13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] localparam n = 4; logic [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:11] ~GENSYM[d][15]; genvar ~GENSYM[i4][16]; ~GENERATE for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] localparam n = 5; logic [9:0] i; assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:6] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 6; logic [11:0] i; assign i = ~SYM[15][0:11]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // ctz64 end - BlackBox: name: GHC.Prim.ctz# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'ctz :: Word# -> Word#' template: |- // ctz begin ~IF ~IW64 ~THEN logic [0:63] ~GENSYM[v][1]; genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; end ~ENDGENERATE logic [0:63] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE logic [0:47] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; logic [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:31] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; logic [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:19] ~GENSYM[c][12]; genvar ~GENSYM[i3][13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] localparam n = 4; logic [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:11] ~GENSYM[d][15]; genvar ~GENSYM[i4][16]; ~GENERATE for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] localparam n = 5; logic [9:0] i; assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:6] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 6; logic [11:0] i; assign i = ~SYM[15][0:11]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE ~ELSE logic [0:31] ~SYM[1]; genvar ~SYM[18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~SYM[19] assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; end ~ENDGENERATE logic [0:31] ~SYM[2]; genvar ~SYM[3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~SYM[8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE logic [0:23] ~SYM[4]; genvar ~SYM[5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~SYM[6] localparam n = 2; logic [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:15] ~SYM[9]; genvar ~SYM[10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~SYM[11] localparam n = 3; logic [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:9] ~SYM[12]; genvar ~SYM[13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~SYM[14] localparam n = 4; logic [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE logic [0:5] ~SYM[7]; ~GENERATE if (1) begin localparam n = 5; logic [9:0] i; assign i = ~SYM[12][0:9]; always_comb begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE ~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 clash-lib-1.8.1/prims/verilog/0000755000000000000000000000000007346545000014351 5ustar0000000000000000clash-lib-1.8.1/prims/verilog/Clash_Explicit_BlockRam.primitives.yaml0000644000000000000000000001144607346545000024102 0ustar0000000000000000- BlackBox: name: Clash.Explicit.BlockRam.blockRam# kind: Declaration outputUsage: NonBlocking type: |- blockRam# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] => Enable dom -- en, ARG[4] -> Vec n a -- init, ARG[5] -> Signal dom Int -- rd, ARG[6] -> Signal dom Bool -- wren, ARG[7] -> Signal dom Int -- wr, ARG[8] -> Signal dom a -- din, ARG[9] -> Signal dom a template: |- // blockRam begin reg ~TYPO ~GENSYM[~RESULT_RAM][1] [0:~LENGTH[~TYP[5]]-1]; reg ~TYP[5] ~GENSYM[ram_init][3]; integer ~GENSYM[i][4]; initial begin ~SYM[3] = ~CONST[5]; for (~SYM[4]=0; ~SYM[4] < ~LENGTH[~TYP[5]]; ~SYM[4] = ~SYM[4] + 1) begin ~SYM[1][~LENGTH[~TYP[5]]-1-~SYM[4]] = ~SYM[3][~SYM[4]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; end end ~IF ~ISACTIVEENABLE[4] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~RESULT_blockRam][5]~IF ~VIVADO ~THEN if (~ARG[4]) begin if (~ARG[7]) begin ~SYM[1][~ARG[8]] <= ~ARG[9]; end ~RESULT <= ~SYM[1][~ARG[6]]; end~ELSE if (~ARG[7] & ~ARG[4]) begin ~SYM[1][~ARG[8]] <= ~ARG[9]; end if (~ARG[4]) begin ~RESULT <= ~SYM[1][~ARG[6]]; end~FI end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[5] if (~ARG[7]) begin ~SYM[1][~ARG[8]] <= ~ARG[9]; end ~RESULT <= ~SYM[1][~ARG[6]]; end~FI // blockRam end - BlackBox: name: Clash.Explicit.BlockRam.blockRamU# kind: Declaration outputUsage: NonBlocking type: |- blockRamU# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> SNat n -- len, ARG[5] -> Signal dom Int -- rd, ARG[6] -> Signal dom Bool -- wren, ARG[7] -> Signal dom Int -- wr, ARG[8] -> Signal dom a -- din, ARG[9] -> Signal dom a template: |- // blockRamU begin reg ~TYPO ~GENSYM[~RESULT_RAM][0] [0:~LIT[5]-1]; ~IF ~ISACTIVEENABLE[4] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~RESULT_blockRam][5]~IF ~VIVADO ~THEN if (~ARG[4]) begin if (~ARG[7]) begin ~SYM[0][~ARG[8]] <= ~ARG[9]; end ~RESULT <= ~SYM[0][~ARG[6]]; end~ELSE if (~ARG[7] & ~ARG[4]) begin ~SYM[0][~ARG[8]] <= ~ARG[9]; end if (~ARG[4]) begin ~RESULT <= ~SYM[0][~ARG[6]]; end~FI end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[5] if (~ARG[7]) begin ~SYM[0][~ARG[8]] <= ~ARG[9]; end ~RESULT <= ~SYM[0][~ARG[6]]; end~FI // blockRamU end - BlackBox: name: Clash.Explicit.BlockRam.blockRam1# kind: Declaration outputUsage: NonBlocking type: |- blockRam1# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> SNat n -- len, ARG[5] -> a -- init, ARG[6] -> Signal dom Int -- rd, ARG[7] -> Signal dom Bool -- wren, ARG[8] -> Signal dom Int -- wr, ARG[9] -> Signal dom a -- din, ARG[10] -> Signal dom a template: |- // blockRam1 begin reg ~TYPO ~GENSYM[~RESULT_RAM][0] [0:~LIT[5]-1]; integer ~GENSYM[i][1]; initial begin for (~SYM[1]=0;~SYM[1]<~LIT[5];~SYM[1]=~SYM[1]+1) begin ~SYM[0][~SYM[1]] = ~CONST[6]; end end ~IF ~ISACTIVEENABLE[4] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~RESULT_blockRam][5]~IF ~VIVADO ~THEN if (~ARG[4]) begin if (~ARG[8]) begin ~SYM[0][~ARG[9]] <= ~ARG[10]; end ~RESULT <= ~SYM[0][~ARG[7]]; end~ELSE if (~ARG[8] & ~ARG[4]) begin ~SYM[0][~ARG[9]] <= ~ARG[10]; end if (~ARG[4]) begin ~RESULT <= ~SYM[0][~ARG[7]]; end~FI end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[5] if (~ARG[8]) begin ~SYM[0][~ARG[9]] <= ~ARG[10]; end ~RESULT <= ~SYM[0][~ARG[7]]; end~FI // blockRam1 end clash-lib-1.8.1/prims/verilog/Clash_Explicit_BlockRam_Blob.primitives.yaml0000644000000000000000000000340507346545000025034 0ustar0000000000000000- BlackBox: name: Clash.Explicit.BlockRam.Blob.blockRamBlob# kind: Declaration outputUsage: NonBlocking type: |- blockRamBlob# :: KnownDomain dom -- ARG[0] => Clock dom -- clk, ARG[1] -> Enable dom -- en, ARG[2] -> MemBlob n m -- init, ARG[3] -> Signal dom Int -- rd, ARG[4] -> Signal dom Bool -- wren, ARG[5] -> Signal dom Int -- wr, ARG[6] -> Signal dom (BitVector m) -- din, ARG[7] -> Signal dom (BitVector m) template: |- // blockRamBlob begin reg ~TYPO ~GENSYM[~RESULT_RAM][1] [0:~LENGTH[~TYP[3]]-1]; reg ~TYP[3] ~GENSYM[ram_init][3]; integer ~GENSYM[i][4]; initial begin ~SYM[3] = ~CONST[3]; for (~SYM[4]=0; ~SYM[4] < ~LENGTH[~TYP[3]]; ~SYM[4] = ~SYM[4] + 1) begin ~SYM[1][~LENGTH[~TYP[3]]-1-~SYM[4]] = ~SYM[3][~SYM[4]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; end end ~IF ~ISACTIVEENABLE[2] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~GENSYM[~RESULT_blockRam][5]~IF ~VIVADO ~THEN if (~ARG[2]) begin if (~ARG[5]) begin ~SYM[1][~ARG[6]] <= ~ARG[7]; end ~RESULT <= ~SYM[1][~ARG[4]]; end~ELSE if (~ARG[5] & ~ARG[2]) begin ~SYM[1][~ARG[6]] <= ~ARG[7]; end if (~ARG[2]) begin ~RESULT <= ~SYM[1][~ARG[4]]; end~FI end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~SYM[5] if (~ARG[5]) begin ~SYM[1][~ARG[6]] <= ~ARG[7]; end ~RESULT <= ~SYM[1][~ARG[4]]; end~FI // blockRamBlob end clash-lib-1.8.1/prims/verilog/Clash_Explicit_BlockRam_File.primitives.yaml0000644000000000000000000000325407346545000025037 0ustar0000000000000000- BlackBox: name: Clash.Explicit.BlockRam.File.blockRamFile# kind: Declaration outputUsage: NonBlocking type: |- blockRamFile# :: ( KnownDomain dom -- ARG[0] , KnownNat m -- ARG[1] , HasCallStack ) -- ARG[2] => Clock dom -- clk, ARG[3] => Enable dom -- en, ARG[4] -> SNat n -- sz, ARG[5] -> FilePath -- file, ARG[6] -> Signal dom Int -- rd, ARG[7] -> Signal dom Bool -- wren, ARG[8] -> Signal dom Int -- wr, ARG[9] -> Signal dom (BitVector m) -- din, ARG[10] -> Signal dom (BitVector m) template: |- // blockRamFile begin reg ~TYPO ~GENSYM[RAM][1] [0:~LIT[5]-1]; initial begin $readmemb(~FILE[~LIT[6]],~SYM[1]); end ~IF ~ISACTIVEENABLE[4] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_blockRamFile][3]~IF ~VIVADO ~THEN if (~ARG[4]) begin if (~ARG[8]) begin ~SYM[1][~ARG[9]] <= ~ARG[10]; end ~RESULT <= ~SYM[1][~ARG[7]]; end~ELSE if (~ARG[8] & ~ARG[4]) begin ~SYM[1][~ARG[9]] <= ~ARG[10]; end if (~ARG[4]) begin ~RESULT <= ~SYM[1][~ARG[7]]; end~FI end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3] if (~ARG[8]) begin ~SYM[1][~ARG[9]] <= ~ARG[10]; end ~RESULT <= ~SYM[1][~ARG[7]]; end~FI // blockRamFile end clash-lib-1.8.1/prims/verilog/Clash_Explicit_DDR.primitives.yaml0000644000000000000000000001050607346545000023015 0ustar0000000000000000- BlackBox: name: Clash.Explicit.DDR.ddrIn# kind: Declaration type: |- ddrIn# :: forall a slow fast n pFast gated synchronous. ( HasCallStack -- ARG[0] , NFDataX a -- ARG[1] , KnownConfi~ fast domf -- ARG[2] , KnownConfi~ slow doms -- ARG[3] => Clock slow -- ARG[4] -> Reset slow -- ARG[5] -> Enable slow -- ARG[6] -> a -- ARG[7] -> a -- ARG[8] -> a -- ARG[9] -> Signal fast a -- ARG[10] -> Signal slow (a,a) template: |- // ddrIn begin reg ~SIGD[~GENSYM[data_Pos][1]][9]; reg ~SIGD[~GENSYM[data_Neg][2]][9]; reg ~SIGD[~GENSYM[data_Neg_Latch][3]][9]; 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_ddrIn_pos][6] if (~IF~ISACTIVEHIGH[2]~THEN~ARG[5]~ELSE! ~ARG[5]~FI) begin ~SYM[1] <= ~ARG[8]; end else ~IF ~ISACTIVEENABLE[6] ~THEN if (~ARG[6]) ~ELSE ~FI begin ~SYM[1] <= ~ARG[10]; end end always @(~IF~ACTIVEEDGE[Rising][2]~THENnegedge~ELSEposedge~FI ~ARG[4]~IF~ISSYNC[3]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[5])~FI begin : ~GENSYM[~COMPNAME_ddrIn_neg][7] if (~IF~ISACTIVEHIGH[2]~THEN~ARG[5]~ELSE! ~ARG[5]~FI) begin ~SYM[2] <= ~ARG[9]; end else ~IF ~ISACTIVEENABLE[6] ~THEN if (~ARG[6]) ~ELSE ~FI begin ~SYM[2] <= ~ARG[10]; end end 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_ddrIn_neg_latch][8] if (~IF~ISACTIVEHIGH[2]~THEN~ARG[5]~ELSE! ~ARG[5]~FI) begin ~SYM[3] <= ~ARG[7]; end else ~IF ~ISACTIVEENABLE[6] ~THEN if (~ARG[6]) ~ELSE ~FI begin ~SYM[3] <= ~SYM[2]; end end assign ~RESULT = {~SYM[3], ~SYM[1]}; // ddrIn end - BlackBox: name: Clash.Explicit.DDR.ddrOut# kind: Declaration type: |- ddrOut# :: ( HasCallStack -- ARG[0] , NFDataX a -- ARG[1] , KnownConfi~ fast domf -- ARG[2] , KnownConfi~ slow doms -- ARG[3] => Clock slow -- ARG[4] -> Reset slow -- ARG[5] -> Enable slow -- ARG[6] -> a -- ARG[7] -> Signal slow a -- ARG[8] -> Signal slow a -- ARG[9] -> Signal fast a template: |- // 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]; end else ~IF ~ISACTIVEENABLE[6] ~THEN if (~ARG[6]) ~ELSE ~FI begin ~SYM[1] <= ~ARG[8]; end end 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_neg][6] if (~IF~ISACTIVEHIGH[2]~THEN~ARG[5]~ELSE! ~ARG[5]~FI) begin ~SYM[2] <= ~ARG[7]; end else ~IF ~ISACTIVEENABLE[6] ~THEN if (~ARG[6]) ~ELSE ~FI begin ~SYM[2] <= ~ARG[9]; end end ~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 clash-lib-1.8.1/prims/verilog/Clash_Explicit_RAM.primitives.yaml0000644000000000000000000000213707346545000023024 0ustar0000000000000000- BlackBox: name: Clash.Explicit.RAM.asyncRam# kind: Declaration type: |- asyncRam# :: ( HasCallStack -- ARG[0] , KnownDomain wdom -- ARG[1] , KnownDomain rdom -- ARG[2] , NFDataX a ) -- ARG[3] => Clock wdom -- ^ wclk, ARG[4] -> Clock rdom -- ^ rclk, ARG[5] -> Enable wdom -- ^ wen, ARG[6] -> SNat n -- ^ sz, ARG[7] -> Signal rdom Int -- ^ rd, ARG[8] -> Signal wdom Bool -- ^ en, ARG[9] -> Signal wdom Int -- ^ wr, ARG[10] -> Signal wdom a -- ^ din, ARG[11] -> Signal rdom a template: |- // asyncRam begin reg ~TYPO ~GENSYM[RAM][0] [0:~LIT[7]-1]; always @(~IF~ACTIVEEDGE[Rising][1]~THENposedge~ELSEnegedge~FI ~ARG[4]) begin : ~GENSYM[~COMPNAME_Ram][1] if (~ARG[9] ~IF ~ISACTIVEENABLE[6] ~THEN & ~ARG[6] ~ELSE ~FI) begin ~SYM[0][~ARG[10]] <= ~ARG[11]; end end assign ~RESULT = ~SYM[0][~ARG[8]]; // asyncRam end clash-lib-1.8.1/prims/verilog/Clash_Explicit_ROM.primitives.yaml0000644000000000000000000000233307346545000023040 0ustar0000000000000000- BlackBox: name: Clash.Explicit.ROM.rom# kind: Declaration outputUsage: NonBlocking type: |- rom# :: ( KnownDomain dom ARG[0] , KnownNat n -- ARG[1] , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> Vec n a -- init, ARG[5] -> Signal dom Int -- rd, ARG[6] -> Signal dom a template: |- // rom begin reg ~TYPO ~GENSYM[ROM][1] [0:~LIT[1]-1]; reg ~TYP[5] ~GENSYM[rom_init][3]; integer ~GENSYM[i][4]; initial begin ~SYM[3] = ~LIT[5]; for (~SYM[4]=0; ~SYM[4] < ~LIT[1]; ~SYM[4] = ~SYM[4] + 1) begin ~SYM[1][~LIT[1]-1-~SYM[4]] = ~SYM[3][~SYM[4]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; end end ~IF ~ISACTIVEENABLE[4] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_rom][5] if (~ARG[4]) begin ~RESULT <= ~SYM[1][~ARG[6]]; end end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[5] ~RESULT <= ~SYM[1][~ARG[6]]; end~FI // rom end clash-lib-1.8.1/prims/verilog/Clash_Explicit_ROM_Blob.primitives.yaml0000644000000000000000000000226407346545000024001 0ustar0000000000000000- BlackBox: name: Clash.Explicit.ROM.Blob.romBlob# kind: Declaration outputUsage: NonBlocking type: |- romBlob# :: KnownDomain dom -- ARG[0] => Clock dom -- clk, ARG[1] -> Enable dom -- en, ARG[2] -> MemBlob n m -- init, ARG[3] -> Signal dom Int -- rd, ARG[4] -> Signal dom (BitVector m) template: |- // romBlob begin reg ~TYPO ~GENSYM[ROM][1] [0:~LENGTH[~TYP[3]]-1]; reg ~TYP[3] ~GENSYM[rom_init][3]; integer ~GENSYM[i][4]; initial begin ~SYM[3] = ~CONST[3]; for (~SYM[4]=0; ~SYM[4] < ~LENGTH[~TYP[3]]; ~SYM[4] = ~SYM[4] + 1) begin ~SYM[1][~LENGTH[~TYP[3]]-1-~SYM[4]] = ~SYM[3][~SYM[4]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; end end ~IF ~ISACTIVEENABLE[2] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~GENSYM[~COMPNAME_rom][5] if (~ARG[2]) begin ~RESULT <= ~SYM[1][~ARG[4]]; end end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~SYM[5] ~RESULT <= ~SYM[1][~ARG[4]]; end~FI // romBlob end clash-lib-1.8.1/prims/verilog/Clash_Explicit_ROM_File.primitives.yaml0000644000000000000000000000217607346545000024004 0ustar0000000000000000- BlackBox: name: Clash.Explicit.ROM.File.romFile# kind: Declaration outputUsage: NonBlocking type: |- romFile# :: ( KnownNat m -- ARG[0] , KnownDomain dom ) -- ARG[1] => Clock dom -- clk, ARG[2] -> Enable dom -- en, ARG[3] -> SNat n -- sz, ARG[4] -> FilePath -- file, ARG[5] -> Signal dom Int -- rd, ARG[6] -> Signal dom (BitVector m) template: |- // romFile begin reg ~TYPO ~GENSYM[ROM][0] [0:~LIT[4]-1]; initial begin $readmemb(~FILE[~LIT[5]],~SYM[0]); end ~IF ~ISACTIVEENABLE[3] ~THEN always @(~IF~ACTIVEEDGE[Rising][1]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~GENSYM[~COMPNAME_romFile][2] if (~ARG[3]) begin ~RESULT <= ~SYM[0][~ARG[6]]; end end~ELSE always @(~IF~ACTIVEEDGE[Rising][1]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~SYM[2] ~RESULT <= ~SYM[0][~ARG[6]]; end~FI // romFile end clash-lib-1.8.1/prims/verilog/Clash_Explicit_Testbench.primitives.yaml0000644000000000000000000000433307346545000024324 0ustar0000000000000000- BlackBox: name: Clash.Explicit.Testbench.assert kind: Declaration type: |- assert :: (KnownDomain dom, Eq a, ShowX a) -- (ARG[0], ARG[1], ARG[2]) => Clock dom -- ARG[3] -> Reset dom -- ARG[4] -> String -- ARG[5] -> Signal dom a -- Checked value (ARG[6]) -> Signal dom a -- Expected value (ARG[7]) -> Signal dom b -- Return valued (ARG[8]) -> Signal dom b template: |- // assert begin // pragma translate_off always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin if (~ARG[6] !== ~ARG[7]) begin $display("@%0tns: %s, expected: %b, actual: %b", $time, ~LIT[5], ~ARG[7], ~ARG[6]); $finish; end end // pragma translate_on assign ~RESULT = ~ARG[8]; // assert end - BlackBox: name: Clash.Explicit.Testbench.assertBitVector kind: Declaration type: |- assertBitVector :: ( KnownDomain dom -- ARG[0] , KnownNat n -- ARG[1] => Clock dom -- ARG[2] -> Reset dom -- ARG[3] -> String -- ARG[4] -> Signal dom (BitVector n) -- Checked value (ARG[5]) -> Signal dom (BitVector n) -- Expected value (ARG[6]) -> Signal dom b -- Return valued (ARG[7]) -> Signal dom b template: |- // assertBitVector begin // pragma translate_off wire ~TYP[5] ~GENSYM[maskXor][0] = ~ARG[6] ^ ~ARG[6]; wire ~TYP[5] ~GENSYM[checked][1] = ~ARG[5] ^ ~SYM[0]; wire ~TYP[5] ~GENSYM[expected][2] = ~ARG[6] ^ ~SYM[0]; always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin if (~SYM[1] !== ~SYM[2]) begin $display("@%0tns: %s, expected: %b, actual: %b", $time, ~LIT[4], ~ARG[6], ~ARG[5]); $finish; end end // pragma translate_on assign ~RESULT = ~ARG[7]; // assertBitVector end clash-lib-1.8.1/prims/verilog/Clash_Intel_DDR.primitives.yaml0000644000000000000000000000275207346545000022313 0ustar0000000000000000- BlackBox: name: Clash.Intel.DDR.altddioIn kind: Declaration libraries: - altera_mf type: |- altddioIn :: ( HasCallStack -- ARG[0] , KnownConfi~ fast domf -- ARG[1] , KnownConfi~ slow doms -- ARG[2] , KnownNat m ) -- ARG[3] => SSymbol deviceFamily -- ARG[4] -> Clock slow -- ARG[5] -> Reset slow -- ARG[6] -> Enable slow -- ARG[7] -> Signal fast (BitVector m) -- ARG[8] -> Signal slow (BitVector m,BitVector m) template: |- // altddioIn begin wire ~SIGD[~GENSYM[dataout_l][1]][8]; wire ~SIGD[~GENSYM[dataout_h][2]][8]; altddio_in #( .intended_device_family (~LIT[4]), .invert_input_clocks ("OFF"), .lpm_hint ("UNUSED"), .lpm_type ("altddio_in"), .power_up_high ("OFF"), .width (~SIZE[~TYP[7]]) ) ~GENSYM[~COMPNAME_ALTDDIO_IN][7] (~IF ~ISSYNC[2] ~THEN .sclr (~ARG[6]), .aclr (1'b0),~ELSE .aclr (~ARG[6]), .sclr (1'b0),~FI .datain (~ARG[8]), .inclock (~ARG[5]), .inclocken (~IF ~ISACTIVEENABLE[7] ~THEN ~ARG[7] ~ELSE 1'b1 ~FI), .dataout_h (~SYM[2]), .dataout_l (~SYM[1]), .aset (1'b0), .sset (1'b0) ); assign ~RESULT = {~SYM[1],~SYM[2]}; // altddioIn end clash-lib-1.8.1/prims/verilog/Clash_Prelude_ROM.primitives.yaml0000644000000000000000000000133707346545000022662 0ustar0000000000000000- BlackBox: name: Clash.Prelude.ROM.asyncRom# kind: Declaration type: |- 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[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] assign ~SYM[0][(~LIT[0]-1)-~SYM[2]] = ~SYM[1][~SYM[2]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; end ~ENDGENERATE assign ~RESULT = ~SYM[0][~ARG[3]]; // asyncRom end clash-lib-1.8.1/prims/verilog/Clash_Prelude_ROM_Blob.primitives.yaml0000644000000000000000000000132107346545000023611 0ustar0000000000000000- BlackBox: name: Clash.Prelude.ROM.Blob.asyncRomBlob# kind: Declaration type: |- asyncRomBlob# :: MemBlob n m -- ARG[0] -> Int -- ARG[1] -> BitVector m template: |- // asyncRomBlob begin wire ~TYPO ~GENSYM[ROM][0] [0:~LENGTH[~TYP[0]]-1]; wire ~TYP[0] ~GENSYM[romflat][1]; assign ~SYM[1] = ~CONST[0]; genvar ~GENSYM[i][2]; ~GENERATE for (~SYM[2]=0; ~SYM[2] < ~LENGTH[~TYP[0]]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3] assign ~SYM[0][(~LENGTH[~TYP[0]]-1)-~SYM[2]] = ~SYM[1][~SYM[2]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; end ~ENDGENERATE assign ~RESULT = ~SYM[0][~ARG[1]]; // asyncRomBlob end clash-lib-1.8.1/prims/verilog/Clash_Prelude_ROM_File.primitives.yaml0000644000000000000000000000105407346545000023615 0ustar0000000000000000- BlackBox: name: Clash.Prelude.ROM.File.asyncRomFile# kind: Declaration type: |- asyncRomFile :: KnownNat m -- ARG[0] => SNat n -- sz, ARG[1] -> FilePath -- file, ARG[2] -> Int -- rd, ARG[3] -> BitVector m template: |- // asyncRomFile begin reg ~TYPO ~GENSYM[ROM][0] [0:~LIT[1]-1]; initial begin $readmemb(~FILE[~LIT[2]],~SYM[0]); end assign ~RESULT = ~SYM[0][~ARG[3]]; // asyncRomFile end clash-lib-1.8.1/prims/verilog/Clash_Signal_BiSignal.primitives.yaml0000644000000000000000000000174407346545000023534 0ustar0000000000000000- BlackBox: name: Clash.Signal.BiSignal.writeToBiSignal# kind: Declaration type: |- writeToBiSignal# :: HasCallStack -- ARG[0] => BiSignalIn ds d n -- ARG[1] -> Signal d (Maybe (BitVector n)) -- ARG[2] -> Signal d Bool -- ARG[3] -> Signal d (BitVector n) -- ARG[4] -> BiSignalOut ds d n renderVoid: RenderVoid template: |- // writeToBiSignal# begin assign ~ARG[1] = (~ARG[3] == 1'b1) ? ~ARG[4] : {~SIZE[~TYP[1]] {1'bz}}; // writeToBiSignal# end - BlackBox: name: Clash.Signal.BiSignal.readFromBiSignal# kind: Declaration type: |- readFromBiSignal# :: ( HasCallStack -- ARG[0] , KnownNat n) -- ARG[1] => BiSignalIn ds d n -- ARG[2] -> Signal d (BitVector n) template: |- // readFromBiSignal begin assign ~RESULT = ~ARG[2]; // readFromBiSignal end workInfo: Never clash-lib-1.8.1/prims/verilog/Clash_Signal_Internal.primitives.yaml0000644000000000000000000001771607346545000023626 0ustar0000000000000000- BlackBox: name: Clash.Signal.Internal.delay# kind: Declaration outputUsage: NonBlocking type: |- delay# :: ( KnownDomain dom -- ARG[0] , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Enable dom -- ARG[3] -> a -- ARG[4] -> Signal clk a -- ARG[5] -> Signal clk a resultInit: template: ~IF~ISINITDEFINED[0]~THEN~CONST[4]~ELSE~FI resultName: template: ~CTXNAME template: |- // delay begin~IF ~ISACTIVEENABLE[3] ~THEN always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~GENSYM[~RESULT_delay][1] if (~ARG[3]) begin ~RESULT <= ~ARG[5]; end end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~SYM[1] ~RESULT <= ~ARG[5]; end~FI // delay end - BlackBox: name: Clash.Signal.Internal.asyncRegister# kind: Declaration outputUsage: NonBlocking type: |- asyncRegister# :: ( KnownDomain dom -- ARG[0] , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Reset dom -- ARG[3] -> Enable dom -- ARG[4] -> a -- ARG[5] (powerup value) -> a -- ARG[6] (reset value) -> Signal clk a -- ARG[7] -> Signal clk a resultInit: template: ~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI resultName: template: ~CTXNAME template: |- // async register begin always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]~IF ~ISUNDEFINED[6] ~THEN ~ELSE or ~IF ~ISACTIVEHIGH[0] ~THEN posedge ~ELSE negedge ~FI ~VAR[rst][3]~FI) begin : ~GENSYM[~RESULT_register][1] ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI~VAR[rst][3]) begin ~RESULT <= ~CONST[6]; end else ~FI~IF ~ISACTIVEENABLE[4] ~THENif (~ARG[4]) ~ELSE~FIbegin ~RESULT <= ~ARG[7]; end end // async register end - BlackBox: name: Clash.Signal.Internal.register# kind: Declaration outputUsage: NonBlocking type: |- register# :: ( KnownDomain dom -- ARG[0] , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Reset dom -- ARG[3] -> Enable dom -- ARG[4] -> a -- ARG[5] (powerup value) -> a -- ARG[6] (reset value) -> Signal clk a -- ARG[7] -> Signal clk a resultInit: template: ~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI resultName: template: ~CTXNAME template: |- // register begin always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]~IF ~ISSYNC[0] ~THEN ~ELSE~IF ~ISUNDEFINED[6] ~THEN ~ELSE or ~IF ~ISACTIVEHIGH[0] ~THEN posedge ~ELSE negedge ~FI ~VAR[rst][3]~FI~FI) begin : ~GENSYM[~RESULT_register][1] ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI~VAR[rst][3]) begin ~RESULT <= ~CONST[6]; end else ~FI~IF ~ISACTIVEENABLE[4] ~THENif (~ARG[4]) ~ELSE~FIbegin ~RESULT <= ~ARG[7]; end end // register end - BlackBox: name: Clash.Signal.Internal.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~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,",(~ ~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 - 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 kind: Declaration type: 'resetGenN :: (KnownDomain dom, 1 <= n) => SNat n -> Reset dom' template: |- // resetGen begin // pragma translate_off reg ~TYPO ~GENSYM[rst][0]; localparam ~GENSYM[reset_period][1] = ~LONGESTPERIOD0 - 10 + (~LIT[2] * ~PERIOD[0]0); `ifndef VERILATOR initial begin #1 ~SYM[0] = ~IF ~ISACTIVEHIGH[0] ~THEN 1 ~ELSE 0 ~FI; #~SYM[1] ~SYM[0] = ~IF ~ISACTIVEHIGH[0] ~THEN 0 ~ELSE 1 ~FI; end `else always begin // The redundant (~SYM[0] | ~ ~SYM[0]) is needed to ensure that this is // calculated in every cycle by verilator. Without it, the reset will stop // being updated and will be stuck as asserted forever. ~SYM[0] = $c("this->~GENSYM[reset_gen][2](",~SYM[1],",~IF~ISACTIVEHIGH[0]~THENtrue~ELSEfalse~FI)") & (~SYM[0] | ~ ~SYM[0]); end `systemc_interface CData ~SYM[2](vluint32_t reset_period, bool active_high) { static vluint32_t to_wait = reset_period; static CData reset = active_high ? 1 : 0; static bool finished = false; if(!finished) { if(to_wait == 0) { reset = reset == 0 ? 1 : 0; finished = true; } else { to_wait = to_wait - 1; } } return reset; } `verilog `endif assign ~RESULT = ~SYM[0]; // pragma translate_on // resetGen end workInfo: Always clash-lib-1.8.1/prims/verilog/Clash_Sized_Internal_BitVector.primitives.yaml0000644000000000000000000000415507346545000025441 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.BitVector.replaceBit# kind: Declaration outputUsage: Blocking type: |- replaceBit# :: KnownNat n -- ARG[0] => BitVector n -- ARG[1] -> Int -- ARG[2] -> Bit -- ARG[3] -> BitVector n template: |- // replaceBit start always @(*) begin ~RESULT = ~ARG[1]; ~RESULT[~ARG[2]] = ~VAR[din][3]; end // replaceBit end - BlackBox: name: Clash.Sized.Internal.BitVector.setSlice# kind: Declaration outputUsage: Blocking type: |- setSlice# :: SNat (m + 1 + i) -> BitVector (m + 1 + i) -- ARG[1] -> SNat m -- ARG[2] -> SNat n -- ARG[3] -> BitVector (m + 1 - n) -- ARG[4] -> BitVector (m + 1 + i) template: |- // setSlice begin always @(*) begin ~RESULT = ~ARG[1]; ~RESULT[~LIT[2] : ~LIT[3]] = ~VAR[din][4]; end // setSlice end workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.split# kind: Expression type: |- split# :: KnownNat n -- ARG[0] => BitVector (m + n) -- ARG[1] -> (BitVector m, BitVector n) template: ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.rotateL# kind: Declaration type: 'rotateL# :: KnownNat n => BitVector n -> Int -> BitVector n' template: |- // rotateL begin wire [2*~SIZE[~TYPO]-1:0] ~GENSYM[bv][0]; assign ~SYM[0] = {~ARG[1],~ARG[1]} << (~ARG[2] % ~SIZE[~TYPO]); assign ~RESULT = ~SYM[0][2*~SIZE[~TYPO]-1 : ~SIZE[~TYPO]]; // rotateL end - BlackBox: name: Clash.Sized.Internal.BitVector.rotateR# kind: Declaration type: 'rotateR# :: KnownNat n => BitVector n -> Int -> BitVector n' template: |- // rotateR begin wire [2*~SIZE[~TYPO]-1:0] ~GENSYM[bv][0]; assign ~SYM[0] = {~ARG[1],~ARG[1]} >> (~ARG[2] % ~SIZE[~TYPO]); assign ~RESULT = ~SYM[0][~SIZE[~TYPO]-1 : 0]; // rotateR end clash-lib-1.8.1/prims/verilog/Clash_Sized_Internal_Signed.primitives.yaml0000644000000000000000000000501307346545000024743 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.Signed.div# kind: Declaration type: 'div# :: KnownNat n => Signed n -> Signed n -> Signed n' template: |- // divSigned begin 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]; assign ~SYM[1] = ~VAR[dividend][1][~SIZE[~TYPO]-1] == ~VAR[divider][2][~SIZE[~TYPO]-1]; assign ~SYM[2] = ~VAR[divider][2][~SIZE[~TYPO]-1] == 1'b1; assign ~SYM[4] = $signed({{~VAR[dividend][1][~SIZE[~TYPO]-1]},~VAR[dividend][1]}); // sign extension assign ~SYM[5] = $signed({{~VAR[divider][2][~SIZE[~TYPO]-1]} ,~VAR[divider][2]} ); // 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]); // divSigned end - BlackBox: name: Clash.Sized.Internal.Signed.mod# kind: Declaration type: 'mod# :: Signed n -> Signed n -> Signed n' template: |- // modSigned begin // remainder wire ~SIGD[~GENSYM[rem_res][0]][0]; assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; // modulo assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : (~SYM[0] == ~SIZE[~TYPO]'sd0 ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modSigned end - BlackBox: name: Clash.Sized.Internal.Signed.rotateL# kind: Declaration type: 'rotateL# :: KnownNat n => Signed n -> Int -> Signed n' template: |- // rotateL begin wire [2*~SIZE[~TYPO]-1:0] ~GENSYM[s][0]; assign ~SYM[0] = {~ARG[1],~ARG[1]} << (~ARG[2] % ~SIZE[~TYPO]); assign ~RESULT = $signed(~SYM[0][2*~SIZE[~TYPO]-1 : ~SIZE[~TYPO]]); // rotateL end - BlackBox: name: Clash.Sized.Internal.Signed.rotateR# kind: Declaration type: 'rotateR# :: KnownNat n => Signed n -> Int -> Signed n' template: |- // rotateR begin wire [2*~SIZE[~TYPO]-1:0] ~GENSYM[s][0]; assign ~SYM[0] = {~ARG[1],~ARG[1]} >> (~ARG[2] % ~SIZE[~TYPO]); assign ~RESULT = $signed(~SYM[0][~SIZE[~TYPO]-1 : 0]); // rotateR end clash-lib-1.8.1/prims/verilog/Clash_Sized_Internal_Unsigned.primitives.yaml0000644000000000000000000000142707346545000025313 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.Unsigned.rotateL# kind: Declaration type: 'rotateL# :: KnownNat n => Unsigned n -> Int -> Unsigned n' template: |- // rotateL begin wire [2*~SIZE[~TYPO]-1:0] ~GENSYM[u][0]; assign ~SYM[0] = {~ARG[1],~ARG[1]} << (~ARG[2] % ~SIZE[~TYPO]); assign ~RESULT = ~SYM[0][2*~SIZE[~TYPO]-1 : ~SIZE[~TYPO]]; // rotateL end - BlackBox: name: Clash.Sized.Internal.Unsigned.rotateR# kind: Declaration type: 'rotateR# :: KnownNat n => Unsigned n -> Int -> Unsigned n' template: |- // rotateR begin wire [2*~SIZE[~TYPO]-1:0] ~GENSYM[u][0]; assign ~SYM[0] = {~ARG[1],~ARG[1]} >> (~ARG[2] % ~SIZE[~TYPO]); assign ~RESULT = ~SYM[0][~SIZE[~TYPO]-1 : 0]; // rotateR end clash-lib-1.8.1/prims/verilog/Clash_Sized_RTree.primitives.yaml0000644000000000000000000000106407346545000022721 0ustar0000000000000000- BlackBox: name: Clash.Sized.RTree.treplicate kind: Expression type: 'replicate :: SNat d -> a -> RTree d a' template: '{(2**~LIT[0]) {~ARG[1]}}' workInfo: Never - BlackBox: name: Clash.Sized.RTree.textract kind: Expression type: 'textract :: RTree 0 a -> a' template: '~VAR[tree][0][~SIZE[~TYP[0]]-1 -: ~SIZE[~TYPO]]' workInfo: Never - BlackBox: name: Clash.Sized.RTree.tsplit kind: Expression type: 'tsplit:: RTree (d+1) a -> (RTree d a,RTree d a)' template: ~ARG[0] workInfo: Never clash-lib-1.8.1/prims/verilog/Clash_Sized_Vector.primitives.yaml0000644000000000000000000003040707346545000023145 0ustar0000000000000000- BlackBox: name: Clash.Sized.Vector.head kind: Expression type: 'head :: Vec (n + 1) a -> a' template: '~FROMBV[~VAR[vec][0][\~SIZE[~TYP[0]]-1 -: ~SIZE[~TYPO]\]][~TYPO]' workInfo: Never - BlackBox: name: Clash.Sized.Vector.tail kind: Expression type: 'tail :: Vec (n + 1) a -> Vec n a' template: '~VAR[vec][0][~SIZE[~TYPO]-1 : 0]' workInfo: Never - BlackBox: name: Clash.Sized.Vector.last kind: Expression type: Vec (n + 1) a -> a template: ~FROMBV[~VAR[vec][0][\~SIZE[~TYPO]-1:0\]][~TYPO] workInfo: Never - BlackBox: name: Clash.Sized.Vector.init kind: Expression type: Vec (n + 1) a -> Vec n a template: '~VAR[vec][0][~SIZE[~TYP[0]]-1 : ~SIZE[~TYPEL[~TYP[0]]]]' workInfo: Never - BlackBox: name: Clash.Sized.Vector.select kind: Declaration type: |- select :: (CmpNat (i + s) (s * n) ~ GT) -- ARG[0] => SNat f -- ARG[1] -> SNat s -- ARG[2] -> SNat n -- ARG[3] -> Vec i a -- ARG[4] -> Vec n a template: |- // select begin wire ~TYPEL[~TYPO] ~SYM[1] [0:~LENGTH[~TYP[4]]-1]; genvar ~GENSYM[i][2]; ~GENERATE for (~SYM[2]=0; ~SYM[2] < ~LENGTH[~TYP[4]]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3] assign ~SYM[1][(~LENGTH[~TYP[4]]-1)-~SYM[2]] = ~VAR[vec][4][~SYM[2]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]]; end ~ENDGENERATE genvar ~GENSYM[i][4]; ~GENERATE for (~SYM[4]=0; ~SYM[4] < ~LIT[3]; ~SYM[4] = ~SYM[4] + 1) begin : ~GENSYM[select][5] assign ~RESULT[(~LIT[3]-1-~SYM[4])*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[1][~LIT[1] + (~LIT[2] * ~SYM[4])]; end ~ENDGENERATE // select end workInfo: Never - BlackBox: name: Clash.Sized.Vector.++ kind: Expression type: '(++) :: Vec n a -> Vec m a -> Vec (n + m) a' template: '{~ARG[0],~ARG[1]}' workInfo: Never - BlackBox: name: Clash.Sized.Vector.concat kind: Expression type: 'concat :: Vec n (Vec m a) -> Vec (n * m) a' template: ~ARG[0] workInfo: Never - BlackBox: name: Clash.Sized.Vector.splitAt kind: Expression type: 'splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)' template: ~ARG[1] workInfo: Never - BlackBox: name: Clash.Sized.Vector.unconcat kind: Expression type: |- unconcat :: KnownNat n -- ARG[0] => SNat m -- ARG[1] -> Vec (n * m) a -- ARG[2] -> Vec n (Vec m a) template: ~ARG[2]~DEVNULL[~ARG[0]]~DEVNULL[~ARG[1]] workInfo: Never - BlackBox: name: Clash.Sized.Vector.map kind: Declaration type: 'map :: (a -> b) -> Vec n a -> Vec n b' template: |- // map begin genvar ~GENSYM[i][1]; ~GENERATE 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 ~OUTPUTUSAGE[0] ~TYPEL[~TYPO] ~GENSYM[map_out][4]; ~INST 0 ~OUTPUT <= ~SYM[4]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[3]~ ~TYPEL[~TYP[1]]~ ~INST assign ~RESULT[~SYM[1]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[4]; end ~ENDGENERATE // map end workInfo: Identity 1 [0] - BlackBox: name: Clash.Sized.Vector.imap kind: Declaration type: 'imap :: KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b' template: |- // imap begin genvar ~GENSYM[i][1]; ~GENERATE for (~SYM[1]=0; ~SYM[1] < ~LENGTH[~TYPO]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[imap][2] 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 ~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 ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[3]~ ~INDEXTYPE[~LIT[0]]~ ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[2]]~ ~INST assign ~RESULT[~SYM[1]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[5]; end ~ENDGENERATE // imap end workInfo: Never - BlackBox: name: Clash.Sized.Vector.imap_go kind: Declaration type: 'imap :: Index n -> (Index n -> a -> b) -> Vec m a -> Vec m b' template: |- // imap begin genvar ~GENSYM[i][1]; ~GENERATE for (~SYM[1]=0; ~SYM[1] < ~LENGTH[~TYPO]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[imap][2] 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 ~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 ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[3]~ ~TYP[0]~ ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[2]]~ ~INST assign ~RESULT[~SYM[1]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[5]; end ~ENDGENERATE // imap end workInfo: Never - BlackBox: name: Clash.Sized.Vector.zipWith kind: Declaration type: 'zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c' template: |- // zipWith start genvar ~GENSYM[i][2]; ~GENERATE for (~SYM[2] = 0; ~SYM[2] < ~LENGTH[~TYPO]; ~SYM[2] = ~SYM[2] + 1) begin : ~GENSYM[zipWith][6]~IF~SIZE[~TYP[1]]~THEN wire ~TYPEL[~TYP[1]] ~GENSYM[zipWith_in1][3]; 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 ~OUTPUTUSAGE[0] ~TYPEL[~TYPO] ~SYM[5]; ~INST 0 ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[3]~ ~TYPEL[~TYP[1]]~ ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[2]]~ ~INST assign ~RESULT[~SYM[2]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[5]; end ~ENDGENERATE // zipWith end workInfo: Never - BlackBox: name: Clash.Sized.Vector.foldr kind: Declaration type: 'foldr :: (a -> b -> b) -> b -> Vec n a -> b' template: |- // foldr start~IF ~LENGTH[~TYP[2]] ~THEN wire ~TYPO ~GENSYM[intermediate][0] [0:~LENGTH[~TYP[2]]]; assign ~SYM[0][~LENGTH[~TYP[2]]] = ~ARG[1]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0; ~SYM[3] < ~LENGTH[~TYP[2]]; ~SYM[3]=~SYM[3]+1) begin : ~GENSYM[foldr][4]~IF~SIZE[~TYP[2]]~THEN 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]; ~OUTPUTUSAGE[0] ~TYPO ~GENSYM[foldr_out][7]; assign ~SYM[6] = ~SYM[0][~SYM[3]+1]; ~INST 0 ~OUTPUT <= ~SYM[7]~ ~TYP[1]~ ~INPUT <= ~SYM[5]~ ~TYPEL[~TYP[2]]~ ~INPUT <= ~SYM[6]~ ~TYP[1]~ ~INST assign ~SYM[0][~SYM[3]] = ~SYM[7]; end ~ENDGENERATE assign ~RESULT = ~SYM[0][0]; ~ELSE assign ~RESULT = ~ARG[1]; ~FI// foldr end workInfo: Never - BlackBoxHaskell: name: Clash.Sized.Vector.index_int templateFunction: Clash.Primitives.Sized.Vector.indexIntVerilog - BlackBox: name: Clash.Sized.Vector.replace_int kind: Declaration type: 'replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a' template: |- // vector replace begin genvar ~GENSYM[i][0]; ~GENERATE for (~SYM[0]=0;~SYM[0]<~LENGTH[~TYPO];~SYM[0]=~SYM[0]+1) begin : ~GENSYM[vector_replace][1] assign ~RESULT[(~MAXINDEX[~TYPO]-~SYM[0])*~SIZE[~TYP[3]]+:~SIZE[~TYP[3]]] = ~ARG[2] == ~SYM[0] ? ~ARG[3] : ~VAR[vec][1][(~MAXINDEX[~TYPO]-~SYM[0])*~SIZE[~TYP[3]]+:~SIZE[~TYP[3]]]; end ~ENDGENERATE // vector replace end - BlackBox: name: Clash.Sized.Vector.maxIndex kind: Expression type: 'maxIndex :: KnownNat n => Vec n a -> Int' template: ~SIZE[~TYPO]'sd~LIT[0] - ~SIZE[~TYPO]'d1 workInfo: Constant - BlackBox: name: Clash.Sized.Vector.length kind: Expression type: 'length :: KnownNat n => Vec n a -> Int' template: ~SIZE[~TYPO]'sd~LIT[0] workInfo: Constant - BlackBox: name: Clash.Sized.Vector.replicate kind: Expression type: 'replicate :: SNat n -> a -> Vec n a' template: '{~LIT[0] {~ARG[1]}}' workInfo: Never - BlackBox: name: Clash.Sized.Vector.transpose kind: Declaration type: 'transpose :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)' template: |- // transpose begin genvar ~GENSYM[row_index][1]; genvar ~GENSYM[col_index][2]; ~GENERATE for (~SYM[1] = 0; ~SYM[1] < ~LENGTH[~TYP[1]]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[transpose_outer][3] for (~SYM[2] = 0; ~SYM[2] < ~LENGTH[~TYPO]; ~SYM[2] = ~SYM[2] + 1) begin : ~GENSYM[transpose_inner][4] assign ~RESULT[((~SYM[2]*~SIZE[~TYPEL[~TYPO]])+(~SYM[1]*~SIZE[~TYPEL[~TYPEL[~TYPO]]]))+:~SIZE[~TYPEL[~TYPEL[~TYPO]]]] = ~VAR[matrix][1][((~SYM[1]*~SIZE[~TYPEL[~TYP[1]]])+(~SYM[2]*~SIZE[~TYPEL[~TYPEL[~TYPO]]]))+:~SIZE[~TYPEL[~TYPEL[~TYPO]]]]; end end ~ENDGENERATE // transpose end workInfo: Never - BlackBox: name: Clash.Sized.Vector.reverse kind: Declaration type: 'reverse :: Vec n a -> Vec n a' template: |- // reverse begin genvar ~GENSYM[i][1]; ~GENERATE for (~SYM[1] = 0; ~SYM[1] < ~LENGTH[~TYPO]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[reverse][2] assign ~RESULT[(~LENGTH[~TYPO] - 1 - ~SYM[1])*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~VAR[vec][0][~SYM[1]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]]; end ~ENDGENERATE // reverse end workInfo: Never - BlackBox: name: Clash.Sized.Vector.concatBitVector# kind: Expression type: |- concatBitVector# :: (KnownNat n, KnownNat m) -- (ARG[0],ARG[1]) => Vec n (BitVector m) -- ARG[2] -> BitVector (n * m) template: ~ARG[2] workInfo: Never - BlackBox: name: Clash.Sized.Vector.unconcatBitVector# kind: Expression type: |- unconcatBitVector# :: (KnownNat n, KnownNat m) -- (ARG[0],ARG[1]) => BitVector (n * m) -- ARG[2] -> Vec n (BitVector m) template: ~ARG[2] workInfo: Never - BlackBox: name: Clash.Sized.Vector.rotateLeftS kind: Declaration type: 'rotateLeftS :: KnownNat n => Vec n a -> SNat d -> Vec n a' template: |- // rotateLeftS begin localparam ~GENSYM[shift_amount][2] = ~LIT[2] % ~LIT[0]; ~GENERATE if (~SYM[2] == 0) begin : ~GENSYM[no_shift][3] assign ~RESULT = ~VAR[vec][1]; end else begin : ~GENSYM[do_shift][4] assign ~RESULT = {~VAR[vec][1][((~LIT[0]-~SYM[2])*~SIZE[~TYPEL[~TYPO]])-1 : 0] ,~VAR[vec][1][~SIZE[~TYPO]-1 : (~LIT[0]-~SYM[2])*~SIZE[~TYPEL[~TYPO]]] }; end ~ENDGENERATE // rotateLeftS end workInfo: Never - BlackBox: name: Clash.Sized.Vector.rotateRightS kind: Declaration type: 'rotateRightS :: KnownNat n => Vec n a -> SNat d -> Vec n a' template: |- // rotateRightS begin localparam ~GENSYM[shift_amount][2] = ~LIT[2] % ~LIT[0]; ~GENERATE if (~SYM[2] == 0) begin : ~GENSYM[no_shift][3] assign ~RESULT = ~VAR[vec][1]; end else begin : ~GENSYM[do_shift][4] assign ~RESULT = {~VAR[vec][1][(~SYM[2]*~SIZE[~TYPEL[~TYPO]])-1 : 0] ,~VAR[vec][1][~SIZE[~TYPO]-1 : ~SYM[2]*~SIZE[~TYPEL[~TYPO]]] }; end ~ENDGENERATE // rotateRightS end workInfo: Never clash-lib-1.8.1/prims/verilog/Clash_Xilinx_DDR.primitives.yaml0000644000000000000000000000533007346545000022506 0ustar0000000000000000- BlackBox: name: Clash.Xilinx.DDR.iddr kind: Declaration type: |- iddr :: ( HasCallStack -- ARG[0] , KnownConfi~ fast domf -- ARG[1] , KnownConfi~ slow doms -- ARG[2] , KnownNat m ) -- ARG[3] -> Clock slow -- ARG[4] -> Reset slow -- ARG[5] -> Enable slow -- ARG[6] -> Signal fast (BitVector m) -- ARG[7] -> Signal slow (BitVector m,BitVector m) template: |- // iddr begin wire ~SIGD[~GENSYM[dataout_l][1]][7]; wire ~SIGD[~GENSYM[dataout_h][2]][7]; wire ~SIGD[~GENSYM[d][3]][7]; assign ~SYM[3] = ~ARG[7]; genvar ~GENSYM[i][8]; ~GENERATE for (~SYM[8]=0; ~SYM[8] < ~SIZE[~TYP[7]]; ~SYM[8]=~SYM[8]+1) begin : ~GENSYM[ddri_array][7] IDDR #( .DDR_CLK_EDGE("SAME_EDGE"), .INIT_Q1(1'b0), .INIT_Q2(1'b0), .SRTYPE(~IF ~ISSYNC[2] ~THEN "SYNC" ~ELSE "ASYNC" ~FI) ) ~GENSYM[~COMPNAME_IDDR][9] ( .Q1(~SYM[1][~SYM[8]]), .Q2(~SYM[2][~SYM[8]]), .C(~ARG[4]), .CE(~IF ~ISACTIVEENABLE[6] ~THEN ~ARG[6] ~ELSE 1'b1 ~FI), .D(~SYM[3][~SYM[8]]), .R(~ARG[5]), .S(1'b0) ); end ~ENDGENERATE assign ~RESULT = {~SYM[2],~SYM[1]}; // iddr end - BlackBox: name: Clash.Xilinx.DDR.oddr# kind: Declaration type: |- oddr# :: ( KnownConfi~ fast domf -- ARG[0] , KnownConfi~ slow doms -- ARG[1] , KnownNat m ) -- ARG[2] => Clock slow -- ARG[3] -> Reset slow -- ARG[4] -> Enable slow -- ARG[5] -> Signal slow (BitVector m) -- ARG[6] -> Signal slow (BitVector m) -- ARG[7] -> Signal fast (BitVector m) template: |- // oddr begin wire ~SIGD[~GENSYM[datain_l][1]][7]; wire ~SIGD[~GENSYM[datain_h][2]][7]; wire ~SIGD[~GENSYM[q][3]][7]; assign ~SYM[1] = ~ARG[6]; assign ~SYM[2] = ~ARG[7]; genvar ~GENSYM[i][8]; ~GENERATE for (~SYM[8]=0; ~SYM[8] < ~SIZE[~TYP[7]]; ~SYM[8]=~SYM[8]+1) begin : ~GENSYM[ddro_array][7] ODDR #( .DDR_CLK_EDGE("SAME_EDGE"), .INIT(1'b0), .SRTYPE(~IF ~ISSYNC[1] ~THEN "SYNC" ~ELSE "ASYNC" ~FI) ) ~GENSYM[~COMPNAME_ODDR][9] ( .Q(~SYM[3][~SYM[8]]), .C(~ARG[3]), .CE(~IF ~ISACTIVEENABLE[5] ~THEN ~ARG[5] ~ELSE 1'b1 ~FI), .D1(~SYM[1][~SYM[8]]), .D2(~SYM[2][~SYM[8]]), .R(~ARG[4]), .S(1'b0) ); end ~ENDGENERATE assign ~RESULT = ~SYM[3]; // oddr end clash-lib-1.8.1/prims/verilog/GHC_Base.primitives.yaml0000644000000000000000000000324407346545000020765 0ustar0000000000000000- BlackBox: name: GHC.Base.divInt kind: Declaration type: 'divInt :: Int -> Int -> Int' template: |- // divInt begin 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]; 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 kind: Declaration type: 'modInt :: Int -> Int -> Int' template: |- // modInt begin // remainder wire ~SIGD[~GENSYM[rem_res][0]][0]; assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; // modulo assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ((~VAR[dividend][0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modInt end clash-lib-1.8.1/prims/verilog/GHC_Classes.primitives.yaml0000644000000000000000000000325607346545000021513 0ustar0000000000000000- BlackBox: name: GHC.Classes.divInt# kind: Declaration type: 'divInt# :: Int# -> Int# -> Int#' template: |- // divInt# begin 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]; 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.Classes.modInt# kind: Declaration type: 'modInt# :: Int# -> Int# -> Int#' template: |- // modInt# begin // remainder wire ~SIGD[~GENSYM[rem_res][0]][0]; assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; // modulo assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modInt# end clash-lib-1.8.1/prims/verilog/GHC_Integer_Type.primitives.yaml0000644000000000000000000001067407346545000022516 0ustar0000000000000000- BlackBox: name: GHC.Integer.Type.divInteger kind: Declaration type: 'divInteger :: Integer -> Integer -> Integer' template: |- // divInteger begin 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]; 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]); // divInteger end warning: 'GHC.Integer.Type.divInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.modInteger kind: Declaration type: 'modInteger :: Integer -> Integer -> Integer' template: |- // modInteger begin // remainder wire ~SIGD[~GENSYM[rem_res][0]][0]; assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; // modulo assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modInteger end warning: 'GHC.Integer.Type.modInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.divModInteger kind: Declaration type: 'divModInteger :: Integer -> Integer -> (# Integer, Integer #)' template: |- // divModInteger begin wire ~GENSYM[resultPos][1]; wire ~GENSYM[dividerNeg][2]; wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividend2][3]; wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividendE][4]; wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividerE][5]; wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[quot_res][6]; wire signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[div_res][7]; assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1]; assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYP[0]]-1] == 1'b1; assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYP[0]]-1]},~VAR[dividend][0]}); // sign extension assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYP[0]]-1]} ,~VAR[divider][1]} ); // sign extension assign ~SYM[3] = ~SYM[1] ? ~SYM[4] : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYP[0]]'sd1) : (~SYM[4] - ~SYM[5] + ~SIZE[~TYP[0]]'sd1)); assign ~SYM[6] = ~SYM[3] / ~SYM[5]; assign ~SYM[7] = $signed(~SYM[6][~SIZE[~TYP[0]]-1:0]); wire ~SIGD[~GENSYM[rem_res][8]][0]; wire ~SIGD[~GENSYM[mod_res][9]][0]; assign ~SYM[8] = ~VAR[dividend][0] % ~VAR[divider][1]; // modulo assign ~SYM[9] = (~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1]) ? ~SYM[8] : ((~SYM[8] == ~SIZE[~TYP[0]]'sd0) ? ~SIZE[~TYP[0]]'sd0 : ~SYM[8] + ~VAR[divider][1]); assign ~RESULT = {~SYM[7],~SYM[9]}; // divModInteger end warning: 'GHC.Integer.Type.divModInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.quotRemInteger kind: Declaration type: 'quotRemInteger :: Integer -> Integer -> (# Integer, Integer #)' template: |- // quotRemInteger 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]}; // quotRemInteger end warning: 'GHC.Integer.Type.quotRemInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' clash-lib-1.8.1/prims/verilog/GHC_Num_Integer.primitives.yaml0000644000000000000000000001067007346545000022330 0ustar0000000000000000- BlackBox: name: GHC.Num.Integer.integerDiv kind: Declaration type: 'integerDiv :: Integer -> Integer -> Integer' template: |- // integerDiv begin 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]; 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]); // integerDiv end warning: 'GHC.Num.Integer.integerDiv: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerMod kind: Declaration type: 'integerMod :: Integer -> Integer -> Integer' template: |- // integerMod begin // remainder wire ~SIGD[~GENSYM[rem_res][0]][0]; assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1]; // modulo assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // integerMod end warning: 'GHC.Num.Integer.integerMod: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerDivMod# kind: Declaration type: 'integerDivMod :: Integer -> Integer -> (# Integer, Integer #)' template: |- // integerDivMod begin wire ~GENSYM[resultPos][1]; wire ~GENSYM[dividerNeg][2]; wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividend2][3]; wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividendE][4]; wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividerE][5]; wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[quot_res][6]; wire signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[div_res][7]; assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1]; assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYP[0]]-1] == 1'b1; assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYP[0]]-1]},~VAR[dividend][0]}); // sign extension assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYP[0]]-1]} ,~VAR[divider][1]} ); // sign extension assign ~SYM[3] = ~SYM[1] ? ~SYM[4] : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYP[0]]'sd1) : (~SYM[4] - ~SYM[5] + ~SIZE[~TYP[0]]'sd1)); assign ~SYM[6] = ~SYM[3] / ~SYM[5]; assign ~SYM[7] = $signed(~SYM[6][~SIZE[~TYP[0]]-1:0]); wire ~SIGD[~GENSYM[rem_res][8]][0]; wire ~SIGD[~GENSYM[mod_res][9]][0]; assign ~SYM[8] = ~VAR[dividend][0] % ~VAR[divider][1]; // modulo assign ~SYM[9] = (~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1]) ? ~SYM[8] : ((~SYM[8] == ~SIZE[~TYP[0]]'sd0) ? ~SIZE[~TYP[0]]'sd0 : ~SYM[8] + ~VAR[divider][1]); assign ~RESULT = {~SYM[7],~SYM[9]}; // integerDivMod end warning: 'GHC.Num.Integer.integerDivMod#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerQuotRem# kind: Declaration type: 'integerQuotRem :: Integer -> Integer -> (# Integer, Integer #)' template: |- // integerQuotRem 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]}; // integerQuotRem end warning: 'GHC.Num.Integer.integerQuotRem#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' clash-lib-1.8.1/prims/verilog/GHC_Prim.primitives.yaml0000644000000000000000000014130107346545000021017 0ustar0000000000000000- BlackBox: name: GHC.Prim.quotRemInt# kind: Declaration type: 'quotRemInt# :: Int# -> Int# -> (#Int#, Int##)' template: |- // quotRemInt 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]}; // quotRemInt end - BlackBox: name: GHC.Prim.quotRemWord# kind: Declaration type: 'quotRemWord# :: Word# -> Word# -> (#Word#, Word##)' template: |- // quotRemWord 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]}; // quotRemWord end - BlackBox: name: GHC.Prim.popCnt8# imports: - ~INCLUDENAME[0].inc includes: - name: popCnt8 extension: inc template: |- // ceiling of log2 function integer ~INCLUDENAME[0]_clog2; input integer value; begin value = value-1; for (~INCLUDENAME[0]_clog2=0; value>0; ~INCLUDENAME[0]_clog2=~INCLUDENAME[0]_clog2+1) value = value>>1; end endfunction // given a level and a depth, calculate the corresponding index into the // intermediate array function integer ~INCLUDENAME[0]_depth2Index; input integer levels; input integer depth; ~INCLUDENAME[0]_depth2Index = (2 ** levels) - (2 ** depth); endfunction kind: Declaration type: 'popCnt8# :: Word# -> Word#' template: |- // popCnt8 begin localparam ~GENSYM[width][0] = 8; // depth of the tree localparam ~GENSYM[levels][2] = ~INCLUDENAME[0]_clog2(~SYM[0]); wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; // put input into the first half of the intermediate array genvar ~GENSYM[i][4]; ~GENERATE for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]); end ~ENDGENERATE // Create the tree of instantiated components genvar ~GENSYM[d][6]; genvar ~GENSYM[i][7]; ~GENERATE if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] assign ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6])+~SYM[7]] = ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] + ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1]; end end end ~ENDGENERATE // The last element of the intermediate array holds the result assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); // popCnt8 end - BlackBox: name: GHC.Prim.popCnt16# imports: - ~INCLUDENAME[0].inc includes: - name: popCnt16 extension: inc template: |- // ceiling of log2 function integer ~INCLUDENAME[0]_clog2; input integer value; begin value = value-1; for (~INCLUDENAME[0]_clog2=0; value>0; ~INCLUDENAME[0]_clog2=~INCLUDENAME[0]_clog2+1) value = value>>1; end endfunction // given a level and a depth, calculate the corresponding index into the // intermediate array function integer ~INCLUDENAME[0]_depth2Index; input integer levels; input integer depth; ~INCLUDENAME[0]_depth2Index = (2 ** levels) - (2 ** depth); endfunction kind: Declaration type: 'popCnt16# :: Word# -> Word#' template: |- // popCnt16 begin localparam ~GENSYM[width][0] = 16; // depth of the tree localparam ~GENSYM[levels][2] = ~INCLUDENAME[0]_clog2(~SYM[0]); wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; // put input into the first half of the intermediate array genvar ~GENSYM[i][4]; ~GENERATE for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]); end ~ENDGENERATE // Create the tree of instantiated components genvar ~GENSYM[d][6]; genvar ~GENSYM[i][7]; ~GENERATE if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] assign ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6])+~SYM[7]] = ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] + ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1]; end end end ~ENDGENERATE // The last element of the intermediate array holds the result assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); // popCnt16 end - BlackBox: name: GHC.Prim.popCnt32# imports: - ~INCLUDENAME[0].inc includes: - name: popCnt32 extension: inc template: |- // ceiling of log2 function integer ~INCLUDENAME[0]_clog2; input integer value; begin value = value-1; for (~INCLUDENAME[0]_clog2=0; value>0; ~INCLUDENAME[0]_clog2=~INCLUDENAME[0]_clog2+1) value = value>>1; end endfunction // given a level and a depth, calculate the corresponding index into the // intermediate array function integer ~INCLUDENAME[0]_depth2Index; input integer levels; input integer depth; ~INCLUDENAME[0]_depth2Index = (2 ** levels) - (2 ** depth); endfunction kind: Declaration type: 'popCnt32# :: Word# -> Word#' template: |- // popCnt32 begin localparam ~GENSYM[width][0] = 32; // depth of the tree localparam ~GENSYM[levels][2] = ~INCLUDENAME[0]_clog2(~SYM[0]); wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; // put input into the first half of the intermediate array genvar ~GENSYM[i][4]; ~GENERATE for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]); end ~ENDGENERATE // Create the tree of instantiated components genvar ~GENSYM[d][6]; genvar ~GENSYM[i][7]; ~GENERATE if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] assign ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6])+~SYM[7]] = ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] + ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1]; end end end ~ENDGENERATE // The last element of the intermediate array holds the result assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); // popCnt32 end - BlackBox: name: GHC.Prim.popCnt64# imports: - ~INCLUDENAME[0].inc includes: - name: popCnt64 extension: inc template: |- // ceiling of log2 function integer ~INCLUDENAME[0]_clog2; input integer value; begin value = value-1; for (~INCLUDENAME[0]_clog2=0; value>0; ~INCLUDENAME[0]_clog2=~INCLUDENAME[0]_clog2+1) value = value>>1; end endfunction // given a level and a depth, calculate the corresponding index into the // intermediate array function integer ~INCLUDENAME[0]_depth2Index; input integer levels; input integer depth; ~INCLUDENAME[0]_depth2Index = (2 ** levels) - (2 ** depth); endfunction kind: Declaration type: 'popCnt64# :: Word# -> Word#' template: |- // popCnt64 begin localparam ~GENSYM[width][0] = 64; // depth of the tree localparam ~GENSYM[levels][2] = ~INCLUDENAME[0]_clog2(~SYM[0]); wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; // put input into the first half of the intermediate array genvar ~GENSYM[i][4]; ~GENERATE for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]); end ~ENDGENERATE // Create the tree of instantiated components genvar ~GENSYM[d][6]; genvar ~GENSYM[i][7]; ~GENERATE if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] assign ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6])+~SYM[7]] = ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] + ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1]; end end end ~ENDGENERATE // The last element of the intermediate array holds the result assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); // popCnt64 end - BlackBox: name: GHC.Prim.popCnt# imports: - ~INCLUDENAME[0].inc includes: - name: popCnt extension: inc template: |- // ceiling of log2 function integer ~INCLUDENAME[0]_clog2; input integer value; begin value = value-1; for (~INCLUDENAME[0]_clog2=0; value>0; ~INCLUDENAME[0]_clog2=~INCLUDENAME[0]_clog2+1) value = value>>1; end endfunction // given a level and a depth, calculate the corresponding index into the // intermediate array function integer ~INCLUDENAME[0]_depth2Index; input integer levels; input integer depth; ~INCLUDENAME[0]_depth2Index = (2 ** levels) - (2 ** depth); endfunction kind: Declaration type: 'popCnt# :: Word# -> Word#' template: |- // popCnt begin localparam ~GENSYM[width][0] = ~SIZE[~TYPO]; // depth of the tree localparam ~GENSYM[levels][2] = ~INCLUDENAME[0]_clog2(~SYM[0]); wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2]; // put input into the first half of the intermediate array genvar ~GENSYM[i][4]; ~GENERATE for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11] assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]); end ~ENDGENERATE // Create the tree of instantiated components genvar ~GENSYM[d][6]; genvar ~GENSYM[i][7]; ~GENERATE if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8] for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9] for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10] assign ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6])+~SYM[7]] = ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] + ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1]; end end end ~ENDGENERATE // The last element of the intermediate array holds the result assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]); // popCnt end - BlackBox: name: GHC.Prim.clz8# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'clz8 :: Word# -> Word#' template: |- // clz8 begin wire [0:7] ~GENSYM[v][1]; assign ~SYM[1] = ~VAR[i][0][7:0]; wire [0:7] ~GENSYM[e][2]; genvar ~GENSYM[n][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<4;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE reg [0:5] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<2;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage1][6] localparam n = 2; wire [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:3] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 3; wire [5:0] i; assign i = ~SYM[4][0:5]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // clz8 end - BlackBox: name: GHC.Prim.clz16# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'clz16 :: Word# -> Word#' template: |- // clz16 begin wire [0:15] ~GENSYM[v][1]; assign ~SYM[1] = ~VAR[i][0][15:0]; wire [0:15] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<8;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE reg [0:11] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<4;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; wire [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:7] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<2;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; wire [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:4] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 4; wire [7:0] i; assign i = ~SYM[9][0:7]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // clz16 end - BlackBox: name: GHC.Prim.clz32# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'clz32 :: Word# -> Word#' template: |- // clz32 begin wire [0:31] ~GENSYM[v][1]; assign ~SYM[1] = ~VAR[i][0][31:0]; wire [0:31] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE reg [0:23] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; wire [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:15] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; wire [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:9] ~GENSYM[c][12]; genvar ~GENSYM[i3][13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] localparam n = 4; wire [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:5] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 5; wire [9:0] i; assign i = ~SYM[12][0:9]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // clz32 end - BlackBox: name: GHC.Prim.clz64# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'clz64 :: Word# -> Word#' template: |- // clz64 begin wire [0:63] ~GENSYM[v][1]; assign ~SYM[1] = ~VAR[i][0][63:0]; wire [0:63] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE reg [0:47] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; wire [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:31] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; wire [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:19] ~GENSYM[c][12]; genvar ~GENSYM[i3][13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] localparam n = 4; wire [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:11] ~GENSYM[d][15]; genvar ~GENSYM[i4][16]; ~GENERATE for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] localparam n = 5; wire [9:0] i; assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:6] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 6; wire [11:0] i; assign i = ~SYM[15][0:11]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // clz64 end - BlackBox: name: GHC.Prim.clz# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'clz :: Word# -> Word#' template: |- // clz begin~IF ~IW64 ~THEN wire [0:63] ~GENSYM[v][1]; assign ~SYM[1] = ~VAR[i][0][63:0]; wire [0:63] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE reg [0:47] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; wire [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:31] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; wire [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:19] ~GENSYM[c][12]; genvar ~GENSYM[i3][13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] localparam n = 4; wire [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:11] ~GENSYM[d][15]; genvar ~GENSYM[i4][16]; ~GENERATE for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] localparam n = 5; wire [9:0] i; assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:6] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 6; wire [11:0] i; assign i = ~SYM[15][0:11]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE ~ELSE wire [0:31] ~SYM[1]; assign ~SYM[1] = ~VAR[i][0][31:0]; wire [0:31] ~SYM[2]; genvar ~SYM[3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~SYM[8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE reg [0:23] ~SYM[4]; genvar ~SYM[5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~SYM[6] localparam n = 2; wire [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:15] ~SYM[9]; genvar ~SYM[10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~SYM[11] localparam n = 3; wire [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:9] ~SYM[12]; genvar ~SYM[13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~SYM[14] localparam n = 4; wire [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:5] ~SYM[7]; ~GENERATE if (1) begin localparam n = 5; wire [9:0] i; assign i = ~SYM[12][0:9]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE ~FI assign ~RESULT = $unsigned(~SYM[7]); // clz end - BlackBox: name: GHC.Prim.ctz8# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'ctz8 :: Word# -> Word#' template: |- // ctz8 begin wire [0:7] ~GENSYM[v][1]; genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<8;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; end ~ENDGENERATE wire [0:7] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<4;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE reg [0:5] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<2;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; wire [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:3] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 3; wire [5:0] i; assign i = ~SYM[4][0:5]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // ctz8 end - BlackBox: name: GHC.Prim.ctz16# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'ctz16 :: Word# -> Word#' template: |- // ctz16 begin wire [0:15] ~GENSYM[v][1]; genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<16;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; end ~ENDGENERATE wire [0:15] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<8;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE reg [0:11] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<4;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; wire [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:7] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<2;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; wire [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:4] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 4; wire [7:0] i; assign i = ~SYM[9][0:7]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // ctz16 end - BlackBox: name: GHC.Prim.ctz32# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'ctz32 :: Word# -> Word#' template: |- // ctz32 begin wire [0:31] ~GENSYM[v][1]; genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; end ~ENDGENERATE wire [0:31] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE reg [0:23] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; wire [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:15] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; wire [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:9] ~GENSYM[c][12]; genvar ~GENSYM[i3][13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] localparam n = 4; wire [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:5] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 5; wire [9:0] i; assign i = ~SYM[12][0:9]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // ctz32 end - BlackBox: name: GHC.Prim.ctz64# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'ctz64 :: Word# -> Word#' template: |- // ctz64 begin wire [0:63] ~GENSYM[v][1]; genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; end ~ENDGENERATE wire [0:63] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE reg [0:47] a; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; wire [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:31] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; wire [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:19] ~GENSYM[c][12]; genvar ~GENSYM[i3][13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] localparam n = 4; wire [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:11] ~GENSYM[d][15]; genvar ~GENSYM[i4][16]; ~GENERATE for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] localparam n = 5; wire [9:0] i; assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:6] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 6; wire [11:0] i; assign i = ~SYM[15][0:11]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE assign ~RESULT = $unsigned(~SYM[7]); // ctz64 end - BlackBox: name: GHC.Prim.ctz# imports: - ~INCLUDENAME[0].inc includes: - name: enc extension: inc template: |- function [1:0] ~INCLUDENAME[0]; input [1:0] a; case (a) 2'b00: ~INCLUDENAME[0] = 2'b10; 2'b01: ~INCLUDENAME[0] = 2'b01; 2'b10: ~INCLUDENAME[0] = 2'b00; default: ~INCLUDENAME[0] = 2'b00; endcase endfunction kind: Declaration type: 'ctz :: Word# -> Word#' template: |- // ctz begin~IF ~IW64 ~THEN wire [0:63] ~GENSYM[v][1]; genvar ~GENSYM[k][18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19] assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; end ~ENDGENERATE wire [0:63] ~GENSYM[e][2]; genvar ~GENSYM[i][3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE reg [0:47] ~GENSYM[a][4]; genvar ~GENSYM[i1][5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6] localparam n = 2; wire [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:31] ~GENSYM[b][9]; genvar ~GENSYM[i2][10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11] localparam n = 3; wire [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:19] ~GENSYM[c][12]; genvar ~GENSYM[i3][13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14] localparam n = 4; wire [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:11] ~GENSYM[d][15]; genvar ~GENSYM[i4][16]; ~GENERATE for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17] localparam n = 5; wire [9:0] i; assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:6] ~GENSYM[res][7]; ~GENERATE if (1) begin localparam n = 6; wire [11:0] i; assign i = ~SYM[15][0:11]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE ~ELSE wire [0:31] ~SYM[1]; genvar ~SYM[18]; ~GENERATE for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~SYM[19] assign ~SYM[1][~SYM[18]] = ~ARG[0][~SYM[18]]; end ~ENDGENERATE wire [0:31] ~SYM[2]; genvar ~SYM[3]; ~GENERATE for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~SYM[8] assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]); end ~ENDGENERATE reg [0:23] ~SYM[4]; genvar ~SYM[5]; ~GENERATE for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~SYM[6] localparam n = 2; wire [3:0] i; assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:15] ~SYM[9]; genvar ~SYM[10]; ~GENERATE for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~SYM[11] localparam n = 3; wire [5:0] i; assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:9] ~SYM[12]; genvar ~SYM[13]; ~GENERATE for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~SYM[14] localparam n = 4; wire [7:0] i; assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE reg [0:5] ~SYM[7]; ~GENERATE if (1) begin localparam n = 5; wire [9:0] i; assign i = ~SYM[12][0:9]; always @(*) begin case (i[n-1+n]) 1'b0 : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]}; default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]}; endcase end end ~ENDGENERATE ~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 clash-lib-1.8.1/prims/vhdl/0000755000000000000000000000000007346545000013637 5ustar0000000000000000clash-lib-1.8.1/prims/vhdl/Clash_Class_Exp.primitives.yaml0000644000000000000000000000253507346545000021715 0ustar0000000000000000- BlackBox: name: Clash.Class.Exp.expIndex# kind: Expression type: 'expIndex# :: KnownNat m => Index m -> SNat n -> Index (m^n)' template: ~DEVNULL[~ARG[0]]to_unsigned(to_integer(~ARG[1]) ** ~LIT[2], ~SIZE[~TYPO]) warning: Exponentiation is only supported on relatively small constructs (< 32 bits). Ideally, Clash should have constant folded your expression. See https://github.com/clash-lang/clash-compiler/issues/593. - BlackBox: name: Clash.Class.Exp.expSigned# kind: Expression type: 'expSigned# :: KnownNat m => Signed m -> SNat n -> Signed (m*n)' template: ~DEVNULL[~ARG[0]]to_signed(to_integer(~ARG[1]) ** ~LIT[2], ~SIZE[~TYPO]) warning: Exponentiation is only supported on relatively small constructs (< 32 bits). Ideally, Clash should have constant folded your expression. See https://github.com/clash-lang/clash-compiler/issues/593. - BlackBox: name: Clash.Class.Exp.expUnsigned# kind: Expression type: 'expUnsigned# :: KnownNat m => Unsigned m -> SNat n -> Unsigned (m*n)' template: ~DEVNULL[~ARG[0]]to_unsigned(to_integer(~ARG[1]) ** ~LIT[2], ~SIZE[~TYPO]) warning: Exponentiation is only supported on relatively small constructs (< 32 bits). Ideally, Clash should have constant folded your expression. See https://github.com/clash-lang/clash-compiler/issues/593. clash-lib-1.8.1/prims/vhdl/Clash_Explicit_BlockRam.primitives.yaml0000644000000000000000000001506707346545000023373 0ustar0000000000000000- BlackBox: name: Clash.Explicit.BlockRam.blockRam# kind: Declaration outputUsage: NonBlocking type: |- blockRam# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> Vec n a -- init, ARG[5] -> Signal dom Int -- rd, ARG[6] -> Signal dom Bool -- wren, ARG[7] -> Signal dom Int -- wr, ARG[8] -> Signal dom a -- din, ARG[9] -> Signal dom a template: |- -- blockRam begin ~GENSYM[~RESULT_blockRam][1] : block signal ~GENSYM[~RESULT_RAM][2] : ~TYP[5] := ~CONST[5]; signal ~GENSYM[rd][4] : integer range 0 to ~LENGTH[~TYP[5]] - 1; signal ~GENSYM[wr][5] : integer range 0 to ~LENGTH[~TYP[5]] - 1; begin ~SYM[4] <= to_integer(~VAR[rdI][6](31 downto 0)) -- pragma translate_off mod ~LENGTH[~TYP[5]] -- pragma translate_on ; ~SYM[5] <= to_integer(~VAR[wrI][8](31 downto 0)) -- pragma translate_off mod ~LENGTH[~TYP[5]] -- pragma translate_on ; ~IF ~VIVADO ~THEN ~SYM[6] : process(~ARG[3]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then if ~ARG[7] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then ~SYM[2](~SYM[5]) <= ~TOBV[~ARG[9]][~TYP[9]]; end if; ~RESULT <= fromSLV(~SYM[2](~SYM[4])); end if; end process; ~ELSE ~SYM[6] : process(~ARG[3]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then if ~ARG[7] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then ~SYM[2](~SYM[5]) <= ~ARG[9]; end if; ~RESULT <= ~SYM[2](~SYM[4]); end if; end process; ~FI end block; --end blockRam - BlackBox: name: Clash.Explicit.BlockRam.blockRamU# kind: Declaration outputUsage: NonBlocking type: |- blockRamU# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> SNat n -- len, ARG[5] -> Signal dom Int -- rd, ARG[6] -> Signal dom Bool -- wren, ARG[7] -> Signal dom Int -- wr, ARG[8] -> Signal dom a -- din, ARG[9] -> Signal dom a template: |- -- blockRamU begin ~GENSYM[~RESULT_blockRam][1] : block~IF~VIVADO~THEN type ~GENSYM[ram_t][8] is array (0 to integer'(~LIT[5])-1) of std_logic_vector(~SIZE[~TYP[9]]-1 downto 0);~ELSE type ~SYM[8] is array (0 to integer'(~LIT[5])-1) of ~TYP[9];~FI signal ~GENSYM[~RESULT_RAM][2] : ~SYM[8]; signal ~GENSYM[rd][4] : integer range 0 to ~LIT[5] - 1; signal ~GENSYM[wr][5] : integer range 0 to ~LIT[5] - 1; begin ~SYM[4] <= to_integer(~VAR[rdI][6](31 downto 0)) -- pragma translate_off mod ~LIT[5] -- pragma translate_on ; ~SYM[5] <= to_integer(~VAR[wrI][8](31 downto 0)) -- pragma translate_off mod ~LIT[5] -- pragma translate_on ; ~IF ~VIVADO ~THEN ~SYM[6] : process(~ARG[3]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then if ~ARG[7] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then ~SYM[2](~SYM[5]) <= ~TOBV[~ARG[9]][~TYP[9]]; end if; ~RESULT <= fromSLV(~SYM[2](~SYM[4])); end if; end process; ~ELSE ~SYM[6] : process(~ARG[3]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then if ~ARG[7] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then ~SYM[2](~SYM[5]) <= ~ARG[9]; end if; ~RESULT <= ~SYM[2](~SYM[4]); end if; end process; ~FI end block; --end blockRamU - BlackBox: name: Clash.Explicit.BlockRam.blockRam1# kind: Declaration outputUsage: NonBlocking type: |- blockRam1# :: ( KnownDomain dom ARG[0] , HasCallStack -- ARG[1] , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> SNat n -- len, ARG[5] -> a -- init, ARG[6] -> Signal dom Int -- rd, ARG[7] -> Signal dom Bool -- wren, ARG[8] -> Signal dom Int -- wr, ARG[9] -> Signal dom a -- din, ARG[10] -> Signal dom a template: |- -- blockRam1 begin ~GENSYM[~RESULT_blockRam][1] : block~IF~VIVADO~THEN type ~GENSYM[ram_t][8] is array (0 to integer'(~LIT[5])-1) of std_logic_vector(~SIZE[~TYP[6]]-1 downto 0);~ELSE type ~SYM[8] is array (0 to integer'(~LIT[5])-1) of ~TYP[6];~FI signal ~GENSYM[~RESULT_RAM][2] : ~SYM[8] := (others => ~IF~VIVADO~THEN~TOBV[~CONST[6]][~TYP[6]]~ELSE~CONST[6]~FI); signal ~GENSYM[rd][4] : integer range 0 to ~LIT[5] - 1; signal ~GENSYM[wr][5] : integer range 0 to ~LIT[5] - 1; begin ~SYM[4] <= to_integer(~VAR[rdI][7](31 downto 0)) -- pragma translate_off mod ~LIT[5] -- pragma translate_on ; ~SYM[5] <= to_integer(~VAR[wrI][9](31 downto 0)) -- pragma translate_off mod ~LIT[5] -- pragma translate_on ; ~IF ~VIVADO ~THEN ~SYM[6] : process(~ARG[3]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then if ~ARG[8] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then ~SYM[2](~SYM[5]) <= ~TOBV[~ARG[10]][~TYP[10]]; end if; ~RESULT <= fromSLV(~SYM[2](~SYM[4])); end if; end process; ~ELSE ~SYM[6] : process(~ARG[3]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then if ~ARG[8] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then ~SYM[2](~SYM[5]) <= ~ARG[10]; end if; ~RESULT <= ~SYM[2](~SYM[4]); end if; end process; ~FI end block; --end blockRam1 clash-lib-1.8.1/prims/vhdl/Clash_Explicit_BlockRam_Blob.primitives.yaml0000644000000000000000000000323507346545000024323 0ustar0000000000000000- BlackBox: name: Clash.Explicit.BlockRam.Blob.blockRamBlob# kind: Declaration outputUsage: NonBlocking type: |- blockRamBlob# :: KnownDomain dom -- ARG[0] => Clock dom -- clk, ARG[1] -> Enable dom -- en, ARG[2] -> MemBlob n m -- init, ARG[3] -> Signal dom Int -- rd, ARG[4] -> Signal dom Bool -- wren, ARG[5] -> Signal dom Int -- wr, ARG[6] -> Signal dom (BitVector m) -- din, ARG[7] -> Signal dom (BitVector m) template: |- -- blockRamBlob begin ~GENSYM[~RESULT_blockRam][1] : block signal ~GENSYM[~RESULT_RAM][2] : ~TYP[3] := ~CONST[3]; signal ~GENSYM[rd][4] : integer range 0 to ~LENGTH[~TYP[3]] - 1; signal ~GENSYM[wr][5] : integer range 0 to ~LENGTH[~TYP[3]] - 1; begin ~SYM[4] <= to_integer(~VAR[rdI][4](31 downto 0)) -- pragma translate_off mod ~LENGTH[~TYP[3]] -- pragma translate_on ; ~SYM[5] <= to_integer(~VAR[wrI][6](31 downto 0)) -- pragma translate_off mod ~LENGTH[~TYP[3]] -- pragma translate_on ; ~SYM[6] : process(~ARG[1]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[1]) then if ~ARG[5]~IF~ISACTIVEENABLE[2]~THEN and ~ARG[2]~ELSE~FI then ~SYM[2](~SYM[5]) <= ~ARG[7]; end if; ~RESULT <= ~SYM[2](~SYM[4]); end if; end process; end block; -- blockRamBlob end clash-lib-1.8.1/prims/vhdl/Clash_Explicit_BlockRam_File.primitives.yaml0000644000000000000000000000704307346545000024325 0ustar0000000000000000- BlackBox: name: Clash.Explicit.BlockRam.File.blockRamFile# kind: Declaration outputUsage: NonBlocking type: |- blockRamFile# :: ( KnownDomain dom -- ARG[0] , KnownNat m -- ARG[1] , HasCallStack ) -- ARG[2] => Clock dom -- clk, ARG[3] => Enable dom -- en, ARG[4] -> SNat n -- sz, ARG[5] -> FilePath -- file, ARG[6] -> Signal dom Int -- rd, ARG[7] -> Signal dom Bool -- wren, ARG[8] -> Signal dom Int -- wr, ARG[9] -> Signal dom (BitVector m) -- din, ARG[10] -> Signal dom (BitVector m) template: |- -- blockRamFile begin ~GENSYM[~COMPNAME_blockRamFile][1] : block type ~GENSYM[RamType][7] is array(natural range <>) of bit_vector(~LIT[1]-1 downto 0); impure function ~GENSYM[InitRamFromFile][2] (RamFileName : in string) return ~SYM[7] is FILE RamFile : text open read_mode is RamFileName; variable RamFileLine : line; variable RAM : ~SYM[7](0 to ~LIT[5]-1); begin for i in RAM'range loop readline(RamFile,RamFileLine); read(RamFileLine,RAM(i)); end loop; return RAM; end function; signal ~GENSYM[RAM][3] : ~SYM[7](0 to ~LIT[5]-1) := ~SYM[2](~FILE[~LIT[6]]); signal ~GENSYM[rd][5] : integer range 0 to ~LIT[5]-1; signal ~GENSYM[wr][6] : integer range 0 to ~LIT[5]-1; begin ~SYM[5] <= to_integer(~VAR[rdI][7](31 downto 0)) -- pragma translate_off mod ~LIT[5] -- pragma translate_on ; ~SYM[6] <= to_integer(~VAR[wrI][9](31 downto 0)) -- pragma translate_off mod ~LIT[5] -- pragma translate_on ; ~IF ~VIVADO ~THEN ~IF ~ISACTIVEENABLE[4] ~THEN ~GENSYM[blockRamFile_sync][10] : process(~ARG[3]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then if ~ARG[4] then if ~ARG[8] then ~SYM[3](~SYM[6]) <= to_bitvector(~ARG[10]); end if; ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5])); end if; end if; end process;~ELSE ~SYM[10] : process(~ARG[3]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then if ~ARG[8] then ~SYM[3](~SYM[6]) <= to_bitvector(~ARG[10]); end if; ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5])); end if; end process;~FI ~ELSE ~IF ~ISACTIVEENABLE[4] ~THEN ~SYM[10] : process(~ARG[3]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then if ~ARG[8] and ~ARG[4] then ~SYM[3](~SYM[6]) <= to_bitvector(~ARG[10]); end if; if ~ARG[4] then ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5])); end if; end if; end process;~ELSE ~SYM[10] : process(~ARG[3]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then if ~ARG[8] then ~SYM[3](~SYM[6]) <= to_bitvector(~ARG[10]); end if; ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5])); end if; end process;~FI ~FI end block; -- blockRamFile end clash-lib-1.8.1/prims/vhdl/Clash_Explicit_DDR.primitives.yaml0000644000000000000000000001436607346545000022313 0ustar0000000000000000- BlackBox: name: Clash.Explicit.DDR.ddrIn# kind: Declaration type: |- ddrIn# :: forall a slow fast n pFast enabled synchronous. ( HasCallStack -- ARG[0] , NFDataX a -- ARG[1] , KnownConfi~ fast domf -- ARG[2] , KnownConfi~ slow doms -- ARG[3] => Clock slow -- ARG[4] -> Reset slow -- ARG[5] -> Enable slow -- ARG[6] -> a -- ARG[7] -> a -- ARG[8] -> a -- ARG[9] -> Signal fast a -- ARG[10] -> Signal slow (a,a) template: |- -- ddrIn begin ~GENSYM[~COMPNAME_ddrIn][0] : block signal ~GENSYM[data_Pos][1] : ~TYP[9]; signal ~GENSYM[data_Neg][2] : ~TYP[9]; signal ~GENSYM[data_Neg_Latch][3] : ~TYP[9]; begin ~IF ~ISSYNC[3] ~THEN -- sync ------------- ~GENSYM[~COMPNAME_ddrIn_pos][6] : process(~ARG[4]) begin if ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[4]) then if ~ARG[5] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then ~SYM[1] <= ~ARG[8]; els~IF ~ISACTIVEENABLE[6] ~THENif ~ARG[6] then~ELSEe~FI ~SYM[1] <= ~ARG[10]; end if; end if; end process; ~GENSYM[~COMPNAME_ddrIn_neg][7] : process(~ARG[4]) begin if ~IF~ACTIVEEDGE[Rising][2]~THENfalling_edge~ELSErising_edge~FI(~ARG[4]) then if ~ARG[5] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then ~SYM[2] <= ~ARG[9]; els~IF ~ISACTIVEENABLE[6] ~THENif ~ARG[6] then~ELSEe~FI ~SYM[2] <= ~ARG[10]; end if; end if; end process; ~GENSYM[~COMPNAME_ddrIn_neg_latch][8] : process(~ARG[4]) begin if ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[4]) then if ~ARG[5] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then ~SYM[3] <= ~ARG[7]; els~IF ~ISACTIVEENABLE[6] ~THENif ~ARG[6] then~ELSEe~FI ~SYM[3] <= ~SYM[2]; end if; end if; end process; ~ELSE -- async -------------- ~SYM[6] : process(~ARG[4],~ARG[5]~VARS[9]) begin if ~ARG[5] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then ~SYM[1] <= ~ARG[8]; elsif ~IF ~ISACTIVEENABLE[6] ~THEN ~ARG[6] and ~ELSE ~FI ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[4]) then ~SYM[1] <= ~ARG[10]; end if; end process; ~SYM[7] : process(~ARG[4],~ARG[5]~VARS[9]) begin if ~ARG[5] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then ~SYM[2] <= ~ARG[9]; elsif ~IF ~ISACTIVEENABLE[6] ~THEN ~ARG[6] and ~ELSE ~FI ~IF~ACTIVEEDGE[Rising][2]~THENfalling_edge~ELSErising_edge~FI(~ARG[4]) then ~SYM[2] <= ~ARG[10]; end if; end process; ~SYM[8] : process(~ARG[4],~ARG[5],~SYM[2]) begin if ~ARG[5] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then ~SYM[3] <= ~ARG[7]; elsif ~IF ~ISACTIVEENABLE[6] ~THEN ~ARG[6] and ~ELSE ~FI ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[4]) then ~SYM[3] <= ~SYM[2]; end if; end process; ~FI ~RESULT <= (~SYM[3], ~SYM[1]); end block; -- ddrIn end - BlackBox: name: Clash.Explicit.DDR.ddrOut# kind: Declaration type: |- ddrOut# :: ( HasCallStack -- ARG[0] , NFDataX a -- ARG[1] , KnownConfi~ fast domf -- ARG[2] , KnownConfi~ slow doms -- ARG[3] => Clock slow -- ARG[4] -> Reset slow -- ARG[5] -> Enable slow -- ARG[6] -> a -- ARG[7] -> Signal slow a -- ARG[8] -> Signal slow a -- ARG[9] -> Signal fast a template: |- -- ddrOut begin ~GENSYM[~COMPNAME_ddrIn][0] : block signal ~GENSYM[data_Pos][1] : ~TYP[7]; signal ~GENSYM[data_Neg][2] : ~TYP[7]; begin ~IF ~ISSYNC[3] ~THEN -- sync ------------- ~GENSYM[~COMPNAME_ddrOut_pos][5] : process(~ARG[4]) begin if ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[4]) then if ~ARG[5] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then ~SYM[1] <= ~ARG[7]; els~IF ~ISACTIVEENABLE[6] ~THENif ~ARG[6] then~ELSEe~FI ~SYM[1] <= ~ARG[8]; end if; end if; end process; ~GENSYM[~COMPNAME_ddrOut_neg][6] : process(~ARG[4]) begin if ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[4]) then if ~ARG[5] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then ~SYM[2] <= ~ARG[7]; els~IF ~ISACTIVEENABLE[6] ~THENif ~ARG[6] then~ELSEe~FI ~SYM[2] <= ~ARG[9]; end if; end if; end process; ~ELSE -- async -------------- ~SYM[5] : process(~ARG[4],~ARG[5]~VARS[8]) begin if ~ARG[5] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then ~SYM[1] <= ~ARG[7]; elsif ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[4]) then ~SYM[1] <= ~ARG[8]; end if; end process; ~SYM[6] : process(~ARG[4],~ARG[5]~VARS[9]) begin if ~ARG[5] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then ~SYM[2] <= ~ARG[7]; elsif ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[4]) then ~SYM[2] <= ~ARG[9]; end if; end process; ~FI ~RESULT <= ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[1]~ELSE~SYM[2]~FI when (~ARG[4] = '1' ~IF ~ISACTIVEENABLE[6] ~THEN and ~ARG[6] ~ELSE ~FI) else ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[2]~ELSE~SYM[1]~FI; end block; -- ddrOut end clash-lib-1.8.1/prims/vhdl/Clash_Explicit_RAM.primitives.yaml0000644000000000000000000000414207346545000022310 0ustar0000000000000000- BlackBox: name: Clash.Explicit.RAM.asyncRam# kind: Declaration type: |- asyncRam# :: ( HasCallStack -- ARG[0] , KnownDomain wdom -- ARG[1] , KnownDomain rdom -- ARG[2] , NFDataX a ) -- ARG[3] => Clock wdom -- ^ wclk, ARG[4] -> Clock rdom -- ^ rclk, ARG[5] -> Enable wdom -- ^ wen, ARG[6] -> SNat n -- ^ sz, ARG[7] -> Signal rdom Int -- ^ rd, ARG[8] -> Signal wdom Bool -- ^ en, ARG[9] -> Signal wdom Int -- ^ wr, ARG[10] -> Signal wdom a -- ^ din, ARG[11] -> Signal rdom a template: |- -- asyncRam begin ~GENSYM[~COMPNAME_asyncRam][0] : block~IF ~VIVADO ~THEN type ~GENSYM[RamType][4] is array(natural range <>) of std_logic_vector(~SIZE[~TYP[11]]-1 downto 0);~ELSE type ~SYM[4] is array(natural range <>) of ~TYP[11];~FI signal ~GENSYM[RAM][1] : ~SYM[4](0 to ~LIT[7]-1); signal ~GENSYM[rd][2] : integer range 0 to ~LIT[7] - 1; signal ~GENSYM[wr][3] : integer range 0 to ~LIT[7] - 1; begin ~SYM[2] <= to_integer(~VAR[rdI][8](31 downto 0)) -- pragma translate_off mod ~LIT[7] -- pragma translate_on ; ~SYM[3] <= to_integer(~VAR[wrI][10](31 downto 0)) -- pragma translate_off mod ~LIT[7] -- pragma translate_on ; ~GENSYM[asyncRam_sync][7] : process(~ARG[4]) begin if ~IF~ACTIVEEDGE[Rising][1]~THENrising_edge~ELSEfalling_edge~FI(~ARG[4]) then if (~ARG[9] ~IF ~ISACTIVEENABLE[6] ~THEN and ~ARG[6] ~ELSE ~FI) then~IF ~VIVADO ~THEN ~SYM[1](~SYM[3]) <= ~TOBV[~ARG[11]][~TYP[11]];~ELSE ~SYM[1](~SYM[3]) <= ~ARG[11];~FI end if; end if; end process; ~IF ~VIVADO ~THEN ~RESULT <= ~FROMBV[~SYM[1](~SYM[2])][~TYP[11]];~ELSE ~RESULT <= ~SYM[1](~SYM[2]);~FI end block; -- asyncRam end clash-lib-1.8.1/prims/vhdl/Clash_Explicit_ROM.primitives.yaml0000644000000000000000000000236307346545000022331 0ustar0000000000000000- BlackBox: name: Clash.Explicit.ROM.rom# kind: Declaration outputUsage: NonBlocking type: |- rom# :: ( KnownDomain dom ARG[0] , KnownNat n -- ARG[1] , NFDataX a ) -- ARG[2] => Clock dom -- clk, ARG[3] -> Enable dom -- en, ARG[4] -> Vec n a -- init, ARG[5] -> Signal dom Int -- rd, ARG[6] -> Signal dom a template: |- -- rom begin ~GENSYM[~COMPNAME_rom][1] : block signal ~GENSYM[ROM][2] : ~TYP[5]; signal ~GENSYM[rd][3] : integer range 0 to ~LIT[1]-1; begin ~SYM[2] <= ~CONST[5]; ~SYM[3] <= to_integer(~VAR[rdI][6](31 downto 0)) -- pragma translate_off mod ~LIT[1] -- pragma translate_on ; ~GENSYM[romSync][6] : process (~ARG[3]) begin if (~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3])~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI) then~IF ~VIVADO ~THEN ~RESULT <= ~FROMBV[~SYM[2](~SYM[3])][~TYPO];~ELSE ~RESULT <= ~SYM[2](~SYM[3]);~FI end if; end process; end block; -- rom end clash-lib-1.8.1/prims/vhdl/Clash_Explicit_ROM_Blob.primitives.yaml0000644000000000000000000000215307346545000023264 0ustar0000000000000000- BlackBox: name: Clash.Explicit.ROM.Blob.romBlob# kind: Declaration outputUsage: NonBlocking type: |- romBlob# :: KnownDomain dom -- ARG[0] => Clock dom -- clk, ARG[1] -> Enable dom -- en, ARG[2] -> MemBlob n m -- init, ARG[3] -> Signal dom Int -- rd, ARG[4] -> Signal dom (BitVector m) template: |- -- romBlob begin ~GENSYM[~COMPNAME_rom][1] : block signal ~GENSYM[ROM][2] : ~TYP[3]; signal ~GENSYM[rd][3] : integer range 0 to ~LENGTH[~TYP[3]]-1; begin ~SYM[2] <= ~CONST[3]; ~SYM[3] <= to_integer(~VAR[rdI][4](31 downto 0)) -- pragma translate_off mod ~LENGTH[~TYP[3]] -- pragma translate_on ; ~GENSYM[romSync][6] : process (~ARG[1]) begin if (~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[1])~IF~ISACTIVEENABLE[2]~THEN and ~ARG[2]~ELSE~FI) then ~RESULT <= ~SYM[2](~SYM[3]); end if; end process; end block; -- romBlob end clash-lib-1.8.1/prims/vhdl/Clash_Explicit_ROM_File.primitives.yaml0000644000000000000000000000415107346545000023265 0ustar0000000000000000- BlackBox: name: Clash.Explicit.ROM.File.romFile# kind: Declaration outputUsage: NonBlocking type: |- romFile# :: ( KnownNat m -- ARG[0] , KnownDomain dom -- ARG[1] => Clock dom -- clk, ARG[2] -> Enable dom -- en, ARG[3] -> SNat n -- sz, ARG[4] -> FilePath -- file, ARG[5] -> Signal dom Int -- rd, ARG[6] -> Signal dom (BitVector m) template: |- -- romFile begin ~GENSYM[~COMPNAME_romFile][0] : block type ~GENSYM[RomType][4] is array(natural range <>) of bit_vector(~LIT[0]-1 downto 0); impure function ~GENSYM[InitRomFromFile][1] (RomFileName : in string) return ~SYM[4] is FILE RomFile : text open read_mode is RomFileName; variable RomFileLine : line; variable ROM : ~SYM[4](0 to ~LIT[4]-1); begin for i in ROM'range loop readline(RomFile,RomFileLine); read(RomFileLine,ROM(i)); end loop; return ROM; end function; signal ~GENSYM[ROM][2] : ~SYM[4](0 to ~LIT[4]-1) := ~SYM[1](~FILE[~LIT[5]]); signal ~GENSYM[rd][3] : integer range 0 to ~LIT[4]-1; begin ~SYM[3] <=to_integer(~VAR[rdI][6](31 downto 0)) -- pragma translate_off mod ~LIT[4] -- pragma translate_on ; ~IF ~ISACTIVEENABLE[3] ~THEN ~GENSYM[romFileSync][7] : process (~ARG[2]) begin if (~IF~ACTIVEEDGE[Rising][1]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2])) then if ~ARG[3] then ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[3])); end if; end if; end process;~ELSE ~SYM[7] : process (~ARG[2]) begin if (~IF~ACTIVEEDGE[Rising][1]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2])) then ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[3])); end if; end process;~FI end block; -- romFile end clash-lib-1.8.1/prims/vhdl/Clash_Explicit_SimIO.primitives.yaml0000644000000000000000000000071507346545000022653 0ustar0000000000000000- Primitive: name: Clash.Explicit.SimIO.mealyIO primType: Function - Primitive: name: Clash.Explicit.SimIO.fmapSimIO# primType: Function - Primitive: name: Clash.Explicit.SimIO.pureSimIO# primType: Function - Primitive: name: Clash.Explicit.SimIO.apSimIO# primType: Function - Primitive: name: Clash.Explicit.SimIO.bindSimIO# primType: Function - Primitive: name: Clash.Explicit.SimIO.unSimIO# primType: Function clash-lib-1.8.1/prims/vhdl/Clash_Explicit_Testbench.primitives.yaml0000644000000000000000000001363607346545000023620 0ustar0000000000000000- BlackBox: name: Clash.Explicit.Testbench.assert imports: - ~INCLUDENAME[0].all includes: - name: slv2string extension: vhdl template: |- -- helper function of Clash.Explicit.Testbench.assert library IEEE; use IEEE.STD_LOGIC_1164.ALL; package ~INCLUDENAME[0] is function slv2string (slv : std_logic_vector) return STRING; end; package body ~INCLUDENAME[0] is function slv2string (slv : std_logic_vector) return STRING is variable result : string (1 to slv'length); variable res_l : string (1 to 3); variable r : integer; begin r := 1; for i in slv'range loop res_l := std_logic'image(slv(i)); result(r) := res_l(2); r := r + 1; end loop; return result; end slv2string; end; kind: Declaration type: |- assert :: (KnownDomain dom, Eq a, ShowX a) -- (ARG[0],ARG[1],ARG[2]) => Clock dom -- ARG[3] -> Reset dom -- ARG[4] -> String -- ARG[5] -> Signal dom a -- Checked value (ARG[6]) -> Signal dom a -- Expected value (ARG[7]) -> Signal dom b -- Return valued (ARG[8]) -> Signal dom b template: |- -- assert begin ~GENSYM[assert][0] : block -- pragma translate_off signal ~GENSYM[actual][2] : ~TYP[6]; signal ~GENSYM[expected][3] : ~TYP[7]; -- pragma translate_on begin -- pragma translate_off ~SYM[2] <= ~ARG[6]; ~SYM[3] <= ~ARG[7]; process(~ARG[3]) is begin if (~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3])) then assert (toSLV(~SYM[2]) = toSLV(~SYM[3])) report (~LIT[5] & ", expected: " & ~INCLUDENAME[0].slv2string(toSLV(~SYM[3])) & ", actual: " & ~INCLUDENAME[0].slv2string(toSLV(~SYM[2]))) severity error; end if; end process; -- pragma translate_on ~RESULT <= ~ARG[8]; end block; -- assert end - BlackBox: name: Clash.Explicit.Testbench.assertBitVector imports: - ~INCLUDENAME[0].all includes: - name: assertBitVector extension: vhdl template: | -- helper functions of Clash.Explicit.Testbench.assertBitVector library IEEE; use IEEE.STD_LOGIC_1164.ALL; package ~INCLUDENAME[0] is function non_std_match (l, r : std_logic_vector) return boolean; function slv2string (slv : std_logic_vector) return STRING; end; package body ~INCLUDENAME[0] is type match_table_type is array (std_ulogic, std_ulogic) of boolean; constant match_table: match_table_type := ('0' | 'L' => ('0' | 'L' | '-' => true, others => false), '1' | 'H' => ('1' | 'H' | '-' => true, others => false), '-' => ('-' => true, others => false), others => ('-' => true, others => false) ); -- non_std_match is like std_match -- But only accepts '-' as don't care in its the second argument r. function non_std_match (l, r : std_logic_vector) return boolean is alias la : std_logic_vector (l'length downto 1) is l; alias ra : std_logic_vector (r'length downto 1) is r; begin for i in l'range loop if not match_table (l (i), r (i)) then return false; end if; end loop; return true; end non_std_match; function slv2string (slv : std_logic_vector) return STRING is variable result : string (1 to slv'length); variable res_l : string (1 to 3); variable r : integer; begin r := 1; for i in slv'range loop res_l := std_logic'image(slv(i)); result(r) := res_l(2); r := r + 1; end loop; return result; end slv2string; end; kind: Declaration type: |- assertBitVector :: ( KnownDomain dom -- ARG[0] , KnownNat n ) -- ARG[1] => Clock dom -- ARG[2] -> Reset dom -- ARG[3] -> String -- ARG[4] -> Signal dom (BitVector n) -- Checked value (ARG[5]) -> Signal dom (BitVector n) -- Expected value (ARG[6]) -> Signal dom b -- Return valued (ARG[7]) -> Signal dom b template: |- -- assertBitVector begin ~GENSYM[assert][0] : block -- pragma translate_off signal ~GENSYM[actual][2] : ~TYP[5]; signal ~GENSYM[expected][3] : ~TYP[6]; -- pragma translate_on begin -- pragma translate_off ~SYM[2] <= ~ARG[5]; ~SYM[3] <= ~ARG[6]; process(~ARG[2]) is begin if (~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2])) then assert (~INCLUDENAME[0].non_std_match(toSLV(~SYM[2]),toSLV(~SYM[3]))) report (~LIT[4] & ", expected: " & ~INCLUDENAME[0].slv2string(toSLV(~SYM[3])) & ", actual: " & ~INCLUDENAME[0].slv2string(toSLV(~SYM[2]))) severity error; end if; end process; -- pragma translate_on ~RESULT <= ~ARG[7]; end block; -- assertBitVector end - 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]) clash-lib-1.8.1/prims/vhdl/Clash_Intel_DDR.primitives.yaml0000644000000000000000000000667407346545000021610 0ustar0000000000000000- BlackBox: name: Clash.Intel.DDR.altddioIn imports: - altera_mf.altera_mf_components.all kind: Declaration libraries: - altera_mf type: |- altddioIn :: ( HasCallStack -- ARG[0] , KnownConfi~ fast domf -- ARG[1] , KnownConfi~ slow doms -- ARG[2] , KnownNat m ) -- ARG[3] => SSymbol deviceFamily -- ARG[4] -> Clock slow -- ARG[5] -> Reset slow -- ARG[6] -> Enable slow -- ARG[7] -> Signal fast (BitVector m) -- ARG[8] -> Signal slow (BitVector m,BitVector m) template: |- -- altddioIn begin ~GENSYM[~COMPNAME_ALTDDIO_IN][0] : block signal ~GENSYM[dataout_l][1] : ~TYP[8]; signal ~GENSYM[dataout_h][2] : ~TYP[8];~IF ~ISACTIVEENABLE[7] ~THEN signal ~GENSYM[ce_logic][4]: std_logic;~ELSE ~FI begin~IF ~ISACTIVEENABLE[5] ~THEN ~SYM[4] <= '1' when (~ARG[7]) else '0';~ELSE ~FI ~GENSYM[~COMPNAME_ALTDDIO_IN][7] : ALTDDIO_IN GENERIC MAP ( intended_device_family => ~LIT[4], invert_input_clocks => "OFF", lpm_hint => "UNUSED", lpm_type => "altddio_in", power_up_high => "OFF", width => ~SIZE[~TYP[8]] ) PORT MAP (~IF ~ISSYNC[6] ~THEN sclr => ~ARG[6],~ELSE aclr => ~ARG[6],~FI datain => ~ARG[8],~IF ~ISACTIVEENABLE[5] ~THEN inclocken => ~SYM[4],~ELSE ~FI inclock => ~ARG[5], dataout_h => ~SYM[2], dataout_l => ~SYM[1] ); ~RESULT <= (~SYM[1],~SYM[2]); end block; -- altddioIn end - BlackBox: name: Clash.Intel.DDR.altddioOut# imports: - altera_mf.altera_mf_components.all kind: Declaration libraries: - altera_mf type: |- altddioOut# :: ( HasCallStack -- ARG[0] , KnownConfi~ fast domf -- ARG[1] , KnownConfi~ slow doms -- ARG[2] , KnownNat m ) -- ARG[3] => SSymbol deviceFamily -- ARG[4] -> Clock slow -- ARG[5] -> Reset slow -- ARG[6] -> Enable slow -- ARG[7] -> Signal slow (BitVector m) -- ARG[8] -> Signal slow (BitVector m) -- ARG[9] -> Signal fast (BitVector m) template: |- -- altddioOut begin ~GENSYM[~COMPNAME_ALTDDIO_OUT][0] : block ~IF ~ISACTIVEENABLE[7] ~THEN signal ~GENSYM[ce_logic][1] : std_logic; ~ELSE ~FI begin~IF ~ISACTIVEENABLE[7] ~THEN ~SYM[3] <= '1' when (~ARG[7]) else '0'; ~ELSE ~FI ~GENSYM[~COMPNAME_ALTDDIO_OUT][7] : ALTDDIO_OUT GENERIC MAP ( extend_oe_disable => "OFF", intended_device_family => ~LIT[4], invert_output => "OFF", lpm_hint => "UNUSED", lpm_type => "altddio_out", oe_reg => "UNREGISTERED", power_up_high => "OFF", width => ~SIZE[~TYPO] ) PORT MAP (~IF ~ISSYNC[2] ~THEN sclr => ~ARG[6],~ELSE aclr => ~ARG[6],~FI ~IF ~ISACTIVEENABLE[7] ~THEN outclocken => ~SYM[1],~ELSE ~FI outclock => ~ARG[5], datain_h => ~ARG[7], datain_l => ~ARG[8], dataout => ~RESULT ); end block; -- altddioOut end clash-lib-1.8.1/prims/vhdl/Clash_Magic.primitives.yaml0000644000000000000000000000037107346545000021050 0ustar0000000000000000- BlackBox: name: Clash.Magic.nameHint kind: Declaration type: |- nameHint :: SSymbol sym -- ARG[0] -> a -- ARG[1] -> a resultName: template: ~NAME[0] template: ~RESULT <= ~ARG[1]; clash-lib-1.8.1/prims/vhdl/Clash_Prelude_ROM.primitives.yaml0000644000000000000000000000146507346545000022152 0ustar0000000000000000- BlackBox: name: Clash.Prelude.ROM.asyncRom# kind: Declaration type: |- 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[2]; signal ~GENSYM[rd][2] : integer range 0 to ~LIT[0]-1; begin ~SYM[1] <= ~CONST[2]; ~SYM[2] <= to_integer(~VAR[rdI][3](31 downto 0)) -- pragma translate_off mod ~LIT[0] -- pragma translate_on ;~IF ~VIVADO ~THEN ~RESULT <= ~FROMBV[~SYM[1](~SYM[2])][~TYPO];~ELSE ~RESULT <= ~SYM[1](~SYM[2]);~FI end block; -- asyncRom end clash-lib-1.8.1/prims/vhdl/Clash_Prelude_ROM_Blob.primitives.yaml0000644000000000000000000000132007346545000023076 0ustar0000000000000000- BlackBox: name: Clash.Prelude.ROM.Blob.asyncRomBlob# kind: Declaration type: |- asyncRomBlob# :: MemBlob n m -- ARG[0] -> Int -- ARG[1] -> BitVector m template: |- -- asyncRomBlob begin ~GENSYM[asyncRom][0] : block signal ~GENSYM[ROM][1] : ~TYP[0]; signal ~GENSYM[rd][2] : integer range 0 to ~LENGTH[~TYP[0]]-1; begin ~SYM[1] <= ~CONST[0]; ~SYM[2] <= to_integer(~VAR[rdI][1](31 downto 0)) -- pragma translate_off mod ~LENGTH[~TYP[0]] -- pragma translate_on ; ~RESULT <= ~SYM[1](~SYM[2]); end block; -- asyncRomBlob end clash-lib-1.8.1/prims/vhdl/Clash_Prelude_ROM_File.primitives.yaml0000644000000000000000000000255007346545000023105 0ustar0000000000000000- BlackBox: name: Clash.Prelude.ROM.File.asyncRomFile# kind: Declaration type: |- asyncRomFile# :: KnownNat m -- ARG[0] => SNat n -- sz, ARG[1] -> FilePath -- file, ARG[2] -> Int -- rd, ARG[3] -> BitVector m template: |- -- asyncRomFile begin ~GENSYM[asyncROMFile][0] : block type ~GENSYM[RomType][4] is array(natural range <>) of bit_vector(~LIT[0]-1 downto 0); impure function ~GENSYM[InitRomFromFile][1] (RomFileName : in string) return ~SYM[4] is FILE RomFile : text open read_mode is RomFileName; variable RomFileLine : line; variable ROM : ~SYM[4](0 to ~LIT[1]-1); begin for i in ROM'range loop readline(RomFile,RomFileLine); read(RomFileLine,ROM(i)); end loop; return ROM; end function; signal ~GENSYM[ROM][2] : ~SYM[4](0 to ~LIT[1]-1) := ~SYM[1](~FILE[~LIT[2]]); signal ~GENSYM[rd][3] : integer range 0 to ~LIT[1]-1; begin ~SYM[3] <= to_integer(~VAR[rdI][3](31 downto 0)) -- pragma translate_off mod ~LIT[1] -- pragma translate_on ; ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[3])); end block; -- asyncRomFile end clash-lib-1.8.1/prims/vhdl/Clash_Promoted_Nat.primitives.yaml0000644000000000000000000000263507346545000022430 0ustar0000000000000000- BlackBox: name: Clash.Promoted.Nat.flogBaseSNat kind: Expression type: |- Clash.Promoted.Nat.flogBaseSNat :: (2 <= base, 1 <= x) => SNat base -- ARG[2] -> SNat x -- ARG[3] -> SNat (FLog base x) template: integer(floor(log(real(~LIT[3]),real(~LIT[2])))) workInfo: Never - BlackBox: name: Clash.Promoted.Nat.clogBaseSNat kind: Expression type: |- Clash.Promoted.Nat.clogBaseSNat :: (2 <= base, 1 <= x) => SNat base -- ARG[2] -> SNat x -- ARG[3] -> SNat (CLog base x) template: integer(ceiling(log(real(~LIT[3]),real(~LIT[2])))) workInfo: Never - BlackBox: name: Clash.Promoted.Nat.logBaseSNat kind: Expression type: |- Clash.Promoted.Nat.logBaseSNat :: (FLog base x ~ CLog base x) => SNat base -- ARG[1] -> SNat x -- ARG[2] -> SNat (Log base x) template: integer(ceiling(log(real(~LIT[2]),real(~LIT[1])))) workInfo: Never clash-lib-1.8.1/prims/vhdl/Clash_Signal_BiSignal.primitives.yaml0000644000000000000000000000173707346545000023024 0ustar0000000000000000- BlackBox: name: Clash.Signal.BiSignal.writeToBiSignal# kind: Declaration type: |- writeToBiSignal# :: HasCallStack -- ARG[0] => BiSignalIn ds d n -- ARG[1] -> Signal d (Maybe (BitVector n)) -- ARG[2] -> Signal d Bool -- ARG[3] -> Signal d (BitVector n) -- ARG[4] -> BiSignalOut ds d n renderVoid: RenderVoid template: |- -- writeToBiSignal# begin ~ARG[1] <= ~ARG[4] when ~ARG[3] else (~SIZE[~TYP[1]]-1 downto 0 => 'Z'); -- writeToBiSignal# end - BlackBox: name: Clash.Signal.BiSignal.readFromBiSignal# kind: Declaration type: |- readFromBiSignal# :: ( HasCallStack -- ARG[0] , KnownNat n) -- ARG[1] => BiSignalIn ds d n -- ARG[2] -> Signal d (BitVector n) template: |- -- readFromBiSignal begin ~RESULT <= ~ARG[2]; -- readFromBiSignal end workInfo: Never clash-lib-1.8.1/prims/vhdl/Clash_Signal_Internal.primitives.yaml0000644000000000000000000002047007346545000023103 0ustar0000000000000000- BlackBox: name: Clash.Signal.Internal.delay# kind: Declaration outputUsage: NonBlocking type: |- delay# :: ( KnownDomain dom -- ARG[0] , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Enable dom -- ARG[3] -> a -- ARG[4] -> Signal clk a -- ARG[5] -> Signal clk a resultInit: template: ~IF~ISINITDEFINED[0]~THEN~CONST[4]~ELSE~FI resultName: template: ~CTXNAME template: |- -- delay begin~IF ~ISACTIVEENABLE[3] ~THEN ~GENSYM[~RESULT_delay][4] : process(~ARG[2]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then if ~ARG[3] then ~RESULT <= ~ARG[5]; end if; end if; end process;~ELSE ~SYM[4] : process(~ARG[2]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then ~RESULT <= ~ARG[5]; end if; end process;~FI -- delay end - BlackBox: name: Clash.Signal.Internal.asyncRegister# kind: Declaration outputUsage: NonBlocking type: |- asyncRegister# :: ( KnownDomain dom -- ARG[0] , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Reset dom -- ARG[3] -> Enable dom -- ARG[4] -> a -- ARG[5] (powerup value) -> a -- ARG[6] (reset value) -> Signal clk a -- ARG[7] -> Signal clk a resultInit: template: ~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI resultName: template: ~CTXNAME template: |- -- async register begin ~SYM[2] : process(~ARG[2]~IF ~ISUNDEFINED[6] ~THEN ~ELSE,~ARG[3]~FI) begin ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then ~RESULT <= ~CONST[6]; els~FIif ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then ~IF ~ISACTIVEENABLE[4] ~THEN if ~ARG[4] then ~RESULT <= ~ARG[7]; end if; ~ELSE ~RESULT <= ~ARG[7]; ~FI end if; end process; -- async register end - BlackBox: name: Clash.Signal.Internal.register# kind: Declaration outputUsage: NonBlocking type: |- register# :: ( KnownDomain dom -- ARG[0] , NFDataX a ) -- ARG[1] => Clock dom -- ARG[2] -> Reset dom -- ARG[3] -> Enable dom -- ARG[4] -> a -- ARG[5] (powerup value) -> a -- ARG[6] (reset value) -> Signal clk a -- ARG[7] -> Signal clk a resultInit: template: ~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI resultName: template: ~CTXNAME template: |- -- register begin~IF ~ISACTIVEENABLE[4] ~THEN ~IF ~ISSYNC[0] ~THEN ~GENSYM[~RESULT_register][2] : process(~ARG[2]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then ~RESULT <= ~CONST[6]; els~FIif ~ARG[4] then ~RESULT <= ~ARG[7]; end if; end if; end process;~ELSE ~SYM[2] : process(~ARG[2]~IF ~ISUNDEFINED[6] ~THEN ~ELSE,~ARG[3]~FI) begin ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then ~RESULT <= ~CONST[6]; els~FIif ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then if ~ARG[4] then ~RESULT <= ~ARG[7]; end if; end if; end process;~FI~ELSE ~IF ~ISSYNC[0] ~THEN ~SYM[2] : process(~ARG[2]) begin if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then ~RESULT <= ~CONST[6]; else ~FI~RESULT <= ~ARG[7]; ~IF ~ISUNDEFINED[6] ~THEN ~ELSEend if;~FI end if; end process;~ELSE ~SYM[2] : process(~ARG[2]~IF ~ISUNDEFINED[6] ~THEN ~ELSE,~ARG[3]~FI) begin ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then ~RESULT <= ~CONST[6]; els~FIif ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then ~RESULT <= ~ARG[7]; end if; end process;~FI~FI -- register end - BlackBox: 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: |- 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; ~IF~ISACTIVEENABLE[1]~THENwhile ~ARG[1] ~ELSE~FIloop ~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.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 dom, 1 <= n) => SNat n -> Reset dom' template: |- -- resetGen begin ~GENSYM[resetGen][0] : block constant ~GENSYM[reset_delay][1] : time := ~LONGESTPERIOD ps - 1 ps + (integer'(~LIT[2]) * ~PERIOD[0] ps); begin -- pragma translate_off ~RESULT <= ~IF ~ISACTIVEHIGH[0] ~THEN'1'~ELSE'0'~FI, ~IF ~ISACTIVEHIGH[0] ~THEN'0'~ELSE'1'~FI after ~SYM[1]; -- pragma translate_on end block; -- resetGen end workInfo: Always - BlackBox: name: Clash.Signal.Internal.unsafeFromReset kind: Declaration type: 'unsafeFromReset :: Reset dom -> Signal dom Bool' template: ~RESULT <= true when ~ARG[0] = '1' else false; workInfo: Never - BlackBox: name: Clash.Signal.Internal.unsafeToReset kind: Declaration type: 'unsafeToReset :: KnownDomain dom => Signal dom Bool -> Reset dom' template: ~RESULT <= '1' when ~ARG[1] = true else '0'; workInfo: Never clash-lib-1.8.1/prims/vhdl/Clash_Sized_Internal_BitVector.primitives.yaml0000644000000000000000000005001307346545000024721 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.BitVector.BV comment: THIS IS ONLY USED WHEN WW EXPOSES BITVECTOR INTERNALS kind: Expression type: 'BV :: Integer -> Integer -> BitVector n' template: std_logic_vector(resize(unsigned(std_logic_vector(~ARG[1])),~SIZE[~TYPO])) workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.Bit comment: THIS IS ONLY USED WHEN WW EXPOSES BIT INTERNALS kind: Expression type: 'Bit :: Integer -> Integer -> BitVector n' template: ~VAR[i][1][0] workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.size# kind: Expression type: 'size# :: KnownNat n => BitVector n -> Int' template: to_signed(~SIZE[~TYP[1]],~SIZE[~TYPO]) workInfo: Constant - BlackBox: name: Clash.Sized.Internal.BitVector.maxIndex# kind: Expression type: 'maxIndex# :: KnownNat n => BitVector n -> Int' template: to_signed(~SIZE[~TYP[1]] - 1,~SIZE[~TYPO]) workInfo: Constant - BlackBox: name: Clash.Sized.Internal.BitVector.high kind: Expression type: 'high :: Bit' template: '''1''' workInfo: Constant - BlackBox: name: Clash.Sized.Internal.BitVector.low kind: Expression type: 'low :: Bit' template: '''0''' workInfo: Constant - BlackBox: name: Clash.Sized.Internal.BitVector.pack# kind: Expression type: 'pack# :: Bit -> BitVector 1' template: std_logic_vector'(0 => ~ARG[0]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.unpack# kind: Expression type: 'unpack# :: BitVector 1 -> Bit' template: ~VAR[bv][0](0) workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.eq## kind: Expression type: 'eq## :: Bit -> Bit -> Bool' template: ~ARG[0] = ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.neq## kind: Expression type: 'neq## :: Bit -> Bit -> Bool' template: ~ARG[0] /= ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.fromInteger## kind: Expression type: 'fromInteger## :: Integer -> Integer -> Bit' template: ~IF~LIT[0]~THEN'U'~ELSE~ARG[1](0)~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.toEnum## kind: Expression type: 'toEnum## :: Int -> Bit' template: ~VAR[i][0](0) workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.and## kind: Expression type: 'and## :: Bit -> Bit -> Bit' template: ~ARG[0] and ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.or## kind: Expression type: 'or## :: Bit -> Bit -> Bit' template: ~ARG[0] or ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.xor## kind: Expression type: 'xor## :: Bit -> Bit -> Bit' template: ~ARG[0] xor ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.complement## kind: Expression type: 'complement## :: Bit -> Bit' template: not ~ARG[0] - BlackBox: name: Clash.Sized.Internal.BitVector.++# kind: Expression type: '(++#) :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)' template: ~IF~AND[~SIZE[~TYP[1]],~SIZE[~TYP[2]]]~THENstd_logic_vector'(std_logic_vector'(~ARG[1]) & std_logic_vector'(~ARG[2]))~ELSE~IF~SIZE[~TYP[1]]~THENstd_logic_vector'(~ARG[1])~ELSEstd_logic_vector'(~ARG[2])~FI~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.reduceAnd# kind: Declaration type: 'reduceAnd# :: KnownNat n => BitVector n -> Bit' template: |- -- reduceAnd begin, ~IF~SIZE[~TYP[1]]~THEN ~GENSYM[reduceAnd][0] : block function and_reduce (arg : std_logic_vector) return std_logic is variable upper, lower : std_logic; variable half : integer; variable argi : std_logic_vector (arg'length - 1 downto 0); variable result : std_logic; begin if (arg'length < 1) then result := '1'; else argi := arg; if (argi'length = 1) then result := argi(argi'left); else half := (argi'length + 1) / 2; -- lsb-biased tree upper := and_reduce (argi (argi'left downto half)); lower := and_reduce (argi (half - 1 downto argi'right)); result := upper and lower; end if; end if; return result; end; begin ~RESULT <= and_reduce(~ARG[1]); end block;~ELSE ~RESULT <= '1';~FI -- reduceAnd end - BlackBox: name: Clash.Sized.Internal.BitVector.reduceOr# kind: Declaration type: 'reduceOr# :: KnownNat n => BitVector n -> Bit' template: |- -- reduceOr begin ~IF~SIZE[~TYP[1]]~THEN ~GENSYM[reduceOr][0] : block function or_reduce (arg : std_logic_vector) return std_logic is variable upper, lower : std_logic; variable half : integer; variable argi : std_logic_vector (arg'length - 1 downto 0); variable result : std_logic; begin if (arg'length < 1) then result := '0'; else argi := arg; if (argi'length = 1) then result := argi(argi'left); else half := (argi'length + 1) / 2; -- lsb-biased tree upper := or_reduce (argi (argi'left downto half)); lower := or_reduce (argi (half - 1 downto argi'right)); result := upper or lower; end if; end if; return result; end; begin ~RESULT <= or_reduce(~ARG[1]); end block;~ELSE ~RESULT <= '0'; ~FI -- reduceOr end - BlackBox: name: Clash.Sized.Internal.BitVector.reduceXor# kind: Declaration type: 'reduceXor# :: KnownNat n => BitVector n -> Bit' template: |- -- reduceXor begin ~IF~SIZE[~TYP[1]]~THEN ~GENSYM[reduceXor][0] : block function xor_reduce (arg : std_logic_vector) return std_logic is variable upper, lower : std_logic; variable half : integer; variable argi : std_logic_vector (arg'length - 1 downto 0); variable result : std_logic; begin if (arg'length < 1) then result := '0'; else argi := arg; if (argi'length = 1) then result := argi(argi'left); else half := (argi'length + 1) / 2; -- lsb-biased tree upper := xor_reduce (argi (argi'left downto half)); lower := xor_reduce (argi (half - 1 downto argi'right)); result := upper xor lower; end if; end if; return result; end; begin ~RESULT <= xor_reduce(~ARG[1]); end block;~ELSE ~RESULT <= '0';~FI -- reduceXor end - BlackBox: name: Clash.Sized.Internal.BitVector.index# kind: Declaration type: |- index# :: KnownNat n -- ARG[0] => BitVector n -- ARG[1] -> Int -- ARG[2] -> Bit template: |- -- indexBitVector begin ~IF~SIZE[~TYP[1]]~THEN~IF ~ISVAR[1] ~THEN ~GENSYM[indexBitVector][0] : block signal ~GENSYM[vec_index][1] : integer range 0 to ~SIZE[~TYP[1]]-1; begin ~SYM[1] <= to_integer(~ARG[2]) -- pragma translate_off mod ~SIZE[~TYP[1]] -- pragma translate_on ; ~RESULT <= ~ARG[1](~SYM[1]); end block;~ELSE ~SYM[0] : block signal ~SYM[1] : integer range 0 to ~SIZE[~TYP[1]]-1; begin ~SYM[1] <= to_integer(~ARG[2]) -- pragma translate_off mod ~SIZE[~TYP[1]] -- pragma translate_on ; ~RESULT <= ~VAR[bv][1](~SYM[1]); end block;~FI~ELSE ~RESULT <= ~ERRORO;~FI -- indexBitVector end - BlackBox: name: Clash.Sized.Internal.BitVector.replaceBit# kind: Declaration outputUsage: NonBlocking type: |- replaceBit# :: KnownNat n -- ARG[0] => BitVector n -- ARG[1] -> Int -- ARG[2] -> Bit -- ARG[3] -> BitVector n template: |- -- replaceBit begin ~IF~SIZE[~TYP[1]]~THEN ~GENSYM[replaceBit][0] : block signal ~GENSYM[vec_index][1] : integer range 0 to ~SIZE[~TYP[1]]-1; begin ~SYM[1] <= to_integer(~ARG[2]) -- pragma translate_off mod ~SIZE[~TYP[1]] -- pragma translate_on ; process(~SYM[1],~VAR[b][3]~VARS[1]) variable ~GENSYM[ivec][2] : ~TYP[1]; begin ~SYM[2] := ~ARG[1]; ~SYM[2](~SYM[1]) := ~ARG[3]; ~RESULT <= ~SYM[2]; end process; end block; ~ELSE ~RESULT <= ~ERRORO;~FI -- replaceBit end - BlackBox: name: Clash.Sized.Internal.BitVector.setSlice# kind: Declaration outputUsage: NonBlocking type: |- setSlice# :: SNat (m + 1 + i) => BitVector (m + 1 + i) -- ARG[1] -> SNat m -- ARG[2] -> SNat n -- ARG[3] -> BitVector (m + 1 - n) -- ARG[4] -> BitVector (m + 1 + i) template: |- -- setSlice begin ~GENSYM[setSlice][0] : process(~VAR[bv][1]~VARS[4]) variable ~GENSYM[ivec][1] : ~TYP[1]; begin ~SYM[1] := ~VAR[bv][1]; ~SYM[1](~LIT[2] downto ~LIT[3]) := ~ARG[4]; ~RESULT <= ~SYM[1]; end process; -- setSlice end workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.slice# kind: Expression type: |- slice# :: BitVector (m + 1 + i) -- ARG[0] -> SNat m -- ARG[1] -> SNat n -- ARG[2] -> BitVector (m + 1 - n) template: ~VAR[bv][0](~LIT[1] downto ~LIT[2]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.split# kind: Expression type: |- split# :: KnownNat n -- ARG[0] => BitVector (m + n) -- ARG[1] -> (BitVector m, BitVector n) template: (~VAR[bv][1](~VAR[bv][1]'high downto ~LIT[0]),~VAR[bv][1](~LIT[0]-1 downto 0)) workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.msb# kind: Expression type: |- msb# :: KnownNat n -- ARG[0] => BitVector n -- ARG[1] -> Bit template: ~IF ~SIZE[~TYP[1]] ~THEN ~VAR[bv][1](~VAR[bv][1]'high) ~ELSE "0" ~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.lsb# kind: Expression type: |- lsb# :: BitVector n -- ARG[0] -> Bit template: ~IF ~SIZE[~TYP[0]] ~THEN ~VAR[bv][0](0) ~ELSE "0" ~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.eq# kind: Expression type: 'eq# :: KnownNat n => BitVector n -> BitVector n -> Bool' template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] = ~ARG[2]~ELSEtrue~FI - BlackBox: name: Clash.Sized.Internal.BitVector.neq# kind: Expression type: 'neq# :: KnownNat n => BitVector n -> BitVector n -> Bool' template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] /= ~ARG[2]~ELSEfalse~FI - BlackBox: name: Clash.Sized.Internal.BitVector.lt# kind: Expression type: 'lt# :: KnownNat n => BitVector n -> BitVector n -> Bool' template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] < ~ARG[2]~ELSEfalse~FI - BlackBox: name: Clash.Sized.Internal.BitVector.ge# kind: Expression type: 'ge# :: KnownNat n => BitVector n -> BitVector n -> Bool' template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] >= ~ARG[2]~ELSEtrue~FI - BlackBox: name: Clash.Sized.Internal.BitVector.gt# kind: Expression type: 'gt# :: KnownNat n => BitVector n -> BitVector n -> Bool' template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] > ~ARG[2]~ELSEfalse~FI - BlackBox: name: Clash.Sized.Internal.BitVector.le# kind: Expression type: 'le# :: KnownNat n => BitVector n -> BitVector n -> Bool' template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] <= ~ARG[2]~ELSEtrue~FI - BlackBox: name: Clash.Sized.Internal.BitVector.minBound# kind: Expression type: 'minBound# :: BitVector n' template: ~IF~SIZE[~TYPO]~THENstd_logic_vector'(~SIZE[~TYPO]-1 downto 0 => '0')~ELSEstd_logic_vector'(0 downto 1 => '0')~FI workInfo: Constant - BlackBox: name: Clash.Sized.Internal.BitVector.maxBound# kind: Expression type: 'maxBound# :: KnownNat n => BitVector n' template: ~IF~SIZE[~TYPO]~THENstd_logic_vector'(~SIZE[~TYPO]-1 downto 0 => '1')~ELSEstd_logic_vector'(0 downto 1 => '1')~FI workInfo: Constant - BlackBox: name: Clash.Sized.Internal.BitVector.+# kind: Expression type: '(+#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: std_logic_vector(unsigned(~ARG[1]) + unsigned(~ARG[2])) - BlackBox: name: Clash.Sized.Internal.BitVector.-# kind: Expression type: '(-#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: std_logic_vector(unsigned(~ARG[1]) - unsigned(~ARG[2])) - BlackBox: name: Clash.Sized.Internal.BitVector.*# kind: Expression type: '(*#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: std_logic_vector(resize(unsigned(~ARG[1]) * unsigned(~ARG[2]), ~SIZE[~TYP[1]])) - BlackBox: name: Clash.Sized.Internal.BitVector.negate# kind: Expression type: 'negate# :: KnownNat n => BitVector n -> BitVector n' template: std_logic_vector(-(signed(~ARG[1]))) - BlackBox: name: Clash.Sized.Internal.BitVector.fromInteger# kind: Expression type: 'fromInteger# :: KnownNat n => Integer -> Integer -> BitVector n' template: std_logic_vector(resize(unsigned(std_logic_vector(~ARG[2])),~SIZE[~TYPO])) workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.toEnum# kind: Expression type: 'toEnum# :: KnownNat n => Int -> BitVector n' template: std_logic_vector(resize(unsigned(std_logic_vector(~ARG[1])),~SIZE[~TYPO])) workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.fromEnum# kind: Expression type: 'fromEnum# :: KnownNat n => BitVector n -> Int' template: ~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(unsigned(~ARG[1]),~SIZE[~TYPO])))~ELSEto_signed(0,~SIZE[~TYPO])~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.plus# kind: Expression type: 'plus# :: (KnownNat m, KnownNat n) => BitVector m -> BitVector n -> BitVector (Max m n + 1)' template: ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THENstd_logic_vector(resize(unsigned(~ARG[2]),~SIZE[~TYPO]) + resize(unsigned(~ARG[3]),~SIZE[~TYPO]))~ELSE~IF~SIZE[~TYP[2]]~THENstd_logic_vector(resize(unsigned(~ARG[2]),~SIZE[~TYPO]))~ELSEstd_logic_vector(resize(unsigned(~ARG[3]),~SIZE[~TYPO]))~FI~FI - BlackBox: name: Clash.Sized.Internal.BitVector.minus# kind: Expression type: 'minus# :: (KnownNat m, KnownNat n) => BitVector m -> BitVector n -> BitVector (Max m n + 1)' template: ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THENstd_logic_vector(resize(unsigned(~ARG[2]),~SIZE[~TYPO]) - resize(unsigned(~ARG[3]),~SIZE[~TYPO]))~ELSE~IF~SIZE[~TYP[2]]~THENstd_logic_vector(resize(unsigned(~ARG[2]),~SIZE[~TYPO]))~ELSEstd_logic_vector(-resize(signed(~ARG[3]),~SIZE[~TYPO]))~FI~FI - BlackBox: name: Clash.Sized.Internal.BitVector.times# kind: Expression type: 'times# :: (KnownNat m, KnownNat n) => BitVector m -> BitVector n -> BitVector (m + n)' template: ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THENstd_logic_vector(unsigned(~ARG[2]) * unsigned(~ARG[3]))~ELSE(~SIZE[~TYPO]-1 downto 0 => '0')~FI - BlackBox: name: Clash.Sized.Internal.BitVector.quot# kind: Declaration type: 'quot# :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: |- ~RESULT <= std_logic_vector(unsigned(~ARG[1]) / unsigned(~ARG[2])) -- pragma translate_off when (~ARG[2] /= std_logic_vector(to_unsigned(0,~SIZE[~TYP[2]]))) else (others => 'X') -- pragma translate_on ; - BlackBox: name: Clash.Sized.Internal.BitVector.rem# kind: Declaration type: 'rem# :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: |- ~RESULT <= std_logic_vector(unsigned(~ARG[1]) rem unsigned(~ARG[2])) -- pragma translate_off when (~ARG[2] /= std_logic_vector(to_unsigned(0,~SIZE[~TYP[2]]))) else (others => 'X') -- pragma translate_on ; - BlackBoxHaskell: name: Clash.Sized.Internal.BitVector.toInteger# templateFunction: Clash.Primitives.Sized.ToInteger.bvToIntegerVHDL workInfo: Never - BlackBox: name: Clash.Sized.Internal.BitVector.and# kind: Expression type: 'and# :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: ~ARG[1] and ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.or# kind: Expression type: 'or# :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: ~ARG[1] or ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.xor# kind: Expression type: 'xor# :: KnownNat n => BitVector n -> BitVector n -> BitVector n' template: ~ARG[1] xor ~ARG[2] - BlackBox: name: Clash.Sized.Internal.BitVector.complement# kind: Expression type: 'complement# :: KnownNat n => BitVector n -> BitVector n' template: not ~ARG[1] - BlackBox: name: Clash.Sized.Internal.BitVector.shiftL# kind: Declaration type: 'shiftL# :: KnownNat n => BitVector n -> Int -> BitVector n' template: |- ~GENSYM[~RESULT_shiftL][0] : block signal ~GENSYM[sh][1] : natural; begin ~SYM[1] <= -- pragma translate_off natural'high when (~VAR[shI][2](~SIZE[~TYP[2]]-1 downto 31) /= 0) else -- pragma translate_on to_integer(~VAR[shI][2]); ~RESULT <= std_logic_vector(shift_left(unsigned(~ARG[1]),~SYM[1])) -- pragma translate_off when (~ARG[2] >= 0) else (others => 'X') -- pragma translate_on ; end block; - BlackBox: name: Clash.Sized.Internal.BitVector.shiftR# kind: Declaration type: 'shiftR# :: KnownNat n => BitVector n -> Int -> BitVector n' template: |- ~GENSYM[~RESULT_shiftR][0] : block signal ~GENSYM[sh][1] : natural; begin ~SYM[1] <= -- pragma translate_off natural'high when (~VAR[shI][2](~SIZE[~TYP[2]]-1 downto 31) /= 0) else -- pragma translate_on to_integer(~VAR[shI][2]); ~RESULT <= std_logic_vector(shift_right(unsigned(~ARG[1]),~SYM[1])) -- pragma translate_off when (~ARG[2] >= 0) else (others => 'X') -- pragma translate_on ; end block; - BlackBox: name: Clash.Sized.Internal.BitVector.rotateL# kind: Declaration type: 'rotateL# :: KnownNat n => BitVector n -> Int -> BitVector n' template: |- ~RESULT <= std_logic_vector(rotate_left(unsigned(~ARG[1]),to_integer((~ARG[2]) -- pragma translate_off mod ~SIZE[~TYP[1]] -- pragma translate_on ))) -- pragma translate_off when (~ARG[2] >= 0) else (others => 'X') -- pragma translate_on ; - BlackBox: name: Clash.Sized.Internal.BitVector.rotateR# kind: Declaration type: 'rotateR# :: KnownNat n => BitVector n -> Int -> BitVector n' template: |- ~RESULT <= std_logic_vector(rotate_right(unsigned(~ARG[1]),to_integer((~ARG[2]) -- pragma translate_off mod ~SIZE[~TYP[1]] -- pragma translate_on ))) -- pragma translate_off when (~ARG[2] >= 0) else (others => 'X') -- pragma translate_on ; - BlackBox: name: Clash.Sized.Internal.BitVector.truncateB# kind: Expression type: 'truncateB# :: forall a b . KnownNat a => BitVector (a + b) -> BitVector a' template: std_logic_vector(resize(unsigned(~ARG[1]),~SIZE[~TYPO])) workInfo: Never clash-lib-1.8.1/prims/vhdl/Clash_Sized_Internal_Index.primitives.yaml0000644000000000000000000001122507346545000024071 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.Index.pack# kind: Expression type: 'pack# :: Index n -> BitVector (CLog 2 n)' template: std_logic_vector(~ARG[0]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.unpack# kind: Expression type: 'unpack# :: (KnownNat n, 1 <= n) => BitVector (CLog 2 n) -> Index n' template: unsigned(~ARG[2]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.eq# kind: Expression type: 'eq# :: Index n -> Index n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] = ~ARG[1]~ELSEtrue~FI - BlackBox: name: Clash.Sized.Internal.Index.neq# kind: Expression type: 'neq# :: Index n -> Index n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] /= ~ARG[1]~ELSEfalse~FI - BlackBox: name: Clash.Sized.Internal.Index.lt# kind: Expression type: 'lt# :: Index n -> Index n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSEfalse~FI - BlackBox: name: Clash.Sized.Internal.Index.ge# kind: Expression type: 'ge# :: Index n -> Index n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSEtrue~FI - BlackBox: name: Clash.Sized.Internal.Index.gt# kind: Expression type: 'gt# :: Index n -> Index n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSEfalse~FI - BlackBox: name: Clash.Sized.Internal.Index.le# kind: Expression type: 'le# :: Index n -> Index n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSEtrue~FI - BlackBox: name: Clash.Sized.Internal.Index.maxBound# kind: Expression type: 'maxBound# :: KnownNat n => Index n' template: to_unsigned(~LIT[0]-1,~SIZE[~TYPO]) workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Index.toEnum# kind: Expression type: 'toEnum# :: KnownNat n => Int -> Index n' template: resize(unsigned(std_logic_vector(~ARG[1])),~SIZE[~TYPO]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.fromEnum# kind: Expression type: 'fromEnum# :: KnownNat n => Index n -> Int' template: ~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(~ARG[1],~SIZE[~TYPO])))~ELSEto_signed(0,~SIZE[~TYPO])~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.+# kind: Expression type: '(+#) :: KnownNat n => Index n -> Index n -> Index n' template: ~ARG[1] + ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Index.-# kind: Expression type: '(-#) :: KnownNat n => Index n -> Index n -> Index n' template: ~ARG[1] - ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Index.*# kind: Expression type: '(*#) :: KnownNat n => Index n -> Index n -> Index n' template: resize(~ARG[1] * ~ARG[2], ~SIZE[~TYPO]) - BlackBox: name: Clash.Sized.Internal.Index.fromInteger# kind: Expression type: 'fromInteger# :: KnownNat n => Integer -> Index n' template: resize(unsigned(std_logic_vector(~ARG[1])),~SIZE[~TYPO]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.plus# kind: Expression type: Index m -> Index n -> Index (m + n - 1) template: resize(~ARG[0],~SIZE[~TYPO]) + resize(~ARG[1],~SIZE[~TYPO]) - BlackBox: name: Clash.Sized.Internal.Index.minus# kind: Expression type: Index m -> Index n -> Index (m + n - 1) template: resize(~ARG[0],~SIZE[~TYPO]) - resize(~ARG[1],~SIZE[~TYPO]) - BlackBox: name: Clash.Sized.Internal.Index.times# kind: Expression type: Index m -> Index n -> Index (((m-1) * (n-1)) + 1) template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) - BlackBox: name: Clash.Sized.Internal.Index.rem# kind: Declaration type: 'rem# :: Index n -> Index n -> Index n' template: |- ~RESULT <= ~ARG[0] rem ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; - BlackBoxHaskell: name: Clash.Sized.Internal.Index.toInteger# templateFunction: Clash.Primitives.Sized.ToInteger.indexToIntegerVHDL workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.resize# kind: Expression type: 'resize# :: KnownNat m => Index n -> Index m' template: ~IF~SIZE[~TYP[1]]~THENresize(~ARG[1],~SIZE[~TYPO])~ELSEunsigned'(~SIZE[~TYPO]-1 downto 0 => '0')~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Index.quot# kind: Declaration type: 'quot# :: Index n -> Index n -> Index n' template: |- ~RESULT <= ~ARG[0] / ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; clash-lib-1.8.1/prims/vhdl/Clash_Sized_Internal_Signed.primitives.yaml0000644000000000000000000002500307346545000024232 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.Signed.size# kind: Expression type: 'size# :: KnownNat n => Signed n -> Int' template: to_signed(~LIT[0],~SIZE[~TYPO]) workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Signed.pack# kind: Expression type: 'pack# :: KnownNat n => Signed n -> BitVector n' template: std_logic_vector(~ARG[1]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.unpack# kind: Expression type: 'unpack# :: KnownNat n => BitVector n -> Signed n' template: signed(~ARG[1]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.eq# kind: Expression type: 'eq# :: Signed n -> Signed n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] = ~ARG[1]~ELSEtrue~FI - BlackBox: name: Clash.Sized.Internal.Signed.neq# kind: Expression type: 'neq# :: Signed n -> Signed n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] /= ~ARG[1]~ELSEfalse~FI - BlackBox: name: Clash.Sized.Internal.Signed.lt# kind: Expression type: 'lt# :: Signed n -> Signed n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSEfalse~FI - BlackBox: name: Clash.Sized.Internal.Signed.ge# kind: Expression type: 'ge# :: Signed n -> Signed n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSEtrue~FI - BlackBox: name: Clash.Sized.Internal.Signed.gt# kind: Expression type: 'gt# :: Signed n -> Signed n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSEfalse~FI - BlackBox: name: Clash.Sized.Internal.Signed.le# kind: Expression type: 'le# :: Signed n -> Signed n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSEtrue~FI - BlackBox: name: Clash.Sized.Internal.Signed.minBound# comment: the quantification with signed gives the array an ascending index kind: Expression type: 'minBound# :: KnownNat n => Signed n' template: ~IF~SIZE[~TYPO]~THENsigned'(0 => '1', 1 to ~LIT[0]-1 => '0')~ELSEsigned'(1 downto 0 => '0')~FI workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Signed.maxBound# comment: the quantification with signed gives the array an ascending index kind: Expression type: 'maxBound# :: KnownNat n => Signed n' template: ~IF~SIZE[~TYPO]~THENsigned'(0 => '0', 1 to ~LIT[0]-1 => '1')~ELSEsigned'(1 downto 0 => '0')~FI workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Signed.*# kind: Expression type: '(*#) :: KnownNat n => Signed n -> Signed n -> Signed n' template: resize(~ARG[1] * ~ARG[2], ~LIT[0]) - BlackBox: name: Clash.Sized.Internal.Signed.negate# kind: Expression type: 'negate# :: KnownNat n => Signed n -> Signed n' template: -~ARG[1] - BlackBox: name: Clash.Sized.Internal.Signed.abs# kind: Expression type: 'abs# :: KnownNat n => Signed n -> Signed n' template: abs ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Signed.fromInteger# format: Haskell kind: Expression type: 'fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat)' templateFunction: Clash.Primitives.Sized.Signed.fromIntegerTFvhdl workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.toEnum# kind: Expression type: 'toEnum# :: KnownNat n => Int -> Signed n' template: resize(signed(std_logic_vector(~ARG[1])),~SIZE[~TYPO]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.fromEnum# kind: Expression type: 'fromEnum# :: KnownNat n => Signed n -> Int' template: ~IF~SIZE[~TYP[1]]~THENresize(~ARG[1],~SIZE[~TYPO])~ELSEto_signed(0,~SIZE[~TYPO])~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.plus# kind: Expression type: 'plus# :: Signed m -> Signed n -> Signed (1 + Max m n)' template: ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THENresize(~ARG[0],~SIZE[~TYPO]) + resize(~ARG[1],~SIZE[~TYPO])~ELSE~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEresize(~ARG[1],~SIZE[~TYPO])~FI~FI - BlackBox: name: Clash.Sized.Internal.Signed.minus# kind: Expression type: 'minus# :: Signed m -> Signed n -> Signed (1 + Max m n)' template: ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THENresize(~ARG[0],~SIZE[~TYPO]) - resize(~ARG[1],~SIZE[~TYPO])~ELSE~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEresize(- ~ARG[1],~SIZE[~TYPO])~FI~FI - BlackBox: name: Clash.Sized.Internal.Signed.times# kind: Expression type: 'times# :: Signed m -> Signed n -> Signed (m + n)' template: ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN~ARG[0] * ~ARG[1]~ELSEsigned'(~SIZE[~TYPO]-1 downto 0 => '0')~FI - BlackBox: name: Clash.Sized.Internal.Signed.rem# kind: Declaration type: 'rem# :: Signed n -> Signed n -> Signed n' template: |- ~RESULT <= ~ARG[0] rem ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; - BlackBox: name: Clash.Sized.Internal.Signed.div# kind: Declaration type: 'div# :: KnownNat n => Signed n -> Signed n -> Signed n' template: |- -- divSigned begin ~GENSYM[divSigned][0] : block 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] <= ~VAR[dividend][1](~VAR[dividend][1]'high) = ~VAR[divider][2](~VAR[divider][2]'high); ~SYM[2] <= ~VAR[divider][2](~VAR[divider][2]'high) = '1'; ~SYM[3] <= resize(~VAR[dividend][1],~SIZE[~TYPO]+1) when ~SYM[1] else (resize(~VAR[dividend][1],~SIZE[~TYPO]+1) - resize(~VAR[divider][2],~SIZE[~TYPO]+1) - 1) when ~SYM[2] else (resize(~VAR[dividend][1],~SIZE[~TYPO]+1) - resize(~VAR[divider][2],~SIZE[~TYPO]+1) + 1); ~SYM[4] <= ~SYM[3] / ~VAR[divider][2] -- pragma translate_off when (~VAR[divider][2] /= 0) else (others => 'X') -- pragma translate_on ; ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0)); end block; -- divSigned end - BlackBox: name: Clash.Sized.Internal.Signed.mod# kind: Declaration type: 'mod# :: Signed n -> Signed n -> Signed n' template: |- ~RESULT <= ~ARG[0] mod ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; - BlackBoxHaskell: name: Clash.Sized.Internal.Signed.toInteger# templateFunction: Clash.Primitives.Sized.ToInteger.signedToIntegerVHDL workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.and# kind: Expression type: 'and# :: KnownNat n => Signed n -> Signed n -> Signed n' template: ~ARG[1] and ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Signed.or# kind: Expression type: 'or# :: KnownNat n => Signed n -> Signed n -> Signed n' template: ~ARG[1] or ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Signed.xor# kind: Expression type: 'xor# :: KnownNat n => Signed n -> Signed n -> Signed n' template: ~ARG[1] xor ~ARG[2] - BlackBox: name: Clash.Sized.Internal.Signed.complement# kind: Expression type: 'complement# :: KnownNat n => Signed n -> Signed n' template: not ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Signed.shiftL# kind: Declaration type: 'shiftL# :: KnownNat n => Signed n -> Int -> Signed n' template: |- ~GENSYM[~RESULT_shiftL][0] : block signal ~GENSYM[sh][1] : natural; begin ~SYM[1] <= -- pragma translate_off natural'high when (~VAR[shI][2](~SIZE[~TYP[2]]-1 downto 31) /= 0) else -- pragma translate_on to_integer(~VAR[shI][2]); ~RESULT <= shift_left(~ARG[1],~SYM[1]) -- pragma translate_off when (~ARG[2] >= 0) else (others => 'X') -- pragma translate_on ; end block; - BlackBox: name: Clash.Sized.Internal.Signed.shiftR# kind: Declaration type: 'shiftR# :: KnownNat n => Signed n -> Int -> Signed n' template: |- ~GENSYM[~RESULT_shiftR][0] : block signal ~GENSYM[sh][1] : natural; begin ~SYM[1] <= -- pragma translate_off natural'high when (~VAR[shI][2](~SIZE[~TYP[2]]-1 downto 31) /= 0) else -- pragma translate_on to_integer(~VAR[shI][2]); ~RESULT <= shift_right(~ARG[1],~SYM[1]) -- pragma translate_off when (~ARG[2] >= 0) else (others => 'X') -- pragma translate_on ; end block; - BlackBox: name: Clash.Sized.Internal.Signed.rotateL# kind: Declaration type: 'rotateL# :: KnownNat n => Signed n -> Int -> Signed n' template: |- ~RESULT <= rotate_left(~ARG[1],to_integer((~ARG[2]) -- pragma translate_off mod ~SIZE[~TYP[1]] -- pragma translate_on )) -- pragma translate_off when (~ARG[2] >= 0) else (others => 'X') -- pragma translate_on ; - BlackBox: name: Clash.Sized.Internal.Signed.rotateR# kind: Declaration type: 'rotateR# :: KnownNat n => Signed n -> Int -> Signed n' template: |- ~RESULT <= rotate_right(~ARG[1],to_integer((~ARG[2]) -- pragma translate_off mod ~SIZE[~TYP[1]] -- pragma translate_on )) -- pragma translate_off when (~ARG[2] >= 0) else (others => 'X') -- pragma translate_on ; - BlackBox: name: Clash.Sized.Internal.Signed.resize# kind: Expression type: 'resize# :: (KnownNat n, KnownNat m) => Signed n -> Signed m' template: ~IF~SIZE[~TYP[2]]~THENresize(~ARG[2],~LIT[1])~ELSEsigned'(~SIZE[~TYPO]-1 downto 0 => '0')~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.truncateB# kind: Expression type: 'truncateB# :: KnownNat m => Signed (n + m) -> Signed m' template: ~IF~SIZE[~TYPO]~THEN~VAR[s][1](~LIT[0]-1 downto 0)~ELSEsigned'(0 downto 1 => '0')~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Signed.quot# kind: Declaration type: 'quot# :: KnownNat n => Signed n -> Signed n -> Signed n' template: |- ~RESULT <= ~ARG[1] / ~ARG[2] -- pragma translate_off when (~ARG[2] /= 0) else (others => 'X') -- pragma translate_on ; clash-lib-1.8.1/prims/vhdl/Clash_Sized_Internal_Unsigned.primitives.yaml0000644000000000000000000002104507346545000024577 0ustar0000000000000000- BlackBox: name: Clash.Sized.Internal.Unsigned.size# kind: Expression type: 'size# :: KnownNat n => Unsigned n -> Int' template: to_signed(~LIT[0],~SIZE[~TYPO]) workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Unsigned.pack# kind: Expression type: 'pack# :: Unsigned n -> BitVector n' template: std_logic_vector(~ARG[0]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.unpack# kind: Expression type: 'unpack# :: KnownNat n => BitVector n -> Unsigned n' template: unsigned(~ARG[1]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.eq# kind: Expression type: 'eq# :: Unsigned n -> Unsigned n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] = ~ARG[1]~ELSEtrue~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.neq# kind: Expression type: 'neq# :: Unsigned n -> Unsigned n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] /= ~ARG[1]~ELSEfalse~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.lt# kind: Expression type: 'lt# :: Unsigned n -> Unsigned n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSEfalse~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.ge# kind: Expression type: 'ge# :: Unsigned n -> Unsigned n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSEtrue~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.gt# kind: Expression type: 'gt# :: Unsigned n -> Unsigned n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSEfalse~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.le# kind: Expression type: 'le# :: Unsigned n -> Unsigned n -> Bool' template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSEtrue~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.minBound# kind: Expression type: 'minBound# :: Unsigned n' template: ~IF~SIZE[~TYPO]~THENunsigned'(~SIZE[~TYPO]-1 downto 0 => '0')~ELSEunsigned'(0 downto 1 => '0')~FI workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Unsigned.maxBound# kind: Expression type: 'maxBound# :: KnownNat n => Unsigned n' template: ~IF~SIZE[~TYPO]~THENunsigned'(~LIT[0]-1 downto 0 => '1')~ELSEunsigned'(0 downto 1 => '1')~FI workInfo: Constant - BlackBox: name: Clash.Sized.Internal.Unsigned.*# kind: Expression type: '(*#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n' template: resize(~ARG[1] * ~ARG[2], ~LIT[0]) - BlackBox: name: Clash.Sized.Internal.Unsigned.negate# kind: Expression type: 'negate# :: KnownNat n => Unsigned n -> Unsigned n' template: unsigned(std_logic_vector(-(signed(std_logic_vector(~ARG[1]))))) - BlackBox: name: Clash.Sized.Internal.Unsigned.fromInteger# kind: Expression type: 'fromInteger# :: KnownNat n => Integer -> Unsigned n' template: resize(unsigned(std_logic_vector(~ARG[1])),~LIT[0]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.toEnum# kind: Expression type: 'toEnum# :: KnownNat n => Int -> Unsigned n' template: resize(unsigned(std_logic_vector(~ARG[1])),~SIZE[~TYPO]) workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.fromEnum# kind: Expression type: 'fromEnum# :: KnownNat n => Unsigned n -> Int' template: ~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(~ARG[1],~SIZE[~TYPO])))~ELSEto_signed(0,~SIZE[~TYPO])~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.plus# kind: Expression type: 'plus# :: Unsigned m -> Unsigned n -> Unsigned (1 + Max m n)' template: ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THENresize(~ARG[0],~SIZE[~TYPO]) + resize(~ARG[1],~SIZE[~TYPO])~ELSE~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEresize(~ARG[1],~SIZE[~TYPO])~FI~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.minus# kind: Expression type: 'minus# :: (KnownNat m,KnownNat n) => Unsigned m -> Unsigned n -> Unsigned (1 + Max m n)' template: ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THENresize(~ARG[2],~SIZE[~TYPO]) - resize(~ARG[3],~SIZE[~TYPO])~ELSE~IF~SIZE[~TYP[2]]~THENresize(~ARG[2],~SIZE[~TYPO])~ELSEresize(~ARG[3],~SIZE[~TYPO])~FI~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.times# kind: Expression type: 'times# :: Unsigned m -> Unsigned n -> Unsigned (m + n)' template: ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN~ARG[0] * ~ARG[1]~ELSEunsigned'(~SIZE[~TYPO]-1 downto 0 => '0')~FI - BlackBox: name: Clash.Sized.Internal.Unsigned.rem# kind: Declaration type: 'rem# :: Unsigned n -> Unsigned n -> Unsigned n' template: |- ~RESULT <= ~ARG[0] rem ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; - BlackBoxHaskell: name: Clash.Sized.Internal.Unsigned.toInteger# templateFunction: Clash.Primitives.Sized.ToInteger.unsignedToIntegerVHDL workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.and# kind: Expression type: 'and# :: Unsigned n -> Unsigned n -> Unsigned n' template: ~ARG[0] and ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Unsigned.or# kind: Expression type: 'or# :: Unsigned n -> Unsigned n -> Unsigned n' template: ~ARG[0] or ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Unsigned.xor# kind: Expression type: 'xor# :: Unsigned n -> Unsigned n -> Unsigned n' template: ~ARG[0] xor ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Unsigned.complement# kind: Expression type: 'complement# :: KnownNat n => Unsigned n -> Unsigned n' template: not ~ARG[1] - BlackBox: name: Clash.Sized.Internal.Unsigned.shiftL# kind: Declaration type: 'shiftL# :: KnownNat n => Unsigned n -> Int -> Unsigned n' template: |- ~GENSYM[~RESULT_shiftL][0] : block signal ~GENSYM[sh][1] : natural; begin ~SYM[1] <= -- pragma translate_off natural'high when (~VAR[shI][2](~SIZE[~TYP[2]]-1 downto 31) /= 0) else -- pragma translate_on to_integer(~VAR[shI][2]); ~RESULT <= shift_left(~ARG[1],~SYM[1]) -- pragma translate_off when (~ARG[2] >= 0) else (others => 'X') -- pragma translate_on ; end block; - BlackBox: name: Clash.Sized.Internal.Unsigned.shiftR# kind: Declaration type: 'shiftR# :: KnownNat n => Unsigned n -> Int -> Unsigned n' template: |- ~GENSYM[~RESULT_shiftL][0] : block signal ~GENSYM[sh][1] : natural; begin ~SYM[1] <= -- pragma translate_off natural'high when (~VAR[shI][2](~SIZE[~TYP[2]]-1 downto 31) /= 0) else -- pragma translate_on to_integer(~VAR[shI][2]); ~RESULT <= shift_right(~ARG[1],~SYM[1]) -- pragma translate_off when (~ARG[2] >= 0) else (others => 'X') -- pragma translate_on ; end block; - BlackBox: name: Clash.Sized.Internal.Unsigned.rotateL# kind: Declaration type: 'rotateL# :: KnownNat n => Unsigned n -> Int -> Unsigned n' template: |- ~RESULT <= rotate_left(~ARG[1],to_integer((~ARG[2]) -- pragma translate_off mod ~SIZE[~TYP[1]] -- pragma translate_on )) -- pragma translate_off when (~ARG[2] >= 0) else (others => 'X') -- pragma translate_on ; - BlackBox: name: Clash.Sized.Internal.Unsigned.rotateR# kind: Declaration type: 'rotateR# :: KnownNat n => Unsigned n -> Int -> Unsigned n' template: |- ~RESULT <= rotate_right(~ARG[1],to_integer((~ARG[2]) -- pragma translate_off mod ~SIZE[~TYP[1]] -- pragma translate_on )) -- pragma translate_off when (~ARG[2] >= 0) else (others => 'X') -- pragma translate_on ; - BlackBox: name: Clash.Sized.Internal.Unsigned.resize# kind: Expression type: 'resize# :: KnownNat m => Unsigned n -> Unsigned m' template: ~IF~SIZE[~TYP[1]]~THENresize(~ARG[1],~LIT[0])~ELSEunsigned'(~SIZE[~TYPO]-1 downto 0 => '0')~FI workInfo: Never - BlackBox: name: Clash.Sized.Internal.Unsigned.quot# kind: Declaration type: 'quot# :: Unsigned n -> Unsigned n -> Unsigned n' template: |- ~RESULT <= ~ARG[0] / ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; clash-lib-1.8.1/prims/vhdl/Clash_Sized_RTree.primitives.yaml0000644000000000000000000000136507346545000022213 0ustar0000000000000000- BlackBox: name: Clash.Sized.RTree.treplicate kind: Expression type: 'replicate :: SNat n -> a -> RTree d a' template: ~TYPMO'(0 to (2**~LIT[0])-1 => ~IF~VIVADO~THEN~TOBV[~ARG[1]][~TYP[1]]~ELSE~ARG[1]~FI) workInfo: Never - BlackBox: name: Clash.Sized.RTree.textract kind: Expression type: 'textract :: RTree 0 a -> a' template: ~IF ~VIVADO ~THEN ~FROMBV[~VAR[t][0](0)][~TYPO] ~ELSE ~VAR[t][0](0) ~FI workInfo: Never - BlackBox: name: Clash.Sized.RTree.tsplit kind: Expression type: 'tsplit:: RTree (d+1) a -> (RTree d a,RTree d a)' template: (~VAR[t][0](0 to (2**(~DEPTH[~TYP[0]]-1))-1) ,~VAR[t][0](2**(~DEPTH[~TYP[0]]-1) to (2**~DEPTH[~TYP[0]])-1)) workInfo: Never clash-lib-1.8.1/prims/vhdl/Clash_Sized_Vector.primitives.yaml0000644000000000000000000003553107346545000022436 0ustar0000000000000000- BlackBox: name: Clash.Sized.Vector.head kind: Expression type: 'head :: Vec (n + 1) a -> a' template: ~IF ~VIVADO ~THEN ~TYPMO'(fromSLV(~VAR[vec][0](0))) ~ELSE ~VAR[vec][0](0) ~FI workInfo: Never - BlackBox: name: Clash.Sized.Vector.tail kind: Expression type: 'tail :: Vec (n + 1) a -> Vec n a' template: ~VAR[vec][0](1 to ~VAR[vec][0]'high) workInfo: Never - BlackBox: name: Clash.Sized.Vector.last kind: Expression type: Vec (n + 1) a -> a template: ~IF ~VIVADO ~THEN ~TYPMO'(fromSLV(~VAR[vec][0](~VAR[vec][0]'high))) ~ELSE ~VAR[vec][0](~VAR[vec][0]'high) ~FI workInfo: Never - BlackBox: name: Clash.Sized.Vector.init kind: Expression type: Vec (n + 1) a -> Vec n a template: ~VAR[vec][0](0 to ~VAR[vec][0]'high - 1) workInfo: Never - BlackBox: name: Clash.Sized.Vector.select kind: Declaration type: |- select :: (CmpNat (i + s) (s * n) ~ GT) -- ARG[0] => SNat f -- ARG[1] -> SNat s -- ARG[2] -> SNat n -- ARG[3] -> Vec i a -- ARG[4] -> Vec n a template: |- -- select begin ~GENSYM[select][0] : for ~GENSYM[i][1] in ~RESULT'range generate ~RESULT(~SYM[1]) <= ~VAR[vec][4](~LIT[1]+(~LIT[2]*~SYM[1])); end generate; -- select end workInfo: Never - BlackBox: name: Clash.Sized.Vector.++ kind: Expression type: '(++) :: Vec n a -> Vec m a -> Vec (n + m) a' template: ~TYPMO'(~TYPM[0]'(~ARG[0]) & ~TYPM[1]'(~ARG[1])) workInfo: Never - BlackBox: name: Clash.Sized.Vector.concat kind: Declaration type: 'concat :: Vec n (Vec m a) -> Vec (n * m) a' template: |- -- concat begin ~GENSYM[concat][0] : for ~GENSYM[i][1] in 0 to (~LENGTH[~TYP[0]] - 1) generate begin~IF ~VIVADO ~THEN ~RESULT(~SYM[1] * ~LENGTH[~TYPEL[~TYP[0]]] to ((~SYM[1]+1) * ~LENGTH[~TYPEL[~TYP[0]]]) - 1) <= fromSLV(~VAR[vec][0](~SYM[1]));~ELSE ~RESULT(~SYM[1] * ~LENGTH[~TYPEL[~TYP[0]]] to ((~SYM[1]+1) * ~LENGTH[~TYPEL[~TYP[0]]]) - 1) <= ~VAR[vec][0](~SYM[1]);~FI end generate; -- concat end workInfo: Never - BlackBox: name: Clash.Sized.Vector.splitAt kind: Expression type: 'splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)' template: ~IF~LENGTH[~TYPO]~THEN~ARG[1]~ELSE(~VAR[vec][1](0 to ~LIT[0]-1),~VAR[vec][1](~LIT[0] to ~VAR[vec][1]'high))~FI workInfo: Never - BlackBox: name: Clash.Sized.Vector.unconcat kind: Declaration type: |- unconcat :: KnownNat n -- ARG[0] => SNat m -- ARG[1] -> Vec (n * m) a -- ARG[2] -> Vec n (Vec m a) template: |- -- unconcat begin~DEVNULL[~ARG[0]] ~GENSYM[unconcat][0] : for ~GENSYM[i][2] in ~RESULT'range generate begin~IF ~VIVADO ~THEN ~RESULT(~SYM[2]) <= ~TOBV[~VAR[vec][2]((~SYM[2] * ~LIT[1]) to ((~SYM[2] * ~LIT[1]) + ~LIT[1] - 1))][~TYPEL[~TYPO]];~ELSE ~RESULT(~SYM[2]) <= ~VAR[vec][2]((~SYM[2] * ~LIT[1]) to ((~SYM[2] * ~LIT[1]) + ~LIT[1] - 1));~FI end generate; -- unconcat end workInfo: Never - BlackBox: name: Clash.Sized.Vector.map kind: Declaration type: 'map :: (a -> b) -> Vec n a -> Vec n b' template: |- -- map begin ~GENSYM[map][0] : for ~GENSYM[i][1] in ~RESULT'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[1]]~THEN signal ~GENSYM[map_in][2] : ~TYPEL[~TYP[1]];~ELSE ~FI signal ~GENSYM[map_out][3] : ~TYPEL[~TYPO]; begin~IF~SIZE[~TYP[1]]~THEN ~SYM[2] <= fromSLV(~VAR[vec][1](~SYM[1]));~ELSE ~FI ~INST 0 ~OUTPUT <= ~SYM[3]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[2]~ ~TYPEL[~TYP[1]]~ ~INST ~RESULT(~SYM[1]) <= ~TOBV[~SYM[3]][~TYPEL[~TYPO]]; end generate;~ELSE begin ~INST 0 ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~ ~INPUT <= ~VAR[vec][1](~SYM[1])~ ~TYPEL[~TYP[1]]~ ~INST end generate;~FI -- map end workInfo: Never - BlackBox: name: Clash.Sized.Vector.imap kind: Declaration type: 'imap :: KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b' template: |- -- imap begin ~GENSYM[imap][0] : block function ~GENSYM[max][6] (l,r : in natural) return natural is begin if l > r then return l; else return r; end if; end function; begin ~GENSYM[imap][5] : for ~GENSYM[i][1] in ~RESULT'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[2]]~THEN signal ~GENSYM[map_in][2] : ~TYPEL[~TYP[2]];~ELSE ~FI signal ~GENSYM[map_out][3] : ~TYPEL[~TYPO]; begin~IF~SIZE[~TYP[2]]~THEN ~SYM[2] <= fromSLV(~VAR[vec][2](~SYM[1]));~ELSE ~FI ~INST 1 ~OUTPUT <= ~SYM[3]~ ~TYPEL[~TYPO]~ ~INPUT <= to_unsigned(~SYM[1],~SYM[6](1,integer(ceil(log2(real(~LIT[0]))))))~ ~INDEXTYPE[~LIT[0]]~ ~INPUT <= ~SYM[2]~ ~TYPEL[~TYP[2]]~ ~INST ~RESULT(~SYM[1]) <= ~TOBV[~SYM[3]][~TYPEL[~TYPO]]; end generate;~ELSE begin ~INST 1 ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~ ~INPUT <= to_unsigned(~SYM[1],~SYM[6](1,integer(ceil(log2(real(~LIT[0]))))))~ ~INDEXTYPE[~LIT[0]]~ ~INPUT <= ~VAR[vec][2](~SYM[1])~ ~TYPEL[~TYP[2]]~ ~INST end generate;~FI end block; -- imap end workInfo: Never - BlackBox: name: Clash.Sized.Vector.imap_go kind: Declaration type: 'imap_go :: Index n -> (Index n -> a -> b) -> Vec m a -> Vec m b' template: |- -- imap_go begin ~GENSYM[imap][5] : for ~GENSYM[i][1] in ~RESULT'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[2]]~THEN signal ~GENSYM[map_in][2] : ~TYPEL[~TYP[2]];~ELSE ~FI signal ~GENSYM[map_out][3] : ~TYPEL[~TYPO]; signal ~GENSYM[i2][4] : ~TYP[0]; begin~IF~SIZE[~TYP[2]]~THEN ~SYM[2] <= fromSLV(~VAR[vec][2](~SYM[1]));~ELSE ~FI ~SYM[4] <= ~ARG[0] + to_unsigned(~SYM[1],~SIZE[~TYP[0]]); ~INST 1 ~OUTPUT <= ~SYM[3]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[4]~ ~TYP[0]~ ~INPUT <= ~SYM[2]~ ~TYPEL[~TYP[2]]~ ~INST ~RESULT(~SYM[1]) <= ~TOBV[~SYM[3]][~TYPEL[~TYPO]]; end generate;~ELSE signal ~SYM[4] : ~TYP[0]; begin ~SYM[4] <= ~ARG[0] + to_unsigned(~SYM[1],~SIZE[~TYP[0]]); ~INST 1 ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[4]~ ~TYP[0]~ ~INPUT <= ~VAR[vec][2](~SYM[1])~ ~TYPEL[~TYP[2]]~ ~INST end generate;~FI -- imap_go end workInfo: Never - BlackBox: name: Clash.Sized.Vector.zipWith kind: Declaration type: 'zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c' template: |- -- zipWith begin ~GENSYM[zipWith][0] : for ~GENSYM[i][1] in ~RESULT'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[1]]~THEN signal ~GENSYM[zipWith_in1][2] : ~TYPEL[~TYP[1]];~ELSE ~FI~IF~SIZE[~TYP[2]]~THEN signal ~GENSYM[zipWith_in2][6] : ~TYPEL[~TYP[2]];~ELSE ~FI signal ~GENSYM[zipWith_out][3] : ~TYPEL[~TYPO]; begin~IF~SIZE[~TYP[1]]~THEN ~SYM[2] <= fromSLV(~VAR[vec1][1](~SYM[1]));~ELSE ~FI~IF~SIZE[~TYP[2]]~THEN ~SYM[6] <= fromSLV(~VAR[vec2][2](~SYM[1]));~ELSE ~FI ~INST 0 ~OUTPUT <= ~SYM[3]~ ~TYPEL[~TYPO]~ ~INPUT <= ~SYM[2]~ ~TYPEL[~TYP[1]]~ ~INPUT <= ~SYM[6]~ ~TYPEL[~TYP[2]]~ ~INST ~RESULT(~SYM[1]) <= ~TOBV[~SYM[3]][~TYPEL[~TYPO]]; end generate;~ELSE begin ~INST 0 ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~ ~INPUT <= ~VAR[vec1][1](~SYM[1])~ ~TYPEL[~TYP[1]]~ ~INPUT <= ~VAR[vec2][2](~SYM[1])~ ~TYPEL[~TYP[2]]~ ~INST end generate;~FI -- zipWith end workInfo: Never - BlackBox: name: Clash.Sized.Vector.foldr kind: Declaration type: 'foldr :: (a -> b -> b) -> b -> Vec n a -> b' template: |- -- foldr begin~IF ~LENGTH[~TYP[2]] ~THEN ~GENSYM[foldr][0] : block type ~GENSYM[foldr_res_type][1] is array (natural range <>) of ~TYP[1]; signal ~GENSYM[intermediate][2] : ~SYM[1] (0 to ~LENGTH[~TYP[2]]); begin ~SYM[2](~LENGTH[~TYP[2]]) <= ~ARG[1]; foldr_loop : for ~GENSYM[i][3] in 0 to (~LENGTH[~TYP[2]] - 1) generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[2]]~THEN signal ~GENSYM[foldr_in][4] : ~TYPEL[~TYP[2]];~ELSE ~FI begin~IF~SIZE[~TYP[2]]~THEN ~SYM[4] <= fromSLV(~VAR[vec][2](~SYM[3]));~ELSE ~FI ~INST 0 ~OUTPUT <= ~SYM[2](~SYM[3])~ ~TYP[1]~ ~INPUT <= ~SYM[4]~ ~TYPEL[~TYP[2]]~ ~INPUT <= ~SYM[2](~SYM[3]+1)~ ~TYP[1]~ ~INST end generate;~ELSE begin ~INST 0 ~OUTPUT <= ~SYM[2](~SYM[3])~ ~TYP[1]~ ~INPUT <= ~VAR[vec][2](~SYM[3])~ ~TYPEL[~TYP[2]]~ ~INPUT <= ~SYM[2](~SYM[3]+1)~ ~TYP[1]~ ~INST end generate;~FI ~RESULT <= ~SYM[2](0); end block;~ELSE ~RESULT <= ~ARG[1];~FI -- foldr end workInfo: Never - BlackBox: name: Clash.Sized.Vector.index_int kind: Declaration type: 'index_int :: KnownNat n => Vec n a -> Int -> a' template: |- -- index begin ~IF~SIZE[~TYP[1]]~THEN~GENSYM[indexVec][0] : block signal ~GENSYM[vec_index][1] : integer range 0 to ~LIT[0]-1; begin ~SYM[1] <= to_integer(~ARG[2]) -- pragma translate_off mod ~LIT[0] -- pragma translate_on ;~IF ~VIVADO ~THEN ~RESULT <= fromSLV(~VAR[vec][1](~SYM[1]));~ELSE ~RESULT <= ~VAR[vec][1](~SYM[1]);~FI end block;~ELSE~RESULT <= ~ERRORO;~FI -- index end - 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: |- -- replace begin ~GENSYM[replaceVec][0] : block signal ~GENSYM[vec_index][1] : integer range 0 to ~LIT[0]-1; begin ~SYM[1] <= to_integer(~ARG[2]) -- pragma translate_off mod ~LIT[0] -- pragma translate_on ; process(~SYM[1]~VARS[1]~VARS[3]) variable ~GENSYM[ivec][2] : ~TYP[1]; begin ~SYM[2] := ~ARG[1];~IF ~VIVADO ~THEN ~SYM[2](~SYM[1]) := ~TOBV[~ARG[3]][~TYP[3]];~ELSE ~SYM[2](~SYM[1]) := ~ARG[3];~FI ~RESULT <= ~SYM[2]; end process; end block; -- replace end - BlackBox: name: Clash.Sized.Vector.length kind: Expression type: 'length :: KnownNat n => Vec n a -> Int' template: to_signed(~LIT[0],~SIZE[~TYPO]) workInfo: Constant - BlackBox: name: Clash.Sized.Vector.replicate kind: Expression type: 'replicate :: SNat n -> a -> Vec n a' template: ~TYPMO'(0 to ~LIT[0]-1 => ~IF ~VIVADO ~THEN ~TOBV[~ARG[1]][~TYP[1]] ~ELSE ~ARG[1] ~FI) workInfo: Never - BlackBox: name: Clash.Sized.Vector.transpose kind: Declaration type: 'transpose :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)' template: |- -- transpose begin ~GENSYM[transpose_outer][2] : for ~GENSYM[row_index][3] in 0 to (~LENGTH[~TYP[1]] - 1) generate ~GENSYM[transpose_inner][4] : for ~GENSYM[col_index][5] in ~RESULT'range generate~IF ~VIVADO ~THEN ~RESULT(~SYM[5])((~LENGTH[~TYP[1]]-~SYM[3])*~SIZE[~TYPEL[~TYPEL[~TYPO]]]-1 downto (~LENGTH[~TYP[1]]-~SYM[3]-1)*~SIZE[~TYPEL[~TYPEL[~TYPO]]]) <= ~VAR[vec][1](~SYM[3])((~RESULT'length-~SYM[5])*~SIZE[~TYPEL[~TYPEL[~TYPO]]]-1 downto (~RESULT'length-~SYM[5]-1)*~SIZE[~TYPEL[~TYPEL[~TYPO]]]);~ELSE ~RESULT(~SYM[5])(~SYM[3]) <= ~VAR[matrix][1](~SYM[3])(~SYM[5]);~FI end generate; end generate; -- transpose end workInfo: Never - BlackBox: name: Clash.Sized.Vector.reverse kind: Declaration type: 'reverse :: Vec n a -> Vec n a' template: |- -- reverse begin ~GENSYM[reverse_loop][2] : for ~GENSYM[i][3] in 0 to (~LENGTH[~TYP[0]] - 1) generate ~RESULT(~VAR[vec][0]'high - ~SYM[3]) <= ~VAR[vec][0](~SYM[3]); end generate; -- reverse end workInfo: Never - BlackBox: name: Clash.Sized.Vector.concatBitVector# kind: Declaration type: |- concatBitVector# :: (KnownNat n,KnownNat m) -- (ARG[0],ARG[1]) => Vec n (BitVector m) -- ARG[2] -> BitVector (n * m) template: |- -- concatBitVector begin ~GENSYM[concatBitVectorIter_loop][2] : for ~GENSYM[i][3] in 0 to (~LENGTH[~TYP[2]] - 1) generate ~RESULT(((~SYM[3] * ~LIT[1]) + ~LIT[1] - 1) downto (~SYM[3] * ~LIT[1])) <= ~TYPMO'(~VAR[vec][2](~VAR[vec][2]'high - ~SYM[3])); end generate; -- concatBitVector end workInfo: Never - BlackBox: name: Clash.Sized.Vector.unconcatBitVector# kind: Declaration type: |- unconcatBitVector# :: (KnownNat n, KnownNat m) -- (ARG[0],ARG[1]) => BitVector (n * m) -- ARG[2] -> Vec n (BitVector m) template: |- -- unconcatBitVector begin ~GENSYM[unconcatBitVectorIter_loop][2] : for ~GENSYM[i][3] in ~RESULT'range generate ~RESULT(~RESULT'high - ~SYM[3]) <= ~VAR[vec][2](((~SYM[3] * ~LIT[1]) + ~LIT[1] - 1) downto (~SYM[3] * ~LIT[1])); end generate; -- unconcatBitVector end workInfo: Never - BlackBox: name: Clash.Sized.Vector.rotateLeftS kind: Declaration type: 'rotateLeftS :: KnownNat n => Vec n a -> SNat d -> Vec n a' template: |- -- rotateLeftS begin ~GENSYM[rotateLeftS][0] : block constant ~GENSYM[shift_amount][2] : natural := ~LIT[2] mod ~LIT[0]; begin ~GENSYM[no_shift][3] : if ~SYM[2] = 0 generate ~RESULT <= ~VAR[vec][1]; end generate; ~GENSYM[do_shift][4] : if ~SYM[2] /= 0 generate ~RESULT <= ~VAR[vec][1](~SYM[2] to ~LIT[0]-1) & ~VAR[vec][1](0 to ~SYM[2]-1); end generate; end block; -- rotateLeftS end workInfo: Never - BlackBox: name: Clash.Sized.Vector.rotateRightS kind: Declaration type: 'rotateRightS :: KnownNat n => Vec n a -> SNat d -> Vec n a' template: |- -- rotateRightS begin ~GENSYM[rotateLeftS][0] : block constant ~GENSYM[shift_amount][2] : natural := ~LIT[2] mod ~LIT[0]; begin ~GENSYM[no_shift][3] : if ~SYM[2] = 0 generate ~RESULT <= ~VAR[vec][1]; end generate; ~GENSYM[do_shift][4] : if ~SYM[2] /= 0 generate ~RESULT <= ~VAR[vec][1](~LIT[0]-~SYM[2] to ~LIT[0]-1) & ~VAR[vec][1](0 to ~LIT[0]-~SYM[2]-1); end generate; end block; -- rotateRightS end workInfo: Never clash-lib-1.8.1/prims/vhdl/Clash_Xilinx_DDR.primitives.yaml0000644000000000000000000000746507346545000022007 0ustar0000000000000000- BlackBox: name: Clash.Xilinx.DDR.iddr imports: - UNISIM.vcomponents.all kind: Declaration libraries: - UNISIM type: |- iddr :: ( HasCallStack -- ARG[0] , KnownConfi~ fast domf -- ARG[1] , KnownConfi~ slow doms -- ARG[2] , KnownNat m ) -- ARG[3] -> Clock slow -- ARG[4] -> Reset slow -- ARG[5] -> Enable slow -- ARG[6] -> Signal fast (BitVector m) -- ARG[7] -> Signal slow (BitVector m,BitVector m) template: |- -- iddr begin ~GENSYM[~COMPNAME_IDDR][0] : block signal ~GENSYM[dataout_l][1] : ~TYP[7]; signal ~GENSYM[dataout_h][2] : ~TYP[7]; signal ~GENSYM[d][3] : ~TYP[7];~IF ~ISACTIVEENABLE[6] ~THEN signal ~GENSYM[ce_logic][4]: std_logic;~ELSE ~FI begin~IF ~ISACTIVEENABLE[6] ~THEN ~SYM[4] <= '1' when (~ARG[6]) else '0';~ELSE ~FI ~SYM[3] <= ~ARG[7]; ~GENSYM[gen_iddr][7] : for ~GENSYM[i][8] in ~SYM[3]'range generate begin ~GENSYM[~COMPNAME_IDDR_inst][9] : IDDR generic map ( DDR_CLK_EDGE => "SAME_EDGE", INIT_Q1 => '0', INIT_Q2 => '0', SRTYPE => ~IF ~ISSYNC[2] ~THEN "SYNC" ~ELSE "ASYNC" ~FI) port map ( Q1 => ~SYM[1](~SYM[8]), -- 1-bit output for positive edge of clock Q2 => ~SYM[2](~SYM[8]), -- 1-bit output for negative edge of clock C => ~ARG[4], -- 1-bit clock input CE => ~IF ~ISACTIVEENABLE[6] ~THEN ~SYM[4] ~ELSE '1' ~FI, -- 1-bit clock enable input D => ~SYM[3](~SYM[8]), -- 1-bit DDR data input R => ~ARG[5], -- 1-bit reset S => '0' -- 1-bit set ); end generate; ~RESULT <= (~SYM[2], ~SYM[1]); end block; -- iddr# end - BlackBox: name: Clash.Xilinx.DDR.oddr# imports: - UNISIM.vcomponents.all kind: Declaration libraries: - UNISIM type: |- oddr# :: ( KnownConfi~ fast domf -- ARG[0] , KnownConfi~ slow doms -- ARG[1] , KnownNat m ) -- ARG[2] => Clock slow -- ARG[3] -> Reset slow -- ARG[4] -> Enable slow -- ARG[5] -> Signal slow (BitVector m) -- ARG[6] -> Signal slow (BitVector m) -- ARG[7] -> Signal fast (BitVector m) template: |- -- oddr begin ~GENSYM[~COMPNAME_ODDR][0] : block signal ~GENSYM[dataout_l][1] : ~TYPO; signal ~GENSYM[dataout_h][2] : ~TYPO; signal ~GENSYM[q][3] : ~TYPO;~IF ~ISACTIVEENABLE[5] ~THEN signal ~GENSYM[ce_logic][4] : std_logic;~ELSE ~FI begin~IF ~ISACTIVEENABLE[5] ~THEN ~SYM[4] <= '1' when (~ARG[5]) else '0';~ELSE ~FI ~SYM[1] <= ~ARG[6]; ~SYM[2] <= ~ARG[7]; ~GENSYM[gen_iddr][7] : for ~GENSYM[i][8] in ~SYM[3]'range generate begin ~GENSYM[~COMPNAME_ODDR_inst][9] : ODDR generic map( DDR_CLK_EDGE => "SAME_EDGE", INIT => '0', SRTYPE => ~IF ~ISSYNC[2] ~THEN "SYNC" ~ELSE "ASYNC" ~FI) port map ( Q => ~SYM[3](~SYM[8]), -- 1-bit DDR output C => ~ARG[3], -- 1-bit clock input CE => ~IF ~ISACTIVEENABLE[5] ~THEN ~SYM[4] ~ELSE '1' ~FI, -- 1-bit clock enable input D1 => ~SYM[1](~SYM[8]), -- 1-bit data input (positive edge) D2 => ~SYM[2](~SYM[8]), -- 1-bit data input (negative edge) R => ~ARG[4], -- 1-bit reset input S => '0' -- 1-bit set input ); end generate; ~RESULT <= ~SYM[3]; end block; -- oddr end clash-lib-1.8.1/prims/vhdl/GHC_Base.primitives.yaml0000644000000000000000000000403207346545000020247 0ustar0000000000000000- BlackBox: name: GHC.Base.remInt kind: Declaration type: 'remInt :: Int -> Int -> Int' template: |- ~RESULT <= ~ARG[0] rem ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; - BlackBox: name: GHC.Base.divInt kind: Declaration type: 'divInt :: Int -> Int -> Int' template: |- -- divInt begin ~GENSYM[divInt][0] : block 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] <= ~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 (~VAR[divider][1] /= 0) else (others => 'X') -- pragma translate_on ; ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0)); end block; -- divInt end - BlackBox: name: GHC.Base.modInt kind: Declaration type: 'modInt :: Int -> Int -> Int' template: |- ~RESULT <= ~ARG[0] mod ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; - BlackBox: name: GHC.Base.quotInt kind: Declaration type: 'quotInt :: Int -> Int -> Int' template: |- ~RESULT <= ~ARG[0] / ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; clash-lib-1.8.1/prims/vhdl/GHC_Classes.primitives.yaml0000644000000000000000000000377007346545000021002 0ustar0000000000000000- BlackBox: name: GHC.Classes.eqInt kind: Expression type: 'eqInt :: Int -> Int -> Bool' template: ~ARG[0] = ~ARG[1] - BlackBox: name: GHC.Classes.neInt kind: Expression type: 'neInt :: Int -> Int -> Bool' template: ~ARG[0] /= ~ARG[1] - BlackBox: name: GHC.Classes.&& kind: Expression type: '(&&) :: Bool -> Bool -> Bool' template: ~ARG[0] and ~ARG[1] - BlackBox: name: GHC.Classes.|| kind: Expression type: '(::) :: Bool -> Bool -> Bool' template: ~ARG[0] or ~ARG[1] - BlackBox: name: GHC.Classes.not kind: Expression type: 'not :: Bool -> Bool' template: not ~ARG[0] - BlackBox: name: GHC.Classes.divInt# kind: Declaration type: 'divInt# :: Int# -> Int# -> Int#' template: |- -- divInt# begin ~GENSYM[divInt][0] : block 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] <= ~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 (~VAR[divider][1] /= 0) else (others => 'X') -- pragma translate_on ; ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0)); end block; -- divInt# end - BlackBox: name: GHC.Classes.modInt# kind: Expression type: 'modInt# :: Int# -> Int# -> Int#' template: ~ARG[0] mod ~ARG[1] clash-lib-1.8.1/prims/vhdl/GHC_Int.primitives.yaml0000644000000000000000000000112007346545000020122 0ustar0000000000000000- BlackBox: name: GHC.Int.I8# kind: Expression type: 'I8# :: Int# -> Int8' template: resize(~ARG[0],8) workInfo: Never - BlackBox: name: GHC.Int.I16# kind: Expression type: 'I16# :: Int# -> Int16' template: resize(~ARG[0],16) workInfo: Never - BlackBox: name: GHC.Int.I32# kind: Expression type: 'I32# :: Int# -> Int32' template: resize(~ARG[0],32) workInfo: Never - BlackBox: name: GHC.Int.I64# kind: Expression type: 'I64# :: Int# -> Int64' template: resize(~ARG[0],64) workInfo: Never clash-lib-1.8.1/prims/vhdl/GHC_Integer_Logarithms.primitives.yaml0000644000000000000000000000055507346545000023171 0ustar0000000000000000- BlackBox: name: GHC.Integer.Logarithms.integerLogBase# kind: Expression type: 'integerLogBase# :: Integer -> Integer -> Int#' template: integer(floor(log(real(~ARG[1]),real(~ARG[0])))) warning: 'GHC.Integer.Logarithms.integerLogBase#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' clash-lib-1.8.1/prims/vhdl/GHC_Integer_Type.primitives.yaml0000644000000000000000000003436307346545000022005 0ustar0000000000000000- BlackBox: name: GHC.Integer.Type.smallInteger kind: Expression type: 'smallInteger :: Int# -> Integer' template: ~ARG[0] warning: 'GHC.Integer.Type.smallInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Integer.Type.integerToInt kind: Expression type: 'integerToInt :: Integer -> Int#' template: ~ARG[0] warning: 'GHC.Integer.Type.integerToInt: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Integer.Type.timesInteger kind: Expression type: 'timesInteger :: Integer -> Integer -> Integer' template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) warning: 'GHC.Integer.Type.timesInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.negateInteger kind: Expression type: 'negateInteger :: Integer -> Integer' template: -~ARG[0] warning: 'GHC.Integer.Type.negateInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.absInteger kind: Expression type: 'absInteger :: Integer -> Integer' template: abs ~ARG[0] warning: 'GHC.Integer.Type.absInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.divInteger kind: Declaration type: 'divInteger :: Integer -> Integer -> Integer' template: |- -- divInteger begin ~GENSYM[divInteger][0] : block 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] <= ~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 (~VAR[divider][1] /= 0) else (others => 'X') -- pragma translate_on ; ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0)); end block; -- divInteger end warning: 'GHC.Integer.Type.divInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.modInteger kind: Expression type: 'modInteger :: Integer -> Integer -> Integer' template: ~ARG[0] mod ~ARG[1] warning: 'GHC.Integer.Type.modInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.divModInteger kind: Declaration type: 'divModInteger :: Integer -> Integer -> (# Integer, Integer #)' template: |- -- divModInteger begin ~GENSYM[divModInteger][0] : block signal ~GENSYM[resultPos][1] : boolean; signal ~GENSYM[dividerNeg][2] : boolean; signal ~GENSYM[dividend2][3] : signed(~SIZE[~TYP[0]] downto 0); signal ~GENSYM[quot_res][4] : signed(~SIZE[~TYP[0]] downto 0); signal ~GENSYM[div_res][5] : signed(~SIZE[~TYP[0]]-1 downto 0); signal ~GENSYM[mod_res][6] : signed(~SIZE[~TYP[0]]-1 downto 0); begin ~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[~TYP[0]]+1) when ~SYM[1] else (resize(~VAR[dividend][0],~SIZE[~TYP[0]]+1) - resize(~VAR[divider][1],~SIZE[~TYP[0]]+1) - 1) when ~SYM[2] else (resize(~VAR[dividend][0],~SIZE[~TYP[0]]+1) - resize(~VAR[divider][1],~SIZE[~TYP[0]]+1) + 1); ~SYM[4] <= ~SYM[3] / ~VAR[divider][1] -- pragma translate_off when (~VAR[divider][1] /= 0) else (others => 'X') -- pragma translate_on ; ~SYM[5] <= signed(~SYM[4](~SIZE[~TYP[0]]-1 downto 0)); ~SYM[6] <= ~VAR[dividend][0] mod ~VAR[divider][1] -- pragma translate_off when (~VAR[divider][1] /= 0) else (others => 'X') -- pragma translate_on ; ~RESULT <= (~SYM[5], ~SYM[6]); end block; -- divModInteger end warning: 'GHC.Integer.Type.divModInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.quotRemInteger kind: Declaration type: 'quotRemInteger :: Integer -> Integer -> (# Integer, Integer #)' 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 ; warning: 'GHC.Integer.Type.quotRemInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.remInteger kind: Declaration type: 'remInteger :: Integer -> Integer -> Integer' template: |- ~RESULT <= ~ARG[0] rem ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; warning: 'GHC.Integer.Type.remInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.eqInteger kind: Expression type: 'eqInteger :: Integer -> Integer -> Bool' template: ~ARG[0] = ~ARG[1] warning: 'GHC.Integer.Type.eqInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.neqInteger kind: Expression type: 'neqInteger :: Integer -> Integer -> Bool' template: ~ARG[0] /= ~ARG[1] warning: 'GHC.Integer.Type.neqInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.eqInteger# kind: Declaration type: 'eqInteger# :: Integer -> Integer -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); warning: 'GHC.Integer.Type.eqInteger#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.neqInteger# kind: Declaration type: 'neqInteger# :: Integer -> Integer -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); warning: 'GHC.Integer.Type.neqInteger#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.leInteger# kind: Declaration type: 'leInteger# :: Integer -> Integer -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); warning: 'GHC.Integer.Type.leInteger#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.gtInteger# kind: Declaration type: 'gtInteger# :: Integer -> Integer -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); warning: 'GHC.Integer.Type.gtInteger#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.ltInteger# kind: Declaration type: 'ltInteger# :: Integer -> Integer -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); warning: 'GHC.Integer.Type.ltInteger#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.geInteger# kind: Declaration type: 'geInteger# :: Integer -> Integer -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); warning: 'GHC.Integer.Type.geInteger#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.shiftRInteger kind: Declaration type: 'shiftRInteger :: Integer -> Int# -> Integer' 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; warning: 'GHC.Integer.Type.shiftRInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.shiftLInteger kind: Declaration type: 'shiftLInteger :: Integer -> Int# -> Integer' 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; warning: 'GHC.Integer.Type.shiftLInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.testBitInteger kind: Expression type: 'testBitInteger :: Integer -> Int# -> Bool' template: ~VAR[input][0](to_integer(~ARG[1])) = '1' warning: 'GHC.Integer.Type.testBitInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.wordToInteger kind: Expression type: 'wordToInteger :: Word# -> Integer' template: signed(std_logic_vector(~ARG[0])) warning: 'GHC.Integer.Type.wordToInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Integer.Type.integerToWord kind: Expression type: 'integerToWord :: Integer -> Word#' template: unsigned(std_logic_vector(~ARG[0])) warning: 'GHC.Integer.Type.integerToWord: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Integer.Type.integerToWord64 comment: only used by 32 bit GHC kind: Expression type: 'integerToWord :: Integer -> Word64#' template: unsigned(std_logic_vector(~ARG[0])) warning: 'GHC.Integer.Type.integerToWord64: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Integer.Type.bitInteger kind: Expression type: 'bitInteger :: Int -> Integer' template: shift_left(to_signed(1, ~SIZE[~TYPO]),to_integer(~ARG[0])) warning: 'GHC.Integer.Type.bitInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.complementInteger kind: Expression type: 'complementInteger :: Integer -> Integer' template: not ~ARG[0] warning: 'GHC.Integer.Type.complementInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.xorInteger kind: Expression type: 'xorInteger :: Integer -> Integer -> Integer' template: ~ARG[0] xor ~ARG[1] warning: 'GHC.Integer.Type.xorInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.orInteger kind: Expression type: 'orInteger :: Integer -> Integer -> Integer' template: ~ARG[0] or ~ARG[1] warning: 'GHC.Integer.Type.orInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.andInteger kind: Expression type: 'andInteger :: Integer -> Integer -> Integer' template: ~ARG[0] and ~ARG[1] warning: 'GHC.Integer.Type.andInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.$wsignumInteger kind: Declaration type: '$wsignumInteger :: Integer -> Integer' template: |2 -- begin signumInteger ~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 signumInteger warning: 'GHC.Integer.Type.$wsignumInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Integer.Type.quotInteger kind: Declaration type: 'quotInteger :: Integer -> Integer -> Integer' template: |- ~RESULT <= ~ARG[0] / ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; warning: 'GHC.Integer.Type.quotInteger: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' clash-lib-1.8.1/prims/vhdl/GHC_Natural.primitives.yaml0000644000000000000000000000204007346545000021000 0ustar0000000000000000- BlackBox: name: GHC.Natural.naturalFromInteger kind: Expression type: 'naturalFromInteger :: Integer -> Natural' template: resize(unsigned(std_logic_vector(~ARG[0])),~SIZE[~TYPO]) warning: 'GHC.Natural.naturalFromInteger: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Natural.timesNatural kind: Expression type: 'timesNatural :: Natural -> Natural -> Natural' template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) warning: 'GHC.Natural.timesNatural: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Natural.wordToNatural# kind: Expression type: 'wordToNatural# :: Word# -> Natural' template: unsigned(std_logic_vector(~ARG[0])) warning: 'GHC.Natural.wordToNatural#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never clash-lib-1.8.1/prims/vhdl/GHC_Num_Integer.primitives.yaml0000644000000000000000000004235107346545000021617 0ustar0000000000000000- BlackBox: name: GHC.Num.Integer.integerToNatural kind: Expression type: 'integerToNatural :: Integer -> Natural' template: resize(unsigned(std_logic_vector(~ARG[0])),~SIZE[~TYPO]) warning: 'GHC.Num.Integer.integerToNatural: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Integer.integerToNaturalThrow kind: Declaration type: 'integerToNaturalThrow :: Integer -> Natural' template: |- -- integerToNaturalThrow begin ~RESULT <= ~ERRORO when ~ARG[0] < ~SIZE[~TYP[0]]'d0 else resize(unsigned(std_logic_vector(~ARG[0])),~SIZE[~TYPO]); -- integerToNaturalThrow end warning: 'GHC.Num.Integer.integerToNaturalThrow: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Integer.integerToNaturalClamp kind: Declaration type: 'integerToNatural :: Integer -> Natural' template: |- -- integerToNaturalClamp begin ~RESULT <= to_unsigned(0,~SIZE[~TYPO]]) when ~ARG[0] < ~SIZE[~TYP[0]]'d0 else resize(unsigned(std_logic_vector(~ARG[0])),~SIZE[~TYPO]); -- integerToNaturalClamp end warning: 'GHC.Num.Integer.integerToNaturalClamp: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Integer.integerToInt# kind: Expression type: 'integerToInt :: Integer -> Int#' template: ~ARG[0] warning: 'GHC.Num.Integer.integerToInt#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Integer.integerMul kind: Expression type: 'integerMul :: Integer -> Integer -> Integer' template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) warning: 'GHC.Num.Integer.integerMul: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerNegate kind: Expression type: 'integerNegate :: Integer -> Integer' template: -~ARG[0] warning: 'GHC.Num.Integer.integerNegate: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerAbs kind: Expression type: 'integerAbs :: Integer -> Integer' template: abs ~ARG[0] warning: 'GHC.Num.Integer.integerAbs: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerDiv kind: Declaration type: 'integerDiv :: Integer -> Integer -> Integer' template: |- -- integerDiv begin ~GENSYM[integerDiv][0] : block 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] <= ~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 (~VAR[divider][1] /= 0) else (others => 'X') -- pragma translate_on ; ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0)); end block; -- integerDiv end warning: 'GHC.Num.Integer.integerDiv: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerMod kind: Expression type: 'integerMod :: Integer -> Integer -> Integer' template: ~ARG[0] mod ~ARG[1] warning: 'GHC.Num.Integer.integerMod: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerDivMod# kind: Declaration type: 'integerDivMod :: Integer -> Integer -> (# Integer, Integer #)' template: |- -- integerDivMod begin ~GENSYM[integerDivMod][0] : block signal ~GENSYM[resultPos][1] : boolean; signal ~GENSYM[dividerNeg][2] : boolean; signal ~GENSYM[dividend2][3] : signed(~SIZE[~TYP[0]] downto 0); signal ~GENSYM[quot_res][4] : signed(~SIZE[~TYP[0]] downto 0); signal ~GENSYM[div_res][5] : signed(~SIZE[~TYP[0]]-1 downto 0); signal ~GENSYM[mod_res][6] : signed(~SIZE[~TYP[0]]-1 downto 0); begin ~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[~TYP[0]]+1) when ~SYM[1] else (resize(~VAR[dividend][0],~SIZE[~TYP[0]]+1) - resize(~VAR[divider][1],~SIZE[~TYP[0]]+1) - 1) when ~SYM[2] else (resize(~VAR[dividend][0],~SIZE[~TYP[0]]+1) - resize(~VAR[divider][1],~SIZE[~TYP[0]]+1) + 1); ~SYM[4] <= ~SYM[3] / ~VAR[divider][1] -- pragma translate_off when (~VAR[divider][1] /= 0) else (others => 'X') -- pragma translate_on ; ~SYM[5] <= signed(~SYM[4](~SIZE[~TYP[0]]-1 downto 0)); ~SYM[6] <= ~VAR[dividend][0] mod ~VAR[divider][1] -- pragma translate_off when (~VAR[divider][1] /= 0) else (others => 'X') -- pragma translate_on ; ~RESULT <= (~SYM[5], ~SYM[6]); end block; -- integerDivMod end warning: 'GHC.Num.Integer.integerDivMod#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerQuotRem# kind: Declaration type: 'integerQuotRem :: Integer -> Integer -> (# Integer, Integer #)' 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 ; warning: 'GHC.Num.Integer.integerQuotRem#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerRem kind: Declaration type: 'integerRem :: Integer -> Integer -> Integer' template: |- ~RESULT <= ~ARG[0] rem ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; warning: 'GHC.Num.Integer.integerRem: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerEq kind: Expression type: 'integerEq :: Integer -> Integer -> Bool' template: ~ARG[0] = ~ARG[1] warning: 'GHC.Num.Integer.integerEq: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerNe kind: Expression type: 'integerNe :: Integer -> Integer -> Bool' template: ~ARG[0] /= ~ARG[1] warning: 'GHC.Num.Integer.integerNe: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerEq# kind: Declaration type: 'integerEq# :: Integer -> Integer -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); warning: 'GHC.Num.Integer.integerEq#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerNe# kind: Declaration type: 'integerNe# :: Integer -> Integer -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); warning: 'GHC.Num.Integer.integerNe#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerLe# kind: Declaration type: 'integerLe# :: Integer -> Integer -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); warning: 'GHC.Num.Integer.integerLe#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerGt# kind: Declaration type: 'integerGt# :: Integer -> Integer -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); warning: 'GHC.Num.Integer.integerGt#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerLt# kind: Declaration type: 'integerLt# :: Integer -> Integer -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); warning: 'GHC.Num.Integer.integerLt#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerGe# kind: Declaration type: 'integerGe# :: Integer -> Integer -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); warning: 'GHC.Num.Integer.integerGe#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerShiftR# kind: Declaration type: 'integerShiftR# :: Integer -> Word# -> Integer' 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]); end block; warning: 'GHC.Num.Integer.integerShiftR#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerShiftL# kind: Declaration type: 'integerShiftL# :: Integer -> Word# -> Integer' 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]); end block; warning: 'GHC.Num.Integer.integerShiftL#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerTestBit# kind: Expression type: 'integerTestBit :: Integer -> Word# -> Bool' template: ~VAR[input][0](to_integer(~ARG[1])) = '1' warning: 'GHC.Num.Integer.integerTestBit#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerFromWord# kind: Expression type: 'integerFromWord :: Word# -> Integer' template: signed(std_logic_vector(~ARG[0])) warning: 'GHC.Num.Integer.integerFromWord#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Integer.integerToWord# kind: Expression type: 'integerToWord :: Integer -> Word#' template: unsigned(std_logic_vector(~ARG[0])) warning: 'GHC.Num.Integer.integerToWord#: Integers are dynamically sized in simulation, 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 type: 'integerToWord :: Integer -> Word64#' template: unsigned(std_logic_vector(~ARG[0])) warning: 'GHC.Num.Integer.integerToWord64#: Integers are dynamically sized in 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# -> Integer' template: shift_left(to_signed(1, ~SIZE[~TYPO]),to_integer(~ARG[0])) warning: 'GHC.Num.Integer.integerBit#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerComplement kind: Expression type: 'integerComplement :: Integer -> Integer' template: not ~ARG[0] warning: 'GHC.Num.Integer.integerComplement: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerXor kind: Expression type: 'integerXor :: Integer -> Integer -> Integer' template: ~ARG[0] xor ~ARG[1] warning: 'GHC.Num.Integer.integerXor: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerOr kind: Expression type: 'integerOr :: Integer -> Integer -> Integer' template: ~ARG[0] or ~ARG[1] warning: 'GHC.Num.Integer.integerOr: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerAnd kind: Expression type: 'integerAnd :: Integer -> Integer -> Integer' template: ~ARG[0] and ~ARG[1] warning: 'GHC.Num.Integer.integerAnd: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerSignum kind: Declaration type: 'integerSignum :: Integer -> Integer' template: |2 -- 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 integerSignum warning: 'GHC.Num.Integer.integerSignum: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.$wintegerSignum kind: Declaration type: '$wsignumInteger :: Integer -> Int#' template: |2 -- begin signumInteger ~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 signumInteger warning: 'GHC.Num.Integer.$wintegerSignum: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerLogBase# kind: Expression type: 'integerLogBase# :: Integer -> Integer -> Int#' template: integer(floor(log(real(~ARG[1]),real(~ARG[0])))) warning: 'GHC.Num.Integer.integerLogBase#: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerCompare kind: Declaration type: 'integerCompare :: Integer -> Integer -> Ordering' template: |2 -- begin integerCompare ~RESULT <= "00" when ~ARG[0] < ~ARG[1] else "01" when ~ARG[0] = ~ARG[1] else "10"; -- end integerCompare warning: 'GHC.Num.Integer.integerCompare: Integers are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Integer.integerQuot kind: Declaration type: 'integerQuot :: Integer -> Integer -> Integer' template: |- ~RESULT <= ~ARG[0] / ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; 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 clash-lib-1.8.1/prims/vhdl/GHC_Num_Natural.primitives.yaml0000644000000000000000000001360307346545000021626 0ustar0000000000000000- BlackBox: name: GHC.Num.Natural.naturalMul kind: Expression type: 'timesNatural :: Natural -> Natural -> Natural' template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) warning: 'GHC.Num.Natural.timesNatural: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalFromWord# kind: Expression type: 'naturalFromWord# :: Word# -> Natural' template: unsigned(std_logic_vector(~ARG[0])) warning: 'GHC.Num.Natural.naturalFromWord#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' workInfo: Never - BlackBox: name: GHC.Num.Natural.naturalRem kind: Declaration type: 'naturalRem :: Natural -> Natural -> Natural' template: |- ~RESULT <= ~ARG[0] rem ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; warning: 'GHC.Num.Natural.naturalRem: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalLogBase# kind: Expression type: 'naturalLogBase# :: Natural -> Natural -> Word#' template: to_unsigned(integer(floor(log(real(to_integer(~ARG[1])),real(to_integer(~ARG[0]))))),~SIZE[~TYPO]) warning: 'GHC.Num.Natural.naturalLogBase#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalEq# kind: Declaration type: 'naturalEq# :: Natural -> Natural -> Int#' template: ~RESULT <= to_unsigned(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_unsigned(0,~SIZE[~TYPO]); warning: 'GHC.Num.Natural.naturalEq#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalNe# kind: Declaration type: 'naturalNe# :: Natural -> Natural -> Int#' template: ~RESULT <= to_unsigned(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_unsigned(0,~SIZE[~TYPO]); warning: 'GHC.Num.Natural.naturalNe#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalLe# kind: Declaration type: 'naturalLe# :: Natural -> Natural -> Int#' template: ~RESULT <= to_unsigned(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_unsigned(0,~SIZE[~TYPO]); warning: 'GHC.Num.Natural.naturalLe#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalGt# kind: Declaration type: 'naturalGt# :: Natural -> Natural -> Int#' template: ~RESULT <= to_unsigned(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_unsigned(0,~SIZE[~TYPO]); warning: 'GHC.Num.Natural.naturalGt#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalLt# kind: Declaration type: 'naturalLt# :: Natural -> Natural -> Int#' template: ~RESULT <= to_unsigned(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_unsigned(0,~SIZE[~TYPO]); warning: 'GHC.Num.Natural.naturalLt#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalGe# kind: Declaration type: 'naturalGe# :: Natural -> Natural -> Int#' template: ~RESULT <= to_unsigned(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_unsigned(0,~SIZE[~TYPO]); warning: 'GHC.Num.Natural.naturalGe#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalShiftL# kind: Declaration type: 'naturalShiftL# :: Natural -> Word# -> Natural' 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]); end block; warning: 'GHC.Num.Natural.naturalShiftL#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalShiftR# kind: Declaration type: 'naturalShiftR# :: Natural -> Word# -> Natural' 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]); end block; warning: 'GHC.Num.Natural.naturalShiftR#: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' - BlackBox: name: GHC.Num.Natural.naturalCompare kind: Declaration type: 'naturalCompare :: Natural -> Natural -> Ordering' template: |- -- begin naturalCompare ~RESULT <= "00" when ~ARG[0] < ~ARG[1] else "01" when ~ARG[0] = ~ARG[1] else "10"; -- end naturalCompare - BlackBox: name: GHC.Num.Natural.naturalQuot kind: Declaration type: 'naturalQuot :: Natural -> Natural -> Natural' template: |- ~RESULT <= ~ARG[0] / ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; warning: 'GHC.Num.Natural.naturalQuot: Naturals are dynamically sized in simulation, but fixed-length after synthesis. Use carefully.' clash-lib-1.8.1/prims/vhdl/GHC_Prim.primitives.yaml0000644000000000000000000023003607346545000020311 0ustar0000000000000000- BlackBox: name: GHC.Prim.gtChar# kind: Declaration type: 'gtChar# :: Char# -> Char# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.geChar# kind: Declaration type: 'geChar# :: Char# -> Char# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.eqChar# kind: Declaration type: 'eqChar# :: Char# -> Char# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.neChar# kind: Declaration type: 'neChar# :: Char# -> Char# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.ltChar# kind: Declaration type: 'ltChar# :: Char# -> Char# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.leChar# kind: Declaration type: 'leChar# :: Char# -> Char# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.ord# kind: Expression type: 'ord# :: Char# -> Int#' template: signed(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO]))) - BlackBox: name: GHC.Prim.*# kind: Expression type: '(*#) :: Int# -> Int# -> Int#' template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) - BlackBox: name: GHC.Prim.remInt# kind: Declaration type: 'remInt# :: Int# -> Int# -> Int#' template: |- ~RESULT <= ~ARG[0] rem ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; - BlackBox: name: GHC.Prim.quotRemInt# kind: Declaration type: 'quotRemInt# :: Int# -> Int# -> (#Int#, Int##)' template: |2- ~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.andI# kind: Expression type: 'and# :: Int# -> Int# -> Int#' template: ~ARG[0] and ~ARG[1] - BlackBox: name: GHC.Prim.orI# kind: Expression type: 'or# :: Int# -> Int# -> Int#' template: ~ARG[0] or ~ARG[1] - BlackBox: name: GHC.Prim.xorI# kind: Expression type: 'xor# :: Int# -> Int# -> Int#' template: ~ARG[0] xor ~ARG[1] - BlackBox: name: GHC.Prim.notI# kind: Expression type: 'not# :: Int# -> Int#' template: not ~ARG[0] - BlackBox: name: GHC.Prim.negateInt# kind: Expression type: 'negateInt# :: Int# -> Int#' template: -~ARG[0] - BlackBox: name: GHC.Prim.># kind: Declaration type: '(>#) :: Int# -> Int# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.>=# kind: Declaration type: '(>=#) :: Int# -> Int# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.==# kind: Declaration type: '(==) :: Int# -> Int# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim./=# kind: Declaration type: '(/=#) :: Int# -> Int# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.<# kind: Declaration type: '(<#) :: Int# -> Int# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.<=# kind: Declaration type: '(<=#) :: Int# -> Int# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.chr# kind: Expression type: 'ord# :: Int# -> Chr#' template: resize(unsigned(std_logic_vector(~ARG[0])),21) workInfo: Never - BlackBox: name: GHC.Prim.int2Word# kind: Expression type: 'word2Int# :: Int# -> Word#' template: unsigned(std_logic_vector(~ARG[0])) workInfo: Never - BlackBox: name: GHC.Prim.uncheckedIShiftL# kind: Declaration type: 'uncheckedIShiftL# :: Int# -> Int# -> Int#' 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.uncheckedIShiftRA# kind: Declaration type: 'uncheckedIShiftRA# :: Int# -> Int# -> Int#' 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.uncheckedIShiftRL# kind: Declaration type: 'uncheckedIShiftRL# :: Int# -> Int# -> Int#' 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.timesWord# kind: Expression type: 'timesWord# :: Word# -> Word# -> Word#' template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO]) - BlackBox: name: GHC.Prim.remWord# kind: Declaration type: 'remWord# :: Word# -> Word# -> Word#' template: |- ~RESULT <= ~ARG[0] rem ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; - BlackBox: name: GHC.Prim.quotRemWord# kind: Declaration type: 'quotRemWord# :: Word# -> Word# -> (#Word#, Word##)' template: |2- ~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.and# kind: Expression type: 'and# :: Word# -> Word# -> Word#' template: ~ARG[0] and ~ARG[1] - BlackBox: name: GHC.Prim.or# kind: Expression type: 'or# :: Word# -> Word# -> Word#' template: ~ARG[0] or ~ARG[1] - BlackBox: name: GHC.Prim.xor# kind: Expression type: 'xor# :: Word# -> Word# -> Word#' template: ~ARG[0] xor ~ARG[1] - BlackBox: name: GHC.Prim.not# kind: Expression type: 'not# :: Word# -> Word#' template: not ~ARG[0] - BlackBox: name: GHC.Prim.uncheckedShiftL# kind: Declaration type: 'uncheckedShiftL# :: Word# -> Int# -> Word#' 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.uncheckedShiftRL# kind: Declaration type: 'uncheckedShiftR# :: Word# -> Int# -> Word#' 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.word2Int# kind: Expression type: 'word2Int# :: word# -> Int#' template: signed(std_logic_vector(~ARG[0])) workInfo: Never - BlackBox: name: GHC.Prim.gtWord# kind: Declaration type: 'gtWord# :: Word# -> Word# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.geWord# kind: Declaration type: 'geWord# :: Word# -> Word# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.eqWord# kind: Declaration type: 'eqWord# :: Word# -> Word# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.neWord# kind: Declaration type: 'neWord# :: Word# -> Word# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.ltWord# kind: Declaration type: 'ltWord# :: Word# -> Word# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.leWord# kind: Declaration type: 'leWord# :: Word# -> Word# -> Int#' template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]); - BlackBox: name: GHC.Prim.popCnt8# kind: Declaration type: 'popCnt8 :: Word# -> Word#' template: |- -- popCnt8 begin ~GENSYM[popCnt8][0] : block -- given a level and a depth, calculate the corresponding index into the -- intermediate array function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is begin return (2 ** levels - 2 ** depth); end function; constant ~GENSYM[width][2] : natural := 8; constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); begin -- put input into the first half of the intermediate array ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); end generate; -- Create the tree of adders ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); end generate; end generate; end generate; -- The last element of the intermediate array holds the result ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); end block; -- popCnt8 end - BlackBox: name: GHC.Prim.popCnt16# kind: Declaration type: 'popCnt16 :: Word# -> Word#' template: |- -- popCnt16 begin ~GENSYM[popCnt16][0] : block -- given a level and a depth, calculate the corresponding index into the -- intermediate array function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is begin return (2 ** levels - 2 ** depth); end function; constant ~GENSYM[width][2] : natural := 16; constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); begin -- put input into the first half of the intermediate array ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); end generate; -- Create the tree of adders ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); end generate; end generate; end generate; -- The last element of the intermediate array holds the result ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); end block; -- popCnt16 end - BlackBox: name: GHC.Prim.popCnt32# kind: Declaration type: 'popCnt32 :: Word# -> Word#' template: |- -- popCnt32 begin ~GENSYM[popCnt32][0] : block -- given a level and a depth, calculate the corresponding index into the -- intermediate array function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is begin return (2 ** levels - 2 ** depth); end function; constant ~GENSYM[width][2] : natural := 32; constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); begin -- put input into the first half of the intermediate array ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); end generate; -- Create the tree of adders ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); end generate; end generate; end generate; -- The last element of the intermediate array holds the result ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); end block; -- popCnt32 end - BlackBox: name: GHC.Prim.popCnt64# kind: Declaration type: 'popCnt64 :: Word# -> Word#' template: |- -- popCnt64 begin ~GENSYM[popCnt64][0] : block -- given a level and a depth, calculate the corresponding index into the -- intermediate array function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is begin return (2 ** levels - 2 ** depth); end function; constant ~GENSYM[width][2] : natural := 64; constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); begin -- put input into the first half of the intermediate array ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); end generate; -- Create the tree of adders ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); end generate; end generate; end generate; -- The last element of the intermediate array holds the result ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); end block; -- popCnt64 end - BlackBox: name: GHC.Prim.popCnt# kind: Declaration type: 'popCnt :: Word# -> Word#' template: |- -- popCnt begin ~GENSYM[popCnt][0] : block -- given a level and a depth, calculate the corresponding index into the -- intermediate array function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is begin return (2 ** levels - 2 ** depth); end function; constant ~GENSYM[width][2] : natural := ~SIZE[~TYPO]; constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2])))); type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0); signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2); begin -- put input into the first half of the intermediate array ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1); end generate; -- Create the tree of adders ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <= ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) + ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1); end generate; end generate; end generate; -- The last element of the intermediate array holds the result ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]); end block; -- popCnt end - BlackBox: name: GHC.Prim.clz8# kind: Declaration type: 'clz8 :: Word# -> Word#' template: |- -- clz8 begin ~GENSYM[clz8][0] : block function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is begin case a is when "00" => return "10"; when "01" => return "01"; when "10" => return "00"; when others => return "00"; end case; end function; function ~GENSYM[clzi][2] ( constant n : in natural; constant i : in unsigned) return unsigned is variable v : unsigned(i'length-1 downto 0):=i; begin if v(n-1+n)='0' then return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); else return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); end if; end function; function ~GENSYM[clz8][3] (constant v : unsigned(0 to 7)) return unsigned is variable e : unsigned(0 to 7); -- 8 variable a : unsigned(0 to 2*3-1); -- 6 begin for i in 0 to 3 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; for i in 0 to 1 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; return ~SYM[2](3,a(0 to 5)); end function; begin ~RESULT <= resize(~SYM[3](~ARG[0](7 downto 0)),~SIZE[~TYPO]); end block; -- clz8 end - BlackBox: name: GHC.Prim.clz16# kind: Declaration type: 'clz16 :: Word# -> Word#' template: |- -- clz16 begin ~GENSYM[clz16][0] : block function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is begin case a is when "00" => return "10"; when "01" => return "01"; when "10" => return "00"; when others => return "00"; end case; end function; function ~GENSYM[clzi][2] ( constant n : in natural; constant i : in unsigned) return unsigned is variable v : unsigned(i'length-1 downto 0):=i; begin if v(n-1+n)='0' then return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); else return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); end if; end function; function ~GENSYM[clz16][3] (constant v : unsigned(0 to 15)) return unsigned is variable e : unsigned(0 to 15); -- 16 variable a : unsigned(0 to 4*3-1); -- 12 variable b : unsigned(0 to 2*4-1); -- 8 begin for i in 0 to 7 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; for i in 0 to 3 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; for i in 0 to 1 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; return ~SYM[2](4,b(0 to 7)); end function; begin ~RESULT <= resize(~SYM[3](~ARG[0](15 downto 0)),~SIZE[~TYPO]); end block; -- clz16 end - BlackBox: name: GHC.Prim.clz32# kind: Declaration type: 'clz32 :: Word# -> Word#' template: |- -- clz32 begin ~GENSYM[clz32][0] : block function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is begin case a is when "00" => return "10"; when "01" => return "01"; when "10" => return "00"; when others => return "00"; end case; end function; function ~GENSYM[clzi][2] ( constant n : in natural; constant i : in unsigned) return unsigned is variable v : unsigned(i'length-1 downto 0):=i; begin if v(n-1+n)='0' then return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); else return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); end if; end function; function ~GENSYM[clz32][3] (constant v : unsigned(0 to 31)) return unsigned is variable e : unsigned(0 to 31); -- 32 variable a : unsigned(0 to 8*3-1); -- 24 variable b : unsigned(0 to 4*4-1); -- 16 variable c : unsigned(0 to 2*5-1); -- 10 begin for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; for i in 0 to 7 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; for i in 0 to 3 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; for i in 0 to 1 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; return ~SYM[2](5,c(0 to 9)); end function; begin ~RESULT <= resize(~SYM[3](~ARG[0](31 downto 0)),~SIZE[~TYPO]); end block; -- clz32 end - BlackBox: name: GHC.Prim.clz64# kind: Declaration type: 'clz64 :: Word# -> Word#' template: |- -- clz64 begin ~GENSYM[clz64][0] : block function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is begin case a is when "00" => return "10"; when "01" => return "01"; when "10" => return "00"; when others => return "00"; end case; end function; function ~GENSYM[clzi][2] ( constant n : in natural; constant i : in unsigned) return unsigned is variable v : unsigned(i'length-1 downto 0):=i; begin if v(n-1+n)='0' then return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); else return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); end if; end function; function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is variable e : unsigned(0 to 63); -- 64 variable a : unsigned(0 to 16*3-1); -- 48 variable b : unsigned(0 to 8*4-1); -- 32 variable c : unsigned(0 to 4*5-1); -- 20 variable d : unsigned(0 to 2*6-1); -- 12 begin for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; for i in 0 to 7 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; for i in 0 to 3 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; for i in 0 to 1 loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop; return ~SYM[2](6,d(0 to 11)); end function; begin ~RESULT <= resize(~SYM[3](~ARG[0]),~SIZE[~TYPO]); end block; -- clz64 end - BlackBox: name: GHC.Prim.clz# kind: Declaration type: 'clz :: Word# -> Word#' template: |- -- clz begin ~GENSYM[clz][0] : block function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is begin case a is when "00" => return "10"; when "01" => return "01"; when "10" => return "00"; when others => return "00"; end case; end function; function ~GENSYM[clzi][2] ( constant n : in natural; constant i : in unsigned) return unsigned is variable v : unsigned(i'length-1 downto 0):=i; begin if v(n-1+n)='0' then return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); else return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); end if; end function; ~IF ~IW64 ~THEN function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is variable e : unsigned(0 to 63); -- 64 variable a : unsigned(0 to 16*3-1); -- 48 variable b : unsigned(0 to 8*4-1); -- 32 variable c : unsigned(0 to 4*5-1); -- 20 variable d : unsigned(0 to 2*6-1); -- 12 begin for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; for i in 0 to 7 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; for i in 0 to 3 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; for i in 0 to 1 loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop; return ~SYM[2](6,d(0 to 11)); end function; ~ELSE function ~GENSYM[clz32][4] (constant v : unsigned(0 to 31)) return unsigned is variable e : unsigned(0 to 31); -- 32 variable a : unsigned(0 to 8*3-1); -- 24 variable b : unsigned(0 to 4*4-1); -- 16 variable c : unsigned(0 to 2*5-1); -- 10 begin for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; for i in 0 to 7 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; for i in 0 to 3 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; for i in 0 to 1 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; return ~SYM[2](5,c(0 to 9)); end function; ~FI begin ~IF ~IW64 ~THEN ~RESULT <= resize(~SYM[3](~ARG[0]),~SIZE[~TYPO]); ~ELSE ~RESULT <= resize(~SYM[4](~ARG[0]),~SIZE[~TYPO]); ~FI end block; -- clz end - BlackBox: name: GHC.Prim.ctz8# kind: Declaration type: 'ctz8 :: Word# -> Word#' template: |- -- ctz8 begin ~GENSYM[ctz8][0] : block function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is begin case a is when "00" => return "10"; when "01" => return "01"; when "10" => return "00"; when others => return "00"; end case; end function; function ~GENSYM[clzi][2] ( constant n : in natural; constant i : in unsigned) return unsigned is variable v : unsigned(i'length-1 downto 0):=i; begin if v(n-1+n)='0' then return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); else return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); end if; end function; function ~GENSYM[clz8][3] (constant v : unsigned(0 to 7)) return unsigned is variable e : unsigned(0 to 7); -- 8 variable a : unsigned(0 to 2*3-1); -- 6 begin for i in 0 to 3 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; for i in 0 to 1 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; return ~SYM[2](3,a(0 to 5)); end function; signal ~GENSYM[w_reversed][5] : ~TYP[0]; begin ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); end generate; ~IF ~IW64 ~THEN ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 56)),~SIZE[~TYPO]); ~ELSE ~RESULT <= resize(~SYM[3](~SYM[5](31 downto 24)),~SIZE[~TYPO]); ~FI end block; -- ctz8 end - BlackBox: name: GHC.Prim.ctz16# kind: Declaration type: 'ctz16 :: Word# -> Word#' template: |- -- ctz16 begin ~GENSYM[ctz16][0] : block function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is begin case a is when "00" => return "10"; when "01" => return "01"; when "10" => return "00"; when others => return "00"; end case; end function; function ~GENSYM[clzi][2] ( constant n : in natural; constant i : in unsigned) return unsigned is variable v : unsigned(i'length-1 downto 0):=i; begin if v(n-1+n)='0' then return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); else return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); end if; end function; function ~GENSYM[clz16][3] (constant v : unsigned(0 to 15)) return unsigned is variable e : unsigned(0 to 15); -- 16 variable a : unsigned(0 to 4*3-1); -- 12 variable b : unsigned(0 to 2*4-1); -- 8 begin for i in 0 to 7 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; for i in 0 to 3 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; for i in 0 to 1 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; return ~SYM[2](4,b(0 to 7)); end function; signal ~GENSYM[w_reversed][5] : ~TYP[0]; begin ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); end generate; ~IF ~IW64 ~THEN ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 48)),~SIZE[~TYPO]); ~ELSE ~RESULT <= resize(~SYM[3](~SYM[5](31 downto 16)),~SIZE[~TYPO]); ~FI end block; -- ctz16 end - BlackBox: name: GHC.Prim.ctz32# kind: Declaration type: 'ctz32 :: Word# -> Word#' template: |- -- ctz32 begin ~GENSYM[ctz32][0] : block function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is begin case a is when "00" => return "10"; when "01" => return "01"; when "10" => return "00"; when others => return "00"; end case; end function; function ~GENSYM[clzi][2] ( constant n : in natural; constant i : in unsigned) return unsigned is variable v : unsigned(i'length-1 downto 0):=i; begin if v(n-1+n)='0' then return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); else return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); end if; end function; function ~GENSYM[clz32][3] (constant v : unsigned(0 to 31)) return unsigned is variable e : unsigned(0 to 31); -- 32 variable a : unsigned(0 to 8*3-1); -- 24 variable b : unsigned(0 to 4*4-1); -- 16 variable c : unsigned(0 to 2*5-1); -- 10 begin for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; for i in 0 to 7 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; for i in 0 to 3 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; for i in 0 to 1 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; return ~SYM[2](5,c(0 to 9)); end function; signal ~GENSYM[w_reversed][5] : ~TYP[0]; begin ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[3]); end generate; ~IF ~IW64 ~THEN ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 32)),~SIZE[~TYPO]); ~ELSE ~RESULT <= resize(~SYM[3](~SYM[5]),~SIZE[~TYPO]); ~FI end block; -- ctz32 end - BlackBox: name: GHC.Prim.ctz64# kind: Declaration type: 'ctz64 :: Word# -> Word#' template: |- -- ctz64 begin ~GENSYM[ctz64][0] : block function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is begin case a is when "00" => return "10"; when "01" => return "01"; when "10" => return "00"; when others => return "00"; end case; end function; function ~GENSYM[clzi][2] ( constant n : in natural; constant i : in unsigned) return unsigned is variable v : unsigned(i'length-1 downto 0):=i; begin if v(n-1+n)='0' then return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); else return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); end if; end function; function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is variable e : unsigned(0 to 63); -- 64 variable a : unsigned(0 to 16*3-1); -- 48 variable b : unsigned(0 to 8*4-1); -- 32 variable c : unsigned(0 to 4*5-1); -- 20 variable d : unsigned(0 to 2*6-1); -- 12 begin for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; for i in 0 to 7 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; for i in 0 to 3 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; for i in 0 to 1 loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop; return ~SYM[2](6,d(0 to 11)); end function; signal ~GENSYM[w_reversed][5] : ~TYP[0]; begin ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]); end generate; ~RESULT <= resize(~SYM[3](~SYM[5]),~SIZE[~TYPO]); end block; -- ctz64 end - BlackBox: name: GHC.Prim.ctz# kind: Declaration type: 'ctz :: Word# -> Word#' template: |- -- ctz begin ~GENSYM[ctz][0] : block function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is begin case a is when "00" => return "10"; when "01" => return "01"; when "10" => return "00"; when others => return "00"; end case; end function; function ~GENSYM[clzi][2] ( constant n : in natural; constant i : in unsigned) return unsigned is variable v : unsigned(i'length-1 downto 0):=i; begin if v(n-1+n)='0' then return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n); else return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0); end if; end function; ~IF ~IW64 ~THEN function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is variable e : unsigned(0 to 63); -- 64 variable a : unsigned(0 to 16*3-1); -- 48 variable b : unsigned(0 to 8*4-1); -- 32 variable c : unsigned(0 to 4*5-1); -- 20 variable d : unsigned(0 to 2*6-1); -- 12 begin for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; for i in 0 to 7 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; for i in 0 to 3 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; for i in 0 to 1 loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop; return ~SYM[2](6,d(0 to 11)); end function; ~ELSE function ~GENSYM[clz32][4] (constant v : unsigned(0 to 31)) return unsigned is variable e : unsigned(0 to 31); -- 32 variable a : unsigned(0 to 8*3-1); -- 24 variable b : unsigned(0 to 4*4-1); -- 16 variable c : unsigned(0 to 2*5-1); -- 10 begin for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1)); end loop; for i in 0 to 7 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop; for i in 0 to 3 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop; for i in 0 to 1 loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop; return ~SYM[2](5,c(0 to 9)); end function; ~FI signal ~GENSYM[w_reversed][6] : ~TYP[0]; begin ~GENSYM[reverse_loop][7] : for ~GENSYM[n][8] in ~VAR[w][0]'range generate ~SYM[6](~VAR[w][0]'high - ~SYM[8]) <= ~VAR[w][0](~SYM[8]); end generate; ~IF ~IW64 ~THEN ~RESULT <= resize(~SYM[3](~SYM[6]),~SIZE[~TYPO]); ~ELSE ~RESULT <= resize(~SYM[4](~SYM[6]),~SIZE[~TYPO]); ~FI end block; -- ctz end - BlackBox: name: GHC.Prim.byteSwap16# kind: Declaration type: 'byteSwap16# :: Word# -> Word#' template: |- -- byteSwap16 begin~IF ~IW64 ~THEN ~RESULT <= ~VAR[w][0](63 downto 16) & ~VAR[w][0](7 downto 0) & ~VAR[w][0](15 downto 8);~ELSE ~RESULT <= ~VAR[w][0](31 downto 16) & ~VAR[w][0](7 downto 0) & ~VAR[w][0](15 downto 8);~FI -- byteSwap16 end workInfo: Never - BlackBox: name: GHC.Prim.byteSwap32# kind: Declaration type: 'byteSwap32# :: Word# -> Word#' template: |- -- byteSwap32 begin~IF ~IW64 ~THEN ~RESULT <= ~VAR[w][0](63 downto 32) & ~VAR[w][0](7 downto 0 ) & ~VAR[w][0](15 downto 8) & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24);~ELSE ~RESULT <= ~VAR[w][0](7 downto 0 ) & ~VAR[w][0](15 downto 8) & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24);~FI -- byteSwap32 end workInfo: Never - BlackBox: name: GHC.Prim.byteSwap64# kind: Declaration type: 'byteSwap64# :: Word# -> Word#' template: |- -- byteSwap64 begin ~RESULT <= ~VAR[w][0](7 downto 0 ) & ~VAR[w][0](15 downto 8) & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24) & ~VAR[w][0](39 downto 32) & ~VAR[w][0](47 downto 40) & ~VAR[w][0](55 downto 48) & ~VAR[w][0](63 downto 56); -- byteSwap64 end workInfo: Never - BlackBox: name: GHC.Prim.byteSwap# kind: Declaration type: 'byteSwap# :: Word# -> Word#' template: |- -- byteSwap begin ~IF ~IW64 ~THEN ~RESULT <= ~VAR[w][0](7 downto 0 ) & ~VAR[w][0](15 downto 8) & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24) & ~VAR[w][0](39 downto 32) & ~VAR[w][0](47 downto 40) & ~VAR[w][0](55 downto 48) & ~VAR[w][0](63 downto 56);~ELSE ~RESULT <= ~VAR[w][0](7 downto 0 ) & ~VAR[w][0](15 downto 8) & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24);~FI -- byteSwap end workInfo: Never - BlackBox: name: GHC.Prim.narrow8Int# kind: Expression type: 'narrow8Int# :: Int# -> Int#' template: resize(~VAR[i][0](7 downto 0),~SIZE[~TYPO]) workInfo: Never - BlackBox: name: GHC.Prim.narrow16Int# kind: Expression type: 'narrow16Int# :: Int# -> Int#' template: resize(~VAR[i][0](15 downto 0),~SIZE[~TYPO]) workInfo: Never - BlackBox: name: GHC.Prim.narrow32Int# kind: Expression type: 'narrow32Int# :: Int# -> Int#' template: resize(~VAR[i][0](31 downto 0),~SIZE[~TYPO]) workInfo: Never - BlackBox: name: GHC.Prim.narrow8Word# kind: Expression type: 'narrow8Word# :: Word# -> Word#' template: resize(~VAR[w][0](7 downto 0),~SIZE[~TYPO]) workInfo: Never - BlackBox: name: GHC.Prim.narrow16Word# kind: Expression type: 'narrow16Word# :: Word# -> Word#' template: resize(~VAR[w][0](15 downto 0),~SIZE[~TYPO]) workInfo: Never - BlackBox: name: GHC.Prim.narrow32Word# kind: Expression type: 'narrow32Word# :: Word# -> Word#' template: resize(~VAR[w][0](31 downto 0),~SIZE[~TYPO]) workInfo: Never - BlackBox: name: GHC.Prim.bitReverse# kind: Declaration type: 'bitReverse# :: Word# -> Word#' template: |- -- bitReverse begin ~GENSYM[bitReverse][0] : for ~GENSYM[i][1] in 0 to ~IF ~IW64 ~THEN 63 ~ELSE 31 ~FI generate begin ~RESULT(~SYM[1]) <= ~VAR[x][0](~IF ~IW64 ~THEN 63 ~ELSE 31 ~FI-~SYM[1]); end generate; -- bitReverse end workInfo: Never - BlackBox: name: GHC.Prim.bitReverse8# kind: Declaration type: 'bitReverse8# :: Word# -> Word#' template: |- -- bitReverse8 begin ~GENSYM[bitReverse8][0] : for ~GENSYM[i][1] in 0 to 7 generate begin ~RESULT(~SYM[1]) <= ~VAR[x][0](7-~SYM[1]); end generate; -- bitReverse8 end workInfo: Never - BlackBox: name: GHC.Prim.bitReverse16# kind: Declaration type: 'bitReverse16# :: Word# -> Word#' template: |- -- bitReverse16 begin ~GENSYM[bitReverse16][0] : for ~GENSYM[i][1] in 0 to 15 generate begin ~RESULT(~SYM[1]) <= ~VAR[x][0](15-~SYM[1]); end generate; -- bitReverse16 end workInfo: Never - BlackBox: name: GHC.Prim.bitReverse32# kind: Declaration type: 'bitReverse32# :: Word# -> Word#' template: |- -- bitReverse32 begin ~GENSYM[bitReverse32][0] : for ~GENSYM[i][1] in 0 to 31 generate begin ~RESULT(~SYM[1]) <= ~VAR[x][0](31-~SYM[1]); end generate; -- bitReverse32 end workInfo: Never - BlackBox: name: GHC.Prim.bitReverse64# kind: Declaration type: 'bitReverse64# :: Word# -> Word#' template: |- -- bitReverse64 begin ~GENSYM[bitReverse64][0] : for ~GENSYM[i][1] in 0 to 63 generate begin ~RESULT(~SYM[1]) <= ~VAR[x][0](63-~SYM[1]); end generate; -- bitReverse64 end workInfo: Never - BlackBox: name: GHC.Prim.quotInt# kind: Declaration type: 'quotInt# :: Int# -> Int# -> Int#' template: |- ~RESULT <= ~ARG[0] / ~ARG[1] -- pragma translate_off when (~ARG[1] /= 0) else (others => 'X') -- pragma translate_on ; - BlackBox: name: GHC.Prim.quotWord# kind: Declaration type: 'quotWord# :: Word# -> Word# -> Word#' template: |- ~RESULT <= ~ARG[0] / ~ARG[1] -- pragma translate_off 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]); clash-lib-1.8.1/prims/vhdl/GHC_Word.primitives.yaml0000644000000000000000000000113407346545000020310 0ustar0000000000000000- BlackBox: name: GHC.Word.W8# kind: Expression type: 'W8# :: Word# -> Word8' template: resize(~ARG[0],8) workInfo: Never - BlackBox: name: GHC.Word.W16# kind: Expression type: 'W16# :: Word# -> Word16' template: resize(~ARG[0],16) workInfo: Never - BlackBox: name: GHC.Word.W32# kind: Expression type: 'W32# :: Word# -> Word32' template: resize(~ARG[0],32) workInfo: Never - BlackBox: name: GHC.Word.W64# kind: Expression type: 'W64# :: Word# -> Word64' template: resize(~ARG[0],64) workInfo: Never clash-lib-1.8.1/src/Clash/Annotations/BitRepresentation/0000755000000000000000000000000007346545000021327 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Annotations/BitRepresentation/ClashLib.hs0000644000000000000000000000344707346545000023354 0ustar0000000000000000{-| Copyright : (C) 2018, Google Inc. 2022, LUMI GUIDE FIETSDETECTIE B.V. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij Houses internal BitRepresentation code which cannot be housed in clash-prelude due to its dependencies. -} {-# LANGUAGE TemplateHaskell #-} module Clash.Annotations.BitRepresentation.ClashLib ( coreToType' , bitsToBits ) where import Clash.Annotations.BitRepresentation.Internal (Type'(..)) import qualified Clash.Annotations.BitRepresentation.Util as BitRepresentation import qualified Clash.Core.Type as C import Clash.Core.Name (nameOcc) import qualified Clash.Netlist.Types as Netlist import Clash.Util (curLoc) import qualified Data.Text as T (pack) -- Convert Core type to BitRepresentation type coreToType' :: C.Type -- ^ Type to convert to bit representation type -> Either String -- Error message Type' -- Bit representation type coreToType' (C.AppTy t1 t2) = AppTy' <$> coreToType' t1 <*> coreToType' t2 coreToType' (C.ConstTy (C.TyCon name)) = return $ ConstTy' (nameOcc name) coreToType' (C.LitTy (C.NumTy n)) = return $ LitTy' n coreToType' (C.LitTy (C.SymTy lit)) = return $ SymLitTy' (T.pack lit) coreToType' e = Left $ $(curLoc) ++ "Unexpected type: " ++ show e bitToBit :: BitRepresentation.Bit -> Netlist.Bit bitToBit BitRepresentation.H = Netlist.H bitToBit BitRepresentation.L = Netlist.L bitToBit BitRepresentation.U = Netlist.U -- | Converts a list of /BitRepresentation.Bit/s to their Netlist counterpart. bitsToBits :: [BitRepresentation.Bit] -> [Netlist.Bit] bitsToBits = map bitToBit clash-lib-1.8.1/src/Clash/Annotations/TopEntity/0000755000000000000000000000000007346545000017625 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Annotations/TopEntity/Extra.hs0000644000000000000000000000236207346545000021247 0ustar0000000000000000{-| Copyright : (C) 2017, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} {-# OPTIONS_GHC -fno-warn-orphans #-} module Clash.Annotations.TopEntity.Extra where import Clash.Annotations.TopEntity (TopEntity, PortName) import Clash.Netlist.Types (TopEntityT) import Language.Haskell.TH.Syntax (ModName, Name, NameFlavour, NameSpace, PkgName, OccName) import Data.Binary (Binary) import Data.Hashable (Hashable) import Control.DeepSeq (NFData) instance Binary TopEntityT instance Binary TopEntity instance Binary PortName instance Binary Name instance Binary OccName instance Binary NameFlavour instance Binary ModName instance Binary NameSpace instance Binary PkgName instance Hashable TopEntityT instance Hashable TopEntity instance Hashable PortName instance Hashable ModName instance Hashable Name instance Hashable NameFlavour instance Hashable NameSpace instance Hashable PkgName instance Hashable OccName instance NFData TopEntityT instance NFData TopEntity instance NFData PortName instance NFData ModName instance NFData Name instance NFData NameFlavour instance NFData NameSpace instance NFData PkgName instance NFData OccName clash-lib-1.8.1/src/Clash/0000755000000000000000000000000007346545000013371 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Backend.hs0000644000000000000000000001466307346545000015266 0ustar0000000000000000{-| 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. -} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Backend where 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 import Control.Monad.State (State) import Data.Text.Prettyprint.Doc.Extra (Doc) #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (SrcSpan) #else import SrcLoc (SrcSpan) #endif import Clash.Driver.Types (ClashOpts) import {-# SOURCE #-} Clash.Netlist.Types (Component, Declaration, Expr, HWType, Identifier, IdentifierSet, HasIdentifierSet, UsageMap) import Clash.Netlist.BlackBox.Types import Clash.Signal.Internal (VDomainConfiguration) import Clash.Annotations.Primitive (HDL) #ifdef CABAL import qualified Paths_clash_lib import qualified Data.Version #else import qualified System.FilePath #endif primsRoot :: IO FilePath #ifdef CABAL primsRoot = Paths_clash_lib.getDataFileName "prims" #else primsRoot = return ("clash-lib" System.FilePath. "prims") #endif clashVer :: String #ifdef CABAL clashVer = Data.Version.showVersion Paths_clash_lib.version #else clashVer = "development" #endif type ModName = Text -- | Is a type used for internal or external use data Usage = Internal -- ^ Internal use | External Text -- ^ External use, field indicates the library name -- | Is '-fclash-aggresive-x-optimization-blackbox' set? newtype AggressiveXOptBB = AggressiveXOptBB Bool -- | Is '-fclash-render-enums' set? newtype RenderEnums = RenderEnums Bool -- | Kind of a HDL type. Used to determine whether types need conversions in -- order to cross top entity boundaries. data HWKind = PrimitiveType -- ^ A type defined in an HDL spec. Usually types such as: bool, bit, .. | SynonymType -- ^ A user defined type that's simply a synonym for another type, very much -- like a type synonym in Haskell. As long as two synonym types refer to the -- same type, they can be used interchangeably. E.g., a subtype in VHDL. | UserType -- ^ User defined type that's not interchangeable with any others, even if -- the underlying structures are the same. Similar to an ADT in Haskell. type DomainMap = HashMap Text VDomainConfiguration emptyDomainMap :: DomainMap emptyDomainMap = empty class HasUsageMap s where usageMap :: Lens' s UsageMap class (HasUsageMap state, HasIdentifierSet state) => Backend state where -- | Initial state for state monad initBackend :: ClashOpts -> state -- | What HDL is the backend generating hdlKind :: state -> HDL -- | Location for the primitive definitions primDirs :: state -> IO [FilePath] -- | Name of backend, used for directory to put output files in. Should be -- constant function / ignore argument. name :: state -> String -- | File extension for target langauge extension :: state -> String -- | Get the set of types out of state extractTypes :: state -> HashSet HWType -- | Generate HDL for a Netlist component 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 hdlType :: Usage -> HWType -> Ap (State state) Doc -- | Query what kind of type a given HDL type is hdlHWTypeKind :: HWType -> State state HWKind -- | Convert a Netlist HWType to an HDL error value for that type hdlTypeErrValue :: HWType -> Ap (State state) Doc -- | Convert a Netlist HWType to the root of a target HDL type hdlTypeMark :: HWType -> Ap (State state) Doc -- | Create a record selector hdlRecSel :: HWType -> Int -> Ap (State state) Doc -- | Create a signal declaration from an identifier (Text) and Netlist HWType hdlSig :: LT.Text -> HWType -> Ap (State state) Doc -- | Create a generative block statement marker genStmt :: Bool -> State state Doc -- | Turn a Netlist Declaration to a HDL concurrent block inst :: Declaration -> Ap (State state) (Maybe Doc) -- | Turn a Netlist expression into a HDL expression expr :: Bool -- ^ Enclose in parentheses? -> Expr -- ^ Expr to convert -> Ap (State state) Doc -- | Bit-width of Int,Word,Integer iwWidth :: State state Int -- | Convert to a bit-vector toBV :: HWType -> LT.Text -> Ap (State state) Doc -- | Convert from a bit-vector fromBV :: HWType -> LT.Text -> Ap (State state) Doc -- | Synthesis tool we're generating HDL for hdlSyn :: State state HdlSyn -- | setModName setModName :: ModName -> state -> state -- | Set the name of the current top entity setTopName :: Identifier -> state -> state -- | Get the name of the current top entity getTopName :: State state Identifier -- | setSrcSpan setSrcSpan :: SrcSpan -> State state () -- | getSrcSpan getSrcSpan :: State state SrcSpan -- | Block of declarations blockDecl :: Identifier -> [Declaration] -> Ap (State state) Doc addIncludes :: [(String, Doc)] -> State state () addLibraries :: [LT.Text] -> State state () addImports :: [LT.Text] -> State state () addAndSetData :: FilePath -> State state String getDataFiles :: State state [(String,FilePath)] addMemoryDataFile :: (String,String) -> State state () getMemoryDataFiles :: State state [(String,String)] ifThenElseExpr :: state -> Bool -- | Whether -fclash-aggressive-x-optimization-blackboxes was set aggressiveXOptBB :: State state AggressiveXOptBB -- | Whether -fclash-no-render-enums was set renderEnums :: State state RenderEnums -- | All the domain configurations of design domainConfigurations :: State state DomainMap -- | Set the domain configurations setDomainConfigurations :: DomainMap -> state -> state clash-lib-1.8.1/src/Clash/Backend/0000755000000000000000000000000007346545000014720 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Backend/SystemVerilog.hs0000644000000000000000000017100307346545000020072 0ustar0000000000000000{-| Copyright : (C) 2015-2016, University of Twente, 2017-2018, Google Inc., 2021-2023, QBayLogic B.V., 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Generate SystemVerilog for assorted Netlist datatypes -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Backend.SystemVerilog (SystemVerilogState) where import qualified Control.Applicative as A import Control.Lens hiding (Indexed) import Control.Monad (forM,liftM,zipWithM) import Control.Monad.State (State) import Data.Bifunctor (first) import Data.Bits (Bits, testBit) import qualified Data.ByteString.Char8 as B8 import Data.Coerce (coerce) import Data.Function (on) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List (nub, nubBy) import Data.List.Extra ((<:>), zipEqual) import Data.Maybe (catMaybes,fromMaybe,mapMaybe) import Data.Monoid (Ap(Ap)) import Data.Monoid.Extra () import qualified Data.Text.Lazy as Text import qualified Data.Text as TextS import Data.Text.Prettyprint.Doc.Extra import qualified Data.Text.Prettyprint.Doc.Extra as PP import qualified System.FilePath import Clash.Annotations.Primitive (HDL (..)) import Clash.Annotations.BitRepresentation.Internal (ConstrRepr'(..), DataRepr'(..)) import Clash.Annotations.BitRepresentation.ClashLib (bitsToBits) import Clash.Annotations.BitRepresentation.Util (BitOrigin(Lit, Field), bitOrigins, bitRanges) 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, usages, _usages) import Clash.Netlist.Util import Clash.Signal.Internal (ActiveEdge (..)) import Clash.Util (SrcSpan, noSrcSpan, curLoc, makeCached, indexNote) import Clash.Util.Graph (reverseTopSort) -- | State for the 'Clash.Backend.SystemVerilog.SystemVerilogM' monad: data SystemVerilogState = SystemVerilogState { _tyCache :: HashSet HWType -- ^ Previously encountered HWTypes , _nameCache :: HashMap HWType Identifier -- ^ Cache for previously generated product type names , _genDepth :: Int -- ^ Depth of current generative block , _modNm :: ModName , _topNm :: Identifier , _idSeen :: IdentifierSet , _oports :: [Identifier] , _srcSpan :: SrcSpan , _includes :: [(String,Doc)] , _imports :: [Text.Text] , _libraries :: [Text.Text] , _dataFiles :: [(String,FilePath)] -- ^ Files to be copied: (filename, old path) , _memoryDataFiles:: [(String,String)] -- ^ Files to be stored: (filename, contents). These files are generated -- during the execution of 'genNetlist'. , _tyPkgCtx :: Bool -- ^ Are we in the context of generating the @_types@ package? , _intWidth :: Int -- ^ Int/Word/Integer bit-width , _hdlsyn :: HdlSyn , _undefValue :: Maybe (Maybe Int) , _aggressiveXOptBB_ :: AggressiveXOptBB , _renderEnums_ :: RenderEnums , _domainConfigurations_ :: DomainMap , _usages :: UsageMap } makeLenses ''SystemVerilogState instance HasIdentifierSet SystemVerilogState where identifierSet = idSeen instance HasUsageMap SystemVerilogState where usageMap = usages instance Backend SystemVerilogState where initBackend opts = SystemVerilogState { _tyCache=HashSet.empty , _nameCache=HashMap.empty , _genDepth=0 , _modNm="" , _topNm=Id.unsafeMake "" , _idSeen=Id.emptyIdentifierSet (opt_escapedIds opts) (opt_lowerCaseBasicIds opts) SystemVerilog , _oports=[] , _srcSpan=noSrcSpan , _includes=[] , _imports=[] , _libraries=[] , _dataFiles=[] , _memoryDataFiles=[] , _tyPkgCtx=False , _intWidth=opt_intWidth opts , _hdlsyn=opt_hdlSyn opts , _undefValue=opt_forceUndefined opts , _aggressiveXOptBB_=coerce (opt_aggressiveXOptBB opts) , _renderEnums_=coerce (opt_renderEnums opts) , _domainConfigurations_=emptyDomainMap , _usages=mempty } hdlKind = const SystemVerilog primDirs = const $ do root <- primsRoot return [ root System.FilePath. "common" , root System.FilePath. "commonverilog" , root System.FilePath. "systemverilog" ] extractTypes = _tyCache name = const "systemverilog" extension = const ".sv" genHDL = genSystemVerilog mkTyPackage = mkTyPackage_ hdlHWTypeKind = \case Vector {} -> pure UserType RTree {} -> pure UserType Product {} -> pure UserType MemBlob {} -> pure UserType BiDirectional _ ty -> hdlHWTypeKind ty Annotated _ ty -> hdlHWTypeKind ty _ -> pure PrimitiveType hdlType _ = verilogType hdlTypeErrValue = verilogTypeErrValue hdlTypeMark = verilogTypeMark hdlRecSel = verilogRecSel hdlSig t ty = sigDecl (string t) ty genStmt True = do cnt <- use genDepth genDepth += 1 if cnt > 0 then emptyDoc else "generate" genStmt False = do genDepth -= 1 cnt <- use genDepth if cnt > 0 then emptyDoc else "endgenerate" inst = inst_ expr = expr_ iwWidth = use intWidth toBV hty id_ = toSLV hty (Identifier (Id.unsafeMake (Text.toStrict id_)) Nothing) fromBV hty id_ = simpleFromSLV hty (Text.toStrict id_) hdlSyn = use hdlsyn setModName nm s = s {_modNm = nm} setTopName nm s = s {_topNm = nm} getTopName = use topNm setSrcSpan = (srcSpan .=) getSrcSpan = use srcSpan blockDecl _ ds = do decs <- decls ds if isEmpty decs then insts ds else pure decs <> line <> insts ds addIncludes inc = includes %= (inc++) addLibraries libs = libraries %= (libs ++) addImports inps = imports %= (inps ++) addAndSetData f = do fs <- use dataFiles let (fs',f') = renderFilePath fs f dataFiles .= fs' return f' getDataFiles = use dataFiles addMemoryDataFile f = memoryDataFiles %= (f:) getMemoryDataFiles = use memoryDataFiles ifThenElseExpr _ = True aggressiveXOptBB = use aggressiveXOptBB_ renderEnums = use renderEnums_ domainConfigurations = use domainConfigurations_ setDomainConfigurations confs s = s {_domainConfigurations_ = confs} type SystemVerilogM a = Ap (State SystemVerilogState) a -- | Generate SystemVerilog for a Netlist component genSystemVerilog :: ClashOpts -> ModName -> SrcSpan -> IdentifierSet -> UsageMap -> Component -> SystemVerilogM ((String, Doc), [(String, Doc)]) 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 $ do idSeen %= Id.union seen usages .= us 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 <> "*/" 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)] mkTyPackage_ modName hwtys = do Ap (tyPkgCtx .= True) normTys <- nub <$> mapM (normaliseType) (hwtys ++ usedTys) let needsDec = nubBy eqReprTy $ normTys hwTysSorted = topSortHWTys needsDec packageDec = vcat $ fmap catMaybes $ mapM tyDec hwTysSorted funDecs = vcat $ fmap catMaybes $ mapM funDec hwTysSorted pkg <- (:[]) A.<$> (TextS.unpack modName ++ "_types",) A.<$> "package" <+> modNameD <> "_types" <> semi <> line <> indent 2 packageDec <> line <> indent 2 funDecs <> line <> "endpackage" <+> colon <+> modNameD <> "_types" Ap (tyPkgCtx .= False) return pkg where modNameD = stringS modName usedTys = concatMap mkUsedTys hwtys eqReprTy :: HWType -> HWType -> Bool eqReprTy (Vector n ty1) (Vector m ty2) | m == n = eqReprTy ty1 ty2 | otherwise = False eqReprTy (RTree n ty1) (RTree m ty2) | m == n = eqReprTy ty1 ty2 | otherwise = False eqReprTy Bit ty2 = ty2 `elem` [Bit,Bool] eqReprTy Bool ty2 = ty2 `elem` [Bit,Bool] eqReprTy ty1 ty2 | isUnsigned ty1 && isUnsigned ty2 = typeSize ty1 == typeSize ty2 | otherwise = ty1 == ty2 isUnsigned :: HWType -> Bool isUnsigned (Unsigned _) = True isUnsigned (BitVector _) = True isUnsigned (Index _) = True isUnsigned (Sum _ _) = True isUnsigned (CustomSum _ _ _ _) = True isUnsigned (SP _ _) = True isUnsigned (CustomSP _ _ _ _) = True isUnsigned _ = False mkUsedTys :: HWType -> [HWType] mkUsedTys v@(Vector _ elTy) = v : mkUsedTys elTy mkUsedTys t@(RTree _ elTy) = t : mkUsedTys elTy mkUsedTys p@(Product _ _ elTys) = p : concatMap mkUsedTys elTys mkUsedTys sp@(SP _ elTys) = sp : concatMap mkUsedTys (concatMap snd elTys) mkUsedTys t = [t] topSortHWTys :: [HWType] -> [HWType] topSortHWTys hwtys = sorted where nodes = zip [0..] hwtys nodesI = HashMap.fromList (zip hwtys [0..]) edges = concatMap edge hwtys sorted = case reverseTopSort nodes edges of Left err -> error ("[BUG IN CLASH] topSortHWTys: " ++ err) Right ns -> ns edge t@(Vector _ elTy) = maybe [] ((:[]) . (HashMap.lookupDefault (error $ $(curLoc) ++ "Vector") t nodesI,)) (HashMap.lookup elTy nodesI) edge t@(RTree _ elTy) = maybe [] ((:[]) . (HashMap.lookupDefault (error $ $(curLoc) ++ "RTree") t nodesI,)) (HashMap.lookup elTy nodesI) edge t@(Product _ _ tys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "Product") t nodesI in mapMaybe (\ty -> liftM (ti,) (HashMap.lookup ty nodesI)) tys edge t@(SP _ ctys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "SP") t nodesI in concatMap (\(_,tys) -> mapMaybe (\ty -> liftM (ti,) (HashMap.lookup ty nodesI)) tys) ctys edge _ = [] normaliseType :: HWType -> SystemVerilogM HWType normaliseType (Annotated _ ty) = normaliseType ty normaliseType (Vector n ty) = Vector n <$> (normaliseType ty) normaliseType (MemBlob n m) = return (Vector n (BitVector m)) normaliseType (RTree d ty) = RTree d <$> (normaliseType ty) normaliseType (Product nm lbls tys) = Product nm lbls <$> (mapM normaliseType tys) normaliseType ty@(SP _ elTys) = do Ap $ mapM_ ((tyCache %=) . HashSet.insert) (concatMap snd elTys) return (BitVector (typeSize ty)) normaliseType (CustomSP _ _dataRepr size elTys) = do Ap $ mapM_ ((tyCache %=) . HashSet.insert) [ty | (_, _, subTys) <- elTys, ty <- subTys] return (BitVector size) normaliseType ty@(Index _) = return (Unsigned (typeSize ty)) 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 normaliseType ty = return ty range :: Either Int Int -> SystemVerilogM Doc range (Left n) = brackets (int (n-1) <> colon <> int 0) range (Right n) = brackets (int 0 <> colon <> int (n-1)) tyDec :: HWType -> SystemVerilogM (Maybe Doc) tyDec ty@(Vector n elTy) | typeSize ty > 0 = Just A.<$> do syn <- Ap hdlSyn case syn of Vivado -> case splitVecTy ty of Just ([Right n',Left n''],elTy') -> "typedef" <+> elTy' <+> brackets (int (n''-1) <> colon <> int 0) <+> tyName ty <+> brackets (int 0 <> colon <> int (n'-1)) <> semi _ -> "typedef" <+> "logic" <+> brackets (int (typeSize elTy - 1) <> colon <> int 0) <+> tyName ty <+> brackets (int 0 <> colon <> int (n-1)) <> semi _ -> case splitVecTy ty of Just (Right n':ns,elTy') -> "typedef" <+> elTy' <+> hcat (mapM range ns) <+> tyName ty <+> brackets (int 0 <> colon <> int (n' - 1)) <> semi _ -> error $ $(curLoc) ++ "impossible" tyDec ty@(RTree n elTy) | typeSize elTy > 0 = Just A.<$> do syn <- Ap hdlSyn case syn of Vivado -> case splitVecTy ty of Just ([Right n',Left n''],elTy') -> -- n' == 2^n "typedef" <+> elTy' <+> brackets (int 0 <> colon <> int (n''-1)) <+> tyName ty <+> brackets (int 0 <> colon <> int (n'-1)) <> semi _ -> "typedef" <+> "logic" <+> brackets (int (typeSize elTy - 1) <> colon <> int 0) <+> tyName ty <+> brackets (int 0 <> colon <> int (2^n-1)) <> semi _ -> case splitVecTy ty of Just (Right n':ns,elTy') -> -- n' == 2^n "typedef" <+> elTy' <+> hcat (mapM range ns) <+> tyName ty <+> brackets (int 0 <> colon <> int (n' - 1)) <> semi _ -> error $ $(curLoc) ++ "impossible" tyDec ty@(Product _ _ tys) | typeSize ty > 0 = Just A.<$> prodDec where prodDec = "typedef struct packed {" <> line <> indent 2 (vcat $ fmap catMaybes $ zipWithM combineM selNames tys) <> line <> "}" <+> tName <> semi combineM x y = do yM <- lvType y case yM of Nothing -> pure Nothing Just y' -> Just A.<$> (pure y' <+> x <> semi) tName = tyName ty selNames = map (\i -> tName <> "_sel" <> int i) [0..] tyDec _ = pure Nothing splitVecTy :: HWType -> Maybe ([Either Int Int],SystemVerilogM Doc) splitVecTy = fmap splitElemTy . go where splitElemTy (ns,t) = case t of 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") Bit -> (ns, "logic") String -> (ns, "string") Signed n -> (ns ++ [Left n],"logic signed") _ -> (ns ++ [Left (typeSize t)], "logic") go (Vector n elTy) = case go elTy of Just (ns,elTy') -> Just (Right n:ns,elTy') _ -> Just ([Right n],elTy) go (RTree n elTy) = let n' = 2^n in case go elTy of Just (ns,elTy') -> Just (Right n':ns,elTy') _ -> Just ([Right n'],elTy) go _ = Nothing lvType :: HWType -> SystemVerilogM (Maybe Doc) lvType ty@(Vector n elTy) | typeSize ty > 0 = Just A.<$> do syn <- Ap hdlSyn case syn of Vivado -> "logic" <+> brackets (int 0 <> colon <> int (n-1)) <> brackets (int (typeSize elTy - 1) <> colon <> int 0) _ -> case splitVecTy ty of Just (ns,elTy') -> elTy' <> hcat (mapM range ns) _ -> error $ $(curLoc) ++ "impossible" lvType ty@(RTree n elTy) | typeSize elTy > 0 = Just A.<$> do syn <- Ap hdlSyn case syn of Vivado -> "logic" <+> brackets (int 0 <> colon <> int (2^n-1)) <> brackets (int (typeSize elTy - 1) <> colon <> int 0) _ -> case splitVecTy ty of Just (ns,elTy') -> elTy' <> hcat (mapM range ns) _ -> error $ $(curLoc) ++ "impossible" lvType ty | typeSize ty > 0 = Just A.<$> verilogType ty lvType _ = pure Nothing funDec :: HWType -> SystemVerilogM (Maybe Doc) funDec ty@(Vector n elTy) | typeSize ty > 0 = Just A.<$> "function" <+> "automatic" <+> "logic" <+> ranges <+> tName <> "_to_lv" <> parens (sigDecl "i" ty) <> semi <> line <> indent 2 ("for" <+> parens ("int n = 0" <> semi <+> "n <" <+> int n <> semi <+> "n=n+1") <> line <> indent 2 (tName <> "_to_lv" <> brackets "n" <+> "=" <+> "i[n]" <> semi)) <> line <> "endfunction" <> line <> "function" <+> "automatic" <+> tName <+> tName <> "_from_lv" <> parens ("logic" <+> ranges <+> "i") <> semi <> line <> indent 2 ("for" <+> parens ("int n = 0" <> semi <+> "n <" <+> int n <> semi <+> "n=n+1") <> line <> indent 2 (tName <> "_from_lv" <> brackets "n" <+> "=" <+> "i[n]" <> semi)) <> line <> "endfunction" <> line <> if n > 1 then "function" <+> "automatic" <+> tName <+> tName <> "_cons" <> parens (sigDecl "x" elTy <> comma <> vecSigDecl "xs") <> semi <> line <> indent 2 (tName <> "_cons" <> brackets (int 0) <+> "=" <+> (toSLV elTy (Identifier (Id.unsafeMake "x") Nothing)) <> semi <> line <> tName <> "_cons" <> brackets (int 1 <> colon <> int (n-1)) <+> "=" <+> "xs" <> semi) <> line <> "endfunction" else "function" <+> "automatic" <+> tName <+> tName <> "_cons" <> parens (sigDecl "x" elTy) <> semi <> line <> indent 2 (tName <> "_cons" <> brackets (int 0) <+> "=" <+> (toSLV elTy (Identifier (Id.unsafeMake "x") Nothing)) <> semi) <> line <> "endfunction" where tName = tyName ty ranges = brackets (int 0 <> colon <> int (n-1)) <> brackets (int (typeSize elTy - 1) <> colon <> int 0) vecSigDecl :: SystemVerilogM Doc -> SystemVerilogM Doc vecSigDecl d = do syn <- Ap hdlSyn case syn of Vivado -> case splitVecTy ty of Just ([Right n',Left n''],elTy') -> elTy' <+> brackets (int 0 <> colon <> int (n''-1)) <+> d <+> brackets (int 0 <> colon <> int (n'-2)) _ -> "logic" <+> brackets (int (typeSize elTy - 1) <> colon <> int 0) <+> d <+> brackets (int 0 <> colon <> int (n-2)) _ -> case splitVecTy ty of Just (Right n':ns,elTy') -> elTy' <+> hcat (mapM range ns) <+> d <+> brackets (int 0 <> colon <> int (n' - 2)) _ -> error $ $(curLoc) ++ "impossible" funDec ty@(RTree n elTy) | typeSize elTy > 0 = Just A.<$> "function" <+> "automatic" <+> "logic" <+> ranges <+> tName <> "_to_lv" <> parens (sigDecl "i" ty) <> semi <> line <> indent 2 ("for" <+> parens ("int n = 0" <> semi <+> "n <" <+> int (2^n) <> semi <+> "n=n+1") <> line <> indent 2 (tName <> "_to_lv" <> brackets "n" <+> "=" <+> "i[n]" <> semi)) <> line <> "endfunction" <> line <> "function" <+> "automatic" <+> tName <+> tName <> "_from_lv" <> parens ("logic" <+> ranges <+> "i") <> semi <> line <> indent 2 ("for" <+> parens ("int n = 0" <> semi <+> "n <" <+> int (2^n) <> semi <+> "n=n+1") <> line <> indent 2 (tName <> "_from_lv" <> brackets "n" <+> "=" <+> "i[n]" <> semi)) <> line <> "endfunction" <> line <> (if n > 0 then "function" <+> "automatic" <+> tName <+> tName <> "_br" <> parens (treeSigDecl "l" <> comma <> treeSigDecl "r") <> semi <> line <> indent 2 (tName <> "_br" <> brackets (int 0 <> colon <> int (2^(n-1)-1)) <+> "=" <+> "l" <> semi <> line <> tName <> "_br" <> brackets (int (2^(n-1)) <> colon <> int (2^n-1)) <+> "=" <+> "r" <> semi) <> line <> "endfunction" else emptyDoc) where treeSigDecl :: SystemVerilogM Doc -> SystemVerilogM Doc treeSigDecl d = do syn <- Ap hdlSyn case syn of Vivado -> case splitVecTy (RTree (n-1) elTy) of Just ([Right n',Left n''],elTy') -> -- n' == 2 ^ (n-1) elTy' <+> brackets (int 0 <> colon <> int (n''-1)) <+> d <+> brackets (int 0 <> colon <> int (n' - 1)) _ -> "logic" <+> brackets (int (typeSize elTy - 1) <> colon <> int 0) <+> d <+> brackets (int 0 <> colon <> int (2^(n-1)-1)) _ -> case splitVecTy (RTree (n-1) elTy) of Just (Right n':ns,elTy') -> -- n' == 2 ^ (n-1) elTy' <+> hcat (mapM range ns) <+> d <+> brackets (int 0 <> colon <> int (n' - 1)) _ -> error $ $(curLoc) ++ "impossible" tName = tyName ty ranges = brackets (int 0 <> colon <> int (2^n-1)) <> brackets (int (typeSize elTy - 1) <> colon <> int 0) funDec _ = pure Nothing module_ :: Component -> SystemVerilogM Doc module_ c = modVerilog <* Ap (imports .= [] >> oports .= []) where modVerilog = do body <- modBody imps <- Ap $ use imports libs <- Ap $ use libraries modHeader <> line <> modPorts <> line <> include (nub imps) <> uselibs (nub libs) <> pure body <> line <> modEnding modHeader = "module" <+> pretty (componentName c) modPorts = indent 4 (tupleInputs inPorts <> line <> tupleOutputs outPorts <> semi) modBody = indent 2 (decls (declarations c)) <> line <> line <> indent 2 (insts (declarations c)) modEnding = "endmodule" inPorts = sequence [ sigPort (Nothing,isBiSignalIn ty) (i,ty) Nothing | (i,ty) <- inputs 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" -- no net type here, it gets added by verilogType. | otherwise = "input wire" -- See NOTE [net types and data types] wr2ty (Just _,_) = "output" -- map a port to its verilog type, port name, and any encoding notes sigPort (wr2ty -> portTy) (nm, hwTy) iEM = addAttrs (hwTypeAttrs hwTy) (portTy <+> sigDecl (pretty nm) hwTy <> iE <+> encodingNote hwTy) where iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM -- slightly more readable than 'tupled', makes the output Haskell-y-er commafy v = (comma <> space) <> pure v tupleInputs v = v >>= \case [] -> lparen <+> string "// No inputs" <> line (x:xs) -> lparen <+> string "// Inputs" <> line <> (string " " <> pure x) <> line <> vcat (forM xs commafy) <> line tupleOutputs v = v >>= \case [] -> string " // No outputs" <> line <> rparen (x:xs) -> string " // Outputs" <> line <> (if (length (inputs c)) > 0 then comma <> space <> pure x else string " " <> pure x) <> (if null xs then emptyDoc else line <> vcat (forM xs commafy)) <> line <> rparen verilogType :: HWType -> SystemVerilogM Doc verilogType t_ = do t <- normaliseType t_ Ap (tyCache %= HashSet.insert t) let logicOrWire | isBiSignalIn t = "wire" | otherwise = "logic" pkgCtx <- Ap $ use tyPkgCtx nm <- Ap $ use modNm let pvrType = if pkgCtx then tyName t else stringS nm <> "_types::" <> tyName t case t of Product {} -> pvrType Vector {} -> pvrType RTree {} -> pvrType Signed n -> logicOrWire <+> "signed" <+> brackets (int (n-1) <> colon <> int 0) Clock _ -> "logic" ClockN _ -> "logic" Reset _ -> "logic" Enable _ -> "logic" Bit -> "logic" Bool -> "logic" String -> "string" FileType -> "integer" _ -> logicOrWire <+> brackets (int (typeSize t -1) <> colon <> int 0) sigDecl :: SystemVerilogM Doc -> HWType -> SystemVerilogM Doc sigDecl d t = verilogType t <+> d -- | Convert a Netlist HWType to the root of a Verilog type verilogTypeMark :: HWType -> SystemVerilogM Doc verilogTypeMark t_ = do t <- normaliseType t_ Ap (tyCache %= HashSet.insert t) pkgCtx <- Ap $ use tyPkgCtx nm <- Ap $ use modNm let pvrType = if pkgCtx then tyName t else stringS nm <> "_types::" <> tyName t case t of Product {} -> pvrType Vector {} -> pvrType RTree {} -> pvrType _ -> emptyDoc tyName :: HWType -> SystemVerilogM Doc tyName Bool = "logic" tyName Bit = "logic" tyName (Vector n elTy) = "array_of_" <> int n <> "_" <> tyName elTy tyName (MemBlob n m) = tyName (Vector n (BitVector m)) tyName (RTree n elTy) = "tree_of_" <> int n <> "_" <> tyName elTy tyName (BitVector n) = "logic_vector_" <> int n tyName t@(Index _) = "logic_vector_" <> int (typeSize t) tyName (Signed n) = "signed_" <> int n tyName (Unsigned n) = "logic_vector_" <> int n tyName t@(Sum _ _) = "logic_vector_" <> int (typeSize t) tyName t@(CustomSum _ _ _ _) = "logic_vector_" <> int (typeSize t) tyName t@(CustomSP _ _ _ _) = "logic_vector_" <> int (typeSize t) tyName t@(Product nm _ _) = do tN <- normaliseType t PP.pretty =<< Ap (makeCached tN nameCache prodName) where prodName :: State SystemVerilogState Identifier prodName = Id.makeBasicOr (last (TextS.splitOn "." nm)) "product" 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 -- | Convert a Netlist HWType to an error SystemVerilog value for that type verilogTypeErrValue :: HWType -> SystemVerilogM Doc verilogTypeErrValue (Vector n elTy) = do syn <- Ap hdlSyn case syn of Vivado -> char '\'' <> braces (int n <+> braces (singularErrValue elTy)) _ -> char '\'' <> braces (int n <+> braces (verilogTypeErrValue elTy)) verilogTypeErrValue (RTree n elTy) = do syn <- Ap hdlSyn case syn of Vivado -> char '\'' <> braces (int (2^n) <+> braces (singularErrValue elTy)) _ -> char '\'' <> braces (int (2^n) <+> braces (verilogTypeErrValue elTy)) verilogTypeErrValue String = "\"ERROR\"" verilogTypeErrValue ty = singularErrValue ty singularErrValue :: HWType -> SystemVerilogM Doc singularErrValue ty = do udf <- Ap (use undefValue) case udf of Nothing -> braces (int (typeSize ty) <+> braces "1'bx") Just Nothing -> int (typeSize ty) <> "'d0 /* undefined */" Just (Just x) -> braces (int (typeSize ty) <+> braces ("1'b" <> int x)) <+> "/* undefined */" verilogRecSel :: HWType -> Int -> SystemVerilogM Doc verilogRecSel ty i = tyName ty <> "_sel" <> int i decls :: [Declaration] -> SystemVerilogM Doc decls [] = emptyDoc decls ds = do dsDoc <- catMaybes A.<$> mapM decl ds case dsDoc of [] -> emptyDoc _ -> punctuate' semi (A.pure dsDoc) decl :: Declaration -> SystemVerilogM (Maybe Doc) decl (NetDecl' noteM id_ tyE iEM) = Just A.<$> maybe id addNote noteM (addAttrs attrs (typ tyE)) where typ ty = sigDecl (pretty id_) ty <> iE addNote n = mappend ("//" <+> stringS n <> line) attrs = fromMaybe [] (hwTypeAttrs A.<$> Just tyE) iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM decl _ = return Nothing -- | Convert single attribute to systemverilog syntax 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 TextS.Text] -> SystemVerilogM Doc -> SystemVerilogM Doc addAttrs [] t = t addAttrs attrs' t = "(*" <+> attrs'' <+> "*)" <+> t where attrs'' = stringS $ TextS.intercalate ", " (map renderAttr attrs') insts :: [Declaration] -> SystemVerilogM Doc insts [] = emptyDoc insts (TickDecl (Comment c):ds) = comment "//" c <> line <> insts ds insts (TickDecl (Directive d):ds) = pretty d <> ";" <> line <> insts ds insts (d:ds) = do docM <- inst_ d case docM of Nothing -> insts ds Just doc -> pure doc <> line <> line <> insts ds stdMatch :: Bits a => Int -> a -> a -> String stdMatch 0 _mask _value = [] stdMatch size mask value = symbol : stdMatch (size - 1) mask value where symbol = if testBit mask (size - 1) then if testBit value (size - 1) then '1' else '0' else '?' patLitCustom' :: Int -> ConstrRepr' -> SystemVerilogM Doc patLitCustom' size (ConstrRepr' _name _n mask value _anns) = int size <> squote <> "b" <> (string $ Text.pack $ stdMatch size mask value) patLitCustom :: HWType -> Literal -> SystemVerilogM Doc patLitCustom (CustomSum _name _dataRepr size reprs) (NumLit (fromIntegral -> i)) = patLitCustom' size (fst $ reprs !! i) patLitCustom (CustomSP _name _dataRepr size reprs) (NumLit (fromIntegral -> i)) = let (cRepr, _id, _tys) = reprs !! i in patLitCustom' size cRepr patLitCustom x y = error $ $(curLoc) ++ unwords [ "You can only pass CustomSP / CustomSum / CustomProduct and a NumLit to" , "this function, not", show x, "and", show y] patMod :: HWType -> Literal -> Literal patMod hwTy (NumLit i) = NumLit (i `mod` (2 ^ typeSize hwTy)) patMod _ l = l -- | Helper function for inst_, handling CustomSP and CustomSum inst_' :: Identifier -> Expr -> HWType -> [(Maybe Literal, Expr)] -> SystemVerilogM (Maybe Doc) inst_' id_ scrut scrutTy es = fmap Just $ "always_comb begin" <> line <> indent 2 casez <> line <> "end" where casez = "casez" <+> parens var <> line <> indent 2 (conds esNub) <> line <> "endcase" esMod = map (first (fmap (patMod scrutTy))) es esNub = nubBy ((==) `on` fst) esMod var = expr_ True scrut conds :: [(Maybe Literal,Expr)] -> SystemVerilogM Doc conds [] = error $ $(curLoc) ++ "Empty list of conditions invalid." conds [(_,e)] = "default" <+> ":" <+> pretty id_ <+> "=" <+> expr_ False e <> ";" conds ((Nothing,e):_) = "default" <+> ":" <+> pretty id_ <+> "=" <+> expr_ False e <> ";" conds ((Just c ,e):es') = mask' <+> ":" <+> pretty id_ <+> "=" <+> expr_ False e <> ";" <> line <> conds es' where mask' = patLitCustom scrutTy c -- | Turn a Netlist Declaration to a SystemVerilog concurrent block inst_ :: Declaration -> SystemVerilogM (Maybe Doc) inst_ (TickDecl {}) = return Nothing 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 { syn <- Ap hdlSyn ; p <- Ap $ use oports ; if syn == Vivado && id_ `elem` p then do { regId <- Id.suffix id_ "reg" ; verilogType ty <+> pretty regId <> semi <> line <> "always_comb begin" <> line <> indent 2 ("if" <> parens (expr_ True scrut) <> line <> (indent 2 $ pretty regId <+> equals <+> expr_ False t <> semi) <> line <> "else" <> line <> (indent 2 $ pretty regId <+> equals <+> expr_ False f <> semi)) <> line <> "end" <> line <> "assign" <+> pretty id_ <+> equals <+> pretty regId <> semi } else "always_comb begin" <> line <> indent 2 ("if" <> parens (expr_ True scrut) <> line <> (indent 2 $ pretty id_ <+> equals <+> expr_ False t <> semi) <> line <> "else" <> line <> (indent 2 $ pretty id_ <+> equals <+> expr_ False f <> semi)) <> line <> "end" } where (t,f) = if b then (l,r) else (r,l) inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSP {}) es) = inst_' id_ scrut scrutTy es inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSum {}) es) = inst_' id_ scrut scrutTy es inst_ (CondAssignment id_ _ scrut scrutTy@(CustomProduct {}) es) = inst_' id_ scrut scrutTy es inst_ (CondAssignment id_ ty scrut scrutTy es) = fmap Just $ do { syn <- Ap hdlSyn ; p <- Ap $ use oports ; if syn == Vivado && id_ `elem` p then do { regId <- Id.suffix id_ "reg" ; verilogType ty <+> pretty regId <> semi <> line <> "always_comb begin" <> line <> indent 2 ("case" <> parens (expr_ True scrut) <> line <> (indent 2 $ vcat $ punctuate semi (conds regId es)) <> semi <> line <> "endcase") <> line <> "end" <> line <> "assign" <+> pretty id_ <+> equals <+> pretty regId <> semi } else "always_comb begin" <> line <> indent 2 ("case" <> parens (expr_ True scrut) <> line <> (indent 2 $ vcat $ punctuate semi (conds id_ es)) <> semi <> line <> "endcase") <> line <> "end" } where conds :: Identifier -> [(Maybe Literal,Expr)] -> SystemVerilogM [Doc] conds _ [] = return [] conds i [(_,e)] = ("default" <+> colon <+> pretty i <+> equals <+> expr_ False e) <:> return [] conds i ((Nothing,e):_) = ("default" <+> colon <+> pretty i <+> equals <+> expr_ False e) <:> return [] conds i ((Just c ,e):es') = (exprLitSV (Just (scrutTy,conSize scrutTy)) c <+> colon <+> pretty i <+> equals <+> expr_ False e) <:> conds i es' inst_ (InstDecl _ _ attrs nm lbl ps pms0) = fmap Just $ attrs' <> nest 2 (pretty nm <> params <> pretty lbl <> line <> pms2 <> semi) where pms2 = case pms0 of NamedPortMap pms1 -> let pm i e = dot <> expr_ False i <+> parens (expr_ False e) in tupled $ sequence [pm i e | (i,_,_,e) <- pms1] IndexedPortMap pms1 -> tupled $ sequence [expr_ False e | (_,_,e) <- pms1] params | null ps = space | otherwise = line <> "#" <> tupled (sequence [dot <> expr_ False i <+> parens (expr_ False e) | (i,_,e) <- ps]) <> line attrs' | null attrs = emptyDoc | otherwise = addAttrs attrs line inst_ (BlackBoxD _ libs imps inc bs bbCtx) = fmap Just (Ap (column (renderBlackBox libs imps inc bs bbCtx))) inst_ (Seq ds) = Just <$> seqs ds inst_ (NetDecl' {}) = return Nothing 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 :: DataRepr' -- ^ Custom representation of data type -> ConstrRepr' -- ^ Custom representation of a specific constructor of @dataRepr@ -> [(HWType, Expr)] -- ^ Arguments applied to constructor -> SystemVerilogM Doc customReprDataCon dataRepr constrRepr args = braces $ hcat $ punctuate ", " $ mapM range' origins where size = drSize dataRepr -- Build bit representations for all constructor arguments argExprs = map (uncurry toSLV) args :: [SystemVerilogM Doc] -- Spread bits of constructor arguments using masks origins = bitOrigins dataRepr constrRepr :: [BitOrigin] range' :: BitOrigin -> SystemVerilogM Doc range' (Lit (bitsToBits -> ns)) = int (length ns) <> squote <> "b" <> hcat (mapM (bit_char undefValue) ns) range' (Field n start end) = -- We want to select the bits starting from 'start' downto and including -- 'end'. We cannot use slice notation in Verilog, as the preceding -- expression might not be an identifier. let fsize = start - end + 1 in let expr' = argExprs !! n in if | fsize == size -> -- If sizes are equal, rotating / resizing amounts to doing nothing expr' | end == 0 -> -- Rotating is not necessary if relevant bits are already at the end int fsize <> squote <> parens expr' | otherwise -> -- Select bits 'start' downto and including 'end' let rotated = parens expr' <+> ">>" <+> int end in int fsize <> squote <> parens rotated seq_ :: Seq -> SystemVerilogM Doc seq_ (AlwaysClocked edge clk ds) = "always @" <> parens (case edge of {Rising -> "posedge"; _ -> "negedge"} <+> expr_ False clk) <+> "begin" <> line <> indent 2 (seqs ds) <> line <> "end" seq_ (Initial ds) = "initial begin" <> line <> indent 2 (seqs ds) <> line <> "end" seq_ (AlwaysComb ds) = "always @* begin" <> line <> indent 2 (seqs ds) <> line <> "end" seq_ (Branch scrut scrutTy es) = "case" <> parens (expr_ True scrut) <> line <> (indent 2 $ vcat $ conds es) <> line <> "endcase" where conds :: [(Maybe Literal,[Seq])] -> SystemVerilogM [Doc] conds [] = return [] conds [(_,sq)] = ("default" <+> colon <+> "begin" <> line <> indent 2 (seqs sq) <> line <> "end") <:> return [] conds ((Nothing,sq):_) = ("default" <+> colon <+> "begin" <> line <> indent 2 (seqs sq) <> line <> "end") <:> return [] conds ((Just c ,sq):es') = (exprLitSV (Just (scrutTy,conSize scrutTy)) c <+> colon <+> "begin" <> line <> indent 2 (seqs sq) <> line <> "end") <:> conds es' seq_ (SeqDecl sd) = case sd of 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 Seq ds -> seqs ds _ -> error (show sd) seqs :: [Seq] -> SystemVerilogM Doc seqs [] = emptyDoc seqs (SeqDecl (TickDecl (Comment c)):ds) = comment "//" c <> line <> seqs ds seqs (SeqDecl (TickDecl (Directive d)):ds) = pretty d <> ";" <> line <> seqs ds seqs (d:ds) = seq_ d <> line <> line <> seqs ds -- | Turn a Netlist expression into a SystemVerilog expression expr_ :: Bool -- ^ Enclose in parentheses? -> Expr -- ^ Expr to convert -> SystemVerilogM Doc expr_ _ (Literal sizeM lit) = exprLitSV sizeM lit expr_ _ (Identifier id_ Nothing) = pretty id_ expr_ _ (Identifier id_ (Just (Indexed (CustomSP _id dataRepr _size args,dcI,fI)))) = case fieldTy of Void {} -> error (unexpectedProjectionErrorMsg dataRepr dcI fI) _ -> expFromSLV fieldTy (braces $ hcat $ punctuate ", " $ sequence ranges) where (ConstrRepr' _name _n _mask _value anns, _, fieldTypes) = args !! dcI ranges = map range' $ bitRanges (anns !! fI) range' (start, end) = pretty id_ <> brackets (int start <> ":" <> int end) fieldTy = indexNote ($(curLoc) ++ "panic") fieldTypes fI expr_ _ (Identifier id_ (Just (Indexed (CustomProduct _id dataRepr _size _maybeFieldNames args,dcI,fI)))) = case fieldTy of Void {} -> error (unexpectedProjectionErrorMsg dataRepr dcI fI) _ -> expFromSLV fieldTy (braces $ hcat $ punctuate ", " $ sequence ranges) where (anns, fieldTypes) = unzip args ranges = map range' $ bitRanges (anns !! fI) range' (start, end) = pretty id_ <> brackets (int start <> ":" <> int end) fieldTy = indexNote ($(curLoc) ++ "panic") fieldTypes fI expr_ _ (Identifier id_ (Just (Indexed (ty@(SP _ args),dcI,fI)))) = fromSLV argTy (Id.toText id_) start end where argTys = snd $ args !! dcI argTy = argTys !! fI argSize = typeSize argTy other = otherSize argTys (fI-1) start = typeSize ty - 1 - conSize ty - other end = start - argSize + 1 expr_ _ (Identifier id_ (Just (Indexed (ty@(Product _ _ tys),_,fI)))) = do id'<- fmap (Text.toStrict . renderOneLine) (pretty id_ <> dot <> tyName ty <> "_sel" <> int fI) simpleFromSLV (tys !! fI) id' expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),1,0)))) = do id' <- fmap (Text.toStrict . renderOneLine) (pretty id_ <> brackets (int 0)) simpleFromSLV elTy id' expr_ _ (Identifier id_ (Just (Indexed ((Vector n _),1,1)))) = pretty id_ <> brackets (int 1 <> colon <> int (n-1)) -- This is a "Hack", we cannot construct trees with a negative depth. This is -- here so that we can recognise merged RTree modifiers. See the code in -- @Clash.Backend.nestM@ which construct these tree modifiers. expr_ _ (Identifier id_ (Just (Indexed (RTree (-1) _,l,r)))) = pretty id_ <> brackets (int l <> colon <> int (r-1)) expr_ _ (Identifier id_ (Just (Indexed ((RTree 0 elTy),0,0)))) = do id' <- fmap (Text.toStrict . renderOneLine) (pretty id_ <> brackets (int 0)) simpleFromSLV elTy id' expr_ _ (Identifier id_ (Just (Indexed ((RTree n _),1,0)))) = let z = 2^(n-1) in pretty id_ <> brackets (int 0 <> colon <> int (z-1)) expr_ _ (Identifier id_ (Just (Indexed ((RTree n _),1,1)))) = let z = 2^(n-1) z' = 2^n in pretty id_ <> brackets (int z <> colon <> int (z'-1)) -- This is a HACK for Clash.Netlist.Util.mkTopOutput -- Vector's don't have a 10'th constructor, this is just so that we can -- recognize the particular case expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),10,fI)))) = do id' <- fmap (Text.toStrict . renderOneLine) (pretty id_ <> brackets (int fI)) simpleFromSLV elTy id' -- This is a HACK for Clash.Netlist.Util.mkTopOutput -- RTree's don't have a 10'th constructor, this is just so that we can -- recognize the particular case expr_ _ (Identifier id_ (Just (Indexed ((RTree _ elTy),10,fI)))) = do id' <- fmap (Text.toStrict . renderOneLine) (pretty id_ <> brackets (int fI)) simpleFromSLV elTy id' expr_ _ (Identifier id_ (Just (DC (ty@(SP _ _),_)))) = pretty id_ <> brackets (int start <> colon <> int end) where start = typeSize ty - 1 end = typeSize ty - conSize ty expr_ _ (Identifier id_ (Just m@Nested {})) = case modifier 0 [] m of Nothing -> pretty id_ Just (mods,resTy) -> do nm <- Ap $ use modNm pkgCtx <- Ap $ use tyPkgCtx let prefix = if pkgCtx then emptyDoc else stringS nm <> "_types::" let e = pretty id_ <> hcat (mapM (either bracketNMod bracketNMod) (reverse mods)) case resTy of Signed _ -> "$signed" <> parens e Vector {} | Left (NRange {}):_ <- mods -> e | otherwise -> do Ap (tyCache %= HashSet.insert resTy) prefix <> tyName resTy <> "_from_lv" <> parens e RTree {} | Left (NRange {}):_ <- mods -> e | otherwise -> do Ap (tyCache %= HashSet.insert resTy) prefix <> tyName resTy <> "_from_lv" <> parens e _ -> e where bracketNMod (NElem i) = brackets (int i) bracketNMod (NRange s e) = brackets (int s <> colon <> int e) -- See [Note] integer projection expr_ _ (Identifier id_ (Just (Indexed ((Signed w),_,_)))) = do iw <- Ap $ use intWidth traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $ pretty id_ -- See [Note] integer projection expr_ _ (Identifier id_ (Just (Indexed ((Unsigned w),_,_)))) = do iw <- Ap $ use intWidth traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $ pretty id_ -- See [Note] mask projection expr_ _ (Identifier _ (Just (Indexed ((BitVector _),_,0)))) = do iw <- Ap $ use intWidth traceIf True ($(curLoc) ++ "WARNING: synthesizing bitvector mask to dontcare") $ verilogTypeErrValue (Unsigned iw) -- See [Note] bitvector projection expr_ _ (Identifier id_ (Just (Indexed ((BitVector w),_,1)))) = do iw <- Ap $ use intWidth traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $ pretty id_ expr_ _ (Identifier id_ (Just (Sliced ((BitVector _,start,end))))) = pretty id_ <> brackets (int start <> ":" <> int end) expr_ _ (Identifier id_ (Just _)) = pretty id_ expr_ b (DataCon _ (DC (Void {}, -1)) [e]) = expr_ b e expr_ _ (DataCon ty@(Vector 0 _) _ _) = verilogTypeErrValue ty 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 (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]) | Literal _ (NumLit n1) <- n0 , n == fromInteger n1 , Literal _ (NumLit m1) <- m0 , m == fromInteger m1 , Literal Nothing (StringLit runs0) <- runs , Literal Nothing (StringLit ends0) <- ends , es <- unpackNats n m (B8.pack runs0) (B8.pack ends0) = let el val = exprLitSV (Just (BitVector m, m)) (BitVecLit 0 $ toInteger val) in "'" <> listBraces (mapM el es) expr_ _ (DataCon (RTree 0 elTy) _ [e]) = "'" <> braces (toSLV elTy e) expr_ _ e@(DataCon ty@(RTree _ elTy) _ [e1,e2]) = case rtreeChain e of Just es -> "'" <> listBraces (mapM (toSLV elTy) es) Nothing -> verilogTypeMark ty <> "_br" <> parens (expr_ False e1 <> comma <+> expr_ False e2) expr_ _ (DataCon (SP {}) (DC (BitVector _,_)) es) = assignExpr where argExprs = map (expr_ False) es assignExpr = braces (hcat $ punctuate comma $ sequence argExprs) expr_ _ (DataCon ty@(SP _ args) (DC (_,i)) es) = assignExpr where argTys = snd $ args !! i dcSize = conSize ty + sum (map typeSize argTys) dcExpr = expr_ False (dcToExpr ty i) argExprs = zipWith toSLV argTys es extraArg = case typeSize ty - dcSize of 0 -> [] n -> [int n <> "'b" <> bits undefValue (replicate n U)] assignExpr = braces (hcat $ punctuate comma $ sequence (dcExpr:argExprs ++ extraArg)) expr_ _ (DataCon ty@(Sum _ _) (DC (_,i)) []) = int (typeSize ty) <> "'d" <> int i expr_ _ (DataCon ty@(CustomSum _ _ _ tys) (DC (_,i)) []) = let (ConstrRepr' _ _ _ value _) = fst $ tys !! i in int (typeSize ty) <> squote <> "d" <> int (fromIntegral value) expr_ _ (DataCon (CustomSP _ dataRepr _size args) (DC (_,i)) es) = let (cRepr, _, argTys) = args !! i in customReprDataCon dataRepr cRepr (zipEqual argTys es) expr_ _ (DataCon (CustomProduct _ dataRepr _size _labels tys) _ es) | DataRepr' _typ _size [cRepr] <- dataRepr = customReprDataCon dataRepr cRepr (zipEqual (map snd tys) es) expr_ _ (DataCon (Product _ _ tys) _ es) = listBraces (zipWithM toSLV tys es) expr_ _ (DataCon (Enable _) _ [e]) = expr_ False e expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Signed.fromInteger#" , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx = exprLitSV (Just (Signed (fromInteger n),fromInteger n)) i expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Unsigned.fromInteger#" , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx = exprLitSV (Just (Unsigned (fromInteger n),fromInteger n)) i expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.BitVector.fromInteger#" , [Literal _ (NumLit n), Literal _ (NumLit m), Literal _ (NumLit i)] <- extractLiterals bbCtx = exprLitSV (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 , NumLit m' <- m , NumLit i' <- i = exprLitSV (Just (Bit,1)) (BitLit $ toBit m' i') expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Index.fromInteger#" , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx = exprLitSV (Just (Index (fromInteger n),fromInteger n)) i expr_ b (BlackBoxE _ libs imps inc bs bbCtx b') = parenIf (b || b') (Ap (renderBlackBox libs imps inc bs bbCtx <*> pure 0)) expr_ _ (DataTag Bool (Left id_)) = pretty id_ <> brackets (int 0) expr_ _ (DataTag Bool (Right id_)) = do iw <- Ap $ use intWidth "$unsigned" <> parens (listBraces (sequence [braces (int (iw-1) <+> braces "1'b0"),pretty id_])) expr_ _ (DataTag (Sum _ _) (Left id_)) = "$unsigned" <> parens (pretty id_) expr_ _ (DataTag (Sum _ _) (Right id_)) = "$unsigned" <> parens (pretty id_) expr_ _ (DataTag (Product {}) (Right _)) = do iw <- Ap $ use intWidth int iw <> "'sd0" expr_ _ (DataTag hty@(SP _ _) (Right id_)) = "$unsigned" <> parens (pretty id_ <> brackets (int start <> colon <> int end)) where start = typeSize hty - 1 end = typeSize hty - conSize hty expr_ _ (DataTag (Vector 0 _) (Right _)) = do iw <- Ap $ use intWidth int iw <> "'sd0" expr_ _ (DataTag (Vector _ _) (Right _)) = do iw <- Ap $ use intWidth int iw <> "'sd1" expr_ _ (DataTag (RTree 0 _) (Right _)) = do iw <- Ap $ use intWidth int iw <> "'sd0" expr_ _ (DataTag (RTree _ _) (Right _)) = do iw <- Ap $ use intWidth int iw <> "'sd1" expr_ b (ToBv topM t e) = do nm <- Ap $ use modNm pkgCtx <- Ap $ use tyPkgCtx let prefix = if pkgCtx then emptyDoc else stringS nm <> "_types::" case t of Vector {} -> do Ap (tyCache %= HashSet.insert t) maybe prefix ((<> "_types::") . pretty) topM <> tyName t <> "_to_lv" <> parens (expr_ False e) RTree {} -> do Ap (tyCache %= HashSet.insert t) maybe prefix ((<> "_types::") . pretty) topM <> tyName t <> "_to_lv" <> parens (expr_ False e) _ -> expr b e expr_ b (FromBv topM t e) = do nm <- Ap $ use modNm pkgCtx <- Ap $ use tyPkgCtx let prefix = if pkgCtx then emptyDoc else stringS nm <> "_types::" case t of Vector {} -> do Ap (tyCache %= HashSet.insert t) maybe prefix ((<> "_types::") . pretty) topM <> tyName t <> "_from_lv" <> parens (expr_ False e) RTree {} -> do Ap (tyCache %= HashSet.insert t) maybe prefix ((<> "_types::") . pretty) topM <> tyName t <> "_from_lv" <> parens (expr_ False e) _ -> expr b e expr_ b (IfThenElse c t e) = parenIf b (expr_ True c <+> "?" <+> expr_ True t <+> ":" <+> expr_ True e) expr_ _ e = error $ $(curLoc) ++ (show e) -- empty exprLitSV :: Maybe (HWType,Size) -> Literal -> SystemVerilogM Doc exprLitSV = exprLit undefValue otherSize :: [HWType] -> Int -> Int otherSize _ n | n < 0 = 0 otherSize [] _ = 0 otherSize (a:as) n = typeSize a + otherSize as (n-1) vectorChain :: Expr -> Maybe [Expr] vectorChain (DataCon (Vector 0 _) _ _) = Just [] vectorChain (DataCon (Vector 1 _) _ [e]) = Just [e] vectorChain (DataCon (Vector _ _) _ [e1,e2]) = Just e1 <:> vectorChain e2 vectorChain _ = Nothing rtreeChain :: Expr -> Maybe [Expr] rtreeChain (DataCon (RTree 0 _) _ [e]) = Just [e] rtreeChain (DataCon (RTree _ _) _ [e1,e2]) = A.liftA2 (++) (rtreeChain e1) (rtreeChain e2) rtreeChain _ = Nothing toSLV :: HWType -> Expr -> SystemVerilogM Doc toSLV t e = case t of Vector _ _ -> braces (verilogTypeMark t <> "_to_lv" <> parens (expr_ False e)) RTree _ _ -> braces (verilogTypeMark t <> "_to_lv" <> parens (expr_ False e)) MemBlob n m -> toSLV (Vector n (BitVector m)) e _ -> expr_ False e fromSLV :: HWType -> IdentifierText -> Int -> Int -> SystemVerilogM Doc fromSLV t@(Vector _ _) id_ start end = verilogTypeMark t <> "_from_lv" <> parens (pretty id_ <> brackets (int start <> colon <> int end)) fromSLV t@(RTree _ _) id_ start end = verilogTypeMark t <> "_from_lv" <> parens (pretty id_ <> brackets (int start <> colon <> int end)) fromSLV (Signed _) id_ start end = "$signed" <> parens (pretty id_ <> brackets (int start <> colon <> int end)) fromSLV (MemBlob n m) id_ start end = fromSLV (Vector n (BitVector m)) id_ start end fromSLV _ id_ start end = pretty id_ <> brackets (int start <> colon <> int end) simpleFromSLV :: HWType -> IdentifierText -> SystemVerilogM Doc simpleFromSLV t@(Vector _ _) id_ = verilogTypeMark t <> "_from_lv" <> parens (pretty id_) simpleFromSLV t@(RTree _ _) id_ = verilogTypeMark t <> "_from_lv" <> parens (pretty id_) simpleFromSLV (Signed _) id_ = "$signed" <> parens (pretty id_) simpleFromSLV (MemBlob n m) id_ = simpleFromSLV (Vector n (BitVector m)) id_ simpleFromSLV _ id_ = pretty id_ expFromSLV :: HWType -> SystemVerilogM Doc -> SystemVerilogM Doc expFromSLV t@(Vector _ _) exp_ = verilogTypeMark t <> "_from_lv" <> parens exp_ expFromSLV t@(RTree _ _) exp_ = verilogTypeMark t <> "_from_lv" <> parens exp_ expFromSLV (Signed _) exp_ = "$signed" <> parens exp_ expFromSLV _ exp_ = exp_ dcToExpr :: HWType -> Int -> Expr dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i)) listBraces :: Monad m => m [Doc] -> m Doc listBraces = align . encloseSep lbrace rbrace comma parenIf :: Monad m => Bool -> m Doc -> m Doc parenIf True = parens parenIf False = id punctuate' :: Monad m => Ap m Doc -> Ap m [Doc] -> Ap m Doc punctuate' s d = vcat (punctuate s d) <> s data NMod = NRange Int Int | NElem Int -- | Calculate the beginning and end index into a variable, to get the -- desired field. Also returns the HWType of the result. -- -- NB: returns a list of slices and indices when selections are into vectors and -- rtrees. Left -> index/slice from an unpacked array; Right -> slice from a -- packed type modifier :: Int -- ^ Offset, only used when we have nested modifiers -> [Either NMod NMod] -- ^ Ranges selected so far -> Modifier -> Maybe ([Either NMod NMod],HWType) modifier offset mods (Sliced (BitVector _,start,end)) = let m = Right (NRange (start+offset) (end+offset)) in case mods of Right {}:rest -> Just (m:rest, BitVector (start-end+1)) _ -> Just (m:mods, BitVector (start-end+1)) modifier offset mods (Indexed (ty@(SP _ args),dcI,fI)) = case mods of Right {}:rest -> Just (m:rest, argTy) _ -> Just (m:mods,argTy) where argTys = snd $ args !! dcI argTy = argTys !! fI argSize = typeSize argTy other = otherSize argTys (fI-1) start = typeSize ty - 1 - conSize ty - other end = start - argSize + 1 m = Right (NRange (start+offset) (end+offset)) modifier offset mods (Indexed (ty@(Product _ _ argTys),_,fI)) = let m = Right (NRange (start+offset) (end+offset)) in case mods of Right {}:rest -> Just (m:rest, argTy) _ -> Just (m:mods,argTy) where argTy = argTys !! fI argSize = typeSize argTy otherSz = otherSize argTys (fI - 1) start = typeSize ty - 1 - otherSz end = start - argSize + 1 modifier offset mods (Indexed (ty@(Vector _ argTy),1,0)) = case mods of Right {}:rest -> Just (Right (NRange (start+offset) (end+offset)):rest, argTy) Left (NRange b _):rest -> Just (Left (NElem b):rest,argTy) _ -> Just (Left (NElem 0):mods,argTy) where argSize = typeSize argTy start = typeSize ty - 1 end = start - argSize + 1 modifier offset mods (Indexed (ty@(Vector n argTy),1,1)) = case mods of Right {}:rest -> Just (Right (NRange (start+offset) offset):rest, Vector (n-1) argTy) Left (NRange b e):rest -> Just (Left (NRange (b+1) e):rest, Vector (n-1) argTy) _ -> Just (Left (NRange 1 (n-1)):mods, Vector (n-1) argTy) where argSize = typeSize argTy start = typeSize ty - argSize - 1 modifier offset mods (Indexed (ty@(RTree 0 argTy),0,0)) = case mods of Right {}:rest -> Just (Right (NRange (start+offset) offset):rest, argTy) Left (NRange b _):rest -> Just (Left (NElem b):rest,argTy) _ -> Just (Left (NElem 0):mods,argTy) where start = typeSize ty - 1 modifier offset mods (Indexed (ty@(RTree d argTy),1,0)) = case mods of Right {}:rest -> Just (Right (NRange (start+offset) (end+offset)):rest, RTree (d-1) argTy) Left (NRange b _):rest -> Just (Left (NRange b (b+lhsSz-1)):rest,RTree (d-1) argTy) _ -> Just (Left (NRange 0 (lhsSz-1)):mods,RTree (d-1) argTy) where start = typeSize ty - 1 end = typeSize ty `div` 2 lhsSz = (d-1)^(2 :: Int) modifier offset mods (Indexed (ty@(RTree d argTy),1,1)) = case mods of Right {}:rest -> Just (Right (NRange (start+offset) offset):rest, RTree (d-1) argTy) Left (NRange _ e):rest -> Just (Left (NRange (e+1-rhsS) e):rest,RTree (d-1) argTy) _ -> Just (Left (NRange rhsS rhsE):mods,RTree (d-1) argTy) where start = (typeSize ty `div` 2) - 1 rhsS = (d-1)^(2 :: Int) rhsE = d^(2 :: Int)-1 -- This is a HACK for Clash.Netlist.Util.mkTopOutput -- Vector's don't have a 10'th constructor, this is just so that we can -- recognize the particular case modifier offset mods (Indexed (ty@(Vector _ argTy),10,fI)) = case mods of Right {}:rest -> Just (Right (NRange (start+offset) (end+offset)):rest, argTy) Left (NRange b _):rest -> Just (Left (NElem (fI+b)):rest, argTy) _ -> Just (Left (NElem fI):mods,argTy) where argSize = typeSize argTy start = typeSize ty - (fI * argSize) - 1 end = start - argSize + 1 -- This is a HACK for Clash.Netlist.Util.mkTopOutput -- RTree's don't have a 10'th constructor, this is just so that we can -- recognize the particular case modifier offset mods (Indexed (ty@(RTree _ argTy),10,fI)) = case mods of Right {}:rest -> Just (Right (NRange (start+offset) (end+offset)):rest, argTy) Left (NRange b _):rest -> Just (Left (NElem (b+fI)):rest, argTy) _ -> Just (Left (NElem fI):mods, argTy) where argSize = typeSize argTy start = typeSize ty - (fI * argSize) - 1 end = start - argSize + 1 modifier offset mods (Indexed (CustomSP typName _dataRepr _size args,dcI,fI)) = case bitRanges (anns !! fI) of [(start,end)] -> let m = Right (NRange (start+offset) (end+offset)) in case mods of Right {}:rest -> Just (m:rest, argTy) _ -> Just (m:mods, argTy) _ -> error $ $(curLoc) ++ "Cannot handle projection out of a " ++ "non-contiguously or zero-width encoded field. Tried to project " ++ "field " ++ show fI ++ " of constructor " ++ show dcI ++ " of " ++ "data type " ++ show typName ++ "." where (ConstrRepr' _name _n _mask _value anns, _, argTys) = args !! dcI argTy = argTys !! fI modifier offset mods (Indexed (CustomProduct typName dataRepr _size _maybeFieldNames args,dcI,fI)) | DataRepr' _typ _size [cRepr] <- dataRepr , ConstrRepr' _cName _pos _mask _val fieldAnns <- cRepr = case bitRanges (fieldAnns !! fI) of [(start,end)] -> let m = Right (NRange (start+offset) (end+offset)) in case mods of Right {}:rest -> Just (m:rest, argTy) _ -> Just (m:mods,argTy) _ -> error $ $(curLoc) ++ "Cannot handle projection out of a " ++ "non-contiguously or zero-width encoded field. Tried to project " ++ "field " ++ show fI ++ " of constructor " ++ show dcI ++ " of " ++ "data type " ++ show typName ++ "." where argTy = map snd args !! fI modifier offset mods (DC (ty@(SP _ _),_)) = let m = Right (NRange (start+offset) (end+offset)) in case mods of Right {}:rest -> Just (m:rest, ty) _ -> Just (m:mods,ty) where start = typeSize ty - 1 end = typeSize ty - conSize ty modifier offset mods (Nested m1 m2) = do case modifier offset mods m1 of Nothing -> modifier offset mods m2 Just (mods1,argTy) -> let m3 = case mods1 of Right (NRange _ e):_ -> modifier e mods1 m2 _ -> modifier 0 mods1 m2 in case m3 of -- In case the second modifier is `Nothing` that means we want the entire -- thing calculated by the first modifier Nothing -> Just (mods1,argTy) m -> m modifier _ _ _ = Nothing clash-lib-1.8.1/src/Clash/Backend/VHDL.hs0000644000000000000000000027250307346545000016022 0ustar0000000000000000{-| Copyright : (C) 2015-2016, University of Twente, 2017-2018, Google Inc., 2021-2023, QBayLogic B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Generate VHDL for assorted Netlist datatypes -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} 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) import Data.Bifunctor (first) import Data.Bits (testBit, Bits) import qualified Data.ByteString.Char8 as B8 import Data.Coerce (coerce) import Data.Function (on) import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap import qualified Data.HashMap.Strict as HashMapS import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List (mapAccumL, nub, nubBy, partition, intersperse, group, sort) import Data.List.Extra ((<:>), equalLength, zipEqual) import Data.Maybe (catMaybes,mapMaybe) import Data.Monoid (Ap(Ap)) import Data.Monoid.Extra () import qualified Data.Text.Lazy as T import qualified Data.Text as TextS import Data.Text.Extra #if MIN_VERSION_prettyprinter(1,7,0) import qualified Prettyprinter as PP #else import qualified Data.Text.Prettyprint.Doc as PP #endif import Data.Text.Prettyprint.Doc.Extra import GHC.Stack (HasCallStack) import qualified System.FilePath import Text.Printf import Clash.Annotations.Primitive (HDL (..)) import Clash.Annotations.BitRepresentation.Internal (ConstrRepr'(..), DataRepr'(..)) import Clash.Annotations.BitRepresentation.ClashLib (bitsToBits) import Clash.Annotations.BitRepresentation.Util (BitOrigin(Lit, Field), bitOrigins, bitRanges) import Clash.Annotations.SynthesisAttributes (Attr(..)) import Clash.Backend import Clash.Debug (traceIf) 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, usages, _usages) import Clash.Netlist.Util import Clash.Util (SrcSpan, noSrcSpan, clogBase, curLoc, makeCached, indexNote) import qualified Clash.Util.Interpolate as I import Clash.Util.Graph (reverseTopSort) import Clash.Backend.Verilog (Range (..), continueWithRange) import Debug.Trace (traceM) -- | State for the 'Clash.Netlist.VHDL.VHDLM' monad: data VHDLState = VHDLState { _tyCache :: HashSet HWType -- ^ Previously encountered HWTypes , _nameCache :: (HashMap (HWType, Bool) TextS.Text) -- ^ Cache for type names. Bool indicates whether this name includes length -- information in its first "part". See `tyName'` for more information. , _modNm :: ModName , _topNm :: Identifier , _srcSpan :: SrcSpan , _libraries :: [T.Text] , _packages :: [T.Text] , _includes :: [(String,Doc)] , _dataFiles :: [(String,FilePath)] -- ^ Files to be copied: (filename, old path) , _memoryDataFiles:: [(String,String)] -- ^ Files to be stored: (filename, contents). These files are generated -- during the execution of 'genNetlist'. , _idSeen :: IdentifierSet , _tyPkgCtx :: Bool -- ^ Are we in the context of generating the @_types@ package? , _intWidth :: Int -- ^ Int/Word/Integer bit-width , _hdlsyn :: HdlSyn -- ^ For which HDL synthesis tool are we generating VHDL , _undefValue :: Maybe (Maybe Int) , _productFieldNameCache :: HashMap (Maybe [TextS.Text], [HWType]) [TextS.Text] -- ^ Caches output of 'productFieldNames'. , _enumNameCache :: HashMap HWType [TextS.Text] -- ^ Cache for enum variant names. , _aggressiveXOptBB_ :: AggressiveXOptBB , _renderEnums_ :: RenderEnums , _domainConfigurations_ :: DomainMap , _usages :: UsageMap } makeLenses ''VHDLState instance HasIdentifierSet VHDLState where identifierSet = idSeen instance HasUsageMap VHDLState where usageMap = usages instance Backend VHDLState where initBackend opts = VHDLState { _tyCache=mempty , _nameCache=mempty , _modNm="" , _topNm=Id.unsafeMake "" , _srcSpan=noSrcSpan , _libraries=[] , _packages=[] , _includes=[] , _dataFiles=[] , _memoryDataFiles=[] , _idSeen=Id.emptyIdentifierSet (opt_escapedIds opts) (opt_lowerCaseBasicIds opts) VHDL , _tyPkgCtx=False , _intWidth=opt_intWidth opts , _hdlsyn=opt_hdlSyn opts , _undefValue=opt_forceUndefined opts , _productFieldNameCache=mempty , _enumNameCache=mempty , _aggressiveXOptBB_=coerce (opt_aggressiveXOptBB opts) , _renderEnums_=coerce (opt_renderEnums opts) , _domainConfigurations_=emptyDomainMap , _usages=mempty } hdlKind = const VHDL primDirs = const $ do root <- primsRoot return [ root System.FilePath. "common" , root System.FilePath. "vhdl" ] extractTypes = _tyCache name = const "vhdl" extension = const ".vhdl" genHDL = genVHDL mkTyPackage = mkTyPackage_ hdlHWTypeKind = \case Vector {} -> pure UserType RTree {} -> pure UserType Product {} -> pure UserType MemBlob {} -> pure UserType Sum {} -> do -- If an enum is rendered, it is a user type. If not, an std_logic_vector -- is rendered, and it is a synonym. RenderEnums enums <- renderEnums if enums then pure UserType else pure SynonymType Clock {} -> pure SynonymType ClockN {} -> pure SynonymType Reset {} -> pure SynonymType Enable {} -> pure SynonymType Index {} -> pure SynonymType CustomSP {} -> pure SynonymType SP {} -> pure SynonymType -- TODO This could possibly be changed to a VHDL enum as well, provided the -- enum_encoding attribute behaves as desired in different tools CustomSum {} -> pure SynonymType CustomProduct {} -> pure SynonymType BitVector _ -> pure PrimitiveType Bool -> pure PrimitiveType Bit -> pure PrimitiveType Unsigned {} -> pure PrimitiveType Signed {} -> pure PrimitiveType String -> pure PrimitiveType Integer -> pure PrimitiveType FileType -> pure PrimitiveType -- Transparent types: BiDirectional _ ty -> hdlHWTypeKind ty Annotated _ ty -> hdlHWTypeKind ty -- Shouldn't be printed? Void {} -> pure PrimitiveType KnownDomain {} -> pure PrimitiveType hdlType Internal (filterTransparent -> ty) = sizedQualTyName ty hdlType (External nm) (filterTransparent -> ty) = let sized = sizedQualTyName ty in case ty of Bit -> sized Bool -> sized Signed _ -> sized Unsigned _ -> sized BitVector _ -> sized _ -> pretty nm <> dot <> sized hdlTypeErrValue = sizedQualTyNameErrValue hdlTypeMark = qualTyName hdlRecSel = vhdlRecSel hdlSig t ty = sigDecl (pretty t) ty genStmt = const emptyDoc inst = inst_ expr = expr_ iwWidth = use intWidth toBV t id_ = do enums <- Ap renderEnums if isBV enums t then pretty id_ else do nm <- Ap $ use modNm -- TODO: restore hack -- seen <- use seenIdentifiers -- This is a bit hacky, as id_ is just a rendered expression. -- But if it's a bare identifier that we've seen before, -- then this identifier has a defined type and we can skip the explicit type qualification. -- let e | T.toStrict id_ `HashMapS.member` seen = pretty id_ -- | otherwise = let e = hdlTypeMark t <> squote <> parens (pretty id_) pretty nm <> "_types.toSLV" <> parens e fromBV t id_ = do enums <- Ap renderEnums if isBV enums t then pretty id_ else do nm <- Ap $ use modNm qualTyName t <> "'" <> parens (pretty nm <> "_types.fromSLV" <> parens (pretty id_)) hdlSyn = use hdlsyn setModName nm s = s {_modNm = nm} setTopName nm s = s {_topNm = nm} getTopName = use topNm setSrcSpan = (srcSpan .=) getSrcSpan = use srcSpan blockDecl nm ds = do decs <- decls ds let attrs = [ (id_, attr) | NetDecl' _ id_ hwtype _ <- ds , attr <- hwTypeAttrs hwtype] if isEmpty decs then insts ids else nest 2 (pretty nm <+> colon <+> "block" <> line <> pure decs <> (if null attrs then emptyDoc 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 ++) addAndSetData f = do fs <- use dataFiles let (fs',f') = renderFilePath fs f dataFiles .= fs' return f' getDataFiles = use dataFiles addMemoryDataFile f = memoryDataFiles %= (f:) getMemoryDataFiles = use memoryDataFiles ifThenElseExpr _ = False aggressiveXOptBB = use aggressiveXOptBB_ renderEnums = use renderEnums_ domainConfigurations = use domainConfigurations_ setDomainConfigurations confs s = s {_domainConfigurations_ = confs} type VHDLM a = Ap (State VHDLState) a -- Check if the underlying type is a BitVector isBV :: RenderEnums -> HWType -> Bool isBV e (normaliseType e -> BitVector _) = True isBV _ _ = False -- | Generate unique (partial) names for product fields. Example: -- -- > productFieldNames Nothing [Unsigned 6, Unsigned 6, Bit, Bool] -- ["unsigned6_0", "unsigned6_1", "bit", "boolean"] productFieldNames :: HasCallStack => Maybe [IdentifierText] -- ^ Label hints. From user records, for example. -> [HWType] -- ^ Field types -> VHDLM [IdentifierText] productFieldNames labels0 fields = do let labels1 = sequence labels0 ++ repeat Nothing hFields <- zipWithM hName labels1 fields let grouped = group $ sort $ hFields 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 where hName :: Maybe IdentifierText -> HWType -> VHDLM IdentifierText hName Nothing field = tyName' False field hName (Just label) _field = Id.toText <$> Id.makeBasic label name' :: HashMap IdentifierText Int -> HashMap IdentifierText Int -> IdentifierText -> (HashMap IdentifierText Int, IdentifierText) name' counted countMap fieldName | counted HashMapS.! fieldName > 1 = -- Seen this fieldname more than once, so we need to add a number -- as a postfix: let succ' n = Just (maybe (0 :: Int) (+1) n) in let countMap' = HashMapS.alter succ' fieldName countMap in -- Each field will get a distinct number: let count = countMap' HashMapS.! fieldName in (countMap', TextS.concat [fieldName, "_", showt count]) | otherwise = -- This fieldname has only been seen once, so we don't need to add -- a number as a postfix: (countMap, fieldName) productFieldName :: HasCallStack => Maybe [IdentifierText] -- ^ Label hints. From user records, for example. -> [HWType] -- ^ Field types -> Int -- ^ Index of field -> VHDLM Doc productFieldName labels fields fieldIndex = do names <- makeCached (labels, fields) productFieldNameCache (productFieldNames labels fields) return (PP.pretty (names !! fieldIndex)) selectProductField :: HasCallStack => Maybe [IdentifierText] -- ^ Label hints. From user records, for example. -> [HWType] -- ^ Field types -> Int -- ^ Index of field -> VHDLM Doc selectProductField fieldLabels fieldTypes fieldIndex = "_sel" <> int fieldIndex <> "_" <> productFieldName fieldLabels fieldTypes fieldIndex enumVariantName :: HasCallStack => HWType -> Int -> VHDLM Doc enumVariantName ty@(Sum _ vs) i = do names <- makeCached ty enumNameCache (traverse variantName vs) pure (PP.pretty (names !! i)) where -- Make a basic identifier from the last part of a qualified name variantName = fmap Id.toText . Id.makeBasic . snd . TextS.breakOnEnd "." enumVariantName _ _ = error $ $(curLoc) ++ "enumVariantName called on non-enum type" -- | Generate VHDL for a Netlist component genVHDL :: ClashOpts -> ModName -> SrcSpan -> IdentifierSet -> UsageMap -> Component -> VHDLM ((String, Doc), [(String, Doc)]) 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 $ do idSeen %= Id.union seen usages .= us setSrcSpan sp v <- vhdl i <- Ap $ use includes Ap $ libraries .= [] Ap $ packages .= [] return ((TextS.unpack (Id.toText cName), v), i) where cName = componentName c vhdl = do ent <- entity c arch <- architecture c imps <- tyImports nm ("-- Automatically generated VHDL-93" <> line <> pure imps <> line <> line <> pure ent <> line <> line <> pure arch) -- | Generate a VHDL package containing type definitions for the given HWTypes mkTyPackage_ :: ModName -> [HWType] -> VHDLM [(String,Doc)] mkTyPackage_ modName (map filterTransparent -> hwtys) = do { Ap (tyPkgCtx .= True) ; syn <- Ap hdlSyn ; enums <- Ap renderEnums ; let usedTys = concatMap mkUsedTys hwtys ; let normTys0 = nub (map mkVecZ (hwtys ++ usedTys)) ; let sortedTys0 = topSortHWTys normTys0 packageDec = vcat $ mapM tyDec (nubBy eqTypM sortedTys0) (funDecs,funBodies) = unzip . mapMaybe (funDec enums syn) $ nubBy eqTypM (normaliseType enums <$> sortedTys0) ; pkg <- (:[]) <$> (TextS.unpack (modName `TextS.append` "_types"),) <$> "library IEEE;" <> line <> "use IEEE.STD_LOGIC_1164.ALL;" <> line <> "use IEEE.NUMERIC_STD.ALL;" <> line <> line <> "package" <+> pretty (modName `TextS.append` "_types") <+> "is" <> line <> indent 2 ( packageDec <> line <> vcat (sequence funDecs) ) <> line <> "end" <> semi <> packageBodyDec funBodies ; Ap (tyPkgCtx .= False) ; return pkg } where packageBodyDec :: [VHDLM Doc] -> VHDLM Doc packageBodyDec funBodies = case funBodies of [] -> emptyDoc _ -> do { line <> line <> "package" <+> "body" <+> pretty (modName `TextS.append` "_types") <+> "is" <> line <> indent 2 (vcat (sequence funBodies)) <> line <> "end" <> semi } eqTypM :: HWType -> HWType -> Bool eqTypM (Signed _) (Signed _) = True eqTypM (Unsigned _) (Unsigned _) = True eqTypM (BitVector _) (BitVector _) = True eqTypM ty1 ty2 = ty1 == ty2 mkUsedTys :: HWType -> [HWType] mkUsedTys hwty = hwty : case hwty of Vector _ elTy -> mkUsedTys elTy RTree _ elTy -> mkUsedTys elTy Product _ _ elTys -> concatMap mkUsedTys elTys SP _ elTys -> concatMap mkUsedTys (concatMap snd elTys) BiDirectional _ elTy -> mkUsedTys elTy Annotated _ elTy -> mkUsedTys elTy CustomProduct _ _ _ _ tys0 -> concatMap mkUsedTys (map snd tys0) CustomSP _ _ _ tys0 -> let tys1 = concat [tys | (_repr, _id, tys) <- tys0] in concatMap mkUsedTys tys1 _ -> [] topSortHWTys :: [HWType] -> [HWType] topSortHWTys hwtys = sorted where nodes = zip [0..] hwtys nodesI = HashMap.fromList (zip hwtys [0..]) edges = concatMap edge hwtys sorted = case reverseTopSort nodes edges of Left err -> error $ $(curLoc) ++ "[BUG IN CLASH] topSortHWTys: " ++ err Right ns -> ns -- `elTy` needs to be rendered before `t` edge t@(Vector _ elTy) = case HashMap.lookup (mkVecZ elTy) nodesI of Just node -> [(nodesI HashMap.! t, node)] Nothing -> [] -- `elTy` needs to be rendered before `t` edge t@(RTree _ elTy) = let vecZ = mkVecZ elTy in case HashMap.lookup vecZ nodesI of Just node -> [(nodesI HashMap.! t, node)] ++ edge elTy Nothing -> [] -- `tys` need to be rendered before `t` edge t@(Product _ _ tys0) = let tys1 = [HashMap.lookup (mkVecZ ty) nodesI | ty <- tys0] in map (nodesI HashMap.! t,) (catMaybes tys1) edge t@(SP _ tys0) = let tys1 = concat (map snd tys0) in let tys2 = [HashMap.lookup (mkVecZ ty) nodesI | ty <- tys1] in map (nodesI HashMap.! t,) (catMaybes tys2) edge t@(CustomSP _ _ _ tys0) = let tys1 = concat [tys | (_repr, _id, tys) <- tys0] in let tys2 = [HashMap.lookup (mkVecZ ty) nodesI | ty <- tys1] in map (nodesI HashMap.! t,) (catMaybes tys2) edge t@(CustomProduct _ _ _ _ (map snd -> tys0)) = let tys1 = [HashMap.lookup (mkVecZ ty) nodesI | ty <- tys0] in map (nodesI HashMap.! t,) (catMaybes tys1) edge _ = [] mkVecZ :: HWType -> HWType mkVecZ (Vector _ elTy) = Vector 0 elTy mkVecZ (RTree _ elTy) = RTree 0 elTy mkVecZ t = t typAliasDec :: HasCallStack => HWType -> VHDLM Doc typAliasDec hwty = do enums <- Ap renderEnums "subtype" <+> tyName hwty <+> "is" <+> sizedTyName (normaliseType enums hwty) <> semi tyDec :: HasCallStack => HWType -> VHDLM Doc tyDec hwty = do syn <- Ap hdlSyn RenderEnums enums <- Ap renderEnums case hwty of -- "Proper" custom types: Vector _ elTy -> case syn of Vivado -> "type" <+> tyName hwty <+> "is array (integer range <>) of std_logic_vector" <> parens (int (typeSize elTy - 1) <+> "downto 0") <> semi _ -> "type" <+> tyName hwty <+> "is array (integer range <>) of" <+> sizedQualTyName elTy <> semi RTree _ elTy -> case syn of Vivado -> "type" <+> tyName hwty <+> "is array (integer range <>) of" <+> "std_logic_vector" <> parens (int (typeSize elTy - 1) <+> "downto 0") <> semi _ -> "type" <+> tyName hwty <+> "is array (integer range <>) of" <+> sizedQualTyName elTy <> semi Product _ labels tys@(_:_:_) -> let selNames = map (\i -> tyName hwty <> selectProductField labels tys i) [0..] in let selTys = map sizedQualTyName tys in "type" <+> tyName hwty <+> "is record" <> line <> indent 2 (vcat $ zipWithM (\x y -> x <+> colon <+> y <> semi) selNames selTys) <> line <> "end record" <> semi Sum _ vs | enums -> let variantNames = traverse (enumVariantName hwty) [0..length vs - 1] in "type" <+> tyName hwty <+> "is" <+> parens (hsep (punctuate comma variantNames)) <> semi MemBlob n m -> tyDec (Vector n (BitVector m)) -- Type aliases: Clock _ -> typAliasDec hwty ClockN _ -> typAliasDec hwty Reset _ -> typAliasDec hwty Enable _ -> typAliasDec hwty Index _ -> typAliasDec hwty CustomSP _ _ _ _ -> typAliasDec hwty Sum _ _ -> typAliasDec hwty SP _ _ -> typAliasDec hwty CustomSum _ _ _ _ -> typAliasDec hwty CustomProduct {} -> typAliasDec hwty -- VHDL builtin types: BitVector _ -> emptyDoc Bool -> emptyDoc Bit -> emptyDoc Unsigned _ -> emptyDoc Signed _ -> emptyDoc String -> emptyDoc Integer -> emptyDoc FileType -> emptyDoc -- Transparent types: BiDirectional _ ty -> tyDec ty Annotated _ ty -> tyDec ty Void {} -> emptyDoc KnownDomain {} -> emptyDoc -- Unexpected arguments: Product _ _ _ -> error $ $(curLoc) ++ [I.i| Unexpected Product with fewer than 2 fields: #{hwty} |] funDec :: RenderEnums -> HdlSyn -> HWType -> Maybe (VHDLM Doc,VHDLM Doc) funDec _ _ Bool = Just ( "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <> semi <> line <> "function" <+> "tagToEnum" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "boolean" <> semi <> line <> "function" <+> "dataToTag" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "signed" <> semi , "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 (vcat $ sequence ["if" <+> "b" <+> "then" , indent 2 ("return" <+> dquotes (int 1) <> semi) ,"else" , indent 2 ("return" <+> dquotes (int 0) <> semi) ,"end" <+> "if" <> semi ]) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <+> "is" <> line <> "begin" <> line <> indent 2 (vcat $ sequence ["if" <+> "sl" <+> "=" <+> dquotes (int 1) <+> "then" , indent 2 ("return" <+> "true" <> semi) ,"else" , indent 2 ("return" <+> "false" <> semi) ,"end" <+> "if" <> semi ]) <> line <> "end" <> semi <> line <> "function" <+> "tagToEnum" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "boolean" <+> "is" <> line <> "begin" <> line <> indent 2 (vcat $ sequence ["if" <+> "s" <+> "=" <+> "to_signed" <> parens (int 0 <> comma <> (Ap (use intWidth) >>= int)) <+> "then" , indent 2 ("return" <+> "false" <> semi) ,"else" , indent 2 ("return" <+> "true" <> semi) ,"end" <+> "if" <> semi ]) <> line <> "end" <> semi <> line <> "function" <+> "dataToTag" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "signed" <+> "is" <> line <> "begin" <> line <> indent 2 (vcat $ sequence ["if" <+> "b" <+> "then" , indent 2 ("return" <+> "to_signed" <> parens (int 1 <> comma <> (Ap (use intWidth) >>= int)) <> semi) ,"else" , indent 2 ("return" <+> "to_signed" <> parens (int 0 <> comma <> (Ap (use intWidth) >>= int)) <> semi) ,"end" <+> "if" <> semi ]) <> line <> "end" <> semi ) funDec _ _ bit@Bit = Just ( "function" <+> "toSLV" <+> parens ("sl" <+> colon <+> "in" <+> tyName bit) <+> "return" <+> "std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> tyName bit <> semi , "function" <+> "toSLV" <+> parens ("sl" <+> colon <+> "in" <+> tyName bit) <+> "return" <+> "std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> "std_logic_vector'" <> parens (int 0 <+> rarrow <+> "sl") <> semi) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> tyName bit <+> "is" <> line <> indent 2 ( "alias islv : std_logic_vector (0 to slv'length - 1) is slv;" ) <> line <> "begin" <> line <> indent 2 ("return" <+> "islv" <> parens (int 0) <> semi) <> line <> "end" <> semi ) funDec _ _ (Signed _) = Just ( "function" <+> "toSLV" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "signed" <> semi , "function" <+> "toSLV" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> "std_logic_vector" <> parens ("s") <> semi) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "signed" <+> "is" <> line <> indent 2 ("alias islv : std_logic_vector(0 to slv'length - 1) is slv;") <> line <> "begin" <> line <> indent 2 ("return" <+> "signed" <> parens ("islv") <> semi) <> line <> "end" <> semi ) funDec _ _ (Unsigned _) = Just ( "function" <+> "toSLV" <+> parens ("u" <+> colon <+> "in" <+> "unsigned") <+> "return" <+> "std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "unsigned" <> semi , "function" <+> "toSLV" <+> parens ("u" <+> colon <+> "in" <+> "unsigned") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> "std_logic_vector" <> parens ("u") <> semi) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "unsigned" <+> "is" <> line <> indent 2 "alias islv : std_logic_vector(0 to slv'length - 1) is slv;" <> line <> "begin" <> line <> indent 2 ("return" <+> "unsigned" <> parens ("islv") <> semi) <> line <> "end" <> semi ) funDec _ _ t@(Product _ labels elTys) = Just ( "function" <+> "toSLV" <+> parens ("p :" <+> sizedTyName t) <+> "return std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> sizedTyName t <> semi , "function" <+> "toSLV" <+> parens ("p :" <+> sizedTyName t) <+> "return std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> parens (hcat (punctuate " & " elTyToSLV)) <> semi) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> sizedTyName t <+> "is" <> line <> "alias islv : std_logic_vector(0 to slv'length - 1) is slv;" <> line <> "begin" <> line <> indent 2 ("return" <+> parens (hcat (punctuate "," elTyFromSLV)) <> semi) <> line <> "end" <> semi ) where elTyToSLV = forM [0..(length elTys - 1)] (\i -> "toSLV" <> parens ("p." <> tyName t <> selectProductField labels elTys i)) argLengths = map typeSize elTys starts1 = snd (mapAccumL ((join (,) .) . (+)) 0 argLengths) starts = 0 : starts1 ends = map (subtract 1) starts1 elTyFromSLV = forM (zip starts ends) (\(s,e) -> "fromSLV" <> parens ("islv" <> parens (int s <+> "to" <+> int e))) funDec (RenderEnums enums) _ t@(Sum _ _) | enums = Just ( "function" <+> "toSLV" <+> parens("value" <+> colon <+> "in" <+> qualTyName t) <+> "return std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> qualTyName t <> semi , "function" <+> "toSLV" <+> parens ("value" <+> colon <+> "in" <+> qualTyName t) <+> "return std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 ( "return" <+> "std_logic_vector" <> parens ("to_unsigned" <> parens (qualTyName t <> "'pos(value)" <> comma <+> int (typeSize t)) )) <> semi <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> qualTyName t <+> "is" <> line <> "begin" <> line <> indent 2 ( translate_off ( "if unsigned(slv) <= " <> qualTyName t <> "'pos("<> qualTyName t <> "'high) then" ) <> line <> indent 2 ( "return" <+> qualTyName t <> "'val" <> parens ("to_integer" <> parens ("unsigned" <> parens "slv"))) <> semi <> line <> translate_off ( "else" <> line <> indent 2 ( "return" <+> qualTyName t <> "'val(0)") <> semi <> line <> "end if" <> semi ) ) <> line <> "end" <> semi ) where translate_off body = "-- pragma translate_off" <> line <> body <> line <> "-- pragma translate_on" funDec _ syn t@(Vector _ elTy) = Just ( "function" <+> "toSLV" <+> parens ("value : " <+> qualTyName t) <+> "return std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> qualTyName t <> semi , "function" <+> "toSLV" <+> parens ("value : " <+> qualTyName t) <+> "return std_logic_vector" <+> "is" <> line <> indent 2 ( "alias ivalue :" <+> qualTyName t <> "(1 to value'length) is value;" <> line <> "variable result :" <+> "std_logic_vector" <> parens ("1 to value'length * " <> int (typeSize elTy)) <> semi ) <> line <> "begin" <> line <> indent 2 ("for i in ivalue'range loop" <> line <> indent 2 ( "result" <> parens (parens ("(i - 1) * " <> int (typeSize elTy)) <+> "+ 1" <+> "to i*" <> int (typeSize elTy)) <+> ":=" <+> (case syn of Vivado -> "ivalue" <> parens ("i") _ -> "toSLV" <> parens ("ivalue" <> parens ("i"))) <> semi ) <> line <> "end" <+> "loop" <> semi <> line <> "return" <+> "result" <> semi ) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> qualTyName t <+> "is" <> line <> indent 2 ( "alias islv :" <+> "std_logic_vector" <> "(0 to slv'length - 1) is slv;" <> line <> "variable result :" <+> qualTyName t <> parens ("0 to slv'length / " <> eSz <+> "- 1") <> semi ) <> line <> "begin" <> line <> indent 2 ("for i in result'range loop" <> line <> indent 2 ( "result" <> parens "i" <+> ":=" <+> case syn of Vivado -> getElem <> semi _ | BitVector _ <- elTy -> getElem <> semi | otherwise -> "fromSLV" <> parens getElem <> semi ) <> line <> "end" <+> "loop" <> semi <> line <> "return" <+> "result" <> semi ) <> line <> "end" <> semi ) where eSz = int (typeSize elTy) getElem = "islv" <> parens ("i * " <> eSz <+> "to (i+1) * " <> eSz <+> "- 1") funDec _ _ (BitVector _) = Just ( "function" <+> "toSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <> semi , "function" <+> "toSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> "slv" <> semi) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <+> "is" <> line <> "begin" <> line <> indent 2 ("return" <+> "slv" <> semi) <> line <> "end" <> semi ) funDec _ syn t@(RTree _ elTy) = Just ( "function" <+> "toSLV" <+> parens ("value : " <+> qualTyName t) <+> "return std_logic_vector" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> qualTyName t <> semi , "function" <+> "toSLV" <+> parens ("value : " <+> qualTyName t) <+> "return std_logic_vector" <+> "is" <> line <> indent 2 ( "alias ivalue :" <+> qualTyName t <> "(1 to value'length) is value;" <> line <> "variable result :" <+> "std_logic_vector" <> parens ("1 to value'length * " <> int (typeSize elTy)) <> semi ) <> line <> "begin" <> line <> indent 2 ("for i in ivalue'range loop" <> line <> indent 2 ( "result" <> parens (parens ("(i - 1) * " <> int (typeSize elTy)) <+> "+ 1" <+> "to i*" <> int (typeSize elTy)) <+> ":=" <+> (case syn of Vivado -> "ivalue" <> parens ("i") _ -> "toSLV" <> parens ("ivalue" <> parens ("i"))) <> semi ) <> line <> "end" <+> "loop" <> semi <> line <> "return" <+> "result" <> semi ) <> line <> "end" <> semi <> line <> "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> qualTyName t <+> "is" <> line <> indent 2 ( "alias islv :" <+> "std_logic_vector" <> "(0 to slv'length - 1) is slv;" <> line <> "variable result :" <+> qualTyName t <> parens ("0 to slv'length / " <> eSz <+> "- 1") <> semi ) <> line <> "begin" <> line <> indent 2 ("for i in result'range loop" <> line <> indent 2 ( "result" <> parens "i" <+> ":=" <+> case syn of Vivado -> getElem <> semi _ | BitVector _ <- elTy -> getElem <> semi | otherwise -> "fromSLV" <> parens getElem <> semi ) <> line <> "end" <+> "loop" <> semi <> line <> "return" <+> "result" <> semi ) <> line <> "end" <> semi ) where eSz = int (typeSize elTy) getElem = "islv" <> parens ("i * " <> eSz <+> "to (i+1) * " <> eSz <+> "- 1") funDec _ _ _ = Nothing tyImports :: ModName -> VHDLM Doc tyImports nm = do libs <- Ap $ use libraries packs <- Ap $ use packages punctuate' semi $ sequence ([ "library IEEE" , "use IEEE.STD_LOGIC_1164.ALL" , "use IEEE.NUMERIC_STD.ALL" , "use IEEE.MATH_REAL.ALL" , "use std.textio.all" , "use work.all" , "use work." <> pretty (nm `TextS.append` "_types") <> ".all" ] ++ (map (("library" <+>) . pretty) (nub libs)) ++ (map (("use" <+>) . pretty) (nub packs))) -- TODO: Way too much happening on a single line port :: Num t => Identifier -> HWType -> VHDLM Doc -> Int -> Maybe Expr -> VHDLM (Doc, t) port (Id.toText -> elName) hwType portDirection fillToN iEM = (,fromIntegral $ TextS.length elName) <$> (encodingNote hwType <> fill fillToN (pretty elName) <+> colon <+> direction <+> sizedQualTyName hwType <> iE) where direction | isBiSignalIn hwType = "inout" | otherwise = portDirection iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM -- [Note] Hack entity attributes in architecture -- -- By default we print attributes inside the entity block. This conforms -- to the VHDL standard (IEEE Std 1076-1993, 5.1 Attribute specification, -- paragraph 9), and is subsequently implemented in this way by open-source -- simulators such as GHDL. --- -- Intel and Xilinx use their own annotation schemes unfortunately, which -- require attributes in the architecture. -- -- References: -- * https://www.mail-archive.com/ghdl-discuss@gna.org/msg03175.html -- * https://forums.xilinx.com/t5/Simulation-and-Verification/wrong-attribute-decorations-of-port-signals-generated-by-write/m-p/704905#M16265 -- * http://quartushelp.altera.com/15.0/mergedProjects/hdl/vhdl/vhdl_file_dir_chip.htm entity :: Component -> VHDLM Doc entity c = do syn <- Ap hdlSyn rec (p,ls) <- fmap unzip (ports (maximum ls)) "entity" <+> pretty (componentName c) <+> "is" <> line <> (case p of [] -> emptyDoc _ -> case syn of -- See: [Note] Hack entity attributes in architecture Other -> indent 2 (rports p <> if null attrs then emptyDoc else line <> line <> rattrs) <> line <> "end" <> semi _ -> indent 2 (rports p) <> line <> "end" <> semi ) where ports l = sequence $ [port iName hwType "in" l Nothing | (iName, hwType) <- inputs c] ++ [port oName hwType "out" l iEM | (_, (oName, hwType), iEM) <- outputs c] rports p = "port" <> (parens (align (vcat (punctuate semi (pure p))))) <> semi rattrs = renderAttrs (TextS.pack "signal") attrs attrs = inputAttrs ++ outputAttrs inputAttrs = [(id_, attr) | (id_, hwtype) <- inputs c, attr <- hwTypeAttrs hwtype] outputAttrs = [(id_, attr) | (_, (id_, hwtype), _) <- outputs c, attr <- hwTypeAttrs hwtype] architecture :: Component -> VHDLM Doc architecture c = do { ; syn <- Ap hdlSyn ; let attrs = case syn of -- See: [Note] Hack entity attributes in architecture Other -> declAttrs _ -> inputAttrs ++ outputAttrs ++ declAttrs ; nest 2 (("architecture structural of" <+> pretty (componentName c) <+> "is" <> line <> decls (declarations c)) <> line <> if null attrs then emptyDoc else line <> line <> renderAttrs (TextS.pack "signal") attrs) <> line <> nest 2 ("begin" <> line <> insts (declarations c)) <> line <> "end" <> semi } where netdecls = filter isNetDecl (declarations c) declAttrs = [(id_, attr) | NetDecl' _ id_ hwtype _ <- netdecls, attr <- hwTypeAttrs hwtype] inputAttrs = [(id_, attr) | (id_, hwtype) <- inputs c, attr <- hwTypeAttrs hwtype] outputAttrs = [(id_, attr) | (_, (id_, hwtype), _) <- outputs c, attr <- hwTypeAttrs hwtype] isNetDecl :: Declaration -> Bool isNetDecl NetDecl'{} = True isNetDecl _ = False 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 [ TextS.unpack name', "already assigned" , TextS.unpack type'', "while we tried to" , "add", TextS.unpack type' ] where 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 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 TextS.Text (TextS.Text, [(TextS.Text, TextS.Text)]) => [(Identifier, Attr TextS.Text)] -> t attrMap attrs0 = foldl go empty' attrs1 where attrs1 = map (first Id.toText) attrs0 empty' = HashMap.fromList [(k, (types HashMap.! k, [])) | k <- HashMap.keys types] types = attrTypes (map snd attrs1) go :: t -> (TextS.Text, Attr TextS.Text) -> t go map' attr = HashMap.adjust (go' attr) (attrName $ snd attr) map' go' :: (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 TextS.Text)] -> VHDLM Doc renderAttrs what (attrMap -> attrs) = vcat $ sequence $ intersperse " " $ map renderAttrGroup (HashMap.toList attrs) where renderAttrGroup :: (TextS.Text, (TextS.Text, [(TextS.Text, TextS.Text)])) -> VHDLM Doc renderAttrGroup (attrname, (typ, elems)) = ("attribute" <+> stringS attrname <+> colon <+> stringS typ <> semi) <> line <> (vcat $ sequence $ map (renderAttrDecl attrname) elems) renderAttrDecl :: TextS.Text -> (TextS.Text, TextS.Text) -> VHDLM Doc renderAttrDecl attrname (signalName, value) = "attribute" <+> stringS attrname <+> "of" <+> stringS signalName -- or component name <+> colon <+> stringS what <+> "is" -- "signal is" or "component is" <+> stringS value <> semi -- | Convert single attribute to VHDL syntax 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 -- | Append size information to given type string appendSize :: VHDLM Doc -> HWType -> VHDLM Doc appendSize baseType sizedType = case sizedType of BitVector n -> baseType <> parens (int (n-1) <+> "downto 0") Signed n -> baseType <> parens (int (n-1) <+> "downto 0") Unsigned n -> baseType <> parens (int (n-1) <+> "downto 0") Vector n _ -> baseType <> parens ("0 to" <+> int (n-1)) RTree d _ -> baseType <> parens ("0 to" <+> int ((2^d)-1)) MemBlob n _ -> baseType <> parens ("0 to" <+> int (n-1)) Annotated _ elTy -> appendSize baseType elTy _ -> baseType -- | Same as @qualTyName@, but instantiate generic types with their size. sizedQualTyName :: HWType -> VHDLM Doc sizedQualTyName (filterTransparent -> hwty) = appendSize (qualTyName hwty) hwty -- | Same as @tyName@, but instantiate generic types with their size. sizedTyName :: HWType -> VHDLM Doc sizedTyName (filterTransparent -> hwty) = appendSize (tyName hwty) hwty -- | Same as @tyName@, but return fully qualified name (name, including module) qualTyName :: HWType -> VHDLM Doc qualTyName (filterTransparent -> hwty) = case hwty of -- Builtin types: Bit -> tyName hwty Bool -> tyName hwty Signed _ -> tyName hwty Unsigned _ -> tyName hwty BitVector _ -> tyName hwty -- Transparent types: BiDirectional _ elTy -> qualTyName elTy Annotated _ elTy -> qualTyName elTy -- Custom types: _ -> do pkgCtx <- Ap (use tyPkgCtx) modName <- Ap (use modNm) if pkgCtx then tyName hwty else pretty modName <> "_types." <> tyName hwty -- | Generates a unique name for a given type. This action will cache its -- results, thus returning the same answer for the same @HWType@ argument. -- Some type names do not have specific names, but are instead basic types -- in VHDL. tyName :: HWType -- ^ Type to name -> VHDLM Doc tyName t = do nm <- tyName' False t pretty nm -- | Generates a unique name for a given type. This action will cache its -- results, thus returning the same answer for the same @HWType@ argument. -- Some type names do not have specific names, but are instead basic types -- in VHDL. tyName' :: HasCallStack => Bool -- ^ Include length information in first part of name. For example, say we -- want to generate a name for a vector, where the vector is of length -- 5, and signed has 64 bits. When given `True`, this function would -- generate `array_of_5_signed_64`. When given `False` it would generate -- `array_of_signed_64`. Note that parts other than the first part will always -- have length information. This option is useful for generating names in -- VHDL, where the `False` case is needed to create generic types. -> HWType -- ^ Type to name -> VHDLM TextS.Text tyName' rec0 (filterTransparent -> t) = do Ap (tyCache %= HashSet.insert t) case t of KnownDomain {} -> return (error ($(curLoc) ++ "Forced to print KnownDomain tyName")) Void _ -> return (error ($(curLoc) ++ "Forced to print Void tyName: " ++ show t)) Bool -> return "boolean" Signed n -> let app = if rec0 then ["_", showt n] else [] in return $ TextS.concat $ "signed" : app Unsigned n -> let app = if rec0 then ["_", showt n] else [] in return $ TextS.concat $ "unsigned" : app BitVector n -> let app = if rec0 then ["_", showt n] else [] in return $ TextS.concat $ "std_logic_vector" : app String -> return "string" Integer -> return "integer" Bit -> return "std_logic" Vector n elTy -> do elTy' <- tyName' True elTy let nm = TextS.concat [ "array_of_" , if rec0 then showt n `TextS.append` "_" else "" , elTy'] Ap $ makeCached (t, rec0) nameCache (return nm) RTree n elTy -> do elTy' <- tyName' True elTy let nm = TextS.concat [ "tree_of_" , if rec0 then showt n `TextS.append` "_" else "" , elTy'] Ap $ makeCached (t, rec0) nameCache (return nm) -- TODO: nice formatting for Index. I.e., 2000 = 2e3, 1024 = 2pow10 Index n -> return ("index_" `TextS.append` showt n) 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) Enable nm0 -> let nm1 = "en_" `TextS.append` nm0 in Ap $ makeCached (t, False) nameCache (userTyName "en" nm1 t) Sum nm _ -> Ap $ makeCached (t, False) nameCache (userTyName "sum" nm t) CustomSum nm _ _ _ -> Ap $ makeCached (t, False) nameCache (userTyName "sum" nm t) SP nm _ -> Ap $ makeCached (t, False) nameCache (userTyName "sp" nm t) CustomSP nm _ _ _ -> Ap $ makeCached (t, False) nameCache (userTyName "sp" nm t) Product nm _ _ -> Ap $ makeCached (t, False) nameCache (userTyName "product" nm t) CustomProduct nm _ _ _ _ -> Ap $ makeCached (t, False) nameCache (userTyName "product" nm t) Annotated _ hwTy -> tyName' rec0 hwTy BiDirectional _ hwTy -> tyName' rec0 hwTy FileType -> return "file" ty -> return (error ($(curLoc) ++ show ty ++ " not filtered by filterTransparent")) -- | Returns underlying type of given HWType. That is, the type by which it -- eventually will be represented in VHDL. normaliseType :: RenderEnums -> HWType -> HWType normaliseType enums@(RenderEnums e) hwty = case hwty of Void {} -> hwty KnownDomain {} -> hwty -- Base types: Bool -> hwty Signed _ -> hwty Unsigned _ -> hwty BitVector _ -> hwty String -> hwty Integer -> hwty Bit -> hwty FileType -> hwty -- Complex types, for which a user defined type is made in VHDL: Vector _ _ -> hwty RTree _ _ -> hwty Product _ _ _ -> hwty Sum _ _ -> if e then hwty else BitVector (typeSize hwty) MemBlob n m -> Vector n (BitVector m) -- 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) CustomSP _ _ _ _ -> BitVector (typeSize hwty) SP _ _ -> BitVector (typeSize hwty) CustomSum _ _ _ _ -> BitVector (typeSize hwty) CustomProduct {} -> BitVector (typeSize hwty) -- Transparent types: Annotated _ elTy -> normaliseType enums elTy BiDirectional _ elTy -> normaliseType enums elTy -- | Recursively remove transparent types from given type filterTransparent :: HWType -> HWType filterTransparent hwty = case hwty of Bool -> hwty Signed _ -> hwty Unsigned _ -> hwty BitVector _ -> hwty String -> hwty Integer -> hwty Bit -> hwty Clock _ -> hwty ClockN _ -> hwty Reset _ -> hwty Enable _ -> hwty Index _ -> hwty Sum _ _ -> hwty CustomSum _ _ _ _ -> hwty FileType -> hwty MemBlob n m -> Vector n (BitVector m) Vector n elTy -> Vector n (filterTransparent elTy) RTree n elTy -> RTree n (filterTransparent elTy) Product nm labels elTys -> Product nm labels (map filterTransparent elTys) SP nm0 constrs -> SP nm0 (map (\(nm1, tys) -> (nm1, map filterTransparent tys)) constrs) CustomSP nm0 drepr size constrs -> CustomSP nm0 drepr size (map (\(repr, nm1, tys) -> (repr, nm1, map filterTransparent tys)) constrs) CustomProduct nm0 drepr size maybeFieldNames constrs -> CustomProduct nm0 drepr size maybeFieldNames (map (second filterTransparent) constrs) -- Transparent types: Annotated _ elTy -> filterTransparent elTy BiDirectional _ elTy -> filterTransparent elTy Void {} -> hwty KnownDomain {} -> hwty -- | Create a unique type name for user defined types userTyName :: IdentifierText -- ^ Default name -> IdentifierText -- ^ Identifier stored in @hwTy@ -> HWType -- ^ Type to give a (unique) name -> StateT VHDLState Identity IdentifierText userTyName dflt nm0 hwTy = do tyCache %= HashSet.insert hwTy Id.toText <$> Id.makeBasicOr (last (TextS.splitOn "." nm0)) dflt -- | Convert a Netlist HWType to an error VHDL value for that type sizedQualTyNameErrValue :: HWType -> VHDLM Doc sizedQualTyNameErrValue Bool = do udf <- Ap (use undefValue) case udf of Just (Just 0) -> "false" _ -> "true" sizedQualTyNameErrValue Bit = singularErrValue sizedQualTyNameErrValue t@(Vector n elTy) = do syn <-Ap hdlSyn case syn of Vivado -> qualTyName t <> "'" <> parens (int 0 <+> "to" <+> int (n-1) <+> rarrow <+> "std_logic_vector'" <> parens (int 0 <+> "to" <+> int (typeSize elTy - 1) <+> rarrow <+> singularErrValue)) _ -> qualTyName t <> "'" <> parens (int 0 <+> "to" <+> int (n-1) <+> rarrow <+> sizedQualTyNameErrValue elTy) sizedQualTyNameErrValue t@(RTree n elTy) = do syn <-Ap hdlSyn case syn of Vivado -> qualTyName t <> "'" <> parens (int 0 <+> "to" <+> int (2^n - 1) <+> rarrow <+> "std_logic_vector'" <> parens (int 0 <+> "to" <+> int (typeSize elTy - 1) <+> rarrow <+> singularErrValue)) _ -> qualTyName t <> "'" <> parens (int 0 <+> "to" <+> int (2^n - 1) <+> rarrow <+> sizedQualTyNameErrValue elTy) sizedQualTyNameErrValue t@(Product _ _ elTys) = qualTyName t <> "'" <> tupled (mapM sizedQualTyNameErrValue elTys) sizedQualTyNameErrValue t@(Sum _ _) = do -- No undefined / don't care for enums, so just set it to the first value RenderEnums enums <- Ap renderEnums if enums then tyName t <> "'val" <> parens (int 0) 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 {}) = return (error ($(curLoc) ++ "[CLASH BUG] Forced to print Void error value")) sizedQualTyNameErrValue String = "\"ERROR\"" sizedQualTyNameErrValue t = qualTyName t <> "'" <> parens (int 0 <+> "to" <+> int (typeSize t - 1) <+> rarrow <+> singularErrValue) singularErrValue :: VHDLM Doc singularErrValue = do udf <- Ap (use undefValue) case udf of Nothing -> "'-'" Just Nothing -> "'0'" Just (Just x) -> "'" <> int x <> "'" vhdlRecSel :: HWType -> Int -> VHDLM Doc vhdlRecSel p@(Product _ labels tys) i = tyName p <> selectProductField labels tys i vhdlRecSel ty i = tyName ty <> "_sel" <> int i decls :: [Declaration] -> VHDLM Doc decls [] = emptyDoc decls ds = do rec (dsDoc,ls) <- fmap (unzip . catMaybes) $ mapM (decl (maximum ls)) ds case dsDoc of [] -> emptyDoc _ -> 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 <+> sizedQualTyName ty <> iE <> semi) where addNote n = mappend ("--" <+> pretty n <> line) iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM decl _ (InstDecl Comp _ attrs nm _ gens (NamedPortMap pms)) = fmap (Just . (,0)) $ do { rec (p,ls) <- fmap unzip $ sequence [ (,formalLength i) <$> fill (maximum ls) (expr_ False i) <+> colon <+> portDir dir <+> sizedQualTyName ty | (i,dir,ty,_) <- pms ] ; rec (g,lsg) <- fmap unzip $ sequence [ (,formalLength i) <$> fill (maximum lsg) (expr_ False i) <+> colon <+> tyName ty | (i,ty,_) <- gens] ; "component" <+> pretty nm <> line <> ( if null g then emptyDoc else indent 2 ("generic" <> line <> tupledSemi (pure g) <> semi) <> line ) <> indent 2 ("port" <+> tupledSemi (pure p) <> semi) <> line <> "end component" <> semi <> line <> attrs' } where formalLength (Identifier i _) = fromIntegral (TextS.length (Id.toText i)) formalLength _ = 0 portDir In = "in" portDir Out = "out" attrs' | null attrs = emptyDoc | otherwise = renderAttrs (TextS.pack "component") [(nm, a) | a <- attrs] decl _ _ = return Nothing noEmptyInit :: VHDLM Doc -> VHDLM Doc noEmptyInit d = do d1 <- d if isEmpty d1 then emptyDoc else (space <> ":=" <+> d) stdMatch :: Bits a => Int -> a -> a -> String stdMatch 0 _mask _value = [] stdMatch size mask value = symbol : stdMatch (size - 1) mask value where symbol = if testBit mask (size - 1) then if testBit value (size - 1) then '1' else '0' else '-' patLitCustom' :: Bits a => VHDLM Doc -> Int -> a -> a -> VHDLM Doc patLitCustom' var size mask value = let mask' = string $ T.pack $ stdMatch size mask value in "std_match" <> parens (dquotes mask' <> comma <+> var) patLitCustom :: VHDLM Doc -> HWType -> Literal -> VHDLM Doc patLitCustom var (CustomSum _name _dataRepr size reprs) (NumLit (fromIntegral -> i)) = patLitCustom' var size mask value where ((ConstrRepr' _name _n mask value _anns), _id) = reprs !! i patLitCustom var (CustomSP _name _dataRepr size reprs) (NumLit (fromIntegral -> i)) = patLitCustom' var size mask value where ((ConstrRepr' _name _n mask value _anns), _id, _tys) = reprs !! i patLitCustom _ x y = error $ $(curLoc) ++ unwords [ "You can only pass CustomSP / CustomSum and a NumLit to this function," , "not", show x, "and", show y] insts :: [Declaration] -> VHDLM Doc insts [] = emptyDoc insts (TickDecl (Comment c):ds) = comment "--" c <> line <> insts ds insts (TickDecl (Directive d):ds) = pretty d <> ";" <> line <> insts ds insts (d:ds) = do d' <- inst_ d case d' of Just doc -> pure doc <> line <> line <> insts ds _ -> insts ds -- | Helper function for inst_, handling CustomSP and CustomSum inst_' :: Identifier -> Expr -> HWType -> [(Maybe Literal, Expr)] -> VHDLM (Maybe Doc) inst_' id_ scrut scrutTy es = fmap Just $ (pretty id_ <+> larrow <+> align (vcat (conds esNub) <> semi)) where esMod = map (first (fmap (patMod scrutTy))) es esNub = nubBy ((==) `on` fst) esMod var = expr_ True scrut conds :: [(Maybe Literal,Expr)] -> VHDLM [Doc] conds [] = return [] conds [(_,e)] = expr_ False e <:> return [] conds ((Nothing,e):_) = expr_ False e <:> return [] conds ((Just c ,e):es') = expr_ False e <+> "when" <+> patLitCustom var scrutTy c <+> "else" <:> conds es' -- | Turn a Netlist Declaration to a VHDL concurrent block inst_ :: Declaration -> VHDLM (Maybe Doc) 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" <+> expr_ False scrut <+> "else" ,expr_ False f <> semi ])) where (t,f) = if b then (l,r) else (r,l) inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSP _ _ _ _) es) = inst_' id_ scrut scrutTy es inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSum _ _ _ _) es) = inst_' id_ scrut scrutTy es inst_ (CondAssignment id_ _ scrut scrutTy@(CustomProduct _ _ _ _ _) es) = inst_' id_ scrut scrutTy es inst_ (CondAssignment id_ _sig scrut scrutTy es) = fmap Just $ "with" <+> parens (expr_ True scrut) <+> "select" <> line <> indent 2 (pretty id_ <+> larrow <+> align (vcat (punctuate comma (conds esNub)) <> semi)) where esMod = map (first (fmap (patMod scrutTy))) es esNub = nubBy ((==) `on` fst) esMod conds :: [(Maybe Literal,Expr)] -> VHDLM [Doc] conds [] = return [] conds [(_,e)] = expr_ False e <+> "when" <+> "others" <:> return [] conds ((Nothing,e):_) = expr_ False e <+> "when" <+> "others" <:> return [] conds ((Just c ,e):es') = expr_ False e <+> "when" <+> patLit scrutTy c <:> conds es' inst_ (InstDecl entOrComp libM _ nm lbl gens pms0) = do maybe (return ()) (\lib -> Ap (libraries %= (T.fromStrict lib:))) libM fmap Just $ nest 2 $ pretty lbl <+> colon <> entOrComp' <+> maybe emptyDoc ((<> ".") . pretty) libM <> pretty nm <> line <> gms <> pms2 <> semi where gms | [] <- gens = emptyDoc | otherwise = do rec (p,ls) <- fmap unzip $ sequence [ (,formalLength i) <$> fill (maximum ls) (expr_ False i) <+> "=>" <+> expr_ False e | (i,_,e) <- gens] nest 2 ("generic map" <> line <> tupled (pure p)) <> line pms2 = do rec (p,ls) <- case pms0 of NamedPortMap pms1 -> fmap unzip $ sequence [pm ls i e | (i,_,_,e) <- pms1] IndexedPortMap pms1 -> fmap unzip $ sequence [pmi e | (_,_,e) <- pms1] nest 2 $ "port map" <> line <> tupled (pure p) pm ls i e = (,formalLength i) <$> fill (maximum ls) (expr_ False i) <+> "=>" <+> expr_ False e pmi e = (,0) <$> expr_ False e formalLength (Identifier i _) = fromIntegral (TextS.length (Id.toText i)) formalLength _ = 0 entOrComp' = case entOrComp of { Entity -> " entity"; Comp -> " component"; Empty -> ""} inst_ (BlackBoxD _ libs imps inc bs bbCtx) = fmap Just (Ap (column (renderBlackBox libs imps inc bs bbCtx))) inst_ (ConditionalDecl cond _) = do traceM $ "WARNING: Conditional compilation is not supported in VHDL. Discarding code conditional on " <> TextS.unpack cond return Nothing inst_ _ = return Nothing -- | Render a data constructor application for data constructors having a -- custom bit representation. customReprDataCon :: DataRepr' -- ^ Custom representation of data type -> ConstrRepr' -- ^ Custom representation of a specific constructor of @dataRepr@ -> [(HWType, Expr)] -- ^ Arguments applied to constructor -> VHDLM Doc customReprDataCon dataRepr constrRepr args = "std_logic_vector'" <> parens (hcat $ punctuate " & " $ mapM range origins) where DataRepr' _typ size _constrs = dataRepr -- Build bit representations for all constructor arguments argSLVs = map (uncurry toSLV) args :: [VHDLM Doc] -- Spread bits of constructor arguments using masks origins = bitOrigins dataRepr constrRepr :: [BitOrigin] range :: BitOrigin -> VHDLM Doc range (Lit (bitsToBits -> ns)) = dquotes $ hcat $ mapM bit_char ns range (Field n start end) = -- We want to select the bits starting from 'start' downto and including -- 'end'. We cannot use "(start downto end)" in VHDL, as the preceeding -- expression might be anything. This notation only works on identifiers -- unfortunately. let fsize = start - end + 1 in let expr' = argSLVs !! n in -- HACK: While expr' is a std_logic_vector (see call `toSLV`), it cannot -- be cast to unsigned in case of literals. This is fixed by explicitly -- casting it to std_logic_vector. let unsigned = "unsigned" <> parens ("std_logic_vector'" <> parens expr') in if | fsize == size -> -- If sizes are equal, rotating / resizing amounts to doing nothing expr' | end == 0 -> -- Rotating is not necessary if relevant bits are already at the end let resized = "resize" <> parens (unsigned <> comma <> int fsize) in "std_logic_vector" <> parens resized | otherwise -> -- Select bits 'start' downto and including 'end' let rotated = unsigned <+> "srl" <+> int end in let resized = "resize" <> parens (rotated <> comma <> int fsize) in "std_logic_vector" <> parens resized -- | Turn a Netlist expression into a VHDL expression expr_ :: HasCallStack => Bool -- ^ Enclose in parentheses? -> Expr -- ^ Expr to convert -> VHDLM Doc expr_ _ (Literal sizeM lit) = exprLit sizeM lit expr_ _ (Identifier id_ Nothing) = pretty id_ expr_ _ (Identifier id_ (Just m)) = do syn <- Ap hdlSyn maybe (pretty id_) (foldr renderModifier (pretty id_)) (buildModifier syn [] m) expr_ b (DataCon _ (DC (Void {}, -1)) [e]) = expr_ b e expr_ _ (DataCon ty@(Vector 0 _) _ _) = sizedQualTyNameErrValue ty expr_ _ (DataCon ty@(Vector 1 elTy) _ [e]) = do syn <- Ap hdlSyn case syn of Vivado -> qualTyName ty <> "'" <> parens (int 0 <+> rarrow <+> toSLV elTy e) _ -> qualTyName ty <> "'" <> parens (int 0 <+> rarrow <+> expr_ False e) expr_ _ e@(DataCon ty@(Vector _ elTy) _ [e1,e2]) = do syn <- Ap hdlSyn case syn of -- When targeting Vivado, arrays must use std_logic_vector for elements. Vivado -> qualTyName ty <> "'" <> case vectorChain e of Just es -> align (tupled (mapM (toSLV elTy) es)) Nothing -> parens ("std_logic_vector'" <> parens (toSLV elTy e1) <+> "&" <+> expr_ False e2) _ -> qualTyName ty <> "'" <> case vectorChain e of Just es -> align (tupled (mapM (expr_ False) es)) Nothing -> parens (qualTyName elTy <> "'" <> parens (expr_ False e1) <+> "&" <+> expr_ False e2) expr_ _ (DataCon ty@(MemBlob n m) _ [n0, m0, _, runs, _, ends]) | Literal _ (NumLit n1) <- n0 , n == fromInteger n1 , Literal _ (NumLit m1) <- m0 , m == fromInteger m1 , Literal Nothing (StringLit runs0) <- runs , Literal Nothing (StringLit ends0) <- ends , es <- unpackNats n m (B8.pack runs0) (B8.pack ends0) = let el val = exprLit (Just (BitVector m, m)) (BitVecLit 0 $ toInteger val) in qualTyName ty <> "'" <> (align $ tupled $ mapM el es) expr_ _ (DataCon ty@(RTree 0 elTy) _ [e]) = do syn <- Ap hdlSyn case syn of Vivado -> qualTyName ty <> "'" <> parens (int 0 <+> rarrow <+> toSLV elTy e) _ -> qualTyName ty <> "'" <> parens (int 0 <+> rarrow <+> expr_ False e) expr_ _ e@(DataCon ty@(RTree d elTy) _ [e1,e2]) = qualTyName ty <> "'" <> case rtreeChain e of Just es -> tupled (mapM (expr_ False) es) Nothing -> parens (qualTyName (RTree (d-1) elTy) <> "'" <> parens (expr_ False e1) <+> "&" <+> expr_ False e2) expr_ _ (DataCon (SP {}) (DC (BitVector _,_)) es) = assignExpr where argExprs = map (parens . expr_ False) es assignExpr = "std_logic_vector'" <> parens (hcat $ punctuate " & " $ sequence argExprs) expr_ _ (DataCon ty@(SP _ args) (DC (_,i)) es) = assignExpr where argTys = snd $ args !! i dcSize = conSize ty + sum (map typeSize argTys) dcExpr = expr_ False (dcToExpr ty i) argExprs = map parens (zipWith toSLV argTys es) extraArg = case typeSize ty - dcSize of 0 -> [] n -> [bits (replicate n U)] assignExpr = "std_logic_vector'" <> parens (hcat $ punctuate " & " $ sequence (dcExpr:argExprs ++ extraArg)) expr_ _ (DataCon ty@(Sum _ _) (DC (_,i)) []) = do RenderEnums enums <- Ap renderEnums if enums then tyName ty <> "'" <> parens (enumVariantName ty i) else expr_ False (dcToExpr ty i) expr_ _ (DataCon ty@(CustomSum _ _ _ tys) (DC (_,i)) []) = let (ConstrRepr' _ _ _ value _) = fst $ tys !! i in "std_logic_vector" <> parens ("to_unsigned" <> parens (int (fromIntegral value) <> comma <> int (typeSize ty))) expr_ _ (DataCon (CustomSP _ dataRepr _size args) (DC (_,i)) es) = let (cRepr, _, argTys) = args !! i in customReprDataCon dataRepr cRepr (zipEqual argTys es) expr_ _ (DataCon (CustomProduct _ dataRepr _size _labels tys) _ es) | DataRepr' _typ _size [cRepr] <- dataRepr = customReprDataCon dataRepr cRepr (zipEqual (map snd tys) es) expr_ _ (DataCon ty@(Product _ labels tys) _ es) = tupled $ zipWithM (\i e' -> tyName ty <> selectProductField labels tys i <+> rarrow <+> expr_ False e') [0..] es expr_ _ (DataCon (Enable _) _ [e]) = expr_ False e expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Signed.fromInteger#" , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx = exprLit (Just (Signed (fromInteger n),fromInteger n)) i expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Unsigned.fromInteger#" , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx = exprLit (Just (Unsigned (fromInteger n),fromInteger n)) i expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.BitVector.fromInteger#" , [Literal _ (NumLit n), Literal _ m, Literal _ i] <- extractLiterals bbCtx , 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 , NumLit m' <- m , NumLit i' <- i = exprLit (Just (Bit,1)) (BitLit $ toBit m' i') expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Index.fromInteger#" , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx , Just k <- clogBase 2 n , let k' = max 1 k = exprLit (Just (Unsigned k',k')) i expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Index.maxBound#" , [Literal _ (NumLit n)] <- extractLiterals bbCtx , n > 0 , Just k <- clogBase 2 n , let k' = max 1 k = exprLit (Just (Unsigned k',k')) (NumLit (n-1)) expr_ b (BlackBoxE _ libs imps inc bs bbCtx b') = do parenIf (b || b') (Ap (renderBlackBox libs imps inc bs bbCtx <*> pure 0)) expr_ _ (DataTag Bool (Left id_)) = "tagToEnum" <> parens (pretty id_) expr_ _ (DataTag Bool (Right id_)) = "dataToTag" <> parens (pretty id_) expr_ _ (DataTag hty@(Sum _ _) (Left id_)) = do RenderEnums enums <- Ap renderEnums nm <- Ap $ use modNm let inner = "std_logic_vector" <> parens ("resize" <> parens ("unsigned" <> parens ("std_logic_vector" <> parens (pretty id_)) <> "," <> int (typeSize hty))) if enums then pretty nm <> "_types.fromSLV" <> parens inner else inner expr_ _ (DataTag (Sum _ _) (Right id_)) = do RenderEnums enums <- Ap renderEnums iw <- Ap $ use intWidth nm <- Ap $ use modNm let inner = if enums then pretty nm <> "_types.toSLV" <> parens (pretty id_) else pretty id_ "signed" <> parens ("std_logic_vector" <> parens ("resize" <> parens ("unsigned" <> parens inner <> "," <> int iw))) expr_ _ (DataTag (Product {}) (Right _)) = do iw <- Ap $ use intWidth "to_signed" <> parens (int 0 <> "," <> int iw) expr_ _ (DataTag hty@(SP _ _) (Right id_)) = do { ; iw <- Ap $ use intWidth ; "signed" <> parens ("std_logic_vector" <> parens ( "resize" <> parens ("unsigned" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int end)) <> "," <> int iw))) } where start = typeSize hty - 1 end = typeSize hty - conSize hty expr_ _ (DataTag (Vector 0 _) (Right _)) = do iw <- Ap $ use intWidth "to_signed" <> parens (int 0 <> "," <> int iw) expr_ _ (DataTag (Vector _ _) (Right _)) = do iw <- Ap $ use intWidth "to_signed" <> parens (int 1 <> "," <> int iw) expr_ _ (DataTag (RTree 0 _) (Right _)) = do iw <- Ap $ use intWidth "to_signed" <> parens (int 0 <> "," <> int iw) expr_ _ (DataTag (RTree _ _) (Right _)) = do iw <- Ap $ use intWidth "to_signed" <> parens (int 1 <> "," <> int iw) expr_ _ (ToBv topM hwty e) = do nm <- Ap $ use modNm case topM of Nothing -> pretty nm <> "_types" <> dot <> "toSLV" <> parens (qualTyName hwty <> "'" <> parens (expr_ False e)) Just t -> pretty t <> dot <> pretty t <> "_types" <> dot <> "toSLV" <> parens (expr_ False e) expr_ _ (FromBv topM hwty e) = do nm <- Ap $ use modNm qualTyName hwty <> "'" <> parens (maybe (pretty nm <> "_types" ) (\t -> pretty t <> dot <> pretty t <> "_types") topM <> dot <> "fromSLV" <> parens (expr_ False e)) expr_ _ e = error $ $(curLoc) ++ (show e) -- empty otherSize :: [HWType] -> Int -> Int otherSize _ n | n < 0 = 0 otherSize [] _ = 0 otherSize (a:as) n = typeSize a + otherSize as (n-1) vectorChain :: Expr -> Maybe [Expr] vectorChain (DataCon (Vector 0 _) _ _) = Just [] vectorChain (DataCon (Vector 1 _) _ [e]) = Just [e] vectorChain (DataCon (Vector _ _) _ [e1,e2]) = Just e1 <:> vectorChain e2 vectorChain _ = Nothing rtreeChain :: Expr -> Maybe [Expr] rtreeChain (DataCon (RTree 1 _) _ [e]) = Just [e] rtreeChain (DataCon (RTree _ _) _ [e1,e2]) = liftA2 (++) (rtreeChain e1) (rtreeChain e2) rtreeChain _ = Nothing exprLit :: Maybe (HWType,Size) -> Literal -> VHDLM Doc exprLit Nothing (NumLit i) = integer i exprLit (Just (hty,sz)) (NumLit i) = case hty of Unsigned n | i < (-2^(31 :: Integer)) -> "unsigned" <> parens ("std_logic_vector" <> parens ("signed'" <> parens lit)) | i < 0 -> "unsigned" <> parens ("std_logic_vector" <> parens ("to_signed" <> parens(integer i <> "," <> int n))) | i < 2^(31 :: Integer) -> "to_unsigned" <> parens (integer i <> "," <> int n) | otherwise -> "unsigned'" <> parens lit Signed n | i < 2^(31 :: Integer) && i > (-2^(31 :: Integer)) -> "to_signed" <> parens (integer i <> "," <> int n) | otherwise -> "signed'" <> parens lit BitVector _ -> "std_logic_vector'" <> parens lit Bit -> squotes (int (fromInteger i `mod` 2)) _ -> blit where validHexLit = sz `mod` 4 == 0 && sz /= 0 lit = if validHexLit then hlit else blit blit = bits (toBits sz i) i' = case hty of Signed _ -> let mask = 2^(sz-1) in case divMod i mask of (s,i'') | even s -> i'' | otherwise -> i'' - mask _ -> i `mod` 2^sz hlit = (if i' < 0 then "-" else emptyDoc) <> hex (toHex sz i') exprLit (Just (hty,sz)) (BitVecLit m i) = case m of 0 -> exprLit (Just (hty,sz)) (NumLit i) _ -> "std_logic_vector'" <> parens bvlit where bvlit = bits (toBits' sz m i) exprLit _ (BoolLit t) = if t then "true" else "false" exprLit _ (BitLit b) = squotes $ bit_char b exprLit _ (StringLit s) = pretty . T.pack $ show s exprLit _ l = error $ $(curLoc) ++ "exprLit: " ++ show l patLit :: HWType -> Literal -> VHDLM Doc patLit Bit (NumLit i) = if i == 0 then "'0'" else "'1'" patLit hwty (NumLit i) = do RenderEnums enums <- Ap renderEnums case hwty of Sum{} | enums -> tyName hwty <> "'" <> parens (enumVariantName hwty (fromInteger i)) _ -> let sz = conSize hwty in case sz `mod` 4 of 0 -> hex (toHex sz i) _ -> bits (toBits sz i) patLit _ l = exprLit Nothing l patMod :: HWType -> Literal -> Literal patMod hwTy (NumLit i) = NumLit (i `mod` (2 ^ typeSize hwTy)) patMod _ l = l toBits :: Integral a => Int -> a -> [Bit] toBits size val = map (\x -> if odd x then H else L) $ reverse $ take size $ map (`mod` 2) $ iterate (`div` 2) val toBits' :: Integral a => Int -> a -> a -> [Bit] toBits' size msk val = map (\(m,i) -> if odd m then U else (if odd i then H else L)) $ ( reverse . take size) $ zip ( map (`mod` 2) $ iterate (`div` 2) msk) ( map (`mod` 2) $ iterate (`div` 2) val) bits :: [Bit] -> VHDLM Doc bits = dquotes . hcat . mapM bit_char toHex :: Int -> Integer -> String 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)) bit_char :: Bit -> VHDLM Doc bit_char H = char '1' bit_char L = char '0' bit_char U = do udf <- Ap (use undefValue) case udf of Nothing -> char '-' Just Nothing -> char '0' Just (Just i) -> int i bit_char Z = char 'Z' toSLV :: HasCallStack => HWType -> Expr -> VHDLM Doc toSLV Bool e = do nm <- Ap $ use modNm pretty nm <> "_types.toSLV" <> parens (expr_ False e) toSLV Bit e = do nm <- Ap $ use modNm pretty nm <> "_types.toSLV" <> parens (expr_ False e) 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) toSLV (Enable _) e = do nm <- Ap $ use modNm pretty nm <> "_types.toSLV" <> parens (expr_ False e) toSLV (BitVector _) e = expr_ True e toSLV (Signed _) e = "std_logic_vector" <> parens (expr_ False e) toSLV (Unsigned _) e = "std_logic_vector" <> parens (expr_ False e) toSLV (Index _) e = "std_logic_vector" <> parens (expr_ False e) toSLV (Sum _ _) e = do RenderEnums enums <- Ap renderEnums if enums then do nm <- Ap $ use modNm pretty nm <> "_types.toSLV" <> parens (expr_ False e) else expr_ False e toSLV (CustomSum _ _dataRepr size reprs) (DataCon _ (DC (_,i)) _) = let (ConstrRepr' _ _ _ value _) = fst $ reprs !! i in let unsigned = "to_unsigned" <> parens (int (fromIntegral value) <> comma <> int size) in "std_logic_vector" <> parens unsigned toSLV (CustomSum {}) e = "std_logic_vector" <> parens (expr_ False e) toSLV t@(Product _ labels tys) (Identifier id_ Nothing) = do selIds' <- sequence selIds encloseSep lparen rparen " & " (zipWithM toSLV tys selIds') where tName = tyName t selNames = map (fmap (Id.unsafeMake . T.toStrict . renderOneLine) ) [pretty id_ <> dot <> tName <> selectProductField labels tys i | i <- [0..(length tys)-1]] selIds = map (fmap (\n -> Identifier n Nothing)) selNames toSLV (Product _ _ tys) (DataCon _ _ es) | equalLength tys es = -- Need equalLenght for code seen in ZipWithUnitVector encloseSep lparen rparen " & " (zipWithM toSLV tys es) toSLV (CustomProduct _ _ _ _ _) e = do -- Custom representations are represented as bitvectors in HDL, so we don't -- need to do anything. expr_ False e toSLV t@(Product _ _ _) e = do nm <- Ap $ use modNm pretty nm <> "_types.toSLV" <> parens (qualTyName t <> "'" <> parens (expr_ False e)) toSLV (SP _ _) e = expr_ False e toSLV (CustomSP _ _ _ _) e = -- Custom representations are represented as bitvectors in HDL, so we don't -- need to do anything. expr_ False e toSLV (Vector n elTy) (Identifier id_ Nothing) = do selIds' <- sequence selIds syn <- Ap hdlSyn parens (vcat $ punctuate " & " (case syn of Vivado -> mapM (expr_ False) selIds' _ -> mapM (toSLV elTy) selIds')) where selNames = map (fmap (Id.unsafeMake . T.toStrict . renderOneLine) ) $ [pretty id_ <> parens (int i) | i <- [0 .. (n-1)]] selIds = map (fmap (`Identifier` Nothing)) selNames -- Don't split up newtype wrappers, or void-filtered types toSLV (Vector _ _) e@(DataCon _ (DC (Void Nothing, -1)) _) = do nm <- Ap $ use modNm pretty nm <> "_types.toSLV" <> parens (expr_ False e) toSLV (Vector n elTy) (DataCon _ _ es) = "std_logic_vector'" <> (parens $ vcat $ punctuate " & " (zipWithM toSLV [elTy,Vector (n-1) elTy] es)) toSLV (Vector _ _) e = do nm <- Ap $ use modNm pretty nm <> "_types.toSLV" <> parens (expr_ False e) toSLV (RTree _ _) e = do nm <- Ap (use modNm) pretty (TextS.toLower nm) <> "_types.toSLV" <> parens (expr_ False e) toSLV hty e = error $ $(curLoc) ++ "toSLV:\n\nType: " ++ show hty ++ "\n\nExpression: " ++ show e dcToExpr :: HWType -> Int -> Expr dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i)) larrow :: VHDLM Doc larrow = "<=" rarrow :: VHDLM Doc rarrow = "=>" parenIf :: Monad m => Bool -> Ap m Doc -> Ap m Doc parenIf True = parens parenIf False = id punctuate' :: Monad m => Ap m Doc -> Ap m [Doc] -> Ap m Doc punctuate' s d = vcat (punctuate s d) <> s 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 encodingNote _ = emptyDoc tupledSemi :: Applicative f => f [Doc] -> f Doc tupledSemi = align . encloseSep (flatAlt (lparen <+> emptyDoc) lparen) (flatAlt (emptyDoc <+> rparen) rparen) (semi <+> emptyDoc) -- | VHDL name modifiers data VHDLModifier -- | SLV slice (descending index) = Range Range -- | Element selection | Idx Int -- | Array slice (ascending index) | Slice Int Int -- | Selected names | Select (VHDLM Doc) -- | Projecting a 'Word#' out of a 'Word8', or 'Int#' ouf of an 'Int8', see -- [Note] integer projection | Resize -- | Projecting a 'Natural' out of a 'BitVector', see [Note] bitvector projection | ResizeAndConvert -- | Projecting the mask out of a 'BitVector', see [Note] mask projection | DontCare -- | Create a sequence of VHDL name modifiers from our internal 'Modifier' -- data type. Note that the modifiers are in "reverse" order, so build a -- complete modified name using 'foldr' over the list by this function. -- -- [Note] Continuing from an SLV slice -- SOP and custom products are represented as std_logic_vector, this means that -- their elements are also std_logic_vector. So when we project an element out -- of an SOP or custom project, and want to do a further projection on that, -- we have to do further SLV slicing; instead of e.g. creating a 'selected' -- modifier. Finally, when we render the modified name, we have to check -- whether the ultimately projected type needs to be converted from this SLV -- slice, to the proper type. buildModifier :: HasCallStack => HdlSyn -> [(VHDLModifier,HWType)] -- ^ The list of modifiers so far, note that this list is in reverse order -- in which they should eventually be applied to the name we want to modify -> Modifier -> Maybe [(VHDLModifier,HWType)] -- ^ 'Nothing' indicates that the 'Modifier' does not result into a VHDL name -- modifier. i.e. we can use the identifier as is; this happens when we get -- projections out of product types with only one non-zero field. buildModifier _ prevM (Sliced (_,start,end)) = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice Just (first Range (continueWithRange [(start,end)] hty r) : rest) _ -> Just ((Range (Contiguous start end),hty) : prevM) where hty = BitVector (start-end+1) buildModifier _ prevM (Indexed (ty@(SP _ args),dcI,fI)) = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice Just (first Range (continueWithRange [(start,end)] argTy r) : rest) _ -> Just ((Range (Contiguous start end),argTy) : prevM) where argTys = snd (indexNote "SOP type: invalid constructor index" args dcI) argTy = indexNote "SOP type: invalid field index" argTys fI argSize = typeSize argTy other = otherSize argTys (fI-1) start = typeSize ty - 1 - conSize ty - other end = start - argSize + 1 buildModifier _ prevM (Indexed (ty@(Product _ labels tys),_,fI)) = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice let argSize = typeSize argTy otherSz = otherSize tys (fI - 1) start = typeSize ty - 1 - otherSz end = start - argSize + 1 in Just (first Range (continueWithRange [(start,end)] argTy r) : rest) _ -> let d = dot <> tyName ty <> selectProductField labels tys fI in Just ((Select d,argTy):prevM) where argTy = indexNote "Product type: invalid field index" tys fI buildModifier syn prevM (Indexed (ty@(Vector _ argTy),1,0)) = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice let argSize = typeSize argTy start = typeSize ty - 1 end = start - argSize + 1 in Just (first Range (continueWithRange [(start,end)] argTy r) : rest) | (Slice start _,Vector _ argTyP) <- prev , argTy == argTyP -> -- If the last modifier was an array slice, we just pick its first element Just (vivadoRange syn argTy ((Idx start,argTy):rest)) _ -> Just (vivadoRange syn argTy ((Idx 0,argTy):prevM)) buildModifier _ prevM (Indexed (ty@(Vector n argTy),1,1)) = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice let argSize = typeSize argTy start = typeSize ty - argSize - 1 in Just (first Range (continueWithRange [(start,0)] tyN r) : rest) | (Slice start end,Vector _ argTyP) <- prev , argTy == argTyP -> -- If the last modifier was an array slice, we just pick the tail of that slice Just ((Slice (start + 1) end,tyN) : rest) _ -> Just ((Slice 1 (n-1),tyN) : prevM) where tyN = Vector (n-1) argTy buildModifier syn prevM (Indexed (ty@(RTree _ argTy),0,0)) = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice let start = typeSize ty - 1 in Just (first Range (continueWithRange [(start,0)] argTy r) : rest) | (Slice start _,RTree _ argTyP) <- prev , argTy == argTyP -> -- If the last modifier was an array slice, we just pick its first element Just (vivadoRange syn argTy ((Idx start,argTy):rest)) _ -> Just (vivadoRange syn argTy ((Idx 0,argTy):prevM)) buildModifier _ prevM (Indexed (ty@(RTree d argTy),1,0)) = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice let start = typeSize ty - 1 end = typeSize ty `div` 2 in Just (first Range (continueWithRange [(start,end)] tyN r) : rest) | (Slice start _,RTree _ argTyP) <- prev , argTy == argTyP -> -- If the last modifier was an array slice, we just pick the left half Just ((Slice start (start+z-1),tyN) : rest) _ -> Just ((Slice 0 (z-1),tyN) : prevM) where tyN = RTree (d-1) argTy z = 2^(d - 1) buildModifier _ prevM (Indexed (ty@(RTree d argTy),1,1)) = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice let start = typeSize ty `div` 2 - 1 in Just (first Range (continueWithRange [(start,0)] tyN r) : rest) | (Slice _ end,RTree _ argTyP) <- prev , argTy == argTyP -> -- If the last modifier was an array slice, we just pick the right half Just ((Slice (end - z + 1) end,tyN) : rest) _ -> Just ((Slice z (z'-1),tyN) : prevM) where tyN = RTree (d-1) argTy z = 2^(d - 1) z' = 2^d -- This is a HACK for Clash.Netlist.Util.mkTopOutput -- Vector's don't have a 10'th constructor, this is just so that we can -- recognize the particular case buildModifier syn prevM (Indexed (ty@(Vector _ argTy),10,fI)) = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice let argSize = typeSize argTy start = typeSize ty - (fI * argSize) - 1 end = start - argSize + 1 in Just (first Range (continueWithRange [(start,end)] argTy r) : rest) | (Slice start _,Vector _ argTyP) <- prev , argTy == argTyP -> -- If the last modifier was an array slice, we offset from its starting element Just (vivadoRange syn argTy ((Idx (start+fI),argTy):rest)) _ -> Just (vivadoRange syn argTy (((Idx fI,argTy):prevM))) -- This is a HACK for Clash.Netlist.Util.mkTopOutput -- RTree's don't have a 10'th constructor, this is just so that we can -- recognize the particular case buildModifier syn prevM (Indexed (ty@(RTree _ argTy),10,fI)) = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice let argSize = typeSize argTy start = typeSize ty - (fI * argSize) - 1 end = start - argSize + 1 in Just (first Range (continueWithRange [(start,end)] argTy r) : rest) | (Slice start _,RTree 1 argTyP) <- prev , argTy == argTyP -> -- If the last modifier was an array slice, we offset from its starting element Just (vivadoRange syn argTy ((Idx (start+fI),argTy):rest)) _ -> Just (vivadoRange syn argTy ((Idx fI,argTy):prevM)) buildModifier _ prevM (Indexed (CustomSP _ dataRepr size args,dcI,fI)) | Void {} <- argTy = error (unexpectedProjectionErrorMsg dataRepr dcI fI) | otherwise = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice Just (first Range (continueWithRange ses argTy r) : rest) _ -> Just (first Range (continueWithRange ses argTy (Contiguous (size-1) 0)) : prevM) where (ConstrRepr' _name _n _mask _value anns, _, argTys) = indexNote "Custom SOP type: invalid constructor index" args dcI ses = bitRanges (indexNote "Custom SOP type: invalid annotation index" anns fI) argTy = indexNote "Custom SOP type: invalid field index" argTys fI buildModifier _ prevM (Indexed (CustomProduct _ dataRepr size _ args,dcI,fI)) | Void {} <- argTy = error (unexpectedProjectionErrorMsg dataRepr dcI fI) | DataRepr' _typ _size [cRepr] <- dataRepr , ConstrRepr' _cName _pos _mask _val fieldAnns <- cRepr , let ses = bitRanges (indexNote "Custom product type: invalid annotation index" fieldAnns fI) = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice Just (first Range (continueWithRange ses argTy r) : rest) _ -> Just (first Range (continueWithRange ses argTy (Contiguous (size-1) 0)):prevM) where argTy = snd (indexNote "Custom product type: invalid field index" args fI) buildModifier _ prevM (DC (ty@(SP _ _),_)) = case prevM of (prev:rest) | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice Just (first Range (continueWithRange [(start,end)] tyN r) : rest) _ -> Just ((Range (Contiguous start end),tyN):prevM) where start = typeSize ty - 1 end = typeSize ty - conSize ty tyN = BitVector (start - end + 1) buildModifier syn prevM (Nested m1 m2) = case buildModifier syn prevM m1 of Nothing -> buildModifier syn prevM m2 Just prevM1 -> case buildModifier syn prevM1 m2 of -- In case the second modifier is `Nothing` that means we want the entire -- thing calculated by the first modifier Nothing -> Just prevM1 m -> m -- [Note] integer projection -- -- The idea behind these expressions is to translate cases like: -- -- > :: Int8 -> Int# -- > \case I8# i -> i -- -- Which is fine, because no bits are lost. However, these expression might -- also be the result of the W/W transformation (or uses of unsafeToInteger) -- for: -- -- > :: Signed 128 -> Integer -- > \case S i -> i -- -- which is very bad because `Integer` is represented by 64 bits meaning we -- we lose the top 64 bits in the above translation. -- -- Just as bad is that -- -- > :: Word8 -> Word# -- > \case W8# w -> w -- -- > :: Unsigned 8 -> Integer -- > \case U i -> i -- -- result in the same expression... even though their resulting types are -- different. TODO: this needs to be fixed! buildModifier _ prevM (Indexed (ty@(Signed _),_,_)) = Just ((Resize,ty):prevM) buildModifier _ prevM (Indexed (ty@(Unsigned _),_,_)) = Just ((Resize,ty):prevM) -- [Note] mask projection -- -- This covers the case of either: -- -- `Clash.Sized.Internal.BitVector.unsafeToMask` or -- -- > :: BitVector 8 -> Integer -- > \case BV m wild -> m -- -- introduced by the W/W transformation. Both of which we prefer not to see -- but will allow. Since the mask is pretty much a simulation artifact we -- emit don't cares so stuff gets optimised away. buildModifier _ prevM (Indexed (ty@(BitVector _),_,0)) = Just ((DontCare,ty):prevM) -- [Note] bitvector projection -- -- This covers the case of either: -- -- `Clash.Sized.Internal.BitVector.unsafeToNatural` or -- -- > :: BitVector 8 -> Integer -- > \case BV wild i -> i -- -- introduced by the W/W transformation. Both of which we prefer not to see -- but will allow. buildModifier _ prevM (Indexed (ty@(BitVector _),_,1)) = Just ((ResizeAndConvert,ty):prevM) buildModifier _ _ _ = Nothing -- | Add an SLV slice for the entire element when we're in the Vivado code-path. -- This is needed after an element projection from an array (Vec or RTree), as -- elements are stored as SLVs in the Vivado code-path. This enabled two things: -- -- 1. Nested modifiers treat the projected element as an SLV, and adjust their -- projection behavior accordingly. -- 2. Projected elements are converted from SLV to the proper VHDL type. vivadoRange :: HdlSyn -> HWType -> [(VHDLModifier, HWType)] -> [(VHDLModifier, HWType)] vivadoRange syn ty mods = case syn of Vivado -> (Range (Contiguous (typeSize ty - 1) 0),ty):mods _ -> mods -- | Render a VHDL modifier on to of a (potentially modified) VHDL name renderModifier :: (VHDLModifier,HWType) -> VHDLM Doc -- ^ (Potentially modified) VHDL name -> VHDLM Doc -- ^ Modified VHDL name renderModifier (Idx n,_) doc = doc <> parens (int n) renderModifier (Slice start end,_) doc = doc <> parens (int start <+> "to" <+> int end) renderModifier (Select sel,_) doc = doc <> sel -- See [Note] integer projection renderModifier (Resize,ty) doc = do iw <- Ap (use intWidth) -- These integer projections always come last, so it's safe not to return a -- modified name, but an expression instead. traceIf (iw < typeSize ty) ($(curLoc) ++ "WARNING: result smaller than argument") $ "resize" <> parens (doc <> "," <> int iw) renderModifier (ResizeAndConvert,ty) doc = do iw <- Ap (use intWidth) -- These natural projections always come last, so it's safe not to return a -- modified name, but an expression instead. traceIf (iw < typeSize ty) ($(curLoc) ++ "WARNING: result smaller than argument") $ "resize" <> parens ("unsigned" <> parens doc <> "," <> int iw) -- See [Note] mask projection renderModifier (DontCare,_) _ = do iw <- Ap (use intWidth) -- These mask projections always come last, so it's safe not to return a -- modified name, but an expression instead. traceIf True ($(curLoc) ++ "WARNING: rendering bitvector mask as dontcare") $ sizedQualTyNameErrValue (Unsigned iw) renderModifier (Range r,t) doc = do nm <- Ap (use modNm) enums <- Ap renderEnums let doc1 = case r of Contiguous start end -> slice start end Split rs -> parens (hcat (punctuate " & " (mapM (\(s,e,_) -> slice s e) rs))) case normaliseType enums t of BitVector _ -> doc1 -- See [Note] Continuing from an SLV slice _ -> qualTyName t <> "'" <> parens (pretty (TextS.toLower nm) <> "_types.fromSLV" <> parens doc1) where slice s e = doc <> parens (int s <+> "downto" <+> int e) clash-lib-1.8.1/src/Clash/Backend/Verilog.hs0000644000000000000000000013001207346545000016660 0ustar0000000000000000{-| Copyright : (C) 2015-2016, University of Twente, 2017-2018, Google Inc., 2021-2023, QBayLogic B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Generate Verilog for assorted Netlist datatypes -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Backend.Verilog ( VerilogState , include , uselibs , encodingNote , exprLit , bits , bit_char , noEmptyInit -- * split ranges , Range (..) , continueWithRange ) where import qualified Control.Applicative as A import Control.Lens (Lens',(+=),(-=),(.=),(%=), makeLenses, use) import Control.Monad (forM) import Control.Monad.State (State) import Data.Bifunctor (first, second) import Data.Bits (Bits, testBit) import qualified Data.ByteString.Char8 as B8 import Data.Coerce (coerce) import Data.Function (on) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid (Ap(Ap)) import Data.Monoid.Extra () import Data.List (mapAccumL, mapAccumR, nubBy, foldl') import Data.List.Extra ((<:>)) import Data.Text.Lazy (pack) import qualified Data.Text.Lazy as Text import qualified Data.Text as TextS import Data.Text.Prettyprint.Doc.Extra import qualified System.FilePath import GHC.Stack (HasCallStack) import Clash.Annotations.Primitive (HDL (..)) import Clash.Annotations.BitRepresentation.ClashLib (bitsToBits) import Clash.Annotations.BitRepresentation.Internal (ConstrRepr'(..), DataRepr'(..), ConstrRepr'(..)) import Clash.Annotations.BitRepresentation.Util (BitOrigin(Lit, Field), bitOrigins, bitRanges) 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) 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 as N hiding (intWidth, usages, _usages) import Clash.Netlist.Util import Clash.Signal.Internal (ActiveEdge (..)) import Clash.Util (SrcSpan, noSrcSpan, curLoc, indexNote, makeCached) -- | State for the 'Clash.Backend.Verilog.VerilogM' monad: data VerilogState = VerilogState { _genDepth :: Int -- ^ Depth of current generative block , _idSeen :: IdentifierSet , _topNm :: Identifier , _srcSpan :: SrcSpan , _includes :: [(String,Doc)] , _imports :: HashSet Text.Text , _libraries :: HashSet Text.Text , _dataFiles :: [(String,FilePath)] -- ^ Files to be copied: (filename, old path) , _memoryDataFiles:: [(String,String)] -- ^ Files to be stored: (filename, contents). These files are generated -- during the execution of 'genNetlist'. , _customConstrs :: HashMap TextS.Text Identifier -- ^ Custom data constructor => Verilog function name , _intWidth :: Int -- ^ Int/Word/Integer bit-width , _hdlsyn :: HdlSyn , _undefValue :: Maybe (Maybe Int) , _aggressiveXOptBB_ :: AggressiveXOptBB , _domainConfigurations_ :: DomainMap , _usages :: UsageMap } makeLenses ''VerilogState instance HasIdentifierSet VerilogState where identifierSet = idSeen instance HasUsageMap VerilogState where usageMap = usages instance Backend VerilogState where initBackend opts = VerilogState { _genDepth=0 , _idSeen=Id.emptyIdentifierSet (opt_escapedIds opts) (opt_lowerCaseBasicIds opts) Verilog , _topNm=Id.unsafeMake "" , _srcSpan=noSrcSpan , _includes=[] , _imports=HashSet.empty , _libraries=HashSet.empty , _dataFiles=[] , _memoryDataFiles=[] , _customConstrs=HashMap.empty , _intWidth=opt_intWidth opts , _hdlsyn=opt_hdlSyn opts , _undefValue=opt_forceUndefined opts , _aggressiveXOptBB_=coerce (opt_aggressiveXOptBB opts) , _domainConfigurations_=emptyDomainMap , _usages=mempty } hdlKind = const Verilog primDirs = const $ do root <- primsRoot return [ root System.FilePath. "common" , root System.FilePath. "commonverilog" , root System.FilePath. "verilog" ] extractTypes = const HashSet.empty name = const "verilog" extension = const ".v" genHDL = genVerilog mkTyPackage _ _ = return [] hdlType _ = verilogType hdlHWTypeKind _ = pure PrimitiveType -- Everything is a bitvector! hdlTypeErrValue = verilogTypeErrValue hdlTypeMark = verilogTypeMark hdlRecSel = verilogRecSel hdlSig t ty = sigDecl (string t) ty genStmt True = do cnt <- use genDepth genDepth += 1 if cnt > 0 then emptyDoc else "generate" genStmt False = do genDepth -= 1 cnt <- use genDepth if cnt > 0 then emptyDoc else "endgenerate" inst = inst_ expr = expr_ iwWidth = use intWidth toBV ty e = case ty of Signed _ -> "$unsigned" <> parens (string e) _ -> string e fromBV ty e = case ty of Signed _ -> "$signed" <> parens (string e) _ -> string e hdlSyn = use hdlsyn setModName _ = id setTopName nm s = s {_topNm = nm} getTopName = use topNm setSrcSpan = (srcSpan .=) getSrcSpan = use srcSpan blockDecl _ ds = do decs <- decls ds if isEmpty decs then insts ds else pure decs <> line <> insts ds addIncludes inc = includes %= (inc ++) addLibraries libs = libraries %= (\s -> foldl' (flip HashSet.insert) s libs) addImports inps = imports %= (\s -> foldl' (flip HashSet.insert) s inps) addAndSetData f = do fs <- use dataFiles let (fs',f') = renderFilePath fs f dataFiles .= fs' return f' getDataFiles = use dataFiles addMemoryDataFile f = memoryDataFiles %= (f:) getMemoryDataFiles = use memoryDataFiles ifThenElseExpr _ = True aggressiveXOptBB = use aggressiveXOptBB_ renderEnums = pure (RenderEnums False) domainConfigurations = use domainConfigurations_ setDomainConfigurations confs s = s {_domainConfigurations_ = confs} type VerilogM a = Ap (State VerilogState) a -- | Generate Verilog for a Netlist component genVerilog :: ClashOpts -> ModName -> SrcSpan -> IdentifierSet -> UsageMap -> Component -> VerilogM ((String, Doc), [(String, Doc)]) 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 $ do idSeen %= Id.union seen usages .= usage setSrcSpan sp v <- commentHeader <> line <> nettype <> line <> timescale <> line <> module_ c incs <- Ap $ use includes return ((TextS.unpack (Id.toText cName), v), incs) where cName = componentName c commentHeader = "/* AUTOMATICALLY GENERATED VERILOG-2001 SOURCE CODE." <> line <> "** GENERATED BY CLASH " <> string (Text.pack clashVer) <> ". DO NOT MODIFY." <> line <> "*/" nettype = "`default_nettype none" timescale = "`timescale 100fs/" <> string (Text.pack precision) precision = periodToString (opt_timescalePrecision opts) sigPort :: VerilogM Doc -> Maybe N.Usage -> Identifier -> HWType -> Maybe Expr -> VerilogM Doc sigPort def mu (Id.toText -> pName) hwType iEM = do addAttrs (hwTypeAttrs hwType) (portType <+> verilogType hwType <+> stringS pName <> iE <> encodingNote hwType) where 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) where modVerilog = do body <- modBody imps <- Ap $ use imports libs <- Ap $ use libraries modHeader <> line <> modPorts <> line <> include (HashSet.toList imps) <> uselibs (HashSet.toList libs) <> pure body <> line <> modEnding modHeader = "module" <+> pretty (componentName c) modPorts = indent 4 (tupleInputs inPorts <> line <> tupleOutputs outPorts <> semi) modBody = indent 2 (decls (declarations c)) <> line <> line <> indent 2 (insts (declarations c)) modEnding = "endmodule" 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 tupleInputs v = v >>= \case [] -> lparen <+> string "// No inputs" <> line (x:xs) -> lparen <+> string "// Inputs" <> line <> (string " " <> pure x) <> line <> vcat (forM xs commafy) <> line tupleOutputs v = v >>= \case [] -> string " // No outputs" <> line <> rparen (x:xs) -> string " // Outputs" <> line <> (if (length (inputs c)) > 0 then comma <> space <> pure x else string " " <> pure x) <> (if null xs then emptyDoc else line <> vcat (forM xs commafy)) <> line <> rparen include :: Monad m => [Text.Text] -> Ap m Doc include [] = emptyDoc include xs = line <> indent 2 (vcat (mapM (\i -> string "`include" <+> dquotes (string i)) xs)) <> line <> line uselibs :: Monad m => [Text.Text] -> Ap m Doc uselibs [] = emptyDoc uselibs xs = line <> -- NOTE: We must produce a single uselib directive as later ones overwrite earlier ones. indent 2 (string "`uselib" <+> (hsep (mapM (\l -> ("lib=" <> string l)) xs))) <> line <> line 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 sigDecl d t = verilogType t <+> d -- | Convert a Netlist HWType to the root of a Verilog type verilogTypeMark :: HWType -> VerilogM Doc verilogTypeMark = const emptyDoc -- | Convert a Netlist HWType to an error Verilog value for that type verilogTypeErrValue :: HWType -> VerilogM Doc verilogTypeErrValue ty = do udf <- Ap (use undefValue) case udf of Nothing -> braces (int (typeSize ty) <+> braces "1'bx") Just Nothing -> int (typeSize ty) <> "'d0 /* undefined */" Just (Just x) -> braces (int (typeSize ty) <+> braces ("1'b" <> int x)) <+> "/* undefined */" verilogRecSel :: HWType -> Int -> VerilogM Doc verilogRecSel ty i = case modifier (Contiguous 0 0) (Indexed (ty,0,i)) of Just (Contiguous start end,_resTy) -> brackets (int start <> colon <> int end) _ -> error "Can't make a record selector" decls :: [Declaration] -> VerilogM Doc decls [] = emptyDoc decls ds = do dsDoc <- catMaybes <$> (mapM decl ds) case dsDoc of [] -> emptyDoc _ -> punctuate' semi (A.pure dsDoc) -- | Add attribute notation to given declaration addAttrs :: [Attr TextS.Text] -> VerilogM Doc -> VerilogM Doc addAttrs [] t = t addAttrs attrs' t = "(*" <+> attrs'' <+> "*)" <+> t where attrs'' = stringS $ TextS.intercalate ", " (map renderAttr attrs') -- | Convert single attribute to verilog syntax 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 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 ty = sigDecl (pretty id_) ty <> iE addNote n = mappend ("//" <+> stringS n <> line) attrs = fromMaybe [] (hwTypeAttrs A.<$> Just tyE) iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM decl _ = return Nothing noEmptyInit :: (Monad m, Semigroup (m Doc)) => m Doc -> m Doc noEmptyInit d = do d1 <- d if isEmpty d1 then emptyDoc else (space <> string "=" <+> d) insts :: [Declaration] -> VerilogM Doc insts [] = emptyDoc insts (TickDecl (Comment c):ds) = comment "//" c <> line <> insts ds insts (TickDecl (Directive d):ds) = pretty d <> ";" <> line <> insts ds insts (d:ds) = do docM <- inst_ d case docM of Nothing -> insts ds Just doc -> pure doc <> line <> line <> insts ds stdMatch :: Bits a => Int -> a -> a -> String stdMatch 0 _mask _value = [] stdMatch size mask value = symbol : stdMatch (size - 1) mask value where symbol = if testBit mask (size - 1) then if testBit value (size - 1) then '1' else '0' else '?' patLitCustom' :: Int -> ConstrRepr' -> VerilogM Doc patLitCustom' size (ConstrRepr' _name _n mask value _anns) = int size <> squote <> "b" <> (string $ Text.pack $ stdMatch size mask value) patLitCustom :: HWType -> Literal -> VerilogM Doc patLitCustom (CustomSum _name _dataRepr size reprs) (NumLit (fromIntegral -> i)) = patLitCustom' size (fst $ reprs !! i) patLitCustom (CustomSP _name _dataRepr size reprs) (NumLit (fromIntegral -> i)) = let (cRepr, _id, _tys) = reprs !! i in patLitCustom' size cRepr patLitCustom hwTy _ | CustomProduct _name dataRepr size _maybeFieldNames _reprs <- hwTy , DataRepr' _typ _size [cRepr] <- dataRepr = patLitCustom' size cRepr patLitCustom x y = error $ $(curLoc) ++ unwords [ "You can only pass CustomSP / CustomSum / CustomProduct and a NumLit to " , "this function, not", show x, "and", show y ] patMod :: HWType -> Literal -> Literal patMod hwTy (NumLit i) = NumLit (i `mod` (2 ^ typeSize hwTy)) patMod _ l = l -- | Helper function for inst_, handling CustomSP and CustomSum inst_' :: TextS.Text -> Expr -> HWType -> [(Maybe Literal, Expr)] -> VerilogM (Maybe Doc) inst_' id_ scrut scrutTy es = fmap Just $ "always @(*) begin" <> line <> indent 2 casez <> line <> "end" where casez = "casez" <+> parens var <> line <> indent 2 (conds esNub) <> line <> "endcase" esMod = map (first (fmap (patMod scrutTy))) es esNub = nubBy ((==) `on` fst) esMod var = expr_ True scrut conds :: [(Maybe Literal,Expr)] -> VerilogM Doc conds [] = error $ $(curLoc) ++ "Empty list of conditions invalid." conds [(_,e)] = "default" <+> ":" <+> stringS id_ <+> "=" <+> expr_ False e <> ";" conds ((Nothing,e):_) = "default" <+> ":" <+> stringS id_ <+> "=" <+> expr_ False e <> ";" conds ((Just c ,e):es') = mask' <+> ":" <+> stringS id_ <+> "=" <+> expr_ False e <> ";" <> line <> conds es' where mask' = patLitCustom scrutTy c -- | Turn a Netlist Declaration to a Verilog concurrent block inst_ :: Declaration -> VerilogM (Maybe Doc) inst_ (TickDecl {}) = return Nothing 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 $ "always @(*) begin" <> line <> indent 2 ("if" <> parens (expr_ True scrut) <> line <> (indent 2 $ pretty id_ <+> equals <+> expr_ False t <> semi) <> line <> "else" <> line <> (indent 2 $ pretty id_ <+> equals <+> expr_ False f <> semi)) <> line <> "end" where (t,f) = if b then (l,r) else (r,l) inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSP {}) es) = inst_' (Id.toText id_) scrut scrutTy es inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSum {}) es) = inst_' (Id.toText id_) scrut scrutTy es inst_ (CondAssignment id_ _ scrut scrutTy@(CustomProduct {}) es) = inst_' (Id.toText id_) scrut scrutTy es inst_ (CondAssignment id_ _ scrut scrutTy es) = fmap Just $ "always @(*) begin" <> line <> indent 2 ("case" <> parens (expr_ True scrut) <> line <> (indent 2 $ vcat $ punctuate semi (conds (Id.toText id_) es)) <> semi <> line <> "endcase") <> line <> "end" where conds :: IdentifierText -> [(Maybe Literal,Expr)] -> VerilogM [Doc] conds _ [] = return [] conds i [(_,e)] = ("default" <+> colon <+> stringS i <+> equals <+> expr_ False e) <:> return [] conds i ((Nothing,e):_) = ("default" <+> colon <+> stringS i <+> equals <+> expr_ False e) <:> return [] conds i ((Just c ,e):es') = (exprLitV (Just (scrutTy,conSize scrutTy)) c <+> colon <+> stringS i <+> equals <+> expr_ False e) <:> conds i es' inst_ (InstDecl _ _ attrs nm lbl ps pms0) = fmap Just $ attrs' <> nest 2 (pretty nm <> params <> pretty lbl <> line <> pms2 <> semi) where pms2 = case pms0 of NamedPortMap pms1 -> -- ( .clk (clk_0), .arst (arst_0), ........ ) let pm i e = dot <> expr_ False i <+> parens (expr_ False e) in tupled $ sequence [pm i e | (i,_,_,e) <- pms1] IndexedPortMap pms1 -> -- ( clk_0, arst_0, ..... ) tupled $ sequence [expr_ False e | (_,_,e) <- pms1] params | null ps = space | otherwise = line <> "#" <> tupled (sequence [dot <> expr_ False i <+> parens (expr_ False e) | (i,_,e) <- ps]) <> line attrs' | null attrs = emptyDoc | otherwise = addAttrs attrs line inst_ (BlackBoxD _ libs imps inc bs bbCtx) = fmap Just (Ap (column (renderBlackBox libs imps inc bs bbCtx))) inst_ (Seq ds) = Just <$> seqs ds inst_ (NetDecl' {}) = return Nothing 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 @" <> parens (case edge of {Rising -> "posedge"; _ -> "negedge"} <+> expr_ False clk) <+> "begin" <> line <> indent 2 (seqs ds) <> line <> "end" seq_ (Initial ds) = "initial begin" <> line <> indent 2 (seqs ds) <> line <> "end" seq_ (AlwaysComb ds) = "always @* begin" <> line <> indent 2 (seqs ds) <> line <> "end" seq_ (Branch scrut scrutTy es) = "case" <> parens (expr_ True scrut) <> line <> (indent 2 $ vcat $ conds es) <> line <> "endcase" where conds :: [(Maybe Literal,[Seq])] -> VerilogM [Doc] conds [] = return [] conds [(_,sq)] = ("default" <+> colon <+> "begin" <> line <> indent 2 (seqs sq) <> line <> "end") <:> return [] conds ((Nothing,sq):_) = ("default" <+> colon <+> "begin" <> line <> indent 2 (seqs sq) <> line <> "end") <:> return [] conds ((Just c ,sq):es') = (exprLitV (Just (scrutTy,conSize scrutTy)) c <+> colon <+> "begin" <> line <> indent 2 (seqs sq) <> line <> "end") <:> conds es' seq_ (SeqDecl sd) = case sd of 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 Seq ds -> seqs ds _ -> error ("seq_: " ++ show sd) seqs :: [Seq] -> VerilogM Doc seqs [] = emptyDoc seqs (SeqDecl (TickDecl (Comment c)):ds) = comment "//" c <> line <> seqs ds seqs (SeqDecl (TickDecl (Directive d)):ds) = pretty d <> ";" <> line <> seqs ds seqs (d:ds) = seq_ d <> line <> line <> seqs ds -- | Range slice, can be contiguous, or split into multiple sub-ranges data Range = Contiguous Int Int | Split [(Int,Int,Provenance)] -- | Original index range of a split range element data Provenance = Provenance Int Int -- | Slice ranges out of a split-range element inRange :: [(Int,Int)] -- ^ start and end indexes into the original data type -> (Int,Int,Provenance) -- ^ Element of a split range -> ([(Int,Int)],[(Int,Int,Provenance)]) -- ^ -- 1. stand and end indexes to be sliced from the rest of the split range elements -- 2. Subset of the current split range for the projected data type inRange [] _ = ([],[]) inRange ((start,end):ses) orig@(_,endRange,Provenance _ endProvenance) = {- The following explains the index calculations == Start == ----------------------------------- | 2 | | 1 | | 0 | <- split range element number |15|14|13|12| |10| 9| 8| | 4| 3| 2| <- split range indexes ----------------------------------- | 9| 8| 7| 6| | 5| 4| 3| | 2| 1| 0| <- original indexes of the data type (provenance) ----------------------------------- 4 1 <- `start` and `end` index that we want to slice == split range element 2 == startOffset: start(4) - endProvenance(6) = -2 next start: 4 next end: 1 == split range element 1 == startOffset: start(4) - endProvenance(3) = 1 endOffSet : end(1) - endProvenance(3) = -2 startRangeNew: endRange(8) + startOffSet(1) = 9 endRangeNew : endRange(8) startProvenanceNew: start(4) - end(1) = 3 endProvenanceNew : startProvenanceNew(3)-startOffset(1) = 2 newSplitRange: ------- | 1 | | 9| 8| <- new split range element ------- | 3| 2| <- index into the projected data type next start: endProvenance(3) - 1 = 2 next end : 1 == split range element 0 == startOffset: start(2) - endProvenance(0) = 2 endOffset : end(1) - endProvenance(0) = 1 startRangeNew: endRange(2) + startOffSet(2) = 4 endRangeNew : endRange(2) + endOffSet(1) = 3 startProvenanceNew: start(2) - end(1) = 1 endProvenanceNew : = 0 newSplitRange: ------- | 0 | | 4| 3| <- new split range element ------- | 1| 0| <- index into the projected data type -} let startOffset = start - endProvenance endOffset = end - endProvenance in if startOffset >= 0 then let startRangeNew = endRange + startOffset endRangeNew = if endOffset >= 0 then endRange + endOffset else endRange startProvenanceNew = start - end endProvenanceNew = if endOffset >= 0 then 0 else startProvenanceNew - startOffset newSplitRange = ( startRangeNew , endRangeNew , Provenance startProvenanceNew endProvenanceNew) in if endOffset >= 0 then -- try to slice the next start+end in the current split range element second (newSplitRange:) (inRange ses orig) else -- continue the slice in the next split range element ((endProvenance-1,end):ses,[newSplitRange]) else -- start offset beyond last bit in the element of the split range ((start,end):ses,[]) -- | Create an Split range element buildSplitRange :: Int -- ^ Offset -> Int -- ^ End index into the original data type -> (Int,Int) -- ^ start and end index for this sub-range -> (Int,(Int,Int,Provenance)) buildSplitRange offset eP (s,e) = let d = s-e in (eP+d+1,(s + offset, e + offset, Provenance (eP+d) eP)) -- | Select a sub-range from a range continueWithRange :: [(Int,Int)] -- ^ Starts and ends -> HWType -- ^ Type of the projection -> Range -- ^ Range selected so far -> (Range, HWType) continueWithRange ses hty r = case r of Contiguous _ offset -> case ses of [(start,end)] -> (Contiguous (start+offset) (end+offset), hty) ses1 -> let ses2 = snd (mapAccumR (buildSplitRange offset) 0 ses1) in (Split ses2, hty) Split rs -> case concat (snd (mapAccumL inRange ses rs)) of [] -> error "internal error" [(s1,e1,_)] -> (Contiguous s1 e1,hty) rs1 -> (Split rs1,hty) -- | Calculate the beginning and end index into a variable, to get the -- desired field. -- Also returns the HWType of the result. modifier :: HasCallStack => Range -- ^ Range selected so far -> Modifier -> Maybe (Range,HWType) modifier r (Sliced (BitVector _,start,end)) = Just (continueWithRange [(start,end)] hty r) where hty = BitVector (start-end-1) modifier r (Indexed (ty@(SP _ args),dcI,fI)) = Just (continueWithRange [(start,end)] argTy r) where argTys = snd $ args !! dcI argTy = argTys !! fI argSize = typeSize argTy other = otherSize argTys (fI-1) start = typeSize ty - 1 - conSize ty - other end = start - argSize + 1 modifier r (Indexed (ty@(Product _ _ argTys),_,fI)) = Just (continueWithRange [(start,end)] argTy r) where argTy = argTys !! fI argSize = typeSize argTy otherSz = otherSize argTys (fI - 1) start = typeSize ty - 1 - otherSz end = start - argSize + 1 modifier r (Indexed (ty@(Vector _ argTy),1,0)) = Just (continueWithRange [(start,end)] argTy r) where argSize = typeSize argTy start = typeSize ty - 1 end = start - argSize + 1 modifier r (Indexed (ty@(Vector n argTy),1,1)) = Just (continueWithRange [(start,0)] hty r) where argSize = typeSize argTy start = typeSize ty - argSize - 1 hty = Vector (n-1) argTy modifier r (Indexed (ty@(RTree 0 argTy),0,0)) = Just (continueWithRange [(start,0)] argTy r) where start = typeSize ty - 1 modifier r (Indexed (ty@(RTree d argTy),1,0)) = Just (continueWithRange [(start,end)] hty r) where start = typeSize ty - 1 end = typeSize ty `div` 2 hty = RTree (d-1) argTy modifier r (Indexed (ty@(RTree d argTy),1,1)) = Just (continueWithRange [(start,0)] hty r) where start = (typeSize ty `div` 2) - 1 hty = RTree (d-1) argTy -- This is a HACK for Clash.Netlist.Util.mkTopOutput -- Vector's don't have a 10'th constructor, this is just so that we can -- recognize the particular case modifier r (Indexed (ty@(Vector _ argTy),10,fI)) = Just (continueWithRange [(start,end)] argTy r) where argSize = typeSize argTy start = typeSize ty - (fI * argSize) - 1 end = start - argSize + 1 -- This is a HACK for Clash.Netlist.Util.mkTopOutput -- RTree's don't have a 10'th constructor, this is just so that we can -- recognize the particular case modifier r (Indexed (ty@(RTree _ argTy),10,fI)) = Just (continueWithRange [(start,end)] argTy r) where argSize = typeSize argTy start = typeSize ty - (fI * argSize) - 1 end = start - argSize + 1 modifier r (Indexed (CustomSP _typName _dataRepr _size args,dcI,fI)) = Just (continueWithRange ses argTy r) where ses = bitRanges (anns !! fI) (ConstrRepr' _name _n _mask _value anns, _, argTys) = args !! dcI argTy = argTys !! fI modifier r (Indexed (CustomProduct _typName dataRepr _size _maybeFieldNames args,_,fI)) | DataRepr' _typ _size [cRepr] <- dataRepr , ConstrRepr' _cName _pos _mask _val fieldAnns <- cRepr = let ses = bitRanges (fieldAnns !! fI) in Just (continueWithRange ses argTy r) where argTy = map snd args !! fI modifier r (DC (ty@(SP _ _),_)) = Just (continueWithRange [(start,end)] ty r) where start = typeSize ty - 1 end = typeSize ty - conSize ty modifier r (Nested m1 m2) = do case modifier r m1 of Nothing -> modifier r m2 Just (r1,argTy) -> case modifier r1 m2 of -- In case the second modifier is `Nothing` that means we want the entire -- thing calculated by the first modifier Nothing -> Just (r1,argTy) m -> m modifier _ _ = Nothing -- | Render a data constructor application for data constructors having a -- custom bit representation. customReprDataCon :: DataRepr' -- ^ Custom representation of data type -> ConstrRepr' -- ^ Custom representation of a specific constructor of @dataRepr@ -> [(HWType, Expr)] -- ^ Arguments applied to constructor -> VerilogM Doc customReprDataCon dataRepr constrRepr [] = let origins = bitOrigins dataRepr constrRepr :: [BitOrigin] in case origins of [Lit (bitsToBits -> ns)] -> int (length ns) <> squote <> "b" <> hcat (mapM (bit_char undefValue) ns) _ -> error "internal error" customReprDataCon dataRepr constrRepr args = do funId <- mkConstrFunction Ap (imports %= HashSet.insert (Text.pack (TextS.unpack (Id.toText funId) ++ ".inc"))) pretty funId <> tupled (mapM (expr_ False . snd) nzArgs) where nzArgs = filter ((/=0) . typeSize . fst) args mkConstrFunction :: Ap (State VerilogState) Identifier mkConstrFunction = makeCached (crName constrRepr) customConstrs $ do let size = drSize dataRepr aTys = map fst args origins = bitOrigins dataRepr constrRepr :: [BitOrigin] let mkId nm = Id.makeBasic nm ids <- mapM (\n -> mkId (TextS.pack ('v':show n))) [1..length args] fId <- mkId (crName constrRepr) let fInps = [ case typeSize t of 0 -> emptyDoc 1 -> "input" <+> pretty i <> semi <> line n -> "input" <+> brackets (int (n-1) <> colon <> int 0) <+> pretty i <> semi <> line | (i,t) <- zip ids aTys ] let range' (Lit (bitsToBits -> ns)) = int (length ns) <> squote <> "b" <> hcat (mapM (bit_char undefValue) ns) range' (Field n start end) = let v = ids !! n aTy = aTys !! n in case typeSize aTy of 0 -> error "internal error" 1 -> if start == 0 && end == 0 then pretty v else error "internal error" _ -> pretty v <> brackets (int start <> colon <> int end) let val = case origins of [] -> error "internal error" [r] -> range' r rs -> listBraces (mapM range' rs) let oSz = case size of 0 -> error "internal error" 1 -> emptyDoc n -> brackets (int (n-1) <> colon <> int 0) funDoc <- "function" <+> oSz <+> pretty fId <> semi <> line <> hcat (sequence fInps) <> "begin" <> line <> indent 2 (pretty fId <+> "=" <+> val <> semi) <> line <> "end" <> line <> "endfunction" Ap (includes %= ((TextS.unpack (Id.toText fId) ++ ".inc",funDoc):)) return fId -- | Turn a Netlist expression into a Verilog expression expr_ :: Bool -- ^ Enclose in parentheses? -> Expr -- ^ Expr to convert -> VerilogM Doc expr_ _ (Literal sizeM lit) = exprLitV sizeM lit expr_ _ (Identifier id_ Nothing) = pretty id_ expr_ _ (Identifier id_ (Just (Indexed (CustomSP _id dataRepr _size args,dcI,fI)))) = case fieldTy of Void {} -> error (unexpectedProjectionErrorMsg dataRepr dcI fI) _ -> braces $ hcat $ punctuate ", " $ sequence ranges where (ConstrRepr' _name _n _mask _value anns, _, fieldTypes) = args !! dcI ranges = map range' $ bitRanges (anns !! fI) range' (start, end) = pretty id_ <> brackets (int start <> ":" <> int end) fieldTy = indexNote ($(curLoc) ++ "panic") fieldTypes fI expr_ _ (Identifier d_ (Just (Indexed (CustomProduct _id dataRepr _size _maybeFieldNames tys, dcI, fI)))) | DataRepr' _typ _size [cRepr] <- dataRepr , ConstrRepr' _cName _pos _mask _val anns <- cRepr = let ranges = map range' (bitRanges (anns !! fI)) in case fieldTy of Void {} -> error (unexpectedProjectionErrorMsg dataRepr dcI fI) _ -> braces $ hcat $ punctuate ", " $ sequence ranges where (_fieldAnn, fieldTy) = indexNote ($(curLoc) ++ "panic") tys fI range' (start, end) = pretty d_ <> brackets (int start <> ":" <> int end) -- See [Note] integer projection expr_ _ (Identifier id_ (Just (Indexed ((Signed w),_,_)))) = do iw <- Ap $ use intWidth traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $ pretty id_ -- See [Note] integer projection expr_ _ (Identifier id_ (Just (Indexed ((Unsigned w),_,_)))) = do iw <- Ap $ use intWidth traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $ pretty id_ -- See [Note] mask projection expr_ _ (Identifier _ (Just (Indexed ((BitVector _),_,0)))) = do iw <- Ap $ use intWidth traceIf True ($(curLoc) ++ "WARNING: synthesizing bitvector mask to dontcare") $ verilogTypeErrValue (Unsigned iw) -- See [Note] bitvector projection expr_ _ (Identifier id_ (Just (Indexed ((BitVector w),_,1)))) = do iw <- Ap $ use intWidth traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $ pretty id_ expr_ _ (Identifier id_ (Just m)) = case modifier (Contiguous 0 0) m of Nothing -> pretty id_ Just (Contiguous start end,resTy) -> case resTy of Signed _ -> "$signed" <> parens (slice start end) _ -> slice start end Just (Split rs,resTy) -> let rs1 = listBraces (mapM (\(start,end,_) -> slice start end) rs) in case resTy of Signed _ -> "$signed" <> parens rs1 _ -> rs1 where slice s e = pretty id_ <> brackets (int s <> colon <> int e) expr_ b (DataCon _ (DC (Void {}, -1)) [e]) = expr_ b e expr_ _ (DataCon ty@(Vector 0 _) _ _) = verilogTypeErrValue ty expr_ _ (DataCon (Vector 1 _) _ [e]) = expr_ False e expr_ _ e@(DataCon (Vector _ _) _ es@[_,_]) = listBraces $ mapM (expr_ False) $ fromMaybe es $ vectorChain e expr_ _ (DataCon (MemBlob n m) _ [n0, m0, _, runs, _, ends]) | Literal _ (NumLit n1) <- n0 , n == fromInteger n1 , Literal _ (NumLit m1) <- m0 , m == fromInteger m1 , Literal Nothing (StringLit runs0) <- runs , Literal Nothing (StringLit ends0) <- ends , es <- unpackNats n m (B8.pack runs0) (B8.pack ends0) = let el val = exprLitV (Just (BitVector m, m)) (BitVecLit 0 $ toInteger val) in listBraces $ mapM el es expr_ _ (DataCon (RTree 0 _) _ [e]) = expr_ False e expr_ _ e@(DataCon (RTree _ _) _ es@[_,_]) = listBraces $ mapM (expr_ False) $ fromMaybe es $ rtreeChain e expr_ _ (DataCon (SP {}) (DC (BitVector _,_)) es) = assignExpr where argExprs = map (expr_ False) es assignExpr = braces (hcat $ punctuate comma $ sequence argExprs) expr_ _ (DataCon ty@(SP _ args) (DC (_,i)) es) = assignExpr where argTys = snd $ args !! i dcSize = conSize ty + sum (map typeSize argTys) dcExpr = expr_ False (dcToExpr ty i) argExprs = map (expr_ False) es extraArg = case typeSize ty - dcSize of 0 -> [] n -> [int n <> "'b" <> bits undefValue (replicate n U)] assignExpr = braces (hcat $ punctuate comma $ sequence (dcExpr:argExprs ++ extraArg)) expr_ _ (DataCon ty@(Sum _ _) (DC (_,i)) []) = int (typeSize ty) <> "'d" <> int i expr_ _ (DataCon ty@(CustomSum _ _ _ tys) (DC (_,i)) []) = let (ConstrRepr' _ _ _ value _) = fst $ tys !! i in int (typeSize ty) <> squote <> "d" <> int (fromIntegral value) expr_ _ (DataCon (CustomSP _name dataRepr _size constrs) (DC (_,constrNr)) es) = let (cRepr, _, argTys) = constrs !! constrNr in customReprDataCon dataRepr cRepr (zip argTys es) expr_ _ (DataCon (CustomProduct _ dataRepr _size _labels tys) _ es) | DataRepr' _typ _size [cRepr] <- dataRepr = customReprDataCon dataRepr cRepr (zip (map snd tys) es) expr_ _ (DataCon (Product {}) _ es) = listBraces (mapM (expr_ False) es) expr_ _ (DataCon (Enable _) _ [e]) = expr_ False e expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Signed.fromInteger#" , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx = exprLitV (Just (Signed (fromInteger n),fromInteger n)) i expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Unsigned.fromInteger#" , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx = exprLitV (Just (Unsigned (fromInteger n),fromInteger n)) i expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.BitVector.fromInteger#" , [Literal _ (NumLit n), Literal _ m, Literal _ i] <- extractLiterals bbCtx , 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 , NumLit m' <- m , NumLit i' <- i = exprLitV (Just (Bit,1)) (BitLit $ toBit m' i') expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm == "Clash.Sized.Internal.Index.fromInteger#" , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx = exprLit undefValue (Just (Index (fromInteger n),fromInteger n)) i expr_ b (BlackBoxE _ libs imps inc bs bbCtx b') = do parenIf (b || b') (Ap (renderBlackBox libs imps inc bs bbCtx <*> pure 0)) expr_ _ (DataTag Bool (Left id_)) = pretty id_ <> brackets (int 0) expr_ _ (DataTag Bool (Right id_)) = do iw <- Ap (use intWidth) "$unsigned" <> parens (listBraces (sequence [braces (int (iw-1) <+> braces "1'b0"),pretty id_])) expr_ _ (DataTag (Sum _ _) (Left id_)) = "$unsigned" <> parens (pretty id_) expr_ _ (DataTag (Sum _ _) (Right id_)) = "$unsigned" <> parens (pretty id_) expr_ _ (DataTag (Product {}) (Right _)) = do iw <- Ap (use intWidth) int iw <> "'sd0" expr_ _ (DataTag hty@(SP _ _) (Right id_)) = "$unsigned" <> parens (pretty id_ <> brackets (int start <> colon <> int end)) where start = typeSize hty - 1 end = typeSize hty - conSize hty expr_ _ (DataTag (Vector 0 _) (Right _)) = do iw <- Ap $ use intWidth int iw <> "'sd0" expr_ _ (DataTag (Vector _ _) (Right _)) = do iw <- Ap $ use intWidth int iw <> "'sd1" expr_ _ (DataTag (RTree 0 _) (Right _)) = do iw <- Ap $ use intWidth int iw <> "'sd0" expr_ _ (DataTag (RTree _ _) (Right _)) = do iw <- Ap $ use intWidth int iw <> "'sd1" expr_ b (ToBv _ _ e) = expr_ b e expr_ b (FromBv _ _ e) = expr_ b e expr_ b (IfThenElse c t e) = parenIf b (expr_ True c <+> "?" <+> expr_ True t <+> ":" <+> expr_ True e) expr_ _ e = error $ $(curLoc) ++ (show e) -- empty otherSize :: [HWType] -> Int -> Int otherSize _ n | n < 0 = 0 otherSize [] _ = 0 otherSize (a:as) n = typeSize a + otherSize as (n-1) vectorChain :: Expr -> Maybe [Expr] vectorChain (DataCon (Vector 0 _) _ _) = Just [] vectorChain (DataCon (Vector 1 _) _ [e]) = Just [e] vectorChain (DataCon (Vector _ _) _ [e1,e2]) = Just e1 <:> vectorChain e2 vectorChain _ = Nothing rtreeChain :: Expr -> Maybe [Expr] rtreeChain (DataCon (RTree 0 _) _ [e]) = Just [e] rtreeChain (DataCon (RTree _ _) _ [e1,e2]) = Just e1 <:> rtreeChain e2 rtreeChain _ = Nothing exprLitV :: Maybe (HWType,Size) -> Literal -> VerilogM Doc exprLitV = exprLit undefValue exprLit :: Lens' s (Maybe (Maybe Int)) -> Maybe (HWType,Size) -> Literal -> Ap (State s) Doc exprLit _ Nothing (NumLit i) = integer i exprLit k (Just (hty,sz)) (NumLit i) = case hty of Unsigned _ | i < 0 -> string "-" <> int sz <> string "'d" <> integer (abs i) | otherwise -> int sz <> string "'d" <> integer i Index _ -> int (typeSize hty) <> string "'d" <> integer i Signed _ | i < 0 -> string "-" <> int sz <> string "'sd" <> integer (abs i) | otherwise -> int sz <> string "'sd" <> integer i _ -> int sz <> string "'b" <> blit where blit = bits k (toBits sz i) exprLit k (Just (_,sz)) (BitVecLit m i) = int sz <> string "'b" <> bvlit where bvlit = bits k (toBits' sz m i) exprLit _ _ (BoolLit t) = string $ if t then "1'b1" else "1'b0" exprLit k _ (BitLit b) = string "1'b" <> bit_char k b exprLit _ _ (StringLit s) = string . pack $ show s exprLit _ _ l = error $ $(curLoc) ++ "exprLit: " ++ show l toBits :: Integral a => Int -> a -> [Bit] toBits size val = map (\x -> if odd x then H else L) $ reverse $ take size $ map (`mod` 2) $ iterate (`div` 2) val toBits' :: Integral a => Int -> a -> a -> [Bit] toBits' size msk val = map (\(m,i) -> if odd m then U else (if odd i then H else L)) $ ( reverse . take size) $ zip ( map (`mod` 2) $ iterate (`div` 2) msk) ( map (`mod` 2) $ iterate (`div` 2) val) bits :: Lens' s (Maybe (Maybe Int)) -> [Bit] -> Ap (State s) Doc bits k = hcat . traverse (bit_char k) bit_char' :: Bit -> Char bit_char' H = '1' bit_char' L = '0' bit_char' U = 'x' bit_char' Z = 'z' bit_char :: Lens' s (Maybe (Maybe Int)) -> Bit -> Ap (State s) Doc bit_char k b = do udf <- Ap (use k) case (udf,b) of (Just Nothing,U) -> char '0' (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)) listBraces :: Monad m => m [Doc] -> m Doc listBraces = align . enclose lbrace rbrace . hsep . punctuate (comma <+> softline) parenIf :: Monad m => Bool -> m Doc -> m Doc parenIf True = parens parenIf False = id punctuate' :: Monad m => Ap m Doc -> Ap m [Doc] -> Ap m Doc punctuate' s d = vcat (punctuate s d) <> s 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 encodingNote _ = emptyDoc clash-lib-1.8.1/src/Clash/Backend/Verilog/0000755000000000000000000000000007346545000016327 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Backend/Verilog/Time.hs0000644000000000000000000000635507346545000017572 0ustar0000000000000000{-| 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)) clash-lib-1.8.1/src/Clash/Core/0000755000000000000000000000000007346545000014261 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Core/DataCon.hs0000644000000000000000000000462407346545000016134 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2017, Google Inc., 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Data Constructors in CoreHW -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Clash.Core.DataCon ( DataCon (..) , DcName , ConTag , DcStrictness(..) ) where import Control.DeepSeq (NFData(..)) import Data.Binary (Binary) import Data.Function (on) import Data.Hashable (Hashable) import qualified Data.Text as Text import GHC.Generics (Generic) import Clash.Core.Name (Name (..)) import {-# SOURCE #-} Clash.Core.Type (Type) import Clash.Core.Var (TyVar) import Clash.Unique -- | Data Constructor data DataCon = MkData { dcName :: !DcName -- ^ Name of the DataCon , dcUniq :: {-# UNPACK #-} !Unique -- ^ Invariant: forall x . dcUniq x ~ nameUniq (dcName x) , dcTag :: !ConTag -- ^ Syntactical position in the type definition , dcType :: !Type -- ^ Type of the 'DataCon , dcUnivTyVars :: [TyVar] -- ^ Universally quantified type-variables, these type variables are also part -- of the result type of the DataCon , dcExtTyVars :: [TyVar] -- ^ Existentially quantified type-variables, these type variables are not -- part of the result of the DataCon, but only of the arguments. , dcArgTys :: [Type] -- ^ Argument types , dcArgStrict :: [DcStrictness] -- ^ Argument strictness , dcFieldLabels :: [Text.Text] -- ^ Names of fields. Used when data constructor is referring to a record type. } deriving (Generic,NFData,Binary) instance Show DataCon where show = show . dcName instance Eq DataCon where (==) = (==) `on` dcUniq (/=) = (/=) `on` dcUniq instance Ord DataCon where compare = compare `on` dcUniq instance Uniquable DataCon where getUnique = dcUniq setUnique dc u = dc {dcUniq=u, dcName=(dcName dc){nameUniq=u}} -- | Syntactical position of the DataCon in the type definition type ConTag = Int -- | DataCon reference type DcName = Name DataCon data DcStrictness = Strict | Lazy deriving (Generic, NFData, Eq, Hashable, Binary) clash-lib-1.8.1/src/Clash/Core/EqSolver.hs0000644000000000000000000001276107346545000016364 0ustar0000000000000000{-| Copyright : (C) 2021 QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Core.EqSolver where import Data.List.Extra (zipEqual) import Data.Maybe (catMaybes, mapMaybe) import Clash.Core.Name (Name(nameOcc)) import Clash.Core.Term import Clash.Core.TyCon import Clash.Core.Type import Clash.Core.Var import Clash.Core.VarEnv (VarSet, elemVarSet, emptyVarSet, mkVarSet) #if MIN_VERSION_ghc(9,0,0) import Clash.Core.DataCon (dcUniq) import GHC.Builtin.Names (unsafeReflDataConKey) import GHC.Types.Unique (getKey) #endif -- | Data type that indicates what kind of solution (if any) was found data TypeEqSolution = Solution (TyVar, Type) -- ^ Solution was found. Variable equals some integer. | AbsurdSolution -- ^ A solution was found, but it involved negative naturals. | NoSolution -- ^ Given type wasn't an equation, or it was unsolvable. deriving (Show, Eq) catSolutions :: [TypeEqSolution] -> [(TyVar, Type)] catSolutions = mapMaybe getSol where getSol (Solution s) = Just s getSol _ = Nothing -- | Solve given equations and return all non-absurd solutions solveNonAbsurds :: TyConMap -> VarSet -> [(Type, Type)] -> [(TyVar, Type)] solveNonAbsurds _tcm _ [] = [] solveNonAbsurds tcm solveSet (eq:eqs) = solved ++ solveNonAbsurds tcm solveSet eqs where solvers = [pure . solveAdd solveSet, solveEq tcm solveSet] solved = catSolutions (concat [s eq | s <- solvers]) -- | Solve simple equalities such as: -- -- * a ~ 3 -- * 3 ~ a -- * SomeType a b ~ SomeType 3 5 -- * SomeType 3 5 ~ SomeType a b -- * SomeType a 5 ~ SomeType 3 b -- solveEq :: TyConMap -> VarSet -> (Type, Type) -> [TypeEqSolution] solveEq tcm solveSet (coreView tcm -> left, coreView tcm -> right) = case (left, right) of (VarTy tyVar, ConstTy {}) | elemVarSet tyVar solveSet -> -- a ~ 3 [Solution (tyVar, right)] (ConstTy {}, VarTy tyVar) | elemVarSet tyVar solveSet -> -- 3 ~ a [Solution (tyVar, left)] (ConstTy {}, ConstTy {}) -> -- Int /= Char if left /= right then [AbsurdSolution] else [] (LitTy {}, LitTy {}) -> -- 3 /= 5 if left /= right then [AbsurdSolution] else [] _ -> -- The call to 'coreView' at the start of 'solveEq' should have reduced -- all solvable type families. If we encounter one here that means the -- type family is stuck (and that we shouldn't compare it to anything!). if any (isTypeFamilyApplication tcm) [left, right] then [] else case (tyView left, tyView right) of (TyConApp leftNm leftTys, TyConApp rightNm rightTys) -> -- SomeType a b ~ SomeType 3 5 (or other way around) if leftNm == rightNm then concat (map (solveEq tcm solveSet) (zipEqual leftTys rightTys)) else [AbsurdSolution] _ -> [] -- | Solve equations supported by @normalizeAdd@. See documentation of -- @TypeEqSolution@ to understand the return value. solveAdd :: VarSet -> (Type, Type) -> TypeEqSolution solveAdd solveSet ab = case normalizeAdd ab of Just (n, m, VarTy tyVar) | elemVarSet tyVar solveSet -> if n >= 0 && m >= 0 && n - m >= 0 then Solution (tyVar, (LitTy (NumTy (n - m)))) else AbsurdSolution _ -> NoSolution -- | Given the left and right side of an equation, normalize it such that -- equations of the following forms: -- -- * 5 ~ n + 2 -- * 5 ~ 2 + n -- * n + 2 ~ 5 -- * 2 + n ~ 5 -- -- are returned as (5, 2, n) normalizeAdd :: (Type, Type) -> Maybe (Integer, Integer, Type) normalizeAdd (a, b) = do (n, rhs) <- lhsLit a b case tyView rhs of TyConApp (nameOcc -> "GHC.TypeNats.+") [left, right] -> do (m, o) <- lhsLit left right return (n, m, o) _ -> Nothing where lhsLit x (LitTy (NumTy n)) = Just (n, x) lhsLit (LitTy (NumTy n)) y = Just (n, y) lhsLit _ _ = Nothing -- | Tests for nonsencical patterns due to types being "absurd". See -- @isAbsurdEq@ for more info. isAbsurdPat :: TyConMap -> Pat -> Bool #if MIN_VERSION_base(4,15,0) isAbsurdPat _tcm (DataPat dc _ _) -- unsafeCoerce is not absurd in the way intended by /isAbsurdPat/ | dcUniq dc == getKey unsafeReflDataConKey = False #endif isAbsurdPat tcm pat = any (isAbsurdEq tcm exts) (patEqs tcm pat) where exts = case pat of DataPat _dc extNms _ids -> mkVarSet extNms _ -> emptyVarSet -- | Determines if an "equation" obtained through @patEqs@ or @typeEq@ is -- absurd. That is, it tests if two types that are definitely not equal are -- asserted to be equal OR if the computation of the types yield some absurd -- (intermediate) result such as -1. isAbsurdEq :: TyConMap -> VarSet -- ^ existential tvs -> (Type, Type) -> Bool isAbsurdEq tcm exts ((left0, right0)) = case (coreView tcm left0, coreView tcm right0) of (solveAdd exts -> AbsurdSolution) -> True lr -> any (==AbsurdSolution) (solveEq tcm exts lr) -- | Get constraint equations patEqs :: TyConMap -> Pat -> [(Type, Type)] patEqs tcm pat = catMaybes (map (typeEq tcm . varType) (snd (patIds pat))) -- | If type is an equation, return LHS and RHS. typeEq :: TyConMap -> Type -> Maybe (Type, Type) typeEq tcm ty = case tyView (coreView tcm ty) of TyConApp (nameOcc -> "GHC.Prim.~#") [_, _, left, right] -> Just (coreView tcm left, coreView tcm right) _ -> Nothing clash-lib-1.8.1/src/Clash/Core/Evaluator/0000755000000000000000000000000007346545000016223 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Core/Evaluator/Types.hs0000644000000000000000000002573507346545000017677 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-| Copyright : (C) 2020-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Types for the Partial Evaluator -} module Clash.Core.Evaluator.Types where import Control.Concurrent.Supply (Supply) import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap (insert, lookup) import Data.List (foldl') import Data.Maybe (fromMaybe, isJust) #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter (hsep) #else import Data.Text.Prettyprint.Doc (hsep) #endif import Clash.Core.DataCon (DataCon, dcType) import Clash.Core.HasType import Clash.Core.Literal (Literal(CharLiteral)) import Clash.Core.Pretty (fromPpr, ppr, showPpr) import Clash.Core.Term (Term(..), PrimInfo(..), TickInfo, Alt, mkApps) import Clash.Core.TyCon (TyConMap) import Clash.Core.Type (Type (..), mkFunTy) import Clash.Core.Var (Id, IdScope(..), TyVar) import Clash.Core.VarEnv import Clash.Driver.Types (BindingMap, bindingTerm) import Clash.Pretty (ClashPretty(..), fromPretty, showDoc) whnf' :: Evaluator -> BindingMap -> VarEnv Term -> TyConMap -> PrimHeap -> Supply -> InScopeSet -> Bool -> Term -> (PrimHeap, PureHeap, Term) 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 lh [] ids is e gh = mapVarEnv bindingTerm bm -- | Evaluate to WHNF given an existing Heap and Stack whnf :: Evaluator -> TyConMap -> Bool -> Machine -> Machine whnf eval tcm isSubj m | isSubj = -- See [Note: empty case expressions] let ty = inferCoreTypeOf tcm (mTerm m) in go (stackPush (Scrutinise ty []) m) | otherwise = go m where go :: Machine -> Machine go s = case step eval s tcm of Just s' -> go s' Nothing -> fromMaybe (error . showDoc . ppr $ mTerm m) (unwindStack s) -- | An evaluator is a collection of basic building blocks which are used to -- define partial evaluation. In this implementation, it consists of two types -- of function: -- -- * steps, which applies the reduction realtion to the current term -- * unwindings, which pop the stack and evaluate the stack frame -- -- Variants of these functions also exist for evalauting primitive operations. -- This is because there may be multiple frontends to the compiler which can -- reuse a common step and unwind, but have different primitives. -- data Evaluator = Evaluator { step :: Step , unwind :: Unwind , primStep :: PrimStep , primUnwind :: PrimUnwind } -- | Completely unwind the stack to get back the complete term unwindStack :: Machine -> Maybe Machine unwindStack m | stackNull m = Just m | otherwise = do (m', kf) <- stackPop m case kf of PrimApply p tys vs tms -> let term = foldl' App (foldl' App (foldl' TyApp (Prim p) tys) (fmap valToTerm vs)) (mTerm m' : tms) in unwindStack (setTerm term m') Instantiate ty -> let term = TyApp (getTerm m') ty in unwindStack (setTerm term m') Apply n -> case heapLookup LocalId n m' of Just e -> let term = App (getTerm m') e in unwindStack (setTerm term m') Nothing -> error $ unlines $ [ "Clash.Core.Evaluator.unwindStack:" , "Stack:" ] <> [ " " <> showDoc (clashPretty frame) | frame <- mStack m] <> [ "" , "Expression:" , showPpr (mTerm m) , "" , "Heap:" , showDoc (clashPretty $ mHeapLocal m) ] Scrutinise _ [] -> unwindStack m' Scrutinise ty alts -> let term = Case (getTerm m') ty alts in unwindStack (setTerm term m') Update LocalId x -> unwindStack (heapInsert LocalId x (mTerm m') m') Update GlobalId _ -> unwindStack m' Tickish sp -> let term = Tick sp (getTerm m') in unwindStack (setTerm term m') -- | A single step in the partial evaluator. The result is the new heap and -- stack, and the next expression to be reduced. -- type Step = Machine -> TyConMap -> Maybe Machine type Unwind = Value -> Step type PrimStep = TyConMap -> Bool -> PrimInfo -> [Type] -> [Value] -> Machine -> Maybe Machine type PrimUnwind = TyConMap -> PrimInfo -> [Type] -> [Value] -> Value -> [Term] -> Machine -> Maybe Machine -- | A machine represents the current state of the abstract machine used to -- evaluate terms. A machine has a term under evaluation, a stack, and three -- heaps: -- -- * a primitive heap to store IO values from primitives (like ByteArrays) -- * a global heap to store top-level bindings in scope -- * a local heap to store local bindings in scope -- -- Machines also include a unique supply and InScopeSet. These are needed when -- new heap bindings are created, and are just an implementation detail. -- data Machine = Machine { mHeapPrim :: PrimHeap , mHeapGlobal :: PureHeap , mHeapLocal :: PureHeap , mStack :: Stack , mSupply :: Supply , mScopeNames :: InScopeSet , mTerm :: Term } instance Show Machine where show (Machine ph gh lh s _ _ x) = unlines [ "Machine:" , "" , "Heap (Prim):" , show ph , "" , "Heap (Globals):" , show gh , "" , "Heap (Locals):" , show lh , "" , "Stack:" , show (fmap clashPretty s) , "" , "Term:" , show x ] type PrimHeap = (IntMap Term, Int) type PureHeap = VarEnv Term type Stack = [StackFrame] data StackFrame = Update IdScope Id | Apply Id | Instantiate Type | PrimApply PrimInfo [Type] [Value] [Term] | Scrutinise Type [Alt] | Tickish TickInfo deriving Show instance ClashPretty StackFrame where clashPretty (Update GlobalId i) = hsep ["Update(Global)", fromPpr i] clashPretty (Update LocalId i) = hsep ["Update(Local)", fromPpr i] clashPretty (Apply i) = hsep ["Apply", fromPpr i] clashPretty (Instantiate t) = hsep ["Instantiate", fromPpr t] clashPretty (PrimApply p tys vs ts) = hsep ["PrimApply", fromPretty (primName p), "::", fromPpr (coreTypeOf p), "; type args=", fromPpr tys, "; val args=", fromPpr (map valToTerm vs), "term args=", fromPpr ts] clashPretty (Scrutinise a b) = hsep ["Scrutinise ", fromPpr a, fromPpr (Case (Literal (CharLiteral '_')) a b)] clashPretty (Tickish sp) = hsep ["Tick", fromPpr sp] -- Values data Value = Lambda Id Term -- ^ Functions | TyLambda TyVar Term -- ^ Type abstractions | DC DataCon [Either Term Type] -- ^ Data constructors | Lit Literal -- ^ Literals | PrimVal PrimInfo [Type] [Value] -- ^ Clash's number types are represented by their "fromInteger#" primitive -- function. So some primitives are values. | Suspend Term -- ^ Used by lazy primitives | TickValue TickInfo Value -- ^ Preserve ticks from Terms in Values | CastValue Value Type Type -- ^ Preserve casts from Terms in Values deriving Show instance InferType Value where inferCoreTypeOf tcm = go where go = \case Lambda i t -> mkFunTy (coreTypeOf i) (inferCoreTypeOf tcm t) TyLambda v t -> ForAllTy v (inferCoreTypeOf tcm t) DC dc args -> applyTypeToArgs (mkApps (Data dc) args) tcm (dcType dc) args Lit l -> coreTypeOf l PrimVal p tys vals -> let args = map Right tys ++ map (Left . valToTerm) vals in applyTypeToArgs (mkApps (Prim p) args) tcm (primType p) args Suspend t -> inferCoreTypeOf tcm t TickValue _ v -> go v CastValue _ _ t -> t valToTerm :: Value -> Term valToTerm v = case v of Lambda x e -> Lam x e TyLambda x e -> TyLam x e DC dc pxs -> foldl' (\e a -> either (App e) (TyApp e) a) (Data dc) pxs Lit l -> Literal l PrimVal ty tys vs -> foldl' App (foldl' TyApp (Prim ty) tys) (map valToTerm vs) Suspend e -> e TickValue t x -> Tick t (valToTerm x) CastValue x t1 t2 -> Cast (valToTerm x) t1 t2 -- Collect all the ticks from a value, exposing the ticked value. -- collectValueTicks :: Value -> (Value, [TickInfo]) collectValueTicks = go [] where go ticks (TickValue t v) = go (t:ticks) v go ticks v = (v, ticks) -- | Are we in a context where special primitives must be forced. -- -- See [Note: forcing special primitives] 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 primCount = snd . mHeapPrim primLookup :: Int -> Machine -> Maybe Term primLookup i = IntMap.lookup i . fst . mHeapPrim primInsert :: Int -> Term -> Machine -> Machine primInsert i x m = let (gh, c) = mHeapPrim m in m { mHeapPrim = (IntMap.insert i x gh, c + 1) } primUpdate :: Int -> Term -> Machine -> Machine primUpdate i x m = let (gh, c) = mHeapPrim m in m { mHeapPrim = (IntMap.insert i x gh, c) } heapLookup :: IdScope -> Id -> Machine -> Maybe Term heapLookup GlobalId i m = lookupVarEnv i $ mHeapGlobal m heapLookup LocalId i m = lookupVarEnv i $ mHeapLocal m heapContains :: IdScope -> Id -> Machine -> Bool heapContains scope i = isJust . heapLookup scope i heapInsert :: IdScope -> Id -> Term -> Machine -> Machine heapInsert GlobalId i x m = m { mHeapGlobal = extendVarEnv i x (mHeapGlobal m) } heapInsert LocalId i x m = m { mHeapLocal = extendVarEnv i x (mHeapLocal m) } heapDelete :: IdScope -> Id -> Machine -> Machine heapDelete GlobalId i m = m { mHeapGlobal = delVarEnv (mHeapGlobal m) i } heapDelete LocalId i m = m { mHeapLocal = delVarEnv (mHeapLocal m) i } stackPush :: StackFrame -> Machine -> Machine stackPush f m = m { mStack = f : mStack m } stackPop :: Machine -> Maybe (Machine, StackFrame) stackPop m = case mStack m of [] -> Nothing (x:xs) -> Just (m { mStack = xs }, x) stackClear :: Machine -> Machine stackClear m = m { mStack = [] } stackNull :: Machine -> Bool stackNull = null . mStack getTerm :: Machine -> Term getTerm = mTerm setTerm :: Term -> Machine -> Machine setTerm x m = m { mTerm = x } clash-lib-1.8.1/src/Clash/Core/FreeVars.hs0000644000000000000000000002157407346545000016343 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Free variable calculations -} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} module Clash.Core.FreeVars (-- * Free variable calculation typeFreeVars , freeIds , freeLocalVars , freeLocalIds , globalIds , termFreeTyVars -- * occurrence check , globalIdOccursIn , localVarsDoNotOccurIn , countFreeOccurances -- * Internal , typeFreeVars' , termFreeVars' ) where import qualified Control.Lens as Lens import Control.Lens.Fold (Fold) import Control.Lens.Getter (Contravariant) import Data.Coerce import qualified Data.IntSet as IntSet import Data.Monoid (All (..), Any (..)) import Clash.Core.Term (Pat (..), Term (..), TickInfo (..), Bind(..)) import Clash.Core.Type (Type (..)) import Clash.Core.Var (Id, IdScope (..), TyVar, Var (..), isLocalId) import Clash.Core.VarEnv (VarEnv, emptyVarEnv, unionVarEnvWith, unitVarEnv) -- | Gives the free type-variables in a Type, implemented as a 'Fold' -- -- The 'Fold' is closed over the types of its variables, so: -- -- @ -- foldMapOf typeFreeVars unitVarSet ((a:* -> k) Int) = {a, k} -- @ typeFreeVars :: Fold Type TyVar typeFreeVars = typeFreeVars' (const True) IntSet.empty -- | Gives the "interesting" free variables in a Type, implemented as a 'Fold' -- -- The 'Fold' is closed over the types of variables, so: -- -- @ -- foldMapOf (typeFreeVars' (const True) IntSet.empty) unitVarSet ((a:* -> k) Int) = {a, k} -- @ -- -- Note [Closing over kind variables] -- -- Consider the type -- -- > forall k . b -> k -- -- where -- -- > b :: k -> Type -- -- When we close over the free variables of @forall k . b -> k@, i.e. @b@, then -- the @k@ in @b :: k -> Type@ is most definitely /not/ the @k@ in -- @forall k . b -> k@. So when a type variable is free, i.e. not in the inScope -- set, its kind variables also aren´t; so in order to prevent collisions due to -- shadowing we close using an empty inScope set. -- -- See also: https://gitlab.haskell.org/ghc/ghc/-/commit/503514b94f8dc7bd9eab5392206649aee45f140b typeFreeVars' :: (Contravariant f, Applicative f) => (forall b . Var b -> Bool) -- ^ Predicate telling whether a variable is interesting -> IntSet.IntSet -- ^ Uniques of the variables in scope, used by 'termFreeVars'' -> (Var a -> f (Var a)) -> Type -> f Type typeFreeVars' interesting is f = go is where go inScope = \case VarTy tv -> tv1 <* go inScope1 (varType tv) where isInteresting = interesting tv tvInScope = varUniq tv `IntSet.member` inScope inScope1 | tvInScope = inScope | otherwise = IntSet.empty -- See Note [Closing over type variables] tv1 | isInteresting , not tvInScope = VarTy . coerce <$> f (coerce tv) | otherwise = pure (VarTy tv) ForAllTy tv ty -> ForAllTy <$> goBndr inScope tv <*> go (IntSet.insert (varUniq tv) inScope) ty AppTy l r -> AppTy <$> go inScope l <*> go inScope r ty -> pure ty goBndr inScope tv = (\t -> tv {varType = t}) <$> go inScope (varType tv) -- | Check whether a set of variables does not occur free in a term localVarsDoNotOccurIn :: [Var a] -> Term -> Bool localVarsDoNotOccurIn vs e = getAll (Lens.foldMapOf freeLocalVars (All . (`notElem` vs)) e) -- | Check whether a local identifier occurs free in a term globalIdOccursIn :: Id -> Term -> Bool globalIdOccursIn v e = getAny (Lens.foldMapOf globalIds (Any . (== v)) e) -- | Calculate the /local/ free variable of an expression: the free type -- variables and the free identifiers that are not bound in the global -- environment. freeLocalVars :: Fold Term (Var a) freeLocalVars = termFreeVars' isLocalVar where isLocalVar (Id {idScope = GlobalId}) = False isLocalVar _ = True -- | Gives the free identifiers of a Term, implemented as a 'Fold' freeIds :: Fold Term Id freeIds = termFreeVars' isId where isId (Id {}) = True isId _ = False -- | Calculate the /local/ free identifiers of an expression: the free -- identifiers that are not bound in the global environment. freeLocalIds :: Fold Term Id freeLocalIds = termFreeVars' isLocalId -- | Calculate the /global/ free identifiers of an expression: the free -- identifiers that are bound in the global environment. globalIds :: Fold Term Id globalIds = termFreeVars' isGlobalId where isGlobalId (Id {idScope = GlobalId}) = True isGlobalId _ = False -- | Gives the free type-variables of a Term, implemented as a 'Fold' -- -- The 'Fold' is closed over the types of variables, so: -- -- @ -- foldMapOf termFreeTyVars unitVarSet (case (x : (a:* -> k) Int)) of {}) = {a, k} -- @ termFreeTyVars :: Fold Term TyVar termFreeTyVars = termFreeVars' isTV where isTV (TyVar {}) = True isTV _ = False -- | Gives the "interesting" free variables in a Term, implemented as a 'Fold' -- -- The 'Fold' is closed over the types of variables, so: -- -- @ -- foldMapOf (termFreeVars' (const True)) unitVarSet (case (x : (a:* -> k) Int)) of {}) = {x, a, k} -- @ -- -- Note [Closing over type variables] -- -- Consider the term -- -- > /\(k :: Type) -> \(b :: k) -> a -- -- where -- -- > a :: k -- -- When we close over the free variables of @/\k -> \(b :: k) -> (a :: k)@, i.e. -- @a@, then the @k@ in @a :: k@ is most definitely /not/ the @k@ in introduced -- by the @/\k ->@. So when a term variable is free, i.e. not in the inScope -- set, its type variables also aren´t; so in order to prevent collisions due to -- shadowing we close using an empty inScope set. -- -- See also: https://gitlab.haskell.org/ghc/ghc/-/commit/503514b94f8dc7bd9eab5392206649aee45f140b termFreeVars' :: (Contravariant f, Applicative f) => (forall b . Var b -> Bool) -- ^ Predicate telling whether a variable is interesting -> (Var a -> f (Var a)) -> Term -> f Term termFreeVars' interesting f = go IntSet.empty where go inLocalScope = \case Var v -> v1 <* typeFreeVars' interesting inLocalScope1 f (varType v) where isInteresting = interesting v vInScope = isLocalId v && varUniq v `IntSet.member` inLocalScope inLocalScope1 | vInScope = inLocalScope | otherwise = IntSet.empty -- See Note [Closing over type variables] v1 | isInteresting , not vInScope = Var . coerce <$> f (coerce v) | otherwise = pure (Var v) Lam id_ tm -> Lam <$> goBndr inLocalScope id_ <*> go (IntSet.insert (varUniq id_) inLocalScope) tm TyLam tv tm -> TyLam <$> goBndr inLocalScope tv <*> go (IntSet.insert (varUniq tv) inLocalScope) tm App l r -> App <$> go inLocalScope l <*> go inLocalScope r TyApp l r -> TyApp <$> go inLocalScope l <*> typeFreeVars' interesting inLocalScope f r Let (NonRec i x) e -> Let <$> (NonRec <$> goBndr inLocalScope i <*> go inLocalScope x) <*> go (IntSet.insert (varUniq i) inLocalScope) e Let (Rec bs) e -> Let <$> (Rec <$> traverse (goBind inLocalScope') bs) <*> go inLocalScope' e where inLocalScope' = foldr (IntSet.insert . varUniq . fst) inLocalScope bs Case subj ty alts -> Case <$> go inLocalScope subj <*> typeFreeVars' interesting inLocalScope f ty <*> traverse (goAlt inLocalScope) alts Cast tm t1 t2 -> Cast <$> go inLocalScope tm <*> typeFreeVars' interesting inLocalScope f t1 <*> typeFreeVars' interesting inLocalScope f t2 Tick tick tm -> Tick <$> goTick inLocalScope tick <*> go inLocalScope tm tm -> pure tm goBndr inLocalScope v = (\t -> v {varType = t}) <$> typeFreeVars' interesting inLocalScope f (varType v) goBind inLocalScope (l,r) = (,) <$> goBndr inLocalScope l <*> go inLocalScope r goAlt inLocalScope (pat,alt) = case pat of DataPat dc tvs ids -> (,) <$> (DataPat <$> pure dc <*> traverse (goBndr inLocalScope') tvs <*> traverse (goBndr inLocalScope') ids) <*> go inLocalScope' alt where inLocalScope' = foldr IntSet.insert (foldr IntSet.insert inLocalScope (map varUniq tvs)) (map varUniq ids) _ -> (,) <$> pure pat <*> go inLocalScope alt goTick inLocalScope = \case NameMod m ty -> NameMod m <$> typeFreeVars' interesting inLocalScope f ty tick -> pure tick -- | Get the free variables of an expression and count the number of occurrences countFreeOccurances :: Term -> VarEnv Int countFreeOccurances = Lens.foldMapByOf freeLocalIds (unionVarEnvWith (+)) emptyVarEnv (`unitVarEnv` (1 :: Int)) clash-lib-1.8.1/src/Clash/Core/HasFreeVars.hs0000644000000000000000000000545107346545000016773 0ustar0000000000000000{-| Copyright : (C) 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Utility class to extract free variables from data which has variables. -} {-# LANGUAGE FlexibleInstances #-} module Clash.Core.HasFreeVars ( HasFreeVars(..) ) where import Control.Lens as Lens (foldMapOf) import Data.Monoid (All(..), Any(..)) import Clash.Core.FreeVars import Clash.Core.Term (Term) import Clash.Core.Type (Type(..)) import Clash.Core.Var (Var) import Clash.Core.VarEnv class HasFreeVars a where {-# MINIMAL freeVarsOf #-} freeVarsOf :: a -> VarSet {-# INLINE isClosed #-} -- | Something is closed if it has no free variables. -- This function may be replaced with a more efficient implementation. isClosed :: a -> Bool isClosed = nullVarSet . freeVarsOf {-# INLINE elemFreeVars #-} -- | Check if a variable is free in the given value. -- This function may be replaced with a more efficient implementation. elemFreeVars :: Var a -> a -> Bool elemFreeVars v = elemVarSet v . freeVarsOf {-# INLINE notElemFreeVars #-} -- | Check if a variable is not free in the given value. -- This function may be replaced with a more efficient implementation. notElemFreeVars :: Var a -> a -> Bool notElemFreeVars x = notElemVarSet x . freeVarsOf {-# INLINE subsetFreeVars #-} -- | Check if all variables in a set are free in the given value. -- This function may be replaced with a more efficient implementation. subsetFreeVars :: VarSet -> a -> Bool subsetFreeVars xs = subsetVarSet xs . freeVarsOf {-# INLINE disjointFreeVars #-} -- | Check if no variables in a set are free in the given value. -- This function may be replaced with a more efficient implementation. disjointFreeVars :: VarSet -> a -> Bool disjointFreeVars xs = disjointVarSet xs . freeVarsOf instance HasFreeVars Term where {-# INLINE freeVarsOf #-} freeVarsOf = Lens.foldMapOf freeLocalVars unitVarSet elemFreeVars v e = getAny (Lens.foldMapOf freeLocalVars (Any . (== v)) e) notElemFreeVars v e = getAll (Lens.foldMapOf freeLocalVars (All . (/= v)) e) disjointFreeVars vs e = getAll (Lens.foldMapOf freeLocalVars (All . (`notElem` vs)) e) instance HasFreeVars Type where {-# INLINE freeVarsOf #-} freeVarsOf = Lens.foldMapOf typeFreeVars unitVarSet isClosed ty = case ty of VarTy{} -> False ForAllTy{} -> getAll (Lens.foldMapOf typeFreeVars (const (All False)) ty) AppTy l r -> isClosed l && isClosed r _ -> True elemFreeVars v ty = getAny (Lens.foldMapOf typeFreeVars (Any . (== v)) ty) notElemFreeVars v ty = getAll (Lens.foldMapOf typeFreeVars (All . (/= v)) ty) instance (Foldable f, HasFreeVars a) => HasFreeVars (f a) where {-# INLINE freeVarsOf #-} freeVarsOf = foldMap freeVarsOf clash-lib-1.8.1/src/Clash/Core/HasType.hs0000644000000000000000000001705107346545000016176 0ustar0000000000000000{-| Copyright : (C) 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Utility class to extract type information from data which has a type. -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Core.HasType ( HasType(..) , coreKindOf , InferType(..) , inferCoreKindOf , applyTypeToArgs , piResultTy , piResultTys ) where #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter (line) #else import Data.Text.Prettyprint.Doc (line) #endif import GHC.Stack (HasCallStack) import Clash.Core.DataCon (DataCon(dcType)) import Clash.Core.HasFreeVars import Clash.Core.Literal (Literal(..)) import Clash.Core.Pretty import Clash.Core.Subst import Clash.Core.Term (Term(..), IsMultiPrim(..), PrimInfo(..), collectArgs) 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.Util (curLoc, pprPanic) import qualified Clash.Util.Interpolate as I class HasType a where coreTypeOf :: a -> Type coreKindOf :: (HasType a) => a -> Kind coreKindOf = coreTypeOf {-# INLINE coreKindOf #-} instance HasType DataCon where coreTypeOf = dcType instance HasType Literal where coreTypeOf = \case IntegerLiteral _ -> integerPrimTy IntLiteral _ -> intPrimTy WordLiteral _ -> wordPrimTy StringLiteral _ -> stringPrimTy FloatLiteral _ -> floatPrimTy DoubleLiteral _ -> doublePrimTy 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 instance HasType PrimInfo where coreTypeOf pr = case primMultiResult pr of SingleResult -> primType pr -- See Note [MultiResult type] in Clash.Normalize.Transformations.MultiPrim MultiResult | let (primArgs, primResTy) = splitFunForallTy (primType pr) , TyConApp tupTcNm tupArgs <- tyView primResTy , isTupleTyConLike tupTcNm -> mkPolyFunTy primResTy (primArgs <> fmap Right tupArgs) | otherwise -> error "PrimInfo.coreTypeOf: MultiResult primitive without tuple type" instance HasType TyCon where coreTypeOf = tyConKind instance HasType Type where coreTypeOf = id instance HasType (Var a) where coreTypeOf = varType class InferType a where inferCoreTypeOf :: TyConMap -> a -> Type inferCoreKindOf :: (InferType a) => TyConMap -> a -> Kind inferCoreKindOf = inferCoreTypeOf {-# INLINE inferCoreKindOf #-} instance InferType Type where inferCoreTypeOf tcm ty = case tyView ty of FunTy{} -> liftedTypeKind TyConApp tc args -> piResultTys tcm (tyConKind (UniqMap.find tc tcm)) args OtherType{} -> case ty of ConstTy c -> error $ $(curLoc) ++ "inferCoreTypeOf: naked ConstTy: " ++ show c VarTy k -> varType k 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 go (AppTy c d) args = go c (d : args) go c args = piResultTys tcm (inferCoreTypeOf tcm c) args instance InferType Term where inferCoreTypeOf tcm = go where go = \case Var i -> coreTypeOf i Data dc -> coreTypeOf dc Literal l -> coreTypeOf l Prim pr -> coreTypeOf pr Lam i x -> mkFunTy (coreTypeOf i) (go x) TyLam i x -> ForAllTy i (go x) x@App{} -> case collectArgs x of (fun, args) -> applyTypeToArgs x tcm (go fun) args x@TyApp{} -> case collectArgs x of (fun, args) -> applyTypeToArgs x tcm (go fun) args Let _ x -> go x Case _ ty _ -> ty Cast _ _ a -> a Tick _ x -> go x -- | Get the result type of a polymorphic function given a list of arguments applyTypeToArgs :: Term -- ^ The complete term, used for error messages. -> TyConMap -> Type -> [Either Term Type] -> Type applyTypeToArgs e m opTy args = go opTy args where go opTy' [] = opTy' go opTy' (Right ty:args') = goTyArgs opTy' [ty] args' go opTy' (Left a:args') = case splitFunTy m opTy' of Just (_,resTy) -> go resTy args' _ -> error [I.i| Unexpected application. The term #{showPpr e} applied an argument #{showPpr a} to something with the non-function type #{showPpr opTy'} |] goTyArgs opTy' revTys (Right ty:args') = goTyArgs opTy' (ty:revTys) args' goTyArgs opTy' revTys args' = go (piResultTys m opTy' (reverse revTys)) args' -- | Like 'piResultTys', but only applies a single type. If multiple types are -- being applied use 'piResultTys', as it is more efficient to only substitute -- once with many types. piResultTy :: HasCallStack => TyConMap -> Type -> Type -> Type piResultTy m ty arg = piResultTys m ty [arg] -- | @(piResultTys f_ty [ty1, ..., tyn])@ gives the type of @(f ty1 .. tyn)@ -- where @f :: f_ty@ -- -- 'piResultTys' is interesting because: -- -- 1. 'f_ty' may have more foralls than there are args -- 2. Less obviously, it may have fewer foralls -- -- Fore case 2. think of: -- -- piResultTys (forall a . a) [forall b.b, Int] -- -- This really can happen, such as situations involving 'undefined's type: -- -- undefined :: forall a. a -- -- undefined (forall b. b -> b) Int -- -- This term should have the type @(Int -> Int)@, but notice that there are -- more type args than foralls in 'undefined's type. -- -- For efficiency reasons, when there are no foralls, we simply drop arrows from -- a function type/kind. piResultTys :: HasCallStack => TyConMap -> Type -> [Type] -> Type piResultTys _ ty [] = ty piResultTys m ty origArgs@(arg:args) | Just ty' <- coreView1 m ty = piResultTys m ty' origArgs | FunTy a res <- tyView ty -- TODO coreView is used here because the partial evaluator will sometimes -- encounter / not encounter a Signal as an argument unexpectedly. When PR -- #1064 is merged the coreView calls should be removed again. = if debugIsOn && not (aeqType (coreView m a) (coreView m arg)) then error [I.i| Unexpected application. A function with type: #{showPpr ty} Got applied to an argument of type: #{showPpr arg} |] else piResultTys m res args | ForAllTy tv res <- ty = go (extendVarEnv tv arg emptyVarEnv) res args | otherwise = pprPanic "piResultTys1" (ppr ty <> line <> ppr origArgs) where inScope = mkInScopeSet (freeVarsOf (ty:origArgs)) go env ty' [] = substTy (mkTvSubst inScope env) ty' go env ty' allArgs@(arg':args') | Just ty'' <- coreView1 m ty' = go env ty'' allArgs | FunTy _ res <- tyView ty' = go env res args' | ForAllTy tv res <- ty' = go (extendVarEnv tv arg' env) res args' | VarTy tv <- ty' , Just ty'' <- lookupVarEnv tv env -- Deals with (piResultTys (forall a.a) [forall b.b, Int]) = piResultTys m ty'' allArgs | otherwise = pprPanic "piResultTys2" (ppr ty' <> line <> ppr origArgs <> line <> ppr allArgs) clash-lib-1.8.1/src/Clash/Core/Literal.hs0000644000000000000000000000425407346545000016216 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, 2017 , Google Inc., 2021 , QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Term Literal -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Clash.Core.Literal ( Literal (..) ) where import Control.DeepSeq (NFData (..)) import Data.Binary (Binary) import Data.Hashable (Hashable) import Data.Primitive.ByteArray (ByteArray) import Data.Primitive.ByteArray.Extra () import Data.Word (Word32, Word64) import GHC.Generics (Generic) {- Note [Storage of floating point in Literal] ------------------------------------------- GHC stores literals of 'Float' and 'Double' as 'Rational'. However, unlike GHC, we also need to store transfinite "literals". We need to preserve all information there is in a specific code word representing a floating point value. Storing them as 'Float' and 'Double' here introduces issues with 'Eq' and 'Hashable'. 0.0 == -0.0, and NaN compares unequal to everything including itself. Also unlike GHC, we already assume that 'Float' is single-precision IEEE-754, and 'Double' is double-precision IEEE-754. So we can store them as 'Word32' and 'Word64' and get the 'Eq' and hashing properties we require. -} -- | Term Literal data Literal = IntegerLiteral !Integer | IntLiteral !Integer | 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 | CharLiteral !Char | NaturalLiteral !Integer | ByteArrayLiteral !ByteArray deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary) clash-lib-1.8.1/src/Clash/Core/Name.hs0000644000000000000000000000442507346545000015502 0ustar0000000000000000{-| Copyright : (C) 2017, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij Names -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Core.Name ( module Clash.Core.Name , noSrcSpan ) where import Control.DeepSeq (NFData) import Data.Binary (Binary) import Data.Function (on) import Data.Hashable (Hashable (..)) import Data.Text (Text, append) import GHC.BasicTypes.Extra () import GHC.Generics (Generic) import GHC.SrcLoc.Extra () #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (SrcSpan, noSrcSpan) #else import SrcLoc (SrcSpan, noSrcSpan) #endif import Clash.Unique data Name a = Name { nameSort :: NameSort , nameOcc :: !OccName , nameUniq :: {-# UNPACK #-} !Unique , nameLoc :: !SrcSpan } deriving (Show,Generic,NFData,Binary) instance Eq (Name a) where (==) = (==) `on` nameUniq (/=) = (/=) `on` nameUniq instance Ord (Name a) where compare = compare `on` nameUniq instance Hashable (Name a) where hashWithSalt salt nm = hashWithSalt salt (nameUniq nm) instance Uniquable (Name a) where getUnique = nameUniq setUnique nm u = nm {nameUniq=u} type OccName = Text data NameSort = User | System | Internal deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary) mkUnsafeName :: NameSort -> Text -> Unique -> Name a mkUnsafeName ns s i = Name ns s i noSrcSpan mkUnsafeSystemName :: Text -> Unique -> Name a mkUnsafeSystemName s i = Name System s i noSrcSpan mkUnsafeInternalName :: Text -> Unique -> Name a mkUnsafeInternalName s i = Name Internal ("c$" `append` s) i noSrcSpan appendToName :: Name a -> Text -> Name a appendToName (Name sort nm uniq loc) s = Name Internal nm2 uniq loc where nm1 = case sort of {Internal -> nm; _ -> "c$" `append` nm} nm2 = nm1 `append` s clash-lib-1.8.1/src/Clash/Core/PartialEval.hs0000644000000000000000000000642107346545000017024 0ustar0000000000000000{-| Copyright : (C) 2020 QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. The main API of the partial evaluator. This exposes the main functions needed to call the evaluator, and the type of evaluators. A concrete implementation of an evaluator is required to use this module: this can be imported from the library for the compiler front-end, e.g. Clash.GHC.PartialEval in clash-ghc. -} module Clash.Core.PartialEval where import Control.Concurrent.Supply (Supply) import Data.IntMap.Strict (IntMap) import Clash.Core.PartialEval.AsTerm import Clash.Core.PartialEval.Monad import Clash.Core.PartialEval.NormalForm import Clash.Core.Term (Term) import Clash.Core.TyCon (TyConMap) import Clash.Core.Var (Id) import Clash.Core.VarEnv (InScopeSet) import Clash.Driver.Types (Binding(..), BindingMap) -- | An evaluator for Clash core. This consists of two functions: one to -- evaluate a term to weak-head normal form (WHNF) and another to recursively -- evaluate sub-terms to obtain beta-normal eta-long form (NF). -- data Evaluator = Evaluator { evalWhnf :: Term -> Eval Value , quoteNf :: Value -> Eval Normal } -- | Evaluate a term to WHNF, converting the result back to a Term. -- The global environment at the end of evaluation is also returned, callers -- should preserve any parts of the global environment needed for later calls. -- whnf :: Evaluator -- ^ The evaluator implementation to use. -> GlobalEnv -- ^ The initial global environment. -> Bool -- ^ Whether evaluation should keep lifted data constructors. -- See NOTE [Lifted Constructors] in Clash.Core.PartialEval.NormalForm. -> Id -- ^ The id of the term under evaluation. -> Term -- ^ The term under evaluation. -> IO (Term, GlobalEnv) -- ^ The term evalated to WHNF, and the final global environment. whnf e g isSubj i x = let l = LocalEnv i mempty mempty (genvFuel g) isSubj in runEval g l (asTerm <$> evalWhnf e x) -- | Evaluate a term to NF, converting the result back to a Term. -- See `whnf` for more details. -- nf :: Evaluator -- ^ The evaluator implementation to use. -> GlobalEnv -- ^ The initial global environment. -> Bool -- ^ Whether evaluation should keep lifted data constructors. -- See NOTE [Lifted Constructors] in Clash.Core.PartialEval.NormalForm. -> Id -- ^ The id of the term under evaluation. -> Term -- ^ The term under evaluation. -> IO (Term, GlobalEnv) -- ^ The term evalated to NF, and the final global environment. nf e g isSubj i x = let l = LocalEnv i mempty mempty (genvFuel g) isSubj in runEval g l (asTerm <$> (evalWhnf e x >>= quoteNf e)) mkGlobalEnv :: BindingMap -- ^ Global bindings available to the evaluator. -> TyConMap -- ^ The type constructors known by Clash. -> InScopeSet -- ^ The set of variables in scope during evaluation. -> Supply -- ^ The supply of fresh names for variables. -> Word -- ^ The initial supply of fuel. -> IntMap Value -- ^ The initial IO heap. -> Int -- ^ The address of the next heap element. -> GlobalEnv mkGlobalEnv bm tcm iss ids fuel heap addr = GlobalEnv (fmap asThunk bm) tcm iss ids fuel heap addr mempty where asThunk b@Binding{bindingId=i,bindingTerm=t} = b { bindingTerm = VThunk t (LocalEnv i mempty mempty fuel False) } clash-lib-1.8.1/src/Clash/Core/PartialEval/0000755000000000000000000000000007346545000016465 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Core/PartialEval/AsTerm.hs0000644000000000000000000000444607346545000020224 0ustar0000000000000000{-| Copyright : (C) 2020-2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. The AsTerm class and relevant instances for the partial evaluator. This defines how to convert normal forms back into Terms which can be given as the result of evaluation. -} {-# LANGUAGE LambdaCase #-} module Clash.Core.PartialEval.AsTerm ( AsTerm(..) ) where import Data.Bifunctor (first, second) import Clash.Core.HasFreeVars import Clash.Core.PartialEval.NormalForm import Clash.Core.Term (Bind(..), Term(..), Pat, Alt, mkApps) import Clash.Core.VarEnv (elemVarSet) -- | Convert a term in some normal form back into a Term. This is important, -- as it may perform substitutions which have not yet been performed (i.e. when -- converting from WHNF where heads contain the environment at that point). -- class AsTerm a where asTerm:: a -> Term instance (AsTerm a) => AsTerm (Neutral a) where asTerm = \case NeVar i -> Var i NePrim pr args -> mkApps (Prim pr) (argsToTerms args) NeApp x y -> App (asTerm x) (asTerm y) NeTyApp x ty -> TyApp (asTerm x) ty NeLet bs x -> removeUnusedBindings (fmap asTerm bs) (asTerm x) NeCase x ty alts -> Case (asTerm x) ty (altsToTerms alts) removeUnusedBindings :: Bind Term -> Term -> Term removeUnusedBindings bs x | isUsed bs = Let bs x | otherwise = x where free = freeVarsOf x isUsed = \case NonRec i _ -> elemVarSet i free Rec xs -> any (flip elemVarSet free . fst) xs instance AsTerm Value where asTerm = \case VNeutral neu -> asTerm neu VLiteral lit -> Literal lit VData dc args _env -> mkApps (Data dc) (argsToTerms args) VLam i x _env -> Lam i x VTyLam i x _env -> TyLam i x VCast x a b -> Cast (asTerm x) a b VTick x tick -> Tick tick (asTerm x) VThunk x _env -> x instance AsTerm Normal where asTerm = \case NNeutral neu -> asTerm neu NLiteral lit -> Literal lit NData dc args -> mkApps (Data dc) (argsToTerms args) NLam i x _env -> Lam i (asTerm x) NTyLam i x _env -> TyLam i (asTerm x) NCast x a b -> Cast (asTerm x) a b NTick x tick -> Tick tick (asTerm x) argsToTerms :: (AsTerm a) => Args a -> Args Term argsToTerms = fmap $ first asTerm altsToTerms :: (AsTerm a) => [(Pat, a)] -> [Alt] altsToTerms = fmap $ second asTerm clash-lib-1.8.1/src/Clash/Core/PartialEval/Monad.hs0000644000000000000000000002132307346545000020060 0ustar0000000000000000{-| Copyright : (C) 2020-2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. The monad for partial evaluation, and its API. This should contain all auxiliary functions needed to define new evaluator implementations. This module is only needed to define new evaluators, for calling an existing evaluator see Clash.Core.PartialEval. -} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} module Clash.Core.PartialEval.Monad ( -- * Partial Evaluation Monad Eval , runEval -- * Local and Global Environments , getLocalEnv , setLocalEnv , modifyLocalEnv , getGlobalEnv , modifyGlobalEnv -- * Evaluation Context , getContext , withContext -- * Local Type Bindings , getTvSubst , findTyVar , withTyVar , withTyVars -- * Local Term Bindings , findId , withId , withIds , withoutId -- * Global Term Bindings , findBinding , replaceBinding -- * IO Heap Bindings , getRef , setRef -- * Lifted Data Constructors , isKeepingLifted , keepLifted -- * Fuel , getFuel , withFuel , preserveFuel -- * Accessing Global State , getTyConMap , getInScope -- * Fresh Variable Generation , getUniqueId , getUniqueTyVar -- * Work free check , workFreeValue ) where import Control.Applicative (Alternative) import Control.Concurrent.Supply (Supply) import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) import Control.Monad.IO.Class (MonadIO) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail) #endif import Control.Monad.RWS.Strict (RWST, MonadReader, MonadState) import qualified Control.Monad.RWS.Strict as RWS import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map import Clash.Core.HasFreeVars import Clash.Core.Name (OccName) import Clash.Core.PartialEval.AsTerm import Clash.Core.PartialEval.NormalForm import Clash.Core.Subst (Subst, mkTvSubst) import Clash.Core.TyCon (TyConMap) import Clash.Core.Type (Kind, KindOrType, Type) import Clash.Core.Util (mkUniqSystemId, mkUniqSystemTyVar) import Clash.Core.Var (Id, TyVar, Var) import Clash.Core.VarEnv import Clash.Driver.Types (Binding(..)) import Clash.Rewrite.WorkFree (isWorkFree) {- NOTE [RWS monad] ~~~~~~~~~~~~~~~~ Local bindings are kept in the Reader monad and global bindings in the State monad. This ensures that global changes are propagated to later evaluation actions whereas local changes only exist when evaluating a particular sub-term. For example, consider the term (let ... in f) (let ... in x) When evaluating this, the let bindings in the left sub-term should not be in scope when evaluating the right sub-term. By using only the State monad for local and global state, too much care needs to be given to ensuring that local bindings are saved and restored when evaluating different sub-terms. The MonadWriter instance is deliberately not derived here, as the Writer monad functionality of RWST is not wanted. -} -- TODO The inner monad here could be changed to STM to allow the evaluator -- to work on evaluating sub-terms concurrently. That would require slightly -- different environment types, where data can be stored in STM types. -- | The monad of partial evaluation. The inner monad is IO, as primitive -- evaluation can attempt to evaluate IO actions. -- newtype Eval a = Eval { unEval :: RWST LocalEnv () GlobalEnv IO a } deriving ( Functor , Applicative , Alternative , Monad , MonadFail , MonadIO , MonadReader LocalEnv , MonadState GlobalEnv , MonadThrow , MonadCatch , MonadMask ) -- | Evaluate an action in the partial evaluator, returning the result, -- and the final state of the global environment. -- runEval :: GlobalEnv -> LocalEnv -> Eval a -> IO (a, GlobalEnv) runEval g l x = let extract (a, g', _) = (a, g') in extract <$> RWS.runRWST (unEval x) l g {-# INLINE runEval #-} getLocalEnv :: Eval LocalEnv getLocalEnv = RWS.ask {-# INLINE getLocalEnv #-} setLocalEnv :: LocalEnv -> Eval a -> Eval a setLocalEnv = RWS.local . const {-# INLINE setLocalEnv #-} modifyLocalEnv :: (LocalEnv -> LocalEnv) -> Eval a -> Eval a modifyLocalEnv = RWS.local {-# INLINE modifyLocalEnv #-} getGlobalEnv :: Eval GlobalEnv getGlobalEnv = RWS.get {-# INLINE getGlobalEnv #-} modifyGlobalEnv :: (GlobalEnv -> GlobalEnv) -> Eval () modifyGlobalEnv = RWS.modify' {-# INLINE modifyGlobalEnv #-} getContext :: Eval Id getContext = lenvContext <$> getLocalEnv withContext :: Id -> Eval a -> Eval a withContext i = modifyLocalEnv go where go env = env { lenvContext = i } findTyVar :: TyVar -> Eval (Maybe Type) findTyVar i = Map.lookup i . lenvTypes <$> getLocalEnv withTyVar :: TyVar -> Type -> Eval a -> Eval a withTyVar i a x = do modifyGlobalEnv goGlobal modifyLocalEnv goLocal x where goGlobal env@GlobalEnv{genvInScope=inScope} = let fvs = unitVarSet i `unionVarSet` freeVarsOf a iss = mkInScopeSet fvs `unionInScope` inScope in env { genvInScope = iss } goLocal env@LocalEnv{lenvTypes=types} = env { lenvTypes = Map.insert i a types } withTyVars :: [(TyVar, Type)] -> Eval a -> Eval a withTyVars = flip $ foldr (uncurry withTyVar) getTvSubst :: Eval Subst getTvSubst = do inScope <- getInScope tys <- lenvTypes <$> getLocalEnv let vars = mkVarEnv (Map.toList tys) pure (mkTvSubst inScope vars) findId :: Id -> Eval (Maybe Value) findId i = Map.lookup i . lenvValues <$> getLocalEnv withId :: Id -> Value -> Eval a -> Eval a withId i v x = do modifyGlobalEnv goGlobal modifyLocalEnv goLocal x where goGlobal env@GlobalEnv{genvInScope=inScope} = -- TODO Change this to use an instance HasFreeVars Value let fvs = unitVarSet i `unionVarSet` freeVarsOf (asTerm v) iss = mkInScopeSet fvs `unionInScope` inScope in env { genvInScope = iss } goLocal env@LocalEnv{lenvValues=values} = env { lenvValues = Map.insert i v values } withIds :: [(Id, Value)] -> Eval a -> Eval a withIds = flip $ foldr (uncurry withId) withoutId :: Id -> Eval a -> Eval a withoutId i = modifyLocalEnv go where go env@LocalEnv{lenvValues=values} = env { lenvValues = Map.delete i values } findBinding :: Id -> Eval (Maybe (Binding Value)) findBinding i = lookupVarEnv i . genvBindings <$> getGlobalEnv replaceBinding :: Binding Value -> Eval () replaceBinding b = modifyGlobalEnv go where go env@GlobalEnv{genvBindings=bindings} = env { genvBindings = extendVarEnv (bindingId b) b bindings } getRef :: Int -> Eval Value getRef addr = do heap <- genvHeap <$> getGlobalEnv case IntMap.lookup addr heap of Just val -> pure val Nothing -> error ("getHeap: Address " <> show addr <> " out of bounds") setRef :: Int -> Value -> Eval () setRef addr val = modifyGlobalEnv go where go env@GlobalEnv{genvHeap=heap,genvAddr=next} | addr == next = env { genvHeap = IntMap.insert addr val heap, genvAddr = addr + 1 } | otherwise = env { genvHeap = IntMap.insert addr val heap } isKeepingLifted :: Eval Bool isKeepingLifted = lenvKeepLifted <$> getLocalEnv keepLifted :: Eval a -> Eval a keepLifted = modifyLocalEnv forceLifted where forceLifted env = env { lenvKeepLifted = True } getFuel :: Eval Word getFuel = do lenv <- getLocalEnv genv <- getGlobalEnv pure (min (lenvFuel lenv) (genvFuel genv)) withFuel :: Eval a -> Eval a withFuel x = modifyGlobalEnv go >> x where go env@GlobalEnv{genvFuel=fuel} = env { genvFuel = fuel - 1 } preserveFuel :: Eval a -> Eval a preserveFuel x = do fuel <- getFuel res <- x modifyGlobalEnv (go fuel) pure res where go fuel env = env { genvFuel = fuel } getTyConMap :: Eval TyConMap getTyConMap = genvTyConMap <$> getGlobalEnv getInScope :: Eval InScopeSet getInScope = genvInScope <$> getGlobalEnv getUniqueId :: OccName -> Type -> Eval Id getUniqueId = getUniqueVar mkUniqSystemId getUniqueTyVar :: OccName -> Kind -> Eval TyVar getUniqueTyVar = getUniqueVar mkUniqSystemTyVar getUniqueVar :: ((Supply, InScopeSet) -> (OccName, KindOrType) -> ((Supply, InScopeSet), Var a)) -> OccName -> KindOrType -> Eval (Var a) getUniqueVar f name ty = do env <- getGlobalEnv let iss = genvInScope env ids = genvSupply env ((ids', iss'), i) = f (ids, iss) (name, ty) modifyGlobalEnv (go ids' iss') pure i where go ids iss env = env { genvInScope = iss, genvSupply = ids } workFreeValue :: Value -> Eval Bool workFreeValue = \case VNeutral _ -> pure False VThunk x _ -> do bindings <- fmap (fmap asTerm) . genvBindings <$> getGlobalEnv isWorkFree workFreeCache bindings x _ -> pure True clash-lib-1.8.1/src/Clash/Core/PartialEval/NormalForm.hs0000644000000000000000000001640107346545000021077 0ustar0000000000000000{-| Copyright : (C) 2020-2021, QBayLogic B.V., 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Normal forms for the partial evaluator. These provide a restricted model of how terms can be constructed (compared to the more liberal Term type) which give a stronger guarantee that evaluation does not produce invalid results. This module is only needed to define new evaluators, for calling an existing evaluator see Clash.Core.PartialEval. -} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} module Clash.Core.PartialEval.NormalForm ( Arg , Args , Neutral(..) , Value(..) , mkValueTicks , stripValue , collectValueTicks , isUndefined , isUndefinedX , Normal(..) , LocalEnv(..) , GlobalEnv(..) , workFreeCache ) where import Control.Concurrent.Supply (Supply) import Control.Lens (Lens', lens) import Data.IntMap.Strict (IntMap) import Data.Map.Strict (Map) import Clash.Core.DataCon (DataCon) import Clash.Core.Literal import Clash.Core.Term (Bind, Term(..), PrimInfo(primName), TickInfo, Pat) import Clash.Core.TyCon (TyConMap) import Clash.Core.Type (Type, TyVar) import Clash.Core.Util (undefinedPrims, undefinedXPrims) import Clash.Core.Var (Id) import Clash.Core.VarEnv (VarEnv, InScopeSet) import Clash.Driver.Types (Binding(..)) type Args a = [Arg a] -- | An argument applied to a function / data constructor / primitive. -- type Arg a = Either a Type -- | Neutral terms cannot be reduced, as they represent things like variables -- which are unknown, partially applied functions, or case expressions where -- the subject cannot be inspected. Consider: -- -- v Stuck if "v" is a free variable -- p x1 ... xn Stuck if "p" is a primitive that cannot be reduced -- x $ y Stuck if "x" is not known to be a lambda -- x @ A Stuck if "x" is not known to be a type lambda -- case x of ... Stuck if "x" is neutral (cannot choose an alternative) -- -- Neutral terms can also be let expressions which preserve required bindings -- in the normal form representation. Examples of bindings that may be kept are -- bindings which perform work (and should not be copied) or bindings that -- are recursive and are still referred to by the body of the let expression. -- -- let ... in ... Preserved bindings are needed by the body -- data Neutral a = NeVar !Id | NePrim !PrimInfo !(Args a) | NeApp !(Neutral a) !a | NeTyApp !(Neutral a) !Type | NeLet !(Bind a) !a | NeCase !a !Type ![(Pat, a)] deriving (Show) -- TODO Write an instance (InferType a) => InferType (Neutral a) -- TODO Write an instance (HasFreeVars a) => HasFreeVars (Neutral a) -- | A term which has been potentially evaluated to WHNF. If evaluation has -- occurred, then there will be no redexes at the head of the Value, but -- sub-terms may still have redexes. Data constructors are only considered to -- be values when fully applied, if partially applied they should be -- eta-expanded during evaluation. -- -- Thunks are included so that lazy evaluation can be modelled without needing -- to store Either Term Value in the environment. This makes the presentation -- simpler, with the caveat that values must be forced when they are required -- to not be thunks. -- data Value = VNeutral !(Neutral Value) | VLiteral !Literal | VData !DataCon !(Args Value) !LocalEnv | VLam !Id !Term !LocalEnv | VTyLam !TyVar !Term !LocalEnv | VCast !Value !Type !Type | VTick !Value !TickInfo | VThunk !Term !LocalEnv deriving (Show) -- TODO Write an instance InferType Value -- TODO Write an instance HasFreeVars Value mkValueTicks :: Value -> [TickInfo] -> Value mkValueTicks = foldl VTick stripValue :: Value -> Value stripValue = fst . collectValueTicks collectValueTicks :: Value -> (Value, [TickInfo]) collectValueTicks = go [] where go !acc = \case VTick v tick -> go (tick : acc) v value -> (value, acc) isUndefined :: Value -> Bool isUndefined = \case VNeutral (NePrim pr _) -> primName pr `elem` undefinedPrims _ -> False isUndefinedX :: Value -> Bool isUndefinedX = \case VNeutral (NePrim pr _) -> primName pr `elem` undefinedXPrims _ -> False -- | A term which is in beta-normal eta-long form (NF). This has no redexes, -- and all partially applied functions in sub-terms are eta-expanded. -- -- While not strictly necessary, NLam includes the environment at the point the -- original term was evaluated. This makes it easier for the AsTerm instance -- for Normal to reintroduce let expressions before lambdas without -- accidentally floating a let using a lambda bound variable outwards. -- data Normal = NNeutral !(Neutral Normal) | NLiteral !Literal | NData !DataCon !(Args Normal) | NLam !Id !Normal !LocalEnv | NTyLam !TyVar !Normal !LocalEnv | NCast !Normal !Type !Type | NTick !Normal !TickInfo deriving (Show) data LocalEnv = LocalEnv { lenvContext :: Id -- ^ The id of the term currently under evaluation. , lenvTypes :: Map TyVar Type -- ^ Local type environment. These are types that are introduced while -- evaluating the current term (i.e. by type applications) , lenvValues :: Map Id Value -- ^ Local term environment. These are WHNF terms or unevaluated thunks -- introduced while evaluating the current term (i.e. by applications) , lenvFuel :: Word -- ^ The amount of fuel left in the local environment when the previous -- head was reached. This is needed so resuming evaluation does not lead -- to additional fuel being available. , lenvKeepLifted :: Bool -- ^ When evaluating, keep data constructors for boxed data types (e.g. I#) -- instead of converting these back to their corresponding primitive. This -- is used when evaluating terms where the result is subject of a case -- expression (see note: lifted data types). } deriving (Show) -- TODO Add recursion info to the global environment. Until then we are forced -- to spend fuel on non-recursive (terminating) terms. data GlobalEnv = GlobalEnv { genvBindings :: VarEnv (Binding Value) -- ^ Global term environment. These are the potentially evaluated bodies -- of the top level definitions which are forced on lookup. , genvTyConMap :: TyConMap -- ^ The type constructors known about by Clash. , genvInScope :: InScopeSet -- ^ The set of in scope variables during partial evaluation. This includes -- new variables introduced by the evaluator (such as the ids of binders -- introduced during eta expansion.) , genvSupply :: Supply -- ^ The supply of fresh names for generating identifiers. , genvFuel :: Word -- ^ The remaining fuel which can be spent inlining global variables. This -- is saved in the local environment, so when evaluation resumes from WHNF -- the amount of fuel used is preserved. , genvHeap :: IntMap Value -- ^ The heap containing the results of any evaluated IO primitives. , genvAddr :: Int -- ^ The address of the next element to be inserted into the heap. , genvWorkCache :: VarEnv Bool -- ^ Cache for the results of isWorkFree. This is required to use -- Clash.Rewrite.WorkFree.isWorkFree. } workFreeCache :: Lens' GlobalEnv (VarEnv Bool) workFreeCache = lens genvWorkCache (\env x -> env { genvWorkCache = x }) clash-lib-1.8.1/src/Clash/Core/Pretty.hs0000644000000000000000000005115307346545000016111 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. PrettyPrec printing class and instances for CoreHW -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Clash.Core.Pretty ( PrettyPrec (..) , PrettyOptions (..) , ClashDoc , ClashAnnotation (..) , SyntaxElement (..) , ppr, ppr' , showPpr, showPpr' , tracePprId , tracePpr , fromPpr ) where import Data.Char (isSymbol, isUpper, ord) import Data.Default (Default(..)) import Data.Text (Text) import Control.Monad.Identity import Data.Binary.IEEE754 (wordToDouble, wordToFloat) import Data.List.Extra ((<:>)) import qualified Data.Text as T import Data.Maybe (fromMaybe) #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter import Prettyprinter.Internal #else import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Internal #endif import GHC.Show (showMultiLineString) import GHC.Stack (HasCallStack) #if MIN_VERSION_ghc(9,0,0) import qualified GHC.Utils.Outputable as GHC #else import qualified Outputable as GHC #endif import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe) import Clash.Core.DataCon (DataCon (..)) import Clash.Core.Literal (Literal (..)) import Clash.Core.Name (Name (..)) import Clash.Core.Term (Pat (..), Term (..), TickInfo (..), NameMod (..), CoreContext (..), primArg, PrimInfo(primName),Bind(..)) import Clash.Core.TyCon (TyCon (..), TyConName, isTupleTyConLike, AlgTyConRhs(..)) import Clash.Core.Type (ConstTy (..), Kind, LitTy (..), Type (..), TypeView (..), tyView,mkTyConApp) import Clash.Core.Var (Id, TyVar, Var (..), IdScope(..)) import Clash.Debug (trace) import Clash.Util import qualified Clash.Util.Interpolate as I import Clash.Pretty unsafeLookupEnvBool :: HasCallStack => String -> Bool -> Bool unsafeLookupEnvBool key dflt = case unsafePerformIO (lookupEnv key) of Nothing -> dflt Just a -> flip fromMaybe (readMaybe a) $ error [I.i| 'unsafeLookupEnvBool' tried to lookup #{key} in the environment. It found it, but couldn't interpret it to as a Bool. Expected one of: True, False. But found: #{a} |] -- | Options for the pretty-printer, controlling which elements to hide. data PrettyOptions = PrettyOptions { displayUniques :: Bool -- ^ whether to display unique identifiers , displayTypes :: Bool -- ^ whether to display type information , displayQualifiers :: Bool -- ^ whether to display module qualifiers , displayTicks :: Bool -- ^ whether to display ticks } instance Default PrettyOptions where def = PrettyOptions { displayUniques = unsafeLookupEnvBool "CLASH_PPR_UNIQUES" True , displayTypes = unsafeLookupEnvBool "CLASH_PPR_TYPES" True , displayQualifiers = unsafeLookupEnvBool "CLASH_PPR_QUALIFIERS" True , displayTicks = unsafeLookupEnvBool "CLASH_PPR_TICKS" True } -- | Annotations carried on pretty-printed code. data ClashAnnotation = AnnContext CoreContext -- ^ marking navigation to a different context | AnnSyntax SyntaxElement -- ^ marking a specific sort of syntax deriving Eq -- | Specific places in the program syntax. data SyntaxElement = Keyword | LitS | Type | Unique | Qualifier | Ticky deriving (Eq, Show) -- | Clash's specialized @Doc@ type holds metadata of type @ClashAnnotation@. type ClashDoc = Doc ClashAnnotation -- | PrettyPrec printing Show-like typeclass class PrettyPrec p where -- default pretty-printing without hiding pprPrec :: Monad m => Rational -> p -> m ClashDoc -- pretty-printing with hiding options -- NB: we utilise the syntax annotations to hide the requested parts of syntax pprPrec' :: Monad m => PrettyOptions -> Rational -> p -> m ClashDoc pprPrec' opts p = fmap hide . pprPrec p where hide = \case FlatAlt d d' -> FlatAlt (hide d) (hide d') Cat d d' -> Cat (hide d) (hide d') Nest i d -> Nest i (hide d) Union d d' -> Union (hide d) (hide d') Column f -> Column (hide . f) WithPageWidth f -> WithPageWidth (hide . f) Nesting f -> Nesting (hide . f) Annotated ann d' -> if not (displayTypes opts) && ann == AnnSyntax Type || not (displayUniques opts) && ann == AnnSyntax Unique || not (displayQualifiers opts) && ann == AnnSyntax Qualifier || not (displayTicks opts) && ann == AnnSyntax Ticky then Empty else Annotated ann (hide d') d -> d pprM :: (Monad m, PrettyPrec p) => p -> m ClashDoc pprM = pprPrec 0 pprM' :: (Monad m, PrettyPrec p) => PrettyOptions -> p -> m ClashDoc pprM' opts = pprPrec' opts 0 ppr :: PrettyPrec p => p -> ClashDoc ppr = runIdentity . pprM ppr' :: PrettyPrec p => PrettyOptions -> p -> ClashDoc ppr' opts = runIdentity . pprM' opts fromPpr :: PrettyPrec a => a -> Doc () fromPpr = removeAnnotations . ppr noPrec, opPrec, appPrec :: Num a => a noPrec = 0 opPrec = 1 appPrec = 2 -- | Print a PrettyPrec thing to a String showPpr :: PrettyPrec p => p -> String showPpr = showPpr' def showPpr' :: PrettyPrec p => PrettyOptions -> p -> String showPpr' opts = showDoc . ppr' opts tracePprId :: PrettyPrec p => p -> p tracePprId p = trace (showPpr p) p tracePpr :: PrettyPrec p => p -> a -> a tracePpr p a = trace (showPpr p) a parensIf :: Bool -> ClashDoc -> ClashDoc parensIf False = id parensIf True = parens tyParens :: ClashDoc -> ClashDoc tyParens = enclose (annotate (AnnSyntax Type) lparen) (annotate (AnnSyntax Type) rparen) tyParensIf :: Bool -> ClashDoc -> ClashDoc tyParensIf False = id tyParensIf True = tyParens vsepHard :: [ClashDoc] -> ClashDoc vsepHard = concatWith (\x y -> x <> hardline <> y) viewName :: Name a -> (Text, Text, Text) viewName n = (qual, occ, T.pack $ show $ nameUniq n) where (qual, occ) = T.breakOnEnd "." $ nameOcc n instance PrettyPrec (Name a) where pprPrec p (viewName -> (qual, occ, uniq)) = do qual' <- annotate (AnnSyntax Qualifier) <$> pprPrec p qual occ' <- pprPrec p occ uniq' <- annotate (AnnSyntax Unique) . brackets <$> (pprPrec p uniq) return $ qual' <> occ' <> uniq' instance ClashPretty (Name a) where clashPretty = fromPpr instance PrettyPrec a => PrettyPrec [a] where pprPrec prec = fmap vcat . mapM (pprPrec prec) instance PrettyPrec (Id, Term) where pprPrec _ = pprTopLevelBndr pprTopLevelBndr :: Monad m => (Id,Term) -> m ClashDoc pprTopLevelBndr (bndr,expr) = do bndr' <- pprM bndr bndrName <- pprM (varName bndr) expr' <- pprM expr return $ bndr' <> line <> hang 2 (sep [(bndrName <+> equals), expr']) <> line dcolon, rarrow, lam, tylam, at, cast, coerce, let_, letrec, in_, case_, of_, forall_, data_,newtype_,type_,family_,instance_ :: ClashDoc 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 instance PrettyPrec Type where pprPrec _ t = annotate (AnnSyntax Type) <$> pprType t instance ClashPretty Type where clashPretty = fromPpr instance PrettyPrec TyCon where pprPrec prec t = case t of AlgTyCon _ nm kn _ (DataTyCon dcs) _ -> do name <- pprPrec prec nm kind <- pprKind kn let decl = name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind) cons <- traverse pprDataCon dcs pure (vsep (data_ <+> decl : cons)) where pprDataCon dc = do name <- pprPrec prec dc ty <- pprType (dcType dc) pure (name <+> dcolon <+> ty) AlgTyCon _ nm kn _ (NewTyCon dc _) _ -> do name <- pprPrec prec nm kind <- pprKind kn let decl = name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind) conName <- pprPrec prec (dcName dc) conType <- pprType (dcType dc) pure (vsep [newtype_ <+> decl, conName <+> dcolon <+> conType]) PromotedDataCon _ _ _ _ dc -> fmap ("promoted" <+>) (pprPrec prec dc) FunTyCon _ nm kn _ ss -> do name <- pprPrec prec nm kind <- pprKind kn let decl = name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind) substs <- traverse pprSubst ss pure (vsep (type_ <+> family_ <+> decl : substs)) where pprSubst (xs, y) = do lhs <- pprType (mkTyConApp (tyConName t) xs) rhs <- pprType y pure (type_ <+> instance_ <+> lhs <+> "=" <+> rhs) PrimTyCon _ nm kn _ -> do name <- pprPrec prec nm kind <- pprKind kn pure (name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind)) 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 instance PrettyPrec Term where pprPrec prec e = case e of Var x -> do v <- pprPrec prec (varName x) s <- pprPrecIdScope x pure (v <> brackets s) Data dc -> pprPrec prec dc Literal l -> pprPrec prec l Prim p -> pprPrecPrim prec (primName p) Lam v e1 -> annotate (AnnContext $ LamBody v) <$> pprPrecLam prec [v] e1 TyLam tv e1 -> annotate (AnnContext $ TyLamBody tv) <$> pprPrecTyLam prec [tv] e1 App fun arg -> pprPrecApp prec fun arg TyApp e' ty -> annotate (AnnContext TyAppC) <$> pprPrecTyApp prec e' ty Let (NonRec i x) e1 -> pprPrecLetrec prec False [(i,x)] e1 Let (Rec xes) e1 -> pprPrecLetrec prec True xes e1 Case e' _ alts -> pprPrecCase prec e' alts Cast e' ty1 ty2 -> pprPrecCast prec e' ty1 ty2 Tick t e' -> do tDoc <- pprPrec prec t eDoc <- pprPrec prec e' return (annotate (AnnSyntax Ticky) (tDoc <> line') <> eDoc) instance PrettyPrec TickInfo where pprPrec prec (SrcSpan sp) = pprPrec prec sp pprPrec prec (NameMod PrefixName t) = ("" <>) <$> pprPrec prec t pprPrec prec (NameMod SuffixName t) = ("" <>) <$> pprPrec prec t pprPrec prec (NameMod SuffixNameP t) = ("" <>) <$> pprPrec prec t pprPrec prec (NameMod SetName t) = ("" <>) <$> pprPrec prec t pprPrec _ DeDup = pure "" pprPrec _ NoDeDup = pure "" instance PrettyPrec SrcSpan where pprPrec _ sp = return (""<>pretty (GHC.showSDocUnsafe (GHC.ppr sp))) instance ClashPretty Term where clashPretty = fromPpr data BindingSite = LambdaBind | CaseBind | LetBind instance PrettyPrec (Var a) where pprPrec _ v@(TyVar {}) = pprM $ varName v pprPrec _ v@(Id {}) = do v' <- pprM (varName v) ty' <- pprM (varType v) return $ v' <> (annotate (AnnSyntax Type) $ align (space <> dcolon <+> ty')) instance ClashPretty (Var a) where clashPretty = fromPpr instance PrettyPrec DataCon where pprPrec _ = pprM . dcName instance PrettyPrec Literal where pprPrec _ l = return $ annotate (AnnSyntax LitS) $ case l of 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 <> "##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 <> "#" StringLiteral s -> vcat $ map pretty $ showMultiLineString s NaturalLiteral n -> pretty n ByteArrayLiteral s -> pretty $ show s instance PrettyPrec Pat where pprPrec prec pat = case pat of DataPat dc txs xs -> do dc' <- pprM dc txs' <- mapM (pprBndr LetBind) txs xs' <- mapM (pprBndr CaseBind) xs return $ parensIf (prec >= appPrec) $ sep [ hsep (dc':txs') , nest 2 (sep xs') ] LitPat l -> pprM l DefaultPat -> return "_" pprPrecIdScope :: Monad m => Var a -> m ClashDoc pprPrecIdScope (TyVar {}) = pure "TyVar" pprPrecIdScope (Id _ _ _ GlobalId) = pure "GlobalId" pprPrecIdScope (Id _ _ _ LocalId) = pure "LocalId" pprPrecPrim :: Monad m => Rational -> Text -> m ClashDoc pprPrecPrim prec nm = (<>) <$> (annotate (AnnSyntax Qualifier) <$> pprPrec prec qual) <*> pprPrec prec occ where (qual, occ) = T.breakOnEnd "." nm pprPrecLam :: Monad m => Rational -> [Id] -> Term -> m ClashDoc pprPrecLam prec xs e = do xs' <- mapM (pprBndr LambdaBind) xs e' <- pprPrec noPrec e return $ parensIf (prec > noPrec) $ lam <> hsep xs' <+> rarrow <> line <> e' pprPrecTyLam :: Monad m => Rational -> [TyVar] -> Term -> m ClashDoc pprPrecTyLam prec tvs e = do tvs' <- mapM pprM tvs e' <- pprPrec noPrec e return $ tyParensIf (prec > noPrec) $ annotate (AnnSyntax Type) (tylam <> hsep tvs' <+> rarrow <> line) <> e' pprPrecApp :: Monad m => Rational -> Term -> Term -> m ClashDoc pprPrecApp prec e1 e2 = do e1' <- annotate (AnnContext AppFun) <$> pprPrec opPrec e1 e2' <- annotate (AnnContext $ AppArg $ primArg e2) <$> pprPrec appPrec e2 return $ parensIf (prec >= appPrec) $ hang 2 (sep [e1',e2']) pprPrecTyApp :: Monad m => Rational -> Term -> Type -> m ClashDoc pprPrecTyApp prec e ty = do e' <- pprPrec opPrec e ty' <- pprParendType ty return $ tyParensIf (prec >= appPrec) $ hang 2 $ group $ e' <> annotate (AnnSyntax Type) (line <> at <> ty') pprPrecCast :: Monad m => Rational -> Term -> Type -> Type -> m ClashDoc pprPrecCast prec e ty1 ty2 = do e' <- annotate (AnnContext CastBody) <$> pprPrec appPrec e ty1' <- pprType ty1 ty2' <- pprType ty2 return $ tyParensIf (prec >= appPrec) $ e' <> annotate (AnnSyntax Type) (softline <> nest 2 (vsep [cast, ty1', coerce, ty2'])) -- TODO Since Clash now keeps non-recursive let expressions separately, the -- result of normalization will contain more nested let expressions as the old -- Letrec-based definitions are replaced by Let. As this happens, it may be a -- good idea to change pprPrecLetrec to encourage more compact forms such as -- printing the entire binding on one line if possible. pprPrecLetrec :: Monad m => Rational -> Bool -> [(Id, Term)] -> Term -> m ClashDoc pprPrecLetrec prec isRec xes body = do let bndrs = fst <$> xes body' <- annotate (AnnContext $ LetBody xes) <$> pprPrec noPrec body xes' <- mapM (\(x,e) -> do x' <- pprBndr LetBind x e' <- pprPrec noPrec e return $ annotate (AnnContext $ LetBinding x bndrs) $ vsepHard [x', equals <+> e'] ) xes let xes'' = case xes' of { [] -> ["EmptyLetrec"]; _ -> xes' } let kw = if isRec then letrec else let_ return $ parensIf (prec > noPrec) $ vsepHard [hang 2 (vsepHard $ kw : xes''), in_ <+> body'] pprPrecCase :: Monad m => Rational -> Term -> [(Pat,Term)] -> m ClashDoc pprPrecCase prec e alts = do e' <- annotate (AnnContext CaseScrut) <$> pprPrec prec e alts' <- mapM (pprPrecAlt noPrec) alts return $ parensIf (prec > noPrec) $ hang 2 $ vsepHard $ (case_ <+> e' <+> of_) : alts' pprPrecAlt :: Monad m => Rational -> (Pat,Term) -> m ClashDoc pprPrecAlt _ (altPat, altE) = do altPat' <- pprPrec noPrec altPat altE' <- pprPrec noPrec altE return $ annotate (AnnContext $ CaseAlt altPat) $ hang 2 $ vsepHard [(altPat' <+> rarrow), altE'] pprBndr :: (Monad m, PrettyPrec a) => BindingSite -> a -> m ClashDoc pprBndr LetBind = pprM pprBndr _ = fmap tyParens . pprM data TypePrec = TopPrec | FunPrec | TyConPrec deriving (Eq,Ord) maybeParen :: TypePrec -> TypePrec -> ClashDoc -> ClashDoc maybeParen ctxt_prec inner_prec = parensIf (ctxt_prec >= inner_prec) pprType :: Monad m => Type -> m ClashDoc pprType = ppr_type TopPrec pprParendType :: Monad m => Type -> m ClashDoc pprParendType = ppr_type TyConPrec ppr_type :: Monad m => TypePrec -> Type -> m ClashDoc ppr_type _ (VarTy tv) = pprM tv ppr_type _ (LitTy tyLit) = pprM tyLit ppr_type p ty@(ForAllTy {}) = pprForAllType p ty ppr_type p (ConstTy (TyCon tc)) = pprTcApp p ppr_type tc [] ppr_type p (AnnType _ann typ) = ppr_type p typ ppr_type p (tyView -> TyConApp tc args) = pprTcApp p ppr_type tc args ppr_type p (tyView -> FunTy ty1 ty2) = pprArrowChain <$> ppr_type FunPrec ty1 <:> pprFunTail ty2 where pprFunTail (tyView -> FunTy ty1' ty2') = ppr_type FunPrec ty1' <:> pprFunTail ty2' pprFunTail otherTy = ppr_type TopPrec otherTy <:> pure [] pprArrowChain [] = emptyDoc pprArrowChain (arg:args) = maybeParen p FunPrec $ sep [arg, sep (map (rarrow <+>) args)] ppr_type p (AppTy ty1 ty2) = maybeParen p TyConPrec <$> ((<+>) <$> pprType ty1 <*> ppr_type TyConPrec ty2) ppr_type _ (ConstTy Arrow) = return (parens rarrow) pprForAllType :: Monad m => TypePrec -> Type -> m ClashDoc pprForAllType p ty = maybeParen p FunPrec <$> pprSigmaType True ty pprSigmaType :: Monad m => Bool -> Type -> m ClashDoc pprSigmaType showForalls ty = do (tvs, rho) <- split1 [] ty sep <$> sequenceA [ if showForalls then pprForAll tvs else pure emptyDoc , pprType rho ] where split1 tvs (ForAllTy tv resTy) = split1 (tv:tvs) resTy split1 tvs resTy = return (reverse tvs,resTy) pprForAll :: Monad m => [TyVar] -> m ClashDoc pprForAll [] = return emptyDoc pprForAll tvs = do tvs' <- mapM pprTvBndr tvs return $ forall_ <+> sep tvs' <> dot pprTvBndr :: Monad m => TyVar -> m ClashDoc pprTvBndr tv = do tv' <- pprM tv kind' <- pprKind (varType tv) return $ tyParens $ tv' <> (annotate (AnnSyntax Type) $ space <> dcolon <+> kind') pprKind :: Monad m => Kind -> m ClashDoc pprKind = pprType pprTcApp :: Monad m => TypePrec -> (TypePrec -> Type -> m ClashDoc) -> TyConName -> [Type] -> m ClashDoc pprTcApp p pp tc tys | null tys = pprM tc | isTupleTyConLike tc = do tys' <- mapM (pp TopPrec) tys return $ parens $ sep $ punctuate comma tys' | isSym , [ty1, ty2] <- tys = do ty1' <- pp FunPrec ty1 ty2' <- pp FunPrec ty2 tc' <- pprM tc return $ maybeParen p FunPrec $ sep [ty1', enclose "`" "`" tc' <+> ty2'] | otherwise = do tys' <- mapM (pp TyConPrec) tys tc' <- parensIf isSym <$> pprM tc return $ maybeParen p TyConPrec $ hang 2 $ sep (tc':tys') where isSym = isSymName tc isSymName :: Name a -> Bool isSymName n = go (nameOcc n) where go s | T.null s = False | isUpper $ T.head s = isLexConSym s | otherwise = isLexSym s isLexSym :: Text -> Bool isLexSym cs = isLexConSym cs || isLexVarSym cs isLexConSym :: Text -> Bool isLexConSym "->" = True isLexConSym cs = startsConSym (T.head cs) isLexVarSym :: Text -> Bool isLexVarSym cs = startsVarSym (T.head cs) startsConSym :: Char -> Bool startsConSym c = c == ':' startsVarSym :: Char -> Bool startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c) isSymbolASCII :: Char -> Bool isSymbolASCII c = c `elem` ("!#$%&*+./<=>?@\\^|~-" :: String) clash-lib-1.8.1/src/Clash/Core/Subst.hs0000644000000000000000000010002007346545000015706 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2017, Google Inc. 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Capture-free substitution function for CoreHW -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #include "../../ClashDebug.h" module Clash.Core.Subst ( -- * Substitution into types -- ** Substitution environments TvSubst (..) , TvSubstEnv -- , mkTvSubst , extendTvSubst , extendTvSubstList -- ** Applying substitutions , substTy , substTyWith , substTyInVar , substGlobalsInExistentials , substInExistentials , substInExistentialsList -- * Substitution into terms -- ** Substitution environments , Subst (..) , mkSubst , mkTvSubst , extendInScopeId , extendInScopeIdList , extendIdSubst , extendIdSubstList , extendGblSubstList -- ** Applying substitutions , substTm , maybeSubstTm , substAlt , substId -- * Variable renaming , deShadowTerm , deShadowAlt , freshenTm , deshadowLetExpr -- * Alpha equivalence , aeqType , aeqTerm -- * Structural equivalence , eqTerm , eqType ) where import Data.Coerce (coerce) #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter #else import Data.Text.Prettyprint.Doc #endif import Data.Hashable (Hashable (hashWithSalt)) import qualified Data.List as List import qualified Data.List.Extra as List import Data.Ord (comparing) import GHC.Stack (HasCallStack) import GHC.SrcLoc.Extra () import GHC.TypeLits (TypeError, ErrorMessage (Text, (:<>:))) import Clash.Core.HasFreeVars import Clash.Core.Pretty (ppr, fromPpr) import Clash.Core.Term (Bind(..), Pat (..), Term (..), TickInfo (..), PrimInfo(primName)) 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.Util import Clash.Pretty -- * Subst -- | A substitution of 'Type's for 'TyVar's -- -- Note [Extending the TvSubstEnv] -- See 'TvSubst' for the invariants that must hold -- -- This invariant allows a short-cut when the subst env is empty: if the -- TvSubstEnv is empty, i.e. @nullVarEnv TvSubstEnv@ holds, then -- (substTy subst ty) does nothing. -- -- For example, consider: -- -- (/\a -> /\b(a ~ Int) -> ... b ...) Int -- -- We substitute Int for 'a'. The Unique of 'b' does not change, but -- nevertheless we add 'b' to the 'TvSubstEnv' because b's kind does change -- -- This invariant has several consequences: -- -- * In 'substTyVarBndr', we extend TvSubstEnv if the unique has changed, or -- if the kind has changed -- -- * In 'substTyVar', we do not need to consult the 'InScopeSet'; the -- TvSubstEnv is enough -- -- * In 'substTy', we can short-circuit when TvSubstEnv is empty type TvSubstEnv = VarEnv Type -- | Type substitution -- -- The following invariants must hold: -- -- 1. The 'InScopeSet' is needed only to guide the generation of fresh uniques -- -- 2. In particular, the kind of the type variables in the 'InScopeSet' is not -- relevant. -- -- 3. The substitution is only applied once -- -- Note [Apply Once] -- -- We might instantiate @forall a b. ty@ with the types @[a, b]@ or @[b, a]@. -- So the substitution might go like @[a -> b, b -> a]@. A similar situation -- arises in terms when we find a redex like @(/\a -> /\b -> e) b a@. Then we -- also end up with a substitution that permutes variables. Other variations -- happen to; for example @[a -> (a,b)]@. -- -- SO A TvSubst MUST BE APPLIED PRECISELY ONCE, OR THINGS MIGHT LOOP -- -- Note [The substitution invariant] -- -- When calling (substTy subst ty) it should be the case that the 'InScopeSet' -- is a superset of both: -- -- * The free variables of the range of the substitution -- -- * The free variables of /ty/ minus the domain of the substitution data TvSubst = TvSubst InScopeSet -- Variable in scope /after/ substitution TvSubstEnv -- Substitution for types instance ClashPretty TvSubst where clashPretty (TvSubst ins tenv) = brackets $ sep [ "TvSubst" , nest 2 ("In scope:" <+> clashPretty ins) , nest 2 ("Type env:" <+> clashPretty tenv)] -- | A substitution of 'Term's for 'Id's -- -- Note [Extending the Subst] -- -- For a term 'Subst', which binds 'Id's as well, we make a different choice for -- Ids than we do for TyVars. -- -- For TyVars see 'TvSubstEnv's Note [Extending the TvSubstEnv] -- -- For Ids, we have a different invariant: -- -- The IdSubstEnv is extended only when the Unique on an Id changes. -- Otherwise, we just extend the InScopeSet -- -- In consequence: -- -- * If all subst envs are empty, substsTm would be a no-op -- -- However, substTm still goes ahead and substitutes. Reason: we may want -- to replace existing Ids with new ones from the in-scope set, to avoid -- space leaks. -- -- * In substIdBndr, we extend the 'IdSubstEnv' only when the unique changes -- -- * If TvSubstEnv and IdSubstEnv are all empty, substExpr does nothing -- (Note that the above rule for 'substIdBndr' maintains this property.) -- -- * In 'lookupIdSubst', we must look up the Id in the in-scope set, because -- it may contain non-trivial changes. Exmaple: -- -- (/\a -> \x:a. ... x ...) Int -- -- We extend the 'TvSubstEnv' with a @[a |-> Int]@; but x's unique does not -- change so we only extend the in-scope set. Then we must look up in the -- in-scope set when we find the occurrence of x. -- -- * The requirement to look up the Id in the in-scope set means that we -- must not take no-op short cut when the 'IdSubstEnv' is empty. We must -- still look up ever Id in the in-scope set. -- -- * (However, we don't need to do so for the expression found in the -- IdSubstEnv, whose range is assumed to be correct wrt the in-scope set) type IdSubstEnv = VarEnv Term -- | A substitution environment containing containing both 'Id' and 'TyVar' -- substitutions. -- -- Some invariants apply to how you use the substitution: -- -- 1. The 'InScopeSet' contains at least those 'Id's and 'TyVar's that will -- be in scope /after/ applying the substitution to a term. Precisely, -- the in-scope set must be a superset of the free variables of the -- substitution range that might possibly clash with locally-bound -- variables in the thing being substituted in. -- -- 2. You may only apply the substitution once. See 'TvSubst' -- -- There are various ways of setting up the in-scope set such that the first of -- of these invariants holds: -- -- * Arrange that the in-scope set really is all the things in scope -- -- * Arrange that it's the free vars of the range of the substitution -- -- * Make it empty, if you know that all the free variables of the -- substitution are fresh, and hence can´t possibly clash data Subst = Subst { substInScope :: InScopeSet -- Variables in scope /after/ substitution , substTmEnv :: IdSubstEnv -- Substitution for terms , substTyEnv :: TvSubstEnv -- Substitution for types , substGblEnv :: IdSubstEnv -- Substitution of globals (in terms) } emptySubst :: Subst emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv -- | An empty substitution, starting the variables currently in scope mkSubst :: InScopeSet -> Subst mkSubst is = Subst is emptyVarEnv emptyVarEnv emptyVarEnv -- | Create a type substitution mkTvSubst :: InScopeSet -> VarEnv Type -> Subst mkTvSubst is env = Subst is emptyVarEnv env emptyVarEnv -- | Generates the in-scope set for the 'Subst' from the types in the incoming -- environment. -- -- Should only be used the type we're substituting into has no free variables -- outside of the domain of substitution zipTvSubst :: [TyVar] -> [Type] -> Subst zipTvSubst tvs tys | debugIsOn , not (List.equalLength tvs tys) = pprTrace "zipTvSubst" (ppr tvs <> line <> ppr tys) emptySubst | otherwise = Subst (mkInScopeSet (freeVarsOf tys)) emptyVarEnv tenv emptyVarEnv where tenv = zipTyEnv tvs tys zipTyEnv :: [TyVar] -> [Type] -> VarEnv Type zipTyEnv tvs tys = mkVarEnv (List.zipEqual tvs tys) -- | Extend the substitution environment with a new 'Id' substitution extendIdSubst :: Subst -> Id -> Term -> Subst extendIdSubst (Subst is env tenv genv) i e = Subst is (extendVarEnv i e env) tenv genv -- | Extend the substitution environment with a list of 'Id' substitutions extendIdSubstList :: Subst -> [(Id,Term)] -> Subst extendIdSubstList (Subst is env tenv genv) es = Subst is (extendVarEnvList env es) tenv genv -- | Extend the substitution environment with a list of global 'Id' substitutions extendGblSubstList :: Subst -> [(Id,Term)] -> Subst extendGblSubstList (Subst is env tenv genv) es = Subst is env tenv (extendVarEnvList genv es) -- | Extend the substitution environment with a new 'TyVar' substitution extendTvSubst :: Subst -> TyVar -> Type -> Subst extendTvSubst (Subst is env tenv genv) tv t = Subst is env (extendVarEnv tv t tenv) genv -- | Extend the substitution environment with a list of 'TyVar' substitutions extendTvSubstList :: Subst -> [(TyVar, Type)] -> Subst extendTvSubstList (Subst is env tenv genv) ts = Subst is env (extendVarEnvList tenv ts) genv -- | Add an 'Id' to the in-scope set: as a side effect, remove any existing -- substitutions for it. extendInScopeId :: Subst -> Id -> Subst extendInScopeId (Subst inScope env tenv genv) id' = Subst inScope' env' tenv genv where inScope' = extendInScopeSet inScope id' env' = delVarEnv env id' -- | Add 'Id's to the in-scope set. See also 'extendInScopeId' extendInScopeIdList :: Subst -> [Id] -> Subst extendInScopeIdList (Subst inScope env tenv genv) ids = Subst inScope' env' tenv genv where inScope' = extendInScopeSetList inScope ids env' = delVarEnvList env ids -- | Substitute within a 'Type' -- -- The substitution has to satisfy the invariant described in -- 'TvSubst's Note [The substitution environment] substTy :: HasCallStack => Subst -> Type -> Type substTy (Subst inScope _ tvS _) ty | nullVarEnv tvS = ty | otherwise = checkValidSubst s' [ty] (substTy' s' ty) where s' = TvSubst inScope tvS -- | Substitute within a 'TyVar'. See 'substTy'. substTyInVar :: HasCallStack => Subst -> Var a -> Var a substTyInVar subst tyVar = tyVar { varType = (substTy subst (varType tyVar)) } -- | Like 'substTy', but skips the checks for the invariants described in -- 'TvSubts' Note [The substitution environment]. Should be used inside this -- module only. substTyUnchecked :: HasCallStack => TvSubst -> Type -> Type substTyUnchecked subst@(TvSubst _ tvS) ty | nullVarEnv tvS = ty | otherwise = substTy' subst ty -- Safely substitute global type variables in a list of potentially -- shadowing type variables. substGlobalsInExistentials :: HasCallStack => InScopeSet -- ^ Variables in scope -> [TyVar] -- ^ List of existentials to apply the substitution for -> [(TyVar, Type)] -- ^ Substitutions -> [TyVar] substGlobalsInExistentials is exts substs0 = result -- TODO: Is is actually possible that existentials shadow each other? If they -- TODO: can't, we can remove this function where iss = scanl extendInScopeSet is exts substs1 = map (\is_ -> extendTvSubstList (mkSubst is_) substs0) iss result = zipWith substTyInVar substs1 exts -- | Safely substitute type variables in a list of existentials. This function -- will account for cases where existentials shadow each other. substInExistentialsList :: HasCallStack => InScopeSet -- ^ Variables in scope -> [TyVar] -- ^ List of existentials to apply the substitution for -> [(TyVar, Type)] -- ^ Substitutions -> [TyVar] substInExistentialsList is exts substs = foldl (substInExistentials is) exts substs -- | Safely substitute a type variable in a list of existentials. This function -- will account for cases where existentials shadow each other. substInExistentials :: HasCallStack => InScopeSet -- ^ Variables in scope -> [TyVar] -- ^ List of existentials to apply the substitution for -> (TyVar, Type) -- ^ Substitution -> [TyVar] substInExistentials is exts subst@(typeVar, _type) = -- TODO: Is is actually possible that existentials shadow each other? If they -- TODO: can't, we can remove this function case List.elemIndices typeVar exts of [] -> -- We're not replacing any of the existentials, but a global variable substGlobalsInExistentials is exts [subst] (last -> i) -> -- We're replacing an existential. That means we're not touching any -- variables that were introduced before it. For all variables after it, -- it is as we would replace global variables in them. take (i+1) exts ++ substGlobalsInExistentials is (drop (i+1) exts) [subst] -- | This checks if the substitution satisfies the invariant from 'TvSubst's -- Note [The substitution invariant]. checkValidSubst :: HasCallStack => TvSubst -> [Type] -> a -> a checkValidSubst subst@(TvSubst inScope tenv) tys a = WARN( not (isValidSubst subst), "inScope" <+> clashPretty inScope <> line <> "tenv" <+> clashPretty tenv <> line <> "tenvFVs" <+> clashPretty (freeVarsOf tenv) <> line <> "tys" <+> fromPpr tys) WARN( not tysFVsInSope, "inScope" <+> clashPretty inScope <> line <> "tenv" <+> clashPretty tenv <> line <> "tys" <+> fromPpr tys <> line <> "needsInScope" <+> clashPretty needsInScope) a where needsInScope = UniqMap.foldrWithUnique (\k _ s -> delVarSetByKey k s) (freeVarsOf tys) tenv tysFVsInSope = needsInScope `varSetInScope` inScope -- | When calling 'substTy' it should be the case that the in-scope set in the -- substitution is a superset of the free variables of the range of the -- substitution. -- -- See also 'TvSubst's Note [The substitution invariant]. isValidSubst :: TvSubst -> Bool isValidSubst (TvSubst inScope tenv) = tenvFVs `varSetInScope` inScope where tenvFVs = freeVarsOf tenv -- | The work-horse of 'substTy' substTy' :: HasCallStack => TvSubst -> Type -> Type substTy' subst = go where go = \case VarTy tv -> substTyVar subst tv ForAllTy tv ty -> case substTyVarBndr subst tv of (subst', tv') -> ForAllTy tv' (substTy' subst' ty) AppTy fun arg -> AppTy (go fun) (go arg) ty -> ty -- | Substitute a variable with a type if it's within the substitution's domain. -- -- Does not substitute within the kind of free variables. substTyVar :: TvSubst -> TyVar -> Type substTyVar (TvSubst _ tenv) tv = case lookupVarEnv tv tenv of Just ty -> ty _ -> VarTy tv -- | Substitute a type variable in a binding position, returning an extended -- substitution environment and a new type variable. -- -- Substitutes within the kind of the type variable substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) substTyVarBndr subst@(TvSubst inScope tenv) oldVar = ASSERT2( no_capture, clashPretty oldVar <> line <> clashPretty newVar <> line <> clashPretty subst ) (TvSubst (inScope `extendInScopeSet` newVar) newEnv, newVar) where newEnv | noChange = delVarEnv tenv oldVar | otherwise = extendVarEnv oldVar (VarTy newVar) tenv -- Assertion that we're not capturing something in the substitution no_capture = not (newVar `elemVarSet` freeVarsOf tenv) oldKi = varType oldVar -- verify that the kind is closed noKindChange = isClosed oldKi -- noChange means that the new type variable is identical in all respects to -- the old type variable (same unique, same kind) -- See 'TvSubstEnv's Note [Extending the TvSubstEnv] -- -- In that case we don't need to extend the substitution to map old to new. -- But instead we must zap any current substitution for the variable. For -- example -- -- (\x.e) with subst = [x | -> e'] -- -- Here we must simply zap the substitution for x noChange = noKindChange && (newVar == oldVar) -- uniqAway ensures that the new variable is not already in scope newVar | noKindChange = uniqAway inScope oldVar | otherwise = uniqAway inScope (oldVar {varType = substTyUnchecked subst oldKi}) -- | Substitute within a 'Term'. Just return original term if given -- substitution is "Nothing". maybeSubstTm :: HasCallStack => Doc () -> Maybe Subst -> Term -> Term maybeSubstTm _doc Nothing = id maybeSubstTm doc (Just s) = substTm doc s -- | Substitute within a 'Term' substTm :: HasCallStack => Doc () -> Subst -> Term -> Term substTm doc subst = go where go = \case Var v -> lookupIdSubst (doc <> line <> "subsTm") subst v Lam v e -> case substIdBndr subst v of (subst',v') -> Lam v' (substTm doc subst' e) TyLam v e -> case substTyVarBndr' subst v of (subst',v') -> TyLam v' (substTm doc subst' e) App l r -> App (go l) (go r) TyApp l r -> TyApp (go l) (substTy subst r) Let bs e -> case substBind doc subst bs of (subst',bs') -> Let bs' (substTm doc subst' e) Case subj ty alts -> Case (go subj) (substTy subst ty) (map goAlt alts) Cast e t1 t2 -> Cast (go e) (substTy subst t1) (substTy subst t2) Tick tick e -> Tick (goTick tick) (go e) tm -> tm goAlt (pat,alt) = case pat of DataPat dc tvs ids -> case List.mapAccumL substTyVarBndr' subst tvs of (subst1,tvs') -> case List.mapAccumL substIdBndr subst1 ids of (subst2,ids') -> (DataPat dc tvs' ids',substTm doc subst2 alt) _ -> (pat,go alt) goTick t@(SrcSpan _) = t goTick (NameMod m ty) = NameMod m (substTy subst ty) goTick t@DeDup = t goTick t@NoDeDup = t -- | Substitute within a case-alternative substAlt :: HasCallStack => Doc () -> Subst -- ^ The substitution -> (Pat, Term) -- ^ The alternative in which to apply the substitution -> (Pat, Term) substAlt doc subst (pat,alt) = case pat of DataPat dc tvs ids -> case List.mapAccumL substTyVarBndr' subst tvs of (subst1,tvs1) -> case List.mapAccumL substIdBndr subst1 ids of (subst2,ids1) -> (DataPat dc tvs1 ids1,substTm doc subst2 alt) _ -> (pat, substTm doc subst alt) substId :: HasCallStack => Subst -> Id -> Id substId subst oldId = snd $ substIdBndr subst oldId -- | Find the substitution for an 'Id' in the 'Subst' lookupIdSubst :: HasCallStack => Doc () -> Subst -> Id -> Term lookupIdSubst doc (Subst inScope tmS _ genv) v | isGlobalId v = case lookupVarEnv v genv of Just e -> e _ -> Var v | Just e <- lookupVarEnv v tmS = e -- Vital! See 'IdSubstEnv' Note [Extending the Subst] -- -- TODO: We match on Id here to workaround an issue where type variables -- TODO: "shadow" term variables. Omitting the check would make 'lookupIdSubst' -- TODO: potentially replace an "Id" with a TyVar. For more information: -- TODO: -- TODO: https://github.com/clash-lang/clash-compiler/issues/1046 -- TODO: | Just v'@(Id {}) <- lookupInScope inScope v = Var (coerce v') | otherwise = WARN(True, "Subst.lookupIdSubst" <+> doc <+> fromPpr v) Var v -- | Substitute an 'Id' for another one according to the 'Subst' given, -- returning the result and an update 'Subst' that should be used in subsequent -- substitutions. substIdBndr :: HasCallStack => Subst -> Id -> (Subst,Id) substIdBndr subst@(Subst inScope env tenv genv) oldId = (Subst (inScope `extendInScopeSet` newId) newEnv tenv genv, newId) where id1 = uniqAway inScope oldId newId | noTypeChange = id1 | otherwise = id1 {varType = substTy subst (varType id1)} oldTy = varType oldId noTypeChange = nullVarEnv tenv || isClosed oldTy -- Extend the substitution if the unique has changed. -- -- In case it hasn't changed we don't need to extend the substitution to map -- old to new. But instead we must zap any current substitution for the -- variable. For example -- -- (\x.e) with subst = [x | -> e'] -- -- Here we must simply zap the substitution for x newEnv | noChange = delVarEnv env oldId | otherwise = extendVarEnv oldId (Var newId) env -- See Note [Extending the Subst] why it's not necessary to check noTypeChange noChange = id1 == oldId -- | Like 'substTyVarBndr' but takes a 'Subst' instead of a 'TvSubst' substTyVarBndr' :: HasCallStack => Subst -> TyVar -> (Subst,TyVar) substTyVarBndr' (Subst inScope tmS tyS tgS) tv = case substTyVarBndr (TvSubst inScope tyS) tv of (TvSubst inScope' tyS',tv') -> (Subst inScope' tmS tyS' tgS, tv') -- | Apply a substitution to an entire set of let-bindings, additionally -- returning an updated 'Subst' that should be used by subsequent substitutions. substBind :: HasCallStack => Doc () -> Subst -> Bind Term -> (Subst, Bind Term) substBind doc subst (NonRec i x) = (subst', NonRec i' x') where (subst', i') = substIdBndr subst i x' = substTm ("substBind" <+> doc) subst x substBind doc subst (Rec xs) = (subst', Rec (zip bndrs' rhss')) where (bndrs,rhss) = unzip xs (subst',bndrs') = List.mapAccumL substIdBndr subst bndrs rhss' = map (substTm ("substBind" <+> doc) subst') rhss -- | Type substitution, see 'zipTvSubst' -- -- Works only if the domain of the substitution is superset of the type being -- substituted into substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type substTyWith tvs tys = ASSERT( List.equalLength tvs tys ) substTy (zipTvSubst tvs tys) -- | Ensure that non of the binders in an expression shadow each-other, nor -- conflict with he in-scope set deShadowTerm :: HasCallStack => InScopeSet -> Term -> Term deShadowTerm is e = substTm "deShadowTerm" (mkSubst is) e -- | Ensure that non of the binders in an alternative shadow each-other, nor -- conflict with the in-scope set deShadowAlt :: HasCallStack => InScopeSet -> (Pat, Term) -> (Pat, Term) deShadowAlt is = substAlt "deShadowAlt" (mkSubst is) -- | Ensure that non of the let-bindings of a let-expression shadow w.r.t the -- in-scope set deshadowLetExpr :: HasCallStack => InScopeSet -- ^ Current InScopeSet -> Bind Term -- ^ Bindings of the let-expression -> Term -- ^ The body of the let-expression -> (Bind Term, Term) -- ^ Deshadowed let-bindings, where let-bound expressions and the let-body -- properly reference the renamed variables deshadowLetExpr is bs e = case substBind "deshadowLetBindings" (mkSubst is) bs of (s1,bs1) -> (bs1, substTm "deShadowLetBody" s1 e) -- | A much stronger variant of `deShadowTerm` that ensures that all bound -- variables are unique. -- -- Also returns an extended 'InScopeSet' additionally containing the (renamed) -- unique bound variables of the term. freshenTm :: InScopeSet -- ^ Current set of variables in scope -> Term -> (InScopeSet, Term) freshenTm is0 = go (mkSubst is0) where go subst0 = \case Var v -> (substInScope subst0, lookupIdSubst "freshenTm" subst0 v) Lam v e -> case substIdBndr subst0 v of (subst1,v') -> case go subst1 e of (is2,e') -> (is2, Lam v' e') TyLam v e -> case substTyVarBndr' subst0 v of (subst1,v') -> case go subst1 e of (is2,e') -> (is2,TyLam v' e') App l r -> case go subst0 l of (is1,l') -> case go subst0 {substInScope = is1} r of (is2,r') -> (is2, App l' r') TyApp l r -> case go subst0 l of (is1,l') -> (is1, TyApp l' (substTy subst0 r)) Let bs e -> case goBind subst0 bs of (subst1,bs') -> case go subst1 e of (is2,e') -> (is2,Let bs' e') Case subj ty alts -> case go subst0 subj of (is1,subj') -> case List.mapAccumL (\isN -> goAlt subst0 {substInScope = isN}) is1 alts of (is2,alts') -> (is2, Case subj' (substTy subst0 ty) alts') Cast e t1 t2 -> case go subst0 e of (is1, e') -> (is1, Cast e' (substTy subst0 t1) (substTy subst0 t2)) Tick tick e -> case go subst0 e of (is1, e') -> (is1, Tick (goTick subst0 tick) e') tm -> (substInScope subst0, tm) goBind subst0 (NonRec i x) = let (subst1, i') = substIdBndr subst0 i (is2, x') = go subst0 x in (subst1 { substInScope = extendInScopeSet is2 i' }, NonRec i' x') goBind subst0 (Rec xs) = let (bndrs,rhss) = unzip xs (subst1,bndrs') = List.mapAccumL substIdBndr subst0 bndrs (is2,rhss') = List.mapAccumL (\isN -> go subst1 {substInScope = isN}) (substInScope subst1) rhss in (subst1 {substInScope = is2}, Rec $ zip bndrs' rhss') goAlt subst0 (pat,alt) = case pat of DataPat dc tvs ids -> case List.mapAccumL substTyVarBndr' subst0 tvs of (subst1,tvs') -> case List.mapAccumL substIdBndr subst1 ids of (subst2,ids') -> case go subst2 alt of (is3,alt') -> (is3,(DataPat dc tvs' ids',alt')) _ -> case go subst0 alt of (is1,alt') -> (is1,(pat,alt')) goTick subst0 (NameMod m ty) = NameMod m (substTy subst0 ty) goTick _ tick = tick -- * AEQ -- | Alpha equality for types aeqType :: Type -> Type -> Bool aeqType t1 t2 = acmpType' rnEnv t1 t2 == EQ where rnEnv = mkRnEnv (mkInScopeSet (freeVarsOf [t1,t2])) -- | Alpha comparison for types acmpType :: Type -> Type -> Ordering acmpType t1 t2 = acmpType' (mkRnEnv inScope) t1 t2 where inScope = mkInScopeSet (freeVarsOf [t1,t2]) -- | Alpha comparison for types. Faster than 'acmpType' as it doesn't need to -- calculate the free variables to create the 'InScopeSet' acmpType' :: RnEnv -> Type -> Type -> Ordering acmpType' = go where go env (VarTy tv1) (VarTy tv2) = compare (rnOccLTy env tv1) (rnOccRTy env tv2) go _ (ConstTy c1) (ConstTy c2) = compare c1 c2 go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = go env (varType tv1) (varType tv2) `thenCompare` go (rnTyBndr env tv1 tv2) t1 t2 go env (AppTy s1 t1) (AppTy s2 t2) = go env s1 s2 `thenCompare` go env t1 t2 go _ (LitTy l1) (LitTy l2) = compare l1 l2 go env (AnnType a1 t1) (AnnType a2 t2) = compare a1 a2 `thenCompare` go env t1 t2 go _ t1 t2 = compare (getRank t1) (getRank t2) getRank :: Type -> Word getRank (VarTy {}) = 0 getRank (LitTy {}) = 1 getRank (ConstTy {}) = 2 getRank (AnnType {}) = 3 getRank (AppTy {}) = 4 getRank (ForAllTy {}) = 5 -- | Structural equality on 'Type' eqType :: Type -> Type -> Bool eqType = go where go (VarTy tv1) (VarTy tv2) = tv1 == tv2 go (ConstTy c1) (ConstTy c2) = c1 == c2 go (ForAllTy tv1 t1) (ForAllTy tv2 t2) = tv1 == tv2 && go (varType tv1) (varType tv2) && go t1 t2 go (AppTy s1 t1) (AppTy s2 t2) = go s1 s2 && go t1 t2 go (LitTy l1) (LitTy l2) = l1 == l2 go (AnnType a1 t1) (AnnType a2 t2) = a1 == a2 && go t1 t2 go _ _ = False -- | Alpha equality for terms aeqTerm :: Term -> Term -> Bool aeqTerm t1 t2 = aeqTerm' inScope t1 t2 where inScope = mkInScopeSet (freeVarsOf [t1,t2]) -- | Alpha equality for terms. Faster than 'aeqTerm' as it doesn't need to -- calculate the free variables to create the 'InScopeSet' aeqTerm' :: InScopeSet -- ^ Superset of variables in scope of the left and right term -> Term -> Term -> Bool aeqTerm' inScope t1 t2 = acmpTerm' inScope t1 t2 == EQ -- | Alpha comparison for types acmpTerm :: Term -> Term -> Ordering acmpTerm t1 t2 = acmpTerm' inScope t1 t2 where inScope = mkInScopeSet (freeVarsOf [t1,t2]) -- | Alpha comparison for types. Faster than 'acmpTerm' as it doesn't need to -- calculate the free variables to create the 'InScopeSet' acmpTerm' :: InScopeSet -- ^ Superset of variables in scope of the left and right term -> Term -> Term -> Ordering acmpTerm' inScope = go (mkRnEnv inScope) where thenCmpTm EQ rel = rel thenCmpTm rel _ = rel go env (Var id1) (Var id2) = compare (rnOccLId env id1) (rnOccRId env id2) go _ (Data dc1) (Data dc2) = compare dc1 dc2 go _ (Literal l1) (Literal l2) = compare l1 l2 go _ (Prim p1) (Prim p2) = comparing primName p1 p2 go env (Lam b1 e1) (Lam b2 e2) = acmpType' env (varType b1) (varType b2) `thenCompare` go (rnTmBndr env b1 b2) e1 e2 go env (TyLam b1 e1) (TyLam b2 e2) = acmpType' env (varType b1) (varType b2) `thenCompare` go (rnTyBndr env b1 b2) e1 e2 go env (App l1 r1) (App l2 r2) = go env l1 l2 `thenCompare` go env r1 r2 go env (TyApp l1 r1) (TyApp l2 r2) = go env l1 l2 `thenCompare` acmpType' env r1 r2 go env (Let (NonRec i1 x1) e1) (Let (NonRec i2 x2) e2) = go env x1 x2 `thenCompare` go (rnTmBndr env i1 i2) e1 e2 go env (Let (Rec bs1) e1) (Let (Rec bs2) e2) = compare (length bs1) (length bs2) `thenCompare` foldr thenCmpTm EQ (zipWith (go env') rhs1 rhs2) `thenCompare` go env' e1 e2 where (ids1,rhs1) = unzip bs1 (ids2,rhs2) = unzip bs2 env' = rnTmBndrs env ids1 ids2 go env (Case e1 _ a1) (Case e2 _ a2) = compare (length a1) (length a2) `thenCompare` go env e1 e2 `thenCompare` foldr thenCmpTm EQ (zipWith (goAlt env) a1 a2) go env (Cast e1 l1 r1) (Cast e2 l2 r2) = go env e1 e2 `thenCompare` acmpType' env l1 l2 `thenCompare` acmpType' env r1 r2 go env (Tick t1 e1) (Tick t2 e2) = compare t1 t2 `thenCompare` go env e1 e2 go _ e1 e2 = compare (getRank e1) (getRank e2) goAlt env (DataPat c1 tvs1 ids1,e1) (DataPat c2 tvs2 ids2,e2) = compare c1 c2 `thenCompare` go env' e1 e2 where env' = rnTmBndrs (rnTyBndrs env tvs1 tvs2) ids1 ids2 goAlt env (c1,e1) (c2,e2) = compare c1 c2 `thenCompare` go env e1 e2 getRank :: Term -> Word getRank = \case Var {} -> 0 Data {} -> 1 Literal {} -> 2 Prim {} -> 3 Cast {} -> 4 App {} -> 5 TyApp {} -> 6 Lam {} -> 7 TyLam {} -> 8 Let NonRec{} _ -> 9 Let Rec{} _ -> 10 Case {} -> 11 Tick {} -> 12 -- | Structural equality on 'Term' eqTerm :: Term -> Term -> Bool eqTerm = go where go (Var id1) (Var id2) = id1 == id2 go (Data dc1) (Data dc2) = dc1 == dc2 go (Literal l1) (Literal l2) = l1 == l2 go (Prim p1) (Prim p2) = primName p1 == primName p2 go (Lam b1 e1) (Lam b2 e2) = b1 == b2 && eqType (varType b1) (varType b2) && go e1 e2 go (TyLam b1 e1) (TyLam b2 e2) = b1 == b2 && eqType (varType b1) (varType b2) && go e1 e2 go (App l1 r1) (App l2 r2) = go l1 l2 && go r1 r2 go (TyApp l1 r1) (TyApp l2 r2) = go l1 l2 && eqType r1 r2 go (Let bs1 e1) (Let bs2 e2) = go e1 e2 && goBind bs1 bs2 where goBind (NonRec b1 r1) (NonRec b2 r2) = -- No need to check types of NonRec bindings, when the RHSs match the -- types must be the same. b1 == b2 && go r1 r2 goBind (Rec brs1) (Rec brs2) = List.all2 (\(b1,r1) (b2,r2) -> b1 == b2 && -- We need to check the types of Rec bindings, because: -- -- letrec (x : Bool) = x in X -- -- is not structurally equivalent to -- -- letrec (x : Int) = x in x eqType (varType b1) (varType b2) && go r1 r2) brs1 brs2 goBind _ _ = False go (Case e1 _ a1) (Case e2 _ a2) = go e1 e2 && List.all2 goAlt a1 a2 where goAlt (p1,r1) (p2,r2) = p1 == p2 && go r1 r2 go (Cast e1 l1 r1) (Cast e2 l2 r2) = go e1 e2 && eqType l1 l2 && eqType r1 r2 go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && go e1 e2 go _ _ = False instance Eq Type where (==) = aeqType instance Ord Type where compare = acmpType instance Eq Term where (==) = aeqTerm instance TypeError ( 'Text "A broken implementation of Hashable Term has been " ':<>: 'Text "removed in Clash 1.4.7. If this is an issue for you, please submit " ':<>: 'Text "an issue report at https://github.com/clash-lang/clash-compiler/issues." ) => Hashable Term where hashWithSalt = error "Term.hashWithSalt: unreachable" instance Ord Term where compare = acmpTerm clash-lib-1.8.1/src/Clash/Core/Subst.hs-boot0000644000000000000000000000051007346545000016652 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module Clash.Core.Subst where import GHC.Stack (HasCallStack) import {-# SOURCE #-} Clash.Core.Type (Type) import Clash.Core.Var (TyVar) substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type aeqType :: Type -> Type -> Bool instance Eq Type instance Ord Type clash-lib-1.8.1/src/Clash/Core/Term.hs0000644000000000000000000003475507346545000015542 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2017, Google Inc. 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Term representation in the CoreHW language: System F + LetRec + Case -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Clash.Core.Term ( Term (.., Letrec) , mkAbstraction , mkTyLams , mkLams , mkApps , mkTyApps , mkTmApps , mkTicks , TmName , varToId , Bind(..) , LetBinding , Pat (..) , patIds , patVars , Alt , TickInfo (..) , stripTicks , stripAllTicks , partitionTicks , NameMod (..) , PrimInfo (..) , PrimUnfolding (..) , IsMultiPrim (..) , MultiPrimInfo (..) , WorkInfo (..) , CoreContext (..) , Context , isLambdaBodyCtx , isTickCtx , walkTerm , collectArgs , collectArgsTicks , collectTicks , collectTermIds , collectBndrs , primArg ) where -- External Modules import Control.DeepSeq import Data.Binary (Binary) import Data.Coerce (coerce) import qualified Data.DList as DList import Data.Either (lefts, rights) import Data.Foldable (foldl') import Data.Hashable (Hashable) import Data.Maybe (catMaybes) import Data.List (nub, partition) import Data.Text (Text) import GHC.Generics #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (SrcSpan, leftmost_smallest) #else 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/Ord Type import {-# SOURCE #-} Clash.Core.Type (Type) import Clash.Core.Var (Var, Id, TyVar) import Clash.Util (curLoc, thenCompare) -- | Term representation in the CoreHW language: System F + LetRec + Case data Term = Var !Id -- ^ Variable reference | Data !DataCon -- ^ Datatype constructor | Literal !Literal -- ^ Literal | Prim !PrimInfo -- ^ Primitive | Lam !Id Term -- ^ Term-abstraction | TyLam !TyVar Term -- ^ Type-abstraction | App !Term !Term -- ^ Application | TyApp !Term !Type -- ^ Type-application | Let !(Bind Term) Term -- ^ Recursive let-binding | Case !Term !Type [Alt] -- ^ Case-expression: subject, type of -- alternatives, list of alternatives | Cast !Term !Type !Type -- ^ Cast a term from one type to another | Tick !TickInfo !Term -- ^ Annotated term deriving (Show, Generic, NFData, Binary) -- TODO When it is possible, remove this pattern. pattern Letrec :: [LetBinding] -> Term -> Term pattern Letrec bs x <- Let (bindToList -> bs) x where Letrec bs x = Let (Rec bs) x bindToList :: Bind a -> [(Id, a)] bindToList (NonRec i x) = [(i, x)] bindToList (Rec xs) = xs data TickInfo = SrcSpan !SrcSpan -- ^ Source tick, will get added by GHC by running clash with `-g` | NameMod !NameMod !Type -- ^ Modifier for naming module instantiations and registers, are added by -- the user by using the functions @Clash.Magic.[prefixName,suffixName,setName]@ | DeDup -- ^ Deduplicate, i.e. try to share expressions between multiple branches. | NoDeDup -- ^ Do not deduplicate, i.e. /keep/, an expression inside a case-alternative; -- 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 -- ^ @Clash.Magic.prefixName@ | SuffixName -- ^ @Clash.Magic.suffixName@ | SuffixNameP -- ^ @Clash.Magic.suffixNameP@ | SetName -- ^ @Clash.Magic.setName@ deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary) data IsMultiPrim = SingleResult | MultiResult deriving (Show, Generic, NFData, Eq, Hashable, Binary) data PrimInfo = PrimInfo { primName :: !Text , primType :: !Type , primWorkInfo :: !WorkInfo , primMultiResult :: !IsMultiPrim -- ^ Primitive with multiple return values. Useful for primitives that cannot -- return their results as a single product type, due to limitation of -- synthesis tooling. It will be applied to its normal arguments, followed by -- the variables it should assign its results to. -- -- See: 'Clash.Normalize.Transformations.setupMultiResultPrim' , primUnfolding :: !PrimUnfolding } deriving (Show, Generic, NFData, Binary) data PrimUnfolding = NoUnfolding | Unfolding !Id deriving (Show, Generic, NFData, Eq, Hashable, Binary) data MultiPrimInfo = MultiPrimInfo { mpi_primInfo :: PrimInfo , mpi_resultDc :: DataCon , mpi_resultTypes :: [Type] } data WorkInfo = WorkConstant -- ^ Ignores its arguments, and outputs a constant | WorkNever -- ^ Never adds any work | WorkVariable -- ^ Does work when the arguments are variable | WorkAlways -- ^ Performs work regardless of whether the variables are constant or -- variable; these are things like clock or reset generators | WorkIdentity Int [Int] -- ^ A more restrictive version of 'WorkNever', where the value is the -- argument at the given position if all arguments for the given list of -- positions are also 'WorkIdentity' deriving (Eq,Show,Generic,NFData,Hashable,Binary) -- | Term reference type TmName = Name Term -- | Binding in a LetRec construct type LetBinding = (Id, Term) data Bind a = NonRec Id a | Rec [(Id, a)] deriving (Eq, Show, Generic, NFData, Hashable, Binary, Functor) -- Structural equivalence instead of alpha equivalance -- | Patterns in the LHS of a case-decomposition data Pat = DataPat !DataCon [TyVar] [Id] -- ^ Datatype pattern, '[TyVar]' bind existentially-quantified -- type-variables of a DataCon | LitPat !Literal -- ^ Literal pattern | DefaultPat -- ^ Default pattern deriving (Eq, Ord, Show, Generic, NFData, Binary) type Alt = (Pat,Term) -- | Get the list of term-binders out of a DataType pattern patIds :: Pat -> ([TyVar],[Id]) patIds (DataPat _ tvs ids) = (tvs,ids) patIds _ = ([],[]) patVars :: Pat -> [Var a] patVars (DataPat _ tvs ids) = coerce tvs ++ coerce ids patVars _ = [] -- | Abstract a term over a list of term and type variables mkAbstraction :: Term -> [Either Id TyVar] -> Term mkAbstraction = foldr (either Lam TyLam) -- | Abstract a term over a list of type variables mkTyLams :: Term -> [TyVar] -> Term mkTyLams tm = mkAbstraction tm . map Right -- | Abstract a term over a list of variables mkLams :: Term -> [Id] -> Term mkLams tm = mkAbstraction tm . map Left -- | Apply a list of types and terms to a term mkApps :: Term -> [Either Term Type] -> Term mkApps = foldl' (\e a -> either (App e) (TyApp e) a) -- | Apply a list of terms to a term mkTmApps :: Term -> [Term] -> Term mkTmApps = foldl' App -- | Apply a list of types to a term mkTyApps :: Term -> [Type] -> Term mkTyApps = foldl' TyApp mkTicks :: Term -> [TickInfo] -> Term mkTicks tm ticks = foldl' (\e s -> Tick s e) tm (nub ticks) -- | Context in which a term appears data CoreContext = AppFun -- ^ Function position of an application | AppArg (Maybe (Text, Int, Int)) -- ^ Argument position of an application. If this is an argument applied to -- a primitive, a tuple is defined containing (name of the primitive, #type -- args, #term args) | TyAppC -- ^ Function position of a type application | LetBinding Id [Id] -- ^ RHS of a Let-binder with the sibling LHS' | LetBody [LetBinding] -- ^ Body of a Let-binding with the bound LHS' | LamBody Id -- ^ Body of a lambda-term with the abstracted variable | TyLamBody TyVar -- ^ Body of a TyLambda-term with the abstracted type-variable | CaseAlt Pat -- ^ RHS of a case-alternative with the bound pattern on the LHS | CaseScrut -- ^ Subject of a case-decomposition | CastBody -- ^ Body of a Cast | TickC TickInfo -- ^ Body of a Tick deriving (Show, Generic, NFData, Binary) -- | A list of @CoreContext@ describes the complete navigation path from the -- top-level to a specific sub-expression. type Context = [CoreContext] -- [Note] Custom @Eq@ instance for @CoreContext@ -- -- We need a manual equality instance here, due to the argument of `AppArg`. -- Specifically, it is the only piece of information kept in `CoreContext`, -- which references information about its children, breaking the invariant -- that contexts represent a navigation to a specific sub-expression. -- -- One would expect equal contexts to navigate to the same place, but if -- these navigate to an argument position that contains different children, -- we will get inequality from the derived `Eq`. instance Eq CoreContext where c == c' = case (c, c') of (AppFun, AppFun) -> True (AppArg _, AppArg _) -> True -- 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') -> map fst is == map fst is' (LamBody i, LamBody i') -> i == i' (TyLamBody tv, TyLamBody tv') -> tv == tv' (CaseAlt p, CaseAlt p') -> p == p' (CaseScrut, CaseScrut) -> True (CastBody, CastBody) -> True (TickC sp, TickC sp') -> sp == sp' (_, _) -> False -- | Is the Context a Lambda/Term-abstraction context? isLambdaBodyCtx :: CoreContext -> Bool isLambdaBodyCtx (LamBody _) = True isLambdaBodyCtx _ = False -- | Is the Context a Tick context? isTickCtx :: CoreContext -> Bool isTickCtx (TickC _) = True isTickCtx _ = False stripTicks :: Term -> Term stripTicks (Tick _ e) = stripTicks e stripTicks e = e -- | Like 'stripTicks' but removes all ticks from subexpressions. stripAllTicks :: Term -> Term stripAllTicks = go where go (Lam i x) = Lam i (go x) go (TyLam i x) = TyLam i (go x) go (App f x) = App (go f) (go x) go (TyApp f a) = TyApp (go f) a go (Let bs x) = Let (goBinds bs) (go x) go (Case x ty alts) = Case (go x) ty (fmap go <$> alts) go (Cast x a b) = Cast (go x) a b go (Tick _ x) = go x go x = x goBinds (NonRec i x) = NonRec i (go x) goBinds (Rec ixs) = Rec (fmap go <$> ixs) -- | Split a (Type)Application in the applied term and it arguments collectArgs :: Term -> (Term, [Either Term Type]) collectArgs = go [] where go args (App e1 e2) = go (Left e2:args) e1 go args (TyApp e t) = go (Right t:args) e go args (Tick _ e) = go args e go args e = (e, args) collectTicks :: Term -> (Term, [TickInfo]) collectTicks = go [] where go ticks (Tick s e) = go (s:ticks) e go ticks e = (e,ticks) collectArgsTicks :: Term -> (Term, [Either Term Type], [TickInfo]) collectArgsTicks = go [] [] where go args ticks (App e1 e2) = go (Left e2:args) ticks e1 go args ticks (TyApp e t) = go (Right t:args) ticks e go args ticks (Tick s e) = go args (s:ticks) e go args ticks e = (e, args, ticks) -- | Split a (Type)Abstraction in the bound variables and the abstracted term collectBndrs :: Term -> ([Either Id TyVar], Term) collectBndrs = go [] where go bs (Lam v e') = go (Left v:bs) e' go bs (TyLam tv e') = go (Right tv:bs) e' go bs e' = (reverse bs,e') -- | Given a function application, find the primitive it's applied. Yields -- Nothing if given term is not an application or if it is not a primitive. primArg :: Term -- ^ Function application -> Maybe (Text, Int, Int) -- ^ If @Term@ was a primitive: (name of primitive, #type args, #term args) primArg (collectArgs -> t) = case t of (Prim p, args) -> Just (primName p, length (rights args), length (lefts args)) _ -> Nothing -- | Partition ticks in source ticks and nameMod ticks partitionTicks :: [TickInfo] -> ([TickInfo], [TickInfo]) -- ^ (source ticks, nameMod ticks) partitionTicks = partition (\case {SrcSpan {} -> True; _ -> False}) -- | Visit all terms in a term, testing it with a predicate, and returning -- a list of predicate yields. walkTerm :: forall a . (Term -> Maybe a) -> Term -> [a] walkTerm f = catMaybes . DList.toList . go where go :: Term -> DList.DList (Maybe a) go t = DList.cons (f t) $ case t of Var _ -> mempty Data _ -> mempty Literal _ -> mempty Prim _ -> mempty Lam _ t1 -> go t1 TyLam _ t1 -> go t1 App t1 t2 -> go t1 <> go t2 TyApp t1 _ -> go t1 Let (NonRec _ x) t1 -> go t1 <> go x Let (Rec bndrs) t1 -> go t1 <> mconcat (map (go . snd) bndrs) Case t1 _ alts -> go t1 <> mconcat (map (go . snd) alts) Cast t1 _ _ -> go t1 Tick _ t1 -> go t1 -- Collect all term ids mentioned in a term collectTermIds :: Term -> [Id] collectTermIds = concat . walkTerm (Just . go) where go :: Term -> [Id] go (Var i) = [i] go (Lam i _) = [i] go (Let (NonRec i _) _) = [i] go (Let (Rec bndrs) _) = fmap fst bndrs go (Case _ _ alts) = concatMap (pat . fst) alts go (Data _) = [] go (Literal _) = [] go (Prim _) = [] go (TyLam _ _) = [] go (App _ _) = [] go (TyApp _ _) = [] go (Cast _ _ _) = [] go (Tick _ _) = [] pat :: Pat -> [Id] pat (DataPat _ _ ids) = ids pat (LitPat _) = [] pat DefaultPat = [] -- | Make a term variable out of a variable reference or ticked variable -- reference varToId :: Term -> Id varToId = \case Var i -> i Tick _ e -> varToId e e -> error $ $(curLoc) ++ "varToId: not a var: " ++ show e clash-lib-1.8.1/src/Clash/Core/Term.hs-boot0000644000000000000000000000056007346545000016466 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} {-# OPTIONS_GHC -fno-warn-missing-methods #-} module Clash.Core.Term where import GHC.Generics (Generic) import Clash.Core.Name (Name) data Term type TmName = Name Term instance Generic Term clash-lib-1.8.1/src/Clash/Core/TermInfo.hs0000644000000000000000000000655007346545000016346 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} module Clash.Core.TermInfo where import Data.Maybe (fromMaybe) import GHC.Stack (HasCallStack) import Clash.Core.HasType import Clash.Core.Term import Clash.Core.TyCon (tyConDataCons, isTupleTyConLike, TyConMap) import Clash.Core.Type import Clash.Core.Var import qualified Clash.Data.UniqMap as UniqMap import Clash.Util.Interpolate as I termSize :: Term -> Word termSize (Var {}) = 1 termSize (Data {}) = 1 termSize (Literal {}) = 1 termSize (Prim {}) = 1 termSize (Lam _ e) = termSize e + 1 termSize (TyLam _ e) = termSize e termSize (App e1 e2) = termSize e1 + termSize e2 termSize (TyApp e _) = termSize e termSize (Cast e _ _) = termSize e termSize (Tick _ e) = termSize e termSize (Let (NonRec _ x) e) = termSize x + termSize e termSize (Let (Rec xs) e) = sum (bodySz:bndrSzs) where bndrSzs = map (termSize . snd) xs bodySz = termSize e termSize (Case subj _ alts) = sum (subjSz:altSzs) where subjSz = termSize subj altSzs = map (termSize . snd) alts multPrimErr :: PrimInfo -> String multPrimErr primInfo = [I.i| Internal error in multiPrimInfo': could not produce MultiPrimInfo. This probably means a multi result blackbox's result type was not a tuple. PrimInfo: #{primInfo} |] splitMultiPrimArgs :: HasCallStack => MultiPrimInfo -> [Either Term Type] -> ([Either Term Type], [Id]) splitMultiPrimArgs MultiPrimInfo{mpi_resultTypes} args0 = (args1, resArgs1) where resArgs1 = [id_ | Left (Var id_) <- resArgs0] (args1, resArgs0) = splitAt (length args0 - length mpi_resultTypes) args0 -- | Same as 'multiPrimInfo', but produced an error if it could not produce a -- 'MultiPrimInfo'. multiPrimInfo' :: HasCallStack => TyConMap -> PrimInfo -> MultiPrimInfo multiPrimInfo' tcm primInfo = fromMaybe (error (multPrimErr primInfo)) (multiPrimInfo tcm primInfo) -- | Produce 'MutliPrimInfo' for given primitive multiPrimInfo :: TyConMap -> PrimInfo -> Maybe MultiPrimInfo multiPrimInfo tcm primInfo | (_primArgs, primResTy) <- splitFunForallTy (primType primInfo) , TyConApp tupTcNm tupEls <- tyView primResTy -- XXX: Hardcoded for tuples , isTupleTyConLike tupTcNm , Just tupTc <- UniqMap.lookup tupTcNm tcm , [tupDc] <- tyConDataCons tupTc = Just $ MultiPrimInfo { mpi_primInfo = primInfo , mpi_resultDc = tupDc , mpi_resultTypes = tupEls } multiPrimInfo _ _ = Nothing -- | Does a term have a function type? isFun :: TyConMap -> Term -> Bool isFun m t = isFunTy m (inferCoreTypeOf m t) -- | Does a term have a function or polymorphic type? isPolyFun :: TyConMap -> Term -> Bool isPolyFun m t = isPolyFunCoreTy m (inferCoreTypeOf m t) -- | Is a term a recursive let-binding? isLet :: Term -> Bool isLet Let{} = True isLet _ = False -- | Is a term a variable reference? isVar :: Term -> Bool isVar (Var {}) = True isVar _ = False isLocalVar :: Term -> Bool isLocalVar (Var v) = isLocalId v isLocalVar _ = False -- | Is a term a datatype constructor? isCon :: Term -> Bool isCon (Data {}) = True isCon _ = False -- | Is a term a primitive? isPrim :: Term -> Bool isPrim (Prim {}) = True isPrim _ = False -- | Is a term a tick? isTick :: Term -> Bool isTick Tick{} = True isTick _ = False -- | Is a term a cast? isCast :: Term -> Bool isCast (Cast {}) = True isCast _ = False clash-lib-1.8.1/src/Clash/Core/TermLiteral.hs0000644000000000000000000002133507346545000017045 0ustar0000000000000000{-| 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) import Data.Either (lefts) 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.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 -- | 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 :: HasCallStack => Term -- ^ Term to convert -> Either Term a -- ^ '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 instance TermLiteral String where termToData (collectArgs -> (_, [Left (Literal (StringLiteral s))])) = Right s termToData t = Left t instance TermLiteral Text where 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) termToData t = Left t instance TermLiteral Word where termToData (collectArgs -> (_, [Left (Literal (WordLiteral n))])) = Right (fromInteger n) 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 instance TermLiteral Char where termToData (collectArgs -> (_, [Left (Literal (CharLiteral c))])) = Right c 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 b' <- termToData b pure (a', b') termToData t = Left t 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 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 showsTypePrec n _ = showParen (n > 10) $ showString "Vec" . showChar ' ' . showString (show (natToInteger @n)) . showChar ' ' . showsTypePrec 11 (Proxy @a) 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 -- 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: #{shownType} |] clash-lib-1.8.1/src/Clash/Core/TermLiteral/0000755000000000000000000000000007346545000016505 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Core/TermLiteral/TH.hs0000644000000000000000000001774607346545000017373 0ustar0000000000000000{-| 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 , deriveShowsTypePrec , deriveTermLiteral -- Stop exporting @dcName'@ once `ghcide` stops type-checking expanded -- TH splices , dcName' ) where 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)) import Clash.Core.Name (nameOcc) -- Workaround for a strange GHC bug, where it complains about Subst only -- existing as a boot file: -- -- 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 = -- 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 deriveTermToData1 constrs = LamCaseE [ Match pat (NormalB (if null args then theCase else LetE args theCase)) [] , Match (VarP termName) (NormalB ((ConE 'Left `AppE` VarE termName))) [] ] where nArgs = maximum (map snd constrs) args :: [Dec] 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" -> ...} theCase :: Exp theCase = CaseE (VarE nameName) (map match constrs ++ [emptyMatch]) emptyMatch = Match WildP (NormalB (ConE 'Left `AppE` VarE termName)) [] match :: (Name, Int) -> Match match (cName, nFields) = Match (LitP (StringL (show cName))) (NormalB (mkCall cName nFields)) [] mkCall :: Name -> Int -> Exp mkCall cName 0 = ConE 'Right `AppE` ConE cName mkCall cName 1 = UInfixE (ConE cName) (VarE '(<$>)) (VarE termToDataName `AppE` VarE (NE.head argNames)) mkCall cName nFields = foldl (\e aName -> UInfixE e (VarE '(<*>)) (VarE termToDataName `AppE` VarE aName)) (mkCall cName 1) (take (nFields-1) (NE.tail argNames)) -- term@(collectArgs -> (Data (dcName' -> nm), args)) pat :: Pat pat = AsP 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 = fmap (mkName . ("arg" <>) . show) (NE.iterate (+1) (0 :: Word)) nameName = mkName "nm" clash-lib-1.8.1/src/Clash/Core/TyCon.hs0000644000000000000000000001106207346545000015651 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Type Constructors in CoreHW -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Clash.Core.TyCon ( TyCon (..) , TyConName , TyConMap , AlgTyConRhs (..) , mkKindTyCon , isTupleTyConLike , isPrimTc , isNewTypeTc , isPromotedDc , tyConDataCons ) where -- External Import import Control.DeepSeq import Data.Binary (Binary) import Data.Function (on) import qualified Data.Text as T import GHC.Generics -- Internal Imports import Clash.Core.DataCon (DataCon) 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 data TyCon -- | Algorithmic DataCons = AlgTyCon { tyConUniq :: {-# UNPACK #-} !Unique , tyConName :: !TyConName -- ^ Name of the TyCon , tyConKind :: !Kind -- ^ Kind of the TyCon , tyConArity :: !Int -- ^ Number of type arguments , algTcRhs :: !AlgTyConRhs -- ^ DataCon definitions , isClassTc :: !Bool -- ^ Is this a class dictionary? } | PromotedDataCon { tyConUniq :: {-# UNPACK #-} !Unique -- invariant (same as dcUniq) , tyConName :: !TyConName -- ^ Name of the TyCon , tyConKind :: !Kind -- ^ Kind of the TyCon , tyConArity :: !Int -- ^ Number of type arguments , tyConData :: !DataCon -- ^ DataCon which is promoted } -- | Function TyCons (e.g. type families) | FunTyCon { tyConUniq :: {-# UNPACK #-} !Unique , tyConName :: !TyConName -- ^ Name of the TyCon , tyConKind :: !Kind -- ^ Kind of the TyCon , tyConArity :: !Int -- ^ Number of type arguments , tyConSubst :: [([Type],Type)] -- ^ List of: ([LHS match types], RHS type) } -- | Primitive TyCons | PrimTyCon { tyConUniq :: {-# UNPACK #-} !Unique , tyConName :: !TyConName -- ^ Name of the TyCon , tyConKind :: !Kind -- ^ Kind of the TyCon , tyConArity :: !Int -- ^ Number of type arguments } deriving (Show,Generic,NFData,Binary) {- instance Show TyCon where show (AlgTyCon {tyConName = n}) = "AlgTyCon: " ++ show n show (FunTyCon {tyConName = n}) = "FunTyCon: " ++ show n show (PrimTyCon {tyConName = n}) = "PrimTyCon: " ++ show n -} instance Eq TyCon where (==) = (==) `on` tyConUniq (/=) = (/=) `on` tyConUniq instance Uniquable TyCon where getUnique = tyConUniq setUnique tyCon u = tyCon {tyConUniq=u} -- | TyCon reference type TyConName = Name TyCon type TyConMap = UniqMap TyCon -- | The RHS of an Algebraic Datatype data AlgTyConRhs = DataTyCon { dataCons :: [DataCon] -- ^ The DataCons of a TyCon } | NewTyCon { dataCon :: !DataCon -- ^ The newtype DataCon , ntEtadRhs :: ([TyVar],Type) -- ^ The argument type of the newtype -- DataCon in eta-reduced form, which is -- just the representation of the TyCon. -- The TyName's are the type-variables from -- the corresponding TyCon. } deriving (Show,Generic,NFData,Binary) -- | Create a Kind out of a TyConName mkKindTyCon :: TyConName -> Kind -> TyCon mkKindTyCon name kind = PrimTyCon (nameUniq name) name kind 0 -- | Does the TyCon look like a tuple TyCon isTupleTyConLike :: TyConName -> Bool isTupleTyConLike nm = tupleName (T.takeWhileEnd (/= '.') (nameOcc nm)) where 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] tyConDataCons (AlgTyCon {algTcRhs = DataTyCon { dataCons = cons}}) = cons tyConDataCons (AlgTyCon {algTcRhs = NewTyCon { dataCon = con }}) = [con] tyConDataCons _ = [] isPrimTc :: TyCon -> Bool isPrimTc PrimTyCon{} = True isPrimTc _ = False isNewTypeTc :: TyCon -> Bool isNewTypeTc (AlgTyCon {algTcRhs = NewTyCon {}}) = True isNewTypeTc _ = False isPromotedDc :: TyCon -> Bool isPromotedDc PromotedDataCon{} = True isPromotedDc _ = False clash-lib-1.8.1/src/Clash/Core/TyCon.hs-boot0000644000000000000000000000041607346545000016613 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} module Clash.Core.TyCon where import Clash.Core.Name (Name) data TyCon type TyConName = Name TyCon clash-lib-1.8.1/src/Clash/Core/Type.hs0000644000000000000000000006451007346545000015544 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, 2017 , Google Inc. 2021 , QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Types in CoreHW -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Clash.Core.Type ( Type (..) , TypeView (..) , ConstTy (..) , LitTy (..) , Kind , KindOrType , KiName , TyName , TyVar , tyView , coreView , coreView1 , mkTyConTy , mkFunTy , mkPolyFunTy , mkTyConApp , splitFunTy , splitFunTys , splitFunForallTy , splitCoreFunForallTy , splitTyConAppM , isPolyFunTy , isPolyFunCoreTy , isPolyTy , isTypeFamilyApplication , isFunTy , isClassTy , applyFunTy , findFunSubst , reduceTypeFamily , isIntegerTy , normalizeType , varAttrs , typeAttrs ) where -- External import import Control.DeepSeq as DS import Data.Binary (Binary) import Data.Coerce (coerce) import Data.Hashable (Hashable (hashWithSalt)) 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, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey, typeNatCmpTyFamNameKey, ordLTDataConKey, ordEQDataConKey, ordGTDataConKey, typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey) import GHC.Types.SrcLoc (wiredInSrcSpan) import GHC.Types.Unique (getKey) #else #if __GLASGOW_HASKELL__ >= 808 import PrelNames (ordLTDataConKey, ordEQDataConKey, ordGTDataConKey) #else import Unique (Unique) import PrelNames (ltDataConKey, eqDataConKey, gtDataConKey) #endif import PrelNames (integerTyConKey, typeNatAddTyFamNameKey, typeNatExpTyFamNameKey, typeNatLeqTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey, typeNatCmpTyFamNameKey, typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey) import SrcLoc (wiredInSrcSpan) import Unique (getKey) #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 qualified Clash.Data.UniqMap as UniqMap import Clash.Util #if __GLASGOW_HASKELL__ <= 806 ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique.Unique ordLTDataConKey = ltDataConKey ordEQDataConKey = eqDataConKey ordGTDataConKey = gtDataConKey #endif varAttrs :: Var a -> [Attr Text] varAttrs t@(TyVar {}) = error $ $(curLoc) ++ "Unexpected argument: " ++ show t varAttrs (Id _ _ ty _) = case ty of AnnType attrs _typ -> attrs _ -> [] -- | Types in CoreHW: function and polymorphic types data Type = VarTy !TyVar -- ^ Type variable | ConstTy !ConstTy -- ^ Type constant | ForAllTy !TyVar !Type -- ^ Polymorphic Type | AppTy !Type !Type -- ^ Type Application | LitTy !LitTy -- ^ Type literal | AnnType [Attr Text] !Type -- ^ Annotated type, see Clash.Annotations.SynthesisAttributes deriving (Show, Generic, NFData, Binary) instance TypeError ( 'Text "A broken implementation of Hashable Type has been " ':<>: 'Text "removed in Clash 1.4.7. If this is an issue for you, please submit " ':<>: 'Text "an issue report at https://github.com/clash-lang/clash-compiler/issues." ) => Hashable Type where hashWithSalt = error "Type.hashWithSalt: unreachable" -- | An easier view on types data TypeView = FunTy !Type !Type -- ^ Function type | TyConApp !TyConName [Type] -- ^ Applied TyCon | OtherType !Type -- ^ Neither of the above deriving Show -- | Type Constants data ConstTy = TyCon !TyConName -- ^ TyCon type | Arrow -- ^ Function type deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary) -- | Literal Types data LitTy = NumTy !Integer | SymTy !String | CharTy !Char deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary) -- | The level above types type Kind = Type -- | Either a Kind or a Type type KindOrType = Type -- | Reference to a Type type TyName = Name Type -- | Reference to a Kind type KiName = Name Kind -- TODO -- -- tyView could be smarter about what it gives back. Since it traverses the -- arguments to make a `TyConApp`, if the leftmost innermost type isn't a -- TyCon it could still return a list of applied types to save a later call to -- something like splitFunForallTy. -- -- It could / should also look through annotations instead of just returning -- the original type wrapped in OtherType. -- | An easier view on types -- -- Note [Arrow arguments] -- -- Clash' Arrow type can either have 2 or 4 arguments, depending on who created it. -- By default it has two arguments: the argument type of a function, and the result -- type of a function. -- -- So when do we have 4 arguments? When in Haskell/GHC land the arrow was -- unsaturated. This can happen in instance heads, or in the eta-reduced -- representation of newtypes. So what are those additional 2 arguments compared to -- the "normal" function type? They're the kinds of argument and result type. tyView :: Type -> TypeView -- XXX: this is a manually unrolled version of: -- -- tyView tOrig = go [] tOrig -- where -- go args t = case t of -- ConstTy c -> case c of -- TyCon tc -> TyConApp tc args -- Arrow -> case args of -- (arg:res:rest) -> case rest of -- [] -> FunTy arg res -- [arg1,res1] -> FunTy arg1 res1 -- _ -> OtherType tOrig -- AppTy l r -> go (r:args) l -- _ -> OtherType tOrig -- -- To get a FunTy without recursive calls. Because it is called so often this -- saves us 5-10% runtime. tyView tOrig = case tOrig of ConstTy c -> case c of TyCon tc -> TyConApp tc [] _ -> OtherType tOrig AppTy l0 res -> case l0 of ConstTy (TyCon tc) -> TyConApp tc [res] AppTy l1 arg -> case l1 of ConstTy Arrow -> FunTy arg res ConstTy (TyCon tc) -> TyConApp tc [arg,res] AppTy l2 resK -> case l2 of ConstTy (TyCon tc) -> TyConApp tc [resK,arg,res] AppTy l3 argK -> case l3 of ConstTy (TyCon tc) -> TyConApp tc [argK,resK,arg,res] ConstTy Arrow -> FunTy arg res -- See Note [Arrow arguments] _ -> case go [argK,resK,arg,res] l3 of (ConstTy (TyCon tc),args) -> TyConApp tc args _ -> OtherType tOrig _ -> OtherType tOrig _ -> OtherType tOrig _ -> OtherType tOrig _ -> OtherType tOrig where go args (AppTy ty1 ty2) = go (ty2:args) ty1 go args t1 = (t1,args) -- | A view on types in which newtypes are transparent, the Signal type is -- transparent, and type functions are evaluated to WHNF (when possible). -- -- Strips away ALL layers. If no layers are found it returns the given type. coreView :: TyConMap -> Type -> Type coreView tcm ty = case coreView1 tcm ty of Nothing -> ty Just ty' -> coreView tcm ty' -- | A view on types in which newtypes are transparent, the Signal type is -- transparent, and type functions are evaluated to WHNF (when possible). -- -- Only strips away one "layer". coreView1 :: TyConMap -> Type -> Maybe Type coreView1 tcMap ty = case tyView ty of TyConApp tcNm args | nameOcc tcNm == "Clash.Signal.BiSignal.BiSignalIn" , [_,_,_,elTy] <- args -> Just elTy | nameOcc tcNm == "Clash.Signal.BiSignal.BiSignalOut" , [_,_,_,elTy] <- args -> Just elTy | nameOcc tcNm == "Clash.Signal.Internal.Signal" , [_,elTy] <- args -> Just elTy | otherwise -> case UniqMap.find tcNm tcMap of AlgTyCon {algTcRhs = (NewTyCon _ nt)} -> newTyConInstRhs nt args _ -> reduceTypeFamily tcMap ty OtherType (AnnType _ ty') -> coreView1 tcMap ty' _ -> Nothing -- | Instantiate and Apply the RHS/Original of a NewType with the given -- list of argument types -- -- Returns /Nothing/ when under-applied newTyConInstRhs :: ([TyVar],Type) -> [Type] -> Maybe Type newTyConInstRhs (tvs,ty) tys | length tvs <= length tys = Just (foldl' AppTy (substTyWith tvs tys1 ty) tys2) | otherwise = Nothing where (tys1, tys2) = splitAtList tvs tys -- | Make a function type of an argument and result type mkFunTy :: Type -> Type -> Type mkFunTy t1 = AppTy (AppTy (ConstTy Arrow) t1) -- | Make a TyCon Application out of a TyCon and a list of argument types mkTyConApp :: TyConName -> [Type] -> Type mkTyConApp tc = foldl AppTy (ConstTy $ TyCon tc) -- | Make a Type out of a TyCon mkTyConTy :: TyConName -> Type mkTyConTy ty = ConstTy $ TyCon ty -- | Split a TyCon Application in a TyCon and its arguments splitTyConAppM :: Type -> Maybe (TyConName,[Type]) splitTyConAppM (tyView -> TyConApp tc args) = Just (tc,args) splitTyConAppM _ = Nothing -- | Is a type polymorphic? isPolyTy :: Type -> Bool isPolyTy (ForAllTy _ _) = True isPolyTy (tyView -> FunTy _ res) = isPolyTy res isPolyTy _ = False -- | Split a function type in an argument and result type splitFunTy :: TyConMap -> Type -> Maybe (Type, Type) splitFunTy m (coreView1 m -> Just ty) = splitFunTy m ty splitFunTy _ (tyView -> FunTy arg res) = Just (arg,res) splitFunTy _ _ = Nothing splitFunTys :: TyConMap -> Type -> ([Type],Type) splitFunTys m ty = go [] ty ty where go args orig_ty (coreView1 m -> Just ty') = go args orig_ty ty' go args _ (tyView -> FunTy arg res) = go (arg:args) res res go args orig_ty _ = (reverse args, orig_ty) -- | Split a poly-function type in a: list of type-binders and argument types, -- and the result type splitFunForallTy :: Type -> ([Either TyVar Type],Type) splitFunForallTy = go [] where go args (ForAllTy tv ty) = go (Left tv:args) ty go args (tyView -> FunTy arg res) = go (Right arg:args) res go args ty = (reverse args,ty) -- | Make a polymorphic function type out of a result type and a list of -- quantifiers and function argument types mkPolyFunTy :: Type -- ^ Result type -> [Either TyVar Type] -- ^ List of quantifiers and function argument types -> Type mkPolyFunTy = foldr (either ForAllTy mkFunTy) -- | Split a poly-function type in a: list of type-binders and argument types, -- and the result type. Looks through 'Signal' and type functions. splitCoreFunForallTy :: TyConMap -> Type -> ([Either TyVar Type], Type) splitCoreFunForallTy tcm ty = go [] ty ty where go args orig_ty (coreView1 tcm -> Just ty') = go args orig_ty ty' go args _ (ForAllTy tv res) = go (Left tv:args) res res go args _ (tyView -> FunTy arg res) = go (Right arg:args) res res go args orig_ty _ = (reverse args,orig_ty) -- | Is a type a polymorphic or function type? isPolyFunTy :: Type -> Bool isPolyFunTy = not . null . fst . splitFunForallTy -- | Is a type a polymorphic or function type under 'coreView1'? isPolyFunCoreTy :: TyConMap -> Type -> Bool isPolyFunCoreTy m (coreView1 m -> Just ty) = isPolyFunCoreTy m ty isPolyFunCoreTy _ ty = case tyView ty of FunTy _ _ -> True OtherType (ForAllTy _ _) -> True _ -> False -- | 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 Text] typeAttrs (AnnType attrs _typ) = attrs typeAttrs _ = [] -- | Is a type a function type? isFunTy :: TyConMap -> Type -> Bool isFunTy m = isJust . splitFunTy m -- | Apply a function type to an argument type and get the result type applyFunTy :: TyConMap -> Type -> Type -> Type applyFunTy m (coreView1 m -> Just ty) arg = applyFunTy m ty arg applyFunTy _ (tyView -> FunTy _ resTy) _ = resTy applyFunTy _ _ _ = error $ $(curLoc) ++ "Report as bug: not a FunTy" -- Type function substitutions -- Given a set of type functions, and list of argument types, get the first -- type function that matches, and return its substituted RHS type. findFunSubst :: TyConMap -> [([Type],Type)] -> [Type] -> Maybe Type findFunSubst _ [] _ = Nothing findFunSubst tcm (tcSubst:rest) args = case funSubsts tcm tcSubst args of Just ty -> Just ty Nothing -> findFunSubst tcm rest args -- Given a ([LHS match type], RHS type) representing a type function, and -- a set of applied types. Match LHS with args, and when successful, return -- a substituted RHS funSubsts :: TyConMap -> ([Type],Type) -> [Type] -> Maybe Type funSubsts tcm (tcSubstLhs,tcSubstRhs) args = do let (funArgs,remainder) = zipAtLeast tcSubstLhs args tySubts <- foldl' (funSubst tcm) (Just []) funArgs let tyRhs = uncurry substTyWith (unzip tySubts) tcSubstRhs -- Type functions can return higher-kinded types case remainder of [] -> return tyRhs -- So don't forget to apply the arguments not consumed by the type -- function application! -- -- Forgetting leads to: #232 args' -> return (foldl' AppTy tyRhs args') where zipAtLeast [] ys = ([],ys) zipAtLeast _ [] = error "Under-applied type family" zipAtLeast (x:xs) (y:ys) = let (zs,remainder) = zipAtLeast xs ys in ((x,y):zs,remainder) -- Given a LHS matching type, and a RHS to-match type, check if LHS and RHS -- are a match. If they do match, and the LHS is a variable, return a -- substitution funSubst :: TyConMap -> Maybe [(TyVar,Type)] -> (Type,Type) -> Maybe [(TyVar,Type)] funSubst _ Nothing = const Nothing funSubst tcm (Just s) = uncurry go where go (VarTy nmF) ty = case lookup nmF s of Nothing -> Just ((nmF,ty):s) -- Given, for example, the type family definition: -- -- > type family Max x y where -- > Max 0 b = b -- > Max a 0 = a -- > Max n n = n -- > Max a b = If (a <=? b) b a -- -- Then `Max 4 8` matches against the 4th clause. -- -- So this is why, whenever we match against a type variable, we first -- check if there is already a substitution defined for this type variable, -- and if so, the applied type, and the type in the substitution should match. Just ty' | ty' `aeqType` ty -> Just s _ -> Nothing -- [Note] funSubst FunTy -- -- Whenever type classes have associated types whose instances 'map' to -- functions, we try to find substitutions in the LHS and RHS of these -- (type-level) functions. Because we use @funSubst@ recursively, we -- implicitly check if these functions are of the same arity and match -- in the first place. An example of such a construct: -- -- class Example p where -- type AB p -- -- instance Example (a -> a) where -- type AB (a -> a) = a -- -- In the given example, we would find two substitutions. For example, when -- matching against `Char -> Char` we'd find a duplicate `a -> Char`. We -- can't think of any (type-checking) cases where these mappings would map -- to different types, so this is OK for our purposes. go (AppTy a1 r1) (AppTy a2 r2) = do s1 <- funSubst tcm (Just s) (a1, a2) funSubst tcm (Just s1) ( r1 , argView tcm r2 -- See [Note: Eager type families] ) go ty1@(ConstTy _) ty2 = -- Looks through AnnType if ty1 `aeqType` ty2 then Just s else Nothing go ty1@(LitTy _) ty2 = -- Looks through AnnType if ty1 `aeqType` ty2 then Just s else Nothing go _ _ = Nothing {- [Note: Eager type families] I don't know whether type families are evaluated strictly or lazily, but since type families do not reduce on stuck argument, we assume strictly. -} reduceTypeFamily :: TyConMap -> Type -> Maybe Type reduceTypeFamily tcm (tyView -> TyConApp tc tys) | nameUniq tc == getKey typeNatAddTyFamNameKey = case mapMaybe (litView tcm) tys of [i1,i2] -> Just (LitTy (NumTy (i1 + i2))) _ -> Nothing | nameUniq tc == getKey typeNatMulTyFamNameKey = case mapMaybe (litView tcm) tys of [i1, i2] -> Just (LitTy (NumTy (i1 * i2))) _ -> Nothing | nameUniq tc == getKey typeNatExpTyFamNameKey = case mapMaybe (litView tcm) tys of [i1, i2] -> Just (LitTy (NumTy (i1 ^ i2))) _ -> Nothing | nameUniq tc == getKey typeNatSubTyFamNameKey = case mapMaybe (litView tcm) tys of [i1, i2] | let z = i1 - i2 , z >= 0 -> 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}) <- UniqMap.lookup tc tcm , (_,tyView -> TyConApp boolTcNm []) <- splitFunTys tcm tck , 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 [i1, i2] -> Just $ ConstTy $ TyCon $ case compare i1 i2 of LT -> Name User "GHC.Types.LT" (getKey ordLTDataConKey) wiredInSrcSpan EQ -> Name User "GHC.Types.EQ" (getKey ordEQDataConKey) wiredInSrcSpan GT -> Name User "GHC.Types.GT" (getKey ordGTDataConKey) wiredInSrcSpan _ -> Nothing | nameUniq tc == getKey typeSymbolCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol" = case mapMaybe (symLitView tcm) tys of [s1, s2] -> Just $ ConstTy $ TyCon $ case compare s1 s2 of LT -> Name User "GHC.Types.LT" (getKey ordLTDataConKey) wiredInSrcSpan EQ -> Name User "GHC.Types.EQ" (getKey ordEQDataConKey) wiredInSrcSpan 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] -> Just (LitTy (SymTy (s1 ++ s2))) _ -> Nothing | nameOcc tc `elem` ["GHC.TypeLits.Extra.FLog", "GHC.TypeNats.FLog"] = case mapMaybe (litView tcm) tys of [i1, i2] | i1 > 1 , i2 > 0 -> Just (LitTy (NumTy (smallInteger (integerLogBase# i1 i2)))) _ -> Nothing | nameOcc tc `elem` ["GHC.TypeLits.Extra.CLog", "GHC.TypeNats.CLog"] = case mapMaybe (litView tcm) tys of [i1, i2] | Just k <- clogBase i1 i2 -> Just (LitTy (NumTy (toInteger k))) _ -> Nothing | nameOcc tc `elem` ["GHC.TypeLits.Extra.Log", "GHC.TypeNats.Log"] = case mapMaybe (litView tcm) tys of [i1, i2] | i1 > 1 , i2 > 0 -> if i2 == 1 then Just (LitTy (NumTy 0)) else let z1 = integerLogBase# i1 i2 z2 = integerLogBase# i1 (i2-1) in if isTrue# (z1 ==# z2) then Nothing else Just (LitTy (NumTy (smallInteger z1))) _ -> Nothing | nameOcc tc `elem` ["GHC.TypeLits.Extra.GCD", "GHC.TypeNats.GCD"] = case mapMaybe (litView tcm) tys of [i1, i2] -> Just (LitTy (NumTy (i1 `gcd` i2))) _ -> Nothing | nameOcc tc `elem` ["GHC.TypeLits.Extra.LCM", "GHC.TypeNats.LCM"] = case mapMaybe (litView tcm) tys of [i1, i2] -> Just (LitTy (NumTy (i1 `lcm` i2))) _ -> Nothing | nameOcc tc `elem` ["GHC.TypeLits.Extra.Div", "GHC.TypeNats.Div"] = case mapMaybe (litView tcm) tys of [i1, i2] | i2 > 0 -> Just (LitTy (NumTy (i1 `div` i2))) _ -> Nothing | nameOcc tc `elem` ["GHC.TypeLits.Extra.Mod", "GHC.TypeNats.Mod"] = case mapMaybe (litView tcm) tys of [i1, i2] | i2 > 0 -> Just (LitTy (NumTy (i1 `mod` i2))) _ -> Nothing | Just (FunTyCon {tyConSubst = tcSubst}) <- UniqMap.lookup tc tcm = let -- See [Note: Eager type families] tysR = map (argView tcm) tys in findFunSubst tcm tcSubst tysR reduceTypeFamily _ _ = Nothing -- | isTypeFamilyApplication :: TyConMap -> Type -> Bool isTypeFamilyApplication tcm (tyView -> TyConApp tcNm _args) | Just (FunTyCon {}) <- UniqMap.lookup tcNm tcm = True isTypeFamilyApplication _tcm _type = False argView :: TyConMap -> Type -> Type argView m t = case reduceTypeFamily m t of Nothing -> t Just tR -> argView m tR litView :: TyConMap -> Type -> Maybe Integer litView _ (LitTy (NumTy i)) = Just i litView m (reduceTypeFamily m -> Just ty') = litView m ty' litView _ _ = Nothing symLitView :: TyConMap -> Type -> Maybe String symLitView _ (LitTy (SymTy s)) = Just s 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 -- | Normalize a type, looking through Signals and newtypes -- -- For example: @Signal a (Vec (6-1) (Unsigned (3+1)))@ normalizes to @Vec 5 (Unsigned 4)@ normalizeType :: TyConMap -> Type -> Type normalizeType tcMap = go where go ty = case tyView ty of TyConApp tcNm args -- These Clash types are implemented with newtypes. -- We need to keep these newtypes because they define the width of the numbers. | nameOcc tcNm == "Clash.Sized.Internal.BitVector.Bit" || nameOcc tcNm == "Clash.Sized.Internal.BitVector.BitVector" || nameOcc tcNm == "Clash.Sized.Internal.Index.Index" || nameOcc tcNm == "Clash.Sized.Internal.Signed.Signed" || nameOcc tcNm == "Clash.Sized.Internal.Unsigned.Unsigned" -> mkTyConApp tcNm (map go args) | otherwise -> case UniqMap.find tcNm tcMap of AlgTyCon {algTcRhs = (NewTyCon _ nt)} -> case newTyConInstRhs nt args of Just ty' -> go ty' Nothing -> ty _ -> let args' = map go args ty' = mkTyConApp tcNm args' in case reduceTypeFamily tcMap ty' of -- TODO Instead of recursing here, reduceTypeFamily should -- ensure that if the result is a reducible type family it is -- also reduced. This would reduce traversals over a type. -- -- It may be a good idea to keep reduceTypeFamily only reducing -- one family, and definiing reduceTypeFamilies to reduce all -- it encounters in one traversal. Just ty'' -> go ty'' Nothing -> ty' FunTy ty1 ty2 -> mkFunTy (go ty1) (go ty2) OtherType (ForAllTy tyvar ty') -> ForAllTy tyvar (go ty') _ -> ty isClassTy :: TyConMap -> Type -> Bool isClassTy tcm (tyView -> TyConApp tcNm _) = case UniqMap.lookup tcNm tcm of Just (AlgTyCon {isClassTc}) -> isClassTc _ -> False isClassTy _ _ = False clash-lib-1.8.1/src/Clash/Core/Type.hs-boot0000644000000000000000000000137107346545000016501 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2017, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} module Clash.Core.Type where import Control.DeepSeq (NFData) import Data.Binary (Binary) import GHC.Generics (Generic) import Clash.Core.Name import {-# SOURCE #-} Clash.Core.TyCon data Type type Kind = Type type TyName = Name Type type KiName = Name Kind instance Generic Type instance Show Type instance NFData Type instance Binary Type mkTyConTy :: TyConName -> Type clash-lib-1.8.1/src/Clash/Core/TysPrim.hs0000644000000000000000000002762707346545000016242 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, 2021 , QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Builtin Type and Kind definitions -} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-} module Clash.Core.TysPrim ( liftedTypeKind , typeNatKind , typeSymbolKind , intPrimTy , 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 , byteArrayPrimTy , eqPrimTy , tysPrimMap ) where #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names import GHC.Types.Unique (getKey) #else import PrelNames 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 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 liftedTypeKindTc, typeNatKindTc, typeSymbolKindTc :: TyCon liftedTypeKindTc = mkKindTyCon liftedTypeKindTyConName liftedTypeKind typeNatKindTc = mkKindTyCon typeNatKindTyConName liftedTypeKind typeSymbolKindTc = mkKindTyCon typeSymbolKindTyConName liftedTypeKind liftedTypeKind, typeNatKind, typeSymbolKind :: Type liftedTypeKind = mkTyConTy liftedTypeKindTyConName typeNatKind = mkTyConTy typeNatKindTyConName typeSymbolKind = mkTyConTy typeSymbolKindTyConName intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName, wordPrimTyConName, int64PrimTyConName, word64PrimTyConName, floatPrimTyConName, doublePrimTyConName, naturalPrimTyConName, byteArrayPrimTyConName, eqPrimTyConName :: TyConName intPrimTyConName = mkUnsafeSystemName "GHC.Prim.Int#" (getKey intPrimTyConKey) #if MIN_VERSION_base(4,15,0) integerPrimTyConName = mkUnsafeSystemName "GHC.Num.Integer.Integer" (getKey integerTyConKey) #else integerPrimTyConName = mkUnsafeSystemName "GHC.Integer.Type.Integer" (getKey integerTyConKey) #endif stringPrimTyConName = mkUnsafeSystemName "GHC.Prim.Addr#" (getKey addrPrimTyConKey) charPrimTyConName = mkUnsafeSystemName "GHC.Prim.Char#" (getKey charPrimTyConKey) wordPrimTyConName = mkUnsafeSystemName "GHC.Prim.Word#" (getKey wordPrimTyConKey) int64PrimTyConName = mkUnsafeSystemName "GHC.Prim.Int64#" (getKey int64PrimTyConKey) word64PrimTyConName = mkUnsafeSystemName "GHC.Prim.Word64#" (getKey word64PrimTyConKey) floatPrimTyConName = mkUnsafeSystemName "GHC.Prim.Float#" (getKey floatPrimTyConKey) doublePrimTyConName = mkUnsafeSystemName "GHC.Prim.Double#" (getKey doublePrimTyConKey) #if MIN_VERSION_base(4,15,0) naturalPrimTyConName = mkUnsafeSystemName "GHC.Num.Natural.Natural" (getKey naturalTyConKey) #else naturalPrimTyConName = mkUnsafeSystemName "GHC.Natural.Natural" (getKey naturalTyConKey) #endif byteArrayPrimTyConName = mkUnsafeSystemName "GHC.Prim.ByteArray#" (getKey byteArrayPrimTyConKey) 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, 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 wordPrimTc = liftedPrimTC wordPrimTyConName int64PrimTc = liftedPrimTC int64PrimTyConName word64PrimTc = liftedPrimTC word64PrimTyConName floatPrimTc = liftedPrimTC floatPrimTyConName doublePrimTc = liftedPrimTC doublePrimTyConName 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 -- forall (a :: Type). forall (b :: Type). a -> b -> Type -- -- The "real" type for this in GHC has a codomain of `TYPE ('TupleRep '[])` -- instead of the `TYPE 'LiftedRep` used here. ty = mkPolyFunTy liftedTypeKind [Left aTv, Left bTv, Right (VarTy aTv), Right (VarTy bTv)] aTv = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0) bTv = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 1) 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 wordPrimTy = mkTyConTy wordPrimTyConName int64PrimTy = mkTyConTy int64PrimTyConName word64PrimTy = mkTyConTy word64PrimTyConName floatPrimTy = mkTyConTy floatPrimTyConName doublePrimTy = mkTyConTy doublePrimTyConName naturalPrimTy = mkTyConTy naturalPrimTyConName 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 = UniqMap.fromList [ (liftedTypeKindTyConName , liftedTypeKindTc) , (typeNatKindTyConName , typeNatKindTc) , (typeSymbolKindTyConName , typeSymbolKindTc) , (intPrimTyConName , intPrimTc) , (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) , (byteArrayPrimTyConName , byteArrayPrimTc) , (eqPrimTyConName , eqPrimTc) ] clash-lib-1.8.1/src/Clash/Core/Util.hs0000644000000000000000000006621707346545000015546 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2021-2023, QBayLogic B.V., 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Smart constructor and destructor functions for CoreHW -} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Core.Util where import Control.Concurrent.Supply (Supply, freshId) import Control.Monad.Trans.Except (Except, throwE, runExcept) import Data.Bifunctor (first, second) import qualified Data.HashSet as HashSet import qualified Data.Graph as Graph import Data.List (mapAccumR, uncons) import Data.List.Extra (zipEqual) import Data.List.NonEmpty (NonEmpty (..), toList) import Data.Maybe (fromMaybe, isJust, mapMaybe, catMaybes) import qualified Data.Set as Set import qualified Data.Set.Lens as Lens import qualified Data.Text as T import GHC.Stack (HasCallStack) #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names (ipClassKey) import GHC.Types.Unique (getKey) #else import PrelNames (ipClassKey) import Unique (getKey) #endif import Clash.Core.DataCon import Clash.Core.EqSolver import Clash.Core.FreeVars (freeLocalIds) import Clash.Core.HasFreeVars import Clash.Core.HasType import Clash.Core.Name (Name (..), OccName, mkUnsafeInternalName, mkUnsafeSystemName) import Clash.Core.Pretty (showPpr) import Clash.Core.Subst import Clash.Core.Term import Clash.Core.TyCon (TyConMap, tyConDataCons) import Clash.Core.Type 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.Util -- | Rebuild a let expression / let expressions by taking the SCCs of a list -- of bindings and remaking Let (NonRec ...) ... and Let (Rec ...) ... -- listToLets :: [LetBinding] -> Term -> Term listToLets xs body = foldr go body (sccLetBindings xs) where go (Graph.AcyclicSCC (i, x)) acc = Let (NonRec i x) acc go (Graph.CyclicSCC binds) acc = Let (Rec binds) acc -- | The type @forall a . a@ undefinedTy ::Type undefinedTy = let aNm = mkUnsafeSystemName "a" 0 aTv = (TyVar aNm 0 liftedTypeKind) in ForAllTy aTv (VarTy aTv) -- | The type @forall a. forall b. a -> b@ unsafeCoerceTy :: Type unsafeCoerceTy = let aNm = mkUnsafeSystemName "a" 0 aTv = TyVar aNm 0 liftedTypeKind bNm = mkUnsafeSystemName "b" 1 bTv = TyVar bNm 1 liftedTypeKind in ForAllTy aTv (ForAllTy bTv (mkFunTy (VarTy aTv) (VarTy bTv))) -- | Create a vector of supplied elements mkVec :: DataCon -- ^ The Nil constructor -> DataCon -- ^ The Cons (:>) constructor -> Type -- ^ Element type -> Integer -- ^ Length of the vector -> [Term] -- ^ Elements to put in the vector -> Term mkVec nilCon consCon resTy = go where go _ [] = mkApps (Data nilCon) [Right (LitTy (NumTy 0)) ,Right resTy ,Left (primCo nilCoTy) ] go n (x:xs) = mkApps (Data consCon) [Right (LitTy (NumTy n)) ,Right resTy ,Right (LitTy (NumTy (n-1))) ,Left (primCo (consCoTy n)) ,Left x ,Left (go (n-1) xs)] 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 -> Type -- ^ Element type -> Term -- ^ The vector to append the elements to -> Integer -- ^ Length of the vector -> [Term] -- ^ Elements to append -> Term appendToVec consCon resTy vec = go where go _ [] = vec go n (x:xs) = mkApps (Data consCon) [Right (LitTy (NumTy n)) ,Right resTy ,Right (LitTy (NumTy (n-1))) ,Left (primCo (consCoTy n)) ,Left x ,Left (go (n-1) xs)] 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 :: HasCallStack => Supply -- ^ Unique supply -> InScopeSet -- ^ (Superset of) in scope variables -> DataCon -- ^ The Cons (:>) constructor -> Type -- ^ The element type -> Char -- ^ Char to append to the bound variable names -> Integer -- ^ Length of the vector -> Term -- ^ The vector -> (Supply, NonEmpty (Term,NonEmpty (Id, Term))) extractElems supply inScope consCon resTy s maxN 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),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 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))) ,"_co_" ,"el" ,"rest" ] (resTy:restTy:idTys) 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)] 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 extractTElems :: Supply -- ^ Unique supply -> InScopeSet -- ^ (Superset of) in scope variables -> DataCon -- ^ The 'LR' constructor -> DataCon -- ^ The 'BR' constructor -> Type -- ^ The element type -> Char -- ^ Char to append to the bound variable names -> Integer -- ^ Depth of the tree -> Term -- ^ The tree -> (Supply,([Term],[(Id, Term)])) extractTElems supply inScope lrCon brCon resTy s maxN tree = first fst (go maxN [0..(2^(maxN+1))-2] [0..(2^maxN - 1)] (supply,inScope) tree) where go :: Integer -> [Int] -> [Int] -> (Supply,InScopeSet) -> Term -> ((Supply,InScopeSet),([Term],[(Id, Term)])) 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]) <- pure $ mapAccumR mkUniqSystemId uniqs0 $ zipEqual [ "el" `T.append` (s `T.cons` T.pack (show k)) , "_co_" , "el" ] (resTy:idTys) 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 = fromMaybe (error "extractTElems: failed to project elements") $ do let tys = [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))] idTys <- dataConInstArgTys brCon tys 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)) ,"_co_" ,"lt" ,"rt" ] (brTy:brTy:idTys) 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 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 -> Type -- ^ Element type -> Integer -- ^ Depth of the tree -> [Term] -- ^ Elements to put in the tree -> Term mkRTree lrCon brCon resTy = go where go _ [x] = mkApps (Data lrCon) [Right (LitTy (NumTy 0)) ,Right resTy ,Left (primCo lrCoTy) ,Left x ] go n xs = let (xsL,xsR) = splitAt (length xs `div` 2) xs in mkApps (Data brCon) [Right (LitTy (NumTy n)) ,Right resTy ,Right (LitTy (NumTy (n-1))) ,Left (primCo (brCoTy n)) ,Left (go (n-1) xsL) ,Left (go (n-1) xsR)] 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" -- -- It is i.e.: -- -- * Signal clk a -- * (Signal clk a, Signal clk b) -- * Vec n (Signal clk a) -- * data Wrap = W (Signal clk' Int) -- * etc. -- -- This also includes BiSignals, i.e.: -- -- * BiSignalIn High System Int -- * etc. -- isSignalType :: TyConMap -> Type -> Bool isSignalType tcm ty = go HashSet.empty ty where go tcSeen (tyView -> TyConApp tcNm args) = case nameOcc tcNm of "Clash.Signal.Internal.Signal" -> True "Clash.Signal.BiSignal.BiSignalIn" -> True "Clash.Signal.BiSignal.BiSignalOut" -> True _ | tcNm `HashSet.member` tcSeen -> False -- Do not follow rec types | otherwise -> case UniqMap.lookup tcNm tcm of Just tc -> let dcs = tyConDataCons tc dcInsArgTys = concat $ mapMaybe (`dataConInstArgTys` args) dcs tcSeen' = HashSet.insert tcNm tcSeen in any (go tcSeen') dcInsArgTys Nothing -> traceIf True ($(curLoc) ++ "isSignalType: " ++ show tcNm ++ " not found.") False go _ _ = False -- | Determines whether given type is an (alias of en) Enable line. isEnable :: TyConMap -> Type -> Bool isEnable m ty0 | TyConApp (nameOcc -> "Clash.Signal.Internal.Enable") _ <- tyView ty0 = True | Just ty1 <- coreView1 m ty0 = isEnable m ty1 isEnable _ _ = False -- | Determines whether given type is an (alias of en) Clock or Reset line isClockOrReset :: TyConMap -> Type -> Bool 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 tyNatSize :: TyConMap -> Type -> Except String Integer tyNatSize m (coreView1 m -> Just ty) = tyNatSize m ty tyNatSize _ (LitTy (NumTy i)) = return i tyNatSize _ ty = throwE $ $(curLoc) ++ "Cannot reduce to an integer:\n" ++ showPpr ty mkUniqSystemTyVar :: (Supply, InScopeSet) -> (OccName, Kind) -> ((Supply, InScopeSet), TyVar) mkUniqSystemTyVar (supply,inScope) (nm, ki) = ((supply',extendInScopeSet inScope v'), v') where (u,supply') = freshId supply v = mkTyVar ki (mkUnsafeSystemName nm u) v' = uniqAway inScope v mkUniqSystemId :: (Supply, InScopeSet) -> (OccName, Type) -> ((Supply,InScopeSet), Id) mkUniqSystemId (supply,inScope) (nm, ty) = ((supply',extendInScopeSet inScope v'), v') where (u,supply') = freshId supply v = mkLocalId ty (mkUnsafeSystemName nm u) v' = uniqAway inScope v mkUniqInternalId :: (Supply, InScopeSet) -> (OccName, Type) -> ((Supply,InScopeSet), Id) mkUniqInternalId (supply,inScope) (nm, ty) = ((supply',extendInScopeSet inScope v'), v') where (u,supply') = freshId supply v = mkLocalId ty (mkUnsafeInternalName nm u) v' = uniqAway inScope v -- | Same as @dataConInstArgTys@, but it tries to compute existentials too, -- hence the extra argument @TyConMap@. WARNING: It will return the types -- of non-existentials only dataConInstArgTysE :: HasCallStack => InScopeSet -> TyConMap -> DataCon -> [Type] -> Maybe [Type] dataConInstArgTysE is0 tcm (MkData { dcArgTys, dcExtTyVars, dcUnivTyVars }) inst_tys = do -- TODO: Check if all existentials were solved (they should be, or the wouldn't have -- TODO: been solved in the caseElemExistentials transformation) let is1 = extendInScopeSetList is0 dcExtTyVars is2 = unionInScope is1 (mkInScopeSet (freeVarsOf inst_tys)) subst = extendTvSubstList (mkSubst is2) (zipEqual dcUnivTyVars inst_tys) go (substGlobalsInExistentials is0 dcExtTyVars (zipEqual dcUnivTyVars inst_tys)) (map (substTy subst) dcArgTys) where exts = mkVarSet dcExtTyVars go :: [TyVar] -- ^ Existentials -> [Type] -- ^ Type arguments -> Maybe [Type] -- ^ Maybe ([type of non-existential]) go exts0 args0 = let eqs = catMaybes (map (typeEq tcm) args0) in case solveNonAbsurds tcm exts eqs of [] -> Just args0 sols -> go exts1 args1 where exts1 = substInExistentialsList is0 exts0 sols is2 = extendInScopeSetList is0 exts1 subst = extendTvSubstList (mkSubst is2) sols args1 = map (substTy subst) args0 -- | Given a DataCon and a list of types, the type variables of the DataCon -- type are substituted for the list of types. The argument types are returned. -- -- The list of types should be equal to the number of type variables, otherwise -- @Nothing@ is returned. dataConInstArgTys :: DataCon -> [Type] -> Maybe [Type] dataConInstArgTys (MkData { dcArgTys, dcUnivTyVars, dcExtTyVars }) inst_tys = -- TODO: Check if inst_tys do not contain any free variables on call sites. If -- TODO: they do, this function is unsafe to use. let tyvars = dcUnivTyVars ++ dcExtTyVars in if length tyvars == length inst_tys then Just (map (substTyWith tyvars inst_tys) dcArgTys) else Nothing -- | Make a coercion primCo :: Type -> Term primCo ty = Prim (PrimInfo "_CO_" ty WorkNever SingleResult NoUnfolding) -- | Make an unsafe coercion primUCo :: Term primUCo = Prim PrimInfo { primName = "GHC.Prim.unsafeCoerce#" , primType = unsafeCoerceTy , primWorkInfo = WorkNever , primMultiResult = SingleResult , primUnfolding = NoUnfolding } undefinedPrims :: [T.Text] undefinedPrims = [ "Clash.Normalize.Primitives.undefined" , "Control.Exception.Base.absentError" , "Control.Exception.Base.patError" , "GHC.Err.error" , "GHC.Err.errorWithoutStackTrace" , "GHC.Err.undefined" , "GHC.Prim.Panic.absentError" , "GHC.Real.divZeroError" , "GHC.Real.overflowError" , "GHC.Real.ratioZeroDenominatorError" , "GHC.Real.underflowError" ] undefinedXPrims :: [T.Text] undefinedXPrims = [ "Clash.Normalize.Primitives.undefinedX" , "Clash.XException.errorX" ] substArgTys :: DataCon -> [Type] -> [Type] substArgTys dc args = let univTVs = dcUnivTyVars dc extTVs = dcExtTyVars dc argsFVs = freeVarsOf args is = mkInScopeSet (argsFVs `unionVarSet` mkVarSet extTVs) -- See Note [The substitution invariant] subst = extendTvSubstList (mkSubst is) (univTVs `zipEqual` args) in map (substTy subst) (dcArgTys dc) -- | Try to reduce an arbitrary type to a literal type (Symbol or Nat), -- and subsequently extract its String representation tyLitShow :: TyConMap -> Type -> Except String String tyLitShow m (coreView1 m -> Just ty) = tyLitShow m ty tyLitShow _ (LitTy (SymTy s)) = return s tyLitShow _ (LitTy (NumTy s)) = return (show s) tyLitShow _ ty = throwE $ $(curLoc) ++ "Cannot reduce to a string:\n" ++ showPpr ty -- | Helper existential for 'shouldSplit', contains a function that: -- -- 1. given a term of a type that should be split, -- 2. creates projections of that term for all the constructor arguments data Projections where Projections :: (forall m . MonadUnique m => InScopeSet -> Term -> m [Term]) -> Projections -- | Determine whether we should split away types from a product type, i.e. -- clocks should always be separate arguments, and not part of a product. shouldSplit :: TyConMap -> Type -- ^ Type to examine -> Maybe ([Term] -> Term, Projections, [Type]) -- ^ If we want to split values of the given type then we have /Just/: -- -- 1. The (type-applied) data-constructor which, when applied to values of -- the types in 3., creates a value of the examined type -- -- 2. Function that give a term of the type we need to split, creates projections -- of that term for all the types in 3. -- -- 3. The arguments types of the product we are trying to split. -- -- Note that we only split one level at a time (although we check all the way -- down), e.g. given /(Int, (Clock, Bool))/ we return: -- -- > Just ( (,) @Int @(Clock, Bool) -- > , \s -> [case s of (a,b) -> a, case s of (a,b) -> b] -- > , [Int, (Clock, Bool)]) -- -- An outer loop is required to subsequently split the /(Clock, Bool)/ tuple. shouldSplit tcm (tyView -> TyConApp (nameOcc -> "Clash.Explicit.SimIO.SimIO") [tyArg]) = -- We also look through `SimIO` to find things like Files shouldSplit tcm tyArg shouldSplit tcm ty = shouldSplit0 tcm (tyView (coreView tcm ty)) -- | Worker of 'shouldSplit', works on 'TypeView' instead of 'Type' shouldSplit0 :: TyConMap -> TypeView -> Maybe ([Term] -> Term, Projections, [Type]) shouldSplit0 tcm (TyConApp tcNm tyArgs) | Just tc <- UniqMap.lookup tcNm tcm , [dc] <- tyConDataCons tc , let dcArgs = substArgTys dc tyArgs , let dcArgsLen = length dcArgs , dcArgsLen > 1 , let dcArgVs = map (tyView . coreView tcm) dcArgs = if any shouldSplitTy dcArgVs && not (isHidden tcNm tyArgs) then Just ( mkApps (Data dc) . (map Right tyArgs ++) . map Left , Projections (\is0 subj -> mapM (mkSelectorCase ($(curLoc) ++ "splitArg") is0 tcm subj 1) [0..dcArgsLen - 1]) , dcArgs ) else Nothing | "Clash.Sized.Vector.Vec" <- nameOcc tcNm , [nTy,argTy] <- tyArgs , Right n <- runExcept (tyNatSize tcm nTy) , n > 1 , Just tc <- UniqMap.lookup tcNm tcm , [nil,cons] <- tyConDataCons tc = if shouldSplitTy (tyView (coreView tcm argTy)) then Just ( mkVec nil cons argTy n , Projections (\is0 subj -> mapM (mkVecSelector is0 subj) [0..n-1]) , replicate (fromInteger n) argTy) else Nothing where -- Project the n'th value out of a vector -- -- >>> mkVecSelector subj 0 -- case subj of Cons x xs -> x -- -- >>> mkVecSelector subj 2 -- case (case (case subj of Cons x xs -> xs) of Cons x xs -> xs) of Cons x xs -> x mkVecSelector :: forall m . MonadUnique m => InScopeSet -> Term -> Integer -> m Term mkVecSelector is0 subj 0 = mkSelectorCase ($(curLoc) ++ "mkVecSelector") is0 tcm subj 2 1 mkVecSelector is0 subj !n = do subj1 <- mkSelectorCase ($(curLoc) ++ "mkVecSelector") is0 tcm subj 2 2 mkVecSelector is0 subj1 (n-1) shouldSplitTy :: TypeView -> Bool shouldSplitTy ty = isJust (shouldSplit0 tcm ty) || splitTy ty -- Hidden constructs (HiddenClock, HiddenReset, ..) don't need to be split -- because KnownDomain will be filtered anyway during netlist generation due -- 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 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 -- TODO: this in the future. -- isHidden :: Name a -> [Type] -> Bool isHidden nm [a1, a2] | TyConApp a2Nm _ <- tyView a2 = nameOcc nm == "GHC.Classes.(%,%)" && splitTy (tyView (stripIP a1)) && nameOcc a2Nm == "Clash.Signal.Internal.KnownDomain" isHidden _ _ = False 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 -- in a bitvector, so we need to make sure Clash -- splits them off , "Clash.Explicit.SimIO.File" , "GHC.IO.Handle.Types.Handle" ] splitTy _ = False shouldSplit0 _ _ = Nothing -- | Potentially split apart a list of function argument types. e.g. given: -- -- > [Int,(Clock,(Reset,Bool)),Char] -- -- we return -- -- > [Int,Clock,Reset,Bool,Char] -- -- But we would leave -- -- > [Int, (Bool,Int), Char] -- -- unchanged. splitShouldSplit :: TyConMap -> [Type] -> [Type] splitShouldSplit tcm = foldr go [] where go ty rest = case shouldSplit tcm ty of Just (_,_,tys) -> splitShouldSplit tcm tys ++ rest Nothing -> ty : rest -- | Strip implicit parameter wrappers (IP) stripIP :: Type -> Type stripIP t@(tyView -> TyConApp tcNm [_a1, a2]) = if nameUniq tcNm == getKey ipClassKey then a2 else t stripIP t = t -- | Do an inverse topological sorting of the let-bindings in a let-expression inverseTopSortLetBindings :: HasCallStack => [(Id, Term)] -> [(Id, Term)] inverseTopSortLetBindings bndrs0 = let (graph,nodeMap,_) = Graph.graphFromEdges (map (\(i,e) -> let fvs = fmap varUniq (Set.elems (Lens.setOf freeLocalIds e) ) in ((i,e),varUniq i,fvs)) bndrs0) nodes = postOrd graph bndrs1 = map ((\(x,_,_) -> x) . nodeMap) nodes in bndrs1 where postOrd :: Graph.Graph -> [Graph.Vertex] postOrd g = postorderF (Graph.dff g) [] postorderF :: Graph.Forest a -> [a] -> [a] postorderF ts = foldr (.) id (map postorder ts) postorder :: Graph.Tree a -> [a] -> [a] postorder (Graph.Node a ts) = postorderF ts . (a :) {-# SCC inverseTopSortLetBindings #-} -- | Group let-bindings into cyclic groups and acyclic individual bindings sccLetBindings :: HasCallStack => [(Id, Term)] -> [Graph.SCC (Id, Term)] sccLetBindings = Graph.stronglyConnComp . (map (\(i,e) -> let fvs = fmap varUniq (Set.elems (Lens.setOf freeLocalIds e) ) in ((i,e),varUniq i,fvs))) {-# SCC sccLetBindings #-} -- | Make a case-decomposition that extracts a field out of a (Sum-of-)Product type mkSelectorCase :: HasCallStack => MonadUnique m => String -- ^ Name of the caller of this function -> InScopeSet -> TyConMap -- ^ TyCon cache -> Term -- ^ Subject of the case-composition -> Int -- ^ n'th DataCon -> Int -- ^ n'th field -> m Term mkSelectorCase caller inScope tcm scrut dcI fieldI = go (inferCoreTypeOf tcm scrut) where go (coreView1 tcm -> Just ty') = go ty' go scrutTy@(tyView -> TyConApp tc args) = 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 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 wildBndrs <- mapM (mkWildValBinder inScope) fieldTys let ty = indexNote ($(curLoc) ++ "No DC field#: " ++ show fieldI) fieldTys fieldI selBndr <- mkInternalVar inScope "sel" ty let bndrs = take fieldI wildBndrs ++ [selBndr] ++ drop (fieldI+1) wildBndrs pat = DataPat dc (dcExtTyVars dc) bndrs retVal = Case scrut ty [ (pat, Var selBndr) ] 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 mkWildValBinder :: (MonadUnique m) => InScopeSet -> Type -> m Id mkWildValBinder is = mkInternalVar is "wild" -- | Make a new, unique, identifier mkInternalVar :: (MonadUnique m) => InScopeSet -> OccName -- ^ Name of the identifier -> KindOrType -> m Id mkInternalVar inScope name ty = do i <- getUniqueM let nm = mkUnsafeInternalName name i return (uniqAway inScope (mkLocalId ty nm)) clash-lib-1.8.1/src/Clash/Core/Var.hs0000644000000000000000000000646707346545000015362 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2017-2018, Google Inc. 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Variables in CoreHW -} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} module Clash.Core.Var ( Var (..) , IdScope (..) , Id , TyVar , mkId , mkLocalId , mkGlobalId , mkTyVar , setIdScope , modifyVarName , isGlobalId , isLocalId ) where import Control.DeepSeq (NFData (..)) import Data.Binary (Binary) import Data.Function (on) import Data.Hashable (Hashable(hashWithSalt)) import GHC.Generics (Generic) import Clash.Core.Name (Name (..)) import {-# SOURCE #-} Clash.Core.Term (Term, TmName) import {-# SOURCE #-} Clash.Core.Type (Kind, Type, TyName) import Clash.Unique -- | Variables in CoreHW data Var a -- | Constructor for type variables = TyVar { varName :: !(Name a) , varUniq :: {-# UNPACK #-} !Unique -- ^ Invariant: forall x . varUniq x ~ nameUniq (varName x) , varType :: Kind } -- | Constructor for term variables | Id { varName :: !(Name a) , varUniq :: {-# UNPACK #-} !Unique -- ^ Invariant: forall x . varUniq x ~ nameUniq (varName x) , varType :: Type , idScope :: IdScope } deriving (Show,Generic,NFData,Binary) -- | Gets a _key_ in the DBMS sense: a value that uniquely identifies a -- Var. In case of a "Var" that is its unique and (if applicable) scope varKey :: Var a -> (Unique, Maybe IdScope) varKey TyVar{varUniq} = (varUniq, Nothing) varKey Id{varUniq,idScope} = (varUniq, Just idScope) instance Hashable (Var a) where hashWithSalt salt a = hashWithSalt salt (varKey a) instance Eq (Var a) where (==) = (==) `on` varKey (/=) = (/=) `on` varKey instance Ord (Var a) where compare = compare `on` varKey instance Uniquable (Var a) where getUnique = varUniq setUnique var u = var {varUniq=u, varName=(varName var){nameUniq=u}} data IdScope = GlobalId | LocalId deriving (Show,Generic,NFData,Hashable,Binary,Eq,Ord) -- | Term variable type Id = Var Term -- | Type variable type TyVar = Var Type -- | Change the name of a variable modifyVarName :: (Name a -> Name a) -> Var a -> Var a modifyVarName f (TyVar n _ k) = let n' = f n in TyVar n' (nameUniq n') k modifyVarName f (Id n _ t s) = let n' = f n in Id n' (nameUniq n') t s -- | Make a type variable mkTyVar :: Kind -> TyName -> TyVar mkTyVar tyKind tyName = TyVar tyName (nameUniq tyName) tyKind -- | Make a term variable mkId :: Type -> IdScope -> TmName -> Id mkId tmType scope tmName = Id tmName (nameUniq tmName) tmType scope mkLocalId :: Type -> TmName -> Id mkLocalId tmType tmName = Id tmName (nameUniq tmName) tmType LocalId mkGlobalId :: Type -> TmName -> Id mkGlobalId tmType tmName = Id tmName (nameUniq tmName) tmType GlobalId isGlobalId :: Var a -> Bool isGlobalId (Id {idScope = GlobalId}) = True isGlobalId _ = False isLocalId :: Var a -> Bool isLocalId (Id {idScope = LocalId}) = True isLocalId _ = False setIdScope :: IdScope -> Var a -> Var a setIdScope s (Id nm u t _) = Id nm u t s setIdScope _ v = v clash-lib-1.8.1/src/Clash/Core/VarEnv.hs0000644000000000000000000003515007346545000016022 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Core.VarEnv ( -- * Environment with variables as keys VarEnv -- ** Accessors -- *** Size information , nullVarEnv -- ** Indexing , lookupVarEnv , lookupVarEnv' , lookupVarEnvDirectly -- ** Construction , emptyVarEnv , unitVarEnv , mkVarEnv -- ** Modification , extendVarEnv , extendVarEnvList , extendVarEnvWith , delVarEnv , delVarEnvList , unionVarEnv , unionVarEnvWith , differenceVarEnv -- ** Element-wise operations -- *** Mapping , mapVarEnv , mapMaybeVarEnv -- ** Folding , foldlWithUniqueVarEnv' -- ** Working with predicates -- *** Searching , elemVarEnv , notElemVarEnv -- ** Conversions -- *** Lists , eltsVarEnv -- * Sets of variables , VarSet -- ** Construction , emptyVarSet , unitVarSet -- ** Modification , delVarSetByKey , unionVarSet , differenceVarSet -- ** Working with predicates , nullVarSet -- *** Searching , elemVarSet , notElemVarSet , subsetVarSet , disjointVarSet -- ** Conversions -- *** Lists , mkVarSet , eltsVarSet -- * In-scope sets , InScopeSet -- ** Accessors -- *** Size information , emptyInScopeSet -- *** Indexing , lookupInScope -- ** Construction , mkInScopeSet -- ** Modification , extendInScopeSet , extendInScopeSetList , unionInScope -- ** Working with predicates -- *** Searching , elemInScopeSet , elemUniqInScopeSet , notElemInScopeSet , varSetInScope -- ** Unique generation , uniqAway , uniqAway' -- * Dual renaming , RnEnv -- ** Construction , mkRnEnv -- ** Renaming , rnTmBndr , rnTyBndr , rnTmBndrs , rnTyBndrs , rnOccLId , rnOccRId , rnOccLTy , rnOccRTy ) where import Control.DeepSeq (NFData) import Data.Binary (Binary) import Data.Coerce (coerce) import qualified Data.List as List import qualified Data.List.Extra as List import Data.Maybe (fromMaybe) #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter #else import Data.Text.Prettyprint.Doc #endif import GHC.Exts (Any) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) 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 import Clash.Pretty -- * VarEnv -- | Map indexed by variables type VarEnv a = UniqMap a -- | Empty map emptyVarEnv :: VarEnv a emptyVarEnv = UniqMap.empty -- | Environment containing a single variable-value pair unitVarEnv :: Var b -> a -> VarEnv a unitVarEnv = UniqMap.singleton -- | Look up a value based on the variable lookupVarEnv :: Var b -> VarEnv a -> Maybe a lookupVarEnv = UniqMap.lookup -- | Lookup a value based on the unique of a variable lookupVarEnvDirectly :: Unique -> VarEnv a -> Maybe a lookupVarEnvDirectly = UniqMap.lookup -- | Lookup a value based on the variable -- -- Errors out when the variable is not present lookupVarEnv' :: HasCallStack => VarEnv a -> Var b -> a lookupVarEnv' = flip UniqMap.find -- | Remove a variable-value pair from the environment delVarEnv :: VarEnv a -> Var b -> VarEnv a delVarEnv = flip UniqMap.delete -- | Remove a list of variable-value pairs from the environment delVarEnvList :: VarEnv a -> [Var b] -> VarEnv a delVarEnvList = flip UniqMap.deleteMany -- | Add a variable-value pair to the environment; overwrites the value if the -- variable already exists extendVarEnv :: Var b -> a -> VarEnv a -> VarEnv a 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 extendVarEnvWith :: Var b -> a -> (a -> a -> a) -> VarEnv a -> VarEnv a extendVarEnvWith k v f = UniqMap.insertWith f k v -- | Add a list of variable-value pairs; the values of existing keys will be -- overwritten extendVarEnvList :: VarEnv a -> [(Var b, a)] -> VarEnv a extendVarEnvList = flip UniqMap.insertMany -- | Is the environment empty nullVarEnv :: VarEnv a -> Bool nullVarEnv = UniqMap.null -- | Get the (left-biased) union of two environments unionVarEnv :: VarEnv a -> VarEnv a -> VarEnv a unionVarEnv = (<>) -- | Get the union of two environments, mapped values existing in both -- environments will be merged with the given function. unionVarEnvWith :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a 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 = UniqMap.fromList -- | Apply a function to every element in the environment mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b mapVarEnv = fmap -- | Apply a function to every element in the environment; values for which the -- function returns 'Nothing' are removed from the environment mapMaybeVarEnv :: (a -> Maybe b) -> VarEnv a -> VarEnv b mapMaybeVarEnv = UniqMap.mapMaybe -- | Strict left-fold over an environment using both the unique of the -- the variable and the value foldlWithUniqueVarEnv' :: (a -> Unique -> b -> a) -> a -> VarEnv b -> a foldlWithUniqueVarEnv' = UniqMap.foldlWithUnique' -- | Extract the elements eltsVarEnv :: VarEnv a -> [a] eltsVarEnv = UniqMap.elems -- | Does the variable exist in the environment elemVarEnv :: Var a -> VarEnv b -> Bool elemVarEnv = UniqMap.elem -- | Does the variable not exist in the environment notElemVarEnv :: Var a -> VarEnv b -> Bool notElemVarEnv = UniqMap.notElem -- * VarSet -- | Set of variables type VarSet = UniqMap (Var Any) -- | The empty set emptyVarSet :: VarSet emptyVarSet = UniqMap.empty -- | The set of a single variable unitVarSet :: Var a -> VarSet unitVarSet v = UniqMap.singletonUnique (coerce v) -- | Add a variable to the set extendVarSet :: VarSet -> Var a -> VarSet extendVarSet env v = UniqMap.insertUnique (coerce v) env -- | Union two sets unionVarSet :: VarSet -> VarSet -> VarSet unionVarSet = (<>) -- | Take the difference of two sets differenceVarSet :: VarSet -> VarSet -> VarSet differenceVarSet = UniqMap.difference -- | Is the variable an element in the set elemVarSet :: Var a -> VarSet -> Bool elemVarSet v = UniqMap.elem (getUnique v) -- | Is the variable not an element in the set notElemVarSet :: Var a -> VarSet -> Bool notElemVarSet v = UniqMap.notElem (getUnique v) -- | Is the set of variables A a subset of the variables B subsetVarSet :: VarSet -- ^ Set of variables A -> VarSet -- ^ Set of variables B -> Bool subsetVarSet = UniqMap.submap -- | Are the sets of variables disjoint disjointVarSet :: VarSet -> VarSet -> Bool disjointVarSet = UniqMap.disjoint -- | Check whether a varset is empty nullVarSet :: VarSet -> Bool nullVarSet = UniqMap.null -- | Look up a variable in the set, returns it if it exists lookupVarSet :: Var a -> VarSet -> Maybe (Var Any) lookupVarSet = UniqMap.lookup -- | Remove a variable from the set based on its 'Unique' delVarSetByKey :: Unique -> VarSet -> VarSet delVarSetByKey = UniqMap.delete -- | Create a set from a list of variables mkVarSet :: [Var a] -> VarSet mkVarSet xs = UniqMap.fromList $ fmap (\x -> (getUnique x, coerce x)) xs eltsVarSet :: VarSet -> [Var Any] eltsVarSet = UniqMap.elems -- * InScopeSet -- | Set of variables that is in scope at some point -- -- The 'Int' is a kind of hash-value used to generate new uniques. It should -- never be zero -- -- See "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 for the -- motivation data InScopeSet = InScopeSet VarSet {-# UNPACK #-} !Int deriving (Generic, NFData, Binary) instance ClashPretty InScopeSet where clashPretty (InScopeSet s _) = clashPretty s -- | The empty set extendInScopeSet :: InScopeSet -> Var a -> InScopeSet extendInScopeSet (InScopeSet inScope n) v = InScopeSet (extendVarSet inScope v) (n + 1) -- | Add a list of variables in scope extendInScopeSetList :: InScopeSet -> [Var a] -> InScopeSet extendInScopeSetList (InScopeSet inScope n) vs = InScopeSet (List.foldl' extendVarSet inScope vs) (n + length vs) -- | Union two sets of in scope variables unionInScope :: InScopeSet -> InScopeSet -> InScopeSet unionInScope (InScopeSet s1 _) (InScopeSet s2 n2) = InScopeSet (s1 `unionVarSet` s2) n2 -- | Is the set of variables in scope varSetInScope :: VarSet -> InScopeSet -> Bool varSetInScope vars (InScopeSet s1 _) = vars `subsetVarSet` s1 -- | Look up a variable in the 'InScopeSet'. This gives you the canonical -- version of the variable lookupInScope :: InScopeSet -> Var a -> Maybe (Var Any) lookupInScope (InScopeSet s _) v = lookupVarSet v s -- | Is the variable in scope elemInScopeSet :: Var a -> InScopeSet -> Bool elemInScopeSet v (InScopeSet s _) = elemVarSet v s -- | Check whether an element exists in the set based on the `Unique` contained -- in that element elemUniqInScopeSet :: Unique -> InScopeSet -> Bool elemUniqInScopeSet u (InScopeSet s _) = UniqMap.elem u s -- | Is the variable not in scope notElemInScopeSet :: Var a -> InScopeSet -> Bool notElemInScopeSet v (InScopeSet s _) = notElemVarSet v s -- | Create a set of variables in scope mkInScopeSet :: VarSet -> InScopeSet mkInScopeSet is = InScopeSet is 1 -- | The empty set emptyInScopeSet :: InScopeSet emptyInScopeSet = mkInScopeSet emptyVarSet -- | Ensure that the 'Unique' of a variable does not occur in the 'InScopeSet' uniqAway :: (Uniquable a, ClashPretty a) => InScopeSet -> a -> a uniqAway (InScopeSet set n) a = uniqAway' (`UniqMap.elem` set) n a uniqAway' :: (Uniquable a, ClashPretty a) => (Unique -> Bool) -- ^ Unique in scope test -> Int -- ^ Seed -> a -> a uniqAway' inScopeTest n u = if inScopeTest (getUnique u) then try 1 else u where origUniq = getUnique u try k | debugIsOn && k > 1000 = pprPanic "uniqAway loop:" msg | inScopeTest uniq = try (k + 1) | k > 3 = pprTraceDebug "uniqAway:" msg (setUnique u uniq) | otherwise = setUnique u uniq where msg = fromPretty k <+> "tries" <+> clashPretty u <+> fromPretty n uniq = deriveUnique origUniq (n * k) deriveUnique :: Unique -> Int -> Unique deriveUnique i delta = i + delta -- * RnEnv -- | Rename environment for e.g. alpha equivalence -- -- When going under binders for e.g. -- -- @ -- \x -> e1 `aeq` \y -> e2 -- @ -- -- We want to rename @[x -> y]@ or @[y -> x]@, but we have to pick a binder -- that is neither free in @e1@ nor @e2@ or we risk accidental capture. -- -- So we must maintain: -- -- 1. A renaming for the left term -- -- 2. A renaming for the right term -- -- 3. A set of in scope variables data RnEnv = RnEnv { rn_envLTy :: VarEnv TyVar -- ^ Type renaming for the left term , rn_envLTm :: VarEnv Id -- ^ Term renaming for the left term , rn_envRTy :: VarEnv TyVar -- ^ Type renaming for the right term , rn_envRTm :: VarEnv Id -- ^ Term renaming for the right term , rn_inScope :: InScopeSet -- ^ In scope in left or right terms } -- | Create an empty renaming environment mkRnEnv :: InScopeSet -> RnEnv mkRnEnv vars = RnEnv { rn_envLTy = emptyVarEnv , rn_envLTm = emptyVarEnv , rn_envRTy = emptyVarEnv , rn_envRTm = emptyVarEnv , rn_inScope = vars } -- | Look up the renaming of an type-variable occurrence in the left term rnOccLTy :: RnEnv -> TyVar -> TyVar rnOccLTy rn v = fromMaybe v (lookupVarEnv v (rn_envLTy rn)) -- | Look up the renaming of an type-variable occurrence in the right term rnOccRTy :: RnEnv -> TyVar -> TyVar rnOccRTy rn v = fromMaybe v (lookupVarEnv v (rn_envRTy rn)) -- | Simultaneously go under the type-variable binder /bTvL/ and type-variable -- binder /bTvR/, finds a new binder /newTvB/, and return an environment mapping -- @[bTvL -> newB]@ and @[bTvR -> newB]@ rnTyBndr :: RnEnv -> TyVar -> TyVar -> RnEnv rnTyBndr rv@(RnEnv {rn_envLTy = lenv, rn_envRTy = renv, rn_inScope = inScope}) bL bR = rv { rn_envLTy = extendVarEnv bL newB lenv -- See Note [Rebinding and shadowing] , rn_envRTy = extendVarEnv bR newB renv , rn_inScope = extendInScopeSet inScope newB } where -- Find a new type-binder not in scope in either term newB | not (bL `elemInScopeSet` inScope) = bL | not (bR `elemInScopeSet` inScope) = bR | otherwise = uniqAway inScope bL {- Note [Rebinding and shadowing] Imagine: @ \x -> \x -> e1 `aeq` \y -> \x -> e2 @ Then inside @ \x \y { [x->p] [y->p] {p} } \x \z { [x->q] [y->p, z->q] {p,q} } @ i.e. if the new var is the same as the old var, the renaming is deleted by 'extendVarEnv' -} -- | Applies 'rnTyBndr' to several variables: the two variable lists must be of -- equal length. rnTyBndrs :: RnEnv -> [TyVar] -> [TyVar] -> RnEnv rnTyBndrs env tvs1 tvs2 = List.foldl' (\s (l,r) -> rnTyBndr s l r) env (List.zipEqual tvs1 tvs2) -- | Look up the renaming of an occurrence in the left term rnOccLId :: RnEnv -> Id -> Id rnOccLId rn v = fromMaybe v (lookupVarEnv v (rn_envLTm rn)) -- | Look up the renaming of an occurrence in the left term rnOccRId :: RnEnv -> Id -> Id rnOccRId rn v = fromMaybe v (lookupVarEnv v (rn_envRTm rn)) -- | Simultaneously go under the binder /bL/ and binder /bR/, finds a new binder -- /newTvB/, and return an environment mapping @[bL -> newB]@ and @[bR -> newB]@ rnTmBndr :: RnEnv -> Id -> Id -> RnEnv rnTmBndr rv@(RnEnv {rn_envLTm = lenv, rn_envRTm = renv, rn_inScope = inScope}) bL bR = rv { rn_envLTm = extendVarEnv bL newB lenv -- See Note [Rebinding and shadowing] , rn_envRTm = extendVarEnv bR newB renv , rn_inScope = extendInScopeSet inScope newB } where -- Find a new type-binder not in scope in either term newB | not (bL `elemInScopeSet` inScope) = bL | not (bR `elemInScopeSet` inScope) = bR | otherwise = uniqAway inScope bL -- | Applies 'rnTmBndr' to several variables: the two variable lists must be of -- equal length. rnTmBndrs :: RnEnv -> [Id] -> [Id] -> RnEnv rnTmBndrs env ids1 ids2 = List.foldl' (\s (l,r) -> rnTmBndr s l r) env (List.zipEqual ids1 ids2) clash-lib-1.8.1/src/Clash/Data/0000755000000000000000000000000007346545000014242 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Data/UniqMap.hs0000644000000000000000000001641107346545000016153 0ustar0000000000000000{- 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 clash-lib-1.8.1/src/Clash/DataFiles.hs0000644000000000000000000000455107346545000015566 0ustar0000000000000000{-| 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" clash-lib-1.8.1/src/Clash/Debug.hs0000644000000000000000000000057307346545000014760 0ustar0000000000000000{-# LANGUAGE CPP #-} module Clash.Debug ( debugIsOn , traceIf , module Debug.Trace ) where import Debug.Trace debugIsOn :: Bool #if defined(DEBUG) debugIsOn = True #else debugIsOn = False #endif -- | Performs trace when first argument evaluates to 'True' traceIf :: Bool -> String -> a -> a traceIf True msg = trace msg traceIf False _ = id {-# INLINE traceIf #-} clash-lib-1.8.1/src/Clash/Driver.hs0000644000000000000000000012521607346545000015167 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017 , QBayLogic, Google Inc. 2020-2023, QBayLogic, 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Module that connects all the parts of the Clash compiler library -} {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Clash.Driver where import Control.Concurrent (MVar, modifyMVar, modifyMVar_, newMVar, withMVar) import Control.Concurrent.Async (mapConcurrently_) import qualified Control.Concurrent.Supply as Supply import Control.DeepSeq import Control.Exception (throw) import qualified Control.Monad as Monad import Control.Monad (unless, foldM, forM, filterM) import Control.Monad.Catch (MonadMask) import Control.Monad.Extra (whenM, ifM, unlessM) import Control.Monad.IO.Class (MonadIO) import Control.Monad.State (evalState, get) 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, second) import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as ByteStringLazy import qualified Data.ByteString.Lazy.Char8 as ByteStringLazyChar8 import Data.Char (isAscii, isAlphaNum) import Data.Default import Data.Hashable (hash) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap 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 () import Data.Monoid (Ap(..)) import qualified Data.Text import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as Text import Data.Text.Lazy.Encoding as Text import qualified Data.Text.Lazy.IO as Text #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter (pretty) #else import Data.Text.Prettyprint.Doc (pretty) #endif import Data.Text.Prettyprint.Doc.Extra (Doc, LayoutOptions (..), PageWidth (..) , layoutPretty, renderLazy) import qualified Data.Time.Clock as Clock import GHC.Stack (HasCallStack) import qualified Language.Haskell.Interpreter as Hint import qualified Language.Haskell.Interpreter.Extension as Hint import qualified Language.Haskell.Interpreter.Unsafe as Hint import qualified System.Directory as Directory import System.Directory (doesPathExist, listDirectory, doesDirectoryExist, createDirectoryIfMissing, removeDirectoryRecursive, doesFileExist) import System.Environment (getExecutablePath) import System.FilePath ((), (<.>), takeDirectory, takeFileName, isAbsolute) import qualified System.FilePath as FilePath import qualified System.IO as IO import System.IO.Temp (getCanonicalTemporaryDirectory, withTempDirectory) import Text.Trifecta.Result (Result(Success, Failure), _errDoc) #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names (eqTyConKey, ipClassKey) import GHC.Types.Unique (getKey) import GHC.Types.SrcLoc (SrcSpan) #else import PrelNames (eqTyConKey, ipClassKey) import Unique (getKey) import SrcLoc (SrcSpan) #endif import GHC.BasicTypes.Extra () import Clash.Annotations.Primitive (HDL (..)) import Clash.Annotations.BitRepresentation.Internal (CustomReprs) import Clash.Annotations.TopEntity (TopEntity (..), PortName(PortName, PortProduct)) import Clash.Annotations.TopEntity.Extra () import Clash.Backend import Clash.Core.PartialEval as PE (Evaluator) import Clash.Core.Evaluator.Types as WHNF (Evaluator) import Clash.Core.HasType import Clash.Core.Name (Name (..)) import Clash.Core.Pretty (PrettyOptions(..), showPpr') import Clash.Core.Type (Type(ForAllTy, LitTy, AnnType), TypeView(..), tyView, mkFunTy, LitTy(SymTy)) import Clash.Core.TyCon (TyConMap) import Clash.Core.Util (shouldSplit) import Clash.Core.Var (Id, varName, varUniq, varType) import Clash.Core.VarEnv (elemVarEnv, emptyVarEnv, lookupVarEnv, lookupVarEnv', mkVarEnv, lookupVarEnvDirectly, eltsVarEnv, VarEnv) import Clash.Debug (debugIsOn) import Clash.Driver.Types import Clash.Driver.Manifest (Manifest(..), readFreshManifest, UnexpectedModification, pprintUnexpectedModifications, mkManifest, writeManifest, manifestFilename) import Clash.Edalize.Edam import Clash.Netlist (genNetlist, genTopNames) import Clash.Netlist.BlackBox.Parser (runParse) import Clash.Netlist.BlackBox.Types (BlackBoxTemplate, BlackBoxFunction) import qualified Clash.Netlist.Id as Id import Clash.Netlist.Types (IdentifierText, BlackBox (..), Component (..), FilteredHWType, HWMap, SomeBackend (..), TopEntityT(..), TemplateFunction, ComponentMap, findClocks, ComponentMeta(..)) import Clash.Normalize (checkNonRecursive, cleanupGraph, normalize, runNormalization) import Clash.Normalize.Util (callGraph, tvSubstWithTyEq) import qualified Clash.Primitives.Sized.Signed as P import qualified Clash.Primitives.Sized.ToInteger as P import qualified Clash.Primitives.Sized.Vector as P 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) import Clash.Util (ClashException(..), reportTimeDiff, wantedLanguageExtensions, unwantedLanguageExtensions, curLoc) import Clash.Util.Graph (reverseTopSort) import qualified Clash.Util.Interpolate as I -- | Worker function of 'splitTopEntityT' splitTopAnn :: TyConMap -> SrcSpan -- ^ Source location of top entity (for error reporting) -> Type -- ^ Top entity body -> TopEntity -- ^ Port annotations for top entity -> TopEntity -- ^ New top entity with split ports (or the old one if not applicable) splitTopAnn tcm sp typ@(tyView -> FunTy {}) t@Synthesize{t_inputs} = t{t_inputs=go typ t_inputs} where go :: Type -> [PortName] -> [PortName] go _ [] = [] go (tyView -> FunTy a res) (p:ps) | shouldNotHavePortName a -- Insert dummy PortName for args for which the user shouldn't have -- to provide a name. -- Ideally this would be any (non Hidden{Clock,Reset,Enable}) constraint. -- But because we can't properly detect constraints, -- we only skip some specific one. see "shouldNotHavePortName" = PortName "" : go res (p:ps) | otherwise = case shouldSplit tcm a of Just (_,_,argTys@(_:_:_)) -> -- Port must be split up into 'n' pieces.. can it? case p of PortProduct nm portNames0 -> let n = length argTys newPortNames = map (PortName . show) [(0::Int)..] portNames1 = map (prependName nm) (portNames0 ++ newPortNames) newLam = foldr1 mkFunTy (argTys ++ [res]) in go newLam (take n portNames1 ++ ps) PortName nm -> throw (flip (ClashException sp) Nothing $ [I.i| Couldn't separate clock, reset, or enable from a product type due to a malformed Synthesize annotation. All clocks, resets, and enables should be given a unique port name. Type to be split: #{showPpr' (PrettyOptions False True False False) a} Given port annotation: #{p}. You might want to use the following instead: PortProduct #{show nm} []. This allows Clash to autogenerate names based on the name #{show nm}. |]) _ -> -- No need to split the port, carrying on.. p : go res ps go (ForAllTy _tyVar ty) ps = go ty ps go _ty ps = ps prependName :: String -> PortName -> PortName prependName "" pn = pn prependName p (PortProduct nm ps) = PortProduct (p ++ "_" ++ nm) ps prependName p (PortName nm) = PortName (p ++ "_" ++ nm) -- Returns True for -- * type equality constraints (~) -- * HasCallStack shouldNotHavePortName :: Type -> Bool shouldNotHavePortName (tyView -> TyConApp (nameUniq -> tcUniq) tcArgs) | tcUniq == getKey eqTyConKey = True | tcUniq == getKey ipClassKey , [LitTy (SymTy "callStack"), _] <- tcArgs = True shouldNotHavePortName _ = False splitTopAnn tcm sp (ForAllTy _tyVar typ) t = splitTopAnn tcm sp typ t splitTopAnn tcm sp (AnnType _anns typ) t = splitTopAnn tcm sp typ t splitTopAnn _tcm _sp _typ t = t -- When splitting up a single argument into multiple arguments (see docs of -- 'separateArguments') we should make sure to update TopEntity annotations -- accordingly. See: https://github.com/clash-lang/clash-compiler/issues/1033 splitTopEntityT :: HasCallStack => TyConMap -> BindingMap -> TopEntityT -> TopEntityT splitTopEntityT tcm bindingsMap tt@(TopEntityT id_ (Just t@(Synthesize {})) _) = case lookupVarEnv id_ bindingsMap of Just (Binding _id sp _ _ _ _) -> tt{topAnnotation=Just (splitTopAnn tcm sp (coreTypeOf id_) t)} Nothing -> error "Internal error in 'splitTopEntityT'. Please report as a bug." splitTopEntityT _ _ t = t -- | Remove constraints such as 'a ~ 3'. removeForAll :: TopEntityT -> TopEntityT removeForAll (TopEntityT var annM isTb) = TopEntityT var{varType=tvSubstWithTyEq (coreTypeOf var)} annM isTb -- | Given a list of all found top entities and _maybe_ a top entity (+dependencies) -- passed in by '-main-is', return the list of top entities Clash needs to -- compile. selectTopEntities :: [TopEntityT] -> Maybe (TopEntityT, [TopEntityT]) -> [TopEntityT] selectTopEntities topEntities mainTopEntity = maybe topEntities (uncurry (:)) mainTopEntity -- | Get modification data of current clash binary. getClashModificationDate :: IO Clock.UTCTime getClashModificationDate = Directory.getModificationTime =<< getExecutablePath hdlFromBackend :: forall backend. Backend backend => Proxy backend -> HDL hdlFromBackend _ = hdlKind (undefined :: backend) replaceChar :: Char -> Char -> String -> String replaceChar a b = map go where go c | c == a = b | otherwise = c removeHistoryFile :: Maybe FilePath -> IO () removeHistoryFile = maybe (pure ()) removeHistory where removeHistory path = whenM (Directory.doesFileExist path) (Directory.removeFile path) prefixModuleName :: HDL -> Maybe Data.Text.Text -> Maybe TopEntity -> String -> (String, Maybe String) prefixModuleName hdl compPrefix annM modName = case compPrefix of Just (Data.Text.unpack -> p) | not (null p) -> case annM of Just ann -> let nm = p <> "_" <> t_name ann in (nm, Just nm) Nothing -> (p <> "_" <> modName, Just p) | Just ann <- annM -> case hdl of VHDL -> (t_name ann, Just modName) _ -> (t_name ann, Nothing) _ -> case annM of Just ann -> case hdl of VHDL -> (t_name ann, Just modName) _ -> (t_name ann, Just modName) _ -> (modName, Nothing) -- | Create a set of target HDL files for a set of functions generateHDL :: forall backend . Backend backend => ClashEnv -> ClashDesign -> Maybe backend -> (CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))) -- ^ Hardcoded 'Type' -> 'HWType' translator -> PE.Evaluator -- ^ Hardcoded evaluator for partial evaluation -> WHNF.Evaluator -- ^ Hardcoded evaluator for WHNF (old evaluator) -> Maybe (TopEntityT, [TopEntityT]) -- ^ 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 let bindingsMap = designBindings design let tcm = envTyConMap env let topEntities0 = designEntities design let opts = envOpts env removeHistoryFile (dbg_historyFile (opt_debug opts)) unless (opt_cachehdl opts) $ putStrLn "Clash: Ignoring previously made caches" let topEntities1 = fmap (removeForAll . splitTopEntityT tcm bindingsMap) (selectTopEntities topEntities0 mainTopEntity) hdl = hdlFromBackend (Proxy @backend) (compNames, initIs) = genTopNames opts hdl topEntities1 (tes, deps) = sortTop bindingsMap topEntities1 -- TODO This is here because of some minimal effort refactoring. At some -- point generateHDL should be better laid out so this can be closer to -- the few places it is needed. let topEntityMap = mkVarEnv (fmap (\x -> (topId x, x)) topEntities1) -- Data which is updated and used when updating the different top entities -- is kept in an MVar. idSet <- newMVar initIs edamFiles <- newMVar HashMap.empty ioLock <- newMVar () mapConcurrently_ (go compNames idSet edamFiles ioLock deps topEntityMap) tes time <- Clock.getCurrentTime let diff = reportTimeDiff time startTime putStrLn $ "Clash: Total compilation took " ++ diff where go :: VarEnv Id.Identifier -> MVar Id.IdentifierSet -> MVar (HashMap Unique [EdamFile]) -> MVar () -> HashMap Unique [Unique] -> VarEnv TopEntityT -> TopEntityT -> IO () go compNames seenV edamFilesV ioLockV deps topEntityMap (TopEntityT topEntity annM isTb) = do let domainConfs = envDomains env let bindingsMap = designBindings design let primMap = envPrimitives env let topEntities0 = designEntities design let opts = envOpts env prevTime <- Clock.getCurrentTime let topEntityS = Data.Text.unpack (nameOcc (varName topEntity)) withMVar ioLockV . const $ putStrLn ("Clash: Compiling " ++ topEntityS) let modName1 = filter (\c -> isAscii c && (isAlphaNum c || c == '_')) (replaceChar '.' '_' topEntityS) modifyMVar_ seenV $ \seen -> pure $! State.execState (Id.addRaw (Data.Text.pack modName1)) seen let topNm = lookupVarEnv' compNames topEntity (modNameS, fmap Data.Text.pack -> prefixM) = prefixModuleName (hdlKind (undefined :: backend)) (opt_componentPrefix opts) annM modName1 modNameT = Data.Text.pack modNameS hdlState' = setDomainConfigurations domainConfs $ setModName modNameT $ setTopName topNm $ fromMaybe (initBackend @backend opts) hdlState hdlDir = fromMaybe (Clash.Backend.name hdlState') (opt_hdlDir opts) topEntityS manPath = hdlDir manifestFilename ite = ifThenElseExpr hdlState' topNmT = Id.toText topNm -- Get manifest file if cache is not stale and caching is enabled. This is used -- to prevent unnecessary recompilation. clashModDate <- getClashModificationDate (userModifications, maybeManifest, topHash) <- readFreshManifest topEntities0 (bindingsMap, topEntity) primMap opts clashModDate manPath let topEntityNames = map topId (eltsVarEnv topEntityMap) case maybeManifest of Just manifest0@Manifest{fileNames} | Just [] <- userModifications -> do -- Found a 'manifest' files. Use it to extend "seen" set. Generate EDAM -- files if necessary. withMVar ioLockV . const $ putStrLn ("Clash: Using cached result for: " ++ topEntityS) modifyMVar_ seenV $ \seen -> pure $! State.execState (mapM_ Id.addRaw (componentNames manifest0)) seen fileNames1 <- modifyMVar edamFilesV $ \edamFiles -> if opt_edalize opts then writeEdam hdlDir (topNm, varUniq topEntity) deps edamFiles fileNames else pure (edamFiles, fileNames) -- If we are generating (System)Verilog, we could potentially verilate -- the results. Clash can output a C++ shim for doing this automatically. fileNames2 <- case hdlFromBackend (Proxy @backend) of VHDL -> pure fileNames1 _ -> writeVerilatorShim hdlDir topNm fileNames1 writeManifest manPath manifest0{fileNames=fileNames2} topTime <- Clock.getCurrentTime let topDiff = reportTimeDiff topTime prevTime withMVar ioLockV . const $ putStrLn ("Clash: Compiling " ++ topEntityS ++ " took " ++ topDiff) return () _ -> do -- 1. Prepare HDL directory -- -- [Note] Create HDL dir before netlist generation -- -- Already create the directory where the HDL ends up being generated, as -- we use directories relative to this final directory to find manifest -- files belonging to other top entities. Failing to do so leads to #463 prepareDir hdlDir opts userModifications -- 2. Normalize topEntity supplyN <- Supply.newSupply transformedBindings <- normalizeEntity env bindingsMap typeTrans peEval eval topEntityNames supplyN topEntity normTime <- transformedBindings `deepseq` Clock.getCurrentTime let prepNormDiff = reportTimeDiff normTime prevTime withMVar ioLockV . const $ putStrLn ("Clash: Normalization took " ++ prepNormDiff) -- 3. Generate netlist for topEntity (topComponent, netlist) <- modifyMVar seenV $ \seen -> do (topComponent, netlist, seen') <- -- TODO My word, this has far too many arguments. genNetlist env isTb transformedBindings topEntityMap compNames typeTrans ite (SomeBackend hdlState') seen hdlDir prefixM topEntity pure (seen', (topComponent, netlist)) netlistTime <- netlist `deepseq` Clock.getCurrentTime let normNetDiff = reportTimeDiff netlistTime normTime withMVar ioLockV . const $ putStrLn ("Clash: Netlist generation took " ++ normNetDiff) -- 4. Generate topEntity wrapper (hdlDocs, dfiles, mfiles) <- withMVar seenV $ \seen -> 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 hdlDocDigests <- mapM (writeHDL hdlDir) hdlDocs dataFilesDigests <- copyDataFiles (opt_importPaths opts) hdlDir dfiles memoryFilesDigests <- writeMemoryDataFiles hdlDir mfiles let components = map (snd . snd) (OMap.assocs netlist) filesAndDigests0 = -- 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 hdlDocs) hdlDocDigests filesAndDigests1 <- modifyMVar edamFilesV $ \edamFiles -> if opt_edalize opts then writeEdam hdlDir (topNm, varUniq topEntity) deps edamFiles filesAndDigests0 else pure (edamFiles, filesAndDigests0) filesAndDigests2 <- case hdlFromBackend (Proxy @backend) of VHDL -> pure filesAndDigests1 _ -> writeVerilatorShim hdlDir topNm filesAndDigests1 let depUniques = fromMaybe [] (HashMap.lookup (getUnique topEntity) deps) depBindings = mapMaybe (flip lookupVarEnvDirectly bindingsMap) depUniques depIds = map bindingId depBindings manifest = mkManifest hdlState' domainConfs opts topComponent components depIds filesAndDigests2 topHash writeManifest manPath manifest topTime <- hdlDocs `seq` Clock.getCurrentTime let topDiff = reportTimeDiff topTime prevTime withMVar ioLockV . const $ putStrLn ("Clash: Compiling " ++ topEntityS ++ " took " ++ topDiff) -- | Interpret a specific function from a specific module. This action tries -- two things: -- -- 1. Interpret without explicitly loading the module. This will succeed if -- the module was already loaded through a package database (set using -- 'interpreterArgs'). -- -- 2. If (1) fails, it does try to load it explicitly. If this also fails, -- an error is returned. -- loadImportAndInterpret :: (MonadIO m, MonadMask m) => [String] -- ^ Extra search path (usually passed as -i) -> [String] -- ^ Interpreter args -> String -- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.) -- can be found -> Hint.ModuleName -- ^ Module function lives in -> String -- ^ Function name -> String -- ^ Type name ('BlackBoxFunction' or 'TemplateFunction') -> m (Either Hint.InterpreterError a) loadImportAndInterpret iPaths0 interpreterArgs topDir qualMod funcName typ = do Hint.liftIO $ Monad.when debugIsOn $ putStr "Hint: Interpreting " >> putStrLn (qualMod ++ "." ++ funcName) -- Try to interpret function *without* loading module explicitly. If this -- succeeds, the module was already in the global package database(s). bbfE <- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do iPaths1 <- (++iPaths0) <$> Hint.get Hint.searchPath Hint.set [Hint.searchPath Hint.:= iPaths1] Hint.setImports [ "Clash.Netlist.Types", "Clash.Netlist.BlackBox.Types", qualMod] Hint.unsafeInterpret funcName typ case bbfE of Left _ -> do -- Try to interpret module as a local module, not yet present in the -- global package database(s). Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do Hint.reset iPaths1 <- (iPaths0++) <$> Hint.get Hint.searchPath Hint.set [ Hint.searchPath Hint.:= iPaths1 , Hint.languageExtensions Hint.:= langExts] Hint.loadModules [qualMod] Hint.setImports [ "Clash.Netlist.BlackBox.Types", "Clash.Netlist.Types", qualMod] Hint.unsafeInterpret funcName typ Right _ -> do return bbfE where langExts = map Hint.asExtension $ map show wantedLanguageExtensions ++ map ("No" ++ ) (map show unwantedLanguageExtensions) -- | List of known BlackBoxFunctions used to prevent Hint from firing. This -- improves Clash startup times. knownBlackBoxFunctions :: HashMap String BlackBoxFunction knownBlackBoxFunctions = HashMap.fromList $ map (first show) $ [ ('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) , ('P.indexToIntegerVHDL, P.indexToIntegerVHDL) , ('P.intTF, P.intTF) , ('P.iterateBBF, P.iterateBBF) , ('P.signedToIntegerVerilog, P.signedToIntegerVerilog) , ('P.signedToIntegerVHDL, P.signedToIntegerVHDL) , ('P.unsignedToIntegerVerilog, P.unsignedToIntegerVerilog) , ('P.unsignedToIntegerVHDL, P.unsignedToIntegerVHDL) , ('P.wordTF, P.wordTF) ] -- | List of known TemplateFunctions used to prevent Hint from firing. This -- improves Clash startup times. knownTemplateFunctions :: HashMap String TemplateFunction knownTemplateFunctions = HashMap.fromList $ map (first show) $ [ ('P.altpllQsysTF, P.altpllQsysTF) , ('P.alteraPllQsysTF, P.alteraPllQsysTF) , ('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. compilePrimitive :: [FilePath] -- ^ Import directories (-i flag) -> [FilePath] -- ^ Package databases -> FilePath -- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.) -- can be found -> ResolvedPrimitive -- ^ Primitive to compile -> IO CompiledPrimitive compilePrimitive idirs pkgDbs topDir (BlackBoxHaskell bbName wf usedArgs multiRes bbGenName source) = do bbFunc <- -- TODO: Use cache for hint targets. Right now Hint will fire multiple times -- TODO: if multiple functions use the same blackbox haskell function. case HashMap.lookup fullName knownBlackBoxFunctions of Just f -> pure f Nothing -> do Monad.when debugIsOn (putStr "Hint: interpreting " >> putStrLn (show fullName)) let interpreterArgs = concatMap (("-package-db":) . (:[])) pkgDbs -- Compile a blackbox template function or fetch it from an already compiled file. r <- go interpreterArgs source processHintError (show bbGenName) bbName id r pure (BlackBoxHaskell bbName wf usedArgs multiRes bbGenName (hash source, bbFunc)) where fullName = qualMod ++ "." ++ funcName qualMod = intercalate "." modNames BlackBoxFunctionName modNames funcName = bbGenName -- | Create directory based on base name and directory. Return path -- of directory just created. createDirectory' :: FilePath -> FilePath -> IO FilePath createDirectory' base sub = let new = base sub in Directory.createDirectory new >> return new go :: [String] -> Maybe Text -> IO (Either Hint.InterpreterError BlackBoxFunction) go args (Just source') = do -- Create a temporary directory with user module in it, add it to the -- list of import direcotries, and run as if it were a "normal" compiled -- module. tmpDir0 <- getCanonicalTemporaryDirectory withTempDirectory tmpDir0 "clash-prim-compile" $ \tmpDir1 -> do modDir <- foldM createDirectory' tmpDir1 (init modNames) Text.writeFile (modDir (last modNames ++ ".hs")) source' loadImportAndInterpret (tmpDir1:idirs) args topDir qualMod funcName "BlackBoxFunction" go args Nothing = do loadImportAndInterpret idirs args topDir qualMod funcName "BlackBoxFunction" compilePrimitive idirs pkgDbs topDir (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 () outputUsage libM' imps' fPlural incs' rM' riM' templ') where iArgs = concatMap (("-package-db":) . (:[])) pkgDbs parseTempl :: Applicative m => Text -> m BlackBoxTemplate parseTempl t = case runParse t of Failure errInfo -> error ("Parsing template for blackbox " ++ Data.Text.unpack pNm ++ " failed:\n" ++ show (_errDoc errInfo)) Success t' -> pure t' parseBB :: ((TemplateFormat,BlackBoxFunctionName), Maybe Text) -> IO BlackBox parseBB ((TTemplate,_),Just t) = BBTemplate <$> parseTempl t parseBB ((TTemplate,_),Nothing) = error ("No template specified for blackbox: " ++ show pNm) parseBB ((THaskell,bbGenName),Just source) = do let BlackBoxFunctionName modNames funcName = bbGenName qualMod = intercalate "." modNames tmpDir <- getCanonicalTemporaryDirectory r <- withTempDirectory tmpDir "clash-prim-compile" $ \tmpDir' -> do let modDir = foldl () tmpDir' (init modNames) Directory.createDirectoryIfMissing True modDir Text.writeFile (modDir last modNames <.> "hs") source loadImportAndInterpret (tmpDir':idirs) iArgs topDir qualMod funcName "TemplateFunction" let hsh = hash (qualMod, source) processHintError (show bbGenName) pNm (BBFunction (Data.Text.unpack pNm) hsh) r parseBB ((THaskell,bbGenName),Nothing) = do let BlackBoxFunctionName modNames funcName = bbGenName qualMod = intercalate "." modNames hsh = hash qualMod fullName = qualMod ++ "." ++ funcName tf <- case HashMap.lookup fullName knownTemplateFunctions of Just f -> pure f Nothing -> do r <- loadImportAndInterpret idirs iArgs topDir qualMod funcName "TemplateFunction" processHintError (show bbGenName) pNm id r pure (BBFunction (Data.Text.unpack pNm) hsh tf) compilePrimitive _ _ _ (Primitive pNm wf typ) = return (Primitive pNm wf typ) {-# SCC compilePrimitive #-} processHintError :: Monad m => String -> Data.Text.Text -> (t -> r) -> Either Hint.InterpreterError t -> m r processHintError fun bb go r = case r of Left (Hint.GhcException err) -> error' "GHC Exception" err Left (Hint.NotAllowed err) -> error' "NotAllowed error" err Left (Hint.UnknownError err) -> error' "an unknown error" err Left (Hint.WontCompile ghcErrs) -> error' "compilation errors" (intercalate "\n\n" $ map Hint.errMsg ghcErrs) Right f -> return $ go f where error' errType report = error $ unwords [ "Encountered", errType, "while compiling blackbox template" , "function", show fun, "for function", show bb ++ "." , "Compilation reported: \n\n" ++ report ] -- | Pretty print Components to HDL Documents createHDL :: Backend backend => backend -- ^ Backend -> ClashOpts -- ^ Global Clash options -> IdentifierText -- ^ Module hierarchy root -> Id.IdentifierSet -- ^ Component names -> ComponentMap -- ^ List of components -> HashMap Data.Text.Text VDomainConfiguration -- ^ Known domains to configurations -> Component -- ^ Top component -> IdentifierText -- ^ Name of the manifest file -> ([(String,Doc)],[(String,FilePath)],[(String,String)]) -- ^ The pretty-printed HDL documents -- + The data files that need to be copied createHDL backend opts modName seen components domainConfs top topName = flip evalState backend $ getAp $ do let componentsL = map snd (OMap.assocs components) (hdlNmDocs0,incs) <- fmap unzip $ forM componentsL $ \(ComponentMeta{cmLoc, cmScope,cmUsage}, comp) -> genHDL opts modName cmLoc (Id.union seen cmScope) cmUsage comp hwtys <- HashSet.toList <$> extractTypes <$> Ap get typesPkg0 <- mkTyPackage modName hwtys dataFiles <- Ap getDataFiles memFiles <- Ap getMemoryDataFiles let 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 sdcFile = Data.Text.unpack topName <.> "sdc" sdcDoc = (sdcFile, pprSDC (SdcInfo sdcInfo)) sdc = if null sdcInfo then Nothing else Just sdcDoc return (maybeToList sdc <> topFiles, dataFiles, memFiles) where findDomainConfig dom = HashMap.lookupDefault (error $ $(curLoc) ++ "Unknown synthesis domain: " ++ show dom) dom domainConfs writeVerilatorShim :: FilePath -> Id.Identifier -> [(FilePath, ByteString)] -> IO [(FilePath, ByteString)] writeVerilatorShim hdlDir topNm filesAndDigests = do let file = Data.Text.unpack (Id.toText topNm) <> "_shim" <.> "cpp" digest <- writeHDL hdlDir (file, pprVerilatorShim topNm) pure ((file, digest) : filesAndDigests) -- | Create a shim for using verilator, which loads the entity and steps -- through simulation until finished. -- pprVerilatorShim :: Id.Identifier -> Doc pprVerilatorShim (Id.toText -> topNm) = -- Extra newlines are aggressively inserted so the quasiquoter doesn't wrap -- the outlines lines in the file. It doesn't matter for code inside main, -- but is fatal for the #include directives. pretty $ Data.Text.pack [I.i| \#include \#include \#include "V#{topNm}.h" int main(int argc, char **argv) { Verilated::commandArgs(argc, argv); V#{topNm} *top = new V#{topNm}; while(!Verilated::gotFinish()) { top->eval(); } top->final(); delete top; return EXIT_SUCCESS; } |] writeEdam :: FilePath -> (Id.Identifier, Unique) -> HashMap Unique [Unique] -> HashMap Unique [EdamFile] -> [(FilePath, ByteString)] -> IO (HashMap Unique [EdamFile], [(FilePath, ByteString)]) writeEdam hdlDir (topNm, topEntity) deps edamFiles0 filesAndDigests = do let (edamFiles1, edamInfo) = createEDAM (topNm, topEntity) deps edamFiles0 (map fst filesAndDigests) edamDigest <- writeHDL hdlDir ("edam.py", pprEdam edamInfo) pure (edamFiles1, ("edam.py", edamDigest) : filesAndDigests) -- | Create an Edalize metadata file for using Edalize to build the project. -- -- TODO: Handle libraries. Also see: https://github.com/olofk/edalize/issues/220 createEDAM :: -- Top entity name and unique (Id.Identifier, Unique) -> -- | Top entity dependency map HashMap Unique [Unique] -> -- | Edam files of each top entity HashMap Unique [EdamFile] -> -- | Files to include in Edam file [FilePath] -> -- | (updated map, edam) (HashMap Unique [EdamFile], Edam) createEDAM (topName, topUnique) deps edamFileMap files = (HashMap.insert topUnique (edamFiles edam) edamFileMap, edam) where edam = Edam { edamProjectName = Id.toText topName , edamTopEntity = Id.toText topName , edamFiles = fmap (asEdamFile topName) files <> fmap asIncFile incFiles , edamToolOptions = def } incFiles = concatMap (\u -> HashMap.lookupDefault [] u edamFileMap) (HashMap.lookupDefault [] topUnique deps) asIncFile f = f { efName = ".." Data.Text.unpack (efLogicalName f) efName f } asEdamFile :: Id.Identifier -> FilePath -> EdamFile asEdamFile topName path = EdamFile path edamFileType (Id.toText topName) where edamFileType = case FilePath.takeExtension path of ".vhdl" -> VhdlSource ".v" -> VerilogSource ".sv" -> SystemVerilogSource ".tcl" -> TclSource ".qsys" -> QSYS ".sdc" -> SDC _ -> Clash.Edalize.Edam.Unknown -- | Prepares directory for writing HDL files. prepareDir :: -- | HDL directory to prepare FilePath -> -- | Relevant options: @-fclash-no-clean@ ClashOpts -> -- | Did directory contain unexpected modifications? See 'readFreshManifest' Maybe [UnexpectedModification] -> IO () prepareDir hdlDir ClashOpts{opt_clear} mods = do ifM (doesPathExist hdlDir) (ifM (doesDirectoryExist hdlDir) (detectCaseIssues >> clearOrError >> createDir) (error [I.i|Tried to write HDL files to #{hdlDir}, but it wasn't a directory.|])) createDir where createDir = createDirectoryIfMissing True hdlDir -- Windows considers 'foo' and 'FOO' the same directory. Error if users tries -- to synthesize two top entities with conflicting (in this sense) names. detectCaseIssues = do allPaths <- listDirectory (takeDirectory hdlDir) unless (takeFileName hdlDir `elem` allPaths) (error [I.i| OS indicated #{hdlDir} existed, but Clash could not find it among the list of existing directories in #{takeDirectory hdlDir}: #{allPaths} This probably means your OS or filesystem is case-insensitive. Rename your top level binders in order to prevent this error message. |]) clearOrError = case mods of Just [] -> -- No unexpected changes, so no user work will get lost removeDirectoryRecursive hdlDir _ | opt_clear -> -- Unexpected changes / non-empty directory, but @-fclash-clear@ was -- set, so remove directory anyway. removeDirectoryRecursive hdlDir Just unexpected -> -- Unexpected changes; i.e. modifications were made after last Clash run error [I.i| Changes were made to #{hdlDir} after last Clash run: #{pprintUnexpectedModifications 5 unexpected} Use '-fclash-clear' if you want Clash to clear out the directory. Warning: this will remove the complete directory, be cautious of data loss. |] Nothing -> -- No manifest file was found. Refuse to write if directory isn't empty. unlessM (null <$> listDirectory hdlDir) (error [I.i| Tried to write HDL files to #{hdlDir}, but directory wasn't empty. This message will be supressed if Clash can detect that no files have changed since it was last run. If you're seeing this message even though you haven't modified any files, Clash encountered a problem reading "#{manifestFilename :: String}". This can happen when upgrading Clash. Use '-fclash-clear' if you want Clash to clear out the directory. Warning: this will remove the complete directory, be cautious of data loss. |]) -- | Write a file to disk in chunks. Returns SHA256 sum of file contents. writeAndHash :: FilePath -> ByteStringLazy.ByteString -> IO ByteString writeAndHash path bs = IO.withFile path IO.WriteMode $ \handle -> fmap Sha256.finalize $ foldM (writeChunk handle) Sha256.init $ ByteStringLazy.toChunks bs where writeChunk :: IO.Handle -> Sha256.Ctx -> ByteString -> IO Sha256.Ctx writeChunk h !ctx chunk = do ByteString.hPut h chunk pure (Sha256.update ctx chunk) -- | Writes a HDL file to the given directory. Returns SHA256 hash of written -- file. writeHDL :: FilePath -> (FilePath, Doc) -> IO ByteString writeHDL dir (cname, hdl) = do let layout = LayoutOptions (AvailablePerLine 120 0.4) rendered0 = renderLazy (layoutPretty layout hdl) rendered1 = Text.unlines (map Text.stripEnd (Text.lines rendered0)) writeAndHash (dir cname) (Text.encodeUtf8 (rendered1 <> "\n")) -- | Copy given files writeMemoryDataFiles :: FilePath -- ^ Directory to copy files to -> [(FilePath, String)] -- ^ (filename, content) -> IO [ByteString] writeMemoryDataFiles dir files = forM files $ \(fname, content) -> writeAndHash (dir fname) (ByteStringLazyChar8.pack content) -- | Copy data files added with ~FILE copyDataFiles :: [FilePath] -- ^ Import directories passed in with @-i@ -> FilePath -- ^ Directory to copy to -> [(FilePath,FilePath)] -- ^ [(name of newly made file in HDL output dir, file to copy)] -> IO [ByteString] -- ^ SHA256 hashes of written files copyDataFiles idirs targetDir = mapM copyDataFile where copyDataFile :: (FilePath, FilePath) -> IO ByteString copyDataFile (newName, toCopy) | isAbsolute toCopy = do ifM (doesFileExist toCopy) (copyAndHash toCopy (targetDir newName)) (error [I.i|Could not find data file #{show toCopy}. Does it exist?|]) | otherwise = do let candidates = map ( toCopy) idirs found <- filterM doesFileExist candidates case found of [] -> error [I.i| Could not find data file #{show toCopy}. The following directories were searched: #{idirs} You can add directories Clash will look in using `-i`. |] (_:_:_) -> error [I.i| Multiple data files for #{show toCopy} found. The following candidates were found: #{found} Please disambiguate data files. |] [c] -> copyAndHash c (targetDir newName) copyAndHash src dst = do ifM (doesPathExist dst) (error [I.i| Tried to copy data file #{src} to #{dst} but a file or directory with that name already existed. This is a bug in Clash, please report it. |]) (ByteStringLazy.readFile src >>= writeAndHash dst) -- | Normalize a complete hierarchy normalizeEntity :: ClashEnv -> BindingMap -- ^ All bindings -> (CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))) -- ^ Hardcoded 'Type' -> 'HWType' translator -> PE.Evaluator -- ^ Hardcoded evaluator for partial evaluation -> WHNF.Evaluator -- ^ Hardcoded evaluator for WHNF (old evaluator) -> [Id] -- ^ TopEntities -> Supply.Supply -- ^ Unique supply -> Id -- ^ root of the hierarchy -> IO BindingMap normalizeEntity env bindingsMap typeTrans peEval eval topEntities supply tm = transformedBindings where doNorm = do norm <- normalize [tm] let normChecked = checkNonRecursive norm cleaned <- cleanupGraph tm normChecked return cleaned transformedBindings = runNormalization env supply bindingsMap typeTrans peEval eval emptyVarEnv topEntities doNorm -- | 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 = case reverseTopSort nodes edges of Left msg -> error msg Right tops -> (tops, mapFrom tops) where nodes = [(varUniq topE, t) | t@(TopEntityT topE _ _) <- topEntities] edges = concatMap getEdges topEntities getEdges (TopEntityT topE _ _) = map (\top -> (varUniq topE, topToUnique top)) (getTransitiveRefs topE) 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 clash-lib-1.8.1/src/Clash/Driver/0000755000000000000000000000000007346545000014624 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Driver/Manifest.hs0000644000000000000000000004303407346545000016732 0ustar0000000000000000{-| Copyright : (C) 2021-2023, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Functions to read, write, and handle manifest files. -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Driver.Manifest where import Control.Exception (tryJust) import Control.Monad (guard, forM) import Control.Monad.State (evalState) import qualified Crypto.Hash.SHA256 as Sha256 import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson import Data.Aeson (ToJSON(toJSON), FromJSON(parseJSON), KeyValue ((.=)), (.:), (.:?)) import Data.Aeson.Types (Parser) import qualified Data.Binary as Binary import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as ByteStringLazy import Data.ByteString (ByteString) import Data.Char (toLower) #if MIN_VERSION_base16_bytestring(1,0,0) import Data.Either (fromRight) #endif import Data.Hashable (hash) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Maybe (catMaybes) import Data.Monoid (Ap(getAp)) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as LText import qualified Data.Text.Lazy.Encoding as LText import Data.Text (Text) import Data.Text.Prettyprint.Doc.Extra (renderOneLine) import Data.Time (UTCTime) import qualified Data.Set as Set import Data.String (IsString) import GHC.Generics (Generic) import System.IO.Error (isDoesNotExistError) import System.FilePath (takeDirectory, ()) import System.Directory (listDirectory, doesFileExist) import Text.Read (readMaybe) import Clash.Annotations.TopEntity.Extra () import Clash.Backend (Backend (hdlType), Usage (External)) import Clash.Core.Name (nameOcc) import Clash.Driver.Types import Clash.Primitives.Types import Clash.Core.Var (Id, varName) import Clash.Netlist.Types (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) import Clash.Primitives.Util (hashCompiledPrimMap) import Clash.Signal (VDomainConfiguration(..)) import Clash.Util.Graph (callGraphBindings) #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(..)) #endif data PortDirection = In | Out | InOut deriving (Generic, Eq, Read, Show) instance ToJSON PortDirection where toJSON = Aeson.genericToJSON Aeson.defaultOptions { Aeson.constructorTagModifier = fmap toLower } instance FromJSON PortDirection where parseJSON = Aeson.genericParseJSON Aeson.defaultOptions { Aeson.constructorTagModifier = fmap toLower } data ManifestPort = ManifestPort { mpName :: Text -- ^ Port name (as rendered in HDL) , mpTypeName :: Text -- ^ Type name (as rendered in HDL) , mpDirection :: PortDirection -- ^ Port direction (in / out / inout) , mpWidth :: Int -- ^ Port width in bits , mpIsClock :: Bool -- ^ Is this port a clock? , mpDomain :: Maybe Text -- ^ Domain this port belongs to. This is currently only included for clock, -- reset, and enable ports. TODO: add to all ports originally defined as a -- @Signal@ too. } deriving (Show,Read,Eq) instance ToJSON ManifestPort where toJSON (ManifestPort{..}) = Aeson.object $ [ "name" .= mpName , "type_name" .= mpTypeName , "direction" .= mpDirection , "width" .= mpWidth , "is_clock" .= mpIsClock ] <> (case mpDomain of Just dom -> ["domain" .= dom] Nothing -> [] ) instance FromJSON ManifestPort where parseJSON = Aeson.withObject "ManifestPort" $ \v -> ManifestPort <$> v .: "name" <*> v .: "type_name" <*> v .: "direction" <*> v .: "width" <*> v .: "is_clock" <*> v .:? "domain" -- | Just the 'fileNames' part of 'Manifest' newtype FilesManifest = FilesManifest [(FilePath, ByteString)] instance FromJSON FilesManifest where parseJSON = Aeson.withObject "FilesManifest" $ fmap FilesManifest . parseFiles -- | Information about the generated HDL between (sub)runs of the compiler data Manifest = Manifest { manifestHash :: ByteString -- ^ Hash digest of the TopEntity and all its dependencies. , successFlags :: (Int, Int) -- ^ Compiler flags used to achieve successful compilation: -- -- * opt_inlineLimit -- * opt_specLimit , ports :: [ManifestPort] -- ^ Ports in the generated @TopEntity@. , componentNames :: [Text] -- ^ Names of all the generated components for the @TopEntity@ (does not -- include the names of the components of the @TestBench@ accompanying -- the @TopEntity@). -- -- This list is reverse topologically sorted. I.e., a component might depend -- on any component listed before it, but not after it. , topComponent :: Text -- ^ Design entry point. This is usually the component annotated with a -- @TopEntity@ annotation. , fileNames :: [(FilePath, ByteString)] -- ^ Names and hashes of all the generated files for the @TopEntity@. Hashes -- are SHA256. -- -- This list is reverse topologically sorted. I.e., a component might depend -- on any component listed before it, but not after it. , domains :: HashMap Text VDomainConfiguration -- ^ Domains encountered in design , transitiveDependencies :: [Text] -- ^ Dependencies of this design (fully qualified binder names). Is a -- transitive closure of all dependencies. -- -- 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 toJSON (Manifest{..}) = Aeson.object [ "version" .= ("unstable" :: Text) , "hash" .= toHexDigest manifestHash , "flags" .= successFlags -- TODO: add nested ports (i.e., how Clash split/filtered arguments) , "components" .= componentNames , "top_component" .= Aeson.object [ "name" .= topComponent , "ports_flat" .= ports ] , "files" .= [ Aeson.object [ "name" .= fName , "sha256" .= toHexDigest fHash -- TODO: Add Edam like fields ] | (fName, fHash) <- fileNames] , "domains" .= HashMap.fromList [ ( domNm , Aeson.object [ "period" .= vPeriod , "active_edge" .= show vActiveEdge , "reset_kind" .= show vResetKind , "init_behavior" .= show vInitBehavior , "reset_polarity" .= show vResetPolarity ] ) | (domNm, VDomainConfiguration{..}) <- HashMap.toList domains ] , "dependencies" .= Aeson.object [ "transitive" .= transitiveDependencies ] ] -- Note [Failed hex digest decodes] -- -- 'unsafeFromHexDigest' may fail to decode a hex digest if it contains characters -- outside of [a-fA-F0-9]. In this case, it will return a broken digest. Because -- this module discards any data covered by the broken digest if it does not match -- a freshly calculated one, this poses no problem. -- | Decode a hex digest to a ByteString. Returns a broken digest if the decode -- fails - hence it being marked as unsafe. unsafeFromHexDigest :: Text -> ByteString unsafeFromHexDigest = #if MIN_VERSION_base16_bytestring(1,0,0) fromRight "failed decode" . Base16.decode . Text.encodeUtf8 #else fst . Base16.decode . Text.encodeUtf8 #endif -- | Encode a ByteString to a hex digest. toHexDigest :: ByteString -> Text toHexDigest = Text.decodeUtf8 . Base16.encode -- | Parse @files@ part of a Manifest file parseFiles :: Aeson.Object -> Parser [(FilePath, ByteString)] parseFiles v = do files <- v .: "files" forM files $ \obj -> do fName <- obj .: "name" sha256 <- obj .: "sha256" -- See Note [Failed hex digest decodes] pure (fName, unsafeFromHexDigest sha256) instance FromJSON Manifest where parseJSON = Aeson.withObject "Manifest" $ \v -> let topComponent = v .: "top_component" in Manifest -- See Note [Failed hex digest decodes] <$> (unsafeFromHexDigest <$> v .: "hash") <*> v .: "flags" <*> (topComponent >>= (.: "ports_flat")) <*> v .: "components" <*> (topComponent >>= (.: "name")) <*> parseFiles v <*> (v .: "domains" >>= HashMap.traverseWithKey parseDomain) <*> (v .: "dependencies" >>= (.: "transitive")) where parseDomain :: Text -> Aeson.Object -> Parser VDomainConfiguration parseDomain nm v = VDomainConfiguration <$> pure (Text.unpack nm) <*> (v .: "period") <*> parseWithRead "active_edge" v <*> parseWithRead "reset_kind" v <*> parseWithRead "init_behavior" v <*> parseWithRead "reset_polarity" v parseWithRead field obj = do v <- obj .:? field case readMaybe =<< v of Just a -> pure a Nothing -> fail $ "Could not read field: " <> show field data UnexpectedModification -- | Clash generated file was modified = Modified FilePath -- | Non-clash generated file was added | Added FilePath -- | Clash generated file was removed | Removed FilePath deriving (Show) mkManifestPort :: Backend backend => -- | Backend used to lookup port type names backend -> -- | Port name Id.Identifier -> -- | Port type HWType -> PortDirection -> ManifestPort mkManifestPort backend portId portType portDir = ManifestPort{..} where mpName = Id.toText portId mpWidth = typeSize portType mpDirection = portDir 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 -- | Filename manifest file should be written to and read from manifestFilename :: IsString a => a manifestFilename = "clash-manifest.json" mkManifest :: Backend backend => -- | Backend used to lookup port type names backend -> -- | Domains encountered in design HashMap Text VDomainConfiguration -> -- | Options Clash was run with ClashOpts -> -- | Component of top entity Component -> -- | All other entities [Component] -> -- | Names of dependencies (transitive closure) [Id] -> -- | Files and their hashes [(FilePath, ByteString)] -> -- | Hash returned by 'readFreshManifest' ByteString -> -- | New manifest Manifest mkManifest backend domains ClashOpts{..} Component{..} components deps files topHash = Manifest { manifestHash = topHash , ports = inPorts <> inOutPorts <> outPorts , componentNames = map Id.toText compNames , topComponent = Id.toText componentName , fileNames = files , successFlags = (opt_inlineLimit, opt_specLimit) , domains = domains , transitiveDependencies = map (nameOcc . varName) deps } where compNames = map Netlist.componentName components inPorts = [mkManifestPort backend pName pType In | p@(pName, pType) <- inputs, not (Netlist.isBiDirectional p)] inOutPorts = [mkManifestPort backend pName pType InOut | p@(pName, pType) <- inputs, Netlist.isBiDirectional p] outPorts = [mkManifestPort backend pName pType Out | (_, (pName, pType), _) <- outputs] -- | Pretty print an unexpected modification as a list item. pprintUnexpectedModification :: UnexpectedModification -> String pprintUnexpectedModification = \case Modified p -> "Unexpected modification in " <> p Added p -> "Unexpected extra file " <> p Removed p -> "Unexpected removed file " <> p -- | Pretty print a list of unexpected modifications. Print a maximum of /n/ -- modifications. pprintUnexpectedModifications :: Int -> [UnexpectedModification] -> String pprintUnexpectedModifications 0 us = pprintUnexpectedModifications maxBound us pprintUnexpectedModifications _ [] = [] pprintUnexpectedModifications _ [u] = "* " <> pprintUnexpectedModification u pprintUnexpectedModifications 1 (u:us) = "* and " <> show (length (u:us)) <> " more unexpected changes" pprintUnexpectedModifications n (u:us) = "* " <> pprintUnexpectedModification u <> "\n" <> pprintUnexpectedModifications (n-1) us -- | Reads a manifest file. Does not return manifest file if: -- -- * Caching is disabled through @-fclash-no-cache@. -- * Manifest could not be found. -- * Cache is stale. This could be triggered by any of the given arguments. -- -- Raises an exception if the manifest file or any of the files it is referring -- to was inaccessible. -- readFreshManifest :: -- | "This" top entity plus all that depend on it. [TopEntityT] -> -- | Core expressions and entry point. Any changes in the call graph will -- trigger a recompile. (BindingMap, Id) -> -- | Any changes in any primitive will trigger a recompile. CompiledPrimMap -> -- | Certain options will trigger recompiles if changed ClashOpts -> -- | Clash modification date UTCTime -> -- | Path to manifest file. FilePath -> -- | ( Nothing if no manifest file was found -- , Nothing on stale cache, disabled cache, or not manifest file found ) IO (Maybe [UnexpectedModification], Maybe Manifest, ByteString) readFreshManifest tops (bindingsMap, topId) primMap opts@(ClashOpts{..}) clashModDate path = do modificationsM <- traverse (isUserModified path) =<< readManifest path manifestM <- readManifest path pure ( modificationsM , checkManifest =<< if opt_cachehdl then manifestM else Nothing , topHash ) where optsHash = hash opts { -- Ignore the following settings, they don't affect the generated HDL: -- 1. Debug opt_debug = opt_debug { dbg_invariants = False , dbg_transformations = Set.empty , dbg_historyFile = Nothing } -- 2. Caching , opt_cachehdl = True -- 3. Warnings , opt_primWarn = True , opt_color = Auto , opt_errorExtra = False , opt_checkIDir = True -- 4. Optional output , opt_edalize = False -- Ignore the following settings, they don't affect the generated HDL. However, -- they do influence whether HDL can be generated at all. -- -- We therefore check whether the new flags changed in such a way that -- they could affect successful compilation, and use that information -- to decide whether to use caching or not (see: XXXX). -- -- 5. termination measures , opt_inlineLimit = 20 , opt_specLimit = 20 -- Finally, also ignore the HDL dir setting, because when a user moves the -- entire dir with generated HDL, they probably still want to use that as -- a cache , opt_hdlDir = Nothing } -- TODO: Binary encoding does not account for alpha equivalence (nor should -- it?), so the cache behaves more pessimisticly than it could. topHash = Sha256.hashlazy $ Binary.encode ( tops , hashCompiledPrimMap primMap , show clashModDate , callGraphBindings bindingsMap topId , optsHash ) checkManifest manifest@Manifest{manifestHash,successFlags} | (cachedInline, cachedSpec) <- successFlags -- Higher limits shouldn't affect HDL , cachedInline <= opt_inlineLimit , cachedSpec <= opt_specLimit -- Callgraph hashes should correspond , manifestHash == topHash = Just manifest -- One or more checks failed | otherwise = Nothing -- | Determines whether the HDL directory the given 'LocatedManifest' was found -- in contains any user made modifications. This is used by Clash to protect the -- user against lost work. isUserModified :: FilePath -> FilesManifest -> IO [UnexpectedModification] isUserModified (takeDirectory -> topDir) (FilesManifest fileNames) = do let manifestFiles = Set.fromList (map fst fileNames) currentFiles <- (Set.delete manifestFilename . Set.fromList) <$> listDirectory topDir let removedFiles = Set.toList (manifestFiles `Set.difference` currentFiles) addedFiles = Set.toList (currentFiles `Set.difference` manifestFiles) changedFiles <- catMaybes <$> mapM detectModification fileNames pure ( map Removed removedFiles <> map Added addedFiles <> map Modified changedFiles ) where detectModification :: (FilePath, ByteString) -> IO (Maybe FilePath) detectModification (filename, manifestDigest) = do let fullPath = topDir filename fileExists <- doesFileExist fullPath if fileExists then do contents <- ByteStringLazy.readFile fullPath if manifestDigest == Sha256.hashlazy contents then pure Nothing else pure (Just filename) else -- Will be caught by @removedFiles@ pure Nothing -- | Read a manifest file from disk. Returns 'Nothing' if file does not exist. -- Any other IO exception is re-raised. readManifest :: FromJSON a => FilePath -> IO (Maybe a) readManifest path = do contentsE <- tryJust (guard . isDoesNotExistError) (Aeson.decodeFileStrict path) pure (either (const Nothing) id contentsE) -- | Write manifest file to disk writeManifest :: FilePath -> Manifest -> IO () writeManifest path = ByteStringLazy.writeFile path . Aeson.encodePretty -- | Serialize a manifest. -- -- TODO: This should really yield a 'ByteString'. serializeManifest :: Manifest -> Text serializeManifest = LText.toStrict . LText.decodeUtf8 . Aeson.encodePretty clash-lib-1.8.1/src/Clash/Driver/Types.hs0000644000000000000000000005234407346545000016274 0ustar0000000000000000{-| Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017 , QBayLogic, Google Inc., 2020-2022, QBayLogic, 2022 , Google Inc., License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Type definitions used by the Driver module -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Clash.Driver.Types where -- For Int/Word size #include "MachDeps.h" import Control.DeepSeq (NFData(rnf), deepseq) import Data.Binary (Binary) import Data.Fixed import Data.Hashable import Data.HashMap.Strict (HashMap) import Data.IntMap.Strict (IntMap) import Data.Maybe (isJust) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text (dropAround) #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter #else import Data.Text.Prettyprint.Doc #endif import GHC.Generics (Generic) #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) import SrcLoc (SrcSpan) import Util (OverridingBool(..)) #endif 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) import Clash.Core.VarEnv (VarEnv) import Clash.Netlist.BlackBox.Types (HdlSyn (..)) import {-# SOURCE #-} Clash.Netlist.Types (PreserveCase(..), TopEntityT) import Clash.Primitives.Types (CompiledPrimMap) data ClashEnv = ClashEnv { envOpts :: ClashOpts , envTyConMap :: TyConMap , envTupleTyCons :: IntMap TyConName , envPrimitives :: CompiledPrimMap , envCustomReprs :: CustomReprs , envDomains :: DomainMap } deriving (Generic, NFData) data ClashDesign = ClashDesign { designEntities :: [TopEntityT] , designBindings :: BindingMap } instance NFData ClashDesign where rnf design = designEntities design `seq` designBindings design `deepseq` () data IsPrim = IsPrim -- ^ The binding is the unfolding for a primitive. | IsFun -- ^ The binding is an ordinary function. deriving (Binary, Eq, Generic, NFData, Show) -- A function binder in the global environment. -- data Binding a = Binding { bindingId :: Id -- ^ The core identifier for this binding. , bindingLoc :: SrcSpan -- ^ The source location of this binding in the original source code. , bindingSpec :: InlineSpec -- ^ the inline specification for this binding, in the original source code. , bindingIsPrim :: IsPrim -- ^ Is the binding a core term corresponding to a primitive with a known -- implementation? If so, it can potentially be inlined despite being -- marked as NOINLINE in source. , bindingTerm :: a -- ^ The term representation for this binding. This is polymorphic so -- alternate representations can be used if more appropriate (i.e. in the -- evaluator this can be Value for evaluated bindings). , bindingRecursive :: Bool -- ^ Whether the binding is recursive. -- -- TODO Ideally the BindingMap would store recursive and non-recursive -- bindings in a way similar to Let / Letrec. GHC also does this. } deriving (Binary, Functor, Generic, NFData, Show) -- | Global function binders -- -- Global functions cannot be mutually recursive, only self-recursive. type BindingMap = VarEnv (Binding Term) type DomainMap = HashMap Text VDomainConfiguration -- | Information to show about transformations during compilation. -- -- __NB__: The @Ord@ instance compares by amount of information. data TransformationInfo = None -- ^ Show no information about transformations. | FinalTerm -- ^ Show the final term after all applied transformations. | AppliedName -- ^ Show the name of every transformation that is applied. | AppliedTerm -- ^ Show the name and result of every transformation that is applied. | TryName -- ^ Show the name of every transformation that is attempted, and the result -- of every transformation that is applied. | TryTerm -- ^ Show the name and input to every transformation that is applied, and -- the result of every transformation that is applied. deriving (Eq, Generic, Hashable, Ord, Read, Show, NFData) -- | Options related to debugging. See 'ClashOpts' data DebugOpts = DebugOpts { dbg_invariants :: Bool -- ^ Check that the results of applied transformations do not violate the -- invariants for rewriting (e.g. no accidental shadowing, or type changes). -- -- Command line flag: -fclash-debug-invariants , dbg_transformationInfo :: TransformationInfo -- ^ The information to show when debugging a transformation. See the -- 'TransformationInfo' type for different configurations. -- -- Command line flag: -fclash-debug-info (None|FinalTerm|AppliedName|AppliedTerm|TryName|TryTerm) , dbg_transformations :: Set String -- ^ List the transformations that are being debugged. When the set is empty, -- all transformations are debugged. -- -- Command line flag: -fclash-debug-transformations t1[,t2...] , dbg_countTransformations :: Bool -- ^ Count how many times transformations are applied and provide a summary -- at the end of normalization. This includes all transformations, not just -- those in 'dbg_transformations'. -- -- Command line flag: -fclash-debug-count-transformations , dbg_transformationsFrom :: Maybe Word -- ^ Debug transformations applied after the nth transformation applied. This -- includes all transformations, not just those in 'dbg_transformations'. -- -- Command line flag: -fclash-debug-transformations-from=N , dbg_transformationsLimit :: Maybe Word -- ^ Debug up to the nth applied transformation. If this limit is exceeded -- then Clash will error. This includes all transformations, not just those -- in 'dbg_transformations'. -- -- Command line flag: -fclash-debug-transformations-limit=N , dbg_historyFile :: Maybe FilePath -- ^ Save information about all applied transformations to a history file -- for use with @clash-term@. -- -- Command line flag: -fclash-debug-history[=FILE] } deriving (Generic, NFData, Show, Eq) instance Hashable DebugOpts where hashWithSalt s DebugOpts{..} = s `hashWithSalt` dbg_invariants `hashWithSalt` dbg_transformationInfo `hashSet` dbg_transformations `hashWithSalt` dbg_countTransformations `hashWithSalt` dbg_transformationsFrom `hashWithSalt` dbg_transformationsLimit `hashWithSalt` dbg_historyFile where hashSet = Set.foldl' hashWithSalt infixl 0 `hashSet` -- | Check whether the debugging options mean the compiler is debugging. This -- is true only if at least one debugging feature is enabled, namely one of -- -- * checking for invariants -- * showing info for transformations -- * counting applied transformations -- * limiting the number of transformations -- -- Other flags, such as writing to a history file or offsetting which applied -- transformation to show information from do not affect the result, as it is -- possible to enable these but still not perform any debugging checks in -- functions like 'applyDebug'. If this is no longer the case, this function -- will need to be changed. isDebugging :: DebugOpts -> Bool isDebugging opts = or [ dbg_invariants opts , dbg_transformationInfo opts > None , dbg_countTransformations opts , isJust (dbg_transformationsLimit opts) ] -- | Check whether the requested information is available to the specified -- transformation according to the options. e.g. -- -- @ -- traceIf (hasDebugInfo AppliedName name opts) ("Trace something using: " <> show name) -- @ -- -- This accounts for the set of transformations which are being debugged. For a -- check which is agnostic to the a transformation, see 'hasTransformationInfo'. hasDebugInfo :: TransformationInfo -> String -> DebugOpts -> Bool hasDebugInfo info name opts = isDebugged name && hasTransformationInfo info opts where isDebugged n = let set = dbg_transformations opts in Set.null set || Set.member n set -- | Check that the transformation info shown supports the requested info. -- If the call-site is in the context of a particular transformation, -- 'hasDebugInfo' should be used instead. hasTransformationInfo :: TransformationInfo -> DebugOpts -> Bool hasTransformationInfo info opts = info <= dbg_transformationInfo opts -- NOTE [debugging options] -- -- The preset debugging options here provide backwards compatibility with the -- old style DebugLevel enum. However it is also possible to have finer-grained -- control over debugging by using individual flags which did not previously -- exist, e.g. -fclash-debug-invariants. -- | -fclash-debug DebugNone debugNone :: DebugOpts debugNone = DebugOpts { dbg_invariants = False , dbg_transformationInfo = None , dbg_transformations = Set.empty , dbg_countTransformations = False , dbg_transformationsFrom = Nothing , dbg_transformationsLimit = Nothing , dbg_historyFile = Nothing } -- | -fclash-debug DebugSilent debugSilent :: DebugOpts debugSilent = debugNone { dbg_invariants = True } -- | -fclash-debug DebugFinal debugFinal :: DebugOpts debugFinal = debugSilent { dbg_transformationInfo = FinalTerm } -- | -fclash-debug DebugCount debugCount :: DebugOpts debugCount = debugFinal { dbg_countTransformations = True } -- | -fclash-debug DebugName debugName :: DebugOpts debugName = debugCount { dbg_transformationInfo = AppliedName } -- | -fclash-debug DebugTry debugTry :: DebugOpts debugTry = debugName { dbg_transformationInfo = TryName } -- | -fclash-debug DebugApplied debugApplied :: DebugOpts debugApplied = debugTry { dbg_transformationInfo = AppliedTerm } -- | -fclash-debug DebugAll debugAll :: DebugOpts debugAll = debugApplied { dbg_transformationInfo = TryTerm } -- | Options passed to Clash compiler data ClashOpts = ClashOpts { opt_werror :: Bool -- ^ Are warnings treated as errors. -- -- Command line flag: -Werror , opt_inlineLimit :: Int -- ^ Change the number of times a function f can undergo inlining inside -- some other function g. This prevents the size of g growing dramatically. -- -- Command line flag: -fclash-inline-limit , opt_specLimit :: Int -- ^ Change the number of times a function can undergo specialization. -- -- Command line flag: -fclash-spec-limit , opt_inlineFunctionLimit :: Word -- ^ Set the threshold for function size. Below this threshold functions are -- always inlined (if it is not recursive). -- -- Command line flag: -fclash-inline-function-limit , opt_inlineConstantLimit :: Word -- ^ Set the threshold for constant size. Below this threshold constants are -- always inlined. A value of 0 inlines all constants. -- -- Command line flag: -fclash-inline-constant-limit , opt_evaluatorFuelLimit :: Word -- ^ Set the threshold for maximum unfolding depth in the evaluator. A value -- of zero means no potentially non-terminating binding is unfolded. -- -- Command line flag: -fclash-evaluator-fuel-limit , opt_debug :: DebugOpts -- ^ Options which control debugging. See 'DebugOpts'. , opt_cachehdl :: Bool -- ^ Reuse previously generated output from Clash. Only caches topentities. -- -- Command line flag: -fclash-no-cache , opt_clear :: Bool -- ^ Remove HDL directories before writing to them. By default, Clash will -- only write to non-empty directories if it can prove all files in it are -- generated by a previous run. This option applies to directories of the -- various top entities, i.e., the subdirectories made in the directory passed -- in with @-fclash-hdldir@. Note that Clash will still use a cache if it can. -- -- Command line flag: @-fclash-clear@ , opt_primWarn :: Bool -- ^ Disable warnings for primitives -- -- Command line flag: -fclash-no-prim-warn , opt_color :: OverridingBool -- ^ Show colors in debug output -- -- Command line flag: -fdiagnostics-color , opt_intWidth :: Int -- ^ 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 , opt_hdlSyn :: HdlSyn -- ^ Synthesis target. See "HdlSyn" for available options. , opt_errorExtra :: Bool -- ^ Show additional information in error messages , opt_importPaths :: [FilePath] -- ^ Paths where Clash should look for modules , opt_componentPrefix :: Maybe Text -- ^ Prefix components with given string , opt_newInlineStrat :: Bool -- ^ Use new inline strategy. Functions marked NOINLINE will get their own -- HDL module. , opt_escapedIds :: Bool -- ^ Use escaped identifiers in HDL. See: -- -- * 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. , opt_ultra :: Bool -- ^ Perform a high-effort compile, trading improved performance for -- potentially much longer compile times. -- -- Name inspired by Design Compiler's /compile_ultra/ flag. , opt_forceUndefined :: Maybe (Maybe Int) -- ^ -- * /Nothing/: generate undefined's in the HDL -- -- * /Just Nothing/: replace undefined's by a constant in the HDL; the -- compiler decides what's best -- -- * /Just (Just x)/: replace undefined's by /x/ in the HDL , opt_checkIDir :: Bool -- ^ Check whether paths specified in 'opt_importPaths' exists on the -- filesystem. , opt_aggressiveXOpt :: Bool -- ^ Enable aggressive X optimization, which may remove undefineds from -- generated HDL by replaced with defined alternatives. , opt_aggressiveXOptBB :: Bool -- ^ Enable aggressive X optimization, which may remove undefineds from -- HDL generated by blackboxes. This enables the ~ISUNDEFINED template tag. , opt_inlineWFCacheLimit :: Word -- ^ At what size do we cache normalized work-free top-level binders. , opt_edalize :: Bool -- ^ Generate an EDAM file for use with Edalize. , 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) instance NFData ClashOpts where rnf o = opt_werror o `deepseq` opt_inlineLimit o `deepseq` opt_specLimit o `deepseq` opt_inlineFunctionLimit o `deepseq` opt_inlineConstantLimit o `deepseq` opt_evaluatorFuelLimit o `deepseq` opt_cachehdl o `deepseq` opt_clear o `deepseq` opt_primWarn o `deepseq` opt_color o `seq` opt_intWidth o `deepseq` opt_hdlDir o `deepseq` opt_hdlSyn o `deepseq` opt_errorExtra o `deepseq` opt_importPaths o `deepseq` opt_componentPrefix o `deepseq` opt_newInlineStrat o `deepseq` opt_escapedIds o `deepseq` opt_lowerCaseBasicIds o `deepseq` opt_ultra o `deepseq` opt_forceUndefined o `deepseq` opt_checkIDir o `deepseq` opt_aggressiveXOpt o `deepseq` opt_aggressiveXOptBB o `deepseq` opt_inlineWFCacheLimit o `deepseq` opt_edalize o `deepseq` opt_renderEnums o `deepseq` opt_timescalePrecision o `deepseq` () instance Eq ClashOpts where s0 == s1 = opt_werror s0 == opt_werror s1 && opt_inlineLimit s0 == opt_inlineLimit s1 && opt_specLimit s0 == opt_specLimit s1 && opt_inlineFunctionLimit s0 == opt_inlineFunctionLimit s1 && opt_inlineConstantLimit s0 == opt_inlineConstantLimit s1 && opt_evaluatorFuelLimit s0 == opt_evaluatorFuelLimit s1 && opt_cachehdl s0 == opt_cachehdl s1 && opt_clear s0 == opt_clear s1 && opt_primWarn s0 == opt_primWarn s1 && (opt_color s0 `eqOverridingBool` opt_color s1) && opt_intWidth s0 == opt_intWidth s1 && opt_hdlDir s0 == opt_hdlDir s1 && opt_hdlSyn s0 == opt_hdlSyn s1 && opt_errorExtra s0 == opt_errorExtra s1 && opt_importPaths s0 == opt_importPaths s1 && opt_componentPrefix s0 == opt_componentPrefix s1 && opt_newInlineStrat s0 == opt_newInlineStrat s1 && opt_escapedIds s0 == opt_escapedIds s1 && opt_lowerCaseBasicIds s0 == opt_lowerCaseBasicIds s1 && opt_ultra s0 == opt_ultra s1 && opt_forceUndefined s0 == opt_forceUndefined s1 && opt_checkIDir s0 == opt_checkIDir s1 && opt_aggressiveXOpt s0 == opt_aggressiveXOpt s1 && 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_timescalePrecision s0 == opt_timescalePrecision s1 where eqOverridingBool :: OverridingBool -> OverridingBool -> Bool eqOverridingBool Auto Auto = True eqOverridingBool Always Always = True eqOverridingBool Never Never = True eqOverridingBool _ _ = False instance Hashable ClashOpts where hashWithSalt s ClashOpts {..} = s `hashWithSalt` opt_werror `hashWithSalt` opt_inlineLimit `hashWithSalt` opt_specLimit `hashWithSalt` opt_inlineFunctionLimit `hashWithSalt` opt_inlineConstantLimit `hashWithSalt` opt_evaluatorFuelLimit `hashWithSalt` opt_cachehdl `hashWithSalt` opt_clear `hashWithSalt` opt_primWarn `hashOverridingBool` opt_color `hashWithSalt` opt_intWidth `hashWithSalt` opt_hdlDir `hashWithSalt` opt_hdlSyn `hashWithSalt` opt_errorExtra `hashWithSalt` opt_importPaths `hashWithSalt` opt_componentPrefix `hashWithSalt` opt_newInlineStrat `hashWithSalt` opt_escapedIds `hashWithSalt` opt_lowerCaseBasicIds `hashWithSalt` opt_ultra `hashWithSalt` opt_forceUndefined `hashWithSalt` opt_checkIDir `hashWithSalt` opt_aggressiveXOpt `hashWithSalt` opt_aggressiveXOptBB `hashWithSalt` opt_inlineWFCacheLimit `hashWithSalt` opt_edalize `hashWithSalt` opt_renderEnums `hashWithSalt` opt_timescalePrecision where hashOverridingBool :: Int -> OverridingBool -> Int hashOverridingBool s1 Auto = hashWithSalt s1 (0 :: Int) hashOverridingBool s1 Always = hashWithSalt s1 (1 :: Int) hashOverridingBool s1 Never = hashWithSalt s1 (2 :: Int) infixl 0 `hashOverridingBool` defClashOpts :: ClashOpts defClashOpts = ClashOpts { opt_werror = False , opt_inlineLimit = 20 , opt_specLimit = 20 , opt_inlineFunctionLimit = 15 , opt_inlineConstantLimit = 0 , opt_evaluatorFuelLimit = 20 , opt_debug = debugNone , opt_cachehdl = True , opt_clear = False , opt_primWarn = True , opt_color = Auto , opt_intWidth = WORD_SIZE_IN_BITS , opt_hdlDir = Nothing , opt_hdlSyn = Other , opt_errorExtra = False , opt_importPaths = [] , opt_componentPrefix = Nothing , opt_newInlineStrat = True , opt_escapedIds = True , opt_lowerCaseBasicIds = PreserveCase , opt_ultra = False , opt_forceUndefined = Nothing , opt_checkIDir = True , opt_aggressiveXOpt = False , opt_aggressiveXOptBB = False , 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. -- Currently this limited to the names and periods of clocks for create_clock. -- newtype SdcInfo = SdcInfo { sdcClock :: [(Text, VDomainConfiguration)] } -- | Render an SDC file from an SdcInfo. -- The clock periods, waveforms, and targets are all hardcoded. -- pprSDC :: SdcInfo -> Doc () pprSDC = vcat . fmap go . sdcClock where go (i, dom) = -- VDomainConfiguration stores period in ps, SDC expects it in ns. let p = MkFixed (toInteger $ vPeriod dom) :: Fixed E3 name = braces (pretty (Text.dropAround (== '\\') i)) period = viaShow p waveform = braces ("0.000" <+> viaShow (p / 2)) targets = brackets ("get_ports" <+> name) in hsep [ "create_clock" , "-name" <+> name , "-period" <+> period , "-waveform" <+> waveform , targets ] clash-lib-1.8.1/src/Clash/Edalize/0000755000000000000000000000000007346545000014746 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Edalize/Edam.hs0000644000000000000000000001757007346545000016162 0ustar0000000000000000{-| Copyright : (C) 2020, QBayLogic License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Data types and rendering for Edalize Metadata files (EDAM). -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Edalize.Edam ( Edam(..) , EdamFile(..) , EdamFileType(..) , EdamTools(..) , GhdlOptions(..) , IcarusOptions(..) , ModelsimOptions(..) , QuartusOptions(..) , VivadoOptions(..) , pprEdam ) where import Data.Default import Data.Maybe import Data.Text (Text) #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter #else import Data.Text.Prettyprint.Doc #endif -- | EDAM data structure to be given to an Edalize backend. This contains all -- information needed to generate a project scaffolding. Note that hooks and -- VPI modules are currently not specified by clash. -- data Edam = Edam { edamProjectName :: Text , edamTopEntity :: Text , edamFiles :: [EdamFile] , edamToolOptions :: EdamTools } pprEdam :: Edam -> Doc ann pprEdam (Edam n te fs ts) = vsep [ pyPre , hsep ["edam", equals, manifest] , pyPost ] where manifest = pyRecord [ pyField "name" $ squotes (pretty n) , pyField "toplevel" $ squotes (pretty te) , pyField "files" $ pyList (fmap pprFile fs) , pyField "tool_options" $ pprEdamTools ts ] -- | Information about each file in the project. This does not include -- is_include_file or include_path, as these are not currently used by Clash. -- data EdamFile = EdamFile { efName :: FilePath , efType :: EdamFileType , efLogicalName :: Text } pprFile :: EdamFile -> Doc ann pprFile (EdamFile n ty ln) = pyRecord [ pyField "name" $ joinPath n , pyField "file_type" $ squotes (pprFileType ty) , pyField "logical_name" $ squotes (pretty ln) ] -- | A subset of the file types recognized by Edalize. The supported formats -- are largely from IP-XACT 2014 (IEEE 1685-2014), although Edalize extends -- this with other types, e.g. QSYS. -- -- Only file types which are generated by Clash are listed. -- data EdamFileType = Unknown -- ^ Unknown file type. | VhdlSource -- ^ VHDL source. | VerilogSource -- ^ Verilog source. | SystemVerilogSource -- ^ SystemVerilog source. | TclSource -- ^ Tool Command Language source. | QSYS -- ^ QSys system source. | SDC -- ^ Synopsys Design Constraints source. deriving (Eq, Show) pprFileType :: EdamFileType -> Doc ann pprFileType = \case Unknown -> "unknown" VhdlSource -> "vhdlSource" VerilogSource -> "verilogSource" SystemVerilogSource -> "systemVerilogSource" TclSource -> "tclSource" QSYS -> "QSYS" SDC -> "SDC" -- | Tool-specific configuration used by Edalize. -- Currently only tools which are supported by Clash are provided. -- data EdamTools = EdamTools { etGhdl :: Maybe GhdlOptions , etIcarus :: Maybe IcarusOptions , etModelsim :: Maybe ModelsimOptions , etQuartus :: Maybe QuartusOptions , etVivado :: Maybe VivadoOptions } instance Default EdamTools where def = EdamTools def def def def def pprEdamTools :: EdamTools -> Doc ann pprEdamTools tools = pyRecord [ pyField "ghdl" $ pprGhdlOptions ghdl , pyField "icarus" $ pprIcarusOptions icarus , pyField "modelsim" $ pprModelsimOptions modelsim , pyDocField "quartus" "TODO Specify options if using Quartus" (pprQuartusOptions quartus) , pyDocField "vivado" "TODO Specify options if using Vivado" (pprVivadoOptions vivado) ] where ghdl = fromMaybe def (etGhdl tools) icarus = fromMaybe def (etIcarus tools) modelsim = fromMaybe def (etModelsim tools) quartus = fromMaybe def (etQuartus tools) vivado = fromMaybe def (etVivado tools) data GhdlOptions = GhdlOptions { ghdlAnalyseOpts :: [Text] , ghdlRunOpts :: [Text] } instance Default GhdlOptions where def = GhdlOptions [] [] pprGhdlOptions :: GhdlOptions -> Doc ann pprGhdlOptions (GhdlOptions aOpts rOpts) = pyRecord [ pyDocField "analyze_options" "Command line arguments for analysis" (flagList (fmap pretty aOpts)) , pyDocField "run_options" "Command line arguments for simulation" (flagList (fmap pretty rOpts)) ] data IcarusOptions = IcarusOptions { icarusOpts :: [Text] , icarusTimeScale :: Text } instance Default IcarusOptions where def = IcarusOptions [] "100fs/100fs" pprIcarusOptions :: IcarusOptions -> Doc ann pprIcarusOptions (IcarusOptions opts ts) = pyRecord [ pyDocField "iverilog_options" "Command line options for iverilog" (flagList (fmap pretty opts)) , pyDocField "timescale" "Default timescale for simulation" (squotes (pretty ts)) ] data ModelsimOptions = ModelsimOptions { msVlogOpts :: [Text] , msVsimOpts :: [Text] } instance Default ModelsimOptions where def = ModelsimOptions [] [] pprModelsimOptions :: ModelsimOptions -> Doc ann pprModelsimOptions (ModelsimOptions vlog vsim) = pyRecord [ pyDocField "vlog_options" "Command line arguments for vlog" (flagList (fmap pretty vlog)) , pyDocField "vsim_options" "Command line arguments for vsim" (flagList (fmap pretty vsim)) ] data QuartusOptions = QuartusOptions { quartusBoardDevIndex :: Int , quartusFamily :: Text , quartusDevice :: Text , quartusOpts :: [Text] , quartusDseOpts :: [Text] } instance Default QuartusOptions where def = QuartusOptions 1 "" "" [] [] pprQuartusOptions :: QuartusOptions -> Doc ann pprQuartusOptions (QuartusOptions bdi fam dev opts dse) = pyRecord [ pyDocField "board_device_index" "Specify the FPGA's device number in the JTAG chain" (squotes (pretty bdi)) , pyDocField "family" "FPGA family, e.g. Cyclone IV E" (squotes (pretty fam)) , pyDocField "device" "Device identifier, e.g. EP4CE55F23C8" (squotes (pretty dev)) , pyDocField "quartus_options" "Command line arguments for Quartus" (flagList (fmap pretty opts)) , pyDocField "dse_options" "Command line arguments for Design Space Explorer" (flagList (fmap pretty dse)) ] data VivadoOptions = VivadoOptions { vivadoPart :: Text } instance Default VivadoOptions where def = VivadoOptions "" pprVivadoOptions :: VivadoOptions -> Doc ann pprVivadoOptions (VivadoOptions part) = pyRecord [ pyDocField "part" "Specify target part by ID, e.g. xc7z020-1clg400c" (squotes (pretty part)) ] -- Helpers; don't export pyPre :: Doc ann pyPre = vsep [ "import os" , "" , "edam_root = os.path.dirname(os.path.realpath(__file__))" , "work_root = 'build'" , "" , "# TODO Specify the EDA tool to use" , "tool = ''" , "" ] pyPost :: Doc ann pyPost = vsep [ "" , "if __name__ == '__main__':" , indent 4 $ vsep [ "from edalize import *" , "" , "tool = get_edatool(tool)(edam=edam, work_root=work_root)" , "os.makedirs(work_root)" , "tool.configure()" , "tool.build()" ] ] pyList :: [Doc ann] -> Doc ann pyList xs = vsep [lbracket, indent 4 (commaList xs), rbracket] pyRecord :: [Doc ann] -> Doc ann pyRecord xs = vsep [lbrace, indent 4 (commaList xs), rbrace] pyComment :: Text -> Doc ann pyComment x = hsep ["#", pretty x] pyField :: Text -> Doc ann -> Doc ann pyField n x = hcat [squotes (pretty n), colon, space, x] pyDocField :: Text -> Text -> Doc ann -> Doc ann pyDocField n d x = vsep [pyComment d, pyField n x] joinPath :: FilePath -> Doc ann joinPath x = hcat [ "os.path.join" , parens (hsep $ punctuate comma ["edam_root", squotes (pretty x)]) ] flagList :: [Doc ann] -> Doc ann flagList = squotes . hsep commaList :: [Doc ann] -> Doc ann commaList = vsep . punctuate comma clash-lib-1.8.1/src/Clash/Netlist.hs0000644000000000000000000013734107346545000015360 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 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. Create Netlists out of normalized CoreHW Terms -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Netlist where import Control.Exception (throw) import Control.Lens ((.=), (<~)) import qualified Control.Lens as Lens 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 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, fromMaybe) import qualified Data.Map.Ordered as OMap import qualified Data.Set as Set import Data.Primitive.ByteArray (ByteArray (..)) import qualified Data.Text as StrictText import GHC.Stack (HasCallStack) #if MIN_VERSION_base(4,15,0) import GHC.Num.Integer (Integer (..)) #else import GHC.Integer.GMP.Internals (Integer (..), BigNat (..)) #endif #if MIN_VERSION_ghc(9,0,0) import GHC.Utils.Outputable (ppr, showSDocUnsafe) import GHC.Types.SrcLoc (isGoodSrcSpan) #else import Outputable (ppr, showSDocUnsafe) import SrcLoc (isGoodSrcSpan) #endif import Clash.Annotations.Primitive (HDL) import Clash.Annotations.BitRepresentation.ClashLib (coreToType') import Clash.Annotations.BitRepresentation.Internal (CustomReprs, DataRepr'(..), ConstrRepr'(..), getDataRepr, getConstrRepr) import Clash.Core.DataCon (DataCon (..)) import Clash.Core.HasType import Clash.Core.Literal (Literal (..)) import Clash.Core.Name (Name(..)) import Clash.Core.Pretty (showPpr) import Clash.Core.Term (IsMultiPrim (..), PrimInfo (..), mpi_resultTypes, Alt, Pat (..), Term (..), TickInfo (..), collectArgs, collectArgsTicks, collectTicks, mkApps, mkTicks, stripTicks) import qualified Clash.Core.Term as Core import Clash.Core.TermInfo (multiPrimInfo', splitMultiPrimArgs) import Clash.Core.Type (Type (..), coreView1, splitFunForallTy, splitCoreFunForallTy) import Clash.Core.TyCon (TyConMap) import Clash.Core.Util (splitShouldSplit) import Clash.Core.Var (Id, Var (..), isGlobalId) import Clash.Core.VarEnv (VarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, lookupVarEnv, lookupVarEnv') import Clash.Driver.Types (BindingMap, Binding(..), ClashEnv(..), ClashOpts (..)) import Clash.Netlist.BlackBox import qualified Clash.Netlist.Id as Id import Clash.Netlist.Types as HW import Clash.Netlist.Util import Clash.Primitives.Types as P import Clash.Util import qualified Clash.Util.Interpolate as I -- | Generate a hierarchical netlist out of a set of global binders with -- @topEntity@ at the top. genNetlist :: ClashEnv -> Bool -- ^ Whether this we're compiling a testbench (suppresses certain warnings) -> BindingMap -- ^ Global binders -> VarEnv TopEntityT -- ^ TopEntity annotations -> VarEnv Identifier -- ^ Top entity names -> (CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))) -- ^ Hardcoded Type -> HWType translator -> Bool -- ^ Whether the backend supports ifThenElse expressions -> SomeBackend -- ^ The current HDL backend -> IdentifierSet -- ^ Seen components -> FilePath -- ^ HDL dir -> Maybe StrictText.Text -- ^ Component name prefix -> Id -- ^ Name of the @topEntity@ -> IO (Component, ComponentMap, IdentifierSet) genNetlist env isTb globals tops topNames typeTrans ite be seen0 dir prefixM topEntity = do ((_meta, topComponent), s) <- runNetlistMonad env isTb globals tops typeTrans ite be seen1 dir componentNames_ $ genComponent topEntity return (topComponent, _components s, seen1) where (componentNames_, seen1) = genNames (opt_newInlineStrat (envOpts env)) prefixM seen0 topNames globals -- | Run a NetlistMonad action in a given environment runNetlistMonad :: ClashEnv -> Bool -- ^ Whether this we're compiling a testbench (suppresses certain warnings) -> BindingMap -- ^ Global binders -> VarEnv TopEntityT -- ^ TopEntity annotations -> (CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))) -- ^ Hardcode Type -> HWType translator -> Bool -- ^ Whether the backend supports ifThenElse expressions -> SomeBackend -- ^ The current HDL backend -> IdentifierSet -- ^ Seen components -> FilePath -- ^ HDL dir -> VarEnv Identifier -- ^ Seen components -> NetlistMonad a -- ^ Action to run -> IO (a, NetlistState) runNetlistMonad env isTb s tops typeTrans ite be seenIds_ dir componentNames_ = flip runReaderT (NetlistEnv env "" "" Nothing) . flip runStateT s' . runNetlist where s' = NetlistState { _bindings=s , _components=OMap.empty , _typeTranslator=typeTrans , _curCompNm=(error "genComponent should have set _curCompNm", noSrcSpan) , _seenIds=seenIds_ , _seenComps=seenIds_ , _seenPrimitives=Set.empty , _componentNames=componentNames_ , _topEntityAnns=tops , _hdlDir=dir , _curBBlvl=0 , _isTestBench=isTb , _backEndITE=ite , _backend=be , _htyCache=mempty , _usages=mempty } -- | Generate names for all binders in "BindingMap", except for the ones already -- present in given identifier varenv. genNames :: Bool -- ^ New inline strategy enabled? -> Maybe StrictText.Text -- ^ Prefix -> IdentifierSet -- ^ Identifier set to extend -> VarEnv Identifier -- ^ Pre-generated names -> BindingMap -> (VarEnv Identifier, IdentifierSet) genNames newInlineStrat prefixM is env bndrs = runState (foldlM go env bndrs) is where go env_ (bindingId -> id_) = case lookupVarEnv id_ env_ of Just _ -> pure env_ Nothing -> do nm <- Id.makeBasic (genComponentName newInlineStrat prefixM id_) pure (extendVarEnv id_ nm env_) -- | Generate names for top entities. Should be executed at the very start of -- the synthesis process and shared between all passes. genTopNames :: ClashOpts -> HDL -- ^ HDL to generate identifiers for -> [TopEntityT] -> (VarEnv Identifier, IdentifierSet) genTopNames opts hdl tops = -- TODO: Report error if fixed top entities have conflicting names flip runState (Id.emptyIdentifierSet esc lw hdl) $ do env0 <- foldlM goFixed emptyVarEnv fixedTops env1 <- foldlM goNonFixed env0 nonFixedTops pure env1 where prefixM = opt_componentPrefix opts esc = opt_escapedIds opts lw = opt_lowerCaseBasicIds opts fixedTops = [(topId, ann) | TopEntityT{topId, topAnnotation=Just ann} <- tops] nonFixedTops = [topId | TopEntityT{topId, topAnnotation=Nothing} <- tops] goFixed env (topId, ann) = do topNm <- genTopName prefixM ann pure (extendVarEnv topId topNm env) goNonFixed env id_ = do topNm <- Id.makeBasic (genComponentName True prefixM id_) pure (extendVarEnv id_ topNm env) -- | Generate a component for a given function (caching) genComponent :: HasCallStack => Id -- ^ Name of the function -> NetlistMonad (ComponentMeta, Component) genComponent compName = do compExprM <- lookupVarEnv compName <$> Lens.use bindings case compExprM of Nothing -> do (_,sp) <- Lens.use curCompNm throw (ClashException sp ($(curLoc) ++ "No normalized expression found for: " ++ show compName) Nothing) Just b -> do makeCachedO compName components $ genComponentT compName (bindingTerm b) -- | Generate a component for a given function genComponentT :: HasCallStack => Id -- ^ Name of the function -> Term -- ^ Corresponding term -> NetlistMonad (ComponentMeta, Component) genComponentT compName0 componentExpr = do tcm <- Lens.view tcCache 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 topVarTypeM = snd . splitCoreFunForallTy tcm . coreTypeOf . topId <$> topEntityTM seenIds <~ Lens.use seenComps (wereVoids,compInps,argWrappers,compOutps,resUnwrappers,binders,resultM) <- case splitNormalized tcm componentExpr of Right (args, binds, res) -> do let varType1 = fromMaybe (coreTypeOf res) topVarTypeM mkUniqueNormalized emptyInScopeSet topAnnMM -- HACK: Determine resulttype of this function by looking at its definition -- instead of looking at its last binder (which obscures any attributes -- [see: Clash.Annotations.SynthesisAttributes]). ((args, binds, res{varType=varType1})) Left err -> throw (ClashException sp ($curLoc ++ err) Nothing) netDecls <- concatMapM mkNetDecl (filter (maybe (const True) (/=) resultM . fst) binders) decls <- concat <$> mapM (uncurry mkDeclarations) binders case resultM of Just result -> do [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] -> ([(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 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 u <- Lens.use usages return (ComponentMeta wereVoids sp ids u, component) mkNetDecl :: (Id, Term) -> NetlistMonad [Declaration] mkNetDecl (id_,tm) = preserveVarEnv $ do hwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (coreTypeOf id_) if | not (shouldRenderDecl hwTy tm) -> return [] | (Prim pInfo@PrimInfo{primMultiResult=MultiResult}, args) <- collectArgs tm -> multiDecls pInfo args | otherwise -> pure <$> singleDecl hwTy where multiDecls pInfo args0 = do tcm <- Lens.view tcCache resInits0 <- getResInits (id_, tm) let resInits1 = map Just resInits0 <> repeat Nothing mpInfo = multiPrimInfo' tcm pInfo (_, res) = splitMultiPrimArgs mpInfo args0 netdecl i 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 rIM <- listToMaybe <$> getResInits (id_, tm) return (NetDecl' srcNote (Id.unsafeFromCoreId id_) hwTy rIM) addSrcNote loc | isGoodSrcSpan loc = Just (StrictText.pack (showSDocUnsafe (ppr loc))) | otherwise = Nothing srcNote = addSrcNote $ case tm of Tick (SrcSpan s) _ -> s _ -> nameLoc (varName id_) isMultiPrimSelect :: Term -> Bool isMultiPrimSelect t = case collectArgs t of (Prim (primName -> "c$multiPrimSelect"), _) -> True _ -> False shouldRenderDecl :: HWType -> Term -> Bool shouldRenderDecl ty t | isVoid ty = False | isMultiPrimSelect t = False | otherwise = True -- 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 Prim p -> extractPrimWarnOrFail (primName p) >>= go p _ -> return [] where go pInfo (BlackBox {resultInits=nmDs, multiResult=True}) = withTicks ticks $ \_ -> do tcm <- Lens.view tcCache let (args1, res) = splitMultiPrimArgs (multiPrimInfo' tcm pInfo) args0 (bbCtx, _) <- mkBlackBoxContext (primName pInfo) res args1 mapM (go' (primName pInfo) bbCtx) nmDs go pInfo (BlackBox {resultInits=nmDs}) = withTicks ticks $ \_ -> do (bbCtx, _) <- mkBlackBoxContext (primName pInfo) [i] args0 mapM (go' (primName pInfo) bbCtx) nmDs go _ _ = pure [] go' pNm bbCtx nmD = do (bbTempl, templDecl) <- prepareBlackBox pNm nmD bbCtx case templDecl of [] -> return (BlackBoxE pNm [] [] [] bbTempl bbCtx False) _ -> do (_,sloc) <- Lens.use curCompNm throw (ClashException sloc [I.i| Initial values cannot produce declarations, but saw: #{templDecl} after rendering initial values for blackbox: #{pNm} Given template: #{nmD} |] Nothing) -- | Generate a list of concurrent Declarations for a let-binder, return an -- empty list if the bound expression is represented by 0 bits mkDeclarations :: HasCallStack => Id -- ^ LHS of the let-binder -> Term -- ^ RHS of the let-binder -> NetlistMonad [Declaration] mkDeclarations = mkDeclarations' Concurrent -- | Generate a list of Declarations for a let-binder, return an empty list if -- the bound expression is represented by 0 bits mkDeclarations' :: HasCallStack => DeclarationType -- ^ Concurrent of sequential declaration -> Id -- ^ LHS of the let-binder -> Term -- ^ RHS of the let-binder -> NetlistMonad [Declaration] mkDeclarations' _declType bndr (collectTicks -> (Var v,ticks)) = withTicks ticks (mkFunApp (Id.unsafeFromCoreId bndr) v []) mkDeclarations' _declType _bndr e@(collectTicks -> (Case _ _ [],_)) = do (_,sp) <- Lens.use curCompNm throw $ ClashException sp ( unwords [ $(curLoc) , "Not in normal form: Case-decompositions with an" , "empty list of alternatives not supported:\n\n" , showPpr e ]) Nothing 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 (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 = 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 return (declsApp1 ++ assn) -- | Generate a declaration that selects an alternative based on the value of -- the scrutinee mkSelection :: DeclarationType -> NetlistId -> Term -> Type -> NonEmpty Alt -> [Declaration] -> NetlistMonad [Declaration] mkSelection declType bndr scrut altTy alts0 tickDecls = do let dstId = netlistId1 id Id.unsafeFromCoreId bndr tcm <- Lens.view tcCache let scrutTy = inferCoreTypeOf tcm scrut scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy scrutId <- Id.suffix dstId "selection" (_,sp) <- Lens.use curCompNm ite <- Lens.use backEndITE altHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) altTy 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 (NE.last alts0))) <$> mkExpr True declType (NetlistId scrutId scrutTy) scrut _ -> mkExpr False declType (NetlistId scrutId scrutTy) scrut altTId <- Id.suffix dstId "sel_alt_t" altFId <- Id.suffix dstId "sel_alt_f" (altTExpr,altTDecls) <- mkExpr False declType (NetlistId altTId altTy) altT (altFExpr,altFDecls) <- mkExpr False declType (NetlistId altFId altTy) altF -- This logic (and the same logic a few lines below) is faulty in the -- sense that it won't generate "void decls" if the alternatives' type -- is void, but the type of the scrut isn't. Ideally, we'd like to pass -- a boolean to 'mkExpr' indicating that it should only render "void decls" -- but that it should skip any others. -- -- TODO: Fix ^ if | isVoid altHTy && isVoid scrutHTy -> return $! scrutDecls ++ altTDecls ++ altFDecls | isVoid altHTy -> return $! altTDecls ++ altFDecls | otherwise -> 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 (NE.head alts1))) <$> mkExpr True declType (NetlistId scrutId scrutTy) scrut (exprs,altsDecls) <- unzip <$> mapM (mkCondExpr scrutHTy) (NE.toList alts1) case declType of Sequential -> do -- Assign to the result in every branch (altNets,exprAlts) <- fmap unzip (zipWithM (altAssign dstId) exprs altsDecls) return $! scrutDecls ++ tickDecls ++ concat altNets ++ [Seq [Branch scrutExpr scrutHTy exprAlts]] Concurrent -> if | isVoid altHTy && isVoid scrutHTy -> return $! concat altsDecls ++ scrutDecls | isVoid altHTy -> return $! concat altsDecls | otherwise -> 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 Id.unsafeFromCoreId bndr) "sel_alt" (altExpr,altDecls) <- mkExpr False declType (NetlistId altId altTy) alt (,altDecls) <$> case pat of DefaultPat -> return (Nothing,altExpr) DataPat dc _ _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr) LitPat (IntegerLiteral i) -> return (Just (NumLit i),altExpr) LitPat (IntLiteral i) -> return (Just (NumLit i), altExpr) LitPat (WordLiteral w) -> return (Just (NumLit w), altExpr) 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 throw (ClashException sp ($(curLoc) ++ "Not an integer literal in LitPat:\n\n" ++ showPpr pat) Nothing) mkScrutExpr :: SrcSpan -> HWType -> Pat -> Expr -> Expr mkScrutExpr sp scrutHTy pat scrutE = case pat of DataPat dc _ _ -> let modifier = Just (DC (scrutHTy,dcTag dc - 1)) in case scrutE of Identifier scrutId Nothing -> Identifier scrutId modifier _ -> 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] -> NetlistMonad ([Declaration],(Maybe HW.Literal,[Seq])) altAssign i (m,expr) ds = do let (nets,rest) = partition isNet ds 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 -- GHC puts default patterns in the first position, we want them in the -- last position. reorderDefault :: 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 -> 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) -> NE.sortOn (patPos reprs . fst) alts Nothing -> alts reorderCustom _tcm _reprs _type alts = alts patPos :: CustomReprs -> Pat -> Int patPos _reprs DefaultPat = -1 patPos _reprs (LitPat _) = 0 patPos reprs pat@(DataPat dataCon _ _) = -- We sort data patterns by their syntactical order let name = nameOcc $ dcName dataCon in case getConstrRepr name reprs of Nothing -> -- TODO: err error $ $(curLoc) ++ (show pat) Just (ConstrRepr' _name n _mask _value _anns) -> n -- | Generate a list of Declarations for a let-binder where the RHS is a function application mkFunApp :: HasCallStack => Identifier -- ^ LHS of the let-binder -> Id -- ^ Name of the applied function -> [Term] -- ^ Function arguments -> [Declaration] -- ^ Tick declarations -> NetlistMonad [Declaration] mkFunApp dstId fun args tickDecls = do topAnns <- Lens.use topEntityAnns tcm <- Lens.view tcCache case (isGlobalId fun, lookupVarEnv fun topAnns) of (True, Just topEntity) | let ty = coreTypeOf (topId topEntity) , let (fArgTys0,fResTy) = splitFunForallTy ty -- Take into account that clocks and stuff are split off from any product -- types containing them , let fArgTys1 = splitShouldSplit tcm $ rights fArgTys0 , length fArgTys1 == length args -> do argHWTys <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc)) fArgTys1 (argExprs, concat -> argDecls) <- unzip <$> mapM (\(e,t) -> mkExpr False Concurrent (NetlistId dstId t) e) (zip args fArgTys1) -- Filter void arguments, but make sure to render their declarations: let filteredTypeExprs = filter (not . isVoid . snd) (zip argExprs argHWTys) dstHWty <- unsafeCoreTypeToHWTypeM' $(curLoc) fResTy -- TODO: The commented code fetches the function definition from the -- set of global bindings and uses it to replicate the port names -- of it. However, this does rely on the binding actually being -- present in the binding map. This isn't the case, as only -- the current top entity (and its dependencies, stopping at other -- top entities) are present. We can't add the non-normalized -- version, as this logic relies on 'splitArguments' having -- fired. Adding normalized versions would create a dependency -- between two top entities, defeating the ability to compile in -- parallel. -- -- One option is to split the normalization process into two -- chunks: preprocessing (e.g., 'splitArguments') and actually -- normalizing. This would ensure only minimal work is being done -- serially. -- -- The current workaround is to not rely on named arguments, using -- positional ones instead when instantiating a top entity. -- -- funTerm <- fmap bindingTerm . lookupVarEnv fun <$> Lens.use bindings -- -- expandedTopEntity <- -- case splitNormalized tcm <$> funTerm of -- Nothing -> error ("Internal error: could not find " <> show fun) -- Just (Left err) -> error ("Internal error: " <> show err) -- Just (Right (argIds, _binds, resId)) -> do -- argTys <- mapM (unsafeCoreTypeToHWTypeM $(curLoc)) (map coreTypeOf argIds) -- resTy <- unsafeCoreTypeToHWTypeM $(curLoc) (coreTypeOf resId) -- is <- Lens.use seenIds -- let topAnnM = topAnnotation topEntity -- pure (expandTopEntityOrErr is (zip argIds argTys) (resId, resTy) topAnnM) -- Generate ExpandedTopEntity, see TODO^ argTys <- mapM (unsafeCoreTypeToHWTypeM $(curLoc) . inferCoreTypeOf tcm) args resTy <- unsafeCoreTypeToHWTypeM $(curLoc) fResTy let ettArgs = (Nothing,) <$> argTys ettRes = (Nothing, resTy) expandedTopEntity <- expandTopEntityOrErrM ettArgs ettRes (topAnnotation topEntity) instDecls <- mkTopUnWrapper fun expandedTopEntity (dstId, dstHWty) filteredTypeExprs tickDecls return (argDecls ++ instDecls) | otherwise -> error $ $(curLoc) ++ "under-applied TopEntity: " ++ showPpr fun (True, Nothing) -> do normalized <- Lens.use bindings case lookupVarEnv fun normalized of Nothing -> error [I.i| Internal error: unknown normalized binder: #{showPpr fun} |] Just (Binding{bindingTerm}) -> do (_, Component compName compInps co _) <- preserveVarEnv $ genComponent fun let argTys = map (inferCoreTypeOf tcm) args argHWTys <- mapM coreTypeToHWTypeM' argTys (argExprs, concat -> argDecls) <- unzip <$> mapM (\(e,t) -> mkExpr False Concurrent (NetlistId dstId t) e) (zip args argTys) -- Filter void arguments, but make sure to render their declarations: let argTypeExprs = zip argHWTys (zip argExprs argTys) filteredTypeExprs = fmap snd $ filter (not . isVoidMaybe True . fst) argTypeExprs let compOutp = (\(_,x,_) -> x) <$> listToMaybe co if length filteredTypeExprs == length compInps then do (argExprs',argDecls') <- (second concat . unzip) <$> mapM (toSimpleVar dstId) filteredTypeExprs let inpAssigns = zipWith (\(i,t) e -> (Identifier i Nothing,In,t,e)) compInps argExprs' outpAssign = case compOutp of Nothing -> [] Just (id_,hwtype) -> [(Identifier id_ Nothing,Out,hwtype,Identifier dstId Nothing)] let instLabel0 = StrictText.concat [Id.toText compName, "_", Id.toText dstId] instLabel1 <- fromMaybe instLabel0 <$> Lens.view setName instLabel2 <- affixName instLabel1 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 argsFiltered :: [Expr] argsFiltered = map fst filteredTypeExprs in error [I.i| Under-applied normalized function at component #{compName}: #{showPpr fun} Core: #{showPpr bindingTerm} Applied to arguments: #{showPpr args} Applied to filtered arguments: #{argsFiltered} Component inputs: #{compInps} |] _ -> case args of [] -> do -- TODO: Figure out what to do with zero-width constructs assn <- contAssign dstId (Identifier (Id.unsafeFromCoreId fun) Nothing) pure [assn] _ -> error [I.i| Netlist generation encountered a local function. This should not happen. Function: #{showPpr fun} Arguments: #{showPpr args} Posssible user issues: * A top entity has an higher-order argument, e.g (Int -> Int) or Maybe (Int -> Int) Possible internal compiler issues: * 'bindOrLiftNonRep' failed to fire * 'caseCon' failed to eliminate something of a type such as "Maybe (Int -> Int)" |] toSimpleVar :: Identifier -> (Expr,Type) -> NetlistMonad (Expr,[Declaration]) toSimpleVar _ (e@(Identifier _ Nothing),_) = return (e,[]) toSimpleVar dstId (e,ty) = do argNm <- Id.suffix dstId "fun_arg" hTy <- unsafeCoreTypeToHWTypeM' $(curLoc) ty 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 => Bool -- ^ Treat BlackBox expression as declaration -> DeclarationType -- ^ Should the returned declarations be concurrent or sequential? -> NetlistId -- ^ Name hint for the id to (potentially) assign the result to -> Term -- ^ Term to convert to an expression -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations mkExpr _ _ _ (stripTicks -> Core.Literal l) = do iw <- Lens.view intWidth case l of IntegerLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, []) IntLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, []) 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), []) NaturalLiteral n -> return (HW.Literal (Just (Unsigned iw,iw)) $ NumLit n, []) #if MIN_VERSION_base(4,15,0) ByteArrayLiteral (ByteArray ba) -> return (HW.Literal Nothing (NumLit (IP ba)),[]) #else ByteArrayLiteral (ByteArray ba) -> return (HW.Literal Nothing (NumLit (Jp# (BN# ba))),[]) #endif StringLiteral s -> return (HW.Literal Nothing $ StringLit s, []) mkExpr bbEasD declType bndr app = let (appF,args,ticks) = collectArgsTicks app (tmArgs,tyArgs) = partitionEithers args in withTicks ticks $ \tickDecls -> do hwTys <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc)) (netlistTypes bndr) (_,sp) <- Lens.use curCompNm let hwTyA = case hwTys of hwTy:_ -> hwTy _ -> error ("internal error: unable to extract sufficient hwTys from: " <> show bndr) case appF of 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 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 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 argNm hwTyA : decls) Case scrut ty' [alt] -> mkProjection bbEasD bndr scrut ty' alt 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 (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 argNm hwTyA Nothing:decls) Letrec binders body -> do netDecls <- concatMapM mkNetDecl 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) -- | Generate an expression that projects a field out of a data-constructor. -- -- Works for both product types, as sum-of-product types. mkProjection :: Bool -- ^ Projection must bind to a simple variable -> NetlistId -- ^ Name hint for the signal to which the projection is (potentially) assigned -> Term -- ^ The subject/scrutinee of the projection -> Type -- ^ The type of the result -> Alt -- ^ The field to be projected -> NetlistMonad (Expr, [Declaration]) mkProjection mkDec bndr scrut altTy alt@(pat,v) = do tcm <- Lens.view tcCache let scrutTy = inferCoreTypeOf tcm scrut e = Case scrut scrutTy [alt] (_,sp) <- Lens.use curCompNm varTm <- case v of (Var n) -> return n _ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: RHS of case-projection is not a variable:\n\n" ++ showPpr e) Nothing) sHwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy vHwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) altTy scrutRendered <- do scrutNm <- netlistId1 Id.next (\b -> Id.suffix (Id.unsafeFromCoreId b) "projection") bndr (scrutExpr,newDecls) <- mkExpr False Concurrent (NetlistId scrutNm scrutTy) scrut case scrutExpr of Identifier newId modM -> pure (Right (newId, modM, newDecls)) Noop -> -- Scrutinee was a zero-width / void construct. We need to render its -- declarations, but it's no use assigning it to a new variable. -- TODO: Figure out whether we need to render alternatives too. -- TODO: seems useless? pure (Left newDecls) _ -> do 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 = Id.unsafeFromCoreId varTm modifier <- case pat of DataPat dc exts tms -> do let tms' = if bindsExistentials exts tms then throw (ClashException sp ($(curLoc) ++ "Not in normal form: Pattern binds existential variables:\n\n" ++ showPpr e) Nothing) else tms argHWTys <- mapM coreTypeToHWTypeM' (map coreTypeOf tms) let tmsBundled = zip argHWTys tms' tmsFiltered = filter (maybe False (not . isVoid) . fst) tmsBundled tmsFiltered' = map snd tmsFiltered case elemIndex varTm {varType = altTy} tmsFiltered' of Nothing -> pure Nothing Just fI | sHwTy /= vHwTy -> pure $ nestModifier modM (Just (Indexed (sHwTy,dcTag dc - 1,fI))) -- When element and subject have the same HW-type, -- then the projections is just the identity | otherwise -> pure $ nestModifier modM (Just (DC (Void Nothing,0))) _ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection:\n\n" ++ showPpr e) Nothing) let extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier case bndr of NetlistId scrutNm _ | mkDec -> do scrutNm' <- Id.next scrutNm scrutDecl <- mkInit Concurrent Cont scrutNm' vHwTy extractExpr return (Identifier scrutNm' Nothing, scrutDecl ++ decls) MultiId {} -> error "mkProjection: MultiId" _ -> return (extractExpr,decls) where nestModifier Nothing m = m nestModifier m Nothing = m nestModifier (Just m1) (Just m2) = Just (Nested m1 m2) -- | Generate an expression for a DataCon application occurring on the RHS of a let-binder mkDcApplication :: HasCallStack => 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 -- ^ Name hint for result id -> DataCon -- ^ Applied DataCon -> [Term] -- ^ DataCon Arguments -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations 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 (Id.unsafeFromCoreId b) "_dc_arg") bndr argHWTys <- mapM coreTypeToHWTypeM' argTys (argExprs, concat -> argDecls) <- unzip <$> mapM (\(e,t) -> mkExpr False declType (NetlistId argNm t) e) (zip args argTys) -- Filter void arguments, but make sure to render their declarations: let filteredTypeExprDecls = filter (not . isVoidMaybe True . fst) (zip argHWTys argExprs) (hWTysFiltered, argExprsFiltered) = unzip filteredTypeExprDecls fmap (,argDecls) $! case (hWTysFiltered,argExprsFiltered) of -- Is the DC just a newtype wrapper? ([Just argHwTy],[argExpr]) | argHwTy == dstHType -> return (HW.DataCon dstHType (DC (Void Nothing,-1)) [argExpr]) _ -> case dstHType of SP _ dcArgPairs -> do let dcI = dcTag dc - 1 dcArgs = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI case compare (length dcArgs) (length argExprsFiltered) of EQ -> return (HW.DataCon dstHType (DC (dstHType,dcI)) argExprsFiltered) LT -> error $ $(curLoc) ++ "Over-applied constructor" GT -> error $ $(curLoc) ++ "Under-applied constructor" Product _ _ dcArgs -> case compare (length dcArgs) (length argExprsFiltered) of EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprsFiltered) LT -> error $ $(curLoc) ++ "Over-applied constructor" GT -> error $ $(curLoc) ++ "Under-applied constructor" CustomProduct _ _ _ _ dcArgs -> case compare (length dcArgs) (length argExprsFiltered) of EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprsFiltered) LT -> error $ $(curLoc) ++ "Over-applied constructor" GT -> error $ $(curLoc) ++ "Under-applied constructor" Sum _ _ -> return (HW.DataCon dstHType (DC (dstHType,dcTag dc - 1)) []) CustomSP _ _ _ dcArgsTups -> do -- Safely get item from list, or err with note let dcI = dcTag dc - 1 let note = $(curLoc) ++ "No DC with tag: " ++ show dcI let argTup = indexNote note dcArgsTups dcI let (_, _, dcArgs) = argTup case compare (length dcArgs) (length argExprsFiltered) of EQ -> return (HW.DataCon dstHType (DC (dstHType, dcI)) argExprsFiltered) LT -> error $ $(curLoc) ++ "Over-applied constructor" GT -> error $ $(curLoc) ++ "Under-applied constructor" CustomSum _ _ _ _ -> return (HW.DataCon dstHType (DC (dstHType, dcTag dc - 1)) []) Enable _ -> case argExprsFiltered of [x] -> return (HW.DataCon dstHType (DC (dstHType,dcTag dc - 1)) [x]) _ -> error $ $(curLoc) ++ "unexpected arguments to Enable: " ++ show argExprsFiltered Bool -> let dc' = case dcTag dc of 1 -> HW.Literal Nothing (BoolLit False) 2 -> HW.Literal Nothing (BoolLit True) tg -> error $ $(curLoc) ++ "unknown bool literal: " ++ showPpr dc ++ "(tag: " ++ show tg ++ ")" in return dc' Vector 0 _ -> return (HW.DataCon dstHType VecAppend []) Vector 1 _ -> case argExprsFiltered of [e] -> return (HW.DataCon dstHType VecAppend [e]) _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showPpr args Vector _ _ -> case argExprsFiltered of [e1,e2] -> return (HW.DataCon dstHType VecAppend [e1,e2]) _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showPpr args MemBlob _ _ -> case compare 6 (length argExprsFiltered) of EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprsFiltered) LT -> error $ $(curLoc) ++ "Over-applied constructor" GT -> error $ $(curLoc) ++ "Under-applied constructor" RTree 0 _ -> case argExprsFiltered of [e] -> return (HW.DataCon dstHType RTreeAppend [e]) _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `LR`: " ++ showPpr args RTree _ _ -> case argExprsFiltered of [e1,e2] -> return (HW.DataCon dstHType RTreeAppend [e1,e2]) _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `BR`: " ++ showPpr args String -> let dc' = case dcTag dc of 1 -> HW.Literal Nothing (StringLit "") _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,dcTag dc,args,argHWTys) in return dc' Void {} -> return Noop Signed _ #if MIN_VERSION_base(4,15,0) | dcNm == "GHC.Num.Integer.IS" #else | dcNm == "GHC.Integer.Type.S#" #endif , (a:_) <- argExprsFiltered -> pure a -- ByteArray# are non-translatable / void, except when they're literals #if MIN_VERSION_base(4,15,0) | dcNm == "GHC.Num.Integer.IP" #else | dcNm == "GHC.Integer.Type.Jp#" #endif , (a@(HW.Literal Nothing (NumLit _)):_) <- argExprs -> pure a #if MIN_VERSION_base(4,15,0) | dcNm == "GHC.Num.Integer.IN" #else | dcNm == "GHC.Integer.Type.Jn#" #endif -- ByteArray# are non-translatable / void, except when they're literals , (HW.Literal Nothing (NumLit i):_) <- argExprs -> pure (HW.Literal Nothing (NumLit (negate i))) Unsigned _ #if MIN_VERSION_base(4,15,0) | dcNm == "GHC.Num.Natural.NS" #else | dcNm == "GHC.Natural.NatS#" #endif , (a:_) <- argExprsFiltered -> pure a #if MIN_VERSION_base(4,15,0) | dcNm == "GHC.Num.Natural.NB" #else | dcNm == "GHC.Natural.NatJ#" #endif -- ByteArray# are non-translatable / void, except when they're literals , (a@(HW.Literal Nothing (NumLit _)):_) <- argExprs -> pure a _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys) -- Handle MultiId assignment mkDcApplication declType dstHTypes (MultiId argNms) _ args = do tcm <- Lens.view tcCache let argTys = map (inferCoreTypeOf tcm) args argHWTys <- mapM coreTypeToHWTypeM' argTys -- Filter out the arguments of hwtype `Void` and only translate -- them to the intermediate HDL afterwards let argsBundled = zip argHWTys (zipEqual (map CoreId argNms) args) (_hWTysFiltered,argsFiltered) = unzip (filter (maybe True (not . isVoid) . fst) argsBundled) (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (uncurry (mkExpr False declType)) argsFiltered if length dstHTypes == length argExprs then do assns <- mapMaybeM (\case (_,Noop) -> pure Nothing (dstId,e) -> let nm = netlistId1 id Id.unsafeFromCoreId dstId in case e of Identifier nm0 Nothing | 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" clash-lib-1.8.1/src/Clash/Netlist.hs-boot0000644000000000000000000000362207346545000016313 0ustar0000000000000000{-| Copyright : (C) 2015-2016, University of Twente 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} {-# LANGUAGE CPP #-} module Clash.Netlist (genComponent ,mkExpr ,mkDcApplication ,mkDeclarations ,mkDeclarations' ,mkNetDecl ,mkProjection ,mkSelection ,mkFunApp ) where import Data.List.NonEmpty (NonEmpty) import Clash.Core.DataCon (DataCon) import Clash.Core.Term (Alt,LetBinding,Term) import Clash.Core.Type (Type) import Clash.Core.Var (Id) import Clash.Netlist.Types (Expr, HWType, Identifier, NetlistMonad, Declaration, NetlistId, DeclarationType, ComponentMeta, Component) import GHC.Stack (HasCallStack) genComponent :: HasCallStack => Id -> NetlistMonad (ComponentMeta, Component) mkExpr :: HasCallStack => Bool -> DeclarationType -> NetlistId -> Term -> NetlistMonad (Expr,[Declaration]) mkDcApplication :: HasCallStack => DeclarationType -> [HWType] -> NetlistId -> DataCon -> [Term] -> NetlistMonad (Expr,[Declaration]) mkProjection :: Bool -> NetlistId -> Term -> Type -> Alt -> NetlistMonad (Expr, [Declaration]) mkSelection :: DeclarationType -> NetlistId -> Term -> Type -> NonEmpty Alt -> [Declaration] -> NetlistMonad [Declaration] mkNetDecl :: LetBinding -> NetlistMonad [Declaration] mkDeclarations :: HasCallStack => Id -> Term -> NetlistMonad [Declaration] mkDeclarations' :: HasCallStack => DeclarationType -> Id -> Term -> NetlistMonad [Declaration] mkFunApp :: HasCallStack => Identifier -- ^ LHS of the let-binder -> Id -- ^ Name of the applied function -> [Term] -- ^ Function arguments -> [Declaration] -- ^ Tick declarations -> NetlistMonad [Declaration] clash-lib-1.8.1/src/Clash/Netlist/0000755000000000000000000000000007346545000015013 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Netlist/BlackBox.hs0000644000000000000000000017506207346545000017047 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} {-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017 , Google Inc., 2021-2023, QBayLogic B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Functions to create BlackBox Contexts and fill in BlackBox templates -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Netlist.BlackBox where import Control.Exception (throw) import Control.Lens ((%=)) import qualified Control.Lens as Lens import Control.Monad (when, replicateM, zipWithM) import Control.Monad.Extra (concatMapM) import Control.Monad.IO.Class (liftIO) 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) import Data.Monoid (Ap(getAp)) import qualified Data.Set as Set import Data.Text.Lazy (fromStrict) import qualified Data.Text.Lazy as Text import Data.Text (unpack) import qualified Data.Text as TextS import Data.Text.Extra import GHC.Stack (HasCallStack, callStack, prettyCallStack) import qualified System.Console.ANSI as ANSI import System.Console.ANSI ( hSetSGR, SGR(SetConsoleIntensity, SetColor), Color(Magenta, Red) , ConsoleIntensity(BoldIntensity), ConsoleLayer(Foreground), ColorIntensity(Vivid)) import System.IO (hPutStrLn, stderr, hFlush, hIsTerminalDevice) #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(..)) #endif import Clash.Annotations.Primitive ( PrimitiveGuard(HasBlackBox, DontTranslate) , PrimitiveWarning(WarnNonSynthesizable, WarnAlways) , extractPrim, HDL(VHDL)) import Clash.Core.DataCon as D (dcTag) import Clash.Core.FreeVars (freeIds) import Clash.Core.HasType import Clash.Core.Literal as L (Literal (..)) import Clash.Core.Name (Name (..), mkUnsafeSystemName) import qualified Clash.Netlist.Id as Id import Clash.Core.Pretty (showPpr) import Clash.Core.Subst (extendIdSubst, mkSubst, substTm) import Clash.Core.Term as C (IsMultiPrim (..), PrimInfo (..), Term (..), WorkInfo (..), collectArgs, collectArgsTicks, collectBndrs, mkApps, PrimUnfolding(..)) import Clash.Core.TermInfo import Clash.Core.Type as C (Type (..), ConstTy (..), TypeView (..), mkFunTy, splitFunTys, tyView) import Clash.Core.TyCon as C (TyConMap, tyConDataCons) import Clash.Core.Util (inverseTopSortLetBindings, splitShouldSplit) import Clash.Core.Var as V (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)) import Clash.Netlist.BlackBox.Types as B import Clash.Netlist.BlackBox.Util as B import Clash.Netlist.Types as N import Clash.Netlist.Util as N import Clash.Normalize.Primitives (removedArg) import Clash.Primitives.Types as P import qualified Clash.Primitives.Util as P import Clash.Signal.Internal (ActiveEdge (..)) import Clash.Util import qualified Clash.Util.Interpolate as I -- | Emits (colorized) warning to stderr warn :: ClashOpts -> String -> IO () warn opts msg = do -- TODO: Put in appropriate module useColor <- case opt_color opts of Always -> return True Never -> return False Auto -> hIsTerminalDevice stderr hSetSGR stderr [SetConsoleIntensity BoldIntensity] case opt_werror opts of True -> do when useColor $ hSetSGR stderr [SetColor Foreground Vivid Red] throw (ClashException noSrcSpan msg Nothing) False -> do when useColor $ hSetSGR stderr [SetColor Foreground Vivid Magenta] hPutStrLn stderr $ "[WARNING] " ++ msg hSetSGR stderr [ANSI.Reset] hFlush stderr -- | Generate the context for a BlackBox instantiation. mkBlackBoxContext :: HasCallStack => TextS.Text -- ^ Blackbox function name -> [Id] -- ^ Identifiers binding the primitive/blackbox application -> [Either Term Type] -- ^ Arguments of the primitive/blackbox application -> NetlistMonad (BlackBoxContext,[Declaration]) mkBlackBoxContext bbName resIds args@(lefts -> termArgs) = do -- Make context inputs let 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 (funs,funDecls) <- mapAccumLM (addFunction (map coreTypeOf resIds)) IntMap.empty (zip termArgs [0..]) -- Make context result let ress = map (flip Identifier Nothing) resNms lvl <- Lens.use curBBlvl (nm,_) <- Lens.use curCompNm -- Set "context name" to value set by `Clash.Magic.setName`, default to the -- name of the closest binder ctxName1 <- fromMaybe (map Id.toText resNms) . fmap pure <$> Lens.view setName -- Update "context name" with prefixes and suffixes set by -- `Clash.Magic.prefixName` and `Clash.Magic.suffixName` ctxName2 <- mapM affixName ctxName1 return ( Context bbName (zip ress resTys) imps funs [] lvl nm (listToMaybe ctxName2) , concat impDecls ++ concat funDecls ) where addFunction resTys im (arg,i) = do tcm <- Lens.view tcCache if isFun tcm arg then do -- Only try to calculate function plurality when primitive actually -- exists. Here to prevent crashes on __INTERNAL__ primitives. prim <- HashMap.lookup bbName <$> Lens.view primitives funcPlurality <- case extractPrim <$> prim of Just (Just p) -> P.getFunctionPlurality p args resTys i _ -> pure 1 curBBlvl Lens.+= 1 (fs,ds) <- case resIds of (resId:_) -> unzip <$> replicateM funcPlurality (mkFunInput bbName resId arg) _ -> error "internal error: insufficient resIds" curBBlvl Lens.-= 1 let im' = IntMap.insert i fs im return (im', concat ds) else return (im, []) prepareBlackBox :: TextS.Text -> BlackBox -> BlackBoxContext -> NetlistMonad (BlackBox,[Declaration]) prepareBlackBox _pNm templ bbCtx = case verifyBlackBoxContext bbCtx templ of Nothing -> do (t2,decls) <- onBlackBox (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 let err1 = concat [ "Couldn't instantiate blackbox for " , 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 (Data _, args) -> all (either isLiteral (const True)) args (Prim _, args) -> all (either isLiteral (const True)) args (C.Literal _,_) -> True _ -> False mkArgument :: TextS.Text -- ^ Blackbox function name -> Identifier -- ^ LHS of the original let-binder. Is used as a name hint to generate new -- names in case the argument is a declaration. -> Int -- ^ Argument n (zero-indexed). Used for error message. -> Term -> NetlistMonad ( (Expr,HWType,Bool) , [Declaration] ) mkArgument bbName bndr nArg e = do tcm <- Lens.view tcCache let ty = inferCoreTypeOf tcm e iw <- Lens.view intWidth hwTyM <- fmap stripFiltered <$> N.termHWTypeM e let eTyMsg = "(" ++ showPpr e ++ " :: " ++ showPpr ty ++ ")" ((e',t,l),d) <- case hwTyM of Nothing | (Prim p,_) <- collectArgs e , primName p == showt 'removedArg -> return ((Identifier (Id.unsafeMake (showt 'removedArg)) Nothing, Void Nothing, False), []) | otherwise -> return ((error ($(curLoc) ++ "Forced to evaluate untranslatable type: " ++ eTyMsg), Void Nothing, False), []) Just hwTy -> case collectArgsTicks e of (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), [],_) -> return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[]) (C.Literal (WordLiteral w), [],_) -> return ((N.Literal (Just (Unsigned iw,iw)) (N.NumLit w),hwTy,True),[]) (C.Literal (CharLiteral c), [],_) -> return ((N.Literal (Just (Unsigned 21,21)) (N.NumLit . toInteger $ ord c),hwTy,True),[]) (C.Literal (StringLiteral s),[],_) -> return ((N.Literal Nothing (N.StringLit s),hwTy,True),[]) (C.Literal (Int64Literal i), [],_) -> 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 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 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 return ((projection,hwTy,False),decls) (Let _bnds _term, [], _ticks) -> do (exprN, letDecls) <- mkExpr False Concurrent (NetlistId bndr ty) e return ((exprN,hwTy,False),letDecls) _ -> do let errMsg = [I.i| Forced to evaluate unexpected function argument: #{eTyMsg} in 'mkArgument' for argument #{nArg} of blackbox #{show bbName}. |] return ((Identifier (error ($(curLoc) ++ errMsg)) Nothing, hwTy, False), []) return ((e',t,l),d) -- | Extract a compiled primitive from a guarded primitive. Emit a warning if -- the guard wants to, or fail entirely. extractPrimWarnOrFail :: HasCallStack => TextS.Text -- ^ Name of primitive -> NetlistMonad CompiledPrimitive extractPrimWarnOrFail nm = do prim <- HashMap.lookup nm <$> Lens.view primitives case prim of Just (HasBlackBox warnings compiledPrim) -> -- See if we need to warn the user if null warnings then return compiledPrim else go warnings compiledPrim Just DontTranslate -> do -- We need to error because we encountered a primitive the user -- explicitly requested not to translate (_,sp) <- Lens.use curCompNm let msg = $(curLoc) ++ "Clash was forced to translate '" ++ unpack nm ++ "', but this value was marked with DontTranslate. Did you forget" ++ " to include a blackbox for one of the constructs using this?" ++ (if debugIsOn then "\n\n" ++ prettyCallStack callStack ++ "\n\n" else []) throw (ClashException sp msg Nothing) Nothing -> do -- Blackbox requested, but no blackbox found at all! (_,sp) <- Lens.use curCompNm let msg = $(curLoc) ++ "No blackbox found for: " ++ unpack nm ++ ". Did you forget to include directories containing " ++ "primitives? You can use '-i/my/prim/dir' to achieve this." ++ (if debugIsOn then "\n\n" ++ prettyCallStack callStack ++ "\n\n" else []) throw (ClashException sp msg Nothing) where go :: [PrimitiveWarning] -> CompiledPrimitive -> NetlistMonad CompiledPrimitive go ((WarnAlways warning):ws) cp = do opts <- Lens.view clashOpts let primWarn = opt_primWarn opts seen <- Set.member nm <$> Lens.use seenPrimitives when (primWarn && not seen) $ liftIO $ warn opts $ "Dubious primitive instantiation for " ++ unpack nm ++ ": " ++ warning ++ " (disable with -fclash-no-prim-warn)" go ws cp go ((WarnNonSynthesizable warning):ws) cp = do isTB <- Lens.use isTestBench if isTB then go ws cp else go ((WarnAlways warning):ws) cp go [] cp = do seenPrimitives %= Set.insert nm return cp mkPrimitive :: Bool -- ^ 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 -- ^ Primitive info -> [Either Term Type] -- ^ Arguments -> [Declaration] -- ^ Tick declarations -> NetlistMonad (Expr,[Declaration]) mkPrimitive bbEParen bbEasD declType dst pInfo args tickDecls = go =<< extractPrimWarnOrFail (primName pInfo) where tys = netlistTypes dst ty = fromMaybe (error "mkPrimitive") (listToMaybe tys) go :: CompiledPrimitive -> NetlistMonad (Expr, [Declaration]) go = \case P.BlackBoxHaskell bbName wf _usedArgs multiResult funcName (_fHash, func) -> do bbFunRes <- func bbEasD (primName pInfo) args tys case bbFunRes of Left err -> do -- Blackbox template function returned an error: let err' = unwords [ $(curLoc) ++ "Could not create blackbox" , "template using", show funcName, "for" , show bbName ++ ".", "Function reported: \n\n" , err ] (_,sp) <- Lens.use curCompNm throw (ClashException sp err' Nothing) Right (BlackBoxMeta {..}, bbTemplate) -> -- Blackbox template generation successful. Rerun 'go', but this time -- around with a 'normal' @BlackBox@ go (P.BlackBox bbName wf bbRenderVoid multiResult bbKind () bbOutputUsage bbLibrary bbImports bbFunctionPlurality bbIncludes bbResultNames bbResultInits bbTemplate) -- See 'setupMultiResultPrim' in "Clash.Normalize.Transformations": P.BlackBox {name="c$multiPrimSelect"} -> pure (Noop, []) p@P.BlackBox {multiResult=True, name, template} -> do -- Multi result primitives assign their results to signals -- provided as arguments. Hence, we ignore any declarations -- from 'resBndr1'. tcm <- Lens.view tcCache let (args1, resArgs) = splitMultiPrimArgs (multiPrimInfo' tcm pInfo) args (bbCtx, ctxDcls) <- mkBlackBoxContext (primName pInfo) resArgs args1 (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,outputUsage}) -> case kind of TDecl -> do resM <- resBndr1 True dst case resM of Just (dst',dstNm,dstDecl) -> do (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) [dst'] args (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 Nothing | RenderVoid <- renderVoid p -> do -- TODO: We should probably 'mkBlackBoxContext' to accept empty lists let dst1 = mkLocalId ty (mkUnsafeSystemName "__VOID_TDECL_NOOP__" 0) (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) [dst1] args (templ,templDecl) <- prepareBlackBox pNm template bbCtx let bbDecl = N.BlackBoxD pNm (libraries p) (imports p) (includes p) templ bbCtx return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl]) -- Otherwise don't render them Nothing -> return (Noop,[]) TExpr -> do if bbEasD then do resM <- resBndr1 True dst case resM of Just (dst',dstNm,dstDecl) -> do (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) [dst'] args (bbTempl,templDecl) <- prepareBlackBox pNm template bbCtx 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 Nothing | RenderVoid <- renderVoid p -> do -- TODO: We should probably 'mkBlackBoxContext' to accept empty lists let dst1 = mkLocalId ty (mkUnsafeSystemName "__VOID_TEXPRD_NOOP__" 0) (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) [dst1] args (templ,templDecl) <- prepareBlackBox pNm template bbCtx let bbDecl = N.BlackBoxD pNm (libraries p) (imports p) (includes p) templ bbCtx return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl]) -- Otherwise don't render them Nothing -> return (Identifier (Id.unsafeMake "__VOID_TEXPRD__") Nothing,[]) else do resM <- resBndr1 False dst case resM of Just (dst',_,_) -> do (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) [dst'] args (bbTempl,templDecl0) <- prepareBlackBox pNm template bbCtx let templDecl1 = case primName pInfo of "Clash.Sized.Internal.BitVector.fromInteger#" | [N.Literal _ (NumLit _), N.Literal _ _, N.Literal _ _] <- extractLiterals bbCtx -> [] "Clash.Sized.Internal.BitVector.fromInteger##" | [N.Literal _ _, N.Literal _ _] <- extractLiterals bbCtx -> [] "Clash.Sized.Internal.Index.fromInteger#" | [N.Literal _ (NumLit _), N.Literal _ _] <- extractLiterals bbCtx -> [] "Clash.Sized.Internal.Signed.fromInteger#" | [N.Literal _ (NumLit _), N.Literal _ _] <- extractLiterals bbCtx -> [] "Clash.Sized.Internal.Unsigned.fromInteger#" | [N.Literal _ (NumLit _), N.Literal _ _] <- extractLiterals bbCtx -> [] _ -> templDecl0 return (BlackBoxE pNm (libraries p) (imports p) (includes p) bbTempl bbCtx bbEParen,ctxDcls ++ templDecl1) -- Render expression as a Noop when requested Nothing | RenderVoid <- renderVoid p -> do -- TODO: We should probably 'mkBlackBoxContext' to accept empty lists let dst1 = mkLocalId ty (mkUnsafeSystemName "__VOID_TEXPRE_NOOP__" 0) (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) [dst1] args (templ,templDecl) <- prepareBlackBox pNm template bbCtx let bbDecl = N.BlackBoxD pNm (libraries p) (imports p) (includes p) templ bbCtx return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl]) -- Otherwise don't render them Nothing -> return (Identifier (Id.unsafeMake "__VOID__") Nothing,[]) P.Primitive pNm _ _ | pNm == "GHC.Prim.tagToEnum#" -> do hwTy <- N.unsafeCoreTypeToHWTypeM' $(curLoc) ty case args of [Right (ConstTy (TyCon tcN)), Left (C.Literal (IntLiteral i))] -> do tcm <- Lens.view tcCache let dcs = tyConDataCons (UniqMap.find tcN tcm) dc = dcs !! fromInteger i (exprN,dcDecls) <- mkDcApplication declType [hwTy] dst dc [] return (exprN,dcDecls) [Right _, Left scrut] -> do tcm <- Lens.view tcCache let scrutTy = inferCoreTypeOf tcm scrut (scrutExpr,scrutDecls) <- mkExpr False Concurrent (NetlistId (Id.unsafeMake "c$tte_rhs") scrutTy) scrut case scrutExpr of Identifier id_ Nothing -> return (DataTag hwTy (Left id_),scrutDecls) _ -> do scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy tmpRhs <- Id.make "c$tte_rhs" 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 iw <- Lens.view intWidth return (N.Literal (Just (Signed iw,iw)) (NumLit $ toInteger $ dcTag dc - 1),[]) [Right _,Left scrut] -> do tcm <- Lens.view tcCache let scrutTy = inferCoreTypeOf tcm scrut scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy (scrutExpr,scrutDecls) <- mkExpr False Concurrent (NetlistId (Id.unsafeMake "c$dtt_rhs") scrutTy) scrut case scrutExpr of Identifier id_ Nothing -> return (DataTag scrutHTy (Right id_),scrutDecls) _ -> do tmpRhs <- Id.make "c$dtt_rhs" 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 resM <- resBndr1 True dst case resM of Just (_,dstNm,dstDecl) -> do tcm <- Lens.view tcCache mealyDecls <- collectMealy dstNm dst tcm (lefts args) return (Noop, dstDecl ++ mealyDecls) Nothing -> return (Noop,[]) | pNm == "Clash.Explicit.SimIO.bindSimIO#" -> do (expr,decls) <- collectBindIO dst (lefts args) resM <- resBndr True dst case resM of Just (_,dstNms,dstDecl) -> case expr of Noop -> return (Noop,decls) _ -> case dstNms of [dstNm] -> do declareUse (Proc Blocking) dstNm return ( Identifier dstNm Nothing , dstDecl ++ decls ++ [Assignment dstNm (Proc Blocking) expr]) _ -> error $ $(curLoc) ++ "bindSimIO: " ++ show resM _ -> return (Noop,decls) | pNm == "Clash.Explicit.SimIO.apSimIO#" -> do collectAppIO dst (lefts args) [] | pNm == "Clash.Explicit.SimIO.fmapSimIO#" -> do resM <- resBndr1 True dst case resM of 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 _ -> error "internal error: insufficient arguments" | pNm == "Clash.Explicit.SimIO.pureSimIO#" -> do (expr,decls) <- case lefts args of (arg:_) -> mkExpr False Sequential dst arg _ -> error "internal error: insufficient arguments" resM <- resBndr True dst case resM of Just (_,dstNms,dstDecl) -> case expr of Noop -> return (Noop,decls) _ -> case dstNms of [dstNm] -> do declareUse (Proc Blocking) dstNm return ( Identifier dstNm Nothing , dstDecl ++ decls ++ [Assignment dstNm (Proc Blocking) expr]) _ -> error "internal error" _ -> return (Noop,decls) | pNm == "GHC.Num.Integer.IS" -> do (expr,decls) <- case lefts args of (arg:_) -> mkExpr False Concurrent dst arg _ -> error "internal error: insufficient arguments" iw <- Lens.view intWidth return (N.DataCon (Signed iw) (DC (Void Nothing,-1)) [expr],decls) | pNm == "GHC.Num.Integer.IP" -> do (expr,decls) <- case lefts args of (arg:_) -> mkExpr False Concurrent dst arg _ -> error "internal error: insufficient arguments" case expr of N.Literal Nothing (NumLit _) -> return (expr,decls) _ -> error "non-constant ByteArray# not supported" | pNm == "GHC.Num.Integer.IN" -> do (expr,decls) <- case lefts args of (arg:_) -> mkExpr False Concurrent dst arg _ -> error "internal error: insufficient arguments" case expr of N.Literal Nothing (NumLit i) -> return (N.Literal Nothing (NumLit (negate i)),decls) _ -> error "non-constant ByteArray# not supported" | pNm == "GHC.Num.Natural.NS" -> do (expr,decls) <- case lefts args of (arg:_) -> mkExpr False Concurrent dst arg _ -> error "internal error: insufficient arguments" iw <- Lens.view intWidth return (N.DataCon (Unsigned iw) (DC (Void Nothing,-1)) [expr],decls) | pNm == "GHC.Num.Integer.NB" -> do (expr,decls) <- case lefts args of (arg:_) -> mkExpr False Concurrent dst arg _ -> error "internal error: insufficient arguments" case expr of N.Literal Nothing (NumLit _) -> return (expr,decls) _ -> error "non-constant ByteArray# not supported" | otherwise -> return (BlackBoxE "" [] [] [] (BBTemplate [Text $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]]) (emptyBBContext pNm) False,[]) -- Do we need to create a new identifier to assign the result? -- -- CoreId: No, this is an original LHS of a let-binder, and already has a -- corresponding NetDecl; unlike NetlistIds, it is not already -- assigned, it will be assigned by the BlackBox/Primitive. -- -- NetlistId: This is a derived (either from an CoreId or other NetlistId) -- identifier created in the NetlistMonad that's already being -- used in an assignment, i.e. we cannot assign it again. -- -- So if it is a declaration BlackBox (indicated by 'mkDec'), -- we will have to create a new NetlistId, create a NetDecl for -- it, and use this new NetlistId for the assignment inside the -- declaration BlackBox -- -- MultiId: This is like a CoreId, but it's split over multiple identifiers -- because it was originally of a product type where the element -- types should not be part of an aggregate type in the generated -- HDL (e.g. Clocks should not be part of an aggregate, because -- tools like verilator don't like it) resBndr :: Bool -- Do we need to create and declare a new identifier in case we're given -- a NetlistId? -> NetlistId -- CoreId/NetlistId/MultiId -> NetlistMonad (Maybe ([Id],[Identifier],[Declaration])) -- Nothing when the binder would have type `Void` resBndr mkDec dst' = do resHwTy <- case tys of (ty1:_) -> unsafeCoreTypeToHWTypeM' $(curLoc) ty1 _ -> error "internal error: insufficient types" if isVoid resHwTy then pure Nothing else case dst' 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' 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 [idDecl] -> return (Just ([id_],[nm2],[idDecl])) ids -> error [I.i| Unexpected nested use of multi result primitive. Ids: #{show ids} Multi primitive should only appear on the RHS of a let-binding. Please report this as a bug. |] CoreId dstR -> return (Just ([dstR], [Id.unsafeFromCoreId dstR], [])) MultiId ids -> return (Just (ids, map Id.unsafeFromCoreId ids, [])) -- Like resBndr, but fails on MultiId resBndr1 :: HasCallStack => Bool -> NetlistId -> NetlistMonad (Maybe (Id,Identifier,[Declaration])) resBndr1 mkDec dst' = resBndr mkDec dst' >>= \case Nothing -> pure Nothing Just ([id_],[nm_],decls) -> pure (Just (id_,nm_,decls)) _ -> error "internal error" -- | Turn a 'mealyIO' expression into a two sequential processes, one "initial" -- process for the starting state, and one clocked sequential process. collectMealy :: HasCallStack => Identifier -- ^ Identifier to assign the final result to -> NetlistId -- ^ Id to assign the final result to -> TyConMap -> [Term] -- ^ The arguments to 'mealyIO' -> NetlistMonad [Declaration] collectMealy dstNm dst tcm (kd:clk:mealyFun:mealyInit:mealyIn:_) = do let (lefts -> args0,res0) = collectBndrs mealyFun is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet res0 <> Lens.foldMapOf freeIds unitVarSet mealyInit <> 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 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 _ -> uniqAway is0 (mkLocalId (inferCoreTypeOf tcm e) (mkUnsafeSystemName "mealyres" 0)) in ([(u,e)], u) #if __GLASGOW_HASKELL__ >= 900 args1 = args0 #else -- Drop the 'State# World' argument args1 = init args0 #endif -- Take into account that the state argument is split over multiple -- binders because it contained types that are not allowed to occur in -- a HDL aggregate type mealyInitLength = length (splitShouldSplit tcm [inferCoreTypeOf tcm mealyInit]) (sArgs,iArgs) = splitAt mealyInitLength args1 -- Give all binders a unique name let sBindings = map (,mealyInit) sArgs ++ map (,mealyIn) iArgs ++ bs normE <- mkUniqueNormalized is0 Nothing ([], sBindings, res) case normE of -- We're not expecting any input or output wrappers (_,[],[],_,[],binders0,Just result) -> do let (sBinders,binders1) = splitAt (length sArgs) binders0 (iBinders,binders2) = splitAt (length iArgs) binders1 -- Get all the "original" let-bindings, without the above "mealyres". -- We don't want to make a NetDecl for it. bindersN = case res0 of Letrec _ (C.Var {}) -> binders2 _ -> init binders2 -- Create new net declarations for state-binders, input-binders, and all -- the "original" let-bindings in 'mealyFun' -- -- The first set is only assigned in the always block, so they must be -- 'reg' in Verilog terminology netDeclsSeq <- concatMapM mkNetDecl (sBinders ++ bindersN) -- The second set is assigned using concurrent assignment, so don't need -- to be 'reg' netDeclsInp <- concatMapM mkNetDecl iBinders -- If the 'mealyFun' was not a let-expression with a variable reference -- as a body then we used the LHS of the entire 'mealyIO' expression as -- a new let-binding; otherwise 'mkUniqueNormalized' would not work. -- -- However, 'mkUniqueNormalized' made a new unique name for that LHS, -- which is not what we want. We want to assign the last expression to the -- LHS of 'mealyIO'. let bindersE = case res0 of Letrec _ (C.Var {}) -> binders2 _ -> case dst of -- See above why we do this. CoreId u0 -> init binders2 ++ [(u0,snd (last binders2))] _ -> binders2 seqDecls <- concat <$> mapM (uncurry (mkDeclarations' Sequential)) bindersE -- When the body the let-expression of 'mealyFun' was variable reference, -- or in case we had to create a new identifier because the original LHS -- was not available: then we need to assign (resExpr,resDecls) <- case res0 of Letrec _ (C.Var {}) -> mkExpr False Concurrent dst (C.Var result) _ -> case dst of CoreId {} -> pure (Noop,[]) _ -> 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 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 = 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 -- ready before the ambient system starts sampling them. The clockGen code -- ensures that the "opposite" edge always comes first. kdTy <- unsafeCoreTypeToHWTypeM $(curLoc) (inferCoreTypeOf tcm kd) let edge = case stripVoid (stripFiltered kdTy) of KnownDomain _ _ Rising _ _ _ -> Falling KnownDomain _ _ Falling _ _ _ -> Rising _ -> error "internal error" (clkExpr,clkDecls) <- mkExpr False Concurrent (NetlistId (Id.unsafeMake "__MEALY_CLK__") (inferCoreTypeOf tcm clk)) clk -- collect the declarations related to the input let netDeclsInp1 = netDeclsInp ++ inpDeclsMisc -- Collate everything return (clkDecls ++ netDeclsSeq1 ++ netDeclsInp1 ++ argAssign ++ [ Seq [Initial (map SeqDecl (initDeclsOther ++ initAssign))] , Seq [AlwaysClocked edge clkExpr (map SeqDecl seqDeclsOther)] ] ++ resAssn) _ -> error "internal error" where isNet NetDecl' {} = True isNet _ = False collectMealy _ _ _ _ = error "internal error" -- | Collect the sequential declarations for 'bindIO' collectBindIO :: NetlistId -> [Term] -> NetlistMonad (Expr,[Declaration]) #if __GLASGOW_HASKELL__ >= 900 collectBindIO dst (m:Lam x q@e:_) = do #else collectBindIO dst (m:Lam x q@(Lam _ e):_) = do #endif tcm <- Lens.view tcCache (ds0,subst) <- collectAction tcm let qS = substTm "collectBindIO1" subst q case splitNormalized tcm qS of Right (args,bs0,res) -> do 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 (Id.unsafeFromCoreId result) Nothing, netDecls ++ ds0 ++ ds1) _ -> error "internal error" _ -> case substTm "collectBindIO2" subst e of Letrec {} -> error "internal error" (collectArgs -> (Prim p,args)) | primName p == "Clash.Explicit.SimIO.bindSimIO#" -> do (expr,ds1) <- collectBindIO dst (lefts args) return (expr, ds0 ++ ds1) eS -> do (expr,ds1) <- mkExpr False Sequential dst eS return (expr, ds0 ++ ds1) where collectAction tcm = case splitNormalized tcm m of Right (args,bs0,res) -> do 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 = 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))) _ -> error "internal error" _ -> do ([x'],s) <- mkUnique (mkSubst eInScopeSet) [x] netDecls <- concatMapM mkNetDecl [(x',m)] ds1 <- mkDeclarations' Sequential x' m return (netDecls ++ ds1,s) eInScopeSet = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet e) collectBindIO _ es = error ("internal error:\n" ++ showPpr es) -- | Collect the sequential declarations for 'appIO' collectAppIO :: NetlistId -> [Term] -> [Term] -> NetlistMonad (Expr,[Declaration]) collectAppIO dst (fun1:arg1:_) rest = case collectArgs fun1 of (Prim (PrimInfo "Clash.Explicit.SimIO.fmapSimIO#" _ _ _ _),(lefts -> (fun0:arg0:_))) -> do tcm <- Lens.view tcCache let argN = map (Left . unSimIO tcm) (arg0:arg1:rest) mkExpr False Sequential dst (mkApps fun0 argN) (Prim (PrimInfo "Clash.Explicit.SimIO.apSimIO#" _ _ _ _),(lefts -> args)) -> do collectAppIO dst args (arg1:rest) _ -> error ("internal error:\n" ++ showPpr (fun1:arg1:rest)) collectAppIO _ es _ = error ("internal error:\n" ++ showPpr es) -- | Unwrap the new-type wrapper for things of type SimIO, this is needed to -- allow applications of the `State# World` token to the underlying IO type. -- -- XXX: this is most likely needed because Ghc2Core that threw away the cast -- that this unwrapping; we should really start to support casts. unSimIO :: TyConMap -> Term -> Term unSimIO tcm arg = let argTy = inferCoreTypeOf tcm arg in case tyView argTy of TyConApp _ [tcArg] -> mkApps (Prim (PrimInfo "Clash.Explicit.SimIO.unSimIO#" (mkFunTy argTy tcArg) WorkNever SingleResult NoUnfolding)) [Left arg] _ -> error ("internal error:\n" ++ showPpr arg) -- | Create an template instantiation text and a partial blackbox content for an -- argument term, given that the term is a function. Errors if the term is not -- a function mkFunInput :: HasCallStack => 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]) ,Usage ,[BlackBoxTemplate] ,[BlackBoxTemplate] ,[((TextS.Text,TextS.Text),BlackBox)] ,BlackBoxContext) ,[Declaration]) mkFunInput parentName resId e = let (appE,args,ticks) = collectArgsTicks e in withTicks ticks $ \tickDecls -> do tcm <- Lens.view tcCache -- TODO: Rewrite this function to use blackbox functions. Right now it -- TODO: generates strings that are later parsed/interpreted again. Silly! templ <- case appE of Prim p -> do bb <- extractPrimWarnOrFail (primName p) case bb of P.BlackBox {..} -> pure (Left (kind,outputUsage,libraries,imports,includes,primName p,template)) P.Primitive pn _ pt -> error $ $(curLoc) ++ "Unexpected blackbox type: " ++ "Primitive " ++ show pn ++ " " ++ show pt P.BlackBoxHaskell{name=pName, multiResult=True} -> -- TODO: dev pointers error [I.i| Encountered multiresult primitive as a direct argument to another primitive. This should not happen. Encountered: #{pName} Please report this as an issue. |] P.BlackBoxHaskell{name=pName, functionName=fName, function=(_, func)} -> do -- Determine result type of this blackbox. If it's not a -- function, simply use its term type. let (_, resTy) = splitFunTys tcm (inferCoreTypeOf tcm e) bbhRes <- func True pName args [resTy] case bbhRes of Left err -> error $ $(curLoc) ++ show fName ++ " yielded an error: " ++ err Right (BlackBoxMeta{..}, template) -> pure $ Left ( bbKind, bbOutputUsage, bbLibrary, bbImports , bbIncludes, pName, template) Data dc -> do let eTy = inferCoreTypeOf tcm e (_,resTy) = splitFunTys tcm eTy resHTyM0 <- coreTypeToHWTypeM resTy let resHTyM1 = (\fHwty -> (stripFiltered fHwty, flattenFiltered fHwty)) <$> resHTyM0 case resHTyM1 of -- Special case where coreTypeToHWTypeM determined a type to -- be completely transparent. 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") 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 -- use the result of coreTypeToHWTypeM to figure out what the -- original indices are. Please see the documentation in -- Clash.Netlist.Util.mkADT for more information. Just (resHTy@(SP _ _), areVoids0) -> do let dcI = dcTag dc - 1 areVoids1 = indexNote ($(curLoc) ++ "No areVoids with index: " ++ show dcI) areVoids0 dcI 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") Cont dcApp return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), Cont)) -- CustomSP the same as SP, but with a user-defined bit -- level representation Just (resHTy@(CustomSP {}), areVoids0) -> do let dcI = dcTag dc - 1 areVoids1 = indexNote ($(curLoc) ++ "No areVoids with index: " ++ show dcI) areVoids0 dcI 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") 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") 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 -- safely ignore it: Just (resHTy@(Vector _ _), _areVoids) -> do 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") 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") 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") Cont dcApp return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), Cont)) Just (Void {}, _areVoids) -> return (error $ $(curLoc) ++ "Encountered Void in mkFunInput." ++ " This is a bug in Clash.") _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showPpr e C.Var fun -> do topAnns <- Lens.use topEntityAnns case lookupVarEnv fun topAnns of Just _ -> error $ $(curLoc) ++ "Cannot make function input for partially applied Synthesize-annotated: " ++ showPpr e _ -> do normalized <- Lens.use bindings case lookupVarEnv fun normalized of Just _ -> do (meta,N.Component compName compInps compOutps _) <- preserveVarEnv $ genComponent fun let ComponentMeta{cmWereVoids} = meta inpAssign (i, t) e' = (Identifier i Nothing, In, t, e') inpVar i = Id.unsafeMake ("~VAR[arg" <> showt i <> "][" <> showt i <> "]") inpVars = [Identifier (inpVar i) Nothing | i <- originalIndices cmWereVoids] inpAssigns = zipWith inpAssign compInps inpVars 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 (outpAssigns ++ inpAssigns) instDecl = InstDecl Entity Nothing [] compName instLabel [] portMap 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) either Left (Right . first (second (tickDecls ++))) <$> go is0 0 appE _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showPpr e let pNm = case appE of Prim p -> primName p _ -> "__INTERNAL__" (bbCtx,dcls) <- mkBlackBoxContext pNm [resId] args case templ of 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',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") 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") 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')) ,Cont ,[] ,[] ,[] ,bbCtx ) ,dcls ) ) templ' Right (decl,u) -> return ((Right decl,u,[],[],[],bbCtx),dcls) where goExpr app@(collectArgsTicks -> (C.Var fun,args@(_:_),ticks)) = do tcm <- Lens.view tcCache resTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (inferCoreTypeOf tcm app) let (tmArgs,tyArgs) = partitionEithers args if null tyArgs then withTicks ticks $ \tickDecls -> do resNm <- Id.make "result" appDecls <- mkFunApp resNm fun tmArgs tickDecls let assn = [ Assignment (Id.unsafeMake "~RESULT") Cont (Identifier resNm Nothing) , NetDecl Nothing resNm resTy ] nm <- Id.makeBasic "block" 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) goExpr e' = do 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") Cont appExpr nm <- if null appDecls then return (Id.unsafeMake "") else Id.makeBasic "block" return (Right ((nm,appDecls ++ [assn]), Cont)) go is0 n (Lam id_ e') = do lvl <- Lens.use curBBlvl let nm = TextS.concat ["~ARGN[",TextS.pack (show lvl),"][",TextS.pack (show n),"]"] v' = uniqAway is0 (modifyVarName (\v -> v {nameOcc = nm}) id_) subst = extendIdSubst (mkSubst is0) id_ (C.Var v') e'' = substTm "mkFunInput.goLam" subst e' is1 = extendInScopeSet is0 v' go is1 (n+(1::Int)) e'' go _ _ (C.Var v) = do 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") Cont projection nm <- if null decls then return (Id.unsafeMake "") else Id.makeBasic "projection" 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 (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), Cont)) go is0 _ e'@(Let{}) = do tcm <- Lens.view tcCache let normE = splitNormalized tcm e' (_,[],[],_,[],binders,resultM) <- case normE of Right norm -> mkUniqueNormalized is0 Nothing norm Left err -> error err case resultM of Just result -> do -- TODO: figure out what to do with multires blackboxes here netDecls <- concatMapM mkNetDecl $ binders decls <- concatMapM (uncurry mkDeclarations) binders nm <- Id.makeBasic "fun" 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") 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' go _ _ e'@(App {}) = goExpr e' go _ _ e'@(C.Data {}) = goExpr e' go _ _ e'@(C.Literal {}) = goExpr e' go _ _ e'@(Cast {}) = goExpr e' go _ _ e'@(Prim {}) = goExpr e' go _ _ e'@(TyApp {}) = goExpr e' go _ _ e'@(Case _ _ []) = error $ $(curLoc) ++ "Cannot make function input for case without alternatives: " ++ show e' go _ _ e'@(TyLam {}) = error $ $(curLoc) ++ "Cannot make function input for TyLam: " ++ show e' clash-lib-1.8.1/src/Clash/Netlist/BlackBox.hs-boot0000644000000000000000000000145507346545000020002 0ustar0000000000000000{-| Copyright : (C) 2019, Google Inc License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} module Clash.Netlist.BlackBox where import Data.Text (Text) import GHC.Stack (HasCallStack) import Clash.Core.Term (Term) import Clash.Core.Type (Type) import Clash.Core.Var (Id) import Clash.Netlist.Types (BlackBoxContext, Declaration, NetlistMonad) import Clash.Primitives.Types (CompiledPrimitive) extractPrimWarnOrFail :: HasCallStack => Text -> NetlistMonad CompiledPrimitive mkBlackBoxContext :: HasCallStack => Text -- ^ Blackbox function name -> [Id] -- ^ Identifiers binding the primitive/blackbox application -> [Either Term Type] -- ^ Arguments of the primitive/blackbox application -> NetlistMonad (BlackBoxContext,[Declaration]) clash-lib-1.8.1/src/Clash/Netlist/BlackBox/0000755000000000000000000000000007346545000016500 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Netlist/BlackBox/Parser.hs0000644000000000000000000001634407346545000020300 0ustar0000000000000000{-| 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. Parser definitions for BlackBox templates -} {-# LANGUAGE OverloadedStrings #-} module Clash.Netlist.BlackBox.Parser (runParse) where import Control.Applicative ((<|>)) import Data.Text.Lazy (Text, pack, unpack) import qualified Data.Text.Lazy as Text import Text.Trifecta hiding (Err) import Text.Trifecta.Delta import qualified Clash.Signal.Internal as Signal import Clash.Netlist.BlackBox.Types -- | Parse a text as a BlackBoxTemplate, returns a list of errors in case -- parsing fails runParse :: Text -> Result BlackBoxTemplate runParse = parseString (pBlackBoxD <* eof) (Directed "" 0 0 0 0) . unpack -- | Parse a BlackBoxTemplate (Declarations and Expressions) pBlackBoxD :: Parser BlackBoxTemplate pBlackBoxD = some pElement -- | Parse a single Template Element pElement :: Parser Element pElement = pTagD <|> Text <$> pText <|> Text <$> (pack <$> string "~ ") -- | Parse the Text part of a Template pText :: Parser Text pText = pack <$> some (satisfyRange '\000' '\125') pEdge :: Parser Signal.ActiveEdge pEdge = (pure Signal.Rising <* symbol "Rising") <|> (pure Signal.Falling <* symbol "Falling") -- | Parse a Declaration or Expression element pTagD :: Parser Element pTagD = IF <$> (symbol "~IF" *> pTagE) <*> (spaces *> (string "~THEN" *> pBlackBoxD)) <*> (string "~ELSE" *> option ([Text ""]) pBlackBoxD <* string "~FI") <|> Component <$> pDecl <|> pTagE -- | Parse a Declaration pDecl :: Parser Decl pDecl = Decl <$> (symbol "~INST" *> natural') <*> pure 0 <*> ((:) <$> pOutput <*> many pInput) <* string "~INST" -- | Parse the output tag of Declaration pOutput :: Parser (BlackBoxTemplate,BlackBoxTemplate) pOutput = symbol "~OUTPUT" *> symbol "<=" *> ((,) <$> (pBlackBoxE <* symbol "~") <*> pBlackBoxE) <* symbol "~" -- | Parse the input tag of Declaration pInput :: Parser (BlackBoxTemplate,BlackBoxTemplate) pInput = symbol "~INPUT" *> symbol "<=" *> ((,) <$> (pBlackBoxE <* symbol "~") <*> pBlackBoxE) <* symbol "~" -- | Parse an Expression element pTagE :: Parser Element pTagE = Result <$ string "~RESULT" <|> ArgGen <$> (string "~ARGN" *> brackets' natural') <*> brackets' natural' <|> Arg <$> (string "~ARG" *> brackets' natural') <|> Const <$> (string "~CONST" *> brackets' natural') <|> Lit <$> (string "~LIT" *> brackets' natural') <|> Name <$> (string "~NAME" *> brackets' natural') <|> ToVar <$> try (string "~VAR" *> brackets' pSigDorEmpty) <*> brackets' natural' <|> (Sym Text.empty) <$> (string "~SYM" *> brackets' natural') <|> Typ Nothing <$ string "~TYPO" <|> (Typ . Just) <$> try (string "~TYP" *> brackets' natural') <|> TypM Nothing <$ string "~TYPMO" <|> (TypM . Just) <$> (string "~TYPM" *> brackets' natural') <|> Err Nothing <$ string "~ERRORO" <|> (Err . Just) <$> (string "~ERROR" *> brackets' natural') <|> TypElem <$> (string "~TYPEL" *> brackets' pTagE) <|> IndexType <$> (string "~INDEXTYPE" *> brackets' pTagE) <|> CompName <$ string "~COMPNAME" <|> IncludeName <$> (string "~INCLUDENAME" *> brackets' natural') <|> Size <$> (string "~SIZE" *> brackets' pTagE) <|> Length <$> (string "~LENGTH" *> brackets' pTagE) <|> Depth <$> (string "~DEPTH" *> brackets' pTagE) <|> MaxIndex <$> (string "~MAXINDEX" *> brackets' pTagE) <|> FilePath <$> (string "~FILE" *> brackets' pTagE) <|> Gen <$> (True <$ string "~GENERATE") <|> Gen <$> (False <$ string "~ENDGENERATE") <|> (`SigD` Nothing) <$> (string "~SIGDO" *> brackets' pSigD) <|> SigD <$> (string "~SIGD" *> brackets' pSigD) <*> (Just <$> (brackets' natural')) <|> IW64 <$ string "~IW64" <|> CmpLE <$> try (string "~CMPLE" *> brackets' pTagE) <*> brackets' pTagE <|> (HdlSyn Vivado) <$ string "~VIVADO" <|> (HdlSyn Other) <$ string "~OTHERSYN" <|> (BV True) <$> (string "~TOBV" *> brackets' pSigD) <*> brackets' pTagE <|> (BV False) <$> (string "~FROMBV" *> brackets' pSigD) <*> brackets' pTagE <|> Sel <$> (string "~SEL" *> brackets' pTagE) <*> brackets' natural' <|> IsLit <$> (string "~ISLIT" *> brackets' natural') <|> IsVar <$> (string "~ISVAR" *> brackets' natural') <|> IsScalar <$> (string "~ISSCALAR" *> brackets' natural') <|> IsActiveHigh <$> (string "~ISACTIVEHIGH" *> brackets' natural') <|> IsActiveEnable <$> (string "~ISACTIVEENABLE" *> brackets' natural') <|> IsUndefined <$> (string "~ISUNDEFINED" *> brackets' natural') <|> StrCmp <$> (string "~STRCMP" *> brackets' pSigD) <*> 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 <|> DevNull <$> (string "~DEVNULL" *> brackets' pSigD) <|> And <$> (string "~AND" *> brackets' (commaSep pTagE)) <|> Vars <$> (string "~VARS" *> brackets' natural') -- Domain attributes: <|> Tag <$> (string "~TAG" *> brackets' natural') <|> Period <$> (string "~PERIOD" *> brackets' natural') <|> ActiveEdge <$> (string "~ACTIVEEDGE" *> brackets pEdge) <*> brackets' natural' <|> IsSync <$> (string "~ISSYNC" *> brackets' natural') <|> IsInitDefined <$> (string "~ISINITDEFINED" *> brackets' natural') <|> CtxName <$ string "~CTXNAME" <|> LongestPeriod <$ string "~LONGESTPERIOD" natural' :: TokenParsing m => m Int natural' = fmap fromInteger natural -- | Parse a bracketed text brackets' :: Parser a -> Parser a brackets' p = char '[' *> p <* char ']' -- | Parse the expression part of Blackbox Templates pBlackBoxE :: Parser BlackBoxTemplate pBlackBoxE = some pElemE -- | Parse an Expression or Text pElemE :: Parser Element pElemE = pTagE <|> Text <$> pText -- | Parse SigD pSigD :: Parser [Element] pSigD = some (pTagE <|> (Text (pack "[") <$ (pack <$> string "[\\")) <|> (Text (pack "]") <$ (pack <$> string "\\]")) <|> (Text <$> (pack <$> some (satisfyRange '\000' '\90'))) <|> (Text <$> (pack <$> some (satisfyRange '\94' '\125')))) pSigDorEmpty :: Parser [Element] pSigDorEmpty = pSigD <|> mempty clash-lib-1.8.1/src/Clash/Netlist/BlackBox/Types.hs0000644000000000000000000002152407346545000020144 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 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. Types used in BlackBox modules -} {-# LANGUAGE DeriveAnyClass #-} module Clash.Netlist.BlackBox.Types ( BlackBoxMeta(..) , emptyBlackBoxMeta , BlackBoxFunction , BlackBoxTemplate , TemplateKind (..) , Element(..) , Decl(..) , HdlSyn(..) , RenderVoid(..) ) where import Control.DeepSeq (NFData) import Data.Aeson (FromJSON) import Data.Binary (Binary) import Data.Hashable (Hashable) import Data.Text.Lazy (Text) import qualified Data.Text as S import GHC.Generics (Generic) import Clash.Core.Term (Term) import Clash.Core.Type (Type) import {-# SOURCE #-} Clash.Netlist.Types (BlackBox, NetlistMonad, Usage(Cont)) import qualified Clash.Signal.Internal as Signal -- | Whether this primitive should be rendered when its result type is void. -- Defaults to 'NoRenderVoid'. data RenderVoid = RenderVoid -- ^ Render blackbox, even if result type is void | NoRenderVoid -- ^ Don't render blackbox result type is void. Default for all blackboxes. deriving (Show, Generic, NFData, Binary, Eq, Hashable, FromJSON) data TemplateKind = TDecl | TExpr deriving (Show, Eq, Generic, NFData, Binary, Hashable) -- | See 'Clash.Primitives.Types.BlackBox' for documentation on this record's -- fields. (They are intentionally renamed to prevent name clashes.) data BlackBoxMeta = BlackBoxMeta { bbOutputUsage :: Usage , bbKind :: TemplateKind , bbLibrary :: [BlackBoxTemplate] , bbImports :: [BlackBoxTemplate] , bbFunctionPlurality :: [(Int, Int)] , bbIncludes :: [((S.Text, S.Text), BlackBox)] , bbRenderVoid :: RenderVoid , bbResultNames :: [BlackBox] , bbResultInits :: [BlackBox] } -- | Use this value in your blackbox template function if you do want to -- accept the defaults as documented in 'Clash.Primitives.Types.BlackBox'. emptyBlackBoxMeta :: BlackBoxMeta 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 -- when having a need for blackbox functions, ... TODO: docs type BlackBoxFunction = Bool -- ^ Indicates whether caller needs a declaration. If set, the function is -- still free to return an expression, but the caller will convert it to a -- declaration. -> S.Text -- ^ Name of primitive -> [Either Term Type] -- ^ Arguments -> [Type] -- ^ Result types -> NetlistMonad (Either String (BlackBoxMeta, BlackBox)) -- | A BlackBox Template is a List of Elements -- TODO: Add name of function for better error messages type BlackBoxTemplate = [Element] -- | Elements of a blackbox context. If you extend this list, make sure to -- update the following functions: -- -- - Clash.Netlist.BlackBox.Types.prettyElem -- - Clash.Netlist.BlackBox.Types.renderElem -- - Clash.Netlist.BlackBox.Types.renderTag -- - Clash.Netlist.BlackBox.Types.setSym -- - Clash.Netlist.BlackBox.Util.inputHole -- - Clash.Netlist.BlackBox.Types.getUsedArguments -- - Clash.Netlist.BlackBox.Types.usedVariables -- - Clash.Netlist.BlackBox.Types.verifyBlackBoxContext -- - Clash.Netlist.BlackBox.Types.walkElement data Element = Text !Text -- ^ Dumps given text without processing in HDL | Component !Decl -- ^ Component instantiation hole | Result -- ^ Output hole; | Arg !Int -- ^ Input hole | ArgGen !Int !Int -- ^ Like Arg, but its first argument is the scoping level. For use in -- in generated code only. | Const !Int -- ^ Like Arg, but input hole must be a constant. | Lit !Int -- ^ Like Arg, but input hole must be a literal | Name !Int -- ^ Name hole | ToVar [Element] !Int -- ^ Like Arg but only insert variable reference (creating an assignment -- elsewhere if necessary). | Sym !Text !Int -- ^ Symbol hole | Typ !(Maybe Int) -- ^ Type declaration hole | TypM !(Maybe Int) -- ^ Type root hole | Err !(Maybe Int) -- ^ Error value hole | TypElem !Element -- ^ Select element type from a vector-like type | CompName -- ^ Hole for the name of the component in which the blackbox is instantiated | IncludeName !Int | IndexType !Element -- ^ Index data type hole, the field is the (exclusive) maximum index | Size !Element -- ^ Size of a type hole | Length !Element -- ^ Length of a vector-like hole | Depth !Element -- ^ Depth of a tree hole | MaxIndex !Element -- ^ Max index into a vector-like type | FilePath !Element -- ^ Hole containing a filepath for a data file | Template [Element] [Element] -- ^ Create data file with contents | Gen !Bool -- ^ Hole marking beginning (True) or end (False) of a generative construct | IF !Element [Element] [Element] | And [Element] | IW64 -- ^ Hole indicating whether Int/Word/Integer are 64-Bit | CmpLE !Element !Element -- ^ Compare less-or-equal | HdlSyn HdlSyn -- ^ Hole indicating which synthesis tool we're generating HDL for | BV !Bool [Element] !Element -- ^ Convert to (True)/from(False) a bit-vector | Sel !Element !Int -- ^ Record selector of a type | IsLit !Int | IsVar !Int | IsScalar !Int -- ^ Whether element is scalar | IsActiveHigh !Int -- ^ Whether a domain's reset lines are active high. Errors if not applied to -- a @KnownDomain@ or @KnownConfiguration@. | Tag !Int -- ^ Tag of a domain. | Period !Int -- ^ Period of a domain. Errors if not applied to a @KnownDomain@ or -- @KnownConfiguration@. | LongestPeriod -- ^ 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@. | IsSync !Int -- ^ Whether a domain's reset lines are synchronous. Errors if not applied to -- a @KnownDomain@ or @KnownConfiguration@. | IsInitDefined !Int -- ^ Whether the initial (or "power up") value of memory elements in a domain -- are configurable to a specific value rather than unknown\/undefined. Errors -- if not applied to a @KnownDomain@ or @KnownConfiguration@. | IsActiveEnable !Int -- ^ Whether given enable line is active. More specifically, whether the -- enable line is NOT set to a constant 'True'. | IsUndefined !Int -- ^ Whether argument is undefined. E.g., an XException, error call, -- removed argument, or primitive that is undefined. This template tag will -- always return 0 (False) if `-fclash-aggressive-x-optimization-blackboxes` -- is NOT set. | StrCmp [Element] !Int | OutputUsage !Int | Vars !Int | GenSym [Element] !Int | Repeat [Element] [Element] -- ^ Repeat n times | DevNull [Element] -- ^ Evaluate but swallow output | SigD [Element] !(Maybe Int) | CtxName -- ^ The "context name", name set by `Clash.Magic.setName`, defaults to the -- name of the closest binder deriving (Show, Generic, NFData, Binary, Eq, Hashable) -- | Component instantiation hole. First argument indicates which function argument -- to instantiate. Third argument corresponds to output and input assignments, -- where the first element is the output assignment, and the subsequent elements -- are the consecutive input assignments. -- -- The LHS of the tuple is the name of the signal, while the RHS of the tuple -- is the type of the signal data Decl = Decl !Int -- ^ Argument position of the function to instantiate !Int -- ^ Subposition of function: blackboxes can request multiple instances -- to be rendered of their given functions. This subposition indicates the -- nth function instance to be rendered (zero-indexed). -- -- This is a hack: the proper solution would postpone rendering the -- function until the very last moment. The blackbox language has no way -- to indicate the subposition, and every ~INST will default its subposition -- to zero. Haskell blackboxes can use this data type. [(BlackBoxTemplate,BlackBoxTemplate)] -- ^ (name of signal, type of signal) deriving (Show, Generic, NFData, Binary, Eq, Hashable) data HdlSyn = Vivado | Quartus | Other deriving (Eq, Show, Read, Generic, NFData, Binary, Hashable) clash-lib-1.8.1/src/Clash/Netlist/BlackBox/Util.hs0000644000000000000000000014520007346545000017753 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2021-2023, QBayLogic B.V. 2022 , LUMI GUIDE FIETSDETECTIE B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Utilties to verify blackbox contexts against templates and rendering filled in templates -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Netlist.BlackBox.Util where import Control.Exception (throw) import Control.Lens (use, (%=), _1, _2, element, (^?)) import Control.Monad (forM, (<=<)) import Control.Monad.State (State, StateT (..), lift, gets) import Data.Bitraversable (bitraverse) import Data.Bool (bool) import Data.Coerce (coerce) import Data.Foldable (foldrM) import Data.Hashable (Hashable (..)) import qualified Data.HashMap.Strict as HashMap import qualified Data.IntMap as IntMap import Data.List (nub) import Data.List.Extra (indexMaybe) import Data.Maybe (mapMaybe, maybeToList, fromJust) import Data.Monoid (Ap(getAp)) import qualified Data.Text import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as Text #if MIN_VERSION_prettyprinter(1,7,0) import qualified Prettyprinter as PP #else import qualified Data.Text.Prettyprint.Doc as PP #endif import Data.Text.Prettyprint.Doc.Extra import GHC.Stack (HasCallStack) import System.FilePath (replaceBaseName, takeBaseName, takeFileName, (<.>)) import Text.Printf import Text.Read (readEither) import Text.Trifecta.Result hiding (Err) import Clash.Backend (Backend (..), DomainMap, Usage (..), AggressiveXOptBB(..), RenderEnums(..)) import Clash.Netlist.BlackBox.Parser import Clash.Netlist.BlackBox.Types import Clash.Netlist.Types (BlackBoxContext (..), Expr (..), HWType (..), Literal (..), Modifier (..), Declaration(BlackBoxD)) import qualified Clash.Netlist.Id as Id import qualified Clash.Netlist.Types as N import Clash.Netlist.Util (typeSize, isVoid, stripAttributes, stripVoid) import Clash.Signal.Internal (ResetKind(..), ResetPolarity(..), InitBehavior(..), VDomainConfiguration (..)) import Clash.Util import qualified Clash.Util.Interpolate as I import Clash.Annotations.Primitive (HDL(VHDL)) inputHole :: Element -> Maybe Int inputHole = \case Text _ -> Nothing Component _ -> Nothing Result -> Nothing Arg n -> pure n ArgGen _ n -> pure n Const n -> pure n Lit n -> pure n Name n -> pure n ToVar _ n -> pure n Sym _ _ -> Nothing Typ nM -> nM TypM nM -> nM Err nM -> nM TypElem _ -> Nothing CompName -> Nothing IncludeName _ -> Nothing IndexType _ -> Nothing Size _ -> Nothing Length _ -> Nothing Depth _ -> Nothing MaxIndex _ -> Nothing FilePath _ -> Nothing Template _ _ -> Nothing Gen _ -> Nothing IF _ _ _ -> Nothing And _ -> Nothing IW64 -> Nothing CmpLE _ _ -> Nothing HdlSyn _ -> Nothing BV _ _ _ -> Nothing Sel _ _ -> Nothing IsLit n -> pure n IsVar n -> pure n IsScalar n -> pure n IsActiveHigh n -> pure n Tag n -> pure n Period n -> pure n LongestPeriod -> Nothing ActiveEdge _ n -> pure n IsSync n -> pure n IsInitDefined n -> pure n IsActiveEnable n -> pure n IsUndefined n -> pure n StrCmp _ n -> pure n OutputUsage n -> pure n Vars n -> pure n GenSym _ _ -> Nothing Repeat _ _ -> Nothing DevNull _ -> Nothing SigD _ nM -> nM CtxName -> Nothing -- | 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 :: BlackBoxContext -- ^ Blackbox to verify -> N.BlackBox -- ^ Template to check against -> Maybe String verifyBlackBoxContext bbCtx (N.BBFunction _ _ (N.TemplateFunction _ f _)) = if f bbCtx then Nothing else -- TODO: Make TemplateFunction return a string Just ("Template function for returned False") verifyBlackBoxContext bbCtx (N.BBTemplate t) = orElses (concatMap (walkElement verify') t) where concatTups = concatMap (\(x, y) -> [x, y]) verify' e = Just $ case e of Lit n -> case indexMaybe (bbInputs bbCtx) n of Just (inp, isVoid -> False, False) -> Just ( "Argument " ++ show n ++ " should be literal, as blackbox " ++ "used ~LIT[" ++ show n ++ "], but was:\n\n" ++ show inp) _ -> Nothing Const n -> case indexMaybe (bbInputs bbCtx) n of Just (inp, isVoid -> False, False) -> Just ( "Argument " ++ show n ++ " should be literal, as blackbox " ++ "used ~CONST[" ++ show n ++ "], but was:\n\n" ++ show inp) _ -> Nothing Component (Decl n subn l') -> case IntMap.lookup n (bbFunctions bbCtx) of Just funcs -> case indexMaybe funcs subn of Nothing -> Just ( "Blackbox requested at least " ++ show (subn+1) ++ " renders of function at argument " ++ show n ++ " but " ++ "found only " ++ show (length funcs) ) Just _ -> orElses $ map (verifyBlackBoxContext bbCtx . N.BBTemplate) (concatTups l') Nothing -> Just ( "Blackbox requested instantiation of function at argument " ++ show n ++ ", but BlackBoxContext did not contain one.") _ -> case inputHole e of Nothing -> Nothing Just n -> case indexMaybe (bbInputs bbCtx) n of Just _ -> Nothing 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] extractLiterals = map (\case (e,_,_) -> e) . filter (\case (_,_,b) -> b) . bbInputs -- | Update all the symbol references in a template, and increment the symbol -- counter for every newly encountered symbol. setSym :: forall m . Id.IdentifierSetMonad m => BlackBoxContext -> BlackBoxTemplate -> m (BlackBoxTemplate,[N.Declaration]) setSym bbCtx l = do (a,(_,decls)) <- runStateT (mapM setSym' l) (IntMap.empty,IntMap.empty) return (a,concatMap snd (IntMap.elems decls)) where bbnm = Data.Text.unpack (bbName bbCtx) setSym' :: Element -> StateT ( IntMap.IntMap N.IdentifierText , IntMap.IntMap (N.IdentifierText, [N.Declaration])) m Element setSym' e = case e of ToVar nm i | i < length (bbInputs bbCtx) -> case bbInputs bbCtx !! i of (Identifier nm0 Nothing,_,_) -> return (ToVar [Text (Id.toLazyText nm0)] i) (e',hwTy,_) -> do varM <- IntMap.lookup i <$> use _2 case varM of Nothing -> do nm' <- lift (Id.make (Text.toStrict (concatT (Text "c$":nm)))) let decls = case typeSize hwTy of 0 -> [] _ -> [N.NetDecl Nothing nm' hwTy ,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) Just (nm',_) -> return (ToVar [Text (Text.fromStrict nm')] i) Sym _ i -> do symM <- IntMap.lookup i <$> use _1 case symM of Nothing -> do t <- Id.toText <$> lift (Id.make "c$n") _1 %= (IntMap.insert i t) return (Sym (Text.fromStrict t) i) Just t -> return (Sym (Text.fromStrict t) i) GenSym t i -> do symM <- IntMap.lookup i <$> use _1 case symM of Nothing -> do t' <- Id.toText <$> lift (Id.makeBasic (Text.toStrict (concatT t))) _1 %= (IntMap.insert i t') return (GenSym [Text (Text.fromStrict t')] i) Just _ -> error ("Symbol #" ++ show (t,i) ++ " is already defined in BlackBox for: " ++ bbnm) Component (Decl n subN l') -> Component <$> (Decl n subN <$> mapM (bitraverse (mapM setSym') (mapM setSym')) l') IF c t f -> IF <$> pure c <*> mapM setSym' t <*> mapM setSym' f SigD e' m -> SigD <$> (mapM setSym' e') <*> pure m BV t e' m -> BV <$> pure t <*> mapM setSym' e' <*> pure m _ -> pure e concatT :: [Element] -> Text concatT = Text.concat . map ( \case Text t -> t Name i -> case elementToText bbCtx (Name i) of Right t -> t Left msg -> error $ $(curLoc) ++ "Could not convert ~NAME[" ++ show i ++ "]" ++ " to string:" ++ msg ++ "\n\nError occured while " ++ "processing blackbox for " ++ bbnm Lit i -> case elementToText bbCtx (Lit i) of Right t -> t Left msg -> error $ $(curLoc) ++ "Could not convert ~LIT[" ++ show i ++ "]" ++ " to string:" ++ msg ++ "\n\nError occured while " ++ "processing blackbox for " ++ bbnm Result | [(Identifier t _, _)] <- bbResults bbCtx -> Id.toLazyText t CompName -> Id.toLazyText (bbCompName bbCtx) CtxName -> case bbCtxName bbCtx of Just nm -> Text.fromStrict nm _ | [(Identifier t _, _)] <- bbResults bbCtx -> Id.toLazyText t _ -> error $ $(curLoc) ++ "Internal error when processing blackbox " ++ "for " ++ bbnm _ -> error $ $(curLoc) ++ "Unexpected element in GENSYM when processing " ++ "blackbox for " ++ bbnm ) selectNewName :: Foldable t => t String -- ^ Set of existing names -> FilePath -- ^ Name for new file ( -> String selectNewName as a | elem a as = selectNewName as (replaceBaseName a (takeBaseName a ++ "_")) | otherwise = a renderFilePath :: [(String,FilePath)] -> String -> ([(String,FilePath)],String) renderFilePath fs f = ((f'',f):fs, f'') where f' = takeFileName f f'' = selectNewName (map fst fs) f' -- | Render a blackbox given a certain context. Returns a filled out template -- and a list of 'hidden' inputs that must be added to the encompassing component. renderTemplate :: Backend backend => BlackBoxContext -- ^ Context used to fill in the hole -> BlackBoxTemplate -- ^ Blackbox template -> State backend (Int -> Text) renderTemplate bbCtx l = do l' <- mapM (renderElem bbCtx) l return (\col -> Text.concat (map ($ col) l')) renderBlackBox :: Backend backend => [BlackBoxTemplate] -> [BlackBoxTemplate] -> [((Data.Text.Text,Data.Text.Text), N.BlackBox)] -> N.BlackBox -> BlackBoxContext -> State backend (Int -> Doc) renderBlackBox libs imps includes bb bbCtx = do let nms' = zipWith (\_ i -> "~INCLUDENAME[" <> Text.pack (show i) <> "]") includes [(0 :: Int)..] layout = LayoutOptions (AvailablePerLine 120 0.4) nms <- forM includes $ \((nm,_),inc) -> do case verifyBlackBoxContext bbCtx inc of Nothing -> return () Just err0 -> do sp <- getSrcSpan let err1 = concat [ "Couldn't instantiate blackbox for " , Data.Text.unpack (bbName bbCtx), ". Verification " , "procedure reported:\n\n" ++ err0 ] throw (ClashException sp ($(curLoc) ++ err1) Nothing) let bbCtx' = bbCtx {bbQsysIncName = map Text.toStrict nms'} incForHash <- onBlackBox (renderTemplate bbCtx') (\_name _hash (N.TemplateFunction _ _ f) -> do t <- f bbCtx' let t' = renderLazy (layoutPretty layout t) return (const t')) inc iw <- iwWidth topNm <- getTopName let incHash = hash (incForHash 0) nm' = Text.concat [ Text.fromStrict (Id.toText topNm) , "_" , Text.fromStrict nm , "_" , Text.pack (printf ("%0" ++ show (iw `div` 4) ++ "X") incHash) ] pure nm' let bbNamedCtx = bbCtx {bbQsysIncName = map Text.toStrict nms} incs = snd <$> includes bb' <- case bb of N.BBTemplate bt -> do t <- renderTemplate bbNamedCtx bt return (\col -> let t1 = t (col + 2) in if Text.null t1 then PP.emptyDoc else PP.nest (col-2) (PP.pretty t1)) N.BBFunction _ _ (N.TemplateFunction _ _ bf) -> do t <- bf bbNamedCtx return (\_ -> t) incs' <- mapM (onBlackBox (fmap (PP.pretty . ($ 0)) . renderTemplate bbNamedCtx) (\_name _hash (N.TemplateFunction _ _ f) -> f bbNamedCtx)) incs libs' <- mapM (fmap ($ 0) . renderTemplate bbNamedCtx) libs imps' <- mapM (fmap ($ 0) . renderTemplate bbNamedCtx) imps addIncludes $ zipWith3 (\nm' ((_, ext), _) inc -> (Text.unpack nm' <.> Data.Text.unpack ext, inc)) nms includes incs' addLibraries libs' addImports imps' return bb' -- | Render a single template element renderElem :: HasCallStack => Backend backend => BlackBoxContext -> Element -> State backend (Int -> Text) 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)) ] 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 templ1 <- case templ0 of Left t -> return t Right (nm0,ds) -> do nm1 <- Id.next nm0 block <- getAp (blockDecl nm1 ds) return (render block) 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 Nothing -> snd $ bbResult "~SIGD" b Just n -> let (_,ty',_) = bbInputs b !! n in ty' t <- getAp (hdlSig e' ty) return (const (renderOneLine t)) renderElem b (Period n) = do let (_, ty, _) = bbInputs b !! n case stripVoid ty of KnownDomain _ period _ _ _ _ -> return $ const $ Text.pack $ show period _ -> error $ $(curLoc) ++ "Period: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty renderElem _ LongestPeriod = do doms <- domainConfigurations -- 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 let (_, ty, _) = bbInputs b !! n case stripVoid ty of KnownDomain dom _ _ _ _ _ -> 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 -> return (const (Text.pack (Data.Text.unpack dom))) _ -> error $ $(curLoc) ++ "Tag: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty renderElem b (IF c t f) = do iw <- iwWidth hdl <- gets hdlKind syn <- hdlSyn enums <- renderEnums xOpt <- aggressiveXOptBB c' <- check (coerce xOpt) iw hdl syn enums c if c' > 0 then renderTemplate b t else renderTemplate b f where check :: Backend backend => Bool -> Int -> HDL -> HdlSyn -> RenderEnums -> Element -> State backend Int check xOpt iw hdl syn enums c' = case c' 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) -> 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) -> pure $ case lineToType b [e] of (RTree n _) -> n _ -> error $ $(curLoc) ++ "IF: treedepth of non-tree type" 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) -> pure $ let (e,_,_) = bbInputs b !! n in case e of DataCon {} -> 1 Literal {} -> 1 BlackBoxE {} -> 1 _ -> 0 (IsScalar n) -> let (_,ty,_) = bbInputs b !! n isScalar _ Bit = 1 isScalar _ Bool = 1 isScalar VHDL Integer = 1 isScalar VHDL (Sum _ _) = case enums of RenderEnums True -> 1 RenderEnums False -> 0 isScalar _ _ = 0 in pure $ isScalar hdl ty (IsUndefined n) -> pure $ let (e, _, _) = bbInputs b !! n in if xOpt && checkUndefined e then 1 else 0 (IsActiveEnable n) -> pure $ let (e, ty, _) = bbInputs b !! n in case ty of Enable _ -> case e of DataCon _ _ [Literal Nothing (BoolLit True)] -> 0 -- TODO: Emit warning? If enable signal is inferred as always -- TODO: False, the component will never be enabled. This is -- TODO: probably not the user's intention. DataCon _ _ [Literal Nothing (BoolLit False)] -> 1 _ -> 1 Bool -> case e of Literal Nothing (BoolLit True) -> 0 -- TODO: Emit warning? If enable signal is inferred as always -- TODO: False, the component will never be enabled. This is -- TODO: probably not the user's intention. Literal Nothing (BoolLit False) -> 1 _ -> 1 _ -> error $ $(curLoc) ++ "IsActiveEnable: Expected Bool or Enable, not: " ++ show ty (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 (IsSync n) -> do let (_, ty, _) = bbInputs b !! n domConf <- getDomainConf ty case domConf of VDomainConfiguration _ _ _ Synchronous _ _ -> pure 1 VDomainConfiguration _ _ _ Asynchronous _ _ -> pure 0 (IsInitDefined n) -> do let (_, ty, _) = bbInputs b !! n domConf <- getDomainConf ty case domConf of VDomainConfiguration _ _ _ _ Defined _ -> pure 1 VDomainConfiguration _ _ _ _ Unknown _ -> pure 0 (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) -> 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) -> do es' <- mapM (check xOpt iw hdl syn enums) es pure $ if all (/=0) es' 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 -> error (show (_errDoc errInfo)) Success templ -> templ idToExpr :: (Text, HWType) -> (Expr, HWType, Bool) idToExpr (t, ty) = (Identifier (Id.unsafeMake (Text.toStrict t)) Nothing, ty, False) bbResult :: HasCallStack => String -> BlackBoxContext -> (Expr, HWType) bbResult _s (bbResults -> [r]) = r bbResult s ctx = error [I.i| Multi result primitives not supported when using template tag #{s}. Tag used in blackbox implementation of #{bbName ctx} |] -- | Fill out the template corresponding to an output/input assignment of a -- component instantiation, and turn it into a single identifier so it can -- be used for a new blackbox context. lineToIdentifier :: Backend backend => BlackBoxContext -> BlackBoxTemplate -> State backend Text lineToIdentifier b = foldrM (\e a -> do e' <- renderTag b e return (e' `Text.append` a) ) Text.empty lineToType :: BlackBoxContext -> BlackBoxTemplate -> HWType lineToType b [(Typ Nothing)] = snd $ bbResult "~TYPO" b lineToType b [(Typ (Just n))] = let (_,ty,_) = bbInputs b !! n in ty lineToType b [(TypElem t)] = case lineToType b [t] of Vector _ elTy -> elTy MemBlob _ m -> BitVector m _ -> error $ $(curLoc) ++ "Element type selection of a non-vector-like type" lineToType b [(IndexType (Lit n))] = case bbInputs b !! n of (Literal _ (NumLit n'),_,_) -> Index (fromInteger n') x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x lineToType _ _ = error $ $(curLoc) ++ "Unexpected type manipulation" -- | Give a context and a tagged hole (of a template), returns part of the -- context that matches the tag of the hole. renderTag :: Backend backend => BlackBoxContext -> Element -> State backend Text renderTag _ (Text t) = return t renderTag b (Result) = do fmap renderOneLine . getAp . expr False . fst $ bbResult "~RESULT" b renderTag b (Arg n) = do let (e,_,_) = bbInputs b !! n renderOneLine <$> getAp (expr True e) renderTag b (Const n) = do let (e,_,_) = bbInputs b !! n renderOneLine <$> getAp (expr False e) renderTag b t@(ArgGen k n) | k == bbLevel b , let (e,_,_) = bbInputs b !! n = renderOneLine <$> getAp (expr False e) | otherwise = getAp (prettyElem t) renderTag b (Lit n) = renderOneLine <$> getAp (expr False (mkLit e)) where (e,_,_) = bbInputs b !! n mkLit (Literal (Just (Signed _,_)) i) = Literal Nothing i -- Integer, Int# mkLit (Literal (Just (Unsigned _,_)) i) = Literal Nothing i -- KnownNat, Natural, Word# mkLit (DataCon _ (DC (Void {}, _)) [Literal (Just (Signed _,_)) i]) = Literal Nothing i -- Int mkLit (DataCon _ (DC (Void {}, _)) [Literal (Just (Unsigned _,_)) i]) = Literal Nothing i -- SNat, Word 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 mkLit (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm `elem` ["Clash.Sized.Internal.Signed.fromInteger#" ,"Clash.Sized.Internal.Unsigned.fromInteger#" ,"Clash.Sized.Internal.Index.fromInteger#"] , [Literal {}, Literal _ i] <- extractLiterals bbCtx = Literal Nothing i mkLit i = i renderTag b e@(Name _i) = case elementToText b e of Right s -> return s Left msg -> error $ $(curLoc) ++ unwords [ "Error when reducing to string" , "in ~NAME construct:", msg ] renderTag _ (ToVar [Text t] _) = return t renderTag _ (Sym t _) = return t renderTag b (BV True es e) = do e' <- Text.concat <$> mapM (fmap ($ 0) . renderElem b) es let ty = lineToType b [e] renderOneLine <$> getAp (toBV ty e') renderTag b (BV False es e) = do e' <- Text.concat <$> (mapM (fmap ($ 0) . renderElem b) es) let ty = lineToType b [e] renderOneLine <$> getAp (fromBV ty e') renderTag b (Sel e n) = let ty = lineToType b [e] in renderOneLine <$> getAp (hdlRecSel ty n) renderTag b (Typ Nothing) = fmap renderOneLine . getAp . hdlType Internal . snd $ bbResult "~TYPO" b renderTag b (Typ (Just n)) = let (_,ty,_) = bbInputs b !! n in renderOneLine <$> getAp (hdlType Internal ty) renderTag b (TypM Nothing) = fmap renderOneLine . getAp . hdlTypeMark . snd $ bbResult "~TYPMO" b renderTag b (TypM (Just n)) = let (_,ty,_) = bbInputs b !! n in renderOneLine <$> getAp (hdlTypeMark ty) renderTag b (Err Nothing) = fmap renderOneLine . getAp . hdlTypeErrValue . snd $ bbResult "~ERRORO" b renderTag b (Err (Just n)) = let (_,ty,_) = bbInputs b !! n in renderOneLine <$> getAp (hdlTypeErrValue ty) renderTag b (Size e) = return . Text.pack . show . typeSize $ lineToType b [e] renderTag b (Length e) = return . Text.pack . show . vecLen $ lineToType b [e] where vecLen (Vector n _) = n vecLen (Void (Just (Vector n _))) = n vecLen (MemBlob n _) = n vecLen (Void (Just (MemBlob n _))) = n vecLen thing = error $ $(curLoc) ++ "vecLen of a non-vector-like type: " ++ show thing renderTag b (Depth e) = return . Text.pack . show . treeDepth $ lineToType b [e] where treeDepth (RTree n _) = n treeDepth (Void (Just (RTree n _))) = n treeDepth thing = error $ $(curLoc) ++ "treeDepth of a non-tree type: " ++ show thing renderTag b (MaxIndex e) = return . Text.pack . show . vecLen $ lineToType b [e] where vecLen (Vector n _) = n-1 vecLen (MemBlob n _) = n-1 vecLen thing = error $ $(curLoc) ++ "vecLen of a non-vector-like type: " ++ show thing renderTag b e@(TypElem _) = let ty = lineToType b [e] in renderOneLine <$> getAp (hdlType Internal ty) renderTag _ (Gen b) = renderOneLine <$> genStmt b renderTag _ (GenSym [Text t] _) = return t -- Determine variables used in argument /n/. renderTag b (Vars n) = return $ vars' where (e, _, _) = bbInputs b !! n vars = map Text.fromStrict (usedVariables e) vars' = Text.concat (map (Text.cons ',') vars) renderTag b (IndexType (Lit n)) = case bbInputs b !! n of (Literal _ (NumLit n'),_,_) -> let hty = Index (fromInteger n') in fmap renderOneLine (getAp (hdlType Internal hty)) x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x renderTag b (FilePath e) = case e of Lit n -> do let (e',_,_) = bbInputs b !! n case exprToString e' of Just s -> do s' <- addAndSetData s return (Text.pack (show s')) _ -> do e2 <- getAp (prettyElem e) error $ $(curLoc) ++ "argument of ~FILE:" ++ show e2 ++ "does not reduce to a string" _ -> do e' <- getAp (prettyElem e) error $ $(curLoc) ++ "~FILE expects a ~LIT[N] argument, but got: " ++ show e' 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 (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 let i'' = case (readEither i' :: Either String Int) of Left msg -> error $ $(curLoc) ++ "Could not parse " ++ show i' ++ ". read reported: " ++ msg ++ "." Right n -> n return $ Text.concat $ take i'' $ repeat es' renderTag b (DevNull es) = do _ <- mapM (renderElem b) es return $ Text.empty renderTag b (Template filenameL sourceL) = case file of Left msg -> error $ $(curLoc) ++ unwords [ "Name or source in ~TEMPLATE construct" , "did not reduce to a string." , "'elementToText' reported:" , msg ] Right fstup@(filename, _source) -> do fs <- getMemoryDataFiles if elem filename (map fst fs) then if not (elem fstup fs) then error $ $(curLoc) ++ unwords [ "Multiple ~TEMPLATE constructs" , "specifiy the same filename" , "but different contents. Make" , "sure these names are unique." ] -- We replace the Template element with an empty constant, so nothing -- ends up in the generated HDL. else return (Text.pack "") else do addMemoryDataFile fstup return (Text.pack "") where file = do filename <- elementsToText b filenameL source <- elementsToText b sourceL return (Text.unpack filename, Text.unpack source) renderTag b CompName = pure (Id.toLazyText (bbCompName b)) renderTag b CtxName = case bbCtxName b of Just nm -> return (Text.fromStrict nm) _ | Identifier t _ <- fst (bbResult "~CTXNAME" b) -> return (Id.toLazyText t) _ -> error "internal error" renderTag _ e = do e' <- getAp (prettyElem e) error $ $(curLoc) ++ "Unable to evaluate: " ++ show e' -- | Compute string from a list of elements. Can interpret ~NAME string literals -- on template level (constants). elementsToText :: BlackBoxContext -> [Element] -> Either String Text elementsToText bbCtx elements = foldl (\txt el -> case txt of -- Append new string (if no error) to string so far Right s -> (Text.append s) <$> elementToText bbCtx el -- If previous iteration resulted in an error: stop. msg -> msg) (Right $ Text.pack "") elements elementToText :: BlackBoxContext -> Element -> Either String Text elementToText bbCtx (Name n) = elementToText bbCtx (Lit n) elementToText _bbCtx (Text t) = return $ t elementToText bbCtx (Lit n) = case bbInputs bbCtx ^? element n of Just (e,_,_) -> case exprToString e of Just t -> Right $ Text.pack t Nothing -> Left $ $(curLoc) ++ unwords [ "Could not extract string from" , show e, "referred to by" , show (Lit n) ] Nothing -> Left $ $(curLoc) ++ unwords [ "Invalid literal", show (Lit n) , "used in blackbox with context:" , show bbCtx, "." ] elementToText _bbCtx e = error $ "Unexpected string like: " ++ show e -- | Extracts string from SSymbol or string literals exprToString :: Expr -> Maybe String exprToString (Literal _ (NumLit i)) = Just (show i) exprToString (Literal _ (StringLit l)) = Just l exprToString (BlackBoxE "Clash.Promoted.Symbol.SSymbol" _ _ _ _ ctx _) = case bbInputs ctx of (e0,_,_):_ -> exprToString e0 _ -> error "internal error: insufficient bbInputs" exprToString (BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ ctx _) = case bbInputs ctx of (e0,_,_):_ -> exprToString e0 _ -> error "internal error: insufficient bbInputs" exprToString _ = Nothing prettyBlackBox :: Monad m => BlackBoxTemplate -> Ap m Text prettyBlackBox bbT = Text.concat <$> mapM prettyElem bbT prettyElem :: (HasCallStack, Monad m) => Element -> Ap m Text prettyElem (Text t) = return t prettyElem (Component (Decl i 0 args)) = do args' <- mapM (\(a,b) -> (,) <$> prettyBlackBox a <*> prettyBlackBox b) args case args' of (arg:rest) -> renderOneLine <$> (nest 2 (string "~INST" <+> int i <> line <> string "~OUTPUT" <+> string "=>" <+> string (fst arg) <+> string (snd arg) <+> string "~" <> line <> vcat (mapM (\(a,b) -> string "~INPUT" <+> string "=>" <+> string a <+> string b <+> string "~") rest)) <> line <> string "~INST") _ -> error "internal error: insufficient args" prettyElem (Component (Decl {})) = error $ $(curLoc) ++ "prettyElem can't (yet) render ~INST when subfuncion /= 0!" prettyElem Result = return "~RESULT" prettyElem (Arg i) = renderOneLine <$> ("~ARG" <> brackets (int i)) prettyElem (Lit i) = renderOneLine <$> (string "~LIT" <> brackets (int i)) prettyElem (Const i) = renderOneLine <$> (string "~CONST" <> brackets (int i)) prettyElem (Name i) = renderOneLine <$> (string "~NAME" <> brackets (int i)) prettyElem (ToVar es i) = do es' <- prettyBlackBox es renderOneLine <$> (string "~VAR" <> brackets (string es') <> brackets (int i)) prettyElem (Sym _ i) = renderOneLine <$> (string "~SYM" <> brackets (int i)) prettyElem (Typ Nothing) = return "~TYPO" prettyElem (Typ (Just i)) = renderOneLine <$> (string "~TYP" <> brackets (int i)) prettyElem (TypM Nothing) = return "~TYPMO" prettyElem (TypM (Just i)) = renderOneLine <$> (string "~TYPM" <> brackets (int i)) prettyElem (Err Nothing) = return "~ERRORO" prettyElem (Err (Just i)) = renderOneLine <$> (string "~ERROR" <> brackets (int i)) prettyElem (TypElem e) = do e' <- prettyElem e renderOneLine <$> (string "~TYPEL" <> brackets (string e')) prettyElem CompName = return "~COMPNAME" prettyElem (IncludeName i) = renderOneLine <$> ("~INCLUDENAME" <> brackets (int i)) prettyElem (IndexType e) = do e' <- prettyElem e renderOneLine <$> (string "~INDEXTYPE" <> brackets (string e')) prettyElem (Size e) = do e' <- prettyElem e renderOneLine <$> (string "~SIZE" <> brackets (string e')) prettyElem (Length e) = do e' <- prettyElem e renderOneLine <$> (string "~LENGTH" <> brackets (string e')) prettyElem (Depth e) = do e' <- prettyElem e renderOneLine <$> (string "~DEPTH" <> brackets (string e')) prettyElem (MaxIndex e) = do e' <- prettyElem e renderOneLine <$> (string "~MAXINDEX" <> brackets (string e')) prettyElem (FilePath e) = do e' <- prettyElem e renderOneLine <$> (string "~FILE" <> brackets (string e')) prettyElem (Gen b) = if b then return "~GENERATE" else return "~ENDGENERATE" prettyElem (IF b esT esF) = do b' <- prettyElem b esT' <- prettyBlackBox esT esF' <- prettyBlackBox esF (renderLazy . layoutCompact) <$> (string "~IF" <+> string b' <+> string "~THEN" <> string esT' <> string "~ELSE" <> string esF' <> string "~FI") prettyElem (And es) = renderOneLine <$> (string "~AND" <> (brackets (hcat (punctuate comma (mapM (string <=< prettyElem) es))))) prettyElem (CmpLE e1 e2) = do e1' <- prettyElem e1 e2' <- prettyElem e2 renderOneLine <$> (string "~CMPLE" <> brackets (string e1') <> brackets (string e2')) prettyElem IW64 = return "~IW64" prettyElem (HdlSyn s) = case s of Vivado -> return "~VIVADO" _ -> return "~OTHERSYN" prettyElem (BV b es e) = do es' <- prettyBlackBox es e' <- prettyBlackBox [e] renderOneLine <$> if b then string "~TOBV" <> brackets (string es') <> brackets (string e') else string "~FROMBV" <> brackets (string es') <> brackets (string e') prettyElem (Sel e i) = do e' <- prettyElem e renderOneLine <$> (string "~SEL" <> brackets (string e') <> brackets (int i)) prettyElem (IsLit i) = renderOneLine <$> (string "~ISLIT" <> brackets (int i)) prettyElem (IsVar i) = renderOneLine <$> (string "~ISVAR" <> brackets (int i)) prettyElem (IsScalar i) = renderOneLine <$> (string "~ISSCALAR" <> brackets (int i)) prettyElem (IsActiveHigh i) = renderOneLine <$> (string "~ISACTIVEHIGH" <> brackets (int i)) prettyElem (IsActiveEnable i) = renderOneLine <$> (string "~ISACTIVEENABLE" <> brackets (int i)) prettyElem (IsUndefined i) = renderOneLine <$> (string "~ISUNDEFINED" <> brackets (int i)) -- Domain attributes: prettyElem (Tag i) = renderOneLine <$> (string "~TAG" <> brackets (int i)) prettyElem (Period i) = renderOneLine <$> (string "~PERIOD" <> brackets (int i)) prettyElem LongestPeriod = return "~LONGESTPERIOD" prettyElem (ActiveEdge e i) = renderOneLine <$> (string "~ACTIVEEDGE" <> brackets (string (Text.pack (show e))) <> brackets (int i)) prettyElem (IsSync i) = renderOneLine <$> (string "~ISSYNC" <> brackets (int i)) prettyElem (IsInitDefined i) = renderOneLine <$> (string "~ISINITDEFINED" <> brackets (int i)) prettyElem (StrCmp es i) = do es' <- prettyBlackBox es renderOneLine <$> (string "~STRCMP" <> brackets (string es') <> brackets (int i)) prettyElem (GenSym es i) = do es' <- prettyBlackBox es renderOneLine <$> (string "~GENSYM" <> brackets (string es') <> brackets (int i)) prettyElem (Repeat [es] [i]) = do es' <- prettyElem es i' <- prettyElem i renderOneLine <$> string "~REPEAT" <> brackets (string es') <> brackets (string i') prettyElem (Repeat es i) = error $ $(curLoc) ++ "Unexpected number of arguments in either " ++ show es ++ " or " ++ show i ++ ". Both lists are expected to have a single element." prettyElem (DevNull es) = do es' <- mapM prettyElem es renderOneLine <$> (string "~DEVNULL" <> brackets (string $ Text.concat es')) prettyElem (SigD es mI) = do es' <- prettyBlackBox es renderOneLine <$> (maybe (string "~SIGDO" <> brackets (string es')) (((string "~SIGD" <> brackets (string es')) <>) . int) mI) prettyElem (Vars i) = renderOneLine <$> (string "~VARS" <> 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 bbname' <- mapM prettyElem bbname source' <- mapM prettyElem source renderOneLine <$> (string "~TEMPLATE" <> brackets (string $ Text.concat bbname') <> brackets (string $ Text.concat source')) prettyElem CtxName = return "~CTXNAME" -- | Recursively walk @Element@, applying @f@ to each element in the tree. walkElement :: (Element -> Maybe a) -> Element -> [a] walkElement f el = maybeToList (f el) ++ walked where go = walkElement f walked = -- TODO: alternatives are purposely explicitly listed in case @Element@ -- TODO: gets extended. This way, GHC will complain about missing -- TODO: alternatives. It would probably be better to replace it by Lens -- TODO: logic? case el of Component (Decl _ _ args) -> concatMap (\(a,b) -> concatMap go a ++ concatMap go b) args IndexType e -> go e FilePath e -> go e Template bbname source -> concatMap go bbname ++ concatMap go source IF b esT esF -> go b ++ concatMap go esT ++ concatMap go esF SigD es _ -> concatMap go es BV _ es _ -> concatMap go es GenSym es _ -> concatMap go es DevNull es -> concatMap go es Text _ -> [] Result -> [] Arg _ -> [] ArgGen _ _ -> [] Const _ -> [] Lit _ -> [] Name _ -> [] ToVar es _ -> concatMap go es Sym _ _ -> [] Typ _ -> [] TypM _ -> [] Err _ -> [] TypElem e -> go e CompName -> [] IncludeName _ -> [] Size e -> go e Length e -> go e Depth e -> go e MaxIndex e -> go e Gen _ -> [] And es -> concatMap go es CmpLE e1 e2 -> go e1 ++ go e2 IW64 -> [] HdlSyn _ -> [] Sel e _ -> go e IsLit _ -> [] IsVar _ -> [] IsScalar _ -> [] Tag _ -> [] Period _ -> [] LongestPeriod -> [] ActiveEdge _ _ -> [] IsSync _ -> [] IsInitDefined _ -> [] IsActiveHigh _ -> [] IsActiveEnable _ -> [] IsUndefined _ -> [] StrCmp es _ -> concatMap go es OutputUsage _ -> [] Vars _ -> [] Repeat es1 es2 -> concatMap go es1 ++ concatMap go es2 CtxName -> [] -- | Determine variables used in an expression. Used for VHDL sensitivity list. -- Also see: https://github.com/clash-lang/clash-compiler/issues/365 usedVariables :: Expr -> [N.IdentifierText] usedVariables Noop = [] usedVariables (Identifier i _) = [Id.toText i] usedVariables (DataCon _ _ es) = concatMap usedVariables es usedVariables (DataTag _ e') = [Id.toText (either id id e')] usedVariables (Literal {}) = [] usedVariables (ToBv _ _ e') = usedVariables e' usedVariables (FromBv _ _ e') = usedVariables e' usedVariables (IfThenElse e1 e2 e3) = concatMap usedVariables [e1,e2,e3] usedVariables (BlackBoxE _ _ _ _ t bb _) = nub (sList ++ sList') where matchArg (Arg i) = Just i matchArg _ = Nothing matchVar (ToVar [Text v] _) = Just (Text.toStrict v) matchVar _ = Nothing t' = onBlackBox id (\_ _ _ -> []) t usedIs = mapMaybe (indexMaybe (bbInputs bb)) (concatMap (walkElement matchArg) t') sList = concatMap (\(e,_,_) -> usedVariables e) usedIs sList' = concatMap (walkElement matchVar) t' -- | Collect arguments (e.g., ~ARG, ~LIT) used in this blackbox getUsedArguments :: N.BlackBox -> [Int] getUsedArguments (N.BBFunction _nm _hsh (N.TemplateFunction k _ _)) = k getUsedArguments (N.BBTemplate t) = nub (concatMap (walkElement matchArg) t) where matchArg = \case Arg i -> Just i Component (Decl i _ _) -> Just i Const i -> Just i IsLit i -> Just i IsActiveEnable i -> Just i IsUndefined i -> Just i Lit i -> Just i Name i -> Just i ToVar _ i -> Just i -- Domain properties (only need type): IsInitDefined _ -> Nothing ActiveEdge _ _ -> Nothing IsSync _ -> Nothing Period _ -> Nothing LongestPeriod -> Nothing Tag _ -> Nothing -- Others. Template tags only using types of arguments can be considered -- "not used". And _ -> Nothing ArgGen _ _ -> Nothing BV _ _ _ -> Nothing CmpLE _ _ -> Nothing CompName -> Nothing Depth _ -> Nothing DevNull _ -> Nothing Err _ -> Nothing FilePath _ -> Nothing Gen _ -> Nothing GenSym _ _ -> Nothing HdlSyn _ -> Nothing IF _ _ _ -> Nothing IncludeName _ -> Nothing IndexType _ -> Nothing IsActiveHigh _ -> Nothing IsVar _ -> Nothing IsScalar _ -> Nothing IW64 -> Nothing Length _ -> Nothing MaxIndex _ -> Nothing OutputUsage _ -> Nothing Repeat _ _ -> Nothing Result -> Nothing Sel _ _ -> Nothing SigD _ _ -> Nothing Size _ -> Nothing StrCmp _ _ -> Nothing Sym _ _ -> Nothing Template _ _ -> Nothing Text _ -> Nothing Typ _ -> Nothing TypElem _ -> Nothing TypM _ -> Nothing Vars _ -> Nothing CtxName -> Nothing onBlackBox :: (BlackBoxTemplate -> r) -> (N.BBName -> N.BBHash -> N.TemplateFunction -> r) -> N.BlackBox -> r onBlackBox f _ (N.BBTemplate t) = f t onBlackBox _ g (N.BBFunction n h t) = g n h t -- | Is the value of the 'Expr' fully undefined? checkUndefined :: Expr -> Bool checkUndefined = \case BlackBoxE _ _ _ _ (N.BBTemplate [Err _]) _ _ -> True BlackBoxE "Clash.Sized.Internal.BitVector.fromInteger#" [] [] [] _ bbCtx _ | [sz, mask, _val] <- bbInputs bbCtx , (Literal _ (NumLit sz0), _, True) <- sz , (Literal _ (NumLit mask0), _, True) <- mask , mask0 == 2^sz0 - 1 -> True DataCon (Product _ _ _) _ es -> and (map checkUndefined es) _ -> False clash-lib-1.8.1/src/Clash/Netlist/BlackBox/Util.hs-boot0000644000000000000000000000105507346545000020713 0ustar0000000000000000{-| Copyright : (C) 2019, Google Inc License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} module Clash.Netlist.BlackBox.Util where import Data.Text.Lazy (Text) import Control.Monad.State (State) import Clash.Backend (Backend) import Clash.Netlist.Types (BlackBoxContext) import Clash.Netlist.BlackBox.Types (BlackBoxTemplate) renderTemplate :: Backend backend => BlackBoxContext -- ^ Context used to fill in the hole -> BlackBoxTemplate -- ^ Blackbox template -> State backend (Int -> Text) clash-lib-1.8.1/src/Clash/Netlist/Expr.hs0000644000000000000000000001432007346545000016265 0ustar0000000000000000{-| 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 clash-lib-1.8.1/src/Clash/Netlist/Id.hs0000644000000000000000000002067107346545000015711 0ustar0000000000000000{-| Copyright : (C) 2020, QBayLogic B.V. 2022, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier -} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Netlist.Id ( -- * Utilities to use IdentifierSet IdentifierSet , IdentifierSetMonad(..) , HasIdentifierSet(..) , emptyIdentifierSet , makeSet , clearSet -- * Unsafe creation and extracting identifiers , Identifier , IdentifierType (..) , unsafeMake , unsafeFromCoreId , toText , toLazyText , toList , union -- * Creating and extending identifiers , make , makeBasic , makeBasicOr , makeAs , add , addMultiple , addRaw , deepen , deepenN , next , nextN , prefix , suffix , fromCoreId -- * Misc. and internals , VHDL.stripDollarPrefixes , toBasicId# , isBasic# , isExtended# ) where import Clash.Annotations.Primitive (HDL (..)) import Clash.Core.Name (nameOcc) import Clash.Core.Var (Id, varName) import Clash.Debug (debugIsOn) import Clash.Netlist.Types (PreserveCase(..), HasIdentifierSet(..), IdentifierSet(..), Identifier(..), IdentifierType(..), IdentifierSetMonad(identifierSetM)) import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap import qualified Data.IntMap.Strict as IntMap import qualified Data.List as List import Data.Text (Text) import qualified Data.Text.Lazy as LT import GHC.Stack import qualified Clash.Netlist.Id.VHDL as VHDL import Clash.Netlist.Id.Internal -- | Identifier set without identifiers emptyIdentifierSet :: Bool -- ^ Allow escaped identifiers? -> PreserveCase -- ^ Should all basic identifiers be lower case? -> HDL -- ^ HDL to generate names for -> IdentifierSet emptyIdentifierSet esc lw hdl = makeSet esc lw hdl mempty -- | Union of two identifier sets. Errors if given sets have been made with -- different options enabled. union :: HasCallStack => IdentifierSet -> IdentifierSet -> IdentifierSet union (IdentifierSet escL lwL hdlL freshL idsL) (IdentifierSet escR lwR hdlR freshR idsR) | escL /= escR = error $ "Internal error: escL /= escR, " <> show (escL, escR) | hdlL /= hdlR = error $ "Internal error: hdlL /= hdlR, " <> show (hdlL, hdlR) | lwL /= lwR = error $ "Internal error: lwL /= lwR , " <> show (lwL, lwR) | otherwise = IdentifierSet escR lwR hdlR fresh ids where fresh = HashMap.unionWith (IntMap.unionWith max) freshL freshR ids = HashSet.union idsL idsR -- | Make a identifier set filled with given identifiers makeSet :: Bool -- ^ Allow escaped identifiers? -> PreserveCase -- ^ Should all basic identifiers be lower case? -> HDL -- ^ HDL to generate names for -> HashSet.HashSet Identifier -- ^ Identifiers to add to set -> IdentifierSet makeSet esc lw hdl ids = IdentifierSet esc lw hdl fresh ids where fresh = List.foldl' updateFreshCache# mempty ids -- | Remove all identifiers from a set clearSet :: IdentifierSet -> IdentifierSet clearSet (IdentifierSet escL lwL hdlL _ _) = IdentifierSet escL lwL hdlL mempty mempty toList :: IdentifierSet -> [Identifier] toList (IdentifierSet _ _ _ _ idStore) = HashSet.toList idStore -- | Convert an identifier to string toText :: Identifier -> Text toText = toText# -- | Convert an identifier to string toLazyText :: Identifier -> LT.Text toLazyText = LT.fromStrict . toText -- | Helper function to define pure Id functions in terms of a IdentifierSetMonad withIdentifierSetM' :: IdentifierSetMonad m => (IdentifierSet -> a -> IdentifierSet) -> a -> m () withIdentifierSetM' f a = do is0 <- identifierSetM id identifierSetM (const (f is0 a)) >> pure () -- | Helper function to define pure Id functions in terms of a IdentifierSetMonad withIdentifierSetM :: IdentifierSetMonad m => (IdentifierSet -> a -> (IdentifierSet, b)) -> a -> m b withIdentifierSetM f a = do is0 <- identifierSetM id let (is1, b) = f is0 a _ <- identifierSetM (const is1) pure b -- | Like 'addRaw', 'unsafeMake' creates an identifier that will be spliced -- at verbatim in the HDL. As opposed to 'addRaw', the resulting Identifier -- might be generated at a later point as it is NOT added to an IdentifierSet. unsafeMake :: HasCallStack => Text -> Identifier unsafeMake t = RawIdentifier t Nothing (if debugIsOn then callStack else emptyCallStack) -- | Add an identifier to an IdentifierSet add :: HasCallStack => IdentifierSetMonad m => Identifier -> m () add = withIdentifierSetM' add# -- | Add identifiers to an IdentifierSet addMultiple :: (HasCallStack, IdentifierSetMonad m, Foldable t) => t Identifier -> m () addMultiple = withIdentifierSetM' addMultiple# -- | Add a string as is to an IdentifierSet. Should only be used for identifiers -- that should be spliced at verbatim in HDL, such as port names. It's sanitized -- version will still be added to the identifier set, to prevent freshly -- generated variables clashing with the raw one. addRaw :: (HasCallStack, IdentifierSetMonad m) => Text -> m Identifier addRaw = withIdentifierSetM addRaw# -- | Make unique identifier based on given string make :: (HasCallStack, IdentifierSetMonad m) => Text -> m Identifier make = withIdentifierSetM make# -- | Make unique basic identifier based on given string makeBasic :: (HasCallStack, IdentifierSetMonad m) => Text -> m Identifier makeBasic = withIdentifierSetM makeBasic# -- | Make unique basic identifier based on given string. If given string can't -- be converted to a basic identifier (i.e., it would yield an empty string) the -- alternative name is used. makeBasicOr :: (HasCallStack, IdentifierSetMonad m) => Text -- ^ Name hint -> Text -- ^ If name hint can't be converted to a sensible basic id, use this instead -> m Identifier makeBasicOr hint altHint = withIdentifierSetM (\is0 -> uncurry (makeBasicOr# is0)) (hint, altHint) -- | Make unique identifier. Uses 'makeBasic' if first argument is 'Basic' makeAs :: (HasCallStack, IdentifierSetMonad m) => IdentifierType -> Text -> m Identifier makeAs Basic = makeBasic makeAs Extended = make -- | Given identifier "foo_1_2" return "foo_1_3". If "foo_1_3" is already a -- member of the given set, return "foo_1_4" instead, etc. Identifier returned -- is guaranteed to be unique. next :: (HasCallStack, IdentifierSetMonad m) => Identifier -> m Identifier next = withIdentifierSetM next# -- | Same as 'nextM', but returns N fresh identifiers nextN :: (HasCallStack, IdentifierSetMonad m) => Int -> Identifier -> m [Identifier] nextN n = withIdentifierSetM (nextN# n) -- | Given identifier "foo_1_2" return "foo_1_2_0". If "foo_1_2_0" is already a -- member of the given set, return "foo_1_2_1" instead, etc. Identifier returned -- is guaranteed to be unique. deepen :: (HasCallStack, IdentifierSetMonad m) => Identifier -> m Identifier deepen = withIdentifierSetM deepen# -- | Same as 'deepenM', but returns N fresh identifiers. For example, given -- "foo_23" is would return "foo_23_0", "foo_23_1", ... deepenN :: (HasCallStack, IdentifierSetMonad m) => Int -> Identifier -> m [Identifier] deepenN n = withIdentifierSetM (deepenN# n) -- | Given identifier "foo_1_2" and a suffix "bar", return an identifier called -- "foo_bar". Identifier returned is guaranteed to be unique according to the -- rules of 'nextIdentifier'. suffix :: (HasCallStack, IdentifierSetMonad m) => Identifier -> Text -> m Identifier suffix id0 suffix_ = withIdentifierSetM (\is id1 -> suffix# is id1 suffix_) id0 -- | Given identifier "foo_1_2" and a prefix "bar", return an identifier called -- "bar_foo". Identifier returned is guaranteed to be unique according to the -- rules of 'nextIdentifier'. prefix :: (HasCallStack, IdentifierSetMonad m) => Identifier -> Text -> m Identifier prefix id0 prefix_ = withIdentifierSetM (\is id1 -> prefix# is id1 prefix_) id0 -- | Convert a Clash Core Id to an identifier. Makes sure returned identifier -- 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 clash-lib-1.8.1/src/Clash/Netlist/Id.hs-boot0000644000000000000000000000021407346545000016641 0ustar0000000000000000module Clash.Netlist.Id where import {-# SOURCE #-} Clash.Netlist.Types (Identifier) import Data.Text (Text) toText :: Identifier -> Text clash-lib-1.8.1/src/Clash/Netlist/Id/0000755000000000000000000000000007346545000015347 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Netlist/Id/Common.hs0000644000000000000000000000571307346545000017141 0ustar0000000000000000{-| Copyright : (C) 2020-2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. )) import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text.Extra (showt) import qualified Data.Text as Text import qualified Data.Char as Char parseWhiteSpace :: Text -> Maybe Text parseWhiteSpace = parseSingle isWhiteSpace isWhiteSpace :: Char -> Bool isWhiteSpace c = c `elem` [' ', '\n', '\t'] parsePrintable :: Text -> Maybe Text parsePrintable = parseSingle (\c -> Char.isPrint c && Char.isAscii c) parseSingle :: (Char -> Bool) -> Text -> Maybe Text parseSingle predicate s = do (l, ls) <- Text.uncons s if predicate l then Just ls else Nothing parseMaybeSingle :: (Char -> Bool) -> Text -> Maybe Text parseMaybeSingle predicate s = Just (fromMaybe s (parseSingle predicate s)) parseLetter :: Text -> Maybe Text parseLetter = parseSingle (\c -> Char.isAscii c && Char.isLetter c) parseDigit :: Text -> Maybe Text parseDigit = parseSingle Char.isDigit parseLetterOrDigit :: Text -> Maybe Text parseLetterOrDigit s = parseLetter s <|> parseDigit s parseUnderscore :: Text -> Maybe Text parseUnderscore = parseSingle (=='_') parseDollar :: Text -> Maybe Text parseDollar = parseSingle (=='$') parseTab :: Text -> Maybe Text parseTab = parseSingle (=='\t') parseBackslash :: Text -> Maybe Text parseBackslash = parseSingle (=='\\') failNonEmpty :: Text -> Maybe Text failNonEmpty s | Text.null s = Just Text.empty | otherwise = Nothing repeatParseN :: (Text -> Maybe Text) -> Text -> Maybe (Int, Text) repeatParseN parser = go 0 where go n s0 = case parser s0 of Just s1 -> go (n+1) s1 Nothing -> Just (n, s0) repeatParse :: (Text -> Maybe Text) -> Text -> Maybe Text repeatParse parser s0 = snd <$> repeatParseN parser s0 -- | Encodes tuples as "TupN" and removes all characters not matching a -- predicate. zEncode :: (Char -> Bool) -- ^ Characters to keep -> Text -> Text zEncode keep s = let go = zEncode keep in case maybeTuple s of Just (tupName, rest) -> tupName <> go rest Nothing -> case Text.uncons s of Just (c, rest) -> if keep c then Text.cons c (go rest) else go rest Nothing -> s prettyName :: Text -> Text prettyName t = maybe t (uncurry (<>)) (maybeTuple t) maybeTuple :: Text -> Maybe (Text, Text) maybeTuple "(# #)" = Just ("Unit", "") maybeTuple "()" = Just ("Unit", "") maybeTuple t = first (\n -> "Tuple" <> showt n) <$> parseTuple t parseTuple :: Text -> Maybe (Int, Text) parseTuple t0 = do t1 <- parseSingle (=='(') t0 t2 <- parseMaybeSingle (=='#') t1 (n, t3) <- repeatParseN (parseSingle (== ',')) t2 t4 <- parseMaybeSingle (=='#') t3 t5 <- parseSingle (==')') t4 pure (n+1, t5) clash-lib-1.8.1/src/Clash/Netlist/Id/Internal.hs0000644000000000000000000002456307346545000017471 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} module Clash.Netlist.Id.Internal where import Clash.Annotations.Primitive (HDL (..)) import Clash.Core.Name (Name(nameOcc)) import Clash.Core.Var (Id, varName) import Clash.Debug (debugIsOn) import Clash.Netlist.Types (PreserveCase(..), IdentifierSet(..), Identifier(..), FreshCache, IdentifierType(..)) import Control.Arrow (second) import qualified Data.Char as Char import qualified Data.List as List #if MIN_VERSION_prettyprinter(1,7,0) import qualified Prettyprinter as PP #else import qualified Data.Text.Prettyprint.Doc as PP #endif import qualified Data.Text as Text import Data.Text (Text) import Data.Text.Extra (showt) import qualified Data.Maybe as Maybe import Text.Read (readMaybe) import GHC.Stack import qualified Data.IntMap as IntMap import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet import qualified Clash.Netlist.Id.SystemVerilog as SystemVerilog import qualified Clash.Netlist.Id.Verilog as Verilog import qualified Clash.Netlist.Id.VHDL as VHDL import qualified Clash.Netlist.Id.Common as Common -- | Return identifier with highest extension for given identifier. See -- 'is_freshCache' for more information. -- -- For example, if the FreshCache contains "foo_12_25" and the given identifier -- is "foo_12_13" this function would return "Just 25". In this case, "foo_12_26" -- is guaranteed to be a fresh identifier. lookupFreshCache# :: FreshCache -> Identifier -> Maybe Word lookupFreshCache# fresh0 id0 = do fresh1 <- HashMap.lookup (i_baseNameCaseFold id0) fresh0 IntMap.lookup (length (i_extensionsRev id0)) fresh1 -- | Add new identifier to FreshCache, see 'is_freshCache' for more information. updateFreshCache# :: HasCallStack => FreshCache -> Identifier -> FreshCache updateFreshCache# _fresh (RawIdentifier _s Nothing _) = error "Internal error: updateFreshCache# called with unsafely made identifier" updateFreshCache# fresh (RawIdentifier _s (Just id_) _) = updateFreshCache# fresh id_ updateFreshCache# fresh id_ = go0 (go1 (max (Maybe.fromMaybe 0 (Maybe.listToMaybe exts)))) where go0 f = HashMap.alter (Just . f . Maybe.fromMaybe mempty) base fresh go1 f = IntMap.alter (Just . f . Maybe.fromMaybe 0) (length exts) exts = i_extensionsRev id_ base = i_baseNameCaseFold id_ -- | Adds identifier at verbatim if its basename hasn't been used before. -- Otherwise it will return the first free identifier. mkUnique# :: HasCallStack => IdentifierSet -> Identifier -> (IdentifierSet, Identifier) mkUnique# _is0 (RawIdentifier {}) = error "Internal error: mkUnique# cannot be used on RawIdentifiers" mkUnique# is0 id_@(i_extensionsRev -> []) = deepen# is0 id_ mkUnique# is id0 = (is{is_freshCache=freshCache, is_store=isStore}, id2) where freshCache = updateFreshCache# (is_freshCache is) id2 isStore = HashSet.insert id2 (is_store is) 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 : drop 1 (i_extensionsRev id0)} Nothing -> -- Identifier doesn't exist in set yet, so just return it. id0 -- | Non-monadic, internal version of 'add' add# :: HasCallStack => IdentifierSet -> Identifier -> IdentifierSet add# is0@(IdentifierSet{..}) (RawIdentifier t Nothing _) = add# is0 (make## is_hdl t) add# is0 (RawIdentifier _ (Just id0) _) = add# is0 id0 add# is0@(IdentifierSet{..}) id0 = is0{is_freshCache=fresh1, is_store=ids1} where ids1 = HashSet.insert id0 is_store fresh1 = updateFreshCache# is_freshCache id0 -- | Non-monadic, internal version of 'addMultiple' addMultiple# :: (HasCallStack, Foldable t) => IdentifierSet -> t Identifier -> IdentifierSet addMultiple# is ids = List.foldl' add# is ids -- | Non-monadic, internal version of 'addRaw' addRaw# :: HasCallStack => IdentifierSet -> Text -> (IdentifierSet, Identifier) addRaw# is0 id0 = second (\i -> RawIdentifier id0 (Just i) (if debugIsOn then callStack else emptyCallStack)) (make# is0 (unextend id0)) where unextend = case is_hdl is0 of VHDL -> VHDL.unextend Verilog -> Verilog.unextend SystemVerilog -> SystemVerilog.unextend -- | Non-monadic, internal version of 'make' make# :: HasCallStack => IdentifierSet -> Text -> (IdentifierSet, Identifier) make# is0@(IdentifierSet esc lw hdl fresh0 ids0) (Common.prettyName -> id0) = if id1 `HashSet.member` ids0 then -- Ideally we'd like to continue with the id from the HashSet so all the old -- strings can be garbage collected, but I haven't found an efficient way of -- doing so. I also doubt that this case will get hit often.. deepen# is0 id1 else (is0{is_freshCache=fresh1, is_store=ids1}, id1) where ids1 = HashSet.insert id1 ids0 fresh1 = updateFreshCache# fresh0 id1 id1 = make## (is_hdl is0) (if esc then id0 else toBasicId# hdl lw id0) -- | Non-monadic, internal version of 'makeBasic' makeBasic# :: HasCallStack => IdentifierSet -> Text -> (IdentifierSet, Identifier) makeBasic# is0 = make# is0 . toBasicId# (is_hdl is0) (is_lowerCaseBasicIds is0) -- | Non-monadic, internal version of 'makeBasicOr' makeBasicOr# :: HasCallStack => IdentifierSet -> Text -> Text -> (IdentifierSet, Identifier) makeBasicOr# is0 hint altHint = make# is0 id1 where id0 = toBasicId# (is_hdl is0) (is_lowerCaseBasicIds is0) hint id1 = if Text.null id0 then toBasicId# (is_hdl is0) (is_lowerCaseBasicIds is0) altHint else id0 -- | Non-monadic, internal version of 'next' next# :: HasCallStack => IdentifierSet -> Identifier -> (IdentifierSet, Identifier) next# is0 (RawIdentifier t Nothing _) = uncurry next# (make# is0 t) next# is0 (RawIdentifier _ (Just id_) _) = next# is0 id_ next# is0 id_@(i_extensionsRev -> []) = deepen# is0 id_ next# is0 id_ = mkUnique# is0 id_ -- | Non-monadic, internal version of 'nextN' nextN# :: HasCallStack => Int -> IdentifierSet -> Identifier -> (IdentifierSet, [Identifier]) nextN# n is0 id0 = List.mapAccumL (\is1 _n -> next# is1 id0) is0 [1..n] -- TODO: ^ More efficient implementation. -- | Non-monadic, internal version of 'deepenN' deepenN# :: HasCallStack => Int -> IdentifierSet -> Identifier -> (IdentifierSet, [Identifier]) deepenN# n is0 id0 = List.mapAccumL (\is1 _n -> deepen# is1 id0) is0 [1..n] -- TODO: ^ More efficient implementation. -- | Non-monadic, internal version of 'deepen' deepen# :: HasCallStack => IdentifierSet -> Identifier -> (IdentifierSet, Identifier) deepen# is0 (RawIdentifier t Nothing _) = uncurry deepen# (make# is0 t) deepen# is0 (RawIdentifier _ (Just id_) _) = deepen# is0 id_ deepen# is0 id_ = mkUnique# is0 (id_{i_extensionsRev=0:i_extensionsRev id_}) -- | Non-monadic, internal version of 'suffix' suffix# :: HasCallStack => IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier) suffix# is0 (RawIdentifier t Nothing _) suffix_ = (uncurry suffix# (make# is0 t)) suffix_ suffix# is0 (RawIdentifier _ (Just id_) _) suffix_ = suffix# is0 id_ suffix_ suffix# is0 id0 suffix_ = make# is0 (i_baseName id0 <> "_" <> suffix_) -- | Non-monadic, internal version of 'prefix' prefix# :: HasCallStack => IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier) prefix# is0 (RawIdentifier t Nothing _) prefix_ = (uncurry prefix# (make# is0 t)) prefix_ prefix# is0 (RawIdentifier _ (Just id_) _) prefix_ = prefix# is0 id_ prefix_ prefix# is0 id0 prefix_ = make# is0 (prefix_ <> "_" <> i_baseName id0) toText# :: Identifier -> Text toText# (RawIdentifier t _ _) = t toText# (UniqueIdentifier{..}) = case i_hdl of VHDL -> VHDL.toText i_idType basicId Verilog -> Verilog.toText i_idType basicId SystemVerilog -> SystemVerilog.toText i_idType basicId where exts = map showt (reverse i_extensionsRev) basicId = Text.intercalate "_" (i_baseName : exts) -- | Is given string a valid basic identifier in given HDL? isBasic# :: HDL -> Text -> Bool isBasic# VHDL = VHDL.parseBasic isBasic# Verilog = Verilog.parseBasic isBasic# SystemVerilog = SystemVerilog.parseBasic -- | Is given string a valid extended identifier in given HDL? isExtended# :: HDL -> Text -> Bool isExtended# VHDL = VHDL.parseExtended isExtended# Verilog = Verilog.parseExtended isExtended# SystemVerilog = SystemVerilog.parseExtended -- | Convert given string to ASCII. Retains all printable ASCII. All other -- characters are thrown out. toPrintableAscii# :: Text -> Text toPrintableAscii# = Text.filter (\c -> Char.isPrint c && Char.isAscii c) -- | Split identifiers such as "foo_1_2" into ("foo", [2, 1]). parseIdentifier# :: Text -> (Text, [Word]) parseIdentifier# t = let (tsRev, extsRev) = go (List.reverse (Text.splitOn "_" t)) in (Text.intercalate "_" (List.reverse tsRev), extsRev) where go :: [Text] -> ([Text], [Word]) go [] = go ["clash", "internal"] go (i:is) = case readMaybe @Word (Text.unpack i) of Just w -> second (w:) (go is) Nothing -> (i:is, []) make## :: HasCallStack => HDL -> Text -> Identifier make## hdl = go . Text.strip . Text.replace "\\" "" . toPrintableAscii# where go s | Text.null s = go "clash_internal" | otherwise = let (baseName, extensions) = parseIdentifier# s idType = if isBasic# hdl s then Basic else Extended -- VHDL is a case insensitive language, so we convert the given -- text to lowercase. Note that 'baseNameCaseFold' is used in the -- Eq for Identifier. baseNameCaseFold = case hdl of VHDL -> Text.toCaseFold baseName _ -> baseName in UniqueIdentifier baseName baseNameCaseFold extensions idType hdl (if debugIsOn then callStack else emptyCallStack) toBasicId# :: HDL -> PreserveCase -> Text -> Text toBasicId# hdl lw id0 = case hdl of VHDL -> VHDL.toBasic id1 Verilog -> Verilog.toBasic id1 SystemVerilog -> SystemVerilog.toBasic id1 where id1 = case lw of {PreserveCase -> id0; ToLower -> Text.toLower id0} -- | Convert a Clash Core Id to an identifier. Makes sure returned identifier -- is unique. fromCoreId# :: IdentifierSet -> Id -> (IdentifierSet, Identifier) fromCoreId# is0 id0 = make# is0 (nameOcc (varName id0)) instance PP.Pretty Identifier where pretty = PP.pretty . toText# clash-lib-1.8.1/src/Clash/Netlist/Id/SystemVerilog.hs0000644000000000000000000000674607346545000020534 0ustar0000000000000000{-| Copyright : (C) 2020, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Bool isKeyword t = HashSet.member (Text.toLower t) keywords parseBasic :: Text -> Bool parseBasic id0 = Verilog.parseBasic' id0 && not (isKeyword id0) parseExtended :: Text -> Bool parseExtended = Verilog.parseExtended toBasic :: Text -> Text toBasic (Verilog.toBasic' -> t) = if isKeyword t then "r_" <> t else t unextend :: Text -> Text unextend = Verilog.unextend toText :: IdentifierType -> Text -> Text toText = Verilog.toText clash-lib-1.8.1/src/Clash/Netlist/Id/VHDL.hs0000644000000000000000000001423607346545000016446 0ustar0000000000000000{-| Copyright : (C) 2020, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. )) import qualified Data.Char as Char import qualified Data.Text as Text import Data.Text (Text) import Data.Maybe (isJust, fromMaybe) import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Clash.Netlist.Types (IdentifierType(..)) -- | Identifiers which are imported from the following: -- -- use IEEE.STD_LOGIC_1164.ALL; -- use IEEE.NUMERIC_STD.ALL; -- use IEEE.MATH_REAL.ALL; -- use std.textio.all; -- -- Clash should not use these identifiers, as it can lead to errors when -- interfacing with an EDA tool. -- -- See https://github.com/clash-lang/clash-compiler/issues/1439. -- importedNames :: [Text] importedNames = [ -- ieee.std_logic_1164.all "std_ulogic", "std_ulogic_vector", "resolved", "std_logic", "std_logic_vector" , "x01", "x01z", "ux01", "ux01z", "to_bit", "to_bitvector", "to_stdulogic" , "to_stdlogicvector", "to_stdulogicvector", "to_01", "to_x01", "to_x01z" , "to_ux01", "rising_edge", "falling_edge", "is_x" -- ieee.numeric_std.all , "unresolved_unsigned", "unresolved_signed", "u_unsigned", "u_signed" , "unsigned", "signed", "find_leftmost", "find_rightmost", "minimum" , "maximum", "shift_left", "shift_right", "rotate_left", "rotate_right" , "resize", "to_integer", "to_unsigned", "to_signed", "std_match" -- ieee.math_real.all , "math_e", "math_1_over_e", "math_pi", "math_2_pi", "math_1_over_pi" , "math_pi_over_2", "math_pi_over_3", "path_pi_over_4", "path_3_pi_over_2" , "math_log_of_2", "math_log_of_10", "math_log10_of_e", "math_sqrt_2" , "math_1_over_sqrt_2", "math_sqrt_pi", "math_deg_to_rad", "math_rad_to_deg" , "sign", "ceil", "floor", "round", "trunc", "realmax", "realmin", "uniform" , "sqrt", "cbrt", "exp", "log", "log2", "log10", "sin", "cos", "tan", "arcsin" , "arccos", "arctan", "sinh", "cosh", "tanh", "arcsinh", "arccosh", "arctanh" -- std.textio.all , "line", "text", "side", "width", "justify", "input", "output", "readline" , "read", "sread", "string_read", "bread", "binary_read", "oread", "octal_read" , "hread", "hex_read", "writeline", "tee", "write", "swrite", "string_write" , "bwrite", "binary_write", "owrite", "octal_write", "hwrite", "hex_write" ] -- | Time units: are added to 'reservedWords' as simulators trip over signals -- named after them. timeUnits :: [Text] timeUnits = ["fs", "ps", "ns", "us", "ms", "sec", "min", "hr"] -- List of reserved VHDL-2008 keywords -- + used internal names: toslv, fromslv, tagtoenum, datatotag -- + used IEEE library names: integer, boolean, std_logic, std_logic_vector, -- signed, unsigned, to_integer, to_signed, to_unsigned, string keywords :: HashSet Text keywords = HashSet.fromList $ ["abs","access","after","alias","all","and","architecture" ,"array","assert","assume","assume_guarantee","attribute","begin","block" ,"body","buffer","bus","case","component","configuration","constant","context" ,"cover","default","disconnect","downto","else","elsif","end","entity","exit" ,"fairness","file","for","force","function","generate","generic","group" ,"guarded","if","impure","in","inertial","inout","is","label","library" ,"linkage","literal","loop","map","mod","nand","new","next","nor","not","null" ,"of","on","open","or","others","out","package","parameter","port","postponed" ,"procedure","process","property","protected","pure","range","record" ,"register","reject","release","rem","report","restrict","restrict_guarantee" ,"return","rol","ror","select","sequence","severity","signal","shared","sla" ,"sll","sra","srl","strong","subtype","then","to","transport","type" ,"unaffected","units","until","use","variable","vmode","vprop","vunit","wait" ,"when","while","with","xnor","xor","toslv","fromslv","tagtoenum","datatotag" ,"integer", "boolean", "std_logic", "std_logic_vector", "signed", "unsigned" ,"to_integer", "to_signed", "to_unsigned", "string","log"] <> timeUnits <> importedNames isKeyword :: Text -> Bool isKeyword t = HashSet.member (Text.toLower t) keywords parseBasic :: Text -> Bool parseBasic id0 = parseBasic' id0 && not (isKeyword id0) parseBasic' :: Text -> Bool parseBasic' id0 = isJust $ do id1 <- parseLetter id0 id2 <- repeatParse parseGroup id1 failNonEmpty id2 where parseGroup s0 = do s1 <- parseUnderscore s0 <|> Just s0 s2 <- parseLetterOrDigit s1 repeatParse parseLetterOrDigit s2 parseExtended :: Text -> Bool parseExtended id0 = isJust $ do id1 <- parseBackslash id0 id2 <- parse id1 id3 <- parseBackslash id2 failNonEmpty id3 where parse s0 = case parseBackslash s0 of Just s1 -> parseBackslash s1 >>= repeatParse parse Nothing -> parsePrintable s0 >>= repeatParse parse toBasic :: Text -> Text toBasic = replaceKeywords . stripMultiscore . Text.dropWhileEnd (=='_') . Text.dropWhile (\c -> c == '_' || Char.isDigit c) . zEncode isBasicChar . stripDollarPrefixes -- . Text.toLower where replaceKeywords i | isKeyword i = "r_" <> i | otherwise = i stripMultiscore = Text.concat . Prelude.map (\cs -> case Text.head cs of {'_' -> "_"; _ -> cs}) . Text.group isBasicChar :: Char -> Bool isBasicChar c = or [ Char.isAsciiLower c , Char.isAsciiUpper c , Char.isDigit c , c == '_' ] stripDollarPrefixes :: Text -> Text stripDollarPrefixes = stripWorkerPrefix . stripSpecPrefix . stripConPrefix . stripWorkerPrefix . stripDictFunPrefix where stripDictFunPrefix t = maybe t (Text.takeWhileEnd (/='_')) (Text.stripPrefix "$f" t) stripWorkerPrefix t = fromMaybe t (Text.stripPrefix "$w" t) stripConPrefix t = fromMaybe t (Text.stripPrefix "$c" t) stripSpecPrefix t = fromMaybe t (Text.stripPrefix "$s" t) unextend :: Text -> Text unextend = Text.strip . (\t -> fromMaybe t (Text.stripPrefix "\\" t)) . (\t -> fromMaybe t (Text.stripSuffix "\\" t)) . Text.strip toText :: IdentifierType -> Text -> Text toText Basic t = t toText Extended t = "\\" <> t <> "\\" clash-lib-1.8.1/src/Clash/Netlist/Id/Verilog.hs0000644000000000000000000000662207346545000017320 0ustar0000000000000000{-| Copyright : (C) 2020, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. )) import qualified Data.Char as Char import Data.Maybe (isJust, fromMaybe) import qualified Data.Text as Text import Data.Text (Text) import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Clash.Netlist.Id.Common import Clash.Netlist.Types (IdentifierType(..)) -- List of reserved Verilog-2005 keywords keywords :: HashSet Text keywords = HashSet.fromList ["always","and","assign","automatic","begin","buf","bufif0" ,"bufif1","case","casex","casez","cell","cmos","config","deassign","default" ,"defparam","design","disable","edge","else","end","endcase","endconfig" ,"endfunction","endgenerate","endmodule","endprimitive","endspecify" ,"endtable","endtask","event","for","force","forever","fork","function" ,"generate","genvar","highz0","highz1","if","ifnone","incdir","include" ,"initial","inout","input","instance","integer","join","large","liblist" ,"library","localparam","macromodule","medium","module","nand","negedge" ,"nmos","nor","noshowcancelled","not","notif0","notif1","or","output" ,"parameter","pmos","posedge","primitive","pull0","pull1","pulldown","pullup" ,"pulsestyle_onevent","pulsestyle_ondetect","rcmos","real","realtime","reg" ,"release","repeat","rnmos","rpmos","rtran","rtranif0","rtranif1","scalared" ,"showcancelled","signed","small","specify","specparam","strong0","strong1" ,"supply0","supply1","table","task","time","tran","tranif0","tranif1","tri" ,"tri0","tri1","triand","trior","trireg","unsigned","use","uwire","vectored" ,"wait","wand","weak0","weak1","while","wire","wor","xnor","xor"] isKeyword :: Text -> Bool isKeyword t = HashSet.member (Text.toLower t) keywords parseBasic :: Text -> Bool parseBasic id0 = parseBasic' id0 && not (isKeyword id0) parseBasic' :: Text -> Bool parseBasic' id0 = isJust $ do id1 <- parseUnderscore id0 <|> parseLetter id0 id2 <- repeatParse parseAllowedChars id1 failNonEmpty id2 where parseAllowedChars s = parseLetterOrDigit s <|> parseUnderscore s <|> parseDollar s parseExtended :: Text -> Bool parseExtended id0 = isJust ((parse id0 >>= failNonEmpty) >> parseEnd id0) where -- Extended identifier must start with backslash, followed by printable chars parse s = parseBackslash s >>= repeatParse parsePrintable -- Extended identifier must end in exactly one whitespace parseEnd :: Text -> Maybe Text parseEnd s = case Text.unpack (Text.takeEnd 2 s) of [c0, c1] | not (isWhiteSpace c0) && isWhiteSpace c1 -> Just "" _ -> Nothing toBasic' :: Text -> Text toBasic' (zEncode isBasicChar -> t) = case Text.uncons t of Just (c, _) | Char.isDigit c || c == '$' -> Text.cons '_' t _ -> t toBasic :: Text -> Text toBasic (toBasic' -> t) = if HashSet.member (Text.toLower t) keywords then "r_" <> t else t isBasicChar :: Char -> Bool isBasicChar c = or [ Char.isAsciiLower c , Char.isAsciiUpper c , Char.isDigit c , c == '_' , c == '$' ] unextend :: Text -> Text unextend = Text.strip . (\t -> fromMaybe t (Text.stripPrefix "\\" t)) . Text.strip toText :: IdentifierType -> Text -> Text toText Basic t = t toText Extended t = "\\" <> t <> " " clash-lib-1.8.1/src/Clash/Netlist/Types.hs0000644000000000000000000011136707346545000016464 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2017 , Myrtle Software Ltd, 2017-2018, Google Inc. 2020-2023, QBayLogic B.V. 2022-2023, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Type and instance definitions for Netlist modules -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Netlist.Types ( Declaration (..,NetDecl) , module Clash.Netlist.Types ) where import Control.DeepSeq import qualified Control.Lens as Lens import Control.Lens (Lens', (.=)) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail) #endif import Control.Monad.Reader (ReaderT, MonadReader) 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) import Data.Hashable (Hashable(hash,hashWithSalt)) import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import qualified Data.List as List 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 import Data.Text (Text) import Data.Typeable (Typeable) import Data.Text.Prettyprint.Doc.Extra (Doc) import GHC.Generics (Generic) import GHC.Stack import Language.Haskell.TH.Syntax (Lift) #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (SrcSpan) #else 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, HasUsageMap (..)) import Clash.Core.HasType import Clash.Core.Type (Type) import Clash.Core.Var (Id) import Clash.Core.TyCon (TyConMap) import Clash.Core.VarEnv (VarEnv) import Clash.Driver.Types (BindingMap, ClashEnv(..), ClashOpts(..)) import Clash.Netlist.BlackBox.Types (BlackBoxTemplate) import Clash.Primitives.Types (CompiledPrimMap) import Clash.Signal.Internal (ResetPolarity, ActiveEdge, ResetKind, InitBehavior) import Clash.Unique (Unique) import Clash.Annotations.BitRepresentation.Internal (CustomReprs, DataRepr', ConstrRepr') import {-# SOURCE #-} qualified Clash.Netlist.Id as Id (toText) -- | Structure describing a top entity: it's id and its port annotations. data TopEntityT = TopEntityT { topId :: Id -- ^ Id of top entity , topAnnotation :: Maybe TopEntity -- ^ (Maybe) a topentity annotation , topIsTestBench :: Bool -- ^ Whether this entity is a test bench } deriving (Generic, Show, Eq) -- | Same as "TopEntity", but with all port names that end up in HDL specified data ExpandedTopEntity a = ExpandedTopEntity { et_inputs :: [Maybe (ExpandedPortName a)] -- ^ Inputs with fully expanded port names. /Nothing/ if port is void. , et_output :: Maybe (ExpandedPortName a) -- ^ Output with fully expanded port names. /Nothing/ if port is void or -- BiDirectionalOut. } deriving (Show, Functor, Foldable, Traversable) -- | See "ExpandedTopEntity" data ExpandedPortName a -- | Same as "PortName", but fully expanded = ExpandedPortName HWType a -- | Same as "PortProduct", but fully expanded | ExpandedPortProduct Text -- ^ Name hint. Can be used to create intermediate signal names. HWType -- ^ Type of product [ExpandedPortName a] -- ^ Product fields deriving (Show, Functor, Foldable, Traversable) -- | Monad that caches generated components (StateT) and remembers hidden inputs -- of components that are being generated (WriterT) newtype NetlistMonad a = NetlistMonad { runNetlist :: Strict.StateT NetlistState (ReaderT NetlistEnv IO) a } deriving newtype (Functor, Monad, Applicative, MonadReader NetlistEnv, Strict.MonadState NetlistState, Strict.MonadIO, MonadFail) type HWMap = Map Type (Either String FilteredHWType) -- | See 'is_freshCache' type FreshCache = HashMap Text (IntMap Word) type IdentifierText = Text -- | Whether to preserve casing in ids or converted everything to -- lowercase. Influenced by '-fclash-lower-case-basic-identifiers' data PreserveCase = PreserveCase | ToLower deriving (Show, Generic, NFData, Eq, Binary, Hashable) -- See: http://vhdl.renerta.com/mobile/source/vhd00037.htm -- http://www.verilog.renerta.com/source/vrg00018.htm data IdentifierType = Basic -- ^ A basic identifier: does not have to be escaped in order to be a valid -- identifier in HDL. | Extended -- ^ An extended identifier: has to be escaped, wrapped, or otherwise -- postprocessed before writhing it to HDL. deriving (Show, Generic, NFData, Eq) -- | A collection of unique identifiers. Allows for fast fresh identifier -- generation. -- -- __NB__: use the functions in Clash.Netlist.Id. Don't use the constructor directly. data IdentifierSet = IdentifierSet { is_allowEscaped :: !Bool -- ^ Allow escaped ids? If set to False, "make" will always behave like -- "makeBasic". , is_lowerCaseBasicIds :: !PreserveCase -- ^ Force all generated basic identifiers to lowercase. , is_hdl :: !HDL -- ^ HDL to generate fresh identifiers for , is_freshCache :: !FreshCache -- ^ Maps an 'i_baseNameCaseFold' to a map mapping the number of -- extensions (in 'i_extensionsRev') to the maximum word at that -- basename/level. For example, if a set would contain the identifiers: -- -- [foo, foo_1, foo_2, bar_5, bar_7_8] -- -- the map would look like: -- -- [(foo, [(0, 0), (1, 2)]), (bar, [(1, 5), (2, 8)])] -- -- This mapping makes sure we can quickly generate fresh identifiers. For -- example, generating a new id for "foo_1" would be a matter of looking -- up the base name in this map, concluding that the maximum identifier -- with this basename and this number of extensions is "foo_2", -- subsequently generating "foo_3". -- -- Note that an identifier with no extensions is also stored in this map -- for practical purposes, but the maximum ext is invalid. , is_store :: !(HashSet Identifier) -- ^ Identifier store } deriving (Generic, NFData, Show) -- | HDL identifier. Consists of a base name and a number of extensions. An -- identifier with a base name of "foo" and a list of extensions [1, 2] will be -- rendered as "foo_1_2". -- -- Note: The Eq instance of "Identifier" is case insensitive! E.g., two -- identifiers with base names 'fooBar' and 'FoObAR' are considered the same. -- However, identifiers are stored case preserving. This means Clash won't -- generate two identifiers with differing case, but it will try to keep -- capitalization. -- -- The goal of this data structure is to greatly simplify how Clash deals with -- identifiers internally. Any Identifier should be trivially printable to any -- HDL. -- -- __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 -- appear in the HDL exactly as the user specified. = RawIdentifier !Text -- ^ An identifier exactly as given by the user (Maybe Identifier) -- ^ Parsed version of raw identifier. Will not be populated if this -- identifier was created with an unsafe function. !CallStack -- ^ Stores where this identifier was generated. Tracking is only enabled -- is 'debugIsOn', otherwise this field will be populated by an empty -- callstack. -- | Parsed and sanitized identifier. See various fields for more information -- on its invariants. | UniqueIdentifier { i_baseName :: !Text -- ^ Base name of identifier. 'make' makes sure this field: -- -- * does not end in '_num' where 'num' is a digit. -- * is solely made up of printable ASCII characters -- * has no leading or trailing whitespace -- , i_baseNameCaseFold :: !Text -- ^ Same as 'i_baseName', but can be used for equality testing that doesn't -- depend on capitalization. , i_extensionsRev :: [Word] -- ^ Extensions applied to base identifier. E.g., an identifier with a base -- name of 'foo' and an extension of [6, 5] would render as 'foo_5_6'. Note -- that extensions are stored in reverse order for easier manipulation. , i_idType :: !IdentifierType -- ^ See 'IdentifierType'. , i_hdl :: !HDL -- ^ HDL this identifier is generated for. , i_provenance :: !CallStack -- ^ Stores where this identifier was generated. Tracking is only enabled -- is 'debugIsOn', otherwise this field will be populated by an empty -- callstack. } deriving (Show, Generic, NFData) identifierKey# :: Identifier -> ((Text, Bool), [Word]) identifierKey# (RawIdentifier t _id _) = ((t, True), []) identifierKey# id_ = ((i_baseNameCaseFold id_, False), i_extensionsRev id_) instance Hashable Identifier where hashWithSalt salt = hashWithSalt salt . hash hash = uncurry hash# . identifierKey# where hash# a extensions = -- 'hash' has an identity around zero, e.g. `hash (0, 2) == 2`. Because a -- lot of zeros can be expected, extensions are fuzzed in order to keep -- efficient `HashMap`s. let fuzz fuzzFactor ext = fuzzFactor * fuzzFactor * ext in hash (a, List.foldl' fuzz 2 extensions) instance Eq Identifier where i1 == i2 = identifierKey# i1 == identifierKey# i2 i1 /= i2 = identifierKey# i1 /= identifierKey# i2 instance Ord Identifier where compare = compare `on` identifierKey# -- | Environment of the NetlistMonad data NetlistEnv = NetlistEnv { _clashEnv :: ClashEnv , _prefixName :: Text -- ^ Prefix for instance/register names , _suffixName :: Text -- ^ Postfix for instance/register names , _setName :: Maybe Text -- ^ (Maybe) user given instance/register name } data ComponentMeta = ComponentMeta { cmWereVoids :: [Bool] , cmLoc :: SrcSpan , cmScope :: IdentifierSet , cmUsage :: UsageMap } deriving (Generic, Show, NFData) type ComponentMap = OMap Unique (ComponentMeta, Component) -- | State of the NetlistMonad data NetlistState = NetlistState { _bindings :: BindingMap -- ^ Global binders , _components :: ComponentMap -- ^ Cached components. Is an insertion ordered map to preserve a topologically -- sorted component list for the manifest file. , _typeTranslator :: CustomReprs -> TyConMap -> Type -> Strict.State HWMap (Maybe (Either String FilteredHWType)) -- ^ Hardcoded Type -> HWType translator , _curCompNm :: !(Identifier,SrcSpan) , _seenIds :: IdentifierSet -- ^ All names currently in scope. , _seenComps :: IdentifierSet -- ^ Components (to be) generated during this netlist run. This is always a -- subset of 'seenIds'. Reason d'etre: we currently generate components in a -- top down manner. E.g. given: -- -- - A -- -- B -- -- C -- -- we would generate component 'A' first. Before trying to generate 'B' and -- 'C'. 'A' might introduce a number of signal declarations. The names of these -- signals can't clash with the name of component 'B', hence we need to pick a -- name for B unique w.r.t. all these signal names. If we would postpone -- generating a unqiue name for 'B' til _after_ generating all the signal -- names, the signal names would get all the "nice" names. E.g., a signal -- would be called "foo", thereby forcing the component 'B' to be called -- "foo_1". Ideally, we'd use the "nice" names for components, and the "ugly" -- names for signals. To achieve this, we generate all the component names -- up front and subsequently store them in '_seenComps'. , _seenPrimitives :: Set.Set Text -- ^ Keeps track of invocations of ´mkPrimitive´. It is currently used to -- filter duplicate warning invocations for dubious blackbox instantiations, -- see GitHub pull request #286. , _componentNames :: VarEnv Identifier -- ^ Names of components (to be) generated during this netlist run. Includes -- top entity names. , _topEntityAnns :: VarEnv TopEntityT , _hdlDir :: FilePath , _curBBlvl :: Int -- ^ The current scoping level assigned to black box contexts , _isTestBench :: Bool -- ^ Whether we're compiling a testbench (suppresses some warnings) , _backEndITE :: Bool -- ^ Whether the backend supports ifThenElse expressions , _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 = ComponentPrefix { componentPrefixTop :: Maybe Text -- ^ Prefix for top-level components , componentPrefixOther :: Maybe Text -- ^ Prefix for all other components } deriving Show -- | Existentially quantified backend data SomeBackend where SomeBackend :: Backend backend => backend -> SomeBackend type Comment = Text type Directive = Text data CommentOrDirective = Comment Comment | Directive Directive deriving Show -- | Component: base unit of a Netlist data Component = Component { componentName :: !Identifier -- ^ Name of the component , inputs :: [(Identifier,HWType)] -- ^ Input ports , outputs :: [(Usage,(Identifier,HWType),Maybe Expr)] -- ^ Output ports , declarations :: [Declaration] -- ^ Internal declarations } deriving (Show, Generic, NFData) -- | Check if an input port is really an inout port. -- isBiDirectional :: (Identifier, HWType) -> Bool 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 where isClock (i, Clock d) = Just (Id.toText i, d) isClock (i, Annotated _ t) = isClock (i,t) isClock _ = Nothing -- | Size indication of a type (e.g. bit-size or number of elements) type Size = Int type IsVoid = Bool -- | Tree structure indicating which constructor fields were filtered from -- a type due to them being void. We need this information to generate stable -- and/or user-defined port mappings. data FilteredHWType = FilteredHWType HWType [[(IsVoid, FilteredHWType)]] deriving (Eq, Show) type DomainName = Text -- | Representable hardware types data HWType = Void (Maybe HWType) -- ^ Empty type. @Just Size@ for "empty" Vectors so we can still have -- primitives that can traverse e.g. Vectors of unit and know the length of -- that vector. | String -- ^ String type | Integer -- ^ Integer type (for parameters only) | Bool -- ^ Boolean type | Bit -- ^ Bit type | BitVector !Size -- ^ BitVector of a specified size | Index !Integer -- ^ Unsigned integer with specified (exclusive) upper bounder | Signed !Size -- ^ Signed integer of a specified size | Unsigned !Size -- ^ Unsigned integer of a specified size | Vector !Size !HWType -- ^ Vector type | MemBlob !Size !Size -- ^ MemBlob type | RTree !Size !HWType -- ^ RTree type | Sum !Text [Text] -- ^ Sum type: Name and Constructor names | Product !Text (Maybe [Text]) [HWType] -- ^ Product type: Name, field names, and field types. Field names will be -- populated when using records. | SP !Text [(Text, [HWType])] -- ^ 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 -- ^ Enable type corresponding to domain /DomainName/ | BiDirectional !PortDirection !HWType -- ^ Tagging type indicating a bidirectional (inout) port | CustomSP !Text !DataRepr' !Size [(ConstrRepr', Text, [HWType])] -- ^ Same as Sum-Of-Product, but with a user specified bit representation. For -- more info, see: Clash.Annotations.BitRepresentations. | CustomSum !Text !DataRepr' !Size [(ConstrRepr', Text)] -- ^ Same as Sum, but with a user specified bit representation. For more info, -- see: Clash.Annotations.BitRepresentations. | 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 Text] !HWType -- ^ Annotated with HDL attributes | KnownDomain !DomainName !Integer !ActiveEdge !ResetKind !InitBehavior !ResetPolarity -- ^ Domain name, period, active edge, reset kind, initial value behavior | FileType -- ^ 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 _ -> Nothing -- | 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 Text] hwTypeAttrs (Annotated attrs _type) = attrs hwTypeAttrs _ = [] -- | Specifies how to wire up a component instance data PortMap = IndexedPortMap [(PortDirection, HWType, Expr)] -- ^ Port map based on port positions (port direction, type, assignment) -- -- HDL Example: -- -- bytemaster bytemaster_ds -- ( clk_1 -- , rst_1 -- , bitCtrl_0 ); -- | NamedPortMap [(Expr, PortDirection, HWType, Expr)] -- ^ Port map based on port names (port name, port direction, type, assignment) -- -- HDL Example: -- -- bytemaster bytemaster_ds -- ( .clk (clk_1) -- , .rst (rst_1) -- , .bitCtrl (bitCtrl_0) ); -- deriving (Show) -- | Internals of a Component data Declaration -- | Signal assignment = Assignment !Identifier -- ^ Signal to assign !Usage -- ^ How the signal is assigned !Expr -- ^ Assigned expression -- | Conditional signal assignment: | CondAssignment !Identifier -- ^ Signal to assign !HWType -- ^ Type of the result/alternatives !Expr -- ^ Scrutinized expression !HWType -- ^ Type of the scrutinee [(Maybe Literal,Expr)] -- ^ List of: (Maybe expression scrutinized expression is compared with,RHS of alternative) -- | Instantiation of another component: | InstDecl EntityOrComponent -- ^ Whether it's an entity or a component (Maybe Text) -- ^ Library instance is defined in [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) PortMap -- | Instantiation of blackbox declaration | BlackBoxD !Text -- ^ Primitive name [BlackBoxTemplate] -- ^ VHDL only: add @library@ declarations [BlackBoxTemplate] -- ^ VHDL only: add @use@ declarations [((Text,Text),BlackBox)] -- ^ Intel Quartus only: create a @.qsys@ file from given template !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 !Identifier -- ^ Name of signal HWType -- ^ Type of signal (Maybe Expr) -- ^ Initial value -- ^ Signal declaration -- | HDL tick corresponding to a Core tick | TickDecl CommentOrDirective -- | Sequential statement | Seq [Seq] -- | Compilation conditional on some preprocessor symbol, note that -- declarations here are ignored for VHDL. See here for a discussion -- https://github.com/clash-lang/clash-compiler/pull/1798#discussion_r648571862 | ConditionalDecl !Text -- ^ condition text, for example @FORMAL@ [Declaration] deriving Show -- | Sequential statements data Seq -- | Clocked sequential statements = AlwaysClocked ActiveEdge -- ^ Edge of the clock the statement should be executed Expr -- ^ Clock expression [Seq] -- ^ Statements to be executed on the active clock edge -- | Statements running at simulator start | Initial [Seq] -- ^ Statements to run at simulator start -- | Statements to run always | AlwaysComb [Seq] -- ^ Statements to run always -- | Declaration in sequential form | SeqDecl Declaration -- ^ The declaration -- | Branching statement | Branch !Expr -- ^ Scrutinized expresson !HWType -- ^ Type of the scrutinized expression [(Maybe Literal,[Seq])] -- ^ List of: (Maybe match, RHS of Alternative) 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) -- NOTE [`Semigroup` instances for `Blocking` and `Usage`] instance Semigroup Blocking where NonBlocking <> y = y Blocking <> _ = Blocking -- | 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 -> Identifier -- ^ Name of signal -> HWType -- ^ Type of signal -> Declaration pattern NetDecl note d ty <- NetDecl' note d ty _ where NetDecl note d ty = NetDecl' note d ty Nothing data PortDirection = In | Out deriving (Eq,Ord,Show,Generic,NFData,Hashable) instance NFData Declaration where rnf a = a `seq` () -- | Expression Modifier data Modifier = 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 -- | Expression used in RHS of a declaration data Expr = Literal !(Maybe (HWType,Size)) !Literal -- ^ Literal expression | DataCon !HWType !Modifier [Expr] -- ^ DataCon application | Identifier !Identifier !(Maybe Modifier) -- ^ Signal reference | DataTag !HWType !(Either Identifier Identifier) -- ^ @Left e@: tagToEnum\#, @Right e@: dataToTag\# -- | Instantiation of a BlackBox expression | BlackBoxE !Text -- ^ Primitive name [BlackBoxTemplate] -- ^ VHDL only: add @library@ declarations [BlackBoxTemplate] -- ^ VHDL only: add @use@ declarations: [((Text,Text),BlackBox)] -- ^ Intel/Quartus only: create a @.qsys@ file from given template. !BlackBox -- ^ Template tokens !BlackBoxContext -- ^ Context in which tokens should be rendered !Bool -- ^ Wrap in parentheses? -- | Convert some type to a BitVector. | ToBv (Maybe Identifier) -- ^ Type prefix HWType -- ^ Type to convert _from_ Expr -- ^ Expression to convert to BitVector -- | Convert BitVector to some type. | FromBv (Maybe Identifier) -- ^ Type prefix HWType -- ^ Type to convert _to_ Expr -- ^ BitVector to convert | IfThenElse Expr Expr Expr -- | Do nothing | Noop deriving Show 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 | BitLit !Bit -- ^ Bit literal | BitVecLit !Integer !Integer -- ^ BitVector literal | BoolLit !Bool -- ^ Boolean literal | VecLit [Literal] -- ^ Vector literal | StringLit !String -- ^ String literal deriving (Eq,Show) -- | Bit literal data Bit = H -- ^ High | L -- ^ Low | U -- ^ Undefined | Z -- ^ High-impedance deriving (Eq,Show,Typeable,Lift) toBit :: Integer -- ^ mask -> Integer -- ^ value -> Bit toBit m i = if testBit m 0 then U else if testBit i 0 then H else L -- | Context used to fill in the holes of a BlackBox template data BlackBoxContext = Context { bbName :: Text -- ^ Blackbox function name (for error reporting) , bbResults :: [(Expr,HWType)] -- ^ Result names and types. Will typically be a list with a single item. -- Multiple result targets will be used for "multi result primitives". See -- 'Clash.Normalize.Transformations.setupMultiResultPrim'. , bbInputs :: [(Expr,HWType,Bool)] -- ^ Argument names, types, and whether it is a literal , bbFunctions :: IntMap [(Either BlackBox (Identifier,[Declaration]) ,Usage ,[BlackBoxTemplate] ,[BlackBoxTemplate] ,[((Text,Text),BlackBox)] ,BlackBoxContext)] -- ^ Function arguments (subset of inputs): -- -- * ( Blackbox Template -- , Whether the result should be /reg/ or a /wire/ (Verilog only) -- , Partial Blackbox Context -- ) , bbQsysIncName :: [IdentifierText] , bbLevel :: Int -- ^ The scoping level this context is associated with, ensures that -- @~ARGN[k][n]@ holes are only filled with values from this context if @k@ -- is equal to the scoping level of this context. , bbCompName :: Identifier -- ^ The component the BlackBox is instantiated in , bbCtxName :: Maybe IdentifierText -- ^ The "context name", name set by `Clash.Magic.setName`, defaults to the -- name of the closest binder } deriving Show type BBName = String type BBHash = Int data BlackBox = BBTemplate BlackBoxTemplate | BBFunction BBName BBHash TemplateFunction deriving (Generic, NFData, Binary) data TemplateFunction where TemplateFunction :: [Int] -- ^ Used arguments -> (BlackBoxContext -> Bool) -- ^ Validation function. Should return 'False' if function can't render -- given a certain context. -> (forall s . Backend s => BlackBoxContext -> Lazy.State s Doc) -- ^ Render function -> TemplateFunction instance Show BlackBox where showsPrec d (BBTemplate t) = showParen (d > 10) $ ("BBTemplate " ++) . showsPrec 11 t showsPrec _ (BBFunction nm hsh _) = ("" ++) instance NFData TemplateFunction where rnf (TemplateFunction is f _) = rnf is `seq` f `seq` () -- | __NB__: serialisation doesn't preserve the embedded function instance Binary TemplateFunction where put (TemplateFunction is _ _ ) = put is get = (\is -> TemplateFunction is err err) <$> get where err = const $ error "TemplateFunction functions can't be preserved by serialisation" -- | Netlist-level identifier data NetlistId = NetlistId Identifier Type -- ^ Identifier generated in the NetlistMonad, always derived from another -- 'NetlistId' | CoreId Id -- ^ An original Core identifier | 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 (Eq, Show) -- | Eliminator for 'NetlistId', fails on 'MultiId' netlistId1 :: HasCallStack => (Identifier -> r) -- ^ Eliminator for Identifiers generated in the NetlistMonad -> (Id -> r) -- ^ Eliminator for original Core Identifiers -> NetlistId -> r netlistId1 f g = \case NetlistId i _ -> f i CoreId i -> g i m -> error ("netlistId1 MultiId: " ++ show m) -- | Return the type(s) of a 'NetListId', returns multiple types when given a -- 'MultiId' netlistTypes :: NetlistId -> [Type] netlistTypes = \case NetlistId _ t -> [t] CoreId i -> [coreTypeOf i] MultiId is -> map coreTypeOf is -- | Return the type of a 'NetlistId', fails on 'MultiId' netlistTypes1 :: HasCallStack => NetlistId -> Type netlistTypes1 = \case NetlistId _ t -> t CoreId i -> coreTypeOf i m -> error ("netlistTypes1 MultiId: " ++ show m) -- | Type of declaration, concurrent or sequential data DeclarationType = Concurrent | Sequential emptyBBContext :: Text -> BlackBoxContext emptyBBContext name = Context { bbName = name , bbResults = [] , bbInputs = [] , bbFunctions = empty , bbQsysIncName = [] , bbLevel = (-1) , bbCompName = UniqueIdentifier "__NOCOMPNAME__" "__NOCOMPNAME__" [] Basic VHDL emptyCallStack , bbCtxName = Nothing } Lens.makeLenses ''NetlistEnv Lens.makeLenses ''NetlistState intWidth :: Lens.Getter NetlistEnv Int intWidth = clashEnv . Lens.to (opt_intWidth . envOpts) customReprs :: Lens.Getter NetlistEnv CustomReprs customReprs = clashEnv . Lens.to envCustomReprs tcCache :: Lens.Getter NetlistEnv TyConMap tcCache = clashEnv . Lens.to envTyConMap primitives :: Lens.Getter NetlistEnv CompiledPrimMap primitives = clashEnv . Lens.to envPrimitives clashOpts :: Lens.Getter NetlistEnv ClashOpts clashOpts = clashEnv . Lens.to envOpts -- | Structures that hold an 'IdentifierSet' class HasIdentifierSet s where identifierSet :: Lens' s IdentifierSet 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 identifierSetM :: (IdentifierSet -> IdentifierSet) -> m IdentifierSet instance IdentifierSetMonad NetlistMonad where identifierSetM f = do is0 <- Lens.use seenIds let is1 = f is0 seenIds .= is1 pure is1 {-# INLINE identifierSetM #-} instance HasIdentifierSet s => IdentifierSetMonad (Strict.State s) where identifierSetM f = do is0 <- Lens.use identifierSet identifierSet .= f is0 Lens.use identifierSet {-# INLINE identifierSetM #-} instance HasIdentifierSet s => IdentifierSetMonad (Lazy.State s) where identifierSetM f = do is0 <- Lens.use identifierSet identifierSet .= f is0 Lens.use identifierSet {-# INLINE identifierSetM #-} instance IdentifierSetMonad m => IdentifierSetMonad (Ap m) where identifierSetM = Ap . identifierSetM clash-lib-1.8.1/src/Clash/Netlist/Types.hs-boot0000644000000000000000000000261607346545000017421 0ustar0000000000000000{-| Copyright : (C) 2018, Google Inc, 2022, QBayLogic B.V. 2022, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} {-# LANGUAGE RoleAnnotations #-} module Clash.Netlist.Types where import Control.DeepSeq (NFData) import Control.Lens (Lens') import Data.Aeson (FromJSON) import Data.Binary (Binary) import Data.Hashable (Hashable) import Data.Map (Map) import Data.Text (Text) data IdentifierType data Identifier data IdentifierSet data HWType data Declaration data Component data Expr data BlackBox data TopEntityT instance NFData BlackBox class Monad m => IdentifierSetMonad m where identifierSetM :: (IdentifierSet -> IdentifierSet) -> m IdentifierSet class HasIdentifierSet s where identifierSet :: Lens' s IdentifierSet type role NetlistMonad nominal data NetlistMonad a data PreserveCase = PreserveCase | ToLower instance Hashable PreserveCase 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 clash-lib-1.8.1/src/Clash/Netlist/Util.hs0000644000000000000000000023315407346545000016274 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2017 , Myrtle Software Ltd 2017-2018, Google Inc. 2021-2023, QBayLogic B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Utilities for converting Core Type/Term to Netlist datatypes -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} #if !MIN_VERSION_ghc(8,8,0) {-# LANGUAGE MonadFailDesugaring #-} #endif {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Netlist.Util where import Data.Coerce (coerce) import Control.Exception (throw) import Control.Lens ((.=), (%=)) import qualified Control.Lens as Lens import Control.Monad (when, zipWithM) import Control.Monad.Extra (concatMapM) import Control.Monad.Reader (ask, local) import qualified Control.Monad.State as State import Control.Monad.State.Strict (State, evalState, get, modify, runState) import Control.Monad.Trans.Except (ExceptT (..), runExcept, runExceptT, throwE) 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 import qualified Data.IntSet as IntSet import Control.Applicative (Alternative((<|>))) import Data.List (unzip4, partition) import qualified Data.List as List import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe (catMaybes, fromMaybe, isNothing, mapMaybe, isJust, listToMaybe, maybeToList) import Text.Printf (printf) import Data.Text (Text) import qualified Data.Text as Text import Data.Text.Extra (showt) import Data.Text.Lazy (toStrict) import Data.Text.Prettyprint.Doc.Extra import GHC.Stack (HasCallStack) #if MIN_VERSION_ghc(9,0,0) import GHC.Utils.Monad (zipWith3M) import GHC.Utils.Outputable (ppr, showSDocUnsafe) #else import MonadUtils (zipWith3M) import Outputable (ppr, showSDocUnsafe) #endif import Clash.Annotations.TopEntity (TopEntity(..), PortName(..), defSyn) import Clash.Annotations.BitRepresentation.ClashLib (coreToType') import Clash.Annotations.BitRepresentation.Internal (CustomReprs, ConstrRepr'(..), DataRepr'(..), getDataRepr, uncheckedGetConstrRepr) 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') import Clash.Core.HasFreeVars (elemFreeVars) import Clash.Core.HasType import qualified Clash.Core.Literal as C import Clash.Core.Name (Name (..), appendToName, nameOcc) import Clash.Core.Pretty (showPpr) import Clash.Core.Subst (Subst (..), extendIdSubst, extendIdSubstList, extendInScopeId, extendInScopeIdList, mkSubst, substTm) import Clash.Core.Term (primMultiResult, MultiPrimInfo(..), Alt, LetBinding, Pat (..), Term (..), TickInfo (..), NameMod (..), IsMultiPrim (..), collectArgsTicks, collectTicks, collectBndrs, PrimInfo(primName), mkTicks, stripTicks) import Clash.Core.TermInfo import Clash.Core.TyCon (TyCon (FunTyCon), TyConName, TyConMap, tyConDataCons) import Clash.Core.Type (Type (..), TyVar, TypeView (..), coreView1, normalizeType, splitTyConAppM, tyView) import Clash.Core.Util (substArgTys, tyLitShow) import Clash.Core.Var (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 (bbResultNames, BlackBoxMeta(BlackBoxMeta)) import qualified Clash.Netlist.Id as Id import Clash.Netlist.Types as HW import Clash.Primitives.Types import Clash.Util import qualified Clash.Util.Interpolate as I hmFindWithDefault :: (Eq k, Hashable k) => v -> k -> HashMap k v -> v #if MIN_VERSION_unordered_containers(0,2,11) hmFindWithDefault = HashMap.findWithDefault #else hmFindWithDefault = HashMap.lookupDefault #endif -- | Generate a simple port_name expression. See: -- -- https://www.hdlworks.com/hdl_corner/vhdl_ref/VHDLContents/PortMap.htm -- -- This function will simply make the left part of a single port map, e.g. "Rst" -- in: -- -- Rst => Reset -- -- If you need more complex constructions, e.g. -- -- Q(3 downto 1) -- -- you can build an Expr manually. instPort :: Text -> Expr instPort pn = Identifier (Id.unsafeMake pn) Nothing -- | Throw away information indicating which constructor fields were filtered -- due to being void. stripFiltered :: FilteredHWType -> HWType stripFiltered (FilteredHWType hwty _filtered) = hwty -- | Strip as many "Void" layers as possible. Might still return a Void if the -- void doesn't contain a hwtype. stripVoid :: HWType -> HWType stripVoid (Void (Just e)) = stripVoid e stripVoid e = e flattenFiltered :: FilteredHWType -> [[Bool]] flattenFiltered (FilteredHWType _hwty filtered) = map (map fst) filtered isVoidMaybe :: Bool -> Maybe HWType -> Bool isVoidMaybe dflt Nothing = dflt isVoidMaybe _dflt (Just t) = isVoid t -- | Determines if type is a zero-width construct ("void") isVoid :: HWType -> Bool isVoid Void {} = True isVoid _ = False -- | Same as @isVoid@, but on @FilteredHWType@ instead of @HWType@ isFilteredVoid :: FilteredHWType -> Bool isFilteredVoid = isVoid . stripFiltered squashLets :: Term -> Term squashLets (Letrec xs (Letrec ys e)) = squashLets (Letrec (xs <> ys) e) squashLets e = e -- | Split a normalized term into: a list of arguments, a list of let-bindings, -- and a variable reference that is the body of the let-binding. Returns a -- String containing the error if the term was not in a normalized form. splitNormalized :: TyConMap -> Term -> (Either String ([Id],[LetBinding],Id)) splitNormalized tcm expr = case collectBndrs expr of (args, collectTicks -> (squashLets -> Letrec xes e, ticks)) | (tmArgs,[]) <- partitionEithers args -> case stripTicks e of Var v -> Right (tmArgs, fmap (second (`mkTicks` ticks)) xes,v) t -> Left ($(curLoc) ++ "Not in normal form: res not simple var: " ++ showPpr t) | otherwise -> Left ($(curLoc) ++ "Not in normal form: tyArgs") _ -> Left ($(curLoc) ++ "Not in normal form: no Letrec:\n\n" ++ showPpr expr ++ "\n\nWhich has type:\n\n" ++ showPpr ty) where ty = inferCoreTypeOf tcm expr -- | Converts a Core type to a HWType given a function that translates certain -- builtin types. Errors if the Core type is not translatable. unsafeCoreTypeToHWType :: SrcSpan -- ^ Approximate location in original source file -> String -> (CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))) -> CustomReprs -> TyConMap -> Type -> State HWMap FilteredHWType unsafeCoreTypeToHWType sp loc builtInTranslation reprs m ty = either (\msg -> throw (ClashException sp (loc ++ msg) Nothing)) id <$> coreTypeToHWType builtInTranslation reprs m ty -- | Same as @unsafeCoreTypeToHWTypeM@, but discards void filter information unsafeCoreTypeToHWTypeM' :: String -> Type -> NetlistMonad HWType unsafeCoreTypeToHWTypeM' loc ty = stripFiltered <$> unsafeCoreTypeToHWTypeM loc ty -- | Converts a Core type to a HWType within the NetlistMonad; errors on failure unsafeCoreTypeToHWTypeM :: String -> Type -> NetlistMonad FilteredHWType unsafeCoreTypeToHWTypeM loc ty = do (_,cmpNm) <- Lens.use curCompNm tt <- Lens.use typeTranslator reprs <- Lens.view customReprs tcm <- Lens.view tcCache htm0 <- Lens.use htyCache let (hty,htm1) = runState (unsafeCoreTypeToHWType cmpNm loc tt reprs tcm ty) htm0 htyCache Lens..= htm1 return hty -- | Same as @coreTypeToHWTypeM@, but discards void filter information coreTypeToHWTypeM' :: Type -- ^ Type to convert to HWType -> NetlistMonad (Maybe HWType) coreTypeToHWTypeM' ty = fmap stripFiltered <$> coreTypeToHWTypeM ty -- | Converts a Core type to a HWType within the NetlistMonad; 'Nothing' on failure coreTypeToHWTypeM :: Type -- ^ Type to convert to HWType -> NetlistMonad (Maybe FilteredHWType) coreTypeToHWTypeM ty = do tt <- Lens.use typeTranslator reprs <- Lens.view customReprs tcm <- Lens.view tcCache htm0 <- Lens.use htyCache let (hty,htm1) = runState (coreTypeToHWType tt reprs tcm ty) htm0 htyCache Lens..= htm1 return (either (const Nothing) Just hty) -- | Constructs error message for unexpected projections out of a type annotated -- with a custom bit representation. unexpectedProjectionErrorMsg :: DataRepr' -> Int -- ^ Constructor index -> Int -- ^ Field index -> String unexpectedProjectionErrorMsg dataRepr cI fI = "Unexpected projection of zero-width type: " ++ show (drType dataRepr) ++ ". Tried to make a projection of field " ++ show fI ++ " of " ++ constrNm ++ ". Did you try to project a field marked as zero-width" ++ " by a custom bit representation annotation?" where constrNm = show (crName (drConstrs dataRepr !! cI)) -- | Helper function of 'maybeConvertToCustomRepr' convertToCustomRepr :: HasCallStack => CustomReprs -> DataRepr' -> HWType -> HWType convertToCustomRepr reprs dRepr@(DataRepr' name' size constrs) hwTy = if length constrs == nConstrs then if size <= 0 then Void (Just cs) else cs else error (unwords [ "Type", show name', "has", show nConstrs, "constructor(s), " , "but the custom bit representation only specified", show (length constrs) , "constructors." ]) where cs = insertVoids $ case hwTy of Sum name conIds -> CustomSum name dRepr size (map packSum conIds) SP name conIdsAndFieldTys -> CustomSP name dRepr size (map packSP conIdsAndFieldTys) Product name maybeFieldNames fieldTys | [ConstrRepr' _cName _pos _mask _val fieldAnns] <- constrs -> CustomProduct name dRepr size maybeFieldNames (zip fieldAnns fieldTys) _ -> error ( "Found a custom bit representation annotation " ++ show dRepr ++ ", " ++ "but it was applied to an unsupported HWType: " ++ show hwTy ++ ".") nConstrs :: Int nConstrs = case hwTy of (Sum _name conIds) -> length conIds (SP _name conIdsAndFieldTys) -> length conIdsAndFieldTys (Product {}) -> 1 _ -> error ("Unexpected HWType: " ++ show hwTy) packSP (name, tys) = (uncheckedGetConstrRepr name reprs, name, tys) packSum name = (uncheckedGetConstrRepr name reprs, name) -- Replace some "hwTy" with "Void (Just hwTy)" if the custom bit -- representation indicated that field is represented by zero bits. We can't -- simply remove them, as we'll later have to deal with an "overapplied" -- constructor. If we remove the arguments altogether, we wouldn't know which -- - on their own potentially non-void! - arguments to ignore. insertVoids :: HWType -> HWType insertVoids (CustomSP i d s constrs0) = CustomSP i d s (map go0 constrs0) where go0 (con@(ConstrRepr' _ _ _ _ fieldAnns), i0, hwTys) = (con, i0, zipWith go1 fieldAnns hwTys) go1 0 hwTy0 = Void (Just hwTy0) go1 _ hwTy0 = hwTy0 insertVoids (CustomProduct i d s f fieldAnns) = CustomProduct i d s f (map go fieldAnns) where go (0, hwTy0) = (0, Void (Just hwTy0)) go (n, hwTy0) = (n, hwTy0) insertVoids hwTy0 = hwTy0 -- | Given a map containing custom bit representation, a type, and the same -- type represented as HWType, convert the HWType to a CustomSP/CustomSum if -- it has a custom bit representation. maybeConvertToCustomRepr :: CustomReprs -- ^ Map containing all custom representations index on its type -> Type -- ^ Custom reprs are index on type, so we need the clash core type to look -- it up. -> FilteredHWType -- ^ Type of previous argument represented as a HWType -> FilteredHWType maybeConvertToCustomRepr reprs (coreToType' -> Right tyName) (FilteredHWType hwTy filtered) | Just dRepr <- getDataRepr tyName reprs = FilteredHWType (convertToCustomRepr reprs dRepr hwTy) [ [ (fieldAnn == 0, hwty) | ((_, hwty), fieldAnn) <- zip fields (crFieldAnns constr) ] | (fields, constr) <- zip filtered (drConstrs dRepr)] maybeConvertToCustomRepr _reprs _ty hwTy = hwTy -- | Same as @coreTypeToHWType@, but discards void filter information coreTypeToHWType' :: (CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))) -> CustomReprs -> TyConMap -> Type -- ^ Type to convert to HWType -> State HWMap (Either String HWType) coreTypeToHWType' builtInTranslation reprs m ty = fmap stripFiltered <$> coreTypeToHWType builtInTranslation reprs m ty -- | Converts a Core type to a HWType given a function that translates certain -- builtin types. Returns a string containing the error message when the Core -- type is not translatable. coreTypeToHWType :: (CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))) -> CustomReprs -> TyConMap -> Type -- ^ Type to convert to HWType -> State HWMap (Either String FilteredHWType) coreTypeToHWType builtInTranslation reprs m ty = do htyM <- Map.lookup ty <$> get case htyM of Just hty -> return hty _ -> do hty0M <- builtInTranslation reprs m ty hty1 <- go hty0M ty modify (Map.insert ty hty1) return hty1 where -- Try builtin translation; for now this is hardcoded to be the one in ghcTypeToHWType go :: Maybe (Either String FilteredHWType) -> Type -> State (Map Type (Either String FilteredHWType)) (Either String FilteredHWType) go (Just hwtyE) _ = pure $ maybeConvertToCustomRepr reprs ty <$> hwtyE -- Strip transparant types: go _ (coreView1 m -> Just ty') = coreTypeToHWType builtInTranslation reprs m ty' -- Try to create hwtype based on AST: go _ (tyView -> TyConApp tc args) = runExceptT $ do hwty <- mkADT builtInTranslation reprs m (showPpr ty) tc args return (maybeConvertToCustomRepr reprs ty hwty) -- All methods failed: go _ _ = return $ Left $ "Can't translate non-tycon type: " ++ showPpr ty -- | Generates original indices in list before filtering, given a list of -- removed indices. -- -- >>> originalIndices [False, False, True, False] -- [0,1,3] originalIndices :: [Bool] -- ^ Were voids. Length must be less than or equal to n. -> [Int] -- ^ Original indices originalIndices wereVoids = [i | (i, void) <- zip [0..] wereVoids, not void] -- | Converts an algebraic Core type (split into a TyCon and its argument) to a HWType. mkADT :: (CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))) -- ^ Hardcoded Type -> HWType translator -> CustomReprs -> TyConMap -- ^ TyCon cache -> String -- ^ String representation of the Core type for error messages -> TyConName -- ^ The TyCon -> [Type] -- ^ Its applied arguments -> ExceptT String (State HWMap) FilteredHWType -- ^ An error string or a tuple with the type and possibly a list of -- removed arguments. mkADT _ _ m tyString tc _ | isRecursiveTy m tc = throwE $ $(curLoc) ++ "Can't translate recursive type: " ++ tyString mkADT builtInTranslation reprs m tyString tc args = case tyConDataCons (UniqMap.find tc m) of [] -> return (FilteredHWType (Void Nothing) []) dcs -> do let tcName = nameOcc tc substArgTyss = map (`substArgTys` args) dcs argHTyss0 <- mapM (mapM (ExceptT . coreTypeToHWType builtInTranslation reprs m)) substArgTyss let argHTyss1 = map (\tys -> zip (map isFilteredVoid tys) tys) argHTyss0 let areVoids = map (map fst) argHTyss1 let filteredArgHTyss = map (map snd . filter (not . fst)) argHTyss1 -- Every alternative is annotated with some examples. Be sure to read them. case (dcs, filteredArgHTyss) of _ | any (hasUnconstrainedExistential m) dcs -> throwE $ $(curLoc) ++ "Can't translate data types with unconstrained existentials: " ++ tyString -- Type has one constructor and that constructor has a single field, -- modulo empty fields if keepVoid is False. Examples of such fields -- are: -- -- >>> data ABC = ABC Int -- >>> data DEF = DEF Int () -- -- Notice that @DEF@'s constructor has an "empty" second argument. The -- second field of FilteredHWType would then look like: -- -- >>> [[False, True]] (_:[],[[elemTy]]) -> return (FilteredHWType (stripFiltered elemTy) argHTyss1) -- Type has one constructor, but multiple fields modulo empty fields -- (see previous case for more thorough explanation). Examples: -- -- >>> data GHI = GHI Int Int -- >>> data JKL = JKL Int () Int -- -- In the second case the second field of FilteredHWType would be -- [[False, True, False]] ([dcFieldLabels -> labels0],[elemTys@(_:_)]) -> do labelsM <- if null labels0 then return Nothing else -- Filter out labels belonging to arguments filtered due to being -- void. See argHTyss1. let areNotVoids = case areVoids of areVoid:_ -> map not areVoid _ -> error "internal error: insufficient areVoids" labels1 = filter fst (zip areNotVoids labels0) labels2 = map snd labels1 in return (Just labels2) let hwty = Product tcName labelsM (map stripFiltered elemTys) return (FilteredHWType hwty argHTyss1) -- Either none of the constructors have fields, or they have been filtered -- due to them being empty. Examples: -- -- >>> data MNO = M | N | O -- >>> data PQR = P () | Q | R () -- >>> data STU = STU -- >>> data VWX (_, concat -> []) -- If none of the dataconstructors have fields, and there are 1 or less -- of them, this type only has one inhabitant. It can therefore be -- represented by zero bits, and is therefore empty: | length dcs <= 1 -> case argHTyss0 of [argHTys0] -> -- We need this to preserve constraint-tuples of `KnownDomains` let argHTys1 = map (stripVoid . stripFiltered) argHTys0 in return (FilteredHWType (Void (Just (Product tcName Nothing argHTys1))) argHTyss1) _ -> return (FilteredHWType (Void Nothing) argHTyss1) -- None of the dataconstructors have fields. This type is therefore a -- simple Sum type. | otherwise -> return (FilteredHWType (Sum tcName $ map (nameOcc . dcName) dcs) argHTyss1) -- A sum of product, due to multiple constructors, where at least one -- of the constructor has one or more fields modulo empty fields. Example: -- -- >>> data YZA = Y Int | Z () | A (_,elemHTys) -> return $ FilteredHWType (SP tcName $ zipWith (\dc tys -> ( nameOcc (dcName dc), tys)) dcs (map stripFiltered <$> elemHTys)) argHTyss1 -- | Determine whether a data constructor has unconstrained existential type -- variables, i.e. those that cannot be inferred by the (potential) constraints -- between the existential type variables and universal type variables. -- -- So here we have an example of a constrained existential: -- -- data Vec :: Nat -> Type -> Type -- where -- Nil :: Vec 0 a -- Cons :: forall m . (n ~ m + 1) => a -> Vec m a -> Vec n a -- -- where we can generate a type for `m` when we know `n` (by doing `n-1`). -- -- And here is an example of an unconstrained existential: -- -- data SomeSNat where -- where -- SomeSNat :: forall m . SNat m -> SomeSNat -- -- where there is no way to generate a type for `m` from any context. -- -- So why do we care? Because terms need to be completely monomorphic in order -- to be translated to circuits. And having a topEntity lambda-bound variable -- with an unconstrained existential type prevents us from achieving a fully -- monomorphic term. hasUnconstrainedExistential :: TyConMap -> DataCon -> Bool hasUnconstrainedExistential tcm dc = let eTVs = dcExtTyVars dc uTVs = dcUnivTyVars dc constraints = mapMaybe (typeEq tcm) (dcArgTys dc) -- Is the existential `eTV` constrained by the constraint `(ty1,ty2)` isConstrainedBy eTV (ty1,ty2) = let -- Free FVs in the LHS and RHS of the constraint that are not the -- in the set of universal type variables of the constructor. ty1FEVs = Lens.toListOf (typeFreeVars' ((`notElem` uTVs) . coerce) IntSet.empty) ty1 ty2FEVs = Lens.toListOf (typeFreeVars' ((`notElem` uTVs) . coerce) IntSet.empty) ty2 -- Determine whether `eTV` can be generated from one side of a -- constraint, under the assumption that the other side of the -- constraint mentions no existential type variables. isGenerative :: -- Side (LHS or RHS) of a constraint Type -> -- Its free type variables (that are no in the set of universal -- type variables) [TyVar] -> Bool isGenerative t efvs = case tyView t of TyConApp tcNm _ | 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`. -> [eTV] == efvs | otherwise -- Normal type constructors are fully generative, e.g. given: -- DomainConfiguration a b ~ DomainConfiguration "System" 10000 -- -- we can infer both `a ~ "System"` and `b ~ 10000` -> eTV `elem` efvs FunTy {} -- Functions are also fully generative -> eTV `elem` efvs OtherType other -> case other of VarTy v -> v == eTV LitTy _ -> False -- Anything else, like some higher-kinded quantified type we -- just give up for now. TODO: implement this _ -> False onlyTy1 = isGenerative ty1 ty1FEVs && null ty2FEVs onlyTy2 = isGenerative ty2 ty2FEVs && null ty1FEVs in onlyTy1 || onlyTy2 -- The existential type variables that are not constrained by any of the -- constraints. unconstrainedETVs = filter (\v -> not (any (isConstrainedBy v) constraints)) eTVs in not (null unconstrainedETVs) -- | Simple check if a TyCon is recursively defined. -- -- Note [Look through type families in recursivity check] -- -- Consider: -- -- @ -- data SList :: [Type] -> Type where -- SNil :: SList [] -- CSons :: a -> Sing (as :: [k]) -> SList (a:as) -- -- type family Sing [a] = SList [a] -- @ -- -- 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 (UniqMap.find tc m) of [] -> False dcs -> let argTyss = map dcArgTys dcs argTycons = (map fst . catMaybes) $ (concatMap . map) -- Note [Look through type families in recursivity check] (splitTyConAppM . normalizeType m) argTyss in tc `elem` argTycons -- | Determines if a Core type is translatable to a HWType given a function that -- translates certain builtin types. representableType :: (CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))) -> CustomReprs -> Bool -- ^ String considered representable -> TyConMap -> Type -> Bool representableType builtInTranslation reprs stringRepresentable m = either (const False) isRepresentable . flip evalState mempty . coreTypeToHWType' builtInTranslation reprs m where isRepresentable hty = case hty of String -> stringRepresentable Vector _ elTy -> isRepresentable elTy RTree _ elTy -> isRepresentable elTy Product _ _ elTys -> all isRepresentable elTys SP _ elTyss -> all (all isRepresentable . snd) elTyss BiDirectional _ t -> isRepresentable t Annotated _ ty -> isRepresentable ty _ -> True -- | Determines the bitsize of a type. For types that don't get turned -- into real values in hardware (string, integer) the size is 0. typeSize :: HWType -> Int typeSize (Void {}) = 0 typeSize FileType = 32 -- (ref. page 287 of IEEE 1364-2005) typeSize String = 0 typeSize Integer = 0 typeSize (KnownDomain {}) = 0 typeSize Bool = 1 typeSize Bit = 1 typeSize (Clock _) = 1 typeSize (ClockN _) = 1 typeSize (Reset _) = 1 typeSize (Enable _) = 1 typeSize (BitVector i) = i typeSize (Index 0) = 0 typeSize (Index 1) = 1 typeSize (Index u) = fromMaybe 0 (clogBase 2 u) typeSize (Signed i) = i typeSize (Unsigned i) = i typeSize (Vector n el) = n * typeSize el typeSize (MemBlob n m) = n * m typeSize (RTree d el) = (2^d) * typeSize el typeSize t@(SP _ cons) = conSize t + maximum (map (sum . map typeSize . snd) cons) typeSize (Sum _ dcs) = fromMaybe 0 . clogBase 2 . toInteger $ length dcs typeSize (Product _ _ tys) = sum $ map typeSize tys typeSize (BiDirectional In h) = typeSize h typeSize (BiDirectional Out _) = 0 typeSize (CustomSP _ _ size _) = fromIntegral size typeSize (CustomSum _ _ size _) = fromIntegral size typeSize (CustomProduct _ _ size _ _) = fromIntegral size typeSize (Annotated _ ty) = typeSize ty -- | Determines the bitsize of the constructor of a type conSize :: HWType -> Int conSize (SP _ cons) = fromMaybe 0 . clogBase 2 . toInteger $ length cons conSize t = typeSize t -- | Gives the HWType corresponding to a term. Returns an error if the term has -- a Core type that is not translatable to a HWType. termHWType :: String -> Term -> NetlistMonad HWType termHWType loc e = do m <- Lens.view tcCache let ty = inferCoreTypeOf m e stripFiltered <$> unsafeCoreTypeToHWTypeM loc ty -- | Gives the HWType corresponding to a term. Returns 'Nothing' if the term has -- a Core type that is not translatable to a HWType. termHWTypeM :: Term -- ^ Term to convert to HWType -> NetlistMonad (Maybe FilteredHWType) termHWTypeM e = do m <- Lens.view tcCache let ty = inferCoreTypeOf m e coreTypeToHWTypeM ty 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 :: HWType -> Bool containsBiSignalIn (BiDirectional In _) = True containsBiSignalIn (Product _ _ tys) = any containsBiSignalIn tys 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 -- term mkUniqueNormalized :: HasCallStack => InScopeSet -> Maybe (Maybe TopEntity) -- ^ Top entity annotation where: -- -- * Nothing: term is not a top entity -- * Just Nothing: term is a top entity, but has no explicit annotation -- * Just (Just ..): term is a top entity, and has an explicit annotation -> ( [Id] , [LetBinding] , Id ) -> NetlistMonad ([Bool] ,[(Identifier,HWType)] ,[Declaration] ,[(Identifier,HWType)] ,[Declaration] ,[LetBinding] ,Maybe Id) mkUniqueNormalized is0 topMM (args, binds, res) = do -- Generate port names and add them to set of seen identifiers argHwtys <- mapM (unsafeCoreTypeToHWTypeM $(curLoc) . coreTypeOf) args resHwty <- unsafeCoreTypeToHWTypeM $(curLoc) (coreTypeOf res) etopM <- mapM (expandTopEntityOrErrM (zip (map Just args) argHwtys) (Just res, resHwty)) topMM -- Make arguments unique let (bndrs, exprs) = unzip binds let is1 = is0 `extendInScopeSetList` (args ++ bndrs) (wereVoids, iports, iwrappers, substArgs) <- mkUniqueArguments (mkSubst is1) etopM args -- Make result unique. This might yield 'Nothing' in which case the result -- was a single BiSignalOut. This is superfluous in the HDL, as the argument -- will already contain a bidirectional signal complementing the BiSignalOut. 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 let -- Is the result variable read by any of the other binders? In that case -- we need to add a redirection as most synthesis tools don't allow reads -- from output ports. Note that if the result is renamed anyway, we don't -- have to do anything here. resultRead = any (elemFreeVars res) exprs recResult = modifyVarName (`appendToName` "_rec") res resRenameM1 = resRenameM0 <|> orNothing resultRead (res, recResult) (resN, extraBind, subst1) <- case resRenameM1 of Nothing -> -- Result binder was not renamed, so we can assign result expression -- directly to new name given by 'res1' pure (res1, Nothing, subst0) Just (_, newName0) -> do -- Result binder was renamed. We cannot rename 'res1', so we need -- to create an indirection. ([newName1], s) <- mkUnique subst0 [newName0] pure (newName1, Just (res1, Var newName1), s) let -- Result binder is already unique, so don't rename that renames1 = [(b, hmFindWithDefault b b renames0) | b <- bndrs] (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) let exprs1 = map (substTm "mkUniqueNormalized1" subst3) exprs binds0 = zip (renamesL1 <> [resN] <> renamesR1) exprs1 binds1 = binds0 <> maybeToList extraBind -- Return the uniquely named arguments, let-binders, and result return (wereVoids, iports, iwrappers, oports, owrappers, binds1, Just res1) Nothing -> do (bndrs1, substArgs1) <- mkUnique substArgs bndrs let binds1 = zip bndrs1 (map (substTm "mkUniqueNormalized2" substArgs1) exprs) return (wereVoids, iports, iwrappers, [], [], binds1, Nothing) -- | Produce a 'Just' when predicate is True, else Nothing orNothing :: Bool -> a -> Maybe a orNothing True a = Just a orNothing False _ = Nothing -- | Set the name of the binder if the given term is a blackbox requesting -- a specific name for the result binder. It might return multiple names in -- case of a multi result primitive. -- renameBinder :: (Id, Term) -> NetlistMonad [(Id, Id)] renameBinder (i, collectArgsTicks -> (k, args, ticks)) = withTicks ticks $ \_ -> do case k of Prim p -> case primMultiResult p of SingleResult -> extractPrimWarnOrFail (primName p) >>= goSingle p MultiResult -> extractPrimWarnOrFail (primName p) >>= goMulti p _ -> pure [] where -- Routine for multi result primitives. For more info: -- 'Clash.Normalize.Transformations.setupMultiResultPrim'. goMulti :: PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)] goMulti pInfo (BlackBoxHaskell{function=(_, function)}) = do tcm <- Lens.view tcCache let mpInfo@MultiPrimInfo{mpi_resultTypes} = multiPrimInfo' tcm pInfo let (args1, resIds) = splitMultiPrimArgs mpInfo args funRes <- preserveVarEnv (function False (primName pInfo) args1 mpi_resultTypes) let BlackBoxMeta{bbResultNames} = either error fst funRes go (primName pInfo) resIds args1 bbResultNames goMulti _ _ = pure [] -- Routine for single result primitives (the default kind of primitive) goSingle :: PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)] goSingle pInfo (BlackBoxHaskell{function=(_, function)}) = do funRes <- preserveVarEnv (function False (primName pInfo) args [coreTypeOf i]) case either error fst funRes of BlackBoxMeta{bbResultNames=[bbResultName]} -> go (primName pInfo) [i] args [bbResultName] _ -> pure [] goSingle pInfo (BlackBox{resultNames=[resultName]}) = do go (primName pInfo) [i] args [resultName] goSingle _ _ = pure [] go :: Text -> [Id] -> [Either Term Type] -> [BlackBox] -> NetlistMonad [(Id, Id)] go nm is0 bbArgs bbResultTemplates = do (bbCtx, _) <- preserveVarEnv (mkBlackBoxContext nm is0 bbArgs) be <- Lens.use backend let _sameName i0 i1 = nameOcc (varName i0) == nameOcc (varName i1) newNames = map (evalBlackBox be bbCtx) bbResultTemplates modName newRetName = modifyVarName (\n -> n {nameOcc = newRetName}) is1 = zipWith modName newNames is0 -- TODO: _sameName check disabled due to -- https://github.com/clash-lang/clash-compiler/issues/1566 -- Don't rename if we didn't change any names, it will cause superfluous -- redirections in 'mkUniqueNormalized'. -- pure (if and (zipWith sameName is0 is1) then [] else zip is0 is1) pure (zip is0 is1) -- | Render a blackbox given its context. Renders _just_ the blackbox, not any -- corresponding includes, libraries, and so forth. evalBlackBox :: HasCallStack => SomeBackend -> BlackBoxContext -> BlackBox -> Text evalBlackBox (SomeBackend s) bbCtx bb | BBFunction _bbName _bbHash (TemplateFunction _usedArgs _verifFunc func) <- bb = let layout = LayoutOptions (AvailablePerLine 120 0.4) in toStrict (renderLazy (layoutPretty layout (State.evalState (func bbCtx) s))) | BBTemplate bbt <- bb = toStrict ((State.evalState (renderTemplate bbCtx bbt) s) 0) mkUniqueArguments :: Subst -> Maybe (ExpandedTopEntity Identifier) -- ^ Top entity annotation where: -- -- * Nothing: term is not a top entity -- * Just ..: term is a top entity -> [Id] -> NetlistMonad ( [Bool] -- Were voids , [(Identifier,HWType)] -- Arguments and their types , [Declaration] -- Extra declarations , Subst -- Substitution with new vars in scope ) mkUniqueArguments subst0 Nothing args = do (args', subst1) <- mkUnique subst0 args ports <- mapM idToInPort args' return (map isNothing ports, catMaybes ports, [], subst1) mkUniqueArguments subst0 (Just (ExpandedTopEntity{..})) args = do (ports, decls, subst1) <- (unzip3 . catMaybes) <$> zipWithM go et_inputs args return ( map isNothing et_inputs , concat ports , concat decls , extendInScopeIdList (extendIdSubstList subst0 (map snd subst1)) (map fst subst1)) where go Nothing _var = pure Nothing go (Just port) var = do (ports, decls, _, portI) <- mkTopInput port let portName = Id.toText portI pId = mkLocalId (coreTypeOf var) (setRepName portName (varName var)) return (Just (ports, decls, (pId, (var, Var pId)))) mkUniqueResult :: Subst -> Maybe (ExpandedTopEntity Identifier) -- ^ Top entity annotation where: -- -- * Nothing: term is not a top entity -- * Just ..: term is a top entity -> Id -> NetlistMonad (Maybe ([(Identifier,HWType)],[Declaration],Id,Subst)) mkUniqueResult subst0 Nothing res = do ([res'],subst1) <- mkUnique subst0 [res] portM <- idToOutPort res' case portM of Just port -> return (Just ([port],[],res',subst1)) _ -> return Nothing mkUniqueResult _subst0 (Just (ExpandedTopEntity{et_output=Nothing})) _res = pure Nothing mkUniqueResult subst0 (Just (ExpandedTopEntity{et_output=Just iPort})) res = do (_, sp) <- Lens.use curCompNm (FilteredHWType hwty _) <- unsafeCoreTypeToHWTypeM $(curLoc) (coreTypeOf res) when (containsBiSignalIn hwty) (throw (ClashException sp ($(curLoc) ++ "BiSignalIn cannot be part of a function's result. Use 'readFromBiSignal'.") Nothing)) (ports, decls, portI) <- mkTopOutput iPort let pO = setRepName (Id.toText portI) (varName res) pOId = mkLocalId (coreTypeOf res) pO subst1 = extendInScopeId (extendIdSubst subst0 res (Var pOId)) pOId return (Just (ports, decls, pOId, subst1)) -- | Same as idToPort, but -- * Throws an error if the port is a composite type with a BiSignalIn idToInPort :: Id -> NetlistMonad (Maybe (Identifier, HWType)) idToInPort var = do (_, sp) <- Lens.use curCompNm portM <- idToPort var case portM of Just (_,hty) -> do when (containsBiSignalIn hty && not (isBiSignalIn hty)) (throw (ClashException sp ($(curLoc) ++ "BiSignalIn currently cannot be part of a composite type when it's a function's argument") Nothing)) return portM _ -> return Nothing -- | Same as idToPort, but: -- * Throws an error if port is of type BiSignalIn idToOutPort :: Id -> NetlistMonad (Maybe (Identifier,HWType)) idToOutPort var = do (_, srcspan) <- Lens.use curCompNm portM <- idToPort var case portM of Just (_,hty) -> do when (containsBiSignalIn hty) (throw (ClashException srcspan ($(curLoc) ++ "BiSignalIn cannot be part of a function's result. Use 'readFromBiSignal'.") Nothing)) return portM _ -> return Nothing idToPort :: Id -> NetlistMonad (Maybe (Identifier, HWType)) idToPort var = do hwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (coreTypeOf var) if isVoid hwTy then return Nothing else return (Just (Id.unsafeFromCoreId var, hwTy)) setRepName :: Text -> Name a -> Name a setRepName s (Name sort' _ i loc) = Name sort' s i loc -- | Make a set of IDs unique; also returns a substitution from old ID to new -- updated unique ID. mkUnique :: Subst -- ^ Existing substitution -> [Id] -- ^ IDs to make unique -> NetlistMonad ([Id],Subst) -- ^ (Unique IDs, update substitution) mkUnique = go [] where go :: [Id] -> Subst -> [Id] -> NetlistMonad ([Id],Subst) go processed subst [] = return (reverse processed,subst) go processed subst@(Subst isN _ _ _) (i:is) = do iN <- Id.toText <$> Id.fromCoreId i let i' = uniqAway isN (modifyVarName (setRepName iN) i) subst' = extendInScopeId (extendIdSubst subst i (Var i')) i' go (i':processed) subst' is -- | Preserve the complete state before running an action, and restore it -- afterwards. preserveState :: NetlistMonad a -> NetlistMonad a preserveState action = do state <- State.get val <- action State.put state pure val -- | Preserve the Netlist '_curCompNm','_seenIds','_usageMap' when executing -- a monadic action preserveVarEnv :: NetlistMonad a -> NetlistMonad a preserveVarEnv action = do -- 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 dcToLiteral Bool 1 = BoolLit False dcToLiteral Bool 2 = BoolLit True dcToLiteral _ i = NumLit (toInteger i-1) -- * TopEntity Annotations extendPorts :: [PortName] -> [Maybe PortName] extendPorts ps = map Just ps ++ repeat Nothing -- | Prefix given string before portnames /except/ when this string is empty. prefixParent :: String -> PortName -> PortName prefixParent "" p = p prefixParent parent (PortName p) = PortName (parent <> "_" <> p) prefixParent parent (PortProduct "" ps) = PortProduct parent ps prefixParent parent (PortProduct p ps) = PortProduct (parent <> "_" <> p) ps -- | 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 b <- Lens.use backend let kind = case b of {SomeBackend s -> State.evalState (hdlHWTypeKind hwty) s} case kind of UserType -> action SynonymType -> pure a PrimitiveType -> pure a -- | Top entities only expose primitive types or types that don't need explicit -- conversion to a primitive type (i.e., no types from the '_types' module). This -- function converts from a custom type to a primitive type if needed. -- -- See 'HWKind' for more info on primitive type kinds. toPrimitiveType :: Identifier -> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType) toPrimitiveType id0 hwty0 = convPrimitiveType hwty0 dflt $ do id1 <- Id.next id0 ds <- mkInit Concurrent Cont id1 hwty1 expr pure (ds, id1, expr, hwty1) where dflt = ([], id0, Identifier id0 Nothing, hwty0) hwty1 = BitVector (typeSize hwty0) expr = ToBv Nothing hwty0 (Identifier id0 Nothing) -- | Top entities only expose primitive types or types that don't need explicit -- conversion to a primitive type (i.e., no types from the '_types' module). This -- function converts from a primitive type to a custom type if needed. -- -- See 'HWKind' for more info on primitive type kinds. fromPrimitiveType :: Identifier -> HWType -> NetlistMonad ([Declaration], Identifier, Expr, HWType) fromPrimitiveType id0 hwty0 = convPrimitiveType hwty0 dflt $ do id1 <- Id.next id0 ds <- mkInit Concurrent Cont id1 hwty0 expr pure (ds, id1, expr, hwty1) where dflt = ([], id0, Identifier id0 Nothing, hwty0) hwty1 = BitVector (typeSize hwty0) expr = FromBv Nothing hwty0 (Identifier id0 Nothing) -- | Create port names for the declaration of a top entity. For /instantiation/ -- see 'mkTopInstInput'. mkTopInput :: ExpandedPortName Identifier -- ^ Port name description -> NetlistMonad ([(Identifier, HWType)], [Declaration], Expr, Identifier) -- ^ (port names, signal decls for intermediate signals, argument expr, argument id) mkTopInput (ExpandedPortName hwty0 i0) = do (decls, i1, expr, hwty1) <- fromPrimitiveType i0 hwty0 return ([(i0, hwty1)], decls, expr, i1) mkTopInput epp@(ExpandedPortProduct p hwty ps) = do pN <- Id.makeBasic p case hwty of Vector sz eHwty -> do (ports, _, exprs, _) <- unzip4 <$> mapM mkTopInput ps let vecExpr = mkVectorChain sz eHwty exprs 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 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] -> 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 case exprs of [conExpr, elExpr] -> do let dcExpr = DataCon hwty (DC (BitVector (typeSize hwty), 0)) [conExpr, ToBv Nothing elTy elExpr] decls <- mkInit Concurrent Cont pN hwty dcExpr return (concat ports, decls, dcExpr, pN) _ -> error $ $(curLoc) ++ "Internal error" _ -> -- 'expandTopEntity' should have made sure this isn't possible error $ $(curLoc) ++ "Internal error: " ++ show epp portProductError :: String -> HWType -> ExpandedPortName Identifier -> a portProductError loc hwty portProduct = error $ loc ++ [I.i| #{loc}PortProduct used, but did not see Vector, RTree, or Product. Saw the following instead: #{hwty} PortProduct used: #{portProduct} Note that the PortProduct as shown above might is only indicative, and might not correspond exactly to the one given in the Clash design. |] -- | Create a Vector chain for a list of 'Identifier's mkVectorChain :: Int -> HWType -> [Expr] -> Expr mkVectorChain _ elTy [] = DataCon (Vector 0 elTy) VecAppend [] mkVectorChain _ elTy [e] = DataCon (Vector 1 elTy) VecAppend [e] mkVectorChain sz elTy (e:es) = DataCon (Vector sz elTy) VecAppend [ e , mkVectorChain (sz-1) elTy es ] -- | Create a RTree chain for a list of 'Identifier's mkRTreeChain :: Int -> HWType -> [Expr] -> Expr mkRTreeChain _ elTy [e] = DataCon (RTree 0 elTy) RTreeAppend [e] mkRTreeChain d elTy es = let (esL,esR) = splitAt (length es `div` 2) es in DataCon (RTree d elTy) RTreeAppend [ mkRTreeChain (d-1) elTy esL , mkRTreeChain (d-1) elTy esR ] genComponentName :: Bool -- ^ New inline strategy enabled -> Maybe Text -- ^ Component name prefix -> Id -- ^ Create component name based on this Core Id -> Text genComponentName newInlineStrat prefixM nm = Text.intercalate "_" (prefix ++ [fn1]) where nm0 = Text.splitOn "." (nameOcc (varName nm)) fn0 = Id.stripDollarPrefixes (last nm0) fn1 = if Text.null fn0 then "Component" else fn0 prefix = fromMaybe (if newInlineStrat then [] else init nm0) (pure <$> prefixM) genTopName :: IdentifierSetMonad m => Maybe Text -- ^ Top entity name prefix -> TopEntity -- ^ Top entity annotation -> m Identifier -- ^ New identifier genTopName prefixM ann = case prefixM of Just prefix | not (Text.null prefix) -> Id.addRaw (Text.concat [prefix, "_", Text.pack (t_name ann)]) _ -> Id.addRaw (Text.pack (t_name ann)) -- | Strips one or more layers of attributes from a HWType; stops at first -- non-Annotated. Accumulates all attributes of nested annotations. stripAttributes :: HWType -> ([Attr Text], HWType) -- Recursively strip type, accumulate attrs: stripAttributes (Annotated attrs typ) = let (attrs', typ') = stripAttributes typ in (attrs ++ attrs', typ') -- Not an annotated type, so just return it: stripAttributes typ = ([], typ) -- | Create output port names for the declaration of a top entity. For -- /instantiation/ see 'mkTopInstOutput'. mkTopOutput :: ExpandedPortName Identifier -> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier) mkTopOutput (ExpandedPortName hwty0 i0) = do i1 <- Id.next i0 (_, _, bvExpr, hwty1) <- toPrimitiveType i1 hwty0 if hwty0 == hwty1 then -- No type conversion happened, so we can just request caller to assign to -- port name directly. return ([(i0, hwty0)], [], i0) else do -- Type conversion happened, so we must use intermediate variable. 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 Nothing case hwty of Vector {} -> do (ports, decls, ids) <- unzip3 <$> mapM mkTopOutput ps 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 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] -> do assn <- contAssign i (Identifier pN Nothing) pure (concat ports, netdecl : assn : 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] -> do let conIx = Sliced ( BitVector (typeSize hwty) , typeSize hwty - 1 , typeSize elTy ) elIx = Sliced ( BitVector (typeSize hwty) , typeSize elTy - 1 , 0 ) 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 = contAssign i (Identifier p_ (Just (Indexed (hwty_, con, n)))) mkTopCompDecl :: Maybe Text -- ^ Library entity is defined in -> [Attr Text] -- ^ Attributes to add to generate 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) -> [InstancePort] -- ^ Input port assignments -> [InstancePort] -- ^ Output port assignments -> Declaration mkTopCompDecl lib attrs name instName params inputs outputs = InstDecl Entity lib attrs name instName params (IndexedPortMap ports) where ports = map (toPort In) inputs ++ map (toPort Out) outputs toExpr id_ = Identifier id_ Nothing toPort dir ip = (dir, (ip_type ip), toExpr (ip_id ip)) -- | Instantiate a TopEntity, and add the proper type-conversions where needed mkTopUnWrapper :: Id -- ^ Name of the TopEntity component -> ExpandedTopEntity Identifier -- ^ A corresponding @TopEntity@ annotation -> (Identifier, HWType) -- ^ The name and type of the signal to which to assign the result -> [(Expr,HWType)] -- ^ The arguments with voids filtered. -> [Declaration] -- ^ Tick declarations -> NetlistMonad [Declaration] mkTopUnWrapper topEntity annM dstId args tickDecls = do -- component name compNameM <- lookupVarEnv topEntity <$> Lens.use componentNames let topName = Id.toText topIdentifier topIdentifier = flip fromMaybe compNameM (error [I.i| Internal error in 'mkTopUnWrapper': tried to lookup (netlist) name of #{showPpr (varName topEntity)}, but couldn't find it in NetlistState's 'componentNames'. This should have been put there by 'runNetlistMonad' / 'genNames'. |]) -- inputs (iports, wrappers, idsI) <- unzip3 <$> mapM mkTopInstInput (catMaybes (et_inputs annM)) inpAssigns <- zipWithM (\i e -> contAssign i e) idsI (fst <$> args) -- output let iResult = inpAssigns : wrappers instLabel0 = Text.concat [topName, "_", Id.toText (fst dstId)] instLabel1 <- fromMaybe instLabel0 <$> Lens.view setName instLabel2 <- affixName instLabel1 instLabel3 <- Id.makeBasic instLabel2 topOutputM <- traverse mkTopInstOutput (et_output annM) let topDecl = mkTopCompDecl (Just topName) [] topIdentifier instLabel3 [] (concat iports) case topOutputM of Nothing -> pure (topDecl [] : concat iResult) Just (oports, unwrappers, id0) -> do outpAssign <- contAssign (fst dstId) (Identifier id0 Nothing) pure (concat iResult ++ tickDecls ++ (topDecl oports:unwrappers) ++ [outpAssign]) data InstancePort = InstancePort { ip_id :: Identifier -- ^ Identifier to assign. Top entities are instantiated using positional -- 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 -- a single signal and returns its name. mkTopInstInput :: ExpandedPortName Identifier -- ^ The @PortName@ of a _TopEntity_ annotation for this input. -> NetlistMonad ([InstancePort], [Declaration], Identifier) -- ^ (ports to assign, declarations for intermediate signals, argument signal) mkTopInstInput (ExpandedPortName hwty0 pN) = do pN' <- Id.next pN (decls, pN'', _bvExpr, hwty1) <- toPrimitiveType pN' hwty0 return ( [InstancePort pN'' hwty1] , 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 (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 = zipWith3 Assignment ids (repeat Cont) (map (indexPN 10) [0..]) if null attrs then return (concat ports, pDecl:assigns ++ concat decls, pName) else throwAnnotatedSplitError $(curLoc) "Vector" RTree {} -> do (ports, decls, ids) <- unzip3 <$> mapM mkTopInstInput ps let assigns = zipWith3 Assignment ids (repeat Cont) (map (indexPN 10) [0..]) if null attrs then return (concat ports, pDecl:assigns ++ concat decls, pName) else throwAnnotatedSplitError $(curLoc) "RTree" Product {} -> do (ports, decls, ids) <- unzip3 <$> mapM mkTopInstInput ps let assigns = zipWith3 Assignment ids (repeat Cont) (map (indexPN 0) [0..]) if null attrs then return (concat ports, pDecl:assigns ++ concat decls, pName) else throwAnnotatedSplitError $(curLoc) "Product" SP _ ((concat . map snd) -> [elTy]) -> do (ports, decls, ids) <- unzip3 <$> mapM mkTopInstInput ps case ids of [conId,elId] -> do let conIx = Sliced ( BitVector (typeSize hwty1) , typeSize hwty1 - 1 , typeSize elTy ) elIx = Sliced ( BitVector (typeSize hwty1) , typeSize elTy - 1 , 0 ) assigns = [ 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" _ -> portProductError $(curLoc) hwty0 epp -- | Consider the following type signature: -- -- @ -- f :: Signal dom (Vec 6 A) \`Annotate\` Attr "keep" -- -> Signal dom (Vec 6 B) -- @ -- -- What does the annotation mean, considering that Clash will split these -- vectors into multiple in- and output ports? Should we apply the annotation -- to all individual ports? How would we handle pin mappings? For now, we simply -- throw an error. This is a helper function to do so. throwAnnotatedSplitError :: String -> String -> NetlistMonad a throwAnnotatedSplitError loc typ = do (_,sp) <- Lens.use curCompNm throw $ ClashException sp (loc ++ printf msg typ typ) Nothing where msg = unwords $ [ "Attempted to split %s into a number of HDL ports. This" , "is not allowed in combination with attribute annotations." , "You can annotate %s's components by splitting it up" , "manually." ] -- | Generate output port(s) for an instantiation of a top entity. This function -- combines all output ports into a signal identifier and returns its name. mkTopInstOutput :: HasCallStack => ExpandedPortName Identifier -- ^ The @PortName@ of a _TopEntity_ annotation for this output -> NetlistMonad ([InstancePort], [Declaration], Identifier) -- ^ (ports to assign, declarations for intermediate signals, result signal) mkTopInstOutput (ExpandedPortName hwty0 portName) = do assignName0 <- Id.next portName (decls, assignName1, _expr, hwty1) <- fromPrimitiveType assignName0 hwty0 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 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 Cont (mkVectorChain sz hwty'' ids1) if null attrs then return (concat ports, pDecl:netassgn:concat decls, pName) else throwAnnotatedSplitError $(curLoc) "Vector" RTree d hwty'' -> do (ports, decls, ids0) <- unzip3 <$> mapM mkTopInstOutput ps let ids1 = map (flip Identifier Nothing) ids0 netassgn = Assignment pName Cont (mkRTreeChain d hwty'' ids1) if null attrs then return (concat ports, pDecl:netassgn:concat decls, pName) else throwAnnotatedSplitError $(curLoc) "RTree" Product {} -> do (ports, decls, ids0) <- unzip3 <$> mapM mkTopInstOutput ps let ids1 = map (flip Identifier Nothing) ids0 netassgn = Assignment pName Cont (DataCon hwty (DC (hwty,0)) ids1) if null attrs then return (concat ports, pDecl:netassgn:concat decls, pName) else throwAnnotatedSplitError $(curLoc) "Product" SP _ ((concat . map snd) -> [elTy]) -> do (ports, decls, ids0) <- unzip3 <$> mapM mkTopInstOutput ps let ids1 = map (flip Identifier Nothing) ids0 ids2 = case ids1 of [conId, elId] -> [conId, ToBv Nothing elTy elId] _ -> error "Unexpected error for PortProduct" netassgn = Assignment pName Cont (DataCon hwty (DC (BitVector (typeSize hwty),0)) ids2) return (concat ports, pDecl:netassgn:concat decls, pName) _ -> portProductError $(curLoc) hwty' epp -- | Try to merge nested modifiers into a single modifier, needed by the VHDL -- and SystemVerilog backend. nestM :: Modifier -> Modifier -> Maybe Modifier nestM (Nested a b) m2 | Just m1 <- nestM a b = maybe (Just (Nested m1 m2)) Just (nestM m1 m2) | Just m2' <- nestM b m2 = maybe (Just (Nested a m2')) Just (nestM a m2') nestM (Indexed (Vector n t1,1,1)) (Indexed (Vector _ t2,1,0)) | t1 == t2 = Just (Indexed (Vector n t1,10,1)) nestM (Indexed (Vector n t1,1,1)) (Indexed (Vector _ t2,10,k)) | t1 == t2 = Just (Indexed (Vector n t1,10,k+1)) nestM (Indexed (RTree d1 t1,1,n)) (Indexed (RTree d2 t2,0,0)) | t1 == t2 , d1 >= 0 , d2 >= 0 = Just (Indexed (RTree d1 t1,10,n)) nestM (Indexed (RTree d1 t1,1,n)) (Indexed (RTree d2 t2,1,m)) | t1 == t2 , d1 >= 0 , d2 >= 0 = if | n == 1 && m == 1 -> let r = 2 ^ d1 l = r - (2 ^ (d1-1) `div` 2) in Just (Indexed (RTree (-1) t1, l, r)) | n == 1 && m == 0 -> let l = 2 ^ (d1-1) r = l + (l `div` 2) in Just (Indexed (RTree (-1) t1, l, r)) | n == 0 && m == 1 -> let l = (2 ^ (d1-1)) `div` 2 r = 2 ^ (d1-1) in Just (Indexed (RTree (-1) t1, l, r)) | n == 0 && m == 0 -> let l = 0 r = (2 ^ (d1-1)) `div` 2 in Just (Indexed (RTree (-1) t1, l, r)) | n > 1 || n < 0 -> error $ "nestM: n should be 0 or 1, not:" ++ show n | m > 1 || m < 0 -> error $ "nestM: m should be 0 or 1, not:" ++ show m | otherwise -> error $ "nestM: unexpected (n, m): " ++ show (n, m) nestM (Indexed (RTree (-1) t1,l,_)) (Indexed (RTree d t2,10,k)) | t1 == t2 , d >= 0 = Just (Indexed (RTree d t1,10,l+k)) nestM _ _ = Nothing -- | Determines if any type variables (exts) are bound in any of the given -- type or term variables (tms). It's currently only used to detect bound -- existentials, hence the name. bindsExistentials :: [TyVar] -> [Var a] -> Bool bindsExistentials exts tms = any (`elem` freeVars) exts where freeVars = concatMap (Lens.toListOf typeFreeVars) (map coreTypeOf tms) iteAlts :: HWType -> [Alt] -> Maybe (Term,Term) iteAlts sHTy [(pat0,alt0),(pat1,alt1)] | validIteSTy sHTy = case pat0 of DataPat dc _ _ -> case dcTag dc of 2 -> Just (alt0,alt1) _ -> Just (alt1,alt0) LitPat (C.IntegerLiteral l) -> case l of 1 -> Just (alt0,alt1) _ -> Just (alt1,alt0) DefaultPat -> case pat1 of DataPat dc _ _ -> case dcTag dc of 2 -> Just (alt1,alt0) _ -> Just (alt0,alt1) LitPat (C.IntegerLiteral l) -> case l of 1 -> Just (alt1,alt0) _ -> Just (alt0,alt1) _ -> Nothing _ -> Nothing where validIteSTy Bool = True validIteSTy Bit = True validIteSTy (Sum _ [_,_]) = True validIteSTy (SP _ [_,_]) = True validIteSTy (Unsigned 1) = True validIteSTy (Index 2) = True validIteSTy _ = False iteAlts _ _ = Nothing -- | Run a NetlistMonad computation in the context of the given source ticks and -- name modifier ticks withTicks :: [TickInfo] -> ([Declaration] -> NetlistMonad a) -- ^ The source ticks are turned into 'TickDecl's and are passed as an argument -- to the NetlistMonad computation. Name modifier ticks will change the local -- environment for the NetlistMonad computation. -> NetlistMonad a withTicks ticks0 k = do let ticks1 = List.nub ticks0 go [] (reverse ticks1) where go decls [] = k (reverse decls) go decls (DeDup:ticks) = go decls ticks go decls (NoDeDup:ticks) = go decls ticks go decls (SrcSpan sp:ticks) = go (TickDecl (Comment (Text.pack (showSDocUnsafe (ppr sp)))):decls) ticks go decls (NameMod m nm0:ticks) = do tcm <- Lens.view tcCache case runExcept (tyLitShow tcm nm0) of Right nm1 -> local (modName m nm1) (go decls ticks) _ -> go decls ticks modName PrefixName (Text.pack -> s2) env@(NetlistEnv {_prefixName = s1}) | Text.null s1 = env {_prefixName = s2} | otherwise = env {_prefixName = s1 <> "_" <> s2} modName SuffixName (Text.pack -> s2) env@(NetlistEnv {_suffixName = s1}) | Text.null s1 = env {_suffixName = s2} | otherwise = env {_suffixName = s2 <> "_" <> s1} modName SuffixNameP (Text.pack -> s2) env@(NetlistEnv {_suffixName = s1}) | Text.null s1 = env {_suffixName = s2} | otherwise = env {_suffixName = s1 <> "_" <> s2} modName SetName (Text.pack -> s) env = env {_setName = Just s} -- | Add the pre- and suffix names in the current environment to the given -- identifier affixName :: Text -> NetlistMonad Text affixName nm0 = do NetlistEnv _ pre suf _ <- ask let nm1 = if Text.null pre then nm0 else pre <> "_" <> nm0 nm2 = if Text.null suf then nm1 else nm1 <> "_" <> suf return nm2 -- | Errors 'expandTopEntity' might yield data ExpandError -- | Synthesis attributes are not supported on PortProducts = 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 => [(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. -> 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 case expandTopEntity ihwtys ohwty topM of Left (AttrError attrs) -> (error [I.i| Cannot use attribute annotations on product types of top entities. Saw annotation: #{attrs} |]) Left (PortProductError pn hwty) -> (error [I.i| Saw a PortProduct in a Synthesize annotation: #{pn} but the port type: #{hwty} is not a product! |]) 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 -- works on "FilteredHWType" in order to generate stable port names. expandTopEntity :: HasCallStack => [(Maybe Id, FilteredHWType)] -- ^ Arguments. Ids are used as name hints. -> (Maybe Id, FilteredHWType) -- ^ Result. Id is used as name hint. -> Maybe TopEntity -- ^ Top entity to expand -> Either ExpandError (ExpandedTopEntity (Either Text Text)) -- ^ Either some error (see "ExpandError") or and expanded top entity. The -- 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 | Synthesize {..} <- fromMaybe (defSyn (error $(curLoc))) topEntityM = do -- TODO 1: Check sizes against number of PortProduct fields -- TODO 2: Warn about duplicate fields let 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) output <- -- BiSignalOut signals are filtered as their counterpart - BiSignalIn - will -- be printed as an inout port in HDL. if isVoid (stripFiltered ohwty) || isBiSignalOut (stripFiltered ohwty) then pure Nothing else Just <$> goPort resHint ohwty t_output pure (ExpandedTopEntity { et_inputs = inputs , et_output = output }) where goInput :: Text -> FilteredHWType -> Maybe PortName -> Either ExpandError (Maybe (ExpandedPortName (Either Text Text))) goInput hint fHwty@(FilteredHWType hwty _) pM | isVoid hwty = Right Nothing | otherwise = Just <$> go hint fHwty pM -- Vector and RTree are hardcoded as product types, even when instantiated as -- /Vec 1 a/ or /RTree 0 a/ respectively. isProduct :: FilteredHWType -> Bool isProduct (FilteredHWType (CustomProduct {}) _) = -- CustomProducts are not yet support in mkTopInput/mkTopOutput so we can't treat -- them as product types. -- FIXME: Support CustomProduct in top entity annotations False isProduct (FilteredHWType (Vector {}) _) = True isProduct (FilteredHWType (RTree {}) _) = True isProduct (FilteredHWType _ [(_:_:_)]) = True isProduct _ = False go :: Text -> FilteredHWType -> Maybe PortName -> Either ExpandError (ExpandedPortName (Either Text Text)) go hint hwty Nothing = goNoPort hint hwty go hint hwty (Just p) = goPort hint hwty p goPort :: Text -> FilteredHWType -> PortName -> Either ExpandError (ExpandedPortName (Either Text Text)) goPort hint fHwty@(FilteredHWType hwty _) (PortName "") = -- TODO: The following logic makes using /no/ top entity annotation and -- TODO: using 'defSyn' behave differently. This is probably not what we -- TODO: want. if isJust topEntityM then -- If top entity annotation was explicitly given, render a single port pure (ExpandedPortName hwty (Right hint)) else -- Treat empty 'PortName's as an non-annotated port if no explicit -- synthesize annotation was given. goNoPort hint fHwty goPort _hint (FilteredHWType hwty _) (PortName pn) = pure (ExpandedPortName hwty (Left (Text.pack pn))) goPort hint0 fHwty@(FilteredHWType hwty0 fields0) pp@(PortProduct p ps0) -- Attrs not allowed on product types | isProduct fHwty , (_:_) <- attrs = Left (AttrError attrs) -- Product types (products, vec, rtree) of which all but one field are -- zero-width. | isProduct fHwty , [fields1] <- fields0 , ((_:_), [_]) <- partition fst fields1 = case [go h t p_ | (h, (False, t), p_) <- zip3 hints fields1 ps1] of port:_ -> port _ -> error "internal error: insuffient ports" -- Product types (products, vec, rtree) | isProduct fHwty , [fields1] <- fields0 = ExpandedPortProduct hint1 hwty1 <$> sequence [go h t p_ | (h, (False, t), p_) <- zip3 hints fields1 ps1] -- Things like "Maybe a" are allowed to be split up using a port -- annotation (but won't be split up if it's missing, should it?) -- FIXME: We probably shouldn't filter void constructs here, it's -- FIXME: inconsistent with how we deal with port annotations elsewhere | [(False, eHwty)] <- filter (not . fst) (concat fields0) , length fields0 > 1 , length ps0 == 2 , conHwty <- FilteredHWType (BitVector (conSize hwty0)) [] = ExpandedPortProduct hint1 hwty1 <$> sequence [go h t p_ | (h, t, p_) <- zip3 hints [conHwty, eHwty] ps1] -- Port annotated as PortProduct, but wasn't one | otherwise = Left (PortProductError pp hwty1) where hint1 = if null p then hint0 else Text.pack p ps1 = extendPorts (map (prefixParent p) ps0) hints = map (\i -> hint1 <> "_" <> showt i) [(0::Int)..] (attrs, hwty1) = stripAttributes hwty0 goNoPort :: Text -> FilteredHWType -> Either ExpandError (ExpandedPortName (Either Text Text)) goNoPort hint fHwty@(FilteredHWType hwty0 fields0) -- Attrs not allowed on product types | isProduct fHwty , (_:_) <- attrs = Left (AttrError attrs) -- Product types (products, vec, rtree) of which all but one field are -- zero-width. | isProduct fHwty , [fields1] <- fields0 , ((_:_), [_]) <- partition fst fields1 = case [goNoPort h t | (h, (False, t)) <- zip hints fields1] of port:_ -> port _ -> error "internal error: insuffient ports" -- Product types (products, vec, rtree) | isProduct fHwty , [fields1] <- fields0 = ExpandedPortProduct hint hwty1 <$> sequence [goNoPort h t | (h, (False, t)) <- zip hints fields1] -- All other types (sum of product, sum, "native") | otherwise = pure (ExpandedPortName hwty0 (Right hint)) 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) clash-lib-1.8.1/src/Clash/Normalize.hs0000644000000000000000000003771707346545000015704 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, 2017 , Google Inc., 2021-2023, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Turn CoreHW terms into normalized CoreHW Terms -} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Normalize where import Control.Concurrent.Supply (Supply) import Control.Exception (throw) import qualified Control.Lens as Lens import Control.Monad (when) import Control.Monad.State.Strict (State) import Data.Default (def) import Data.Either (lefts,partitionEithers) import qualified Data.IntMap as IntMap import Data.List (intersect, mapAccumL) import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Data.Set.Lens as Lens #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter (vcat) #else import Data.Text.Prettyprint.Doc (vcat) #endif import GHC.BasicTypes.Extra (isNoInline) import Clash.Annotations.BitRepresentation.Internal (CustomReprs) import Clash.Core.Evaluator.Types as WHNF (Evaluator) import Clash.Core.FreeVars (freeLocalIds, globalIds) import Clash.Core.HasFreeVars (notElemFreeVars) import Clash.Core.HasType import Clash.Core.PartialEval as PE (Evaluator) import Clash.Core.Pretty (PrettyOptions(..), showPpr, showPpr', ppr) import Clash.Core.Subst (extendGblSubstList, mkSubst, substTm) import Clash.Core.Term (Term (..), collectArgsTicks ,mkApps, mkTicks) import Clash.Core.Type (Type, splitCoreFunForallTy) import Clash.Core.TyCon (TyConMap) import Clash.Core.Type (isPolyTy) import Clash.Core.Var (Id, varName, varType) import Clash.Core.VarEnv (VarEnv, elemVarSet, eltsVarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, lookupVarEnv, mapVarEnv, mapMaybeVarEnv, mkVarEnv, mkVarSet, notElemVarEnv, notElemVarSet, nullVarEnv, unionVarEnv) import Clash.Debug (traceIf) import Clash.Driver.Types (BindingMap, Binding(..), DebugOpts(..), ClashEnv(..)) import Clash.Netlist.Types (HWMap, FilteredHWType(..)) import Clash.Netlist.Util (splitNormalized) import Clash.Normalize.Strategy import Clash.Normalize.Transformations import Clash.Normalize.Types import Clash.Normalize.Util import Clash.Rewrite.Combinators ((>->), (!->), bottomupR, repeatR, topdownR) import Clash.Rewrite.Types (RewriteEnv (..), RewriteState (..), bindings, debugOpts, extra, tcCache, topEntities, newInlineStrategy) import Clash.Rewrite.Util (apply, isUntranslatableType, runRewriteSession) import Clash.Util import Clash.Util.Interpolate (i) import Data.Binary (encode) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import System.IO.Unsafe (unsafePerformIO) import Clash.Rewrite.Types (RewriteStep(..)) -- | Run a NormalizeSession in a given environment runNormalization :: ClashEnv -> Supply -- ^ UniqueSupply -> BindingMap -- ^ Global Binders -> (CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType))) -- ^ Hardcoded Type -> HWType translator -> PE.Evaluator -- ^ Hardcoded evaluator for partial evaluation -> WHNF.Evaluator -- ^ Hardcoded evaluator for WHNF (old evaluator) -> VarEnv Bool -- ^ Map telling whether a components is part of a recursive group -> [Id] -- ^ topEntities -> NormalizeSession a -- ^ NormalizeSession to run -> IO a runNormalization env supply globals typeTrans peEval eval rcsMap topEnts = runRewriteSession rwEnv rwState where -- TODO The RewriteEnv should just take ClashOpts. rwEnv = RewriteEnv env typeTrans peEval eval (mkVarSet topEnts) rwState = RewriteState 0 mempty -- transformCounters Map globals supply (error $ $(curLoc) ++ "Report as bug: no curFun",noSrcSpan) 0 (IntMap.empty, 0) emptyVarEnv normState normState = NormalizeState emptyVarEnv Map.empty emptyVarEnv emptyVarEnv Map.empty rcsMap normalize :: [Id] -> NormalizeSession BindingMap normalize [] = return emptyVarEnv normalize top = do (new,topNormalized) <- unzip <$> mapM normalize' top newNormalized <- normalize (concat new) return (unionVarEnv (mkVarEnv topNormalized) newNormalized) normalize' :: Id -> NormalizeSession ([Id], (Id, Binding Term)) normalize' nm = do exprM <- lookupVarEnv nm <$> Lens.use bindings let nmS = showPpr (varName nm) case exprM of Just (Binding nm' sp inl pr tm r) -> do tcm <- Lens.view tcCache topEnts <- Lens.view topEntities let isTop = nm `elemVarSet` topEnts ty0 = coreTypeOf nm' ty1 = if isTop then tvSubstWithTyEq ty0 else ty0 -- check for polymorphic types when (isPolyTy ty1) $ let msg = $curLoc ++ [i| Clash can only normalize monomorphic functions, but this is polymorphic: #{showPpr' def{displayUniques=False\} nm'} |] msgExtra | ty0 == ty1 = Nothing | otherwise = Just $ [i| Even after applying type equality constraints it remained polymorphic: #{showPpr' def{displayUniques=False\} nm'{varType=ty1\}} |] in throw (ClashException sp msg msgExtra) -- check for unrepresentable result type let (args,resTy) = splitCoreFunForallTy tcm ty1 isTopEnt = nm `elemVarSet` topEnts isFunction = not $ null $ lefts args resTyRep <- not <$> isUntranslatableType False resTy if resTyRep then do tmNorm <- normalizeTopLvlBndr isTopEnt nm (Binding nm' sp inl pr tm r) let usedBndrs = Lens.toListOf globalIds (bindingTerm tmNorm) traceIf (bindingRecursive tmNorm) (concat [ $(curLoc),"Expr belonging to bndr: ",nmS ," (:: " , showPpr (coreTypeOf (bindingId tmNorm)) , ") remains recursive after normalization:\n" , showPpr (bindingTerm tmNorm) ]) (return ()) prevNorm <- mapVarEnv bindingId <$> Lens.use (extra.normalized) let toNormalize = filter (`notElemVarSet` topEnts) $ filter (`notElemVarEnv` (extendVarEnv nm nm prevNorm)) usedBndrs return (toNormalize,(nm,tmNorm)) else do -- Throw an error for unrepresentable topEntities and functions when (isTopEnt || isFunction) $ let msg = $(curLoc) ++ [i| This bndr has a non-representable return type and can't be normalized: #{showPpr' def{displayUniques=False\} nm'} |] in throw (ClashException sp msg Nothing) -- But allow the compilation to proceed for nonrepresentable values. -- This can happen for example when GHC decides to create a toplevel binder -- for the ByteArray# inside of a Natural constant. -- (GHC-8.4 does this with tests/shouldwork/Numbers/Exp.hs) -- It will later be inlined by flattenCallTree. opts <- Lens.view debugOpts traceIf (dbg_invariants opts) (concat [$(curLoc), "Expr belonging to bndr: ", nmS, " (:: " , showPpr (coreTypeOf nm') , ") has a non-representable return type." , " Not normalising:\n", showPpr tm] ) (return ([],(nm,(Binding nm' sp inl pr tm r)))) Nothing -> error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " not found" -- | Check whether the normalized bindings are non-recursive. Errors when one -- of the components is recursive. checkNonRecursive :: BindingMap -- ^ List of normalized binders -> BindingMap checkNonRecursive norm = case mapMaybeVarEnv go norm of rcs | nullVarEnv rcs -> norm rcs -> error $ $(curLoc) ++ "Callgraph after normalization contains following recursive components: " ++ show (vcat [ ppr a <> ppr b | (a,b) <- eltsVarEnv rcs ]) where go (Binding nm _ _ _ tm r) = if r then Just (nm,tm) else Nothing -- | Perform general \"clean up\" of the normalized (non-recursive) function -- hierarchy. This includes: -- -- * Inlining functions that simply \"wrap\" another function cleanupGraph :: Id -> BindingMap -> NormalizeSession BindingMap cleanupGraph topEntity norm | Just ct <- mkCallTree [] norm topEntity = do ctFlat <- flattenCallTree ct return (mkVarEnv $ snd $ callTreeToList [] ctFlat) cleanupGraph _ norm = return norm -- | A tree of identifiers and their bindings, with branches containing -- additional bindings which are used. See "Clash.Driver.Types.Binding". -- data CallTree = CLeaf (Id, Binding Term) | CBranch (Id, Binding Term) [CallTree] mkCallTree :: [Id] -- ^ Visited -> BindingMap -- ^ Global binders -> Id -- ^ Root of the call graph -> Maybe CallTree mkCallTree visited bindingMap root | Just rootTm <- lookupVarEnv root bindingMap = let used = Set.toList $ Lens.setOf globalIds $ (bindingTerm rootTm) other = Maybe.mapMaybe (mkCallTree (root:visited) bindingMap) (filter (`notElem` visited) used) in case used of [] -> Just (CLeaf (root,rootTm)) _ -> Just (CBranch (root,rootTm) other) mkCallTree _ _ _ = Nothing stripArgs :: [Id] -> [Id] -> [Either Term Type] -> Maybe [Either Term Type] stripArgs _ (_:_) [] = Nothing stripArgs allIds [] args = if any mentionsId args then Nothing else Just args where mentionsId t = not $ null (either (Lens.toListOf freeLocalIds) (const []) t `intersect` allIds) stripArgs allIds (id_:ids) (Left (Var nm):args) | id_ == nm = stripArgs allIds ids args | otherwise = Nothing stripArgs _ _ _ = Nothing flattenNode :: CallTree -> NormalizeSession (Either CallTree ((Id,Term),[CallTree])) 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 tcm <- Lens.view tcCache let norm = splitNormalized tcm e case norm of Right (ids,[(bId,bExpr)],_) -> do let (fun,args,ticks) = collectArgsTicks bExpr case stripArgs ids (reverse ids) (reverse args) of Just remainder | bId `notElemFreeVars` bExpr -> return (Right ((nm,mkApps (mkTicks fun ticks) (reverse remainder)),[])) _ -> return (Right ((nm,e),[])) _ -> return (Right ((nm,e),[])) flattenNode b@(CBranch (_,(Binding _ _ spec _ _ _)) _) | isNoInline spec = return (Left b) flattenNode b@(CBranch (nm,(Binding _ _ _ _ e _)) us) = do isTopEntity <- elemVarSet nm <$> Lens.view topEntities if isTopEntity then return (Left b) else do tcm <- Lens.view tcCache let norm = splitNormalized tcm e case norm of Right (ids,[(bId,bExpr)],_) -> do let (fun,args,ticks) = collectArgsTicks bExpr case stripArgs ids (reverse ids) (reverse args) of Just remainder | bId `notElemFreeVars` bExpr -> return (Right ((nm,mkApps (mkTicks fun ticks) (reverse remainder)),us)) _ -> return (Right ((nm,e),us)) _ -> do newInlineStrat <- Lens.view newInlineStrategy if newInlineStrat || isCheapFunction e then return (Right ((nm,e),us)) else return (Left b) flattenCallTree :: CallTree -> NormalizeSession CallTree flattenCallTree c@(CLeaf _) = return c flattenCallTree (CBranch (nm,(Binding nm' sp inl pr tm r)) used) = do flattenedUsed <- mapM flattenCallTree used (newUsed,il_ct) <- partitionEithers <$> mapM flattenNode flattenedUsed let (toInline,il_used) = unzip il_ct subst = extendGblSubstList (mkSubst emptyInScopeSet) toInline newExpr <- case toInline of [] -> return tm _ -> do let tm1 = substTm "flattenCallTree.flattenExpr" subst tm -- NB: When -fclash-debug-history is on, emit binary data holding the recorded rewrite steps opts <- Lens.view debugOpts let rewriteHistFile = dbg_historyFile opts when (Maybe.isJust rewriteHistFile) $ let !_ = unsafePerformIO $ BS.appendFile (Maybe.fromJust rewriteHistFile) $ BL.toStrict $ encode RewriteStep { t_ctx = [] , t_name = "INLINE" , t_bndrS = showPpr (varName nm') , t_before = tm , t_after = tm1 } in pure () rewriteExpr ("flattenExpr",flatten) (showPpr nm, tm1) (nm', sp) let allUsed = newUsed ++ concat il_used -- 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 not (isNoInline inl) && isCheapFunction newExpr then do let (toInline',allUsed') = unzip (map goCheap allUsed) subst' = extendGblSubstList (mkSubst emptyInScopeSet) (Maybe.catMaybes toInline') let tm1 = substTm "flattenCallTree.flattenCheap" subst' newExpr newExpr' <- rewriteExpr ("flattenCheap",flatten) (showPpr nm, tm1) (nm', sp) return (CBranch (nm,(Binding nm' sp inl pr newExpr' r)) (concat allUsed')) else return (CBranch (nm,(Binding nm' sp inl pr newExpr r)) allUsed) where flatten = repeatR (topdownR (apply "appProp" appProp >-> apply "bindConstantVar" bindConstantVar >-> apply "caseCon" caseCon >-> (apply "reduceConst" reduceConst !-> apply "deadcode" deadCode) >-> apply "reduceNonRepPrim" reduceNonRepPrim >-> apply "removeUnusedExpr" removeUnusedExpr) >-> bottomupR (apply "flattenLet" flattenLet)) !-> topdownSucR (apply "topLet" topLet) goCheap c@(CLeaf (nm2,(Binding _ _ inl2 _ e _))) | isNoInline inl2 = (Nothing ,[c]) | otherwise = (Just (nm2,e),[]) goCheap c@(CBranch (nm2,(Binding _ _ inl2 _ e _)) us) | isNoInline inl2 = (Nothing, [c]) | otherwise = (Just (nm2,e),us) callTreeToList :: [Id] -> CallTree -> ([Id], [(Id, Binding Term)]) callTreeToList visited (CLeaf (nm,bndr)) | nm `elem` visited = (visited,[]) | otherwise = (nm:visited,[(nm,bndr)]) callTreeToList visited (CBranch (nm,bndr) used) | nm `elem` visited = (visited,[]) | otherwise = (visited',(nm,bndr):(concat others)) where (visited',others) = mapAccumL callTreeToList (nm:visited) used clash-lib-1.8.1/src/Clash/Normalize/0000755000000000000000000000000007346545000015331 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Normalize/PrimitiveReductions.hs0000644000000000000000000015172707346545000021712 0ustar0000000000000000{-| Copyright : (C) 2015-2016, University of Twente, 2016 , Myrtle Software Ltd, 2021 , QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Reductions of primitives Currently, it contains reductions for: * Clash.Sized.Vector.map * Clash.Sized.Vector.zipWith * Clash.Sized.Vector.traverse# * Clash.Sized.Vector.foldr * Clash.Sized.Vector.fold * Clash.Sized.Vector.dfold * Clash.Sized.Vector.(++) * Clash.Sized.Vector.head * Clash.Sized.Vector.tail * Clash.Sized.Vector.unconcatBitVector# * Clash.Sized.Vector.replicate * Clash.Sized.Vector.imap * Clash.Sized.Vector.dtfold * Clash.Sized.RTree.tfold * Clash.Sized.Vector.reverse * Clash.Sized.Vector.unconcat Partially handles: * Clash.Sized.Vector.transpose -} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} module Clash.Normalize.PrimitiveReductions where 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) #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names (boolTyConKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey) import GHC.Types.Unique (getKey) import GHC.Types.SrcLoc (wiredInSrcSpan) #else import PrelNames (boolTyConKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey) import Unique (getKey) import SrcLoc (wiredInSrcSpan) #endif import Clash.Core.DataCon (DataCon) import Clash.Core.HasType import Clash.Core.Literal (Literal (..)) import Clash.Core.Name (nameOcc, Name(..), NameSort(User), mkUnsafeSystemName) import Clash.Core.Pretty (showPpr) import Clash.Core.Term (IsMultiPrim (..), CoreContext (..), PrimInfo (..), Term (..), WorkInfo (..), Pat (..), collectTermIds, mkApps, PrimUnfolding(..)) import Clash.Core.Type (LitTy (..), Type (..), TypeView (..), coreView1, mkFunTy, mkTyConApp, splitFunForallTy, tyView) import Clash.Core.TyCon (TyConMap, TyConName, tyConDataCons, tyConName) import Clash.Core.TysPrim (integerPrimTy, typeNatKind, liftedTypeKind) import Clash.Core.Util (appendToVec, extractElems, extractTElems, mkRTree, mkUniqInternalId, mkUniqSystemTyVar, mkVec, dataConInstArgTys, primCo) import Clash.Core.Var (mkTyVar, mkLocalId) 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.Util import qualified Clash.Util.Interpolate as I typeNatAdd :: TyConName typeNatAdd = Name User "GHC.TypeNats.+" (getKey typeNatAddTyFamNameKey) wiredInSrcSpan typeNatMul :: TyConName typeNatMul = Name User "GHC.TypeNats.*" (getKey typeNatMulTyFamNameKey) wiredInSrcSpan typeNatSub :: TyConName typeNatSub = Name User "GHC.TypeNats.-" (getKey typeNatSubTyFamNameKey) wiredInSrcSpan vecHeadPrim :: TyConName -- ^ Vec TyCon name -> Term vecHeadPrim vecTcNm = -- head :: Vec (n+1) a -> a Prim (PrimInfo "Clash.Sized.Vector.head" (vecHeadTy vecTcNm) WorkNever SingleResult NoUnfolding) vecLastPrim :: TyConName -- ^ Vec TyCon name -> Term vecLastPrim vecTcNm = -- last :: Vec (n+1) a -> a -- has the same type signature as head, hence we're reusing its type -- definition here. Prim (PrimInfo "Clash.Sized.Vector.last" (vecHeadTy vecTcNm) WorkNever SingleResult NoUnfolding) vecHeadTy :: TyConName -- ^ Vec TyCon name -> Type vecHeadTy vecNm = ForAllTy nTV $ ForAllTy aTV $ mkFunTy (mkTyConApp vecNm [mkTyConApp typeNatAdd [VarTy nTV, LitTy (NumTy 1)], VarTy aTV]) (VarTy aTV) where aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0) nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1) vecTailPrim :: TyConName -- ^ Vec TyCon name -> Term vecTailPrim vecTcNm = -- tail :: Vec (n + 1) a -> Vec n a Prim (PrimInfo "Clash.Sized.Vector.tail" (vecTailTy vecTcNm) WorkNever SingleResult NoUnfolding) vecInitPrim :: TyConName -- ^ Vec TyCon name -> Term vecInitPrim vecTcNm = -- init :: Vec (n + 1) a -> Vec n a -- has the same type signature as tail, hence we're reusing its type -- definition here. Prim (PrimInfo "Clash.Sized.Vector.init" (vecTailTy vecTcNm) WorkNever SingleResult NoUnfolding) vecTailTy :: TyConName -- ^ Vec TyCon name -> Type vecTailTy vecNm = ForAllTy nTV $ ForAllTy aTV $ mkFunTy (mkTyConApp vecNm [mkTyConApp typeNatAdd [VarTy nTV, LitTy (NumTy 1)], VarTy aTV]) (mkTyConApp vecNm [VarTy nTV, VarTy aTV]) where nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0) aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1) -- | Makes two case statements: the first one extract the _head_ from the given -- vector, the latter the tail. extractHeadTail :: DataCon -- ^ The Cons (:>) constructor -> Type -- ^ Element type -> Integer -- ^ 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 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)))] -- | Create a vector of supplied elements mkVecCons :: HasCallStack => DataCon -- ^ The Cons (:>) constructor -> Type -- ^ Element type -> Integer -- ^ Length of the vector -> Term -- ^ head of the vector -> Term -- ^ tail of the vector -> Term mkVecCons consCon resTy n h t | n <= 0 = error "mkVecCons: n <= 0" | 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 :: DataCon -- ^ The Nil constructor -> Type -- ^ The element type -> Term 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 :: Integer -- ^ Length of the vector, must be positive -> Type -- ^ Element of type of the vector -> Term -- ^ The vector to reverse -> TransformContext -> NormalizeSession Term 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 <- 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 sconcat . NE.unzip) $ extractElems uniqs0 inScope0 consCon elTy 'V' n vArg 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 -- | Replace an application of the @Clash.Sized.Vector.zipWith@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.zipWith@ reduceZipWith :: 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 -> Type -- ^ Element type of the result of the function -> Term -- ^ The zipWith'd functions -> Term -- ^ The 1st vector argument -> Term -- ^ The 2nd vector argument -> TransformContext -> NormalizeSession Term 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) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon, consCon] <- tyConDataCons vecTc = if n == 0 then mkVecNil nilCon resElTy else let (a, as) = extractHeadTail consCon lhsElTy n lhsArg (b, bs) = extractHeadTail consCon rhsElTy n rhsArg c = mkApps fun [Left a, Left b] cs = mkApps (Prim zipWithPrimInfo) [ Right lhsElTy , Right rhsElTy , Right resElTy , Right (LitTy (NumTy (n - 1))) , Left fun , Left as , Left bs ] in mkVecCons consCon resElTy n c cs go _ ty = error $ $(curLoc) ++ [I.i| reduceZipWith: argument does not have a vector type: #{showPpr ty} |] -- | Replace an application of the @Clash.Sized.Vector.map@ primitive on vectors -- of a known length @n@, by the fully unrolled recursive "definition" of -- @Clash.Sized.Vector.map@ reduceMap :: 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 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) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon,consCon] <- tyConDataCons vecTc = if n == 0 then mkVecNil nilCon argElTy else let nPredTy = Right (LitTy (NumTy (n - 1))) (a, as) = extractHeadTail consCon argElTy n arg b = mkApps fun [Left a] bs = mkApps (Prim mapPrimInfo) [ Right argElTy , Right resElTy , nPredTy , Left fun , Left as ] in mkVecCons consCon resElTy n b bs go _ ty = error $ $(curLoc) ++ [I.i| reduceMap: argument does not have a vector type: #{showPpr ty} |] -- | Replace an application of the @Clash.Sized.Vector.imap@ primitive on vectors -- of a known length @n@, by the fully unrolled recursive "definition" of -- @Clash.Sized.Vector.imap@ reduceImap :: 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 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) <- 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) (uniqs1,nTv) = mkUniqSystemTyVar (uniqs0,is1) ("n",typeNatKind) (uniqs2,(vars,elems)) = second (second sconcat . NE.unzip) $ uncurry extractElems uniqs1 consCon argElTy 'I' n arg 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 (mkTyConApp idxTcNm [VarTy nTv]) [integerPrimTy,integerPrimTy]) idxFromInteger = Prim (PrimInfo "Clash.Sized.Internal.Index.fromInteger#" idxFromIntegerTy WorkNever SingleResult NoUnfolding) 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 (NE.toList vars) lbody = mkVec nilCon consCon resElTy n funApps 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 -- | Replace an application of the @Clash.Sized.Vector.iterateI@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.iterateI@ reduceIterateI :: 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 n aTy vTy _kn f0 a (TransformContext is0 ctx) = do tcm <- Lens.view tcCache f1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) f0 -- Generate uniq ids for element assignments. uniqs0 <- Lens.use uniqSupply let is1 = extendInScopeSetList is0 (collectTermIds f1) ((uniqs1, _is2), elementIds) = mapAccumR mkUniqInternalId (uniqs0, is1) (zip (map (("el" <>) . showt) [1..n-1]) (repeat aTy)) uniqSupply .= uniqs1 let elems = map (App f1) (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 -- el1 = f a -- el2 = f el1 -- el3 = f el2 -- .. -- in -- (a :> el1 :> el2 :> el3 :> ..) -- changed (Letrec (zip elementIds elems) vec) -- | Replace an application of the @Clash.Sized.Vector.traverse#@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.traverse#@ reduceTraverse :: 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 n aTy fTy bTy dict fun arg (TransformContext is0 ctx) = do tcm <- Lens.view tcCache 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) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon,consCon] <- tyConDataCons vecTc = 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 _ <- 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) 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 '<*>' 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 'fmap' function from the Functor dictionary fmapTy = coreTypeOf fmapId fmapTm = Case (Var functorDictId) fmapTy [(fnPat, Var fmapId)] (uniqs3,(vars,elems)) = second (second sconcat . NE.unzip) $ uncurry extractElems uniqs2 consCon aTy 'T' n arg funApps = map (fun1 `App`) (NE.toList vars) 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) ] ++ 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 -- -- e.g. for a length '2' input vector, we get -- -- > (:>) <$> x0 <*> ((:>) <$> x1 <*> pure Nil) mkTravVec :: TyConName -- ^ Vec tcon -> DataCon -- ^ Nil con -> DataCon -- ^ Cons con -> Term -- ^ 'pure' term -> Term -- ^ '<*>' term -> Term -- ^ 'fmap' term -> Type -- ^ 'b' ty -> Integer -- ^ Length of the vector -> [Term] -- ^ Elements of the vector -> Term mkTravVec vecTc nilCon consCon pureTm apTm fmapTm bTy = go where go :: Integer -> [Term] -> Term go _ [] = mkApps pureTm [Right (mkTyConApp vecTc [LitTy (NumTy 0),bTy]) ,Left (mkApps (Data nilCon) [Right (LitTy (NumTy 0)) ,Right bTy ,Left (primCo nilCoTy)])] go n (x:xs) = mkApps apTm [Right (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy]) ,Right (mkTyConApp vecTc [LitTy (NumTy n),bTy]) ,Left (mkApps fmapTm [Right bTy ,Right (mkFunTy (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy]) (mkTyConApp vecTc [LitTy (NumTy n),bTy])) ,Left (mkApps (Data consCon) [Right (LitTy (NumTy n)) ,Right bTy ,Right (LitTy (NumTy (n-1))) ,Left (primCo (consCoTy n)) ]) ,Left x]) ,Left (go (n-1) xs)] nilCoTy = case dataConInstArgTys nilCon [(LitTy (NumTy 0)), bTy] of Just (x:_) -> x _ -> error "impossible" 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 :: PrimInfo -- ^ Primitive info for foldr blackbox -> Integer -- ^ Length of the vector -> Type -- ^ Element type of the argument vector -> Term -- ^ The function to fold with -> Term -- ^ The starting value -> Term -- ^ The argument vector -> TransformContext -> NormalizeSession Term 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) where go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) | nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , Just vecTc <- UniqMap.lookup vecTcNm tcm , [_nilCon, consCon] <- tyConDataCons vecTc = let (a, as) = extractHeadTail consCon aTy n arg b = mkApps (Prim foldrPrimInfo) [ Right aTy , Right (inferCoreTypeOf tcm start) , Right (LitTy (NumTy (n - 1))) , Left fun , Left start , Left as ] in mkApps fun [Left a, Left b] go _ ty = error $ $(curLoc) ++ [I.i| reduceFoldr: argument does not have a vector type: #{showPpr ty} |] -- | Replace an application of the @Clash.Sized.Vector.fold@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.fold@ reduceFold :: 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 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) <- 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 sconcat . NE.unzip) $ extractElems uniqs0 is1 consCon aTy 'F' n arg 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 foldV _ [a] = a foldV f as = let (l,r) = splitAt (length as `div` 2) as lF = foldV f l rF = foldV f r in mkApps f [Left lF, Left rF] -- | Replace an application of the @Clash.Sized.Vector.dfold@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.dfold@ reduceDFold :: 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 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) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply 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 sconcat . NE.unzip) $ extractElems uniqs0 is1 consCon aTy 'D' n arg 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 doFold _ _ [] = start doFold snDc k (x:xs) = mkApps fun [Right (LitTy (NumTy k)) ,Left (snDc k) ,Left x ,Left (doFold snDc (k-1) xs) ] -- | Replace an application of the @Clash.Sized.Vector.head@ primitive on -- vectors of a known length @n@, by a projection of the first element of a -- vector. reduceHead :: Integer -- ^ Length of the vector, must be positive -> Type -- ^ Element type of the vector -> Term -- ^ The argument vector -> TransformContext -> NormalizeSession Term 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) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 inScope consCon aTy 'H' n vArg 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 -- | Replace an application of the @Clash.Sized.Vector.tail@ primitive on -- vectors of a known length @n@, by a projection of the tail of a -- vector. reduceTail :: Integer -- ^ Length of the vector, must be positive -> Type -- ^ Element type of the vector -> Term -- ^ The argument vector -> TransformContext -> NormalizeSession Term 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) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply let (uniqs1,(_,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 inScope consCon aTy 'L' n vArg b@(tB,_) = elems NE.!! 1 lb = Letrec [b] (Var tB) uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "reduceTail: argument does not have a vector type: " ++ showPpr ty -- | Replace an application of the @Clash.Sized.Vector.last@ primitive on -- vectors of a known length @n@, by a projection of the last element of a -- vector. reduceLast :: Integer -- ^ Length of the vector, must be positive -> Type -- ^ Element type of the vector -> Term -- ^ The argument vector -> TransformContext -> NormalizeSession Term 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) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply let (uniqs1,(_,elems)) = second NE.unzip $ extractElems uniqs0 inScope consCon aTy 'L' n vArg (tB,_) = NE.head (NE.last elems) uniqSupply Lens..= uniqs1 case n of 0 -> changed (TyApp (Prim NP.undefined) aTy) _ -> 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 :: PrimInfo -- ^ Primitive info for 'init' -> Integer -- ^ Length of the vector -> Type -- ^ Element type of the vector -> Term -- ^ The argument vector -> TransformContext -> NormalizeSession Term 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) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon, consCon] <- tyConDataCons vecTc = if n == 0 then mkVecNil nilCon aTy else let nPredTy = Right (LitTy (NumTy (n - 1))) (a, as0) = extractHeadTail consCon aTy (n+1) vArg as1 = mkApps (Prim initPrimInfo) [nPredTy, Right aTy, Left as0] in mkVecCons consCon aTy n a as1 go _ ty = error $ $(curLoc) ++ [I.i| reduceInit: argument does not have a vector type: #{showPpr ty} |] -- | Replace an application of the @Clash.Sized.Vector.(++)@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.(++)@ reduceAppend :: 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 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) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 inScope consCon aTy 'C' n lArg 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 -- | 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 :: 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 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) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon,consCon] <- tyConDataCons vecTc , let innerVecTy = mkTyConApp vecTcNm [LitTy (NumTy m), aTy] = if n == 0 then changed (mkVecNil nilCon innerVecTy) else if m == 0 then do let nilVec = mkVecNil nilCon aTy retVec = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec) changed retVec else do uniqs0 <- Lens.use uniqSupply let (uniqs1,(vars,headsAndTails)) = 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 (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,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))) , Right (LitTy (NumTy m)) , Right aTy , Left (Literal (NaturalLiteral (n-1))) , Left sm , Left (snd nextVec) ] -- let (mvec,nextVec) = splitAt sm arg -- in Cons mvec (unconcat sm nextVec) lBody = mkVecCons consCon innerVecTy n mvec nextUnconcat lb = Letrec lbs lBody uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "reduceUnconcat: argument does not have a vector type: " ++ showPpr ty -- | Replace an application of the @Clash.Sized.Vector.transpose@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.transpose@ 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 _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) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [nilCon,consCon] <- tyConDataCons vecTc = let nilVec = mkVec nilCon consCon aTy 0 [] innerVecTy = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy] retVec = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec) in changed retVec go _ ty = error $ $(curLoc) ++ "reduceTranspose: argument does not have a vector type: " ++ showPpr ty reduceTranspose _ _ _ _ _ _ = error $ $(curLoc) ++ "reduceTranspose: unimplemented" reduceReplicate :: Integer -> Type -> Type -> Term -> Term -> TransformContext -> NormalizeSession Term 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) <- 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) in changed retVec go _ ty = error $ $(curLoc) ++ "reduceReplicate: argument does not have a vector type: " ++ showPpr ty -- TODO: Take a shortcut when given index is a literal. Right now, this function -- TODO: simply creates a case statement for every element in the vector, which -- 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 :: 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 n aTy vTy _kn v i newA (TransformContext is0 _ctx) = do tcm <- Lens.view tcCache go tcm vTy where -- Basically creates: -- -- case eqInt i0 curI of -- True -> newA -- _ -> oldA -- -- where: -- -- - curI is the index of the current element, which we statically know -- - i0 is the index given to replace_int -- - newA is the element given to replace_int as a replacement for.. -- - oldA; an element at index curI -- replace_intElement :: TyConMap -- ^ TyCon map -> DataCon -- Int datacon -> Type -- Int type -> Term -- ^ Element in vector -> Integer -- ^ -> Term replace_intElement tcm iDc iTy oldA elIndex = case0 where 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 :: Type -> Type -> Term eqIntPrim intTy boolTy = Prim (PrimInfo "GHC.Classes.eqInt" (mkFunTy intTy (mkFunTy intTy boolTy)) WorkVariable SingleResult NoUnfolding) go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) | (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 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 sconcat . NE.unzip) $ extractElems uniqs0 is0 consCon aTy 'I' n v -- Replace every element with (if i == elIndex then newA else oldA) let replacedEls = zipWith (replace_intElement tcm iDc iTy) (NE.toList vars) [0..] lbody = mkVec nilCon consCon aTy n replacedEls lb = Letrec (NE.init elems) lbody uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "reduceReplace_int: argument does not have " ++ "a vector type: " ++ showPpr ty -- TODO: Take a shortcut when given index is a literal. Right now, this function -- TODO: simply creates a case statement for every element in the vector, which -- 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 :: 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 n aTy _kn v i (TransformContext is0 _ctx) = do tcm <- Lens.view tcCache let vTy = inferCoreTypeOf tcm v go tcm vTy where -- Basically creates: -- -- case eqInt i0 curI of -- True -> curA -- _ -> next -- -- where: -- -- - curI is the index of the current element, which we statically know -- - i0 is the index given to index_int -- - curA is the element at index curI -- - next; the value if the current index is not equal to index argument -- index_intElement :: TyConMap -- ^ TyCon map -> DataCon -- Int datacon -> Type -- Int type -> (Term, Integer) -- ^ Element in the vector, and its corresponding index -> Term -- ^ The rest -> Term index_intElement tcm iDc iTy (cur,elIndex) next = case0 where 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 :: Type -> Type -> Term eqIntPrim intTy boolTy = Prim ( PrimInfo "GHC.Classes.eqInt" (mkFunTy intTy (mkFunTy intTy boolTy)) WorkVariable SingleResult NoUnfolding) go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) | (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 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 sconcat . NE.unzip) $ extractElems uniqs0 is0 consCon aTy 'I' n v -- Build a right-biased tree of case-expressions let indexed = foldr (index_intElement tcm iDc iTy) (TyApp (Prim NP.undefined) aTy) (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 " ++ "a vector type: " ++ showPpr ty -- | Replace an application of the @Clash.Sized.Vector.dtfold@ primitive on -- vectors of a known length @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.Vector.dtfold@ reduceDTFold :: 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 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) <- UniqMap.lookup vecTcNm tcm , nameOcc vecTcNm == "Clash.Sized.Vector.Vec" , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip) $ extractElems uniqs0 inScope consCon aTy 'T' (2^n) arg 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 doFold :: (Integer -> Term) -> Integer -> [Term] -> Term doFold _ _ [x] = mkApps lrFun [Left x] doFold snDc k xs = let (xsL,xsR) = splitAt (2^k) xs k' = k-1 eL = doFold snDc k' xsL eR = doFold snDc k' xsR in mkApps brFun [Right (LitTy (NumTy k)) ,Left (snDc k) ,Left eL ,Left eR ] -- | Replace an application of the @Clash.Sized.RTree.tdfold@ primitive on -- trees of a known depth @n@, by the fully unrolled recursive "definition" -- of @Clash.Sized.RTree.tdfold@ reduceTFold :: 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 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) <- 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 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) uniqSupply Lens..= uniqs1 changed lb go _ ty = error $ $(curLoc) ++ "reduceTFold: argument does not have a tree type: " ++ showPpr ty doFold _ _ [x] = mkApps lrFun [Left x] doFold snDc k xs = let (xsL,xsR) = splitAt (length xs `div` 2) xs k' = k-1 eL = doFold snDc k' xsL eR = doFold snDc k' xsR in mkApps brFun [Right (LitTy (NumTy k)) ,Left (snDc k) ,Left eL ,Left eR ] 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 _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) <- 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) in changed retVec go _ ty = error $ $(curLoc) ++ "reduceTReplicate: argument does not have a RTree type: " ++ showPpr ty buildSNat :: DataCon -> Integer -> Term buildSNat snatDc i = mkApps (Data snatDc) [Right (LitTy (NumTy i)) ,Left (Literal (NaturalLiteral (toInteger i))) ] clash-lib-1.8.1/src/Clash/Normalize/Primitives.hs0000644000000000000000000000345107346545000020023 0ustar0000000000000000{-| Copyright : (C) 2021, QBayLogic B.V., 2022, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Special primitives created during the normalization process. -} {-# LANGUAGE TemplateHaskellQuotes #-} module Clash.Normalize.Primitives ( removedArg , undefined , undefinedX ) where import Prelude hiding (undefined) import qualified Data.Text.Extra as Text import Clash.Core.Term (IsMultiPrim(..), PrimInfo(..), PrimUnfolding(..), WorkInfo(..)) import Clash.Core.Util (undefinedTy) -- | The removedArg primitive represents an argument which is computationally -- irrelevant, and has been removed from the circuit (as removing it does not -- change the behaviour of the circuit). Examples of such arguments are unused -- arguments to blackboxes, as removing them does not affect the rendered HDL. -- removedArg :: PrimInfo removedArg = PrimInfo { primName = Text.showt 'removedArg , primType = undefinedTy , primWorkInfo = WorkNever , primMultiResult = SingleResult , primUnfolding = NoUnfolding } -- | The undefined primitive represents an undefined value that was identified -- during normalization. This includes undefined results to compile-time -- evaluation, such as division by zero. -- undefined :: PrimInfo undefined = PrimInfo { primName = Text.showt 'undefined , primType = undefinedTy , primWorkInfo = WorkNever , primMultiResult = SingleResult , primUnfolding = NoUnfolding } -- | The undefinedX primitive represents an X-exception throwing value that was -- identified during normalization. -- undefinedX :: PrimInfo undefinedX = PrimInfo { primName = Text.showt 'undefinedX , primType = undefinedTy , primWorkInfo = WorkNever , primMultiResult = SingleResult , primUnfolding = NoUnfolding } clash-lib-1.8.1/src/Clash/Normalize/Strategy.hs0000644000000000000000000002641307346545000017475 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, (C) 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Transformation process for normalization -} {-# LANGUAGE CPP #-} module Clash.Normalize.Strategy where import Clash.Normalize.Transformations import Clash.Normalize.Types import Clash.Rewrite.Combinators import Clash.Rewrite.Types import Clash.Rewrite.Util -- [Note: bottomup traversal evalConst] -- -- 2-May-2019: There is a bug in the evaluator where all data constructors are -- considered lazy, even though their declaration says they have strict fields. -- This causes some reductions to fail because the term under the constructor is -- not in WHNF, which is what some of the evaluation rules for certain primitive -- operations expect. Using a bottom-up traversal works around this bug by -- ensuring that the values under the constructor are in WHNF. -- -- Using a bottomup traversal ensures that constants are reduced to NF, even if -- constructors are lazy, thus ensuring more sensible/smaller generated HDL. -- | Normalisation transformation normalization :: NormRewrite normalization = rmDeadcode >-> multPrim >-> constantPropagation >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >-> bindConst >-> letTL >-> evalConst >-!-> cse >-!-> cleanup >-> xOptim >-> rmDeadcode >-> cleanup >-> bindSimIO >-> recLetRec >-> splitArgs where multPrim = topdownR (apply "setupMultiResultPrim" setupMultiResultPrim) anf = topdownR (apply "nonRepANF" nonRepANF) >-> apply "ANF" makeANF >-> topdownR (apply "caseCon" caseCon) letTL = topdownSucR (apply "topLet" topLet) recLetRec = apply "recToLetRec" recToLetRec rmUnusedExpr = bottomupR (apply "removeUnusedExpr" removeUnusedExpr) rmDeadcode = bottomupR (apply "deadcode" deadCode) bindConst = topdownR (apply "bindConstantVar" bindConstantVar) -- See [Note] bottomup traversal evalConst: evalConst = bottomupR (apply "evalConst" reduceConst) cse = topdownR (apply "CSE" simpleCSE) xOptim = bottomupR (apply "xOptimize" xOptimize) cleanup = topdownR (apply "etaExpandSyn" etaExpandSyn) >-> -- See [Note] relation `collapseRHSNoops` and `inlineCleanup` topdownSucR (apply "collapseRHSNoops" collapseRHSNoops) >-> topdownSucR (apply "inlineCleanup" inlineCleanup) !-> innerMost (applyMany [("caseCon" , caseCon) ,("bindConstantVar", bindConstantVar) ,("letFlat" , flattenLet)]) >-> rmDeadcode >-> letTL splitArgs = topdownR (apply "separateArguments" separateArguments) !-> bottomupR (apply "caseCon" caseCon) bindSimIO = topdownR (apply "bindSimIO" inlineSimIO) constantPropagation :: NormRewrite constantPropagation = inlineAndPropagate >-> caseFlattening >-> etaTL >-> dec >-> spec >-> dec >-> conSpec where etaTL = apply "etaTL" etaExpansionTL !-> topdownR (apply "applicationPropagation" appProp) inlineAndPropagate = repeatR (topdownR (applyMany transPropagateAndInline) >-> inlineNR) spec = bottomupR (applyMany specTransformations) caseFlattening = repeatR (topdownR (apply "caseFlat" caseFlat)) dec = repeatR (topdownR (apply "DEC" disjointExpressionConsolidation)) conSpec = bottomupR ((apply "appPropCS" appProp !-> bottomupR (apply "constantSpec" constantSpec)) >-! apply "constantSpec" constantSpec) transPropagateAndInline :: [(String,NormRewrite)] transPropagateAndInline = [ ("applicationPropagation", appProp ) , ("bindConstantVar" , bindConstantVar ) , ("caseLet" , caseLet ) , ("caseCase" , caseCase ) , ("caseCon" , caseCon ) , ("elimExistentials" , elimExistentials ) , ("caseElemNonReachable" , caseElemNonReachable ) , ("removeUnusedExpr" , removeUnusedExpr ) -- These transformations can safely be applied in a top-down traversal as -- they themselves check whether the to-be-inlined binder is recursive or not. , ("inlineWorkFree" , inlineWorkFree) , ("inlineSmall" , inlineSmall) , ("bindOrLiftNonRep", inlineOrLiftNonRep) -- See: [Note] bindNonRep before liftNonRep -- See: [Note] bottom-up traversal for liftNonRep , ("reduceNonRepPrim", reduceNonRepPrim) , ("caseCast" , caseCast) , ("letCast" , letCast) , ("splitCastWork" , splitCastWork) , ("argCastSpec" , argCastSpec) , ("inlineCast" , inlineCast) , ("elimCastCast" , elimCastCast) ] -- InlineNonRep cannot be applied in a top-down traversal, as the non-representable -- binder might be recursive. The idea is, is that if the recursive -- non-representable binder is inlined once, we can get rid of the recursive -- aspect using the case-of-known-constructor -- -- Note that we first do a dead code removal pass, which makes sure that -- unused let-bindings get cleaned up. Only if no dead code is removed -- 'inlineNonRep' is executed. We do this for two reasons: -- -- 1. 'deadCode' is an expensive operation and is therefore left out of -- the hot loop 'transPropagateAndInline'. -- -- 2. In various situations 'transPropagateAndInline' can do more work -- after 'deadCode' was successful. This work in turn might remove a -- a construct 'inlineNonRep' would fire on - saving the compiler work. -- inlineNR :: NormRewrite inlineNR = bottomupR (apply "deadCode" deadCode) >-! apply "inlineNonRep" inlineNonRep specTransformations :: [(String,NormRewrite)] specTransformations = [ ("typeSpec" , typeSpec) , ("nonRepSpec" , nonRepSpec) , ("zeroWidthSpec", zeroWidthSpec) -- See Note [zeroWidthSpec enabling transformations] ] {- Note [zeroWidthSpec enabling transformations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When zeroWidthSpec fires, it can lead to better results in normalization, but this is somewhat incidental. The extra transformations which fire are typically from * calls to transformations like caseCon which occur after constantPropagation (e.g. caseCon run after ANF conversion). * flattening / inlining which happens late in normalization (after regular normalization has occurred) * normalizing another function due to being marked NOINLINE If we consider the following: data AB = A | B ab :: KnownNat n => Index n -> AB -> AB ab n A = if n > 0 then A else B ab n B = if n == 0 then B else A {-# NOINLINE ab #-} topEntity = ab @1 {-# NOINLINE topEntity #-} The zeroWidthSpec transformation fires on the topEntity, giving a post-normalization topEntity of \(x :: Index 1) -> \(y :: AB) -> letrec result :: AB = ab' y in result where ab' = ab (fromInteger# 0) The extra transformations which fire happen later when ab' is normalized. Removing the NOINLINE from ab gives the same result, but the extra transformations fire in flattening instead. -} {- [Note] bottom-up traversal for liftNonRep We used to say: "The liftNonRep transformation must be applied in a topDown traversal because of what Clash considers tail calls in its join-point analysis." Consider: > let fail = \x -> ... > in case ... of > A -> let fail1 = \y -> case ... of > X -> fail ... > Y -> ... > in case ... of > P -> fail1 ... > Q -> ... > B -> fail ... under "normal" tail call rules, the local 'fail' functions is not a join-point because it is used in a let-binding. However, we apply "special" tail call rules in Clash. Because 'fail' is used in a TC position within 'fail1', and 'fail1' is only used in a TC position, in Clash, we consider 'tail' also only to be used in a TC position. Now image we apply 'liftNonRep' in a bottom up traversal, we will end up with: > fail1 = \fail y -> case ... of > X -> fail ... > Y -> ... > let fail = \x -> ... > in case ... of > A -> case ... of > P -> fail1 fail ... > Q -> ... > B -> fail ... Suddenly, 'fail' ends up in an argument position, because it occurred as a _locally_ bound variable within 'fail1'. And because of that 'fail' stops being a join-point. However, when we apply 'liftNonRep' in a top down traversal we end up with: > fail = \x -> ... > > fail1 = \y -> case ... of > X -> fail ... > Y -> ... > > let ... > in case ... of > A -> let > in case ... of > P -> fail1 ... > Q -> ... > B -> fail ... and all is well with the world. UPDATE: We can now just perform liftNonRep in a bottom-up traversal again, because liftNonRep no longer checks that if the binding that is lifted is a join-point. However, for this to work, bindNonRep must always have been exhaustively applied before liftNonRep. See also: [Note] bindNonRep before liftNonRep. -} {- [Note] bindNonRep before liftNonRep The combination of liftNonRep and nonRepSpec can lead to non-termination in an unchecked rewrite system (without termination measures in place) on the following: > main = f not > f = \a x -> (a x) && (f a x) nonRepSpec will lead to: > main = f' > f = \a x -> (a x) && (f a x) > f' = (\a x -> (a x) && (f a x)) not then lamApp leads to: > main = f' > f = \a x -> (a x) && (f a x) > f' = let a = not in (\x -> (a x) && (f a x)) then liftNonRep leads to: > main = f' > f = \a x -> (a x) && (f a x) > f' = \x -> (g x) && (f g x) > g = not and nonRepSepc leads to: > main = f' > f = \a x -> (a x) && (f a x) > f' = \x -> (g x) && (f'' g x) > g = not > f'' = (\a x -> (a x) && (f a x)) g This cycle continues indefinitely, as liftNonRep creates a new global variable, which is never alpha-equivalent to the previous global variable introduced by liftNonRep. That is why bindNonRep must always be applied before liftNonRep. When we end up in the situation after lamApp: > main = f' > f = \a x -> (a x) && (f a x) > f' = let a = not in (\x -> (a x) && (f a x)) bindNonRep will now lead to: > main = f' > f = \a x -> (a x) && (f a x) > f' = \x -> (not x) && (f not x) Because `f` has already been specialized on the alpha-equivalent-to-itself `not` function, liftNonRep leads to: > main = f' > f = \a x -> (a x) && (f a x) > f' = \x -> (not x) && (f' x) And there is no non-terminating rewriting cycle. That is why bindNonRep must always be exhaustively applied before we apply liftNonRep. -} -- | Topdown traversal, stops upon first success topdownSucR :: Rewrite extra -> Rewrite extra topdownSucR r = r >-! (allR (topdownSucR r)) {-# INLINE topdownSucR #-} innerMost :: Rewrite extra -> Rewrite extra innerMost = let go r = bottomupR (r !-> innerMost r) in go {-# INLINE innerMost #-} applyMany :: [(String,Rewrite extra)] -> Rewrite extra applyMany = foldr1 (>->) . map (uncurry apply) {-# INLINE applyMany #-} clash-lib-1.8.1/src/Clash/Normalize/Strategy.hs-boot0000644000000000000000000000027007346545000020427 0ustar0000000000000000module Clash.Normalize.Strategy (constantPropagation, normalization) where import Clash.Normalize.Types (NormRewrite) normalization :: NormRewrite constantPropagation :: NormRewrite clash-lib-1.8.1/src/Clash/Normalize/Transformations.hs0000644000000000000000000000201107346545000021050 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., 2021 , QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Transformations of the Normalization process -} module Clash.Normalize.Transformations ( module X ) where import Clash.Normalize.Transformations.ANF as X import Clash.Normalize.Transformations.Case as X import Clash.Normalize.Transformations.Cast as X import Clash.Normalize.Transformations.DEC as X import Clash.Normalize.Transformations.EtaExpand as X import Clash.Normalize.Transformations.Inline as X import Clash.Normalize.Transformations.Letrec as X import Clash.Normalize.Transformations.MultiPrim as X import Clash.Normalize.Transformations.Reduce as X import Clash.Normalize.Transformations.SeparateArgs as X import Clash.Normalize.Transformations.Specialize as X import Clash.Normalize.Transformations.XOptimize as X clash-lib-1.8.1/src/Clash/Normalize/Transformations/0000755000000000000000000000000007346545000020522 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Normalize/Transformations/ANF.hs0000644000000000000000000003704607346545000021474 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Transformations for converting to A-Normal Form. -} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Normalize.Transformations.ANF ( makeANF , nonRepANF ) where import Control.Arrow ((***)) import Control.Lens (_2) import qualified Control.Lens as Lens import qualified Control.Monad as Monad import Control.Monad.State (StateT, lift, modify, runStateT) import Control.Monad.Writer (listen) import Data.Bifunctor (second) import qualified Data.Monoid as Monoid (Any(..)) import qualified Data.Text.Extra as Text (showt) import GHC.Stack (HasCallStack) import Clash.Signal.Internal (Signal(..)) import Clash.Core.DataCon (DataCon(..)) import Clash.Core.HasFreeVars (disjointFreeVars) import Clash.Core.HasType import Clash.Core.Name (mkUnsafeSystemName, nameOcc) import Clash.Core.Subst (deshadowLetExpr, freshenTm) import Clash.Core.Term ( Alt, CoreContext(..), LetBinding, Pat(..), PrimInfo(..), Term(..) , collectArgs, collectTicks, mkTicks, partitionTicks, stripTicks) import Clash.Core.TermInfo (isCon, isLocalVar, isPrim, isVar) import Clash.Core.TyCon (TyConMap) import Clash.Core.Type (Type, TypeView(..), coreView, tyView) import Clash.Core.Util (mkSelectorCase) import Clash.Core.Var (Id) import Clash.Core.VarEnv (InScopeSet, extendInScopeSet, extendInScopeSetList, mkVarSet) import Clash.Netlist.Util (bindsExistentials) import Clash.Normalize.Transformations.Specialize (specialize) import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Rewrite.Combinators (bottomupR) import Clash.Rewrite.Types (Transform, TransformContext(..), tcCache) import Clash.Rewrite.Util (changed, isUntranslatable, mkDerivedName, mkTmBinderFor) import Clash.Rewrite.WorkFree (isConstant, isConstantNotClockReset) import Clash.Util (curLoc) {- [Note: ANF in Clash] ANF suitable for use in Clash can be described with the given types: data ATerm = ALam !Id ATerm | ATyLam !TyVar ATerm | ALetrec [(Id, CTerm)] !ITerm data CTerm = CApp !Id [Either ITerm Type] | CCase !ITerm !Type [(Pat, ITerm)] | CCast !ITerm !Type !Type | CPrim !PrimInfo [Either ITerm Type] | CTick !TickInfo CTerm data ITerm = IVar !Id | ILiteral !Literal | IData !DataCon [Either ITerm Type] | IPrim !PrimInfo [Either ITerm Type] | ITick !TickInfo ITerm where ATerm is a term in A-normal form, CTerm is a compound term (i.e. one which can only appear let-bound in ANF) and ITerm is an immediate term (i.e. one which represents some simple term). There are two constructors for primtiives, CPrim and IPrim. The difference between these are whether the primitive performs work or not. Primitives which perform work should be shared, but work-free primitives can be used directly. These types help codify some invariants that must hold for the result of ANF: * terms start with (ty)lambdas, lambdas do not occur in let bindings or the the body of a letrec expression * there are no nested letrec expressions, only a single letrec which may occur after all lambdas * an ANF term may not have a letrec expression if the definition is already an immediate term, e.g. where there is no benefit in sharing the result * only compound terms are let-bound, as there is no benefit from let binding an immediate term (there is no benefit to sharing immediate terms) * arguments to functions / data constructors / primitives are not let bound if they correspond are immediate, but are if they are compound (to produce a variable which is an immediate term) * the leftmost innermost term in a function application is always an identifier, lambdas should have been removed by application propagation * the right-hand side of a case alternative is an immediate term * the body of the letrec expression is an immediate term Some invariants are not captured by these types: * non-representable terms and terms in IO are not let-bound, instead they are pushed down as far as possible * if a let binding is created for the result, the name of the Id is "result" TODO: The best way to enforce that Clash implements ANF compatible with these types is to implement ANF using these types. However, as currently implemented ANF is mostly defined using the bottom-up transformation 'collectANF'. This would be some amount of effort to replace currently, perhaps it would be better to convert the result of partial evaluation to these data types when it is implemented more, then use these Anf types directly in the conversion to netlist, i.e. Term -> Value -> Normal -> Anf -> Netlist. -} {- [Note: Name re-creation] The names of heap bound variables are safely generate with mkUniqSystemId in Clash.Core.Evaluator.newLetBinding. But only their uniqs end up in the heap, not the complete names. So we use mkUnsafeSystemName to recreate the same Name. -} -- | Turn an expression into a modified ANF-form. As opposed to standard ANF, -- constants do not become let-bound. makeANF :: HasCallStack => NormRewrite makeANF (TransformContext is0 ctx) (Lam bndr e) = do let ctx' = TransformContext (extendInScopeSet is0 bndr) (LamBody bndr : ctx) e' <- makeANF ctx' e return (Lam bndr e') makeANF _ e@(TyLam {}) = return e makeANF ctx@(TransformContext is0 _) e0 = do -- We need to freshen all binders in `e` because we're shuffling them around -- into a single let-binder, because even when binders don't shadow, they -- don't have to be unique within an expression. And so lifting them all -- to a single let-binder will cause issues when they're not unique. -- -- We cannot make freshening part of collectANF, because when we generate -- new binders, we need to make sure those names do not conflict with _any_ -- of the existing binders in the expression. -- -- See also Note [ANF InScopeSet] let (is2,e1) = freshenTm is0 e0 ((e2,(bndrs,_)),Monoid.getAny -> hasChanged) <- listen (runStateT (bottomupR collectANF ctx e1) ([],is2)) case bndrs of [] -> if hasChanged then return e2 else return e0 _ -> do let (e3,ticks) = collectTicks e2 (srcTicks,nmTicks) = partitionTicks ticks -- Ensure that `AppendName` ticks still scope over the entire expression changed (mkTicks (Letrec bndrs (mkTicks e3 srcTicks)) nmTicks) {-# SCC makeANF #-} type NormRewriteW = Transform (StateT ([LetBinding],InScopeSet) NormalizeSession) -- | See Note [ANF InScopeSet] tellBinders :: [LetBinding] -> StateT ([LetBinding],InScopeSet) NormalizeSession () tellBinders bs = modify ((bs ++) *** (`extendInScopeSetList` (map fst bs))) -- | See Note [ANF InScopeSet]; only extends the inscopeset notifyBinders :: Monad m => [LetBinding] -> StateT ([LetBinding],InScopeSet) m () notifyBinders bs = modify (second (`extendInScopeSetList` (map fst bs))) -- | Is the given type IO-like isSimIOTy :: TyConMap -> Type -- ^ Type to check for IO-likeness -> Bool isSimIOTy tcm ty = case tyView (coreView tcm ty) of TyConApp tcNm args | nameOcc tcNm == "Clash.Explicit.SimIO.SimIO" -> True | nameOcc tcNm == "GHC.Prim.(#,#)" , [_,_,st,_] <- args -> isStateTokenTy tcm st FunTy _ res -> isSimIOTy tcm res _ -> False -- | Is the given type the state token isStateTokenTy :: TyConMap -> Type -- ^ Type to check for state tokenness -> Bool isStateTokenTy tcm ty = case tyView (coreView tcm ty) of TyConApp tcNm _ -> nameOcc tcNm == "GHC.Prim.State#" _ -> False -- | Note [ANF InScopeSet] -- -- The InScopeSet contains: -- -- 1. All the free variables of the expression we are traversing -- -- 2. All the bound variables of the expression we are traversing -- -- 3. The newly created let-bindings as we recurse back up the traversal -- -- All of these are needed to created let-bindings that -- -- * Do not shadow -- * Are not shadowed -- * Nor conflict with each other (i.e. have the same unique) -- -- Initially we start with the local InScopeSet and add the global variables: -- -- @ -- is1 <- unionInScope is0 <$> Lens.use globalInScope -- @ -- -- Which will gives us the (superset of) free variables of the expression. Then -- we call 'freshenTm' -- -- @ -- let (is2,e1) = freshenTm is1 e0 -- @ -- -- Which extends the InScopeSet with all the bound variables in 'e1', the -- version of 'e0' where all binders are unique (not just deshadowed). -- -- So we start out with an InScopeSet that satisfies points 1 and 2, now every -- time we create a new binder we must add it to the InScopeSet to satisfy -- point 3. -- -- Note [ANF no let-bind] -- -- | Do not let-bind: -- -- 1. Arguments with an untranslatable type: untranslatable expressions -- should be propagated down as far as possible -- -- 2. Local variables or constants: they don't add any work, so no reason -- to let-bind to enable sharing -- -- 3. IO actions, the translation of IO actions to sequential HDL constructs -- depends on IO actions to be propagated down as far as possible. collectANF :: HasCallStack => NormRewriteW collectANF ctx e@(App appf arg) | (conVarPrim, _) <- collectArgs e , isCon conVarPrim || isPrim conVarPrim || isVar conVarPrim = do tcm <- Lens.view tcCache untranslatable <- lift (isUntranslatable False arg) let localVar = isLocalVar arg constantNoCR = isConstantNotClockReset tcm arg -- See Note [ANF no let-bind] case (untranslatable,localVar || constantNoCR, isSimBind conVarPrim,arg) of (False,False,False,_) -> do -- See Note [ANF InScopeSet] is1 <- Lens.use _2 argId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "app_arg") arg) -- See Note [ANF InScopeSet] tellBinders [(argId,arg)] return (App appf (Var argId)) (True,False,_,Letrec binds body) -> do tellBinders binds return (App appf body) _ -> return e where isSimBind (Prim p) = primName p == "Clash.Explicit.SimIO.bindSimIO#" isSimBind _ = False collectANF _ (Letrec binds body) = do tcm <- Lens.view tcCache let isSimIO = isSimIOTy tcm (inferCoreTypeOf tcm body) untranslatable <- lift (isUntranslatable False body) let localVar = isLocalVar body -- See Note [ANF no let-bind] if localVar || untranslatable || isSimIO then do tellBinders binds return body else do -- See Note [ANF InScopeSet] is1 <- Lens.use _2 argId <- lift (mkTmBinderFor is1 tcm (mkUnsafeSystemName "result" 0) body) -- See Note [ANF InScopeSet] tellBinders [(argId,body)] tellBinders binds return (Var argId) -- TODO: The code below special-cases ANF for the ':-' constructor for the -- 'Signal' type. The 'Signal' type is essentially treated as a "transparent" -- type by the Clash compiler, so observing its constructor leads to all kinds -- of problems. In this case that "Clash.Rewrite.Util.mkSelectorCase" will -- try to project the LHS and RHS of the ':-' constructor, however, -- 'mkSelectorCase' uses 'coreView1' to find the "real" data-constructor. -- 'coreView1' however looks through the 'Signal' type, and hence 'mkSelector' -- finds the data constructors for the element type of Signal. This resulted in -- error #24 (https://github.com/christiaanb/clash2/issues/24), where we -- try to get the first field out of the 'Vec's 'Nil' constructor. -- -- Ultimately we should stop treating Signal as a "transparent" type and deal -- handling of the Signal type, and the involved co-recursive functions, -- properly. At the moment, Clash cannot deal with this recursive type and the -- recursive functions involved, hence the need for special-casing code. After -- everything is done properly, we should remove the two lines below. collectANF _ e@(Case _ _ [(DataPat dc _ _,_)]) | nameOcc (dcName dc) == Text.showt '(:-) = return e collectANF ctx (Case subj ty alts) = do let localVar = isLocalVar subj let isConstantSubj = isConstant subj (subj',subjBinders) <- if localVar || isConstantSubj then return (subj,[]) else do tcm <- Lens.view tcCache -- See Note [ANF InScopeSet] is1 <- Lens.use _2 argId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "case_scrut") subj) -- See Note [ANF InScopeSet] notifyBinders [(argId,subj)] return (Var argId,[(argId,subj)]) tcm <- Lens.view tcCache let isSimIOAlt = isSimIOTy tcm ty alts' <- mapM (doAlt isSimIOAlt subj') alts tellBinders subjBinders case alts' of [(DataPat _ [] xs,altExpr)] | mkVarSet xs `disjointFreeVars` altExpr || isSimIOAlt -> return altExpr _ -> return (Case subj' ty alts') where doAlt :: Bool -> Term -> Alt -> StateT ([LetBinding],InScopeSet) NormalizeSession Alt doAlt isSimIOAlt subj' alt@(DataPat dc exts xs,altExpr) | not (bindsExistentials exts xs) = do let lv = isLocalVar altExpr patSels <- Monad.zipWithM (doPatBndr subj' dc) xs [0..] let altExprIsConstant = isConstant altExpr let usesXs (Var n) = any (== n) xs usesXs _ = False -- See [ANF no let-bind] if or [isSimIOAlt, lv && (not (usesXs altExpr) || length alts == 1), altExprIsConstant] then do -- See Note [ANF InScopeSet] tellBinders patSels return alt else do tcm <- Lens.view tcCache -- See Note [ANF InScopeSet] is1 <- Lens.use _2 altId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "case_alt") altExpr) -- See Note [ANF InScopeSet] tellBinders (patSels ++ [(altId,altExpr)]) return (DataPat dc exts xs,Var altId) doAlt _ _ alt@(DataPat {}, _) = return alt doAlt isSimIOAlt _ alt@(pat,altExpr) = do let lv = isLocalVar altExpr let altExprIsConstant = isConstant altExpr -- See [ANF no let-bind] if isSimIOAlt || lv || altExprIsConstant then return alt else do tcm <- Lens.view tcCache -- See Note [ANF InScopeSet] is1 <- Lens.use _2 altId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "case_alt") altExpr) tellBinders [(altId,altExpr)] return (pat,Var altId) doPatBndr :: Term -> DataCon -> Id -> Int -> StateT ([LetBinding],InScopeSet) NormalizeSession LetBinding doPatBndr subj' dc pId i = do tcm <- Lens.view tcCache -- See Note [ANF InScopeSet] is1 <- Lens.use _2 patExpr <- lift (mkSelectorCase ($(curLoc) ++ "doPatBndr") is1 tcm subj' (dcTag dc) i) -- No need to 'tellBinders' here because 'pId' is already in the ANF -- InScopeSet. -- -- See also Note [ANF InScopeSet] return (pId,patExpr) collectANF _ e = return e {-# SCC collectANF #-} -- | Bring an application of a DataCon or Primitive in ANF, when the argument is -- is considered non-representable nonRepANF :: HasCallStack => NormRewrite nonRepANF ctx@(TransformContext is0 _) e@(App appConPrim arg) | (conPrim, _) <- collectArgs e , isCon conPrim || isPrim conPrim = do untranslatable <- isUntranslatable False arg case (untranslatable,stripTicks arg) of (True,Let binds body) -> -- This is a situation similar to Note [CaseLet deshadow] let (binds1,body1) = deshadowLetExpr is0 binds body in changed (Let binds1 (App appConPrim body1)) (True,Case {}) -> specialize ctx e (True,Lam {}) -> specialize ctx e (True,TyLam {}) -> specialize ctx e _ -> return e nonRepANF _ e = return e {-# SCC nonRepANF #-} clash-lib-1.8.1/src/Clash/Normalize/Transformations/Case.hs0000644000000000000000000006303507346545000021740 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2022, Google Inc., 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Transformations on case-expressions -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Normalize.Transformations.Case ( caseCase , caseCon , caseElemNonReachable , caseFlat , caseLet , caseOneAlt , elimExistentials ) where import qualified Control.Lens as Lens import Control.Monad.State.Strict (evalState) import Data.Bifunctor (second) import Data.Coerce (coerce) import qualified Data.Either as Either import qualified Data.List as List import qualified Data.List.Extra as List import qualified Data.Maybe as Maybe import qualified Data.Primitive.ByteArray as BA import qualified Data.Text.Extra as Text (showt) import GHC.Stack (HasCallStack) #if MIN_VERSION_base(4,15,0) import GHC.Num.Integer (Integer(..)) #else import GHC.Integer.GMP.Internals (BigNat(..), Integer(..)) #endif import Clash.Sized.Internal.BitVector as BV (BitVector, eq#) import Clash.Sized.Internal.Index as I (Index, eq#) import Clash.Sized.Internal.Signed as S (Signed, eq#) import Clash.Sized.Internal.Unsigned as U (Unsigned, eq#) import Clash.Core.DataCon (DataCon(..)) import Clash.Core.EqSolver import Clash.Core.FreeVars (freeLocalIds, localVarsDoNotOccurIn) import Clash.Core.HasType import Clash.Core.Literal (Literal(..)) import Clash.Core.Name (nameOcc) import Clash.Core.Pretty (showPpr) import Clash.Core.Subst import Clash.Core.Term ( Alt, Pat(..), PrimInfo(..), Term(..), collectArgs, collectArgsTicks , collectTicks, mkApps, mkTicks, patIds, stripTicks, Bind(..)) import Clash.Core.TyCon (TyConMap) import Clash.Core.Type (LitTy(..), Type(..), TypeView(..), coreView1, tyView) import Clash.Core.Util (listToLets, mkInternalVar) import Clash.Core.VarEnv ( InScopeSet, elemVarSet, extendInScopeSet, extendInScopeSetList, mkVarSet , unitVarSet, uniqAway) import Clash.Debug (traceIf) import Clash.Driver.Types (DebugOpts(dbg_invariants)) import Clash.Netlist.Types (FilteredHWType(..), HWType(..)) import Clash.Netlist.Util (coreTypeToHWType, representableType) import qualified Clash.Normalize.Primitives as NP (undefined, undefinedX) import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Rewrite.Combinators ((>-!)) import Clash.Rewrite.Types ( TransformContext(..), bindings, customReprs, debugOpts, tcCache , typeTranslator, workFreeBinders) import Clash.Rewrite.Util (changed, isFromInt, whnfRW) import Clash.Rewrite.WorkFree import Clash.Util (curLoc) -- | Move a Case-decomposition from the subject of a Case-decomposition to the -- alternatives caseCase :: HasCallStack => NormRewrite caseCase (TransformContext is0 _) e@(Case (stripTicks -> Case scrut alts1Ty alts1) alts2Ty alts2) = do ty1Rep <- representableType <$> Lens.view typeTranslator <*> Lens.view customReprs <*> pure False <*> Lens.view tcCache <*> pure alts1Ty -- This is only worth doing if the inner case-expression has a -- non-representable alternative type. if ty1Rep then return e else -- Deshadow to prevent accidental capture of free variables of inner -- case. Imagine: -- -- case (case a of {x -> x}) of {_ -> x} -- -- 'x' is introduced the inner 'case' and used (as a free variable) in -- the outer one. The goal of 'caseCase' is to rewrite cases such that -- their subjects aren't cases. This is achieved by 'pushing' the outer -- case to all the alternatives of the inner one. Naively doing so in -- this example would cause an accidental capture: -- -- case a of {x -> case x of {_ -> x}} -- -- Suddenly, the 'x' in the alternative of the inner case statement -- refers to the one introduced by the outer one, instead of being a -- free variable. To prevent this, we deshadow the alternatives of the -- original inner case. We now end up with: -- -- case a of {x1 -> case x1 of {_ -> x}} -- let newAlts = fmap (second (\altE -> Case altE alts2Ty alts2)) (fmap (deShadowAlt is0) alts1) in changed $ Case scrut alts2Ty newAlts caseCase _ e = return e {-# SCC caseCase #-} {- NOTE: caseOneAlt before caseCon' When you put a bang on a signal argument: f :: Signal d a -> _ f !x = ... GHC generates a case like: case x of _ :- _ -> ... When this f is inlined in an: g = f (pure False) And clash does its Signal d a ~ a thing we get: g = case False of _ :- _ -> ... Because no pattern matches caseCon transforms this into g = undefined By trying caseOneAlt first clash can instead drop the case and use the body of the single alternative. -} caseCon :: HasCallStack => NormRewrite caseCon = const caseOneAlt >-! caseCon' -- | Specialize a Case-decomposition (replace by the RHS of an alternative) if -- the subject is (an application of) a DataCon; or if there is only a single -- alternative that doesn't reference variables bound by the pattern. -- -- Note [CaseCon deshadow] -- -- Imagine: -- -- @ -- case D (f a b) (g x y) of -- D a b -> h a -- @ -- -- rewriting this to: -- -- @ -- let a = f a b -- in h a -- @ -- -- is very bad because the newly introduced let-binding now captures the free -- variable 'a' in 'f a b'. -- -- instead me must rewrite to: -- -- @ -- let a1 = f a b -- in h a1 -- @ caseCon' :: HasCallStack => NormRewrite caseCon' ctx@(TransformContext is0 _) e@(Case subj ty alts) = do tcm <- Lens.view tcCache case collectArgsTicks subj of -- The subject is an applied data constructor (Data dc, args, ticks) -> case List.find (equalCon . fst) alts of Just (DataPat _ tvs xs, altE) -> do let -- Create the substitution environment for all the existential -- type variables. exTysList = List.zipEqual tvs (drop (length (dcUnivTyVars dc)) (Either.rights args)) exTySubst = extendTvSubstList (mkSubst is0) exTysList -- Apply the type-substitution in all the pattern variables, we need -- to do this because we might use them as let-bindings later on, -- and they should have the correct type. xs1 = fmap (substTyInVar exTySubst) xs -- Create an initial set of let-binders for all variables used in the -- RHS of the alternative. We might later decide to substitute instead -- of let-bind in case the RHS of the let-binder is work-free. fvs = Lens.foldMapOf freeLocalIds unitVarSet altE (binds,_) = List.partition ((`elemVarSet` fvs) . fst) $ List.zipEqual xs1 (Either.lefts args) binds1 = fmap (second (`mkTicks` ticks)) binds altE1 <- case binds1 of [] -> -- Apply the type-substitution for the existential type variables pure (substTm "caseCon'" exTySubst altE) _ -> do -- See Note [CaseCon deshadow] let -- Only let-bind expression that perform work. is1 = extendInScopeSetList (extendInScopeSetList is0 tvs) xs1 ((is3,substIds),binds2) <- List.mapAccumLM newBinder (is1,[]) binds1 let -- Create a substitution for all the existential type variables -- and the work-free expressions subst = mkSubst is3 `extendTvSubstList` exTysList `extendIdSubstList` substIds body = substTm "caseCon'" subst altE case Maybe.catMaybes binds2 of [] -> pure body -- Use listToLets to create a series of non-recursive lets instead -- of a recursive group. We know these binders will not form a group. binds3 -> pure (listToLets binds3 body) changed altE1 _ -> case alts of -- In Core, default patterns always come first, so we match against -- that if there is one, and we couldn't match with any of the data -- patterns. ((DefaultPat,altE):_) -> changed altE _ -> changed (TyApp (Prim NP.undefined) ty) where -- Check whether the pattern matches the data constructor equalCon (DataPat dcPat _ _) = dcTag dc == dcTag dcPat equalCon _ = False -- Decide whether the applied arguments of the data constructor should -- be let-bound, or substituted into the alternative. We decide this -- based on the fact on whether the argument has the potential to make -- the circuit larger than needed if we were to duplicate that argument. newBinder (isN0, substN) (x, arg) = do bndrs <- Lens.use bindings isWorkFree workFreeBinders bndrs arg >>= \case True -> pure ((isN0, (x, arg):substN), Nothing) False -> let x' = uniqAway isN0 x isN1 = extendInScopeSet isN0 x' in pure ((isN1, (x, Var x'):substN), Just (x', arg)) -- The subject is a literal (Literal l,_,_) -> case List.find (equalLit . fst) alts of Just (LitPat _,altE) -> changed altE _ -> matchLiteralContructor e l alts where equalLit (LitPat l') = l == l' equalLit _ = False -- The subject is an applied primitive (Prim _,_,_) -> -- We try to reduce the applied primitive to WHNF whnfRW True ctx subj $ \ctx1 subj1 -> case collectArgsTicks subj1 of -- WHNF of subject is a literal, try `caseCon` with that (Literal l,_,_) -> caseCon ctx1 (Case (Literal l) ty alts) -- WHNF of subject is a data-constructor, try `caseCon` with that (Data _,_,_) -> caseCon ctx1 (Case subj1 ty alts) -- WHNF of subject is _|_, in the form of `error`: that means that the -- entire case-expression is evaluates to _|_ (Prim pInfo,repTy:_:callStack:msg:_,ticks) | primName pInfo == "GHC.Err.error" -> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [repTy,Right ty,callStack,msg] in changed e1 -- 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 `elem` ["Control.Exception.Base.absentError" ,"GHC.Prim.Panic.absentError"] -> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty,msgOrCallStack] in changed e1 -- WHNF of subject is _|_, in the form of `patError`, `undefined`, or -- `errorWithoutStackTrace`: that means the entire case-expression is _|_ (Prim pInfo,repTy:_:msgOrCallStack:_,ticks) | primName pInfo `elem` ["Control.Exception.Base.patError" ,"GHC.Err.undefined" ,"GHC.Err.errorWithoutStackTrace"] -> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [repTy,Right ty,msgOrCallStack] in changed e1 -- WHNF of subject is _|_, in the form of our internal _|_-values: that -- means the entire case-expression is _|_ (Prim pInfo,[_],ticks) | primName pInfo `elem` [ Text.showt 'NP.undefined , Text.showt 'NP.undefinedX ] -> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty] in changed e1 -- WHNF of subject is _|_, in the form of `errorX`: that means that -- the entire case-expression is evaluates to _|_ (Prim pInfo,_:callStack:msg:_,ticks) | primName pInfo == "Clash.XException.errorX" -> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty,callStack,msg] in changed e1 -- WHNF of subject is non of the above, so either a variable reference, -- or a primitive for which the evaluator doesn't have any evaluation -- rules. _ -> do let subjTy = inferCoreTypeOf tcm subj tran <- Lens.view typeTranslator reprs <- Lens.view customReprs case (`evalState` mempty) (coreTypeToHWType tran reprs tcm subjTy) of Right (FilteredHWType (Void (Just hty)) _areVoids) | hty `elem` [BitVector 0, Unsigned 0, Signed 0, Index 1] -- If we know that the type of the subject is zero-bits wide and -- one of the Clash number types. Then the only valid alternative is -- the one that can match on the literal "0", so try 'caseCon' with -- that. -> caseCon ctx1 (Case (Literal (IntegerLiteral 0)) ty alts) _ -> do opts <- Lens.view debugOpts -- When invariants are being checked, report missing evaluation -- rules for the primitive evaluator. traceIf (dbg_invariants opts && isConstant subj) ("Unmatchable constant as case subject: " ++ showPpr subj ++ "\nWHNF is: " ++ showPpr subj1) -- Otherwise check whether the entire case-expression has a -- single alternative, and pick that one. (caseOneAlt e) -- The subject is a variable (Var v, [], _) | isNum0 (coreTypeOf v) -> -- If we know that the type of the subject is zero-bits wide and -- one of the Clash number types. Then the only valid alternative is -- the one that can match on the literal "0", so try 'caseCon' with -- that. caseCon ctx (Case (Literal (IntegerLiteral 0)) ty alts) where isNum0 (tyView -> TyConApp (nameOcc -> tcNm) [arg]) | tcNm `elem` [ Text.showt ''BitVector , Text.showt ''Signed , Text.showt ''Unsigned ] = isLitX 0 arg | tcNm == Text.showt ''Index = isLitX 1 arg isNum0 (coreView1 tcm -> Just t) = isNum0 t isNum0 _ = False isLitX n (LitTy (NumTy m)) = n == m isLitX n (coreView1 tcm -> Just t) = isLitX n t isLitX _ _ = False -- Otherwise check whether the entire case-expression has a single -- alternative, and pick that one. _ -> caseOneAlt e caseCon' _ e = return e {-# SCC caseCon' #-} {- [Note: Name re-creation] The names of heap bound variables are safely generate with mkUniqSystemId in Clash.Core.Evaluator.newLetBinding. But only their uniqs end up in the heap, not the complete names. So we use mkUnsafeSystemName to recreate the same Name. -} matchLiteralContructor :: Term -> Literal -> [Alt] -> NormalizeSession Term matchLiteralContructor c (IntegerLiteral l) alts = go (reverse alts) where go [(DefaultPat,e)] = changed e go ((DataPat dc [] [x],e):alts') | dcTag dc == 1 , l >= ((-2)^(63::Int)) && l < 2^(63::Int) = let fvs = Lens.foldMapOf freeLocalIds unitVarSet e bind = NonRec x (Literal (IntLiteral l)) in if x `elemVarSet` fvs then changed (Let bind e) else changed e | dcTag dc == 2 , l >= 2^(63::Int) #if MIN_VERSION_base(4,15,0) = let !(IP ba) = l #else = let !(Jp# !(BN# ba)) = l #endif ba' = BA.ByteArray ba fvs = Lens.foldMapOf freeLocalIds unitVarSet e bind = NonRec x (Literal (ByteArrayLiteral ba')) in if x `elemVarSet` fvs then changed (Let bind e) else changed e | dcTag dc == 3 , l < ((-2)^(63::Int)) #if MIN_VERSION_base(4,15,0) = let !(IN ba) = l #else = let !(Jn# !(BN# ba)) = l #endif ba' = BA.ByteArray ba fvs = Lens.foldMapOf freeLocalIds unitVarSet e bind = NonRec x (Literal (ByteArrayLiteral ba')) in if x `elemVarSet` fvs then changed (Let bind e) else changed e | otherwise = go alts' go ((LitPat l', e):alts') | IntegerLiteral l == l' = changed e | otherwise = go alts' go _ = error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showPpr c matchLiteralContructor c (NaturalLiteral l) alts = go (reverse alts) where go [(DefaultPat,e)] = changed e go ((DataPat dc [] [x],e):alts') | dcTag dc == 1 , l >= 0 && l < 2^(64::Int) = let fvs = Lens.foldMapOf freeLocalIds unitVarSet e bind = NonRec x (Literal (WordLiteral l)) in if x `elemVarSet` fvs then changed (Let bind e) else changed e | dcTag dc == 2 , l >= 2^(64::Int) #if MIN_VERSION_base(4,15,0) = let !(IP ba) = l #else = let !(Jp# !(BN# ba)) = l #endif ba' = BA.ByteArray ba fvs = Lens.foldMapOf freeLocalIds unitVarSet e bind = NonRec x (Literal (ByteArrayLiteral ba')) in if x `elemVarSet` fvs then changed (Let bind e) else changed e | otherwise = go alts' go ((LitPat l', e):alts') | NaturalLiteral l == l' = changed e | otherwise = go alts' go _ = error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showPpr c matchLiteralContructor _ _ ((DefaultPat,e):_) = changed e matchLiteralContructor c _ _ = error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showPpr c {-# SCC matchLiteralContructor #-} -- | Remove non-reachable alternatives. For example, consider: -- -- data STy ty where -- SInt :: Int -> STy Int -- SBool :: Bool -> STy Bool -- -- f :: STy ty -> ty -- f (SInt b) = b + 1 -- f (SBool True) = False -- f (SBool False) = True -- {-# NOINLINE f #-} -- -- g :: STy Int -> Int -- g = f -- -- @f@ is always specialized on @STy Int@. The SBool alternatives are therefore -- unreachable. Additional information can be found at: -- https://github.com/clash-lang/clash-compiler/pull/465 caseElemNonReachable :: HasCallStack => NormRewrite caseElemNonReachable _ case0@(Case scrut altsTy alts0) = do tcm <- Lens.view tcCache let (altsAbsurd, altsOther) = List.partition (isAbsurdPat tcm . fst) alts0 case altsAbsurd of [] -> return case0 _ -> changed =<< caseOneAlt (Case scrut altsTy altsOther) caseElemNonReachable _ e = return e {-# SCC caseElemNonReachable #-} -- | Flatten ridiculous case-statements generated by GHC -- -- For case-statements in haskell of the form: -- -- @ -- f :: Unsigned 4 -> Unsigned 4 -- f x = case x of -- 0 -> 3 -- 1 -> 2 -- 2 -> 1 -- 3 -> 0 -- @ -- -- GHC generates Core that looks like: -- -- @ -- f = \(x :: Unsigned 4) -> case x == fromInteger 3 of -- False -> case x == fromInteger 2 of -- False -> case x == fromInteger 1 of -- False -> case x == fromInteger 0 of -- False -> error "incomplete case" -- True -> fromInteger 3 -- True -> fromInteger 2 -- True -> fromInteger 1 -- True -> fromInteger 0 -- @ -- -- Which would result in a priority decoder circuit where a normal decoder -- circuit was desired. -- -- This transformation transforms the above Core to the saner: -- -- @ -- f = \(x :: Unsigned 4) -> case x of -- _ -> error "incomplete case" -- 0 -> fromInteger 3 -- 1 -> fromInteger 2 -- 2 -> fromInteger 1 -- 3 -> fromInteger 0 -- @ caseFlat :: HasCallStack => NormRewrite caseFlat (TransformContext is0 _) e@(Case (collectEqArgs -> Just (scrut',val)) ty _) = case collectFlat scrut' e of Just alts' -> case collectArgs val of -- When we're pattern matching on `Int`, extract the `Int#` first before -- we do the Literal matching branches. (Data dc,_) | nameOcc (dcName dc) == "GHC.Types.I#" , [argTy] <- dcArgTys dc -> do wild <- mkInternalVar is0 "wild" argTy changed (Case scrut' ty [(DataPat dc [] [wild] ,Case (Var wild) ty (last alts' : init alts'))]) _ -> changed (Case scrut' ty (last alts' : init alts')) Nothing -> return e caseFlat _ e = return e {-# SCC caseFlat #-} collectFlat :: Term -> Term -> Maybe [Alt] collectFlat scrut (Case (collectEqArgs -> Just (scrut', val)) _ty [lAlt,rAlt]) | scrut' == scrut = case collectArgs val of (Prim p,args') | isFromInt (primName p) -> go (last args') (Data dc,args') | nameOcc (dcName dc) == "GHC.Types.I#" -> go (last args') _ -> Nothing where go (Left (Literal i)) = case (lAlt,rAlt) of ((pl,el),(pr,er)) | isFalseDcPat pl || isTrueDcPat pr -> case collectFlat scrut el of Just alts' -> Just ((LitPat i, er) : alts') Nothing -> Just [(LitPat i, er) ,(DefaultPat, el) ] | otherwise -> case collectFlat scrut er of Just alts' -> Just ((LitPat i, el) : alts') Nothing -> Just [(LitPat i, el) ,(DefaultPat, er) ] go _ = Nothing isFalseDcPat (DataPat p _ _) = ((== "GHC.Types.False") . nameOcc . dcName) p isFalseDcPat _ = False isTrueDcPat (DataPat p _ _) = ((== "GHC.Types.True") . nameOcc . dcName) p isTrueDcPat _ = False collectFlat _ _ = Nothing {-# SCC collectFlat #-} collectEqArgs :: Term -> Maybe (Term,Term) collectEqArgs f@(collectArgsTicks -> (Prim p, args, ticks)) | nm == Text.showt 'BV.eq# = 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# = 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" = 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 collectEqArgs _ = Nothing -- | Lift the let-bindings out of the subject of a Case-decomposition caseLet :: HasCallStack => NormRewrite caseLet (TransformContext is0 _) (Case (collectTicks -> (Let xes e,ticks)) ty alts) = do -- Note [CaseLet deshadow] -- Imagine -- -- @ -- case (let x = u in e) of {p -> a} -- @ -- -- where `a` has a free variable named `x`. -- -- Simply transforming the above to: -- -- @ -- let x = u in case e of {p -> a} -- @ -- -- would be very bad, because now the let-binding captures the free x variable -- in a. -- -- We must therefor rename `x` so that it doesn't capture the free variables -- in the alternative: -- -- @ -- let x1 = u[x:=x1] in case e[x:=x1] of {p -> a} -- @ -- -- It is safe to over-approximate the free variables in `a` by simply taking -- the current InScopeSet. let (xes1,e1) = deshadowLetExpr is0 xes e changed (Let (fmap (`mkTicks` ticks) xes1) (Case (mkTicks e1 ticks) ty alts)) caseLet _ e = return e {-# SCC caseLet #-} caseOneAlt :: Term -> NormalizeSession Term caseOneAlt e@(Case _ _ [(pat,altE)]) = case pat of DefaultPat -> changed altE LitPat _ -> changed altE DataPat _ tvs xs | (coerce tvs ++ coerce xs) `localVarsDoNotOccurIn` altE -> changed altE | otherwise -> return e caseOneAlt (Case _ _ ((pat,alt):alts@(_:_))) | all ((== alt) . snd) alts , (tvs,xs) <- patIds pat , (coerce tvs ++ coerce xs) `localVarsDoNotOccurIn` alt = changed alt caseOneAlt e = return e {-# SCC caseOneAlt #-} -- | Tries to eliminate existentials by using heuristics to determine what the -- existential should be. For example, consider Vec: -- -- data Vec :: Nat -> Type -> Type where -- Nil :: Vec 0 a -- Cons x xs :: a -> Vec n a -> Vec (n + 1) a -- -- Thus, 'null' (annotated with existentials) could look like: -- -- null :: forall n . Vec n Bool -> Bool -- null v = -- case v of -- Nil {n ~ 0} -> True -- Cons {n1:Nat} {n~n1+1} (x :: a) (xs :: Vec n1 a) -> False -- -- When it's applied to a vector of length 5, this becomes: -- -- null :: Vec 5 Bool -> Bool -- null v = -- case v of -- Nil {5 ~ 0} -> True -- Cons {n1:Nat} {5~n1+1} (x :: a) (xs :: Vec n1 a) -> False -- -- This function solves 'n1' and replaces every occurrence with its solution. A -- very limited number of solutions are currently recognized: only adds (such -- as in the example) will be solved. elimExistentials :: HasCallStack => NormRewrite elimExistentials (TransformContext is0 _) (Case scrut altsTy alts0) = do tcm <- Lens.view tcCache alts1 <- traverse (go is0 tcm) alts0 caseOneAlt (Case scrut altsTy alts1) where -- Eliminate free type variables if possible go :: InScopeSet -> TyConMap -> Alt -> NormalizeSession Alt go is2 tcm alt@(pat@(DataPat dc exts0 xs0), term0) = case solveNonAbsurds tcm (mkVarSet exts0) (patEqs tcm pat) of -- No equations solved: [] -> return alt -- One or more equations solved: sols -> changed =<< go is2 tcm (DataPat dc exts1 xs1, term1) where -- Substitute solution in existentials and applied types is3 = extendInScopeSetList is2 exts0 xs1 = fmap (substTyInVar (extendTvSubstList (mkSubst is3) sols)) xs0 exts1 = substInExistentialsList is2 exts0 sols -- Substitute solution in term. is4 = extendInScopeSetList is3 xs1 subst = extendTvSubstList (mkSubst is4) sols term1 = substTm "Replacing tyVar due to solved eq" subst term0 go _ _ alt = return alt elimExistentials _ e = return e {-# SCC elimExistentials #-} clash-lib-1.8.1/src/Clash/Normalize/Transformations/Cast.hs0000644000000000000000000001152307346545000021752 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Normalize.Transformations.Cast ( argCastSpec , caseCast , elimCastCast , letCast , splitCastWork ) where import Control.Exception (throw) import qualified Control.Lens as Lens import Control.Monad.Writer (listen) import qualified Data.Monoid as Monoid (Any(..)) import GHC.Stack (HasCallStack) import Clash.Core.Name (nameOcc) import Clash.Core.Pretty (showPpr) import Clash.Core.Term (LetBinding, Term(..), collectArgs, stripTicks) import Clash.Core.TermInfo (isCast) import Clash.Core.Type (normalizeType) import Clash.Core.Var (isGlobalId, varName) import Clash.Core.VarEnv (InScopeSet) import Clash.Debug (trace) import Clash.Normalize.Transformations.Specialize (specialize) import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Rewrite.Types (TransformContext(..), bindings, curFun, tcCache, workFreeBinders) import Clash.Rewrite.Util (changed, mkDerivedName, mkTmBinderFor) import Clash.Rewrite.WorkFree (isWorkFree) import Clash.Util (ClashException(..), curLoc) -- | Push cast over an argument to a function into that function -- -- This is done by specializing on the casted argument. -- Example: -- @ -- y = f (cast a) -- where f x = g x -- @ -- transforms to: -- @ -- y = f' a -- where f' x' = (\x -> g x) (cast x') -- @ -- -- The reason d'etre for this transformation is that we hope to end up with -- and expression where two casts are "back-to-back" after which we can -- eliminate them in 'eliminateCastCast'. argCastSpec :: HasCallStack => NormRewrite argCastSpec ctx e@(App f (stripTicks -> Cast e' _ _)) -- Don't specialise when the arguments are casts-of-casts, these casts-of-casts -- will be eliminated by 'eliminateCastCast' during the normalization of the -- "current" function. We thus prevent the unnecessary introduction of a -- specialized version of 'f'. | not (isCast e') -- We can only push casts into global binders , (Var g, _) <- collectArgs f , isGlobalId g = do bndrs <- Lens.use bindings isWorkFree workFreeBinders bndrs e' >>= \case True -> go False -> warn go where go = specialize ctx e warn = trace (unwords [ "WARNING:", $(curLoc), "specializing a function on a non work-free" , "cast. Generated HDL implementation might contain duplicate work." , "Please report this as a bug.", "\n\nExpression where this occured:" , "\n\n" ++ showPpr e ]) argCastSpec _ e = return e {-# SCC argCastSpec #-} -- | Push a cast over a case into it's alternatives. caseCast :: HasCallStack => NormRewrite caseCast _ (Cast (stripTicks -> Case subj ty alts) ty1 ty2) = do let alts' = map (\(p,e) -> (p, Cast e ty1 ty2)) alts changed (Case subj ty alts') caseCast _ e = return e {-# SCC caseCast #-} -- | Eliminate two back to back casts where the type going in and coming out are the same -- -- @ -- (cast :: b -> a) $ (cast :: a -> b) x ==> x -- @ elimCastCast :: HasCallStack => NormRewrite elimCastCast _ c@(Cast (stripTicks -> Cast e tyA tyB) tyB' tyC) = do tcm <- Lens.view tcCache let ntyA = normalizeType tcm tyA ntyB = normalizeType tcm tyB ntyB' = normalizeType tcm tyB' ntyC = normalizeType tcm tyC if ntyB == ntyB' && ntyA == ntyC then changed e else throwError where throwError = do (nm,sp) <- Lens.use curFun throw (ClashException sp ($(curLoc) ++ showPpr nm ++ ": Found 2 nested casts whose types don't line up:\n" ++ showPpr c) Nothing) elimCastCast _ e = return e {-# SCC elimCastCast #-} -- | Push a cast over a Let into it's body letCast :: HasCallStack => NormRewrite letCast _ (Cast (stripTicks -> Let binds body) ty1 ty2) = changed $ Let binds (Cast body ty1 ty2) letCast _ e = return e {-# SCC letCast #-} -- | Make a cast work-free by splitting the work of to a separate binding -- -- @ -- let x = cast (f a b) -- ==> -- let x = cast x' -- x' = f a b -- @ splitCastWork :: HasCallStack => NormRewrite splitCastWork ctx@(TransformContext is0 _) unchanged@(Letrec vs e') = do (vss', Monoid.getAny -> hasChanged) <- listen (mapM (splitCastLetBinding is0) vs) let vs' = concat vss' if hasChanged then changed (Letrec vs' e') else return unchanged where splitCastLetBinding :: InScopeSet -> LetBinding -> NormalizeSession [LetBinding] splitCastLetBinding isN x@(nm, e) = case stripTicks e of Cast (Var {}) _ _ -> return [x] -- already work-free Cast (Cast {}) _ _ -> return [x] -- casts will be eliminated Cast e0 ty1 ty2 -> do tcm <- Lens.view tcCache nm' <- mkTmBinderFor isN tcm (mkDerivedName ctx (nameOcc $ varName nm)) e0 changed [(nm',e0) ,(nm, Cast (Var nm') ty1 ty2) ] _ -> return [x] splitCastWork _ e = return e {-# SCC splitCastWork #-} clash-lib-1.8.1/src/Clash/Normalize/Transformations/DEC.hs0000644000000000000000000010043707346545000021456 0ustar0000000000000000{-| Copyright : (C) 2015-2016, University of Twente, 2021-2022, QBayLogic B.V. 2022, LumiGuide Fietsdetectie B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. The 'disjointExpressionConsolidation' transformation lifts applications of global binders out of alternatives of case-statements. e.g. It converts: > case x of > A -> f 3 y > B -> f x x > C -> h x into: > let f_arg0 = case x of {A -> 3; B -> x} > f_arg1 = case x of {A -> y; B -> x} > f_out = f f_arg0 f_arg1 > in case x of > A -> f_out > B -> f_out > C -> h x -} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Normalize.Transformations.DEC ( disjointExpressionConsolidation ) where import Control.Concurrent.Supply (splitSupply) import Control.Lens ((^.), _1) import qualified Control.Lens as Lens import qualified Control.Monad as Monad import Data.Bifunctor (first, second) import Data.Bits ((.&.), complement) import Data.Coerce (coerce) import qualified Data.Either as Either import qualified Data.Foldable as Foldable import qualified Data.Graph as Graph import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet as IntSet import qualified Data.List as List import qualified Data.List.Extra as List import qualified Data.Map.Strict as Map import qualified Data.Maybe as Maybe import Data.Monoid (All(..)) import qualified Data.Text as Text import GHC.Stack (HasCallStack) #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) #endif #if MIN_VERSION_ghc(9,0,0) import GHC.Settings.Constants (mAX_TUPLE_SIZE) #else import Constants (mAX_TUPLE_SIZE) #endif -- internal import Clash.Core.DataCon (DataCon) import Clash.Core.Evaluator.Types (whnf') import Clash.Core.FreeVars (termFreeVars', typeFreeVars', localVarsDoNotOccurIn) import Clash.Core.HasType import Clash.Core.Literal (Literal(..)) import Clash.Core.Name (nameOcc) import Clash.Core.Term ( Alt, LetBinding, Pat(..), PrimInfo(..), Term(..), TickInfo(..) , collectArgs, collectArgsTicks, mkApps, mkTicks, patIds, stripTicks) import Clash.Core.TyCon (TyConMap, TyConName, tyConDataCons) import Clash.Core.Type (Type, TypeView (..), isPolyFunTy, mkTyConApp, splitFunForallTy, tyView) import Clash.Core.Util (mkInternalVar, mkSelectorCase, sccLetBindings) import Clash.Core.Var (isGlobalId, isLocalId, varName) 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.Util (MonadUnique, curLoc) -- | This transformation lifts applications of global binders out of -- alternatives of case-statements. -- -- e.g. It converts: -- -- @ -- case x of -- A -> f 3 y -- B -> f x x -- C -> h x -- @ -- -- into: -- -- @ -- let f_arg0 = case x of {A -> 3; B -> x} -- f_arg1 = case x of {A -> y; B -> x} -- f_out = f f_arg0 f_arg1 -- in case x of -- A -> f_out -- B -> f_out -- C -> h x -- @ disjointExpressionConsolidation :: HasCallStack => NormRewrite disjointExpressionConsolidation ctx@(TransformContext isCtx _) e@(Case _scrut _ty _alts@(_:_:_)) = do -- Collect all (the applications of) global binders (and certain primitives) -- that would be interesting to share out of the case-alternatives. (_,isCollected,collected) <- collectGlobals isCtx [] [] e -- Filter those that are used at most once in every (nested) branch. let disJoint = filter (isDisjoint . snd . snd) collected if null disJoint then return e else do -- For every to-lift expression create (the generalization of): -- -- let fargs = case x of {A -> (3,y); B -> (x,x)} -- in f (fst fargs) (snd fargs) -- -- the let-expression is not created when `f` has only one (selectable) -- argument -- -- NB: mkDisJointGroup needs the context InScopeSet, isCtx, to determine -- whether expressions reference variables from the context, or -- variables inside a let-expression inside one of the alternatives. lifted <- mapM (mkDisjointGroup isCtx) disJoint tcm <- Lens.view tcCache -- Create let-binders for all of the lifted expressions -- -- NB: Because we will be substituting under binders we use the collected -- inScopeSet, isCollected, which also contains all the binders -- created inside all of the alternatives. With this inScopeSet, we -- ensure that the let-bindings we create here won't be accidentally -- captured by binders inside the case-alternatives. (_,funOutIds) <- List.mapAccumLM (mkFunOut tcm) isCollected (zip disJoint lifted) -- Create "substitutions" of the form [f X Y := f_out] let substitution = zip (map fst disJoint) (map Var funOutIds) -- For all of the lifted expression: substitute occurrences of the -- disjoint expressions (f X Y) by a variable reference to the lifted -- expression (f_out) let isCtx1 = extendInScopeSetList isCtx funOutIds lifted1 <- substLifted isCtx1 substitution lifted -- Do the same for the actual case expression (e1,_,_) <- collectGlobals isCtx1 substitution [] e -- Let-bind all the lifted function let lb = Letrec (zip funOutIds lifted1) e1 -- Do an initial dead-code elimination pass, as `mkDisJoint` doesn't -- clean-up unused let-binders. lb1 <- bottomupR deadCode ctx lb changed lb1 where -- Make the let-binder for the lifted expressions mkFunOut tcm isN ((fun,_),(eLifted,_)) = do let ty = inferCoreTypeOf tcm eLifted nm = case collectArgs fun of (Var v,_) -> nameOcc (varName v) (Prim p,_) -> primName p _ -> "complex_expression_" nm1 = last (Text.splitOn "." nm) `Text.append` "Out" nm2 <- mkInternalVar isN nm1 ty return (extendInScopeSet isN nm2,nm2) -- Substitute inside the lifted expressions -- -- In case you are wondering why this function isn't simply -- -- > mapM (\s (eL,seen) -> collectGlobal isN s seen eL) substitution lifted -- -- then that's because we have e.g. the list of "substitutions": -- -- [foo _ _ := foo_out; bar _ _ := bar_out] -- -- and if we were to apply that to a lifted expression, which is going -- to be of the form `foo (case ...) (case ...)` then we would end up -- with let-bindings that are simply: -- -- > let foo_out = foo_out ; bar_out = bar_out -- -- instead of the desired -- -- > let foo_out = foo ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out]) -- > ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out]) -- > bar_out = bar ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out]) -- > ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out]) -- -- So what we do is that for every lifted-expression we make sure that the -- 'substitution' never contains the self-substitution, so we end up with: -- -- > let foo_out = (foo (case ...) (case ...))[bar _ _ := bar_out] -- bar_out = (bar (case ...) (case ...))[foo _ _ := foo_out] -- -- We used to have a different approach, see commit -- 73d237017c4a5fff0c49bb72c9c4d5f6c68faf69 -- -- But that lead to the generation of combinational loops. Now that we no -- longer traverse into recursive groups of let-bindings, the issue #1316 -- that the above commit tried to solve, no longer shows up. substLifted isN substitution lifted = do -- remove the self-substitutions for the respective lifted expressions let subsMatrix = l2m substitution lifted1 <- Monad.zipWithM (\s (eL,seen) -> collectGlobals isN s seen eL) subsMatrix lifted return (map (^. _1) lifted1) l2m = go [] where go _ [] = [] go xs (y:ys) = (xs ++ ys) : go (xs ++ [y]) ys disjointExpressionConsolidation _ e = return e {-# SCC disjointExpressionConsolidation #-} data CaseTree a = Leaf a | LB [LetBinding] (CaseTree a) | Branch Term [(Pat,CaseTree a)] deriving (Eq,Show,Functor,Foldable) -- | Test if a 'CaseTree' collected from an expression indicates that -- application of a global binder is disjoint: occur in separate branches of a -- case-expression. isDisjoint :: CaseTree ([Either Term Type]) -> Bool isDisjoint (Branch _ [_]) = False isDisjoint ct = go ct where go (Leaf _) = False go (LB _ ct') = go ct' go (Branch _ []) = False go (Branch _ [(_,x)]) = go x go b@(Branch _ (_:_:_)) = allEqual (map Either.rights (Foldable.toList b)) -- Remove empty branches from a 'CaseTree' removeEmpty :: Eq a => CaseTree [a] -> CaseTree [a] removeEmpty l@(Leaf _) = l removeEmpty (LB lb ct) = case removeEmpty ct of Leaf [] -> Leaf [] ct' -> LB lb ct' removeEmpty (Branch s bs) = case filter ((/= (Leaf [])) . snd) (map (second removeEmpty) bs) of [] -> Leaf [] bs' -> Branch s bs' -- | Test if all elements in a list are equal to each other. allEqual :: Eq a => [a] -> Bool allEqual [] = True allEqual (x:xs) = all (== x) xs -- | Collect 'CaseTree's for (potentially) disjoint applications of globals out -- of an expression. Also substitute truly disjoint applications of globals by a -- reference to a lifted out application. collectGlobals' :: InScopeSet -> [(Term,Term)] -- ^ Substitution of (applications of) a global binder by a reference to a -- lifted term. -> [Term] -- ^ List of already seen global binders -> Term -- ^ The expression -> Bool -- ^ Whether expression is constant -> NormalizeSession (Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Type]))]) collectGlobals' is0 substitution seen (Case scrut ty alts) _eIsConstant = do rec (alts1, isAlts, collectedAlts) <- collectGlobalsAlts is0 substitution seen scrut1 alts (scrut1, isScrut, collectedScrut) <- collectGlobals is0 substitution (map fst collectedAlts ++ seen) scrut return ( Case scrut1 ty alts1 , unionInScope isAlts isScrut , collectedAlts ++ collectedScrut ) collectGlobals' is0 substitution seen e@(collectArgsTicks -> (fun, args@(_:_), ticks)) eIsconstant | not eIsconstant = do tcm <- Lens.view tcCache bndrs <- Lens.use bindings evaluate <- Lens.view evaluator ids <- Lens.use uniqSupply let (ids1,ids2) = splitSupply ids uniqSupply Lens..= ids2 gh <- Lens.use globalHeap 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 -- Don't lift out non-representable values, because they cannot be let-bound -- in our desired normal form. False -> do -- Look for, and substitute by, disjoint applications of globals in -- the arguments first before considering the current term in function -- position. Doing it in the other order (this term in function position -- first, followed by arguments) resulted in issue #1322 (args1,isArgs,collectedArgs) <- collectGlobalsArgs is0 substitution seen args let seenInArgs = map fst collectedArgs ++ seen isInteresting <- interestingToLift is0 eval fun args ticks case isInteresting of Just fun1 | fun1 `notElem` seenInArgs -> do let e1 = Maybe.fromMaybe (mkApps fun1 args1) (List.lookup fun1 substitution) -- This function is lifted out an environment with the currently 'seen' -- binders. When we later apply substitution, we need to start with this -- environment, otherwise we perform incorrect substitutions in the -- arguments. return (e1,isArgs,(fun1,(seen,Leaf args1)):collectedArgs) _ -> return (mkApps (mkTicks fun ticks) args1, isArgs, collectedArgs) _ -> return (e,is0,[]) -- FIXME: This duplicates A LOT of let-bindings, where I just pray that after -- the ANF, CSE, and DeadCodeRemoval pass all duplicates are removed. -- -- I think we should be able to do better, but perhaps we cannot fix it here. collectGlobals' is0 substitution seen (Letrec lbs body) _eIsConstant = do let is1 = extendInScopeSetList is0 (map fst lbs) (body1,isBody,collectedBody) <- collectGlobals is1 substitution seen body (lbs1,isBndrs,collectedBndrs) <- collectGlobalsLbs is1 substitution (map fst collectedBody ++ seen) lbs return ( Letrec lbs1 body1 , unionInScope isBody isBndrs , map (second (second (LB lbs1))) (collectedBody ++ collectedBndrs) ) collectGlobals' is0 substitution seen (Tick t e) eIsConstant = do (e1,is1,collected) <- collectGlobals' is0 substitution seen e eIsConstant return (Tick t e1, is1, collected) collectGlobals' is0 _ _ e _ = return (e,is0,[]) -- | Collect 'CaseTree's for (potentially) disjoint applications of globals out -- of an expression. Also substitute truly disjoint applications of globals by a -- reference to a lifted out application. collectGlobals :: InScopeSet -> [(Term,Term)] -- ^ Substitution of (applications of) a global binder by a reference to -- a lifted term. -> [Term] -- ^ List of already seen global binders -> Term -- ^ The expression -> NormalizeSession (Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Type]))]) collectGlobals inScope substitution seen e = collectGlobals' inScope substitution seen e (isConstant e) -- | Collect 'CaseTree's for (potentially) disjoint applications of globals out -- of a list of application arguments. Also substitute truly disjoint -- applications of globals by a reference to a lifted out application. collectGlobalsArgs :: InScopeSet -> [(Term,Term)] -- ^ Substitution of (applications of) a global -- binder by a reference to a lifted term. -> [Term] -- ^ List of already seen global binders -> [Either Term Type] -- ^ The list of arguments -> NormalizeSession ( [Either Term Type] , InScopeSet , [(Term, ([Term], CaseTree [(Either Term Type)]))] ) collectGlobalsArgs is0 substitution seen args = do ((is1,_),(args',collected)) <- second unzip <$> List.mapAccumLM go (is0,seen) args return (args',is1,concat collected) where go (isN0,s) (Left tm) = do (tm',isN1,collected) <- collectGlobals isN0 substitution s tm return ((isN1,map fst collected ++ s),(Left tm',collected)) go (isN,s) (Right ty) = return ((isN,s),(Right ty,[])) -- | Collect 'CaseTree's for (potentially) disjoint applications of globals out -- of a list of alternatives. Also substitute truly disjoint applications of -- globals by a reference to a lifted out application. collectGlobalsAlts :: InScopeSet -> [(Term,Term)] -- ^ Substitution of (applications of) a global -- binder by a reference to a lifted term. -> [Term] -- ^ List of already seen global binders -> Term -- ^ The subject term -> [Alt] -- ^ The list of alternatives -> NormalizeSession ( [Alt] , InScopeSet , [(Term, ([Term], CaseTree [(Either Term Type)]))] ) collectGlobalsAlts is0 substitution seen scrut alts = do (is1,(alts',collected)) <- second unzip <$> List.mapAccumLM go is0 alts let collectedM = map (Map.fromList . map (second (second (:[])))) collected collectedUN = Map.unionsWith (\(l1,r1) (l2,r2) -> (List.nub (l1 ++ l2),r1 ++ r2)) collectedM collected' = map (second (second (Branch scrut))) (Map.toList collectedUN) return (alts',is1,collected') where go isN0 (p,e) = do let isN1 = extendInScopeSetList isN0 (snd (patIds p)) (e',isN2,collected) <- collectGlobals isN1 substitution seen e return (isN2,((p,e'),map (second (second (p,))) collected)) -- | Collect 'CaseTree's for (potentially) disjoint applications of globals out -- of a list of let-bindings. Also substitute truly disjoint applications of -- globals by a reference to a lifted out application. collectGlobalsLbs :: InScopeSet -> [(Term,Term)] -- ^ Substitution of (applications of) a global -- binder by a reference to a lifted term. -> [Term] -- ^ List of already seen global binders -> [LetBinding] -- ^ The list let-bindings -> NormalizeSession ( [LetBinding] , InScopeSet , [(Term, ([Term], CaseTree [(Either Term Type)]))] ) collectGlobalsLbs is0 substitution seen lbs = do let lbsSCCs = sccLetBindings lbs ((is1,_),(lbsSCCs1,collected)) <- second unzip <$> List.mapAccumLM go (is0,seen) lbsSCCs return (Graph.flattenSCCs lbsSCCs1,is1,concat collected) where go :: (InScopeSet,[Term]) -> Graph.SCC LetBinding -> NormalizeSession ( (InScopeSet, [Term]) , ( Graph.SCC LetBinding , [(Term, ([Term], CaseTree [(Either Term Type)]))] ) ) go (isN0,s) (Graph.AcyclicSCC (id_, e)) = do (e',isN1,collected) <- collectGlobals isN0 substitution s e return ((isN1,map fst collected ++ s),(Graph.AcyclicSCC (id_,e'),collected)) -- TODO: This completely skips recursive let-bindings in the collection of -- potentially disjoint applications of globals; and skips substituting truly -- disjoint applications of globals by a reference to a lifted out application. -- -- This is to prevent the creation of combinational loops that have occurred -- "in the wild", but for which we have not been able to a create small -- unit test that triggers this creation-of-combinational-loops bug. -- Completely skipping recursive let-bindings is taking the hammer to -- solving this bug, without knowing whether a scalpel even existed and what -- it might look like. We should at some point think hard how traversing -- recursive let-bindings can introduce combinational loops, and whether -- there exists a solution that can traverse recursive let-bindings, -- finding more opportunities for DEC, while not introducing combinational -- loops. go acc scc@(Graph.CyclicSCC {}) = return (acc,(scc,[])) -- | Given a case-tree corresponding to a disjoint interesting \"term-in-a- -- function-position\", return a let-expression: where the let-binding holds -- a case-expression selecting between the distinct arguments of the case-tree, -- and the body is an application of the term applied to the shared arguments of -- the case tree, and projections of let-binding corresponding to the distinct -- argument positions. mkDisjointGroup :: InScopeSet -- ^ Variables in scope at the very top of the case-tree, i.e., the original -- expression -> (Term,([Term],CaseTree [(Either Term Type)])) -- ^ Case-tree of arguments belonging to the applied term. -> NormalizeSession (Term,[Term]) mkDisjointGroup inScope (fun,(seen,cs)) = do tcm <- Lens.view tcCache let argss = Foldable.toList cs argssT = zip [0..] (List.transpose argss) (sharedT,distinctT) = List.partition (areShared tcm inScope . fmap (first stripTicks) . snd) argssT -- 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 $ fmap (Either.lefts . map snd) (if null shared then cs' else fmap (filter (`notElem` shared)) cs') (distinctCaseM,distinctProjections) <- case distinct of -- only shared arguments: do nothing. [] -> return (Nothing,[]) -- Create selectors and projections (uc:_) -> do let argTys = map (inferCoreTypeOf tcm) uc disJointSelProj inScope argTys cs'' let newArgs = mkDJArgs 0 shared distinctProjections case distinctCaseM of Just lb -> return (Letrec [lb] (mkApps fun newArgs), seen) Nothing -> return (mkApps fun newArgs, seen) -- | Create a single selector for all the representable distinct arguments by -- selecting between tuples. This selector is only ('Just') created when the -- number of representable uncommmon arguments is larger than one, otherwise it -- is not ('Nothing'). -- -- It also returns: -- -- * For all the non-representable distinct arguments: a selector -- * For all the representable distinct arguments: a projection out of the tuple -- created by the larger selector. If this larger selector does not exist, a -- single selector is created for the single representable distinct argument. disJointSelProj :: InScopeSet -> [Type] -- ^ Types of the arguments -> CaseTree [Term] -- The case-tree of arguments -> NormalizeSession (Maybe LetBinding,[Term]) disJointSelProj _ _ (Leaf []) = return (Nothing,[]) disJointSelProj inScope argTys cs = do tcm <- Lens.view tcCache tupTcm <- Lens.view tupleTcCache let maxIndex = length argTys - 1 css = map (\i -> fmap ((:[]) . (!!i)) cs) [0..maxIndex] (untran,tran) <- List.partitionM (isUntranslatableType False . snd) (zip [0..] argTys) let untranCs = map (css!!) (map fst untran) untranSels = zipWith (\(_,ty) cs' -> genCase tcm tupTcm ty [ty] cs') untran untranCs (lbM,projs) <- case tran of [] -> return (Nothing,[]) [(i,ty)] -> return (Nothing,[genCase tcm tupTcm ty [ty] (css!!i)]) tys -> do let m = length tys (tyIxs,tys') = unzip tys tupTy = mkBigTupTy tcm tupTcm tys' cs' = fmap (\es -> map (es !!) tyIxs) cs djCase = genCase tcm tupTcm tupTy tys' cs' scrutId <- mkInternalVar inScope "tupIn" tupTy projections <- mapM (mkBigTupSelector inScope tcm tupTcm (Var scrutId) tys') [0..m-1] return (Just (scrutId,djCase),projections) let selProjs = tranOrUnTran 0 (zip (map fst untran) untranSels) projs return (lbM,selProjs) where tranOrUnTran _ [] projs = projs tranOrUnTran _ sels [] = map snd sels tranOrUnTran n ((ut,s):uts) (p:projs) | n == ut = s : tranOrUnTran (n+1) uts (p:projs) | otherwise = p : tranOrUnTran (n+1) ((ut,s):uts) projs -- | Arguments are shared between invocations if: -- -- * They contain _no_ references to locally-bound variables -- * Are either: -- 1. All equal -- 2. A proof of an equality: we don't care about the shape of a proof. -- -- Whether we have `Refl : True ~ True` or `SomeAxiom : (1 <=? 2) ~ True` -- it doesn't matter, since when we normalize both sides we always end -- up with a proof of `True ~ True`. -- Since DEC only fires for applications where all the type arguments -- are equal, we can deduce that all equality arguments witness the same -- equality, hence we don't have to care about the shape of the proof. areShared :: TyConMap -> InScopeSet -> [Either Term Type] -> Bool areShared _ _ [] = True areShared tcm inScope xs@(x:_) = noFV1 && (isProof x || allEqual xs) where noFV1 = case x of Right ty -> getAll (Lens.foldMapOf (typeFreeVars' isLocallyBound IntSet.empty) (const (All False)) ty) Left tm -> getAll (Lens.foldMapOf (termFreeVars' isLocallyBound) (const (All False)) tm) isLocallyBound v = isLocalId v && v `notElemInScopeSet` inScope isProof (Left co) = case tyView (inferCoreTypeOf tcm co) of TyConApp (nameOcc -> "GHC.Types.~") _ -> True _ -> False isProof _ = False -- | Create a list of arguments given a map of positions to common arguments, -- and a list of arguments mkDJArgs :: Int -- ^ Current position -> [(Int,Either Term Type)] -- ^ map from position to common argument -> [Term] -- ^ (projections for) distinct arguments -> [Either Term Type] mkDJArgs _ cms [] = map snd cms mkDJArgs _ [] uncms = map Left uncms mkDJArgs n ((m,x):cms) (y:uncms) | n == m = x : mkDJArgs (n+1) cms (y:uncms) | otherwise = Left y : mkDJArgs (n+1) ((m,x):cms) uncms -- | Create a case-expression that selects between the distinct arguments given -- a case-tree genCase :: TyConMap -> IntMap TyConName -> Type -- ^ Type of the alternatives -> [Type] -- ^ Types of the arguments -> CaseTree [Term] -- ^ CaseTree of arguments -> Term genCase tcm tupTcm ty argTys = go where go (Leaf tms) = mkBigTupTm tcm tupTcm (List.zipEqual argTys tms) go (LB lb ct) = Letrec lb (go ct) go (Branch scrut [(p,ct)]) = let ct' = go ct (ptvs,pids) = patIds p in if (coerce ptvs ++ coerce pids) `localVarsDoNotOccurIn` ct' then ct' else Case scrut ty [(p,ct')] go (Branch scrut pats) = Case scrut ty (map (second go) pats) -- | Lookup the TyConName and DataCon for a tuple of size n findTup :: TyConMap -> IntMap TyConName -> Int -> (TyConName,DataCon) 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 mkSmallTup,mkBigTup :: TyConMap -> IntMap TyConName -> [(Type,Term)] -> (Type,Term) mkSmallTup _ _ [] = error $ $curLoc ++ "mkSmallTup: Can't create 0-tuple" mkSmallTup _ _ [(ty,tm)] = (ty,tm) mkSmallTup tcm tupTcm args = (ty,tm) where (argTys,tms) = unzip args (tupTcNm,tupDc) = findTup tcm tupTcm (length args) tm = mkApps (Data tupDc) (map Right argTys ++ map Left tms) ty = mkTyConApp tupTcNm argTys mkBigTup tcm tupTcm = mkChunkified (mkSmallTup tcm tupTcm) mkSmallTupTy,mkBigTupTy :: TyConMap -> IntMap TyConName -> [Type] -> Type mkSmallTupTy _ _ [] = error $ $curLoc ++ "mkSmallTupTy: Can't create 0-tuple" mkSmallTupTy _ _ [ty] = ty mkSmallTupTy tcm tupTcm tys = mkTyConApp tupTcNm tys where m = length tys (tupTcNm,_) = findTup tcm tupTcm m mkBigTupTy tcm tupTcm = mkChunkified (mkSmallTupTy tcm tupTcm) mkSmallTupSelector,mkBigTupSelector :: MonadUnique m => InScopeSet -> TyConMap -> IntMap TyConName -> Term -> [Type] -> Int -> m Term mkSmallTupSelector _ _ _ scrut [_] 0 = return scrut mkSmallTupSelector _ _ _ _ [_] n = error $ $curLoc ++ "mkSmallTupSelector called with one type, but to select " ++ show n mkSmallTupSelector inScope tcm _ scrut _ n = mkSelectorCase ($curLoc ++ "mkSmallTupSelector") inScope tcm scrut 1 n mkBigTupSelector inScope tcm tupTcm scrut tys n = go (chunkify tys) where go [_] = mkSmallTupSelector inScope tcm tupTcm scrut tys n go tyss = do let (nOuter,nInner) = divMod n mAX_TUPLE_SIZE tyss' = map (mkSmallTupTy tcm tupTcm) tyss outer <- mkSmallTupSelector inScope tcm tupTcm scrut tyss' nOuter inner <- mkSmallTupSelector inScope tcm tupTcm outer (tyss List.!! nOuter) nInner return inner -- | Determine if a term in a function position is interesting to lift out of -- of a case-expression. -- -- This holds for all global functions, and certain primitives. Currently those -- primitives are: -- -- * All non-power-of-two multiplications -- * All division-like operations with a non-power-of-two divisor interestingToLift :: InScopeSet -- ^ in scope -> (Term -> Term) -- ^ Evaluator -> Term -- ^ Term in function position -> [Either Term Type] -- ^ Arguments -> [TickInfo] -- ^ Tick annoations -> RewriteMonad extra (Maybe Term) interestingToLift inScope _ e@(Var v) _ ticks = if NoDeDup `notElem` ticks && (isGlobalId v || v `elemInScopeSet` inScope) then pure (Just e) else pure Nothing interestingToLift inScope eval e@(Prim pInfo) args ticks | NoDeDup `notElem` ticks = do let anyArgNotConstant = any (not . isConstant) lArgs case List.lookup (primName pInfo) interestingPrims of Just t | t || anyArgNotConstant -> pure (Just e) _ | DeDup `elem` ticks -> pure (Just e) _ -> do let isInteresting = (\(x, y, z) -> interestingToLift inScope eval x y z) . collectArgsTicks if isHOTy (coreTypeOf pInfo) then do anyInteresting <- List.anyM (fmap Maybe.isJust . isInteresting) lArgs if anyInteresting then pure (Just e) else pure Nothing else pure Nothing where interestingPrims = [("Clash.Sized.Internal.BitVector.*#",tailNonPow2) ,("Clash.Sized.Internal.BitVector.times#",tailNonPow2) ,("Clash.Sized.Internal.BitVector.quot#",lastNotPow2) ,("Clash.Sized.Internal.BitVector.rem#",lastNotPow2) ,("Clash.Sized.Internal.Index.*#",tailNonPow2) ,("Clash.Sized.Internal.Index.quot#",lastNotPow2) ,("Clash.Sized.Internal.Index.rem#",lastNotPow2) ,("Clash.Sized.Internal.Signed.*#",tailNonPow2) ,("Clash.Sized.Internal.Signed.times#",tailNonPow2) ,("Clash.Sized.Internal.Signed.rem#",lastNotPow2) ,("Clash.Sized.Internal.Signed.quot#",lastNotPow2) ,("Clash.Sized.Internal.Signed.div#",lastNotPow2) ,("Clash.Sized.Internal.Signed.mod#",lastNotPow2) ,("Clash.Sized.Internal.Unsigned.*#",tailNonPow2) ,("Clash.Sized.Internal.Unsigned.times#",tailNonPow2) ,("Clash.Sized.Internal.Unsigned.quot#",lastNotPow2) ,("Clash.Sized.Internal.Unsigned.rem#",lastNotPow2) ,("GHC.Base.quotInt",lastNotPow2) ,("GHC.Base.remInt",lastNotPow2) ,("GHC.Base.divInt",lastNotPow2) ,("GHC.Base.modInt",lastNotPow2) ,("GHC.Classes.divInt#",lastNotPow2) ,("GHC.Classes.modInt#",lastNotPow2) #if MIN_VERSION_base(4,15,0) ,("GHC.Num.Integer.integerMul",allNonPow2) ,("GHC.Num.Integer.integerDiv",lastNotPow2) ,("GHC.Num.Integer.integerMod",lastNotPow2) ,("GHC.Num.Integer.integerQuot",lastNotPow2) ,("GHC.Num.Integer.integerRem",lastNotPow2) #else ,("GHC.Integer.Type.timesInteger",allNonPow2) ,("GHC.Integer.Type.divInteger",lastNotPow2) ,("GHC.Integer.Type.modInteger",lastNotPow2) ,("GHC.Integer.Type.quotInteger",lastNotPow2) ,("GHC.Integer.Type.remInteger",lastNotPow2) #endif ,("GHC.Prim.*#",allNonPow2) ,("GHC.Prim.quotInt#",lastNotPow2) ,("GHC.Prim.remInt#",lastNotPow2) ] lArgs = Either.lefts args allNonPow2 = all (not . termIsPow2) lArgs tailNonPow2 = case lArgs of [] -> True _ -> all (not . termIsPow2) (drop 1 lArgs) lastNotPow2 = case lArgs of [] -> True _ -> not (termIsPow2 (last lArgs)) termIsPow2 e' = case eval e' of Literal (IntegerLiteral n) -> isPow2 n a -> case collectArgs a of (Prim p,[Right _,Left _,Left (Literal (IntegerLiteral n))]) | isFromInteger (primName p) -> isPow2 n (Prim p,[Right _,Left _,Left _,Left (Literal (IntegerLiteral n))]) | primName p == "Clash.Sized.Internal.BitVector.fromInteger#" -> isPow2 n (Prim p,[Right _, Left _,Left (Literal (IntegerLiteral n))]) | primName p == "Clash.Sized.Internal.BitVector.fromInteger##" -> isPow2 n _ -> False isPow2 x = x /= 0 && (x .&. (complement x + 1)) == x isFromInteger x = x `elem` ["Clash.Sized.Internal.BitVector.fromInteger#" ,"Clash.Sized.Integer.Index.fromInteger" ,"Clash.Sized.Internal.Signed.fromInteger#" ,"Clash.Sized.Internal.Unsigned.fromInteger#" ] isHOTy t = case splitFunForallTy t of (args',_) -> any isPolyFunTy (Either.rights args') interestingToLift _ _ _ _ _ = pure Nothing clash-lib-1.8.1/src/Clash/Normalize/Transformations/EtaExpand.hs0000644000000000000000000000710107346545000022726 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., 2021 , QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. The eta-expansion transformation. -} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Normalize.Transformations.EtaExpand ( etaExpandSyn , etaExpansionTL ) where import qualified Control.Lens as Lens import qualified Data.Maybe as Maybe import GHC.Stack (HasCallStack) import Clash.Core.HasType import Clash.Core.Term (Bind(..), CoreContext(..), Term(..), collectArgs, mkLams) import Clash.Core.TermInfo (isFun) import Clash.Core.Type (splitFunTy) import Clash.Core.Util (mkInternalVar) import Clash.Core.Var (Id) import Clash.Core.VarEnv (elemVarSet, extendInScopeSet, extendInScopeSetList) import Clash.Normalize.Types (NormRewrite) import Clash.Rewrite.Types (TransformContext(..), tcCache, topEntities) import Clash.Rewrite.Util (changed) import Clash.Util (curLoc) -- | Eta-expand functions with a Synthesize annotation, needed to allow such -- functions to appear as arguments to higher-order primitives. etaExpandSyn :: HasCallStack => NormRewrite etaExpandSyn (TransformContext is0 ctx) e@(collectArgs -> (Var f, _)) = do topEnts <- Lens.view topEntities tcm <- Lens.view tcCache let isTopEnt = f `elemVarSet` topEnts isAppFunCtx = \case AppFun:_ -> True TickC _:c -> isAppFunCtx c _ -> False argTyM = fmap fst (splitFunTy tcm (inferCoreTypeOf tcm e)) case argTyM of Just argTy | isTopEnt && not (isAppFunCtx ctx) -> do newId <- mkInternalVar is0 "arg" argTy changed (Lam newId (App e (Var newId))) _ -> return e etaExpandSyn _ e = return e {-# SCC etaExpandSyn #-} stripLambda :: Term -> ([Id], Term) stripLambda (Lam bndr e) = let (bndrs, e') = stripLambda e in (bndr : bndrs, e') stripLambda e = ([], e) -- | Eta-expand top-level lambda's (DON'T use in a traversal!) etaExpansionTL :: HasCallStack => NormRewrite etaExpansionTL (TransformContext is0 ctx) (Lam bndr e) = do let ctx' = TransformContext (extendInScopeSet is0 bndr) (LamBody bndr : ctx) e' <- etaExpansionTL ctx' e return $ Lam bndr e' etaExpansionTL (TransformContext is0 ctx) (Let (NonRec i x) e) = do let ctx' = TransformContext (extendInScopeSet is0 i) (LetBody [(i,x)] : ctx) e' <- etaExpansionTL ctx' e case stripLambda e' of (bs@(_:_),e2) -> do let e3 = Let (NonRec i x) e2 changed (mkLams e3 bs) _ -> return (Let (NonRec i x) e') etaExpansionTL (TransformContext is0 ctx) (Let (Rec xes) e) = do let bndrs = map fst xes ctx' = TransformContext (extendInScopeSetList is0 bndrs) (LetBody xes : ctx) e' <- etaExpansionTL ctx' e case stripLambda e' of (bs@(_:_),e2) -> do let e3 = Let (Rec xes) e2 changed (mkLams e3 bs) _ -> return (Let (Rec xes) e') etaExpansionTL (TransformContext is0 ctx) e = do tcm <- Lens.view tcCache if isFun tcm e then do let argTy = ( fst . Maybe.fromMaybe (error $ $(curLoc) ++ "etaExpansion splitFunTy") . splitFunTy tcm . inferCoreTypeOf tcm ) e newId <- mkInternalVar is0 "arg" argTy let ctx' = TransformContext (extendInScopeSet is0 newId) (LamBody newId : ctx) e' <- etaExpansionTL ctx' (App e (Var newId)) changed (Lam newId e') else return e {-# SCC etaExpansionTL #-} clash-lib-1.8.1/src/Clash/Normalize/Transformations/Inline.hs0000644000000000000000000006531707346545000022310 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2022, Google Inc., 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Transformations for inlining -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Normalize.Transformations.Inline ( bindConstantVar , inlineBndrsCleanup , inlineCast , inlineCleanup , collapseRHSNoops , inlineNonRep , inlineOrLiftNonRep , inlineSimIO , inlineSmall , inlineWorkFree ) where 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 Data.Default (Default(..)) import Data.Either (lefts) import qualified Data.HashMap.Lazy as HashMap import qualified Data.List as List import qualified Data.Maybe as Maybe import qualified Data.Monoid as Monoid (Any(..)) import qualified Data.Text as Text import qualified Data.Text.Extra as Text import GHC.Stack (HasCallStack) import GHC.BasicTypes.Extra (isNoInline) import qualified Clash.Explicit.SimIO as SimIO import qualified Clash.Sized.Internal.BitVector as BV (Bit(Bit), BitVector(BV)) import Clash.Annotations.Primitive (extractPrim) import Clash.Core.DataCon (DataCon(..)) import Clash.Core.FreeVars (countFreeOccurances, freeLocalIds) import Clash.Core.HasFreeVars import Clash.Core.HasType import Clash.Core.Name (Name(..), NameSort(..)) import Clash.Core.Pretty (PrettyOptions(..), showPpr, showPpr') import Clash.Core.Subst import Clash.Core.Term ( CoreContext(..), Pat(..), PrimInfo(..), Term(..), WorkInfo(..), collectArgs , collectArgsTicks, mkApps , mkTicks, stripTicks) import Clash.Core.TermInfo (isLocalVar, termSize) import Clash.Core.Type (TypeView(..), isClassTy, isPolyFunCoreTy, tyView) import Clash.Core.Util (isSignalType, primUCo) import Clash.Core.Var (Id, Var(..), isGlobalId, isLocalId) import Clash.Core.VarEnv ( InScopeSet, VarEnv, VarSet, elemUniqInScopeSet, elemVarEnv, elemVarSet , eltsVarEnv, emptyVarEnv, extendInScopeSetList, extendVarEnv , foldlWithUniqueVarEnv', lookupVarEnv, lookupVarEnvDirectly, mkVarEnv , notElemVarSet, unionVarEnv, unionVarEnvWith, unitVarSet) import Clash.Debug (trace) import Clash.Driver.Types (Binding(..)) import Clash.Netlist.Util (representableType) import Clash.Primitives.Types (CompiledPrimMap, Primitive(..), TemplateKind(..)) import Clash.Rewrite.Combinators (allR) import Clash.Rewrite.Types ( TransformContext(..), bindings, curFun, customReprs, tcCache, topEntities , typeTranslator, inlineConstantLimit, inlineFunctionLimit, inlineLimit , inlineWFCacheLimit, primitives) import Clash.Rewrite.Util ( changed, inlineBinders, inlineOrLiftBinders, isJoinPointIn , isUntranslatable, isUntranslatableType, isVoidWrapper, zoomExtra) import Clash.Rewrite.WorkFree (isWorkFreeIsh) import Clash.Normalize.Types ( NormRewrite, NormalizeSession) import Clash.Normalize.Util ( addNewInline, alreadyInlined, isRecursiveBndr, mkInlineTick , normalizeTopLvlBndr) import Clash.Unique (Unique) import Clash.Util (curLoc) import qualified Clash.Util.Interpolate as I {- [Note] join points and void wrappers Join points are functions that only occur in tail-call positions within an expression, and only when they occur in a tail-call position more than once. Normally bindNonRep binds/inlines all non-recursive local functions. However, doing so for join points would significantly increase compilation time, so we avoid it. The only exception to this rule are so-called void wrappers. Void wrappers are functions of the form: > \(w :: Void) -> f a b c i.e. a wrapper around the function 'f' where the argument 'w' is not used. We do bind/line these join-points because these void-wrappers interfere with the 'disjoint expression consolidation' (DEC) and 'common sub-expression elimination' (CSE) transformation, sometimes resulting in circuits that are twice as big as they'd need to be. -} -- | Inline let-bindings when the RHS is either a local variable reference or -- is constant (except clock or reset generators) bindConstantVar :: HasCallStack => NormRewrite bindConstantVar = inlineBinders test where test _ (i,stripTicks -> e) = case isLocalVar e of -- Don't inline `let x = x in x`, it throws us in an infinite loop True -> return (i `notElemFreeVars` e) _ -> do tcm <- Lens.view tcCache case isWorkFreeIsh tcm e of True -> Lens.view inlineConstantLimit >>= \case 0 -> return True n -> return (termSize e <= n) _ -> return False {-# SCC bindConstantVar #-} -- | Mark to track progress of 'reduceBindersCleanup' data Mark = Temp | Done | Rec -- | Used (transitively) by 'inlineCleanup' inline to-inline let-binders into -- the other to-inline let-binders. reduceBindersCleanup :: HasCallStack => InScopeSet -- ^ Current InScopeSet -> VarEnv ((Id,Term),VarEnv Int) -- ^ Original let-binders with their free variables (+ #occurrences) -> (Maybe Subst,VarEnv Int,VarEnv ((Id,Term),VarEnv Int,Mark)) -- ^ Accumulated: -- -- 1. (Maybe) the build up substitution so far -- 2. The free variables of the range of the substitution -- 3. Processed let-binders with their free variables and a tag to mark -- the progress: -- * Temp: Will eventually form a recursive cycle -- * Done: Processed, non-recursive -- * Rec: Processed, recursive -> Unique -- ^ The unique of the let-binding that we want to simplify -> Int -- ^ Ignore, artifact of 'foldlWithUniqueVarEnv' -> (Maybe Subst,VarEnv Int,VarEnv ((Id,Term),VarEnv Int,Mark)) -- ^ Same as the third argument reduceBindersCleanup isN origInl (!substM,!substFVs,!doneInl) u _ = case lookupVarEnvDirectly u doneInl of Nothing -> case lookupVarEnvDirectly u origInl of Nothing -> -- let-binding not found, cannot extend the substitution if elemUniqInScopeSet u isN then (substM,substFVs,doneInl) else error [I.i| Internal error: 'reduceBindersCleanup' encountered a variable reference that was neither in 'doneInl', 'origInl', or in the transformation's in scope set. Unique was: '#{u}'. |] Just ((v,e),eFVs) -> -- Simplify the transitive dependencies let (sM,substFVsE,doneInl1) = foldlWithUniqueVarEnv' (reduceBindersCleanup isN origInl) ( Nothing -- It's okay/needed to over-approximate the free variables of -- the range of the new substitution by including the free -- variables of the original let-binder, because this set of -- free variables is only used to check whether let-binding will -- become self-recursive after applying the substitution. -- -- That is, it was already self-recursive, or becomes -- self-recursive after applying the substitution because it was -- part of a recursive group. And we do not want to inline -- recursive binders. , eFVs -- Temporarily extend the processing environment with the -- let-binding so we don't end up in a loop in case there is a -- recursive group. , extendVarEnv v ((v,e),eFVs,Temp) doneInl) eFVs e1 = maybeSubstTm "reduceBindersCleanup" sM e in if v `elemVarEnv` substFVsE then -- We cannot inline recursive let-bindings, so we do not extend -- the substitution environment. ( substM , substFVs -- And we explicitly mark the let-binding as recursive in the -- processing environment. So that it will be kept around at the -- end of 'inlineCleanup' , extendVarEnv v ((v,e1),substFVsE,Rec) doneInl1 ) else -- Extend the substitution ( Just (extendIdSubst (Maybe.fromMaybe (mkSubst isN) substM) v e1) , unionVarEnv substFVsE substFVs -- Mark the let-binding a fully "reduced", so we don't repeat -- this process when we encounter it again. , extendVarEnv v ((v,e1),substFVsE,Done) doneInl1 ) -- It's already been processed, just extend the substitution environment Just ((v,e),eFVs,Done) -> ( Just (extendIdSubst (Maybe.fromMaybe (mkSubst isN) substM) v e) , unionVarEnv eFVs substFVs , doneInl ) -- It's either recursive (Rec), or part of a recursive group (Temp) where we -- originally entered a different part of the cycle. Regardless, we do not -- extend the substitution environment. Just _ -> ( substM , substFVs , doneInl ) {-# SCC reduceBindersCleanup #-} -- | Used by 'inlineCleanup' to inline binders that we want to inline into the -- binders that we want to keep. inlineBndrsCleanup :: HasCallStack => InScopeSet -- ^ Current InScopeSet -> VarEnv ((Id,Term),VarEnv Int) -- ^ Original let-binders with their free variables (+ #occurrences), that we -- want to inline -> VarEnv ((Id,Term),VarEnv Int,Mark) -- ^ Processed let-binders with their free variables and a tag to mark the -- progress: -- * Temp: Will eventually form a recursive cycle -- * Done: Processed, non-recursive -- * Rec: Processed, recursive -> [((Id,Term),VarEnv Int)] -- ^ The let-binders with their free variables (+ #occurrences), that we want -- to keep -> [(Id,Term)] inlineBndrsCleanup isN origInl = go where go doneInl [] = -- If some of the let-binders that we wanted to inline turn out to be -- recursive, then we have to keep those around as well, as we weren't able -- to inline them. Furthermore, for every recursive binder there might still -- be non-inlined variables left, see #1337. flip map [ (ve, eFvs) | (ve,eFvs,Rec) <- eltsVarEnv doneInl ] $ \((v, e), eFvs) -> let (substM, _, _) = foldlWithUniqueVarEnv' (reduceBindersCleanup isN emptyVarEnv) (Nothing, emptyVarEnv, doneInl) eFvs in (v, maybeSubstTm "inlineBndrsCleanup_0" substM e) go !doneInl_0 (((v,e),eFVs):il) = let (sM,_,doneInl_1) = foldlWithUniqueVarEnv' (reduceBindersCleanup isN origInl) (Nothing, emptyVarEnv, doneInl_0) eFVs e1 = maybeSubstTm "inlineBndrsCleanup_1" sM e in (v,e1):go doneInl_1 il {-# SCC inlineBndrsCleanup #-} -- | Only inline casts that just contain a 'Var', because these are guaranteed work-free. -- These are the result of the 'splitCastWork' transformation. inlineCast :: HasCallStack => NormRewrite inlineCast = inlineBinders test where test _ (_, (Cast (stripTicks -> Var {}) _ _)) = return True test _ _ = return False {-# SCC inlineCast #-} -- | Given a function in the desired normal form, inline all the following -- let-bindings: -- -- Let-bindings with an internal name that is only used once, where it binds: -- * a primitive that will be translated to an HDL expression (as opposed to -- a HDL declaration) -- * a projection case-expression (1 alternative) -- * a data constructor -- * I/O actions inlineCleanup :: HasCallStack => NormRewrite inlineCleanup (TransformContext is0 _) (Letrec binds body) = do prims <- Lens.view primitives -- For all let-bindings, count the number of times they are referenced. -- We only inline let-bindings which are referenced only once, otherwise -- we would lose sharing. let is1 = extendInScopeSetList is0 (map fst binds) bindsFvs = map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds allOccs = List.foldl' (unionVarEnvWith (+)) emptyVarEnv $ map (snd.snd) bindsFvs bodyFVs = Lens.foldMapOf freeLocalIds unitVarSet body (il,keep) = List.partition (isInteresting allOccs prims bodyFVs) bindsFvs keep' = inlineBndrsCleanup is1 (mkVarEnv il) emptyVarEnv $ map snd keep if | null il -> return (Letrec binds body) | null keep' -> changed body | otherwise -> changed (Letrec keep' body) where -- Determine whether a let-binding is interesting to inline isInteresting :: VarEnv Int -> CompiledPrimMap -> VarSet -> (Id,((Id, Term), VarEnv Int)) -> Bool isInteresting allOccs prims bodyFVs (id_,((_,(fst.collectArgs) -> tm),_)) -- Try to keep user defined names, but inline names generated by GHC or -- Clash. For example, if a user were to write: -- -- x = 2 * y -- -- Even if 'x' is only used once, we'd like to keep it around to produce -- more readable HDL. In contrast, if a user were to write: -- -- let x = f (2 * y) -- -- ANF would transform that to: -- -- let x = f f_arg; f_arg = 2 * y -- -- In that case, there's no harm in inlining f_arg. | nameSort (varName id_) /= User , id_ `notElemVarSet` bodyFVs = case tm of Prim pInfo | let nm = primName pInfo , Just (extractPrim -> Just p@(BlackBox {})) <- HashMap.lookup nm prims , TExpr <- kind p , Just occ <- lookupVarEnv id_ allOccs , occ < 2 -> True | otherwise -> primName pInfo `elem` ["Clash.Explicit.SimIO.bindSimIO#"] Case _ _ [_] -> True Data _ -> True Case _ aTy (_:_:_) | TyConApp nm _ <- tyView aTy , nameOcc nm == Text.showt ''SimIO.SimIO -> True _ -> False | id_ `notElemVarSet` bodyFVs = case tm of Prim pInfo | primName pInfo `elem` [ Text.showt 'SimIO.openFile , Text.showt 'SimIO.getChar , Text.showt 'SimIO.isEOF ] , Just occ <- lookupVarEnv id_ allOccs , occ < 2 -> True | otherwise -> primName pInfo `elem` ["Clash.Explicit.SimIO.bindSimIO#"] Case _ _ [(DataPat dcE _ _,_)] -> let nm = (nameOcc (dcName dcE)) in -- Inlines WW projection that exposes internals of the BitVector types nm == Text.showt 'BV.BV || nm == Text.showt 'BV.Bit || -- Inlines projections out of constraint-tuples (e.g. HiddenClockReset) "GHC.Classes" `Text.isPrefixOf` nm Case _ aTy (_:_:_) | TyConApp nm _ <- tyView aTy , nameOcc nm == Text.showt ''SimIO.SimIO -> True _ -> False isInteresting _ _ _ _ = False inlineCleanup _ e = return e {-# SCC inlineCleanup #-} {- [Note] relation `collapseRHSNoops` and `inlineCleanup` The `collapseRHSNoops` transformation replaces functions/primitives that are the identity in HDL, but not in Haskell, by `unsafeCoerce`. `inlineCleanup` subsequently inlines these `unsafeCoerce` calls. The end result of all of this is that we get no/fewer assignments in HDL where the RHS is simply a variable reference. See issue #779 -} -- | Takes a binding and collapses its term if it is a noop collapseRHSNoops :: HasCallStack => NormRewrite collapseRHSNoops _ (Letrec binds body) = do binds1 <- mapM runCollapseNoop binds return $ Letrec binds1 body where runCollapseNoop orig = runMaybeT (collapseNoop orig) >>= Maybe.maybe (return orig) changed collapseNoop (iD,term) = do (Prim info,args) <- return $ collectArgs term identity <- getIdentity info $ lefts args collapsed <- collapseToIdentity iD identity return (iD,collapsed) collapseToIdentity iD identity = do tcm <- Lens.view tcCache let aTy = inferCoreTypeOf tcm identity bTy = coreTypeOf iD return $ primUCo `TyApp` aTy `TyApp` bTy `App` identity getIdentity primInfo termArgs = do WorkIdentity idIdx noopIdxs <- return $ primWorkInfo primInfo mapM_ (getTermArg termArgs >=> isNoop >=> Monad.guard) noopIdxs getTermArg termArgs idIdx getTermArg args i = do Monad.guard $ i <= length args - 1 return $ args !! i isNoop (Var i) = do binding <- MaybeT $ lookupVarEnv i <$> Lens.use bindings isRecursive <- lift $ isRecursiveBndr $ bindingId binding Monad.guard $ not isRecursive isNoop $ bindingTerm binding isNoop (Prim PrimInfo{primWorkInfo=WorkIdentity _ []}) = return True isNoop (Lam x e) = isNoopApp x (collectArgs e) isNoop _ = return False -- Check whether we have a term of the form: -- -- primX a (primY b (primZ c (... x ...)))) -- -- Where primX, primY and primZ are either: -- -- 1. xToBV, or -- 2. Primitives that are the identity on their argument -- -- And that the variable 'x' is used by the last primitive in the chain. isNoopApp x (Var y,[]) = return (x == y) isNoopApp x (Prim PrimInfo{primWorkInfo=WorkIdentity i []},args) = do arg <- getTermArg (lefts args) i isNoopApp x (collectArgs arg) isNoopApp x (Prim PrimInfo{primName="Clash.Class.BitPack.Internal.xToBV"},args) = do -- We don't make 'xToBV' something of 'WorkIdentity 1 []' because we don't -- want 'getIdentity' to replace "naked" occurances of 'xToBV' by -- 'unsafeCoerce#'. We don't want that since 'xToBV' has a special evaluator -- rule that can translate XExceptions to 'undefined# :: BitVector n'. arg@(App {}) <- getTermArg (lefts args) 1 isNoopApp x (collectArgs arg) isNoopApp _ _ = return False collapseRHSNoops _ e = return e {-# SCC collapseRHSNoops #-} -- | Inline function with a non-representable result if it's the subject -- of a Case-decomposition. It's a custom topdown traversal that -for efficiency -- reasons- does not explore alternative of cases whose subject triggered an -- 'inlineNonRepWorker'. inlineNonRep :: HasCallStack => NormRewrite inlineNonRep ctx0 e0@(Case {}) = do r <- listen (inlineNonRepWorker e0) case r of (e1, Monoid.getAny -> True) -> return e1 (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) listen (inlineNonRep ctx2 subj0) >>= \case (subj1, Monoid.getAny -> True) -> return (Case subj1 typ alts) (subj1, _) -> do let (pats, rhss0) = unzip alts rhss1 <- mapM (inlineNonRep ctx2) rhss0 pure (Case subj1 typ (zip pats rhss1)) inlineNonRep ctx e = -- All non-case statements are simply traversed. TODO: are there other special -- cases like 'Case' that would warrant an optimization like ^ ? allR inlineNonRep ctx e {-# SCC inlineNonRep #-} -- | Inline function with a non-representable result if it's the subject -- of a Case-decomposition. This worker function only tries the given term -- (i.e., it does not traverse it). -- -- It sets the changed flag in the NormalizeSession if it successfully inlines -- a binder. inlineNonRepWorker :: HasCallStack => Term -> NormalizeSession Term inlineNonRepWorker e@(Case scrut altsTy alts) | (Var f, args,ticks) <- collectArgsTicks scrut , isGlobalId f = do (cf,_) <- Lens.use curFun isInlined <- zoomExtra (alreadyInlined f cf) limit <- Lens.view inlineLimit tcm <- Lens.view tcCache let scrutTy = inferCoreTypeOf tcm scrut -- Constraint dictionary inlining always terminates, so we ignore the -- usual inline safeguards. notClassTy = not (isClassTy tcm scrutTy) overLimit = notClassTy && (Maybe.fromMaybe 0 isInlined) > limit bodyMaybe <- lookupVarEnv f <$> Lens.use bindings nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view customReprs <*> pure False <*> Lens.view tcCache <*> pure scrutTy) case (nonRepScrut, bodyMaybe) of (True, Just b) -> do if overLimit then trace ($(curLoc) ++ [I.i| InlineNonRep: #{showPpr (varName f)} already inlined #{limit} times in: #{showPpr (varName cf)}. The type of the subject is: #{showPpr' def{displayTypes=True\} scrutTy} Function #{showPpr (varName cf)} will not reach a normal form and compilation might fail. Run with '-fclash-inline-limit=N' to increase the inline limit to N. |]) (return e) else do Monad.when notClassTy (zoomExtra (addNewInline f cf)) let scrutBody0 = mkTicks (bindingTerm b) (mkInlineTick f : ticks) let scrutBody1 = mkApps scrutBody0 args changed $ Case scrutBody1 altsTy alts _ -> return e inlineNonRepWorker e = pure e {-# SCC inlineNonRepWorker #-} inlineOrLiftNonRep :: HasCallStack => NormRewrite inlineOrLiftNonRep ctx eLet@(Letrec _ body) = inlineOrLiftBinders nonRepTest inlineTest ctx eLet where bodyFreeOccs = countFreeOccurances body nonRepTest :: (Id, Term) -> NormalizeSession Bool nonRepTest (Id {varType = ty}, _) = not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view customReprs <*> pure False <*> Lens.view tcCache <*> pure ty) nonRepTest _ = return False inlineTest :: Term -> (Id, Term) -> Bool inlineTest e (id_, e') = -- We do __NOT__ inline: not $ or [ -- 1. recursive let-binders -- id_ `elemFreeVars` e' -- <= already checked in inlineOrLiftBinders -- 2. join points (which are not void-wrappers) isJoinPointIn id_ e && not (isVoidWrapper e') -- 3. binders that are used more than once in the body, because -- it makes CSE a whole lot more difficult. -- -- XXX: Check whether we can extend this to the binders as well , maybe False (>1) (lookupVarEnv id_ bodyFreeOccs) ] inlineOrLiftNonRep _ e = return e {-# SCC inlineOrLiftNonRep #-} -- | Inline anything of type `SimIO`: IO actions cannot be shared inlineSimIO :: HasCallStack => NormRewrite inlineSimIO = inlineBinders test where test _ (i,_) = case tyView (coreTypeOf i) of TyConApp tc _ -> return $! nameOcc tc == Text.showt ''SimIO.SimIO _ -> return False {-# SCC inlineSimIO #-} -- | Inline small functions inlineSmall :: HasCallStack => NormRewrite inlineSmall _ e@(collectArgsTicks -> (Var f,args,ticks)) = do untranslatable <- isUntranslatable True e topEnts <- Lens.view topEntities let lv = isLocalId f if untranslatable || f `elemVarSet` topEnts || lv then return e else do bndrs <- Lens.use bindings sizeLimit <- Lens.view inlineFunctionLimit case lookupVarEnv f bndrs of -- Don't inline recursive expressions Just b -> do isRecBndr <- isRecursiveBndr f 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 else return e _ -> return e inlineSmall _ e = return e {-# SCC inlineSmall #-} -- | Inline work-free functions, i.e. fully applied functions that evaluate to -- a constant inlineWorkFree :: HasCallStack => NormRewrite inlineWorkFree _ e@(collectArgsTicks -> (Var f,args@(_:_),ticks)) = do tcm <- Lens.view tcCache let eTy = inferCoreTypeOf tcm e argsHaveWork <- or <$> mapM (either expressionHasWork (const (pure False))) args untranslatable <- isUntranslatableType True eTy topEnts <- Lens.view topEntities let isSignal = isSignalType tcm eTy let lv = isLocalId f let isTopEnt = elemVarSet f topEnts if untranslatable || isSignal || argsHaveWork || lv || isTopEnt then return e else do bndrs <- Lens.use bindings case lookupVarEnv f bndrs of -- Don't inline recursive expressions Just b -> do isRecBndr <- isRecursiveBndr f if isRecBndr then return e else do let tm = mkTicks (bindingTerm b) (mkInlineTick f : ticks) changed $ mkApps tm args _ -> return e where -- an expression is has work when it contains free local variables, -- or has a Signal type, i.e. it does not evaluate to a work-free -- constant. expressionHasWork e' = do let fvIds = Lens.toListOf freeLocalIds e' tcm <- Lens.view tcCache let e'Ty = inferCoreTypeOf tcm e' isSignal = isSignalType tcm e'Ty return (not (null fvIds) || isSignal) inlineWorkFree _ e@(Var f) = do tcm <- Lens.view tcCache let fTy = coreTypeOf f closed = not (isPolyFunCoreTy tcm fTy) isSignal = isSignalType tcm fTy untranslatable <- isUntranslatableType True fTy topEnts <- Lens.view topEntities let gv = isGlobalId f if closed && f `notElemVarSet` topEnts && not untranslatable && not isSignal && gv then do bndrs <- Lens.use bindings case lookupVarEnv f bndrs of -- Don't inline recursive expressions Just top -> do isRecBndr <- isRecursiveBndr f if isRecBndr then return e else do let topB = bindingTerm top sizeLimit <- Lens.view inlineWFCacheLimit -- caching only worth it from a certain size onwards, otherwise -- the caching mechanism itself brings more of an overhead. if termSize topB < sizeLimit then changed topB else do b <- normalizeTopLvlBndr False f top changed (bindingTerm b) _ -> return e else return e inlineWorkFree _ e = return e {-# SCC inlineWorkFree #-} clash-lib-1.8.1/src/Clash/Normalize/Transformations/Letrec.hs0000644000000000000000000004526207346545000022305 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Transformations on letrec expressions. -} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-} module Clash.Normalize.Transformations.Letrec ( deadCode , flattenLet , recToLetRec , removeUnusedExpr , simpleCSE , topLet ) where import qualified Control.Lens as Lens import qualified Control.Monad as Monad import Control.Monad.Trans.Except (runExcept) import Control.Monad.Writer (listen) import Data.Bifunctor (second) import qualified Data.Either as Either import qualified Data.HashMap.Lazy as HashMap 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 import GHC.Stack (HasCallStack) import Clash.Annotations.BitRepresentation.Deriving (dontApplyInHDL) import Clash.Sized.Vector as Vec (Vec(Cons), splitAt) import Clash.Annotations.Primitive (extractPrim) import Clash.Core.DataCon (DataCon(..)) import Clash.Core.FreeVars (freeLocalIds) import Clash.Core.HasFreeVars import Clash.Core.HasType import Clash.Core.Name (mkUnsafeSystemName, nameOcc) import Clash.Core.Subst import Clash.Core.Term ( LetBinding, Pat(..), PrimInfo(..), Term(..), collectArgs, collectArgsTicks , collectTicks, isLambdaBodyCtx, isTickCtx, mkApps, mkLams, mkTicks, Bind(..) , partitionTicks, stripAllTicks) import Clash.Core.TermInfo (isCon, isLet, isLocalVar, isTick) import Clash.Core.TyCon (tyConDataCons) import Clash.Core.Type (Type(..), TypeView(..), normalizeType , splitFunForallTy, tyView) import Clash.Core.Util (inverseTopSortLetBindings, mkVec, tyNatSize) import Clash.Core.Var (isGlobalId) 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) import Clash.Normalize.Primitives (removedArg) import Clash.Normalize.Transformations.Reduce (reduceBinders) import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Primitives.Types (Primitive(..), UsedArguments(..)) import Clash.Rewrite.Types (TransformContext(..), bindings, curFun, tcCache, workFreeBinders, primitives) import Clash.Rewrite.Util (changed, isFromInt, isUntranslatable, mkTmBinderFor, removeUnusedBinders, setChanged) import Clash.Rewrite.WorkFree {- [Note: Name re-creation] The names of heap bound variables are safely generate with mkUniqSystemId in Clash.Core.Evaluator.newLetBinding. But only their uniqs end up in the heap, not the complete names. So we use mkUnsafeSystemName to recreate the same Name. -} -- | Remove unused let-bindings deadCode :: HasCallStack => NormRewrite deadCode _ e@(Let binds body) = case removeUnusedBinders binds body of Just t -> changed t Nothing -> return e deadCode _ e = return e {-# SCC deadCode #-} removeUnusedExpr :: HasCallStack => NormRewrite removeUnusedExpr _ e@(collectArgsTicks -> (p@(Prim pInfo),args,ticks)) = do bbM <- HashMap.lookup (primName pInfo) <$> Lens.view primitives let usedArgs0 = case Monad.join (extractPrim <$> bbM) of Just (BlackBoxHaskell{usedArguments}) -> case usedArguments of UsedArguments used -> Just used IgnoredArguments ignored -> Just ([0..length args - 1] \\ ignored) Just (BlackBox pNm _ _ _ _ _ _ _ _ _ inc r ri templ) -> Just $ if | isFromInt pNm -> [0,1,2] | primName pInfo `elem` [ Text.showt 'dontApplyInHDL , Text.showt 'Vec.splitAt ] -> [0,1] | otherwise -> concat [ concatMap getUsedArguments r , concatMap getUsedArguments ri , getUsedArguments templ , concatMap (getUsedArguments . snd) inc ] _ -> Nothing case usedArgs0 of Nothing -> return e Just usedArgs1 -> do tcm <- Lens.view tcCache (args1, Monoid.getAny -> hasChanged) <- listen (go tcm 0 usedArgs1 args) if hasChanged then return (mkApps (mkTicks p ticks) args1) else return e where arity = length . Either.rights . fst $ splitFunForallTy (coreTypeOf pInfo) go _ _ _ [] = return [] go tcm !n used (Right ty:args') = do args'' <- go tcm n used args' return (Right ty : args'') go tcm !n used (Left tm : args') = do args'' <- go tcm (n+1) used args' case tm of TyApp (Prim p0) _ | primName p0 == Text.showt 'removedArg -> return (Left tm : args'') _ -> do let ty = inferCoreTypeOf tcm tm p' = TyApp (Prim removedArg) ty if n < arity && n `notElem` used then changed (Left p' : args'') else return (Left tm : args'') removeUnusedExpr _ e@(Case _ _ [(DataPat _ [] xs,altExpr)]) = if mkVarSet xs `disjointFreeVars` altExpr then changed altExpr else return e -- Replace any expression that creates a Vector of size 0 within the application -- of the Cons constructor, by the Nil constructor. removeUnusedExpr _ e@(collectArgsTicks -> (Data dc, [_,Right aTy,Right nTy,_,Left a,Left nil],ticks)) | nameOcc (dcName dc) == Text.showt 'Vec.Cons = do tcm <- Lens.view tcCache case runExcept (tyNatSize tcm nTy) of Right 0 | (con, _) <- collectArgs nil , not (isCon con) -> let eTy = inferCoreTypeOf tcm e 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 removeUnusedExpr _ e = return e {-# SCC removeUnusedExpr #-} -- | Flatten's letrecs after `inlineCleanup` -- -- `inlineCleanup` sometimes exposes additional possibilities for `caseCon`, -- which then introduces let-bindings in what should be ANF. This transformation -- flattens those nested let-bindings again. -- -- NB: must only be called in the cleaning up phase. flattenLet :: HasCallStack => NormRewrite 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) 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) bodyOccs = Lens.foldMapByOf freeLocalIds (unionVarEnvWith (+)) emptyVarEnv (`unitVarEnv` (1 :: Int)) body (is2,binds1) <- second concat <$> List.mapAccumLM go is1 binds bndrs <- Lens.use bindings e1WorkFree <- case binds1 of [(_,e1)] -> isWorkFree workFreeBinders bndrs e1 _ -> pure (error "flattenLet: unreachable") case binds1 of -- inline binders into the body when there's only a single binder, and only -- if that binder doesn't perform any work or is only used once in the body [(id1,e1)] | Just occ <- lookupVarEnv id1 bodyOccs, e1WorkFree || occ < 2 -> if id1 `elemFreeVars` e1 -- Except when the binder is recursive! then return (Letrec binds1 body) else let subst = extendIdSubst (mkSubst is2) id1 e1 in changed (substTm "flattenLet" subst body) _ -> return (Letrec binds1 body) where go :: InScopeSet -> LetBinding -> NormalizeSession (InScopeSet,[LetBinding]) go isN (id1,collectTicks -> (Letrec binds1 body1,ticks)) = do let bs1 = map fst binds1 let (binds2,body2,isN1) = -- We need to deshadow because we're merging nested let-expressions -- into a single let-expression: and within a let-expression, the -- bindings are not allowed to shadow each-other. Of course, we -- only need to deshadow if any shadowing is happening in the -- first place. -- -- 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 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 freeLocalIds (unionVarEnvWith (+)) emptyVarEnv (`unitVarEnv` (1 :: Int)) body2 (srcTicks,nmTicks) = partitionTicks ticks bndrs <- Lens.use bindings e2WorkFree <- case binds2 of [(_,e2)] -> isWorkFree workFreeBinders bndrs e2 _ -> pure (error "flattenLet: unreachable") -- Distribute the name ticks of the let-expression over all the bindings (isN1,) . map (second (`mkTicks` nmTicks)) <$> case binds2 of -- inline binders into the body when there's only a single binder, and -- only if that binder doesn't perform any work or is only used once in -- the body [(id2,e2)] | Just occ <- lookupVarEnv id2 bodyOccs, e2WorkFree || occ < 2 -> if id2 `elemFreeVars` e2 -- Except when the binder is recursive! then changed ([(id2,e2),(id1, body2)]) else let subst = extendIdSubst (mkSubst isN1) id2 e2 in changed [(id1 -- Only apply srcTicks to the body ,mkTicks (substTm "flattenLetGo" subst body2) srcTicks)] bs -> changed (bs ++ [(id1 -- Only apply srcTicks to the body ,mkTicks body2 srcTicks)]) go isN b = return (isN,[b]) flattenLet _ e = return e {-# SCC flattenLet #-} -- | Turn a normalized recursive function, where the recursive calls only pass -- along the unchanged original arguments, into let-recursive function. This -- means that all recursive calls are replaced by the same variable reference as -- found in the body of the top-level let-expression. recToLetRec :: HasCallStack => NormRewrite recToLetRec (TransformContext is0 []) e = do (fn,_) <- Lens.use curFun tcm <- Lens.view tcCache case splitNormalized tcm e of Right (args,bndrs,res) -> do let args' = map Var args (toInline,others) = List.partition (eqApp tcm fn args' . snd) bndrs resV = Var res case (toInline,others) of (_:_,_:_) -> do let is1 = extendInScopeSetList is0 (args ++ map fst bndrs) let substsInline = extendIdSubstList (mkSubst is1) $ map (second (const resV)) toInline others' = map (second (substTm "recToLetRec" substsInline)) others changed $ mkLams (Letrec others' resV) args _ -> return e _ -> return e where -- This checks whether things are semantically equal. For example, say we -- have: -- -- x :: (a, (b, c)) -- -- and -- -- y :: (a, (b, c)) -- -- If we can determine that 'y' is constructed solely using the -- corresponding fields in 'x', then we can say they are semantically -- equal. The algorithm below keeps track of what (sub)field it is -- constructing, and checks if the field-expression projects the -- corresponding (sub)field from the target variable. -- -- TODO: See [Note: Breaks on constants and predetermined equality] -- -- Since 'aeqTerm' now looks at ticks when determining equality, it is -- required that all ticks are removed with 'stripAllTicks' to keep the -- previous behaviour of this function. If we remove this, most terms will -- not be identified as equal. eqApp tcm v args (collectArgs . stripAllTicks -> (Var v',args')) | isGlobalId v' , v == v' , let args2 = Either.lefts args' , length args == length args2 = and (zipWith (eqArg tcm) args args2) eqApp _ _ _ _ = False eqArg _ v1 v2@Var{} = v1 == v2 eqArg tcm v1 v2@(collectArgs -> (Data _, args')) | let t1 = normalizeType tcm (inferCoreTypeOf tcm v1) , let t2 = normalizeType tcm (inferCoreTypeOf tcm v2) , t1 == t2 = if isClassConstraint t1 then -- Class constraints are equal if their types are equal, so we can -- take a shortcut here. True else -- Check whether all arguments to the data constructor are projections -- and (zipWith (eqDat v1) (map pure [0..]) (Either.lefts args')) eqArg _ _ _ = False -- Recursively check whether a term /e/ is semantically equal to some variable /v/. -- Currently it can only assert equality when /e/ is syntactically equal -- to /v/, or is constructed out of projections of /v/, importantly: -- -- [Note: Breaks on constants and predetermined equality] -- This function currently breaks if: -- -- * One or more subfields are constants. Constants might have been -- inlined for the construction, instead of being a projection of the -- target variable. -- -- * One or more subfields are determined to be equal and one is simply -- swapped / replaced by the other. For example, say we have -- `x :: (a, a)`. If GHC determines that both elements of the tuple will -- always be the same, it might replace the (semantically equal to 'x') -- construction of `y` with `(fst x, fst x)`. -- eqDat :: Term -> [Int] -> Term -> Bool eqDat v fTrace (collectArgs -> (Data _, args)) = and (zipWith (eqDat v) (map (:fTrace) [0..]) (Either.lefts args)) eqDat v1 fTrace v2 = case stripProjection (reverse fTrace) v1 v2 of Just [] -> True _ -> False stripProjection :: [Int] -> Term -> Term -> Maybe [Int] stripProjection fTrace0 vTarget0 (Case v _ [(DataPat _ _ xs, r)]) = do -- Get projection made in subject of case: fTrace1 <- stripProjection fTrace0 vTarget0 v -- Extract projection of this case statement. Subsequent calls to -- 'stripProjection' will check if new target is actually used. (n, fTrace2) <- List.uncons fTrace1 vTarget1 <- List.indexMaybe xs n stripProjection fTrace2 (Var vTarget1) r stripProjection fTrace (Var sTarget) (Var s) = if sTarget == s then Just fTrace else Nothing stripProjection _fTrace _vTarget _v = Nothing recToLetRec _ e = return e {-# SCC recToLetRec #-} isClassConstraint :: Type -> Bool isClassConstraint (tyView -> TyConApp nm0 _) = if -- Constraint tuple: | "GHC.Classes.(%" `Text.isInfixOf` nm1 -> True -- Constraint class: | "C:" `Text.isInfixOf` nm2 -> True | otherwise -> False where nm1 = nameOcc nm0 nm2 = snd (Text.breakOnEnd "." nm1) isClassConstraint _ = False -- | Simplified CSE, only works on let-bindings, does an inverse topological -- sort of the let-bindings and then works from top to bottom -- -- XXX: Check whether inverse top-sort followed by single traversal removes as -- many binders as the previous "apply-until-fixpoint" approach in the presence -- of recursive groups in the let-bindings. If not but just for checking whether -- changes to transformation affect the eventual size of the circuit, it would -- be really helpful if we tracked circuit size in the regression/test suite. -- 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 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 -- doing a substitution over the the binders as well is that I don't know in -- what order a recursive group shows up in a inverse topological sort. -- Depending on the order and forgetting to apply the substitution over the -- let-bindings might lead to the introduction of free variables. -- -- NB: don't apply the substitution to the entire let-expression, and that -- would rename the let-bindings because they've been added to the InScopeSet -- of the substitution. if Monoid.getAny change then let bndrs2 = map (second (substTm "simpleCSE.bndrs" subst)) bndrs1 body1 = substTm "simpleCSE.body" subst body in changed (Letrec bndrs2 body1) else return term simpleCSE _ e = return e {-# SCC simpleCSE #-} -- | Ensure that top-level lambda's eventually bind a let-expression of which -- the body is a variable-reference. topLet :: HasCallStack => NormRewrite topLet (TransformContext is0 ctx) e | all (\c -> isLambdaBodyCtx c || isTickCtx c) ctx && not (isLet e) && not (isTick e) = do untranslatable <- isUntranslatable False e if untranslatable then return e else do tcm <- Lens.view tcCache argId <- mkTmBinderFor is0 tcm (mkUnsafeSystemName "result" 0) e changed (Let (NonRec argId e) (Var argId)) topLet (TransformContext is0 ctx) e@(Letrec binds body) | all (\c -> isLambdaBodyCtx c || isTickCtx c) ctx = do let localVar = isLocalVar body untranslatable <- isUntranslatable False body if localVar || untranslatable then return e else do tcm <- Lens.view tcCache let is2 = extendInScopeSetList is0 (fmap fst binds) argId <- mkTmBinderFor is2 tcm (mkUnsafeSystemName "result" 0) body -- TODO We would like this to be -- -- Let binds (Let (NonRec argId body) (Var argId)) -- -- but this makes tests/shouldwork/SimIO/Test00.hs fail. changed (Letrec (binds ++ [(argId, body)]) (Var argId)) topLet _ e = return e {-# SCC topLet #-} clash-lib-1.8.1/src/Clash/Normalize/Transformations/MultiPrim.hs0000644000000000000000000001104607346545000023002 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc. 2022 , QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Transformations on primitives with multiple results. -} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Normalize.Transformations.MultiPrim ( setupMultiResultPrim ) where import qualified Control.Lens as Lens import qualified Data.Either as Either import Data.Text.Extra (showt) import GHC.Stack (HasCallStack) import Clash.Annotations.Primitive (extractPrim) import Clash.Core.Name (mkUnsafeInternalName) import Clash.Core.Term ( IsMultiPrim(..), MultiPrimInfo(..), PrimInfo(..), Term(..), WorkInfo(..) , mkAbstraction, mkApps, mkTmApps, mkTyApps, PrimUnfolding(..)) import Clash.Core.TermInfo (multiPrimInfo') import Clash.Core.TyCon (TyConMap) import Clash.Core.Type (Type(..), mkPolyFunTy, splitFunForallTy) import Clash.Core.Util (listToLets) import Clash.Core.Var (mkLocalId) import Clash.Normalize.Types (NormRewrite) import Clash.Primitives.Types (Primitive(..)) import Clash.Rewrite.Types (tcCache, primitives) import Clash.Rewrite.Util (changed) -- Note [MultiResult type] -- -- A multi result primitive assigns its results to multiple result variables -- instead of one. Besides producing nicer HDL it works around issues with -- synthesis tooling described in: -- -- https://github.com/clash-lang/clash-compiler/issues/1555 -- -- This transformation rewrites primitives indicating they can assign their -- results to multiple signals, such that netlist can easily render it. This -- involves inserting additional arguments for each of the result values, and -- then using the c$multiPrimSelect primitive to select individual results. -- -- Example: -- -- @ -- prim :: forall a b c. a -> (b, c) -- @ -- -- will be rewritten to: -- -- @ -- \(x :: a) -> -- let -- r = prim @a @b @c x r0 r1 -- With 'Clash.Core.Term.MultiPrim' -- r0 = c$multiPrimSelect r0 r -- r1 = c$multiPrimSelect r1 r -- in -- (r0, r1) -- @ -- -- Netlist will not render any @multiPrimSelect@ primitives. Similar to -- primitives having a /void/ return type, /r/ is not rendered either. -- -- This transformation is currently hardcoded to recognize tuples as return -- types, not any product type. It will error if it sees a multi result primitive -- with a non-tuple return type. -- setupMultiResultPrim :: HasCallStack => NormRewrite setupMultiResultPrim _ctx e@(Prim pInfo@PrimInfo{primMultiResult=SingleResult}) = do tcm <- Lens.view tcCache prim <- Lens.view (primitives . Lens.at (primName pInfo)) case prim >>= extractPrim of Just (BlackBoxHaskell{multiResult=True}) -> changed (setupMultiResultPrim' tcm pInfo) Just (BlackBox{multiResult=True}) -> changed (setupMultiResultPrim' tcm pInfo) _ -> return e setupMultiResultPrim _ e = return e setupMultiResultPrim' :: HasCallStack => TyConMap -> PrimInfo -> Term setupMultiResultPrim' tcm primInfo@PrimInfo{primType} = mkAbstraction letTerm (map Right typeVars <> map Left argIds) where typeVars = Either.lefts pArgs internalNm prefix n = mkUnsafeInternalName (prefix <> showt n) n internalId prefix typ n = mkLocalId typ (internalNm prefix n) nTermArgs = length (Either.rights pArgs) argIds = zipWith (internalId "a") (Either.rights pArgs) [1..nTermArgs] resIds = zipWith (internalId "r") resTypes [nTermArgs+1..nTermArgs+length resTypes] resId = mkLocalId pResTy (mkUnsafeInternalName "r" (nTermArgs+length resTypes+1)) (pArgs, pResTy) = splitFunForallTy primType MultiPrimInfo{mpi_resultDc=tupTc, mpi_resultTypes=resTypes} = multiPrimInfo' tcm primInfo multiPrimSelect r t = (r, mkTmApps (Prim (multiPrimSelectInfo t)) [Var r, Var resId]) multiPrimSelectBinds = zipWith multiPrimSelect resIds resTypes multiPrimTermArgs = map (Left . Var) (argIds <> resIds) multiPrimTypeArgs = map (Right . VarTy) typeVars multiPrimBind = mkApps (Prim primInfo{primMultiResult=MultiResult}) (multiPrimTypeArgs <> multiPrimTermArgs) multiPrimSelectInfo t = PrimInfo { primName = "c$multiPrimSelect" , primType = mkPolyFunTy pResTy [Right pResTy, Right t] , primWorkInfo = WorkAlways , primMultiResult = SingleResult , primUnfolding = NoUnfolding } letTerm = listToLets ((resId,multiPrimBind):multiPrimSelectBinds) (mkTmApps (mkTyApps (Data tupTc) resTypes) (map Var resIds)) clash-lib-1.8.1/src/Clash/Normalize/Transformations/Reduce.hs0000644000000000000000000006267107346545000022301 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Transformations for compile-time reduction of expressions / primitives. -} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Normalize.Transformations.Reduce ( reduceBinders , reduceConst , reduceNonRepPrim ) where import qualified Control.Lens as Lens import Control.Monad.Trans.Except (runExcept) import qualified Data.Either as Either 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 ( CoreContext(..), LetBinding, PrimInfo(..), Term(..), TickInfo(..), collectArgs , collectArgsTicks, mkApps, mkTicks, mkTmApps) import Clash.Core.TyCon (tyConDataCons) 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) -- | XXX: is given inverse topologically sorted binders, but returns -- topologically sorted binders -- -- TODO: check further speed improvements: -- -- 1. Store the processed binders in a `Map Expr LetBinding`: -- * Trades O(1) `cons` and O(n)*aeqTerm `find` for: -- * O(log n)*aeqTerm `insert` and O(log n)*aeqTerm `lookup` -- 2. Store the processed binders in a `AEQTrie Expr LetBinding` -- * Trades O(1) `cons` and O(n)*aeqTerm `find` for: -- * O(e) `insert` and O(e) `lookup` reduceBinders :: Subst -> [LetBinding] -> [LetBinding] -> NormalizeSession (Subst, [LetBinding]) reduceBinders !subst processed [] = return (subst,processed) reduceBinders !subst processed ((i,substTm "reduceBinders" subst -> e):rest) | (_,_,ticks) <- collectArgsTicks e , NoDeDup `notElem` ticks , Just (i1,_) <- List.find ((== e) . snd) processed = do let subst1 = extendIdSubst subst i (Var i1) setChanged reduceBinders subst1 processed rest | otherwise = reduceBinders subst ((i,e):processed) rest {-# SCC reduceBinders #-} reduceConst :: HasCallStack => NormRewrite reduceConst ctx e@(App _ _) | (Prim p0, _) <- collectArgs e = whnfRW False ctx e $ \_ctx1 e1 -> case e1 of (collectArgs -> (Prim p1, _)) | primName p0 == primName p1 -> return e _ -> changed e1 reduceConst _ e = return e {-# SCC reduceConst #-} -- | Replace primitives by their "definition" if they would lead to let-bindings -- with a non-representable type when a function is in ANF. This happens for -- example when Clash.Size.Vector.map consumes or produces a vector of -- non-representable elements. -- -- Basically what this transformation does is replace a primitive the completely -- unrolled recursive definition that it represents. e.g. -- -- > zipWith ($) (xs :: Vec 2 (Int -> Int)) (ys :: Vec 2 Int) -- -- is replaced by: -- -- > let (x0 :: (Int -> Int)) = case xs of (:>) _ x xr -> x -- > (xr0 :: Vec 1 (Int -> Int)) = case xs of (:>) _ x xr -> xr -- > (x1 :: (Int -> Int)( = case xr0 of (:>) _ x xr -> x -- > (y0 :: Int) = case ys of (:>) _ y yr -> y -- > (yr0 :: Vec 1 Int) = case ys of (:>) _ y yr -> xr -- > (y1 :: Int = case yr0 of (:>) _ y yr -> y -- > in (($) x0 y0 :> ($) x1 y1 :> Nil) -- -- Currently, it only handles the following functions: -- -- * Clash.Sized.Vector.zipWith -- * Clash.Sized.Vector.map -- * Clash.Sized.Vector.traverse# -- * Clash.Sized.Vector.fold -- * Clash.Sized.Vector.foldr -- * Clash.Sized.Vector.dfold -- * Clash.Sized.Vector.(++) -- * Clash.Sized.Vector.head -- * Clash.Sized.Vector.tail -- * Clash.Sized.Vector.last -- * Clash.Sized.Vector.init -- * Clash.Sized.Vector.unconcat -- * Clash.Sized.Vector.transpose -- * Clash.Sized.Vector.replicate -- * Clash.Sized.Vector.replace_int -- * Clash.Sized.Vector.imap -- * Clash.Sized.Vector.dtfold -- * Clash.Sized.RTree.tdfold -- * Clash.Sized.RTree.treplicate -- * Clash.Sized.Internal.BitVector.split# -- * Clash.Sized.Internal.BitVector.eq# -- -- Note [Unroll shouldSplit types] -- 1. Certain higher-order functions over Vec, such as map, have specialized -- code-paths to turn them into generate-for loops in HDL, instead of having to -- having to unroll/inline their recursive definitions, e.g. Clash.Sized.Vector.map -- -- 2. Clash, in general, translates Haskell product types to VHDL records. This -- mostly works out fine, there is however one exception: certain synthesis -- tools, and some HDL simulation tools (like verilator), do not like it when -- the clock (and certain other global control signals) is contained in a -- record type; they want them to be separate inputs to the entity/module. -- And Clash actually does some transformations to try to ensure that values of -- type Clock do not end up in a VHDL record type. -- -- The problem is that the transformations in 2. never took into account the -- specialized code-paths in 1. Making the code-paths in 1. aware of the -- transformations in 2. is really not worth the effort for such a niche case. -- It's easier to just unroll the recursive definitions. -- -- See https://github.com/clash-lang/clash-compiler/issues/1606 reduceNonRepPrim :: HasCallStack => NormRewrite 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 let resTy = snd (splitFunForallTy eTy) case tyView resTy of (TyConApp vecTcNm@(nameOcc -> "Clash.Sized.Vector.Vec") [runExcept . tyNatSize tcm -> Right 0, aTy]) -> do 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" | (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 , List.anyM isUntranslatableType_not_poly [lhsElTy,rhsElty,resElTy] -- Note [Unroll shouldSplit types] , pure (any (Maybe.isJust . shouldSplit tcm) [lhsTy,rhsTy,resTy]) ] if shouldReduce1 then abstractOverMissingArgs ticks tmArgs eTy c (reduceZipWith p n lhsElTy rhsElty resElTy) else return e _ -> return e | 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 , List.anyM isUntranslatableType_not_poly [argElTy,resElTy] -- Note [Unroll shouldSplit types] , pure (any (Maybe.isJust . shouldSplit tcm) [argTy,resTy]) ] if shouldReduce1 then abstractOverMissingArgs ticks tmArgs eTy c (reduceMap p n argElTy resElTy) else return e _ -> return e | 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 | 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 , isUntranslatableType_not_poly aTy -- Note [Unroll shouldSplit types] , pure (Maybe.isJust (shouldSplit tcm argTy))] if shouldReduce1 then abstractOverMissingArgs ticks tmArgs eTy c (reduceFold (n + 1) aTy) else return e _ -> return e | 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 , List.anyM isUntranslatableType_not_poly [aTy,bTy] -- Note [Unroll shouldSplit types] , pure (Maybe.isJust (shouldSplit tcm argTy)) ] if shouldReduce1 then abstractOverMissingArgs ticks tmArgs eTy c (reduceFoldr p n aTy) else return e _ -> return e | 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 | 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 resTy)) ] if shouldReduce1 then abstractOverMissingArgs ticks tmArgs eTy c (reduceAppend n m aTy) else return e _ -> return e | 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 abstractOverMissingArgs ticks tmArgs eTy c (reduceHead (n+1) aTy) else return e _ -> return e | 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 abstractOverMissingArgs ticks tmArgs eTy c (reduceTail (n+1) aTy) else return e _ -> return e | 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 -- Note [Unroll shouldSplit types] , pure (Maybe.isJust (shouldSplit tcm argTy)) ] if shouldReduce1 then abstractOverMissingArgs ticks tmArgs eTy c (reduceLast (n+1) aTy) else return e _ -> return e | 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 abstractOverMissingArgs ticks tmArgs eTy c (reduceInit p n aTy) else return e _ -> return e | 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 , isUntranslatableType_not_poly aTy -- Note [Unroll shouldSplit types] , pure (Maybe.isJust (shouldSplit tcm argTy)) ] if shouldReduce1 then abstractOverMissingArgs ticks tmArgs eTy c (reduceUnconcat p n m aTy) else return e _ -> return e | 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 | 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 resTy)) ] if shouldReduce1 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" | (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 resTy)) ] if shouldReduce1 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" | (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 , isUntranslatableType_not_poly aTy -- Note [Unroll shouldSplit types] , pure (Maybe.isJust (shouldSplit tcm argTy)) ] if shouldReduce1 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" | (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,resTy]) ] if shouldReduce1 then abstractOverMissingArgs ticks tmArgs eTy c (reduceImap n argElTy resElTy) else return e _ -> return e | 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 resTy)) ] if shouldReduce1 then abstractOverMissingArgs ticks tmArgs eTy c (reduceIterateI n aTy resTy) else return e _ -> return e | 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 , (tmArgs,[nTy,aTy]) <- Either.partitionEithers args , Right n <- runExcept (tyNatSize tcm nTy) -> abstractOverMissingArgs ticks tmArgs eTy c (reduceReverse n aTy) "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 | 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 abstractOverMissingArgs ticks tmArgs eTy c (reduceTReplicate n aTy resTy) else return e _ -> return e | 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 -> 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) :: 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) :: 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#" | (tmArgs,[nTy]) <- Either.partitionEithers args , Right 0 <- runExcept (tyNatSize tcm nTy) , TyConApp boolTcNm [] <- tv -> 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 u <- isUntranslatableType False t if u then return (null $ Lens.toListOf typeFreeVars t) else return False 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) clash-lib-1.8.1/src/Clash/Normalize/Transformations/SeparateArgs.hs0000644000000000000000000001001607346545000023435 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., 2021 , QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. The separating arguments transformation -} {-# LANGUAGE OverloadedStrings #-} module Clash.Normalize.Transformations.SeparateArgs ( separateArguments ) where import qualified Control.Lens as Lens import Control.Monad.Writer (listen) import qualified Data.List as List import qualified Data.Monoid as Monoid import GHC.Stack (HasCallStack) import Clash.Core.HasType import Clash.Core.Name (Name(..)) import Clash.Core.Subst (extendIdSubst, mkSubst, substTm) import Clash.Core.Term (Term(..), collectArgsTicks, mkApps, mkLams, mkTicks) import Clash.Core.Type (Type, mkPolyFunTy, splitFunForallTy) import Clash.Core.TyCon (TyConMap) import Clash.Core.Util (Projections (..), shouldSplit) import Clash.Core.Var (Id, TyVar, Var (..), isGlobalId, mkLocalId) import Clash.Core.VarEnv (extendInScopeSet, uniqAway) import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Rewrite.Types (TransformContext(..), tcCache) import Clash.Rewrite.Util (changed, mkDerivedName) -- | Split apart (global) function arguments that contain types that we -- want to separate off, e.g. Clocks. Works on both the definition side (i.e. the -- lambda), and the call site (i.e. the application of the global variable). e.g. -- turns -- -- > f :: (Clock System, Reset System) -> Signal System Int -- -- into -- -- > f :: Clock System -> Reset System -> Signal System Int separateArguments :: HasCallStack => NormRewrite separateArguments ctx e0@(Lam b eb) = do tcm <- Lens.view tcCache case separateLambda tcm ctx b eb of Just e1 -> changed e1 Nothing -> return e0 separateArguments (TransformContext is0 _) e@(collectArgsTicks -> (Var g, args, ticks)) | isGlobalId g = do -- We ensure that both the type of the global variable reference is updated -- to take into account the changed arguments, and that we apply the global -- function with the split apart arguments. let (argTys0,resTy) = splitFunForallTy (coreTypeOf g) (concat -> args1, Monoid.getAny -> hasChanged) <- listen (mapM (uncurry splitArg) (zip argTys0 args)) if hasChanged then let (argTys1,args2) = unzip args1 gTy = mkPolyFunTy resTy argTys1 in return (mkApps (mkTicks (Var g {varType = gTy}) ticks) args2) else return e where -- Split a single argument splitArg :: Either TyVar Type -- The quantifier/function argument type of the global variable -> Either Term Type -- The applied type argument or term argument -> NormalizeSession [(Either TyVar Type,Either Term Type)] splitArg tv arg@(Right _) = return [(tv,arg)] splitArg ty arg@(Left tmArg) = do tcm <- Lens.view tcCache let argTy = inferCoreTypeOf tcm tmArg case shouldSplit tcm argTy of Just (_,Projections projections,_) -> do tmArgs <- projections is0 tmArg changed (map ((ty,) . Left) tmArgs) _ -> return [(ty,arg)] separateArguments _ e = return e {-# SCC separateArguments #-} -- | Worker function of 'separateArguments'. separateLambda :: TyConMap -> TransformContext -> Id -- ^ Lambda binder -> Term -- ^ Lambda body -> Maybe Term -- ^ If lambda is split up, this function returns a Just containing the new term separateLambda tcm ctx@(TransformContext is0 _) b eb0 = case shouldSplit tcm (coreTypeOf b) of Just (dc, _, argTys) -> let nm = mkDerivedName ctx (nameOcc (varName b)) bs0 = map (`mkLocalId` nm) argTys (is1, bs1) = List.mapAccumL newBinder is0 bs0 subst = extendIdSubst (mkSubst is1) b (dc (map Var bs1)) eb1 = substTm "separateArguments" subst eb0 in Just (mkLams eb1 bs1) _ -> Nothing where newBinder isN0 x = let x' = uniqAway isN0 x isN1 = extendInScopeSet isN0 x' in (isN1, x') {-# SCC separateLambda #-} clash-lib-1.8.1/src/Clash/Normalize/Transformations/Specialize.hs0000644000000000000000000006750507346545000023163 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., 2021-2023, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Transformations for specialization -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskellQuotes #-} module Clash.Normalize.Transformations.Specialize ( appProp , constantSpec , specialize , nonRepSpec , typeSpec , zeroWidthSpec ) where import Control.Arrow ((***), (&&&)) import Control.DeepSeq (deepseq) import Control.Exception (throw) import Control.Lens ((%=)) import qualified Control.Lens as Lens import qualified Control.Monad as Monad import Control.Monad.Extra (orM) import qualified Control.Monad.Writer as Writer (listen) import Data.Bifunctor (bimap) import Data.Coerce (coerce) import qualified Data.Either as Either import Data.Functor.Const (Const(..)) import qualified Data.Map.Strict as Map import qualified Data.Monoid as Monoid (getAny) import qualified Data.Set.Ordered as OSet import qualified Data.Set.Ordered.Extra as OSet 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 qualified Clash.Sized.Internal.BitVector as BV (BitVector, fromInteger#) import qualified Clash.Sized.Internal.Index as I (Index, fromInteger#) import qualified Clash.Sized.Internal.Signed as S (Signed, fromInteger#) import qualified Clash.Sized.Internal.Unsigned as U (Unsigned, fromInteger#) import Clash.Core.DataCon (DataCon(dcArgTys)) import Clash.Core.FreeVars (freeLocalVars, termFreeTyVars, typeFreeVars) import Clash.Core.HasType import Clash.Core.Literal (Literal(..)) import Clash.Core.Name (NameSort(..), Name(..), appendToName, mkUnsafeInternalName, mkUnsafeSystemName) import Clash.Core.Pretty (showPpr) import Clash.Core.Subst import Clash.Core.Term ( Term(..), TickInfo, collectArgs, collectArgsTicks, mkApps, mkTmApps, mkTicks, patIds, Bind(..) , patVars, mkAbstraction, PrimInfo(..), WorkInfo(..), IsMultiPrim(..), PrimUnfolding(..), stripAllTicks) import Clash.Core.TermInfo (isLocalVar, isVar, isPolyFun) import Clash.Core.TyCon (TyConMap, tyConDataCons) import Clash.Core.Type (LitTy(NumTy), Type(LitTy,VarTy), applyFunTy, splitTyConAppM, normalizeType , mkPolyFunTy, mkTyConApp) import Clash.Core.TysPrim import Clash.Core.Util (listToLets) import Clash.Core.Var (Var(..), Id, TyVar, mkTyVar) 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) import Clash.Rewrite.Combinators (topdownR) import Clash.Rewrite.Types ( TransformContext(..), bindings, censor, curFun, customReprs, extra, tcCache , typeTranslator, workFreeBinders, debugOpts, topEntities, specializationLimit) import Clash.Rewrite.Util ( mkBinderFor, mkDerivedName, mkFunction, mkTmBinderFor, setChanged, changed , normalizeTermTypes, normalizeId) import Clash.Rewrite.WorkFree (isWorkFree) import Clash.Normalize.Types ( NormRewrite, NormalizeSession, specialisationCache, specialisationHistory) import Clash.Normalize.Util (constantSpecInfo, csrFoundConstant, csrNewBindings, csrNewTerm) import Clash.Util (ClashException(..)) -- | Propagate arguments of application inwards; except for 'Lam' where the -- argument becomes let-bound. 'appProp' tries to propagate as many arguments -- as possible, down as many levels as possible; and should be called in a -- top-down traversal. -- -- The idea is that this reduces the number of traversals, which hopefully leads -- to shorter compile times. -- -- Note [AppProp no shadowing] -- -- Case 1. -- -- Imagine: -- -- @ -- (case x of -- D a b -> h a) (f x y) -- @ -- -- rewriting this to: -- -- @ -- let b = f x y -- in case x of -- D a b -> h a b -- @ -- -- is very bad because @b@ in @h a b@ is now bound by the pattern instead of the -- newly introduced let-binding -- -- instead we must deshadow w.r.t. the new variable and rewrite to: -- -- @ -- let b = f x y -- in case x of -- D a b1 -> h a b -- @ -- -- Case 2. -- -- Imagine -- -- @ -- (\x -> e) u -- @ -- -- where @u@ has a free variable named @x@, rewriting this to: -- -- @ -- let x = u -- in e -- @ -- -- would be very bad, because the let-binding suddenly captures the free -- variable in @u@. To prevent this from happening we over-approximate and check -- whether @x@ is in the current InScopeSet, and deshadow if that's the case, -- i.e. we then rewrite to: -- -- @ -- let x1 = u -- in e [x:=x1] -- @ -- -- Case 3. -- -- The same for: -- -- @ -- (let x = w in e) u -- @ -- -- where @u@ again has a free variable @x@, rewriting this to: -- -- @ -- let x = w in (e u) -- @ -- -- would be bad because the let-binding now captures the free variable in @u@. -- -- To prevent this from happening, we unconditionally deshadow the function part -- of the application w.r.t. the free variables in the argument part of the -- application. It is okay to over-approximate in this case and deshadow w.r.t -- the current InScopeSet. appProp :: HasCallStack => NormRewrite appProp ctx@(TransformContext is _) = \case e@App {} | let (fun,args,ticks) = collectArgsTicks e -> do (eN,hasChanged) <- Writer.listen (go is (deShadowTerm is fun) args ticks) if Monoid.getAny hasChanged then return eN else return e e@TyApp {} | let (fun,args,ticks) = collectArgsTicks e -> do (eN,hasChanged) <- Writer.listen (go is (deShadowTerm is fun) args ticks) if Monoid.getAny hasChanged then return eN else return e e -> return e where go :: InScopeSet -> Term -> [Either Term Type] -> [TickInfo] -> NormalizeSession Term go is0 (collectArgsTicks -> (fun,args0@(_:_),ticks0)) args1 ticks1 = go is0 fun (args0 ++ args1) (ticks0 ++ ticks1) go is0 (Lam v e) (Left arg:args) ticks = do setChanged bndrs <- Lens.use bindings orM [pure (isVar arg), isWorkFree workFreeBinders bndrs arg] >>= \case True -> let subst = extendIdSubst (mkSubst is0) v arg in (`mkTicks` ticks) <$> go is0 (substTm "appProp.AppLam" subst e) args [] False -> let is1 = extendInScopeSet is0 v in Let (NonRec v arg) <$> go is1 (deShadowTerm is1 e) args ticks go is0 (Let (NonRec i x) e) args@(_:_) ticks = do setChanged let is1 = extendInScopeSet is0 i -- XXX: binding should already be deshadowed w.r.t. 'is0' Let (NonRec i x) <$> go is1 e args ticks go is0 (Let (Rec vs) e) args@(_:_) ticks = do setChanged let vbs = map fst vs is1 = extendInScopeSetList is0 vbs -- XXX: 'vs' should already be deshadowed w.r.t. 'is0' Let (Rec vs) <$> go is1 e args ticks go is0 (TyLam tv e) (Right t:args) ticks = do setChanged let subst = extendTvSubst (mkSubst is0) tv t (`mkTicks` ticks) <$> go is0 (substTm "appProp.TyAppTyLam" subst e) args [] go is0 (Case scrut ty0 alts) args0@(_:_) ticks = do setChanged let isA1 = unionInScope is0 ((mkInScopeSet . mkVarSet . concatMap (patVars . fst)) alts) (ty1,vs,args1) <- goCaseArg isA1 ty0 [] args0 case vs of [] -> (`mkTicks` ticks) . Case scrut ty1 <$> mapM (goAlt is0 args1) alts _ -> do let vbs = map fst vs is1 = extendInScopeSetList is0 vbs alts1 = map (deShadowAlt is1) alts -- TODO I should have a mkNonRecLets :: [LetBinding] -> Term -> Term -- function which makes a chain of non-recursive let expressions without -- needing to first take the SCCs of all the binders. listToLets vs . (`mkTicks` ticks) . Case scrut ty1 <$> mapM (goAlt is1 args1) alts1 go is0 (Tick sp e) args ticks = do setChanged go is0 e args (sp:ticks) go _ fun args ticks = return (mkApps (mkTicks fun ticks) args) goAlt is0 args0 (p,e) = do let (tvs,ids) = patIds p is1 = extendInScopeSetList (extendInScopeSetList is0 tvs) ids (p,) <$> go is1 e args0 [] goCaseArg isA ty0 ls0 (Right t:args0) = do tcm <- Lens.view tcCache let ty1 = piResultTy tcm ty0 t (ty2,ls1,args1) <- goCaseArg isA ty1 ls0 args0 return (ty2,ls1,Right t:args1) goCaseArg isA0 ty0 ls0 (Left arg:args0) = do tcm <- Lens.view tcCache bndrs <- Lens.use bindings let argTy = inferCoreTypeOf tcm arg ty1 = applyFunTy tcm ty0 argTy orM [pure (isVar arg), isWorkFree workFreeBinders bndrs arg] >>= \case True -> do (ty2,ls1,args1) <- goCaseArg isA0 ty1 ls0 args0 return (ty2,ls1,Left arg:args1) False -> do boundArg <- mkTmBinderFor isA0 tcm (mkDerivedName ctx "app_arg") arg let isA1 = extendInScopeSet isA0 boundArg (ty2,ls1,args1) <- goCaseArg isA1 ty1 ls0 args0 return (ty2,(boundArg,arg):ls1,Left (Var boundArg):args1) goCaseArg _ ty ls [] = return (ty,ls,[]) {-# SCC appProp #-} -- | Specialize functions on arguments which are constant, except when they -- are clock, reset generators. constantSpec :: HasCallStack => NormRewrite constantSpec ctx@(TransformContext is0 tfCtx) e@(App e1 e2) | (Var {}, args) <- collectArgs e1 , (_, []) <- Either.partitionEithers args , null $ Lens.toListOf termFreeTyVars e2 = do specInfo<- constantSpecInfo ctx e2 if csrFoundConstant specInfo then let newBindings = csrNewBindings specInfo in if null newBindings then -- Whole of e2 is constant specialize ctx (App e1 e2) else do -- Parts of e2 are constant let is1 = extendInScopeSetList is0 (fst <$> csrNewBindings specInfo) (body, isSpec) <- Writer.listen $ specialize (TransformContext is1 tfCtx) (App e1 (csrNewTerm specInfo)) if Monoid.getAny isSpec then changed (listToLets newBindings body) else return e else -- e2 has no constant parts return e constantSpec _ e = return e {-# SCC constantSpec #-} -- | Specialize an application on its argument specialize :: NormRewrite specialize ctx e = case e of (TyApp e1 ty) -> specialize' ctx e (collectArgsTicks e1) (Right ty) (App e1 e2) -> specialize' ctx e (collectArgsTicks e1) (Left e2) _ -> return e {- Note [ticks and specialization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As Clash now distinguishes between ticks in expressions when comparing for alpha equality, this has a knock-on effect when accessing the specialization cache. Consider these applications which differ only by ticks: f[GlobalId] (\x -> ... x[LocalId]) f[GlobalId] (\x -> ... x[LocalId]) f[GlobalId] (\x -> ... x[LocalId]) If one of these had been specialized, the other two would hit that term in the specialization cache, saving Clash from having to re-do work which is in effect the same. To preserve this behaviour, we use 'stripAllTicks' on the keys for the specialization cache. TODO While this preserves the old behaviour, the old behaviour is likely not quite what we want. Using a value from the specialization cache may change the ticks present, which can affect naming / debugging information in generated HDL. We may also not want to look at ticks, as then the specialization cache will 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 -- ^ Transformation context -> Term -- ^ Original term -> (Term, [Either Term Type], [TickInfo]) -- ^ Function part of the term, split into root and applied arguments -> Either Term Type -- ^ Argument to specialize on -> NormalizeSession Term specialize' (TransformContext is0 _) e (Var f, args, ticks) specArgIn = do opts <- Lens.view debugOpts tcm <- Lens.view tcCache -- Don't specialize TopEntities topEnts <- Lens.view topEntities if f `elemVarSet` topEnts then do case specArgIn of Left _ -> do traceM ("Not specializing TopEntity: " ++ showPpr (varName f)) return e Right tyArg -> traceIf (hasTransformationInfo AppliedTerm opts) ("Dropping type application on TopEntity: " ++ showPpr (varName f) ++ "\ntype:\n" ++ showPpr tyArg) $ -- TopEntities aren't allowed to be semantically polymorphic. -- But using type equality constraints they may be syntactically polymorphic. -- > topEntity :: forall dom . (dom ~ "System") => Signal dom Bool -> Signal dom Bool -- The TyLam's in the body will have been removed by 'Clash.Normalize.Util.substWithTyEq'. -- So we drop the TyApp ("specializing" on it) and change the varType to match. let newVarTy = piResultTy tcm (coreTypeOf f) tyArg in changed (mkApps (mkTicks (Var f{varType = newVarTy}) ticks) args) else do -- NondecreasingIndentation let specArg = bimap (normalizeTermTypes tcm) (normalizeType tcm) specArgIn -- Create binders and variable references for free variables in 'specArg' -- (specBndrsIn,specVars) :: ([Either Id TyVar], [Either Term Type]) (specBndrsIn,specVars) = specArgBndrsAndVars specArg argLen = length args specBndrs :: [Either Id TyVar] specBndrs = map (Lens.over Lens._Left (normalizeId tcm)) specBndrsIn -- See Note [ticks and specialization] specAbs :: Either Term Type specAbs = either (Left . stripAllTicks . (`mkAbstraction` specBndrs)) (Right . id) specArg -- Determine if 'f' has already been specialized on (a type-normalized) 'specArg' specM <- Map.lookup (f,argLen,specAbs) <$> Lens.use (extra.specialisationCache) case specM of -- Use previously specialized function Just f' -> traceIf (hasTransformationInfo AppliedTerm opts) ("Using previous specialization of " ++ showPpr (varName f) ++ " on " ++ (either showPpr showPpr) specAbs ++ ": " ++ showPpr (varName f')) $ changed $ mkApps (mkTicks (Var f') ticks) (args ++ specVars) -- Create new specialized function Nothing -> do -- Determine if we can specialize f 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 <- UniqMap.lookup f <$> Lens.use (extra.specialisationHistory) specLim <- Lens.view specializationLimit if maybe False (> specLim) specHistM then throw (ClashException sp (unlines [ "Hit specialization limit " ++ show specLim ++ " on function `" ++ showPpr (varName f) ++ "'.\n" , "The function `" ++ showPpr f ++ "' is most likely recursive, and looks like it is being indefinitely specialized on a growing argument.\n" , "Body of `" ++ showPpr f ++ "':\n" ++ showPpr bodyTm ++ "\n" , "Argument (in position: " ++ show argLen ++ ") that triggered termination:\n" ++ (either showPpr showPpr) specArg , "Run with '-fclash-spec-limit=N' to increase the specialization limit to N." ]) Nothing) else do let existingNames = collectBndrsMinusApps bodyTm newNames = [ mkUnsafeInternalName ("pTS" `Text.append` Text.pack (show n)) n | n <- [(0::Int)..] ] -- Make new binders for existing arguments (boundArgs,argVars) <- fmap (unzip . map (either (Left &&& Left . Var) (Right &&& Right . VarTy))) $ Monad.zipWithM (mkBinderFor is0 tcm) (existingNames ++ newNames) args -- Determine name the resulting specialized function, and the -- form of the specialized-on argument (fId,inl',specArg') <- case specArg of Left a@(collectArgsTicks -> (Var g,gArgs,_gTicks)) -> if isPolyFun tcm a then do -- In case we are specializing on an argument that is a -- global function then we use that function's name as the -- name of the specialized higher-order function. -- Additionally, we will return the body of the global -- function, instead of a variable reference to the -- global function. -- -- This will turn things like @mealy g k@ into a new -- 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 (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) %= 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 go bs (Lam v e') = go (coerce (varName v):bs) e' go bs (TyLam tv e') = go (coerce (varName tv):bs) e' go bs (App e' _) = case go [] e' of [] -> bs bs' -> init bs' ++ bs go bs (TyApp e' _) = case go [] e' of [] -> bs bs' -> init bs' ++ bs go bs _ = bs -- Specializing non Var's is used by nonRepANF specialize' _ctx _ (appE,args,ticks) (Left specArg) = do -- Create binders and variable references for free variables in 'specArg' let (specBndrs,specVars) = specArgBndrsAndVars (Left specArg) -- Create specialized function newBody = mkAbstraction specArg specBndrs -- See if there's an existing binder that's alpha-equivalent to the -- specialized function existing <- UniqMap.filter ((`aeqTerm` newBody) . bindingTerm) <$> Lens.use bindings -- Create a new function if an alpha-equivalent binder doesn't exist 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 -- Use specialized argument let newExpr = mkApps (mkTicks appE ticks) (args ++ [newArg]) changed newExpr specialize' _ e _ _ = return e -- Note [Collect free-variables in an insertion-ordered set] -- -- In order for the specialization cache to work, 'specArgBndrsAndVars' should -- yield (alpha equivalent) results for the same specialization. While collecting -- free variables in a given term or type it should therefore keep a stable -- ordering based on the order in which it finds free vars. To see why, -- consider the following two pseudo-code calls to 'specialize': -- -- specialize {f ('a', x[123], y[456])} -- specialize {f ('b', x[456], y[123])} -- -- Collecting the binders in a VarSet would yield the following (unique ordered) -- sets: -- -- {x[123], y[456]} -- {y[123], x[456]} -- -- ..and therefore breaking specializing caching. We now track them in insert- -- ordered sets, yielding: -- -- {x[123], y[456]} -- {x[456], y[123]} -- -- | Create binders and variable references for free variables in 'specArg' specArgBndrsAndVars :: Either Term Type -> ([Either Id TyVar], [Either Term Type]) specArgBndrsAndVars specArg = -- See Note [Collect free-variables in an insertion-ordered set] let unitFV :: Var a -> Const (OSet.OLSet TyVar, OSet.OLSet Id) (Var a) unitFV v@(Id {}) = Const (mempty, coerce (OSet.singleton (coerce v))) unitFV v@(TyVar {}) = Const (coerce (OSet.singleton (coerce v)), mempty) (specFTVs,specFVs) = case specArg of Left tm -> (OSet.toListL *** OSet.toListL) . getConst $ Lens.foldMapOf freeLocalVars unitFV tm Right ty -> ( UniqMap.elems (Lens.foldMapOf typeFreeVars (\x -> UniqMap.singletonUnique (coerce x)) ty) , [] :: [Id]) specTyBndrs = map Right specFTVs specTmBndrs = map Left specFVs specTyVars = map (Right . VarTy) specFTVs specTmVars = map (Left . Var) specFVs in (specTyBndrs ++ specTmBndrs,specTyVars ++ specTmVars) -- | Specialize functions on their non-representable argument nonRepSpec :: HasCallStack => NormRewrite nonRepSpec ctx e@(App e1 e2) | (Var {}, args) <- collectArgs e1 , (_, []) <- Either.partitionEithers args , null $ Lens.toListOf termFreeTyVars e2 = do tcm <- Lens.view tcCache let e2Ty = inferCoreTypeOf tcm e2 let localVar = isLocalVar e2 nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view customReprs <*> pure False <*> Lens.view tcCache <*> pure e2Ty) if nonRepE2 && not localVar then do e2' <- inlineInternalSpecialisationArgument e2 specialize ctx (App e1 e2') else return e where -- | If the argument on which we're specializing is an internal function, -- one created by the compiler, then inline that function before we -- specialize. -- -- We need to do this because otherwise the specialization history won't -- recognize the new specialization argument as something the function has -- already been specialized on inlineInternalSpecialisationArgument :: Term -> NormalizeSession Term inlineInternalSpecialisationArgument app | (Var f,fArgs,ticks) <- collectArgsTicks app = do fTmM <- lookupVarEnv f <$> Lens.use bindings case fTmM of Just b | nameSort (varName (bindingId b)) == Internal -> censor (const mempty) (topdownR appProp ctx (mkApps (mkTicks (bindingTerm b) ticks) fArgs)) _ -> return app | otherwise = return app nonRepSpec _ e = return e {-# SCC nonRepSpec #-} -- | Specialize functions on their type typeSpec :: HasCallStack => NormRewrite typeSpec ctx e@(TyApp e1 ty) | (Var {}, args) <- collectArgs e1 , null $ Lens.toListOf typeFreeVars ty , (_, []) <- Either.partitionEithers args = specialize ctx e typeSpec _ e = return e {-# SCC typeSpec #-} -- | Specialize functions on arguments which are zero-width. These arguments -- can have only one possible value, and specializing on this value may create -- additional opportunities for transformations to fire. -- -- As we can't remove zero-width arguements (as transformations cannot change -- the type of a term), we instead substitute all occurances of a lambda-bound -- variable with a zero-width type with the only value of that type. -- zeroWidthSpec :: HasCallStack => NormRewrite zeroWidthSpec (TransformContext is _) e@(Lam i x0) = do tcm <- Lens.view tcCache let bndrTy = normalizeType tcm (coreTypeOf i) case zeroWidthTypeElem tcm bndrTy of Just tm -> let subst = extendIdSubst (mkSubst is) i tm x1 = substTm "zeroWidthSpec" subst x0 in changed (Lam i x1) Nothing -> return e zeroWidthSpec _ e = return e {-# SCC zeroWidthSpec #-} -- Get the only element of a type, if it is zero-width. -- zeroWidthTypeElem :: TyConMap -> Type -> Maybe Term zeroWidthTypeElem tcm ty = do (tcNm, args) <- splitTyConAppM ty if | nameOcc tcNm == Text.showt ''BV.BitVector , [LitTy (NumTy 0)] <- args -> return (bitVectorZW tcNm args) | nameOcc tcNm == Text.showt ''I.Index , [LitTy (NumTy 1)] <- args -> return (indexZW tcNm args) | nameOcc tcNm == Text.showt ''S.Signed , [LitTy (NumTy 0)] <- args -> return (signedZW tcNm args) | nameOcc tcNm == Text.showt ''U.Unsigned , [LitTy (NumTy 0)] <- args -> return (unsignedZW tcNm args) -- Any other zero-width type should only have a single data constructor -- where all fields are also zero-width. | otherwise -> do tc <- UniqMap.lookup tcNm tcm case tyConDataCons tc of [dc] -> do zwArgs <- traverse (zeroWidthTypeElem tcm) (dcArgTys dc) return (mkTmApps (Data dc) zwArgs) _ -> Nothing where nNm = mkUnsafeSystemName "n" 0 nTv = mkTyVar typeNatKind nNm mkBitVector tcNm = let prTy = mkPolyFunTy (mkTyConApp tcNm [VarTy nTv]) [Left nTv, Right naturalPrimTy, Right naturalPrimTy, Right integerPrimTy] in PrimInfo (Text.showt 'BV.fromInteger#) prTy WorkNever SingleResult NoUnfolding bitVectorZW tcNm tyArgs = let pr = mkBitVector tcNm in mkApps (Prim pr) $ fmap Right tyArgs <> [ Left (Literal (NaturalLiteral 0)) , Left (Literal (NaturalLiteral 0)) , Left (Literal (IntegerLiteral 0)) ] mkSizedNum tcNm n = let prTy = mkPolyFunTy (mkTyConApp tcNm [VarTy nTv]) [Left nTv, Right naturalPrimTy, Right integerPrimTy] in PrimInfo n prTy WorkNever SingleResult NoUnfolding indexZW tcNm tyArgs = let pr = mkSizedNum tcNm (Text.showt 'I.fromInteger#) in mkApps (Prim pr) $ fmap Right tyArgs <> [ Left (Literal (NaturalLiteral 1)) , Left (Literal (IntegerLiteral 0)) ] signedZW tcNm tyArgs = let pr = mkSizedNum tcNm (Text.showt 'S.fromInteger#) in mkApps (Prim pr) $ fmap Right tyArgs <> [ Left (Literal (NaturalLiteral 0)) , Left (Literal (IntegerLiteral 0)) ] unsignedZW tcNm tyArgs = let pr = mkSizedNum tcNm (Text.showt 'U.fromInteger#) in mkApps (Prim pr) $ fmap Right tyArgs <> [ Left (Literal (NaturalLiteral 0)) , Left (Literal (IntegerLiteral 0)) ] clash-lib-1.8.1/src/Clash/Normalize/Transformations/XOptimize.hs0000644000000000000000000001136607346545000023015 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2018, Google Inc., 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. The X-optimization transformation. -} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Normalize.Transformations.XOptimize ( xOptimize ) where import qualified Control.Lens as Lens import qualified Control.Monad as Monad import qualified Data.List.Extra as List import qualified Data.Text.Extra as Text (showt) import GHC.Stack (HasCallStack) import Clash.XException (errorX) import Clash.Annotations.Primitive (extractPrim) import Clash.Core.DataCon (DataCon) import Clash.Core.HasType import Clash.Core.Term ( Alt, IsMultiPrim(..), LetBinding, Pat(..), PrimInfo(..), Term(..) , WorkInfo(..), collectArgs, PrimUnfolding(..)) import Clash.Core.Type (TyVar, Type) import Clash.Core.Util (mkInternalVar) import Clash.Core.Var (Id) import Clash.Core.VarEnv (InScopeSet) import Clash.Netlist.BlackBox.Types (Element(Err)) import Clash.Netlist.Types (BlackBox(..)) import Clash.Normalize.Types (NormRewrite, NormalizeSession) import Clash.Primitives.Types (Primitive(..)) import Clash.Rewrite.Types (TransformContext(..), aggressiveXOpt, tcCache, primitives) import Clash.Rewrite.Util (changed) import Clash.Util (MonadUnique, curLoc) -- | Remove all undefined alternatives from case expressions, replacing them -- with the value of another defined alternative. If there is one defined -- alternative, the entire expression is replaced with that alternative. If -- there are no defined alternatives, the entire expression is replaced with -- a call to 'errorX'. -- -- e.g. It converts -- -- case x of -- D1 a -> f a -- D2 -> undefined -- D3 -> undefined -- -- to -- -- let subj = x -- a = case subj of -- D1 a -> field0 -- in f a -- -- where fieldN is an internal variable referring to the nth argument of a -- data constructor. -- xOptimize :: HasCallStack => NormRewrite xOptimize (TransformContext is0 _) e@(Case subj ty alts) = do runXOpt <- Lens.view aggressiveXOpt if runXOpt then do defPart <- List.partitionM (isPrimError . snd) alts case defPart of ([], _) -> return e (_, []) -> changed (Prim (PrimInfo (Text.showt 'errorX) ty WorkConstant SingleResult NoUnfolding)) (_, [alt]) -> xOptimizeSingle is0 subj alt (_, defs) -> xOptimizeMany is0 subj ty defs else return e xOptimize _ e = return e {-# SCC xOptimize #-} -- Return an expression equivalent to the alternative given. When only one -- alternative is defined the result of this function is used to replace the -- case expression. -- xOptimizeSingle :: InScopeSet -> Term -> Alt -> NormalizeSession Term xOptimizeSingle is subj (DataPat dc tvs vars, expr) = do tcm <- Lens.view tcCache subjId <- mkInternalVar is "subj" (inferCoreTypeOf tcm subj) let fieldTys = fmap coreTypeOf vars lets <- Monad.zipWithM (mkFieldSelector is subjId dc tvs fieldTys) vars [0..] changed (Letrec ((subjId, subj) : lets) expr) xOptimizeSingle _ _ (_, expr) = changed expr -- Given a list of alternatives which are defined, create a new case -- expression which only ever returns a defined value. -- xOptimizeMany :: HasCallStack => InScopeSet -> Term -> Type -> [Alt] -> NormalizeSession Term xOptimizeMany is subj ty defs@(d:ds) | isAnyDefault defs = changed (Case subj ty defs) | otherwise = do newAlt <- xOptimizeSingle is subj d changed (Case subj ty $ ds <> [(DefaultPat, newAlt)]) where isAnyDefault :: [Alt] -> Bool isAnyDefault = any ((== DefaultPat) . fst) xOptimizeMany _ _ _ [] = error $ $(curLoc) ++ "Report as bug: xOptimizeMany error: No defined alternatives" mkFieldSelector :: MonadUnique m => InScopeSet -> Id -- ^ subject id -> DataCon -> [TyVar] -> [Type] -- ^ concrete types of fields -> Id -> Int -> m LetBinding mkFieldSelector is0 subj dc tvs fieldTys nm index = do fields <- mapM (\ty -> mkInternalVar is0 "field" ty) fieldTys let alt = (DataPat dc tvs fields, Var $ fields !! index) return (nm, Case (Var subj) (fieldTys !! index) [alt]) -- Check whether a term is really a black box primitive representing an error. -- Such values are undefined and are removed in X Optimization. -- isPrimError :: Term -> NormalizeSession Bool isPrimError (collectArgs -> (Prim pInfo, _)) = do prim <- Lens.view (primitives . Lens.at (primName pInfo)) case prim >>= extractPrim of Just p -> return (isErr p) Nothing -> return False where isErr BlackBox{template=(BBTemplate [Err _])} = True isErr _ = False isPrimError _ = return False clash-lib-1.8.1/src/Clash/Normalize/Types.hs0000644000000000000000000000507107346545000016774 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2017, Google Inc. 2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Types used in Normalize modules -} {-# LANGUAGE TemplateHaskell #-} module Clash.Normalize.Types where import qualified Control.Lens as Lens import Control.Monad.State.Strict (State) import Data.Map (Map) import Data.Set (Set) import Data.Text (Text) import Clash.Core.Term (Term) import Clash.Core.Type (Type) import Clash.Core.Var (Id) import Clash.Core.VarEnv (VarEnv) import Clash.Driver.Types (BindingMap) import Clash.Rewrite.Types (Rewrite, RewriteMonad) -- | State of the 'NormalizeMonad' data NormalizeState = NormalizeState { _normalized :: BindingMap -- ^ Global binders , _specialisationCache :: Map (Id,Int,Either Term Type) Id -- ^ Cache of previously specialized functions: -- -- * Key: (name of the original function, argument position, specialized term/type) -- -- * Elem: (name of specialized function,type of specialized function) , _specialisationHistory :: VarEnv Int -- ^ Cache of how many times a function was specialized , _inlineHistory :: VarEnv (VarEnv Int) -- ^ Cache of function where inlining took place: -- -- * Key: function where inlining took place -- -- * Elem: (functions which were inlined, number of times inlined) , _primitiveArgs :: Map Text (Set Int) -- ^ Cache for looking up constantness of blackbox arguments , _recursiveComponents :: VarEnv Bool -- ^ Map telling whether a components is recursively defined. -- -- NB: there are only no mutually-recursive component, only self-recursive -- ones. } Lens.makeLenses ''NormalizeState -- | State monad that stores specialisation and inlining information type NormalizeMonad = State NormalizeState -- | RewriteSession with extra Normalisation information type NormalizeSession = RewriteMonad NormalizeState -- | A 'Transform' action in the context of the 'RewriteMonad' and 'NormalizeMonad' type NormRewrite = Rewrite NormalizeState -- | Description of a @Term@ in terms of the type "components" the @Term@ has. -- -- Is used as a performance/size metric. data TermClassification = TermClassification { _function :: !Int -- ^ Number of functions , _primitive :: !Int -- ^ Number of primitives , _selection :: !Int -- ^ Number of selections/multiplexers } deriving Show Lens.makeLenses ''TermClassification clash-lib-1.8.1/src/Clash/Normalize/Util.hs0000644000000000000000000004427107346545000016612 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Utility functions used by the normalisation transformations -} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskellQuotes #-} module Clash.Normalize.Util ( ConstantSpecInfo(..) , isConstantArg , shouldReduce , alreadyInlined , addNewInline , isRecursiveBndr , callGraph , collectCallGraphUniques , classifyFunction , isCheapFunction , isNonRecursiveGlobalVar , constantSpecInfo , normalizeTopLvlBndr , rewriteExpr , mkInlineTick , substWithTyEq , tvSubstWithTyEq ) where import Control.Lens ((&),(+~),(%=),(.=)) import qualified Control.Lens as Lens import Data.Bifunctor (bimap) import Data.Either (lefts,rights) import qualified Data.List as List import qualified Data.List.Extra as List import qualified Data.Map as Map import qualified Data.HashMap.Strict as HashMapS import qualified Data.HashSet as HashSet import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Extra as Text #if MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Names (eqTyConKey) import GHC.Types.Unique (getKey) #else import PrelNames (eqTyConKey) import Unique (getKey) #endif import Clash.Annotations.Primitive (extractPrim) import Clash.Core.FreeVars (globalIds, globalIdOccursIn) import Clash.Core.HasFreeVars (isClosed) import Clash.Core.HasType import Clash.Core.Name (Name(nameOcc,nameUniq)) import Clash.Core.Pretty (showPpr) import Clash.Core.Subst (deShadowTerm, extendTvSubst, mkSubst, substTm, substTy, substId, extendIdSubst) import Clash.Core.Term import Clash.Core.Type (Type(ForAllTy,LitTy, VarTy), LitTy(SymTy), TypeView (..), tyView, splitTyConAppM, mkPolyFunTy) import Clash.Core.Util (isClockOrReset) import Clash.Core.Var (Id, TyVar, Var (..), isGlobalId) 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) import Clash.Normalize.Primitives (removedArg) import {-# SOURCE #-} Clash.Normalize.Strategy (normalization) import Clash.Normalize.Types import Clash.Primitives.Util (constantArgs) import Clash.Rewrite.Types (RewriteMonad, TransformContext(..), bindings, curFun, debugOpts, extra, tcCache, primitives) import Clash.Rewrite.Util (runRewrite, mkTmBinderFor, mkDerivedName) import Clash.Unique import Clash.Util (SrcSpan, makeCachedU) -- | Determine if argument should reduce to a constant given a primitive and -- an argument number. Caches results. isConstantArg :: Text -- ^ Primitive name -> Int -- ^ Argument number -> RewriteMonad NormalizeState Bool -- ^ Yields @DontCare@ for if given primitive name is not found, if the -- argument does not exist, or if the argument was not mentioned by the -- blackbox. isConstantArg "Clash.Explicit.SimIO.mealyIO" i = pure (i == 2 || i == 3) isConstantArg nm i = do argMap <- Lens.use (extra.primitiveArgs) case Map.lookup nm argMap of Nothing -> do -- Constant args not yet calculated, or primitive does not exist prims <- Lens.view primitives case extractPrim =<< HashMapS.lookup nm prims of Nothing -> -- Primitive does not exist: pure False Just p -> do -- Calculate constant arguments: let m = constantArgs nm p (extra.primitiveArgs) Lens.%= Map.insert nm m pure (i `elem` m) Just m -> -- Cached version found pure (i `elem` m) -- | Given a list of transformation contexts, determine if any of the contexts -- indicates that the current arg is to be reduced to a constant / literal. shouldReduce :: Context -- ^ ..in the current transformcontext -> RewriteMonad NormalizeState Bool shouldReduce = List.anyM isConstantArg' where isConstantArg' (AppArg (Just (nm, _, i))) = isConstantArg nm i isConstantArg' _ = pure False -- | Determine if a function is already inlined in the context of the 'NetlistMonad' alreadyInlined :: Id -- ^ Function we want to inline -> Id -- ^ Function in which we want to perform the inlining -> NormalizeMonad (Maybe Int) alreadyInlined f cf = do inlinedHM <- Lens.use inlineHistory case lookupVarEnv cf inlinedHM of Nothing -> return Nothing Just inlined' -> return (lookupVarEnv f inlined') -- | Record a new inlining in the `inlineHistory` addNewInline :: Id -- ^ Function we're inlining -> Id -- ^ Function in which we're inlining it -> NormalizeMonad () addNewInline f cf = inlineHistory %= extendVarEnvWith cf (unitVarEnv f 1) (\_ hm -> extendVarEnvWith f 1 (+) hm) -- | Test whether a given term represents a non-recursive global variable isNonRecursiveGlobalVar :: Term -> NormalizeSession Bool isNonRecursiveGlobalVar (collectArgs -> (Var i, _args)) = do let eIsGlobal = isGlobalId i eIsRec <- isRecursiveBndr i return (eIsGlobal && not eIsRec) isNonRecursiveGlobalVar _ = return False -- | Assert whether a name is a reference to a recursive binder. isRecursiveBndr :: Id -> NormalizeSession Bool isRecursiveBndr f = do cg <- Lens.use (extra.recursiveComponents) case lookupVarEnv f cg of Just isR -> return isR Nothing -> do fBodyM <- lookupVarEnv f <$> Lens.use bindings case fBodyM of Nothing -> return False Just b -> do -- There are no global mutually-recursive functions, only self-recursive -- ones, so checking whether 'f' is part of the free variables of the -- body of 'f' is sufficient. let isR = f `globalIdOccursIn` bindingTerm b (extra.recursiveComponents) %= extendVarEnv f isR return isR data ConstantSpecInfo = ConstantSpecInfo { csrNewBindings :: [(Id, Term)] -- ^ New let-bindings to be created for all the non-constants found , csrNewTerm :: !Term -- ^ A term where all the non-constant constructs are replaced by variable -- references (found in 'csrNewBindings') , csrFoundConstant :: !Bool -- ^ Whether the algorithm found a constant at all. (If it didn't, it's no -- use creating any new let-bindings!) } deriving (Show) -- | Indicate term is fully constant (don't bind anything) constantCsr :: Term -> ConstantSpecInfo constantCsr t = ConstantSpecInfo [] t True -- | Bind given term to a new variable and indicate that it's fully non-constant bindCsr :: TransformContext -> Term -> RewriteMonad NormalizeState ConstantSpecInfo bindCsr ctx@(TransformContext is0 _) oldTerm = do -- TODO: Seems like the need to put global ids in scope has been made obsolete -- TODO: by a recent change in Clash. Investigate whether this is true. tcm <- Lens.view tcCache newId <- mkTmBinderFor is0 tcm (mkDerivedName ctx "bindCsr") oldTerm pure (ConstantSpecInfo { csrNewBindings = [(newId, oldTerm)] , csrNewTerm = Var newId , csrFoundConstant = False }) mergeCsrs :: TransformContext -> [TickInfo] -- ^ Ticks to wrap around proposed new term -> Term -- ^ \"Old\" term -> ([Either Term Type] -> Term) -- ^ Proposed new term in case any constants were found -> [Either Term Type] -- ^ Subterms -> RewriteMonad NormalizeState ConstantSpecInfo mergeCsrs ctx ticks oldTerm proposedTerm subTerms = do subCsrs <- snd <$> List.mapAccumLM constantSpecInfoFolder ctx subTerms -- If any arguments are constant (and hence can be constant specced), a new -- term is created with these constants left in, but variable parts let-bound. -- There's one edge case: whenever a term has _no_ arguments. This happens for -- constructors without fields, or -depending on their WorkInfo- primitives -- without args. We still set 'csrFoundConstant', because we know the newly -- proposed term will be fully constant. let anyArgsOrResultConstant = null (lefts subCsrs) || any csrFoundConstant (lefts subCsrs) if anyArgsOrResultConstant then let newTerm = proposedTerm (bimap csrNewTerm id <$> subCsrs) in pure (ConstantSpecInfo { csrNewBindings = concatMap csrNewBindings (lefts subCsrs) , csrNewTerm = mkTicks newTerm ticks , csrFoundConstant = True }) else do -- No constructs were found to be constant, so we might as well refer to the -- whole thing with a new let-binding (instead of creating a number of -- "smaller" let-bindings) bindCsr ctx oldTerm where constantSpecInfoFolder :: TransformContext -> Either Term Type -> RewriteMonad NormalizeState (TransformContext, Either ConstantSpecInfo Type) constantSpecInfoFolder localCtx (Right typ) = pure (localCtx, Right typ) constantSpecInfoFolder localCtx@(TransformContext is0 tfCtx) (Left term) = do specInfo <- constantSpecInfo localCtx term let newIds = map fst (csrNewBindings specInfo) let is1 = extendInScopeSetList is0 newIds pure (TransformContext is1 tfCtx, Left specInfo) -- | Calculate constant spec info. The goal of this function is to analyze a -- given term and yield a new term that: -- -- * Leaves all the constant parts as they were. -- * Has all _variable_ parts replaced by a newly generated identifier. -- -- The result structure will additionally contain: -- -- * Whether the function found any constant parts at all -- * A list of let-bindings binding the aforementioned identifiers with -- the term they replaced. -- -- This can be used in functions wanting to constant specialize over -- partially constant data structures. constantSpecInfo :: TransformContext -> Term -> RewriteMonad NormalizeState ConstantSpecInfo constantSpecInfo ctx e = do tcm <- Lens.view tcCache -- Don't constant spec clocks or resets, they're either: -- -- * A simple wire (Var), therefore not interesting to spec -- * A clock/reset generator, and speccing a generator weirds out HDL simulators. -- -- I believe we can remove this special case in the future by looking at the -- primitive's workinfo. if isClockOrReset tcm (inferCoreTypeOf tcm e) then case collectArgs e of (Prim p, _) | primName p == Text.showt 'removedArg -> pure (constantCsr e) _ -> bindCsr ctx e else case collectArgsTicks e of (dc@(Data _), args, ticks) -> mergeCsrs ctx ticks e (mkApps dc) args -- TODO: Work with prim's WorkInfo? (prim@(Prim _), args, ticks) -> do csr <- mergeCsrs ctx ticks e (mkApps prim) args if null (csrNewBindings csr) then pure csr else bindCsr ctx e (Lam _ _, _, _ticks) -> if not (isClosed e) then bindCsr ctx e else pure (constantCsr e) (var@(Var f), args, ticks) -> do (curF, _) <- Lens.use curFun isNonRecGlobVar <- isNonRecursiveGlobalVar e if isNonRecGlobVar && f /= curF then do csr <- mergeCsrs ctx ticks e (mkApps var) args if null (csrNewBindings csr) then pure csr else bindCsr ctx e else bindCsr ctx e (Literal _,_, _ticks) -> pure (constantCsr e) _ -> bindCsr ctx e -- | A call graph counts the number of occurrences that a functions 'g' is used -- in 'f'. type CallGraph = VarEnv (VarEnv Word) -- | Collect all binders mentioned in CallGraph into a HashSet collectCallGraphUniques :: CallGraph -> HashSet.HashSet Unique collectCallGraphUniques cg = HashSet.fromList (us0 ++ us1) where 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 :: BindingMap -> Id -> CallGraph callGraph bndrs rt = go emptyVarEnv (varUniq rt) where go cg root | Nothing <- UniqMap.lookup root cg , Just rootTm <- UniqMap.lookup root bndrs = let used = Lens.foldMapByOf globalIds (unionVarEnvWith (+)) 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. classifyFunction :: Term -> TermClassification classifyFunction = go (TermClassification 0 0 0) where go !c (Lam _ e) = go c e go !c (TyLam _ e) = go c e go !c (Letrec bs _) = List.foldl' go c (map snd bs) go !c e@(App {}) = case fst (collectArgs e) of Prim {} -> c & primitive +~ 1 Var {} -> c & function +~ 1 _ -> c go !c (Case _ _ alts) = case alts of (_:_:_) -> c & selection +~ 1 _ -> c go !c (Tick _ e) = go c e go c _ = c -- | Determine whether a function adds a lot of hardware or not. -- -- It is considered expensive when it has 2 or more of the following components: -- -- * functions -- * primitives -- * selections (multiplexers) isCheapFunction :: Term -> Bool isCheapFunction tm = case classifyFunction tm of TermClassification {..} | _function <= 1 -> _primitive <= 0 && _selection <= 0 | _primitive <= 1 -> _function <= 0 && _selection <= 0 | _selection <= 1 -> _function <= 0 && _primitive <= 0 | otherwise -> False normalizeTopLvlBndr :: Bool -> Id -> Binding Term -> NormalizeSession (Binding Term) normalizeTopLvlBndr isTop nm (Binding nm' sp inl pr tm _) = makeCachedU nm (extra.normalized) $ do tcm <- Lens.view tcCache let nmS = showPpr (varName nm) -- We deshadow the term because sometimes GHC gives us -- code where a local binder has the same unique as a -- global binder, sometimes causing the inliner to go -- into a loop. Deshadowing freshens all the bindings -- to avoid this. let tm1 = deShadowTerm emptyInScopeSet tm tm2 = if isTop then substWithTyEq tm1 else tm1 old <- Lens.use curFun tm3 <- rewriteExpr ("normalization",normalization) (nmS,tm2) (nm',sp) curFun .= old let ty' = inferCoreTypeOf tcm tm3 let r' = nm' `globalIdOccursIn` tm3 return (Binding nm'{varType = ty'} sp inl pr tm3 r') -- | Turn type equality constraints into substitutions and apply them. -- -- So given: -- -- > /\dom . \(eq : dom ~ "System") . \(eta : Signal dom Bool) . eta -- -- we create the substitution [dom := "System"] and apply it to create: -- -- > \(eq : "System" ~ "System") . \(eta : Signal "System" Bool) . eta -- -- __NB:__ Users of this function should ensure it's only applied to TopEntities substWithTyEq :: Term -> Term substWithTyEq e0 = go [] False e0 where go :: [Either Id TyVar] -> Bool -> Term -> Term go args changed (TyLam tv e) = go (Right tv : args) changed e go args changed (Lam v e) | TyConApp (nameUniq -> tcUniq) (tvFirst -> Just (tv, ty)) <- tyView (coreTypeOf v) , tcUniq == getKey eqTyConKey , Right tv `elem` args = let tvs = rights args subst0 = extendTvSubst (mkSubst $ mkInScopeSet $ mkVarSet tvs) tv ty removedTy = substTy subst0 $ coreTypeOf v subst1 = extendIdSubst subst0 v (TyApp (Prim removedArg) removedTy) in go (Left (substId subst0 v) : (args List.\\ [Right tv])) True (substTm "substWithTyEq e" subst1 e) | otherwise = go (Left v : args) changed e go args True e = mkAbstraction e (reverse args) go _ False _ = e0 -- Type equality (~) is symmetrical, so users could write: (dom ~ System) or (System ~ dom) tvFirst :: [Type] -> Maybe (TyVar, Type) tvFirst [_, VarTy tv, ty] = Just (tv, ty) tvFirst [_, ty, VarTy tv] = Just (tv, ty) tvFirst _ = Nothing -- | The type equivalent of 'substWithTyEq' tvSubstWithTyEq :: Type -> Type tvSubstWithTyEq ty0 = go [] False ty0 where go :: [Either TyVar Type] -> Bool -> Type -> Type go argsOut changed (ForAllTy tv ty) = go (Left tv:argsOut) changed ty go argsOut changed (tyView -> FunTy arg tyRes) | Just (tc,tcArgs) <- splitTyConAppM arg , nameUniq tc == getKey eqTyConKey , Just (tv,ty) <- tvFirst tcArgs = let argsOut2 = Right arg : (argsOut List.\\ [Left tv]) subst = extendTvSubst (mkSubst $ mkInScopeSet $ mkVarSet $ lefts argsOut2) tv ty in go argsOut2 True (substTy subst tyRes) | otherwise = go (Right arg : argsOut) changed tyRes go _ False _ = ty0 -- no eq constraints, returning original type go argsOut True tyRes = mkPolyFunTy tyRes (reverse argsOut) -- | Rewrite a term according to the provided transformation rewriteExpr :: (String,NormRewrite) -- ^ Transformation to apply -> (String,Term) -- ^ Term to transform -> (Id, SrcSpan) -- ^ Renew current function being rewritten -> NormalizeSession Term rewriteExpr (nrwS,nrw) (bndrS,expr) (nm, sp) = do curFun .= (nm, sp) opts <- Lens.view debugOpts let before = showPpr expr let expr' = traceIf (hasTransformationInfo FinalTerm opts) (bndrS ++ " before " ++ nrwS ++ ":\n\n" ++ before ++ "\n") expr rewritten <- runRewrite nrwS emptyInScopeSet nrw expr' let after = showPpr rewritten traceIf (hasTransformationInfo FinalTerm opts) (bndrS ++ " after " ++ nrwS ++ ":\n\n" ++ after ++ "\n") $ return rewritten -- | A tick to prefix an inlined expression with it's original name. -- For example, given -- -- foo = bar -- ... -- bar = baz -- ... -- baz = quuz -- ... -- -- if bar is inlined into foo, then the name of the component should contain -- the name of the inlined component. This tick ensures that the component in -- foo is called bar_baz instead of just baz. -- mkInlineTick :: Id -> TickInfo mkInlineTick n = NameMod PrefixName (LitTy . SymTy $ toStr n) where toStr = Text.unpack . snd . Text.breakOnEnd "." . nameOcc . varName clash-lib-1.8.1/src/Clash/Pretty.hs0000644000000000000000000000332707346545000015221 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} module Clash.Pretty where #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter import Prettyprinter.Render.String #else import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.String #endif import Data.Maybe (fromMaybe) import qualified System.Console.Terminal.Size as Terminal import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe) import qualified Clash.Util.Interpolate as I import GHC.Stack (HasCallStack) unsafeLookupEnvWord :: HasCallStack => String -> Word -> Word unsafeLookupEnvWord key dflt = case unsafePerformIO (lookupEnv key) of Nothing -> dflt Just w -> flip fromMaybe (readMaybe w) $ error [I.i| 'unsafeLookupEnvWord' tried to lookup #{key} in the environment. It found it, but couldn't interpret it to as a Word (positive Int). Found: #{w} |] defaultPprWidth :: Int defaultPprWidth = let dflt = max 80 (maybe 80 Terminal.width (unsafePerformIO Terminal.size)) in fromIntegral (unsafeLookupEnvWord "CLASH_PPR_WIDTH" dflt) showDoc :: Doc ann -> String showDoc = let layoutOpts = LayoutOptions (AvailablePerLine defaultPprWidth 0.6) in renderString . layoutPretty layoutOpts removeAnnotations :: Doc ann -> Doc () removeAnnotations = reAnnotate $ const () -- | A variant of @Pretty@ that is not polymorphic on the type of annotations. -- This is needed to derive instances from Clash's pretty printer (PrettyPrec), -- which annotates documents with Clash-specific information and, therefore, -- fixes the type of annotations. class ClashPretty a where clashPretty :: a -> Doc () fromPretty :: Pretty a => a -> Doc () fromPretty = removeAnnotations . pretty clash-lib-1.8.1/src/Clash/Primitives/Annotations/0000755000000000000000000000000007346545000020021 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Primitives/Annotations/SynthesisAttributes.hs0000644000000000000000000000520207346545000024414 0ustar0000000000000000{-# 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 clash-lib-1.8.1/src/Clash/Primitives/0000755000000000000000000000000007346545000015524 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Primitives/DSL.hs0000644000000000000000000010667507346545000016521 0ustar0000000000000000{-| 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. This module contains a mini dsl for creating haskell blackbox instantiations. -} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Clash.Primitives.DSL ( -- * Annotations BlackBoxHaskellOpts(..) , blackBoxHaskell -- * Declarations , BlockState (..) , TExpr(..) , addDeclaration , assign , compInBlock , declaration , declarationReturn , declare , declareN , instDecl , instHO , viaAnnotatedSignal -- ** Literals , bvLit , LitHDL (..) , pattern High , pattern Low , constructProduct , tuple , vec -- ** Extraction , tInputs , tResults , getStr , getBool , getVec , exprToInteger , tExprToInteger , deconstructProduct , untuple , unvec , deconstructMaybe -- ** Conversion , bitCoerce , toBV , toBvWithAttrs , fromBV , enableToBit , boolToBit , boolFromBit , boolFromBitVector , unsignedFromBitVector , boolFromBits , unsafeToActiveHigh , unsafeToActiveLow -- ** Operations , andExpr , notExpr , pureToBV , pureToBVResized , open -- ** Utilities , clog2 , litTExpr , toIdentifier , tySize ) 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) import qualified Data.IntMap as IntMap import Data.List (intersperse) import Data.List.Extra (zipEqual) import Data.Maybe (fromMaybe) import Data.Monoid (Ap(getAp)) import Data.Semigroup hiding (Product) import Data.String import Data.Text (Text) import qualified Data.Text as Text import Data.Text.Extra (showt) import Data.Text.Prettyprint.Doc.Extra import GHC.Stack (HasCallStack) import Clash.Annotations.Primitive (HDL (..), Primitive (..)) import Clash.Annotations.SynthesisAttributes (Attr) import Clash.Backend hiding (Usage, fromBV, toBV) import Clash.Backend.VHDL (VHDLState) 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 import Clash.Netlist.Types hiding (Component, toBit) import Clash.Netlist.Util import Clash.Util (clogBase) import qualified Data.String.Interpolate as I import Language.Haskell.TH (Name) import Prelude -- | Options for 'blackBoxHaskell' function. Use 'def' from package -- 'data-default' for a set of default options. data BlackBoxHaskellOpts = BlackBoxHaskellOpts { -- | Arguments to ignore (i.e., remove during normalization) -- -- Default: [] bo_ignoredArguments :: [Int] -- | HDLs to use the blackbox for -- -- Default: all , bo_supportedHdls :: [HDL] -- | Does this blackbox assign its results to multiple binders? -- -- Default: False. , bo_multiResult :: Bool } instance Default BlackBoxHaskellOpts where def = BlackBoxHaskellOpts { bo_ignoredArguments = [] , bo_supportedHdls = [minBound..maxBound] , bo_multiResult = False } -- | Create a blackBoxHaskell primitive. To be used as part of an annotation: -- -- @ -- {-\# ANN myFunction (blackBoxHaskell 'myFunction 'myBBF def{bo_ignoredArguments=[1,2]}) \#-} -- @ -- -- @[1,2]@ would mean this blackbox __ignores__ its second and third argument. blackBoxHaskell :: Name -- ^ blackbox name -> Name -- ^ template function name -> BlackBoxHaskellOpts -- ^ Options, see data structure for more information -> Primitive blackBoxHaskell bb tf BlackBoxHaskellOpts{..} = InlineYamlPrimitive bo_supportedHdls [I.__i| BlackBoxHaskell: name: #{bb} templateFunction: #{tf} ignoredArguments : #{bo_ignoredArguments} multiResult : #{toYamlBool bo_multiResult} |] where toYamlBool :: Bool -> String toYamlBool True = "true" toYamlBool False = "false" -- | The state of a block. Contains a list of declarations and a the -- backend state. data BlockState backend = BlockState { _bsDeclarations :: [Declaration] -- ^ Declarations store , _bsHigherOrderCalls :: IntMap Int -- ^ Tracks how many times a higher order function has been instantiated. -- Needed to fill in the second field of 'Clash.Netlist.BlackBox.Types.Decl' , _bsBackend :: backend -- ^ Backend state } makeLenses ''BlockState instance Backend backend => HasIdentifierSet (BlockState backend) where 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 , eex :: Expr } deriving Show makeLenses ''TExpr -- | Run a block declaration. Assign the result of the block builder to the -- result variable in the given blackbox context. declarationReturn :: Backend backend => BlackBoxContext -> Text.Text -- ^ block name -> State (BlockState backend) [TExpr] -- ^ block builder yielding an expression that should be assigned to the -- result variable in the blackbox context -> State backend Doc -- ^ pretty printed block declarationReturn bbCtx blockName blockBuilder = declaration blockName $ do res <- blockBuilder 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 => Text.Text -- ^ block name -> State (BlockState backend) () -- ^ block builder -> State backend Doc -- ^ pretty printed block declaration blockName c = do backend0 <- get let initState = emptyBlockState backend0 (BlockState {..}) = execState c initState put _bsBackend blockNameUnique <- Id.makeBasic blockName getAp $ blockDecl blockNameUnique (reverse _bsDeclarations) -- | Add a declaration to the state. addDeclaration :: Declaration -> State (BlockState backend) () addDeclaration dec = bsDeclarations %= cons dec -- | Declare a new signal with the given name and type. declare' :: Backend backend => Text -- ^ Name hint -> HWType -- ^ Type of new signal -> State (BlockState backend) Identifier -- ^ Expression pointing the the new signal declare' decName ty = do uniqueName <- Id.makeBasic decName addDeclaration (NetDecl' Nothing uniqueName ty Nothing) pure uniqueName -- | Declare a new signal with the given name and type. declare :: Backend backend => Text -- ^ Name hint -> HWType -- ^ Type of new signal -> State (BlockState backend) TExpr -- ^ Expression pointing the the new signal 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 :: Backend backend => Text -- ^ Name hint for assignment -> TExpr -- ^ 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 <- 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 -- to them. If given expression is not an identifier, an intermediate variable -- will be used to assign the given expression to which is subsequently indexed. unvec :: (HasCallStack, Backend backend) => Text -- ^ Name hint for intermediate signal -> TExpr -- ^ Vector expression -> State (BlockState backend) [TExpr] -- ^ Vector elements unvec vName v@(ety -> Vector vSize eType) = do 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. deconstructProduct :: (HasCallStack, Backend backend) => TExpr -- ^ Product expression -> [Text] -- ^ Name hints for element assignments -> State (BlockState backend) [TExpr] 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 -- | Extract the elements of a tuple expression and return expressions -- to them. These new expressions are given unique names and get -- declared in the block scope. untuple :: (HasCallStack, Backend backend) => TExpr -- ^ Tuple expression -> [Text] -- ^ Name hints for element assignments -> State (BlockState backend) [TExpr] untuple = deconstructProduct -- | The high literal bit. pattern High :: TExpr pattern High <- TExpr Bit (Literal _ (BitLit H)) where High = TExpr Bit (Literal (Just (Bit,1)) (BitLit H)) -- | The low literal bit. pattern Low :: TExpr pattern Low <- TExpr Bit (Literal _ (BitLit L)) where Low = TExpr Bit (Literal (Just (Bit,1)) (BitLit L)) -- | The true literal bool. pattern T :: TExpr pattern T <- TExpr Bool (Literal _ (BoolLit True)) where T = TExpr Bool (Literal (Just (Bool,1)) (BoolLit True)) -- | The false literal bool. pattern F :: TExpr pattern F <- TExpr Bool (Literal _ (BoolLit False)) where F = TExpr Bool (Literal (Just (Bool,1)) (BoolLit False)) -- | Construct a fully defined BitVector literal bvLit :: Int -- ^ BitVector size -> Integer -- ^ Literal -> TExpr bvLit sz n = TExpr (BitVector sz) (Literal (Just (BitVector sz, sz)) (BitVecLit 0 n)) -- | Convert a bool to a bit. boolToBit :: (HasCallStack, Backend backend) => Text -- ^ Name hint for intermediate signal -> TExpr -> State (BlockState backend) TExpr boolToBit bitName = \case T -> pure High F -> pure Low TExpr Bool boolExpr -> do 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" -- | Convert an enable to a bit. enableToBit :: (HasCallStack, Backend backend) => Text -- ^ Name hint for intermediate signal -> TExpr -> State (BlockState backend) TExpr enableToBit bitName = \case TExpr ena@(Enable _) enableExpr -> do 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" -- | Use to create an output `Bool` from a `Bit`. The expression given -- must be the identifier of the bool you wish to get assigned. -- Returns a reference to a declared `Bit` that should get assigned -- by something (usually the output port of an entity). boolFromBit :: (HasCallStack, Backend backend) => Text -- ^ Name hint for intermediate signal -> TExpr -> 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. -- -- TODO: Implement for (System)Verilog boolFromBitVector :: Size -> Text -- ^ Name hint for intermediate signal -> TExpr -> State (BlockState VHDLState) TExpr boolFromBitVector n = outputCoerce (BitVector n) Bool (\i -> "unsigned(" <> i <> ") > 0") -- | Used to create an output `Unsigned` from a `BitVector` of given -- size. Works in a similar way to `boolFromBit` above. 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 -- references to declared values (the inputs to the function) which -- should get assigned by something---usually output ports of an -- entity. -- -- TODO: Implement for (System)Verilog boolFromBits :: [Text] -> TExpr -> State (BlockState VHDLState) [TExpr] boolFromBits inNames = outputFn (map (const Bit) inNames) Bool (foldl (<>) "" . intersperse " and " . map (\i -> "(" <> i <> " = '1')")) inNames -- | Used to create an output value with an arbitrary VHDL coercion. -- The expression given should be the identifier of the output value -- you wish to get assigned. Returns a reference to a declared value -- of the input type that should get assigned by something (usually -- the output port of an entity). outputCoerce :: (HasCallStack, Backend backend) => HWType -> HWType -> (Text -> Text) -> Text -> TExpr -> State (BlockState backend) TExpr outputCoerce fromType toType exprStringFn inName0 expr_ | TExpr outType (Identifier outName Nothing) <- expr_ , outType == toType = do inName1 <- Id.makeBasic inName0 let inName2 = Id.unsafeMake (exprStringFn (Id.toText inName1)) exprIdent = Identifier inName2 Nothing addDeclaration (NetDecl Nothing inName1 fromType) 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 -- | Used to create an output value that is an arbitrary function (as -- VHDL) of existing values. The expression given should be the -- identifier of the output value you wish to get assigned. Similarly -- to `untuple`, it returns a list of references to declared values -- (the inputs to the function) which should get assigned by -- something---usually output ports of an entity. outputFn :: (HasCallStack, Backend backend) => [HWType] -> HWType -> ([Text] -> Text) -> [Text] -> TExpr -> State (BlockState backend) [TExpr] outputFn fromTypes toType exprFn inNames0 (TExpr outType (Identifier outName Nothing)) | outType == toType = do inNames1 <- mapM Id.makeBasic inNames0 let idExpr = Id.unsafeMake (exprFn (map Id.toText inNames1)) exprIdent = Identifier idExpr Nothing sequenceOf_ each [ addDeclaration (NetDecl Nothing nm t) | (nm, t) <- zip inNames1 fromTypes ] addDeclaration (Assignment outName Cont exprIdent) pure [ TExpr t (Identifier nm Nothing) | (nm,t) <- zipEqual inNames1 fromTypes ] outputFn _ outType _ _ texpr = error $ "outputFn: the expression " <> show texpr <> " must be an Identifier with type " <> show outType -- | Create a vector of 'TExpr's vec :: (HasCallStack, Backend backend) => [TExpr] -- ^ Elements of vector -> State (BlockState backend) TExpr -- ^ Vector elements vec els@(el:_) | all (\e -> ety e == ety el) els = pure (TExpr (Vector (length els) (ety el)) theVec) | otherwise = error $ "vec: elements not of same type: " ++ show els where theVec = mkVectorChain (length els) (ety el) (map eex els) vec [] = error "vec: can't be used on empty lists" -- | Construct a product type given its type and fields constructProduct :: HWType -> [TExpr] -> TExpr constructProduct ty els = TExpr ty (DataCon ty (DC (ty,0)) (map eex els)) -- | Create an n-tuple of 'TExpr' tuple :: HasCallStack => [TExpr] -> TExpr tuple [] = error $ "nTuple: Cannot create empty tuple" tuple [_] = -- If we don't put this in: tuple . untuple /= id error $ "nTuple: Cannot create 1-tuple" tuple els = constructProduct tupTy els where commas = Text.replicate (length els - 1) "," tupTy = Product ("GHC.Tuple.(" <> commas <> ")") Nothing (map ety els) -- | Try to get the literal string value of an expression. getStr :: TExpr -> Maybe String getStr (TExpr _ e) = exprToString e -- | Try to get the literal bool value of an expression. getBool :: TExpr -> Maybe Bool 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 exprToInteger :: Expr -> Maybe Integer exprToInteger (DataCon _ _ [n]) = exprToInteger n exprToInteger (Literal _ (NumLit n)) = Just n exprToInteger _ = Nothing -- | 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 -- | 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) => -- | 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 tySize :: Num i => HWType -> i tySize = fromIntegral . typeSize -- | A literal that can be used for hdl attributes. It has a `Num` and -- `IsString` instances for convenience. data LitHDL = B Bool | S String | I Integer deriving Show instance Num LitHDL where (+) = undefined (*) = undefined abs = undefined signum = undefined negate = undefined fromInteger = I instance IsString LitHDL where fromString = S -- | Instantiate/call a higher-order function. instHO :: Backend backend => BlackBoxContext -- ^ BlackBoxContext, used for rendering higher-order function and error -- reporting -> Int -- ^ Position of HO-argument. For example: -- -- > 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 -- -- would have it at position 1. -> (HWType, BlackBoxTemplate) -- ^ Result type of HO function -> [(TExpr, BlackBoxTemplate)] -- ^ Arguments and their types -> State (BlockState backend) TExpr -- ^ Result of the function instHO bbCtx fPos (resTy, bbResTy) argsWithTypes = do let (args0, argTypes) = unzip argsWithTypes fSubPos <- fromMaybe 0 . IntMap.lookup fPos <$> use bsHigherOrderCalls bsHigherOrderCalls %= IntMap.insert fPos (succ fSubPos) -- Create argument identifiers, example: fold_ho3_0_arg0 let ctxName = last (Text.split (=='.') (bbName bbCtx)) baseArgName = ctxName <> "_" <> "ho" <> showt fPos <> "_" <> showt fSubPos argName n = baseArgName <> "_arg" <> showt n args1 <- zipWithM (\argN -> toIdentifier' (argName argN)) [(0::Int)..] args0 let args2 = map (pure . Text . Id.toLazyText) args1 resName <- declare' (ctxName <> "_" <> "ho" <> showt fPos <> "_" <> showt fSubPos <> "_res") resTy let res = ([Text (Id.toLazyText resName)], bbResTy) -- Render HO argument to plain text let component = Component (Decl fPos fSubPos (res:zip args2 argTypes)) rendered0 <- zoom bsBackend (string =<< (renderElem bbCtx component <*> pure 0)) let layout = LayoutOptions (AvailablePerLine 120 0.4) rendered1 = renderLazy (layoutPretty layout rendered0) addDeclaration $ BlackBoxD ("__INST_" <> bbName bbCtx <> "_BB_INTERNAL__") [] [] [] (BBTemplate [Text rendered1]) (emptyBBContext ("__INST_" <> bbName bbCtx <> "_BB_INTERNAL__")) pure (TExpr resTy (Identifier resName Nothing)) -- | 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 -> Identifier -- ^ Instantiation label -> [(Text, TExpr)] -- ^ Generics / parameters -> [(Text, TExpr)] -- ^ In ports -> [(Text, TExpr)] -- ^ Out ports -> State (BlockState backend) () instDecl entOrComp compName instLbl params inPorts outPorts = do inPorts' <- mapM (mkPort In) inPorts outPorts' <- mapM (mkPort Out) outPorts addDeclaration $ InstDecl entOrComp Nothing [] compName instLbl (mkParams params) (NamedPortMap (inPorts' ++ outPorts')) where mkPort :: PortDirection -> (Text, TExpr) -> StateT (BlockState backend) Identity (Expr, PortDirection, HWType, Expr) mkPort inOrOut (nmText, pExpr) = do TExpr ty pExpr' <- toIdentifier (nmText <> "_port") pExpr pure (Identifier (Id.unsafeMake nmText) Nothing, inOrOut, ty, pExpr') -- 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 -- annotated type, using the given attributes. viaAnnotatedSignal :: (HasCallStack, Backend backend) => Identifier -- ^ Name given to signal -> TExpr -- ^ expression the signal is assigned to -> TExpr -- ^ expression (must be identifier) to which the signal is assigned -> [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 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." viaAnnotatedSignal _ _ outTExpr _ = error $ "viaAnnotatedSignal: The out expression \"" <> show outTExpr <> "\" must be an Identifier." -- | The TExp inputs from a blackbox context. tInputs :: BlackBoxContext -> [(TExpr, HWType)] tInputs = map (\(x, t, _) -> (TExpr t x, t)) . bbInputs -- | The TExp result of a blackbox context. tResults :: BlackBoxContext -> [TExpr] tResults = map (\(x,t) -> TExpr t x) . bbResults -- | Get an identifier to an expression, creating a new assignment if -- necessary. toIdentifier' :: Backend backend => Text -- ^ desired new identifier name, will be made unique -> TExpr -- ^ expression to get identifier of -> State (BlockState backend) Identifier -- ^ identifier to expression toIdentifier' _ (TExpr _ (Identifier aExpr Nothing)) = pure aExpr toIdentifier' nm texp = do 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 -- necessary. toIdentifier :: Backend backend => Text -- ^ desired new identifier name, will be made unique -> TExpr -- ^ expression to get identifier of -> State (BlockState backend) TExpr -- ^ identifier to expression toIdentifier nm texp = do id' <- toIdentifier' nm texp pure (TExpr (ety texp) (Identifier id' Nothing)) -- | And together @(&&)@ two expressions, assigning it to a new identifier. andExpr :: Backend backend => Text -- ^ name hint -> TExpr -- ^ a -> TExpr -- ^ a -> State (BlockState backend) TExpr -- ^ a && b andExpr _ T bExpr = pure bExpr andExpr _ F _ = pure F andExpr _ aExpr T = pure aExpr andExpr _ _ F = pure F andExpr nm a b = do aIdent <- Id.toText <$> toIdentifier' (nm <> "_a") a bIdent <- Id.toText <$> toIdentifier' (nm <> "_b") b -- This is somewhat hacky and relies on the fact that clash doesn't -- postprocess the text in Identifier. The alternative is to run -- this as a fully fledged @BlackBoxE@ but that involves a lot of -- faffing. It should be reasonably safe because we assign each side -- to an identifier if it isn't already. andTxt <- uses bsBackend hdlKind <&> \case VHDL -> aIdent <> " and " <> bIdent Verilog -> aIdent <> " && " <> bIdent 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@ -> State (BlockState backend) TExpr -- ^ @not a@ notExpr _ T = pure F notExpr _ F = pure T notExpr nm aExpr = do aIdent <- Id.toText <$> toIdentifier' (nm <> "_a") aExpr -- See disclaimer in `andExpr` above. notTxt <- uses bsBackend hdlKind <&> \case VHDL -> "not " <> aIdent Verilog -> "! " <> aIdent SystemVerilog -> "! " <> aIdent assign nm $ TExpr Bit (Identifier (Id.unsafeMake notTxt) Nothing) -- | Creates a BV that produces the following vhdl: -- -- @ -- (0 to n => ARG) -- @ -- -- TODO: Implement for (System)Verilog pureToBV :: Text -- ^ name hint -> Int -- ^ Size (n) -> TExpr -- ^ @ARG@ -> State (BlockState VHDLState) TExpr -- ^ @(0 to n => ARG)@ pureToBV nm n arg = do arg' <- Id.toText <$> toIdentifier' nm arg -- This is very hard coded and hacky let text = "(0 to " <> showt n <> " => " <> arg' <> ")" assign nm $ TExpr (BitVector (n+1)) (Identifier (Id.unsafeMake text) Nothing) -- | Creates a BV that produces the following vhdl: -- -- @ -- std_logic_vector(resize(ARG, n)) -- @ -- -- TODO: Implement for (System)Verilog pureToBVResized :: Text -- ^ name hint -> Int -- ^ Size (n) -> TExpr -- ^ ARG -> State (BlockState VHDLState) TExpr -- ^ @std_logic_vector(resize(ARG, n))@ pureToBVResized nm n arg = do arg' <- Id.toText <$> toIdentifier' nm arg -- This is very hard coded and hacky let text = "std_logic_vector(resize(" <> arg' <> ", " <> showt n <> "))" assign nm $ TExpr (BitVector n) (Identifier (Id.unsafeMake text) Nothing) -- | Allows assignment of a port to be "open" open :: Backend backend => HWType -> State (BlockState backend) TExpr open hwType = pure $ TExpr hwType (Identifier (Id.unsafeMake "open") Nothing) clash-lib-1.8.1/src/Clash/Primitives/GHC/0000755000000000000000000000000007346545000016125 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Primitives/GHC/Int.hs0000644000000000000000000000372307346545000017220 0ustar0000000000000000{-| Copyright : (C) 2019, Myrtle Software Ltd License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij 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(..)) import Clash.Core.Term (Term(Literal)) import Clash.Core.Type (Type) import Clash.Primitives.GHC.Literal (literalTF, signed, signedLiteral, assign) import Clash.Netlist.Types (BlackBox(BBTemplate)) import Clash.Netlist.BlackBox.Types (BlackBoxFunction, Element(Arg, Result), emptyBlackBoxMeta ,BlackBoxMeta, bbKind, TemplateKind(TDecl)) getIntLit :: Literal -> Maybe Integer getIntLit = \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 -- | Template function for Int8,Int16,.. Constructs "clean" literals. intTF :: BlackBoxFunction intTF = literalTF "GHC.Int.I" intTF' intTF' :: Bool -- ^ Is declaration -> [Either Term Type] -- ^ Arguments -> Int -- ^ Word size -> (BlackBoxMeta, BlackBox) intTF' False [Left (Literal (getIntLit -> Just n))] intSize = -- Literal as expression: ( emptyBlackBoxMeta , BBTemplate [signedLiteral intSize n]) intTF' True [Left (Literal (getIntLit -> Just n))] intSize = -- Literal as declaration: ( emptyBlackBoxMeta , BBTemplate (assign Result [signedLiteral intSize n])) intTF' _isDecl _args _intSize = -- Not a literal. We need an assignment as Verilog does not support truncating -- arbitrary expression. ( emptyBlackBoxMeta {bbKind = TDecl } , BBTemplate (assign Result (signed (Arg 0)))) clash-lib-1.8.1/src/Clash/Primitives/GHC/Literal.hs0000644000000000000000000000454507346545000020065 0ustar0000000000000000{-| Copyright : (C) 2019, Myrtle Software Ltd License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij Blackbox generation for literal data constructors. (System)Verilog only! -} {-# LANGUAGE OverloadedStrings #-} module Clash.Primitives.GHC.Literal ( assign , signed , signedLiteral , unsigned , unsignedLiteral , literalTF ) where import qualified Data.Text.Lazy as LT import Data.Text (Text, stripPrefix, stripSuffix, unpack) import Data.Text.Extra (showtl) import Text.Read (readMaybe) import Clash.Core.Term (Term) import Clash.Core.Type (Type) import Clash.Netlist.Types (BlackBox) import Clash.Netlist.BlackBox.Types (BlackBoxFunction, Element(Text), BlackBoxMeta) unsigned :: Element -> [Element] unsigned el = [Text "$unsigned(", el, Text ")"] signed :: Element -> [Element] signed el = [Text "$signed(", el, Text ")"] assign :: Element -> [Element] -> [Element] assign lhs rhs = Text "assign " : lhs : Text " = " : rhs ++ [Text ";"] signedLiteral :: Int -> Integer -> Element signedLiteral wordSize wordVal = Text (LT.concat [ if wordVal < 0 then "-" else "" , showtl wordSize , "'sd" , showtl (abs wordVal) ]) unsignedLiteral :: Int -> Integer -> Element unsignedLiteral wordSize wordVal = Text (LT.concat [ if wordVal < 0 then "-" else "" , showtl wordSize , "'d" , showtl (abs wordVal) ]) -- | Parse integer in strings of the form "GHC.Word.WordX#" where -- "GHC.Word.Word" is the prefix given. readSize :: Text -> Text -> Maybe Int readSize prefix nm0 = do nm1 <- stripPrefix prefix nm0 nm2 <- stripSuffix "#" nm1 readMaybe (unpack nm2) -- | Constructs "clean" literals. literalTF :: Text -- ^ Base name of constructors (for example: "GHC.Word.W") -> (Bool -> [Either Term Type] -> Int -> (BlackBoxMeta, BlackBox)) -- ^ Functions processing -> BlackBoxFunction literalTF baseName tf isDecl primName args _resTy = return $ case readSize baseName primName of Nothing -> Left (concat ["Can only make blackboxes for '", unpack baseName, "X#'"]) Just n -> Right (tf isDecl args n) clash-lib-1.8.1/src/Clash/Primitives/GHC/Word.hs0000644000000000000000000000400507346545000017373 0ustar0000000000000000{-| Copyright : (C) 2019, Myrtle Software Ltd License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij 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(..)) import Clash.Core.Term (Term(Literal)) import Clash.Core.Type (Type) import Clash.Primitives.GHC.Literal (literalTF, unsigned, unsignedLiteral, assign) import Clash.Netlist.Types (BlackBox(BBTemplate)) import Clash.Netlist.BlackBox.Types (BlackBoxFunction, Element(Arg, Result), emptyBlackBoxMeta ,BlackBoxMeta, bbKind, TemplateKind(TDecl)) -- | Template function for Word8,Word16,.. Constructs "clean" literals. This -- function generates valid (System)Verilog only! 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 -> [Either Term Type] -- ^ Arguments -> Int -- ^ Word size -> (BlackBoxMeta, BlackBox) wordTF' False [Left (Literal (getWordLit -> Just n))] wordSize = -- Literal as expression: ( emptyBlackBoxMeta , BBTemplate [unsignedLiteral wordSize n]) wordTF' True [Left (Literal (getWordLit -> Just n))] wordSize = -- Literal as declaration: ( emptyBlackBoxMeta , BBTemplate (assign Result [unsignedLiteral wordSize n])) wordTF' _isDecl _args _wordSize = -- Not a literal. We need an assignment as Verilog does not support truncating -- arbitrary expression. ( emptyBlackBoxMeta {bbKind = TDecl } , BBTemplate (assign Result (unsigned (Arg 0)))) clash-lib-1.8.1/src/Clash/Primitives/Intel/0000755000000000000000000000000007346545000016577 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Primitives/Intel/ClockGen.hs0000644000000000000000000002333707346545000020630 0ustar0000000000000000{-| Copyright : (C) 2018 , Google Inc., 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 -} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ViewPatterns #-} 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 qualified Clash.Netlist.Id as Id import Clash.Netlist.Types import Clash.Netlist.Util 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 qualified Prettyprinter.Interpolate as I data Variant = Altpll | AlteraPll hdlUsed :: [Int] hdlUsed = [ clk, rst ] where _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 qsysUsed valid altpllQsysTemplate where valid = const True alteraPllTF :: TemplateFunction alteraPllTF = TemplateFunction hdlUsed hdlValid (hdlTemplate AlteraPll) alteraPllQsysTF :: TemplateFunction alteraPllQsysTF = TemplateFunction qsysUsed valid alteraPllQsysTemplate where valid = const True 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" 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 compNameId = Id.unsafeMake compName DSL.declarationReturn bbCtx (stdName variant <> "_block") $ 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 -> 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)] 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 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 clkFreq p = periodToHz (fromInteger p) / 1e6 :: Double clkOutPeriods = map clkPeriod kdOuts clkLcms = map (lcm clkInPeriod) clkOutPeriods clkMults = zipWith quot clkLcms clkOutPeriods clkDivs = map (`quot` clkInPeriod) clkLcms clkOutFreqs = map clkFreq clkOutPeriods qsysParams = TextS.intercalate "\n " [[I.__i| |] | (clkMult, clkDiv, n) <- zip3 clkMults clkDivs [(0 :: Word)..] ] 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 | (_,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.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.__di| #{clkOuts} |] in pure bbText | otherwise = error $ ppShow bbCtx clash-lib-1.8.1/src/Clash/Primitives/Magic.hs0000644000000000000000000000163207346545000017102 0ustar0000000000000000{-| 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 clash-lib-1.8.1/src/Clash/Primitives/Sized/0000755000000000000000000000000007346545000016602 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Primitives/Sized/Signed.hs0000644000000000000000000000331307346545000020347 0ustar0000000000000000{-| Copyright : (C) 2021-2022, QBayLogic License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. VHDL Blackbox implementations for "Clash.Sized.Internal.Signed.toInteger#". -} {-# LANGUAGE OverloadedStrings #-} module Clash.Primitives.Sized.Signed (fromIntegerTFvhdl) where import Control.Monad.State (State) import Data.Monoid (Ap(getAp)) import Data.Text.Prettyprint.Doc.Extra (Doc, tupled) import Clash.Backend (Backend, expr) import Clash.Netlist.Types (BlackBoxContext (..), Expr (..), HWType (..), Literal (..), Modifier (..), TemplateFunction (..)) fromIntegerTFvhdl :: TemplateFunction fromIntegerTFvhdl = TemplateFunction used valid fromIntegerTFTemplateVhdl where used = [0,1] valid bbCtx = case bbInputs bbCtx of [kn,_] -> case kn of (Literal _ (NumLit _),_,True) -> True _ -> False _ -> False fromIntegerTFTemplateVhdl :: Backend s => BlackBoxContext -> State s Doc 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) m1 = Just (maybe sl (`Nested` sl) m) in expr False (Identifier iV m1) _ -> "signed(std_logic_vector(resize(unsigned(std_logic_vector(" <> expr False i <> "))," <> expr False (Literal Nothing (NumLit sz)) <> ")))" 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)) clash-lib-1.8.1/src/Clash/Primitives/Sized/ToInteger.hs0000644000000000000000000002031507346545000021037 0ustar0000000000000000{-| Copyright : (C) 2020,2022 QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Blackbox implementations for "Clash.Sized.Internal.*.toInteger#". -} {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} module Clash.Primitives.Sized.ToInteger ( bvToIntegerVerilog , bvToIntegerVHDL , indexToIntegerVerilog , indexToIntegerVHDL , signedToIntegerVerilog , signedToIntegerVHDL , unsignedToIntegerVerilog , unsignedToIntegerVHDL ) where import qualified Control.Lens as Lens import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Data.Text.Lazy (pack) import System.IO (hPutStrLn, stderr) import Text.Trifecta.Result (Result(Success)) #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 (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>)) import qualified GHC.Utils.Outputable as Outputable import GHC.Types.SrcLoc (isGoodSrcSpan) #else import DynFlags (unsafeGlobalDynFlags) import ErrUtils (mkPlainWarnMsg, pprLocErrMsg) import Outputable (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>)) import qualified Outputable import SrcLoc (isGoodSrcSpan) #endif import Clash.Annotations.Primitive (HDL (Verilog,VHDL)) import Clash.Core.Type (Type (LitTy), LitTy (NumTy)) import Clash.Netlist.BlackBox.Parser (runParse) import Clash.Netlist.BlackBox.Types (BlackBoxFunction, BlackBoxMeta (bbKind), TemplateKind (TExpr), emptyBlackBoxMeta) import Clash.Netlist.Types (BlackBox (BBTemplate), HWType (..), curCompNm, intWidth) import Clash.Util (clogBase) bvToIntegerVerilog, bvToIntegerVHDL, indexToIntegerVerilog, indexToIntegerVHDL, signedToIntegerVerilog, signedToIntegerVHDL, unsignedToIntegerVerilog, unsignedToIntegerVHDL :: BlackBoxFunction bvToIntegerVerilog = toIntegerBB Verilog (BitVector 0) bvToIntegerVHDL = toIntegerBB VHDL (BitVector 0) indexToIntegerVerilog = toIntegerBB Verilog (Index 0) indexToIntegerVHDL = toIntegerBB VHDL (Index 0) signedToIntegerVerilog = toIntegerBB Verilog (Signed 0) signedToIntegerVHDL = toIntegerBB VHDL (Signed 0) unsignedToIntegerVerilog = toIntegerBB Verilog (Unsigned 0) unsignedToIntegerVHDL = toIntegerBB VHDL (Unsigned 0) toIntegerBB :: HDL -> HWType -> BlackBoxFunction toIntegerBB hdl hty _isD _primName args _ty = do case args of (Right (LitTy (NumTy i)):_) -> do iw <- Lens.view intWidth let i1 = width i when (fromInteger i1 > iw) $ do (_,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 warnMsg2)) _ -> return () return ((meta,) <$> bb) where meta = emptyBlackBoxMeta{bbKind=TExpr} bb = BBTemplate <$> case runParse (pack bbText) of Success t -> Right t _ -> Left "internal error: parse fail" bbText = case hdl of VHDL -> case hty of BitVector {} -> "~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(unsigned(~ARG[1]),~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI" Index {} -> "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI" Signed {} -> "~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEto_signed(0,64)~FI" Unsigned {} -> "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI" _ -> error "internal error" _ -> case hty of BitVector {} -> "~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[bv][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[bv][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI" Index {} -> "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$unsigned(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI" Signed {} -> "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$signed(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI" Unsigned {} -> "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$unsigned(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI" _ -> error "internal error" tyName = case hty of BitVector {} -> text "BitVector" Index {} -> text "Index" Signed {} -> text "Signed" Unsigned {} -> text "Unsigned" _ -> error "internal error" width i = case hty of Index {} -> maybe 0 toInteger (clogBase 2 i) _ -> i warnMsg i iw = tyName Outputable.<> text ".toInteger: Integer width," <+> int iw Outputable.<> text ", is smaller than" <+> tyName <+> text "width," <+> integer i Outputable.<> text ". Dropping MSBs." $+$ text "Are you using 'fromIntegral' to convert between types?" <+> text "Use 'bitCoerce' instead." srcInfo = text "NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." $$ text "The actual location of the error can be in a function that is inlined." $$ text "To prevent inlining of those functions, annotate them with a NOINLINE pragma." clash-lib-1.8.1/src/Clash/Primitives/Sized/Vector.hs0000644000000000000000000002631607346545000020410 0ustar0000000000000000{-| Copyright : (C) 2020-2022 QBayLogic B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Blackbox implementations for functions in "Clash.Sized.Vector". -} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Primitives.Sized.Vector where import Control.Monad (replicateM, zipWithM) import Control.Monad.State (State) import qualified Control.Lens as Lens import Data.Either (rights) import Data.List.Extra (iterateNM) import Data.Maybe (fromMaybe, listToMaybe) import Data.Monoid (Ap(getAp)) import Data.Text.Extra (showt) 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 GHC.Stack (HasCallStack) import Clash.Backend (Backend, hdlTypeErrValue, expr, blockDecl) import Clash.Core.TermInfo (isVar) import Clash.Core.Type (Type(LitTy), LitTy(NumTy), coreView) import Clash.Netlist.BlackBox (isLiteral) import Clash.Netlist.BlackBox.Util (renderElem) import Clash.Netlist.BlackBox.Parser (runParse) import Clash.Netlist.BlackBox.Types (BlackBoxFunction, BlackBoxMeta(..), TemplateKind(TExpr, TDecl), Element(Component, Typ, TypElem, Text), Decl(Decl), emptyBlackBoxMeta) import Clash.Netlist.Types (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 import Clash.Primitives.DSL (declarationReturn, instHO, tInputs, tExprToInteger) import Clash.Util (curLoc) -- | Blackbox function for 'Clash.Sized.Vector.iterateI' iterateBBF :: HasCallStack => BlackBoxFunction iterateBBF _isD _primName args _resTy = do tcm <- Lens.view tcCache pure (Right (meta tcm, bb)) where bb = BBFunction "Clash.Primitives.Sized.Vector.iterateBBF" 0 iterateTF vecLength tcm = 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)] } -- | Type signature of function we're generating netlist for: -- -- iterateI :: KnownNat n => (a -> a) -> a -> Vec n a -- iterateTF :: TemplateFunction iterateTF = TemplateFunction [] (const True) iterateTF' iterateTF' :: forall s . (HasCallStack, Backend s) => BlackBoxContext -> State s Doc iterateTF' bbCtx | [ (fromMaybe (error "n") . tExprToInteger -> n, _) , _hoFunction , (a, aType) ] <- tInputs bbCtx , let aTemplateType = [TypElem (Typ (Just 2))] , let inst arg = instHO bbCtx 1 (aType, aTemplateType) [(arg, aTemplateType)] = declarationReturn bbCtx "iterateI" (fmap pure . Prim.vec =<< iterateNM (fromInteger n) inst a) | otherwise = error $ "Unexpected number of arguments: " ++ show (length (bbInputs bbCtx)) data FCall = FCall Identifier -- left Identifier -- right Identifier -- result -- | Calculates the number of function calls needed for an evaluation of -- 'Clash.Sized.Vector.fold', given the length of the vector given to fold. foldFunctionPlurality :: HasCallStack => Int -> Int foldFunctionPlurality 1 = 0 foldFunctionPlurality 2 = 1 foldFunctionPlurality n | n <= 0 = error $ "functionPlurality: unexpected n: " ++ show n | otherwise = let (d, r) = n `divMod` 2 in 1 + foldFunctionPlurality d + foldFunctionPlurality (d+r) -- | Blackbox function for 'Clash.Sized.Vector.fold' foldBBF :: HasCallStack => BlackBoxFunction foldBBF _isD _primName args _resTy = do tcm <- Lens.view tcCache 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: -- -- fold :: (a -> a -> a) -> Vec (n + 1) a -> a -- -- The implementation promises to create a (balanced) tree structure. foldTF :: TemplateFunction foldTF = TemplateFunction [] (const True) foldTF' foldTF' :: forall s . (HasCallStack, Backend s) => BlackBoxContext -> State s Doc foldTF' bbCtx@(bbInputs -> [_f, (vec, vecType@(Vector n aTy), _isLiteral)]) = do -- Create an id for every element in the vector baseId <- Id.make "acc_0" vecIds <- replicateM n (Id.next baseId) vecId <- Id.make "vec" 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 _ -> error "Unexpected result identifier" -- Create a list of function calls to be made (creates identifiers for -- intermediate result signals) (concat -> fCalls, result) <- mkTree 1 vecIds let intermediateResultIds = concatMap (\(FCall l r _) -> [l, r]) fCalls sigDecls = fmap (sigDecl aTy) (result : intermediateResultIds) resultAssign = Assignment resultId Cont (Identifier result Nothing) callDecls <- zipWithM callDecl [0..] fCalls foldNm <- Id.make "fold" getAp $ blockDecl foldNm $ resultAssign : vecAssign : vecDecl : elemAssigns ++ sigDecls ++ callDecls where callDecl :: Int -> FCall -> State s Declaration callDecl fSubPos (FCall a b r) = do rendered0 <- string =<< (renderElem bbCtx call <*> pure 0) let layout = LayoutOptions (AvailablePerLine 120 0.4) rendered1 = renderLazy (layoutPretty layout rendered0) pure ( BlackBoxD "__FOLD_BB_INTERNAL__" [] [] [] (BBTemplate [Text rendered1]) (emptyBBContext "__FOLD_BB_INTERNAL__") ) where call = Component (Decl fPos fSubPos (resEl:aEl:[bEl])) elTyp = [TypElem (Typ (Just vecPos))] resEl = ([Text (Id.toLazyText r)], elTyp) aEl = ([Text (Id.toLazyText a)], elTyp) bEl = ([Text (Id.toLazyText b)], elTyp) -- Argument no. of function fPos = 0 -- Argument no. of vector vecPos = 1 -- Create the whole tree mkTree :: Int -- ^ Current level -> [Identifier] -- ^ Elements left to process -> State s ( [[FCall]] -- function calls to be rendered , Identifier -- result signal ) mkTree _lvl [] = error "Unreachable?" mkTree _lvl [res] = pure ([], res) mkTree lvl results0 = do (calls0, results1) <- mkLevel (lvl, 0) results0 (calls1, result) <- mkTree (lvl+1) results1 pure (calls0 : calls1, result) -- Create a single layer of a tree mkLevel :: (Int, Int) -- ^ (level, offset) -> [Identifier] -> State s ([FCall], [Identifier]) mkLevel (!lvl, !offset) (a:b:rest) = do c <- Id.makeBasic ("acc_" <> showt lvl <> "_" <> showt offset) (calls, results) <- mkLevel (lvl, offset+1) rest pure (FCall a b c:calls, c:results) mkLevel _lvl rest = pure ([], rest) -- Simple wire without comment 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 -- HDL backends as vector indexing. iIndex :: Identifier -> Int -> Expr iIndex vecId i = Identifier vecId (Just (Indexed (vecType, 10, i))) foldTF' args = error $ "Unexpected number of arguments: " ++ show (length (bbInputs args)) indexIntVerilog :: BlackBoxFunction indexIntVerilog _isD _primName args _ty = return bb where meta bbKi = emptyBlackBoxMeta{bbKind=bbKi} bb = case args of [_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 bbTextLitIx of Success t -> Right (meta TDecl, BBTemplate t) _ -> Left "internal error: parse fail" _ -> case runParse bbText of Success t -> Right (meta TDecl, BBTemplate t) _ -> Left "internal error: parse fail" bbText = [I.__i| // index begin ~IF~SIZE[~TYP[1]]~THENwire ~TYPO ~GENSYM[vecArray][0] [0:~LIT[0]-1]; genvar ~GENSYM[i][2]; ~GENERATE for (~SYM[2]=0; ~SYM[2] < ~LIT[0]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3] assign ~SYM[0][(~LIT[0]-1)-~SYM[2]] = ~VAR[vecFlat][1][~SYM[2]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; end ~ENDGENERATE assign ~RESULT = ~SYM[0][~ARG[2]];~ELSEassign ~RESULT = ~ERRORO;~FI // index end |] 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 |] indexIntVerilogTF :: TemplateFunction indexIntVerilogTF = TemplateFunction used valid indexIntVerilogTemplate where used = [1,2] valid = const True indexIntVerilogTemplate :: Backend s => BlackBoxContext -> State s Doc 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 -> 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) | otherwise = error ("indexIntVerilogTemplate: bad bbContext: " <> show bbCtx) clash-lib-1.8.1/src/Clash/Primitives/Types.hs0000644000000000000000000003426507346545000017176 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 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. Type and instance definitions for Primitive -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Primitives.Types ( TemplateSource(..) , TemplateKind(..) , TemplateFormat(..) , BlackBoxFunctionName(..) , Primitive(..) , UsedArguments(..) , GuardedCompiledPrimitive , GuardedResolvedPrimitive , PrimMap , UnresolvedPrimitive , ResolvedPrimitive , ResolvedPrimMap , CompiledPrimitive , CompiledPrimMap ) where 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) import GHC.Stack (HasCallStack) import Text.Read (readMaybe) #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as KeyMap #endif -- | An unresolved primitive still contains pointers to files. type UnresolvedPrimitive = Primitive Text ((TemplateFormat,BlackBoxFunctionName),Maybe TemplateSource) (Maybe S.Text) (Maybe TemplateSource) -- | A parsed primitive does not contain pointers to filesystem files anymore, -- but holds uncompiled @BlackBoxTemplate@s and @BlackBoxFunction@s. type ResolvedPrimitive = Primitive Text ((TemplateFormat,BlackBoxFunctionName),Maybe Text) () (Maybe Text) type GuardedResolvedPrimitive = PrimitiveGuard ResolvedPrimitive type ResolvedPrimMap = PrimMap GuardedResolvedPrimitive -- | A compiled primitive has compiled all templates and functions from its -- @ResolvedPrimitive@ counterpart. The Int in the tuple is a hash of the -- (uncompiled) BlackBoxFunction. type CompiledPrimitive = Primitive BlackBoxTemplate BlackBox () (Int, BlackBoxFunction) type GuardedCompiledPrimitive = PrimitiveGuard CompiledPrimitive type CompiledPrimMap = PrimMap GuardedCompiledPrimitive -- | A @PrimMap@ maps primitive names to a @Primitive@ type PrimMap a = H.HashMap S.Text a -- | A BBFN is a parsed version of a fully qualified function name. It is -- guaranteed to have at least one module name which is not /Main/. data BlackBoxFunctionName = BlackBoxFunctionName [String] String deriving (Eq, Generic, NFData, Binary, Hashable) instance Show BlackBoxFunctionName where show (BlackBoxFunctionName mods funcName) = "BBFN<" ++ intercalate "." mods ++ "." ++ funcName ++ ">" -- | Quick and dirty implementation of Text.splitOn for Strings splitOn :: String -> String -> [String] splitOn (S.pack -> sep) (S.pack -> str) = map S.unpack $ S.splitOn sep str -- | Parses a string into a list of modules and a function name. I.e., it parses -- the string 'Clash.Primitives.Types.parseBBFN' to -- @["Clash", "Primitives",Types"]@ and @"parseBBFN"@. -- The result is stored as a BlackBoxFunctionName. parseBBFN :: HasCallStack => String -> Either String BlackBoxFunctionName parseBBFN bbfn = case splitOn "." bbfn of [] -> Left $ "Empty function name: " ++ bbfn [_] -> Left $ "No module or function defined: " ++ bbfn nms -> let (mods, func) = (init nms, last nms) in let errs = lefts $ checkFunc func : map checkMod mods in case errs of [] -> Right $ BlackBoxFunctionName mods func e:_ -> Left $ "Error while parsing " ++ show bbfn ++ ": " ++ e where checkMod mod' | m':_ <- mod' , isLower m' = Left $ "Module name cannot start with lowercase: " ++ mod' | any (not . isAlphaNum) mod' = Left $ "Module name must be alphanumerical: " ++ mod' | otherwise = Right mod' checkFunc func | f:_ <- func , isUpper f = Left $ "Function name must start with lowercase: " ++ func | otherwise = Right func data TemplateSource = TFile FilePath -- ^ Template source stored in file on filesystem | TInline Text -- ^ Template stored inline deriving (Show, Eq, Hashable, Generic, NFData) data TemplateFormat = TTemplate | THaskell deriving (Show, Generic, Eq, Hashable, NFData) -- | Data type to indicate what arguments are in use by a BlackBox data UsedArguments = UsedArguments [Int] -- ^ Only these are used | IgnoredArguments [Int] -- ^ All but these are used deriving (Show, Generic, Eq, Hashable, NFData, Binary) -- | Externally defined primitive data Primitive a b c d -- | Primitive template written in a Clash specific templating language = BlackBox { name :: !S.Text -- ^ Name of the primitive , workInfo :: WorkInfo -- ^ Whether the primitive does any work, i.e. takes chip area , renderVoid :: RenderVoid -- ^ Whether this primitive should be rendered when its result type is -- void. Defaults to 'NoRenderVoid'. , multiResult :: Bool -- ^ Wether this blackbox assigns its results to multiple variables. See -- 'Clash.Normalize.Transformations.setupMultiResultPrim' , kind :: TemplateKind -- ^ Whether this results in an expression or a declaration , warning :: c -- ^ 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. , 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] -- ^ VHDL only: add /use/ declarations for the given names , functionPlurality :: [(Int, Int)] -- Using map ruins Hashable instance -- ^ Indicates how often a function will be instantiated in a blackbox. For -- example, consider the following higher-order function that creates a tree -- structure: -- -- fold :: (a -> a -> a) -> Vec n a -> a -- -- In order to generate HDL for an instance of fold we need log2(n) calls -- to the first argument, `a -> a -> a` (plus a few more if n is not a -- power of two). Note that this only targets multiple textual instances -- of the function. If you can generate the HDL using a for-loop and only -- need to call ~INST once, you don't have to worry about this option. See -- the blackbox for 'Clash.Sized.Vector.map' for an example of this. -- -- Right now, option can only be generated by BlackBoxHaskell. It cannot be -- used within JSON primitives. To see how to use this, see the Haskell -- blackbox for 'Clash.Sized.Vector.fold'. , includes :: [((S.Text,S.Text),b)] -- ^ Create files to be included with the generated primitive. The fields -- are ((name, extension), content), where content is a template of the file -- Defaults to @[]@ when not specified in the /.primitives/ file , resultNames :: [b] -- ^ (Maybe) Control the generated name of the result , resultInits :: [b] -- ^ (Maybe) Control the initial/power-up value of the result , template :: b -- ^ Used to indiciate type of template (declaration or expression). Will be -- filled with @Template@ or an @Either decl expr@. } -- | Primitive template rendered by a Haskell function (given as raw source code) | BlackBoxHaskell { name :: !S.Text -- ^ Name of the primitive , workInfo :: WorkInfo -- ^ Whether the primitive does any work, i.e. takes chip area , usedArguments :: UsedArguments -- ^ Arguments used by blackbox. Used to remove arguments during normalization. , multiResult :: Bool -- ^ Wether this blackbox assigns its results to multiple variables. See -- 'Clash.Normalize.Transformations.setupMultiResultPrim' , functionName :: BlackBoxFunctionName , function :: d -- ^ Holds blackbox function and its hash, (Int, BlackBoxFunction), in a -- CompiledPrimitive. } -- | A primitive that carries additional information. These are "real" -- primitives, hardcoded in the compiler. For example: 'mapSignal' in -- @GHC2Core.coreToTerm@. | Primitive { name :: !S.Text -- ^ Name of the primitive , workInfo :: WorkInfo -- ^ Whether the primitive does any work, i.e. takes chip area , primSort :: !Text -- ^ Additional information } deriving (Show, Generic, NFData, Binary, Eq, Hashable, Functor) instance FromJSON UnresolvedPrimitive where parseJSON (Object v) = #if MIN_VERSION_aeson(2,0,0) case KeyMap.toList v of #else case H.toList v of #endif [(conKey,Object conVal)] -> case conKey of "BlackBoxHaskell" -> do usedArgs <- conVal .:? "usedArguments" ignoredArgs <- conVal .:? "ignoredArguments" args <- case (usedArgs, ignoredArgs) of (Nothing, Nothing) -> pure (IgnoredArguments []) (Just a, Nothing) -> pure (UsedArguments a) (Nothing, Just a) -> pure (IgnoredArguments a) (Just _, Just _) -> fail "[8] Don't use both 'usedArguments' and 'ignoredArguments'" name' <- conVal .: "name" wf <- ((conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable) fName <- conVal .: "templateFunction" 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 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 .:? "outputUsage" .!= Cont <*> conVal .:? "libraries" .!= [] <*> conVal .:? "imports" .!= [] <*> pure [] -- functionPlurality not supported in json <*> (conVal .:? "includes" .!= [] >>= traverse parseInclude) <*> (conVal .:? "resultName" >>= maybe (pure Nothing) parseResult) .!= [] <*> (conVal .:? "resultInit" >>= maybe (pure Nothing) parseResult) .!= [] <*> parseTemplate conVal "Primitive" -> Primitive <$> conVal .: "name" <*> (conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable <*> conVal .: "primType" e -> fail $ "[1] Expected: BlackBox or Primitive object, got: " ++ show e e -> fail $ "[2] Expected: BlackBox or Primitive object, got: " ++ show e where parseTemplate c = (,) <$> ((,) <$> (c .:? "format" >>= traverse parseTemplateFormat) .!= TTemplate <*> (c .:? "templateFunction" >>= traverse parseBBFN') .!= defTemplateFunction) <*> (Just . TInline <$> c .: "template" <|> Just . TFile <$> c .: "file" <|> pure Nothing) parseInclude c = (,) <$> ((,) <$> c .: "name" <*> c .: "extension") <*> parseTemplate c parseTemplateKind (String "Declaration") = pure TDecl parseTemplateKind (String "Expression") = pure TExpr parseTemplateKind c = fail ("[4] Expected: Declaration or Expression, got " ++ show c) parseTemplateFormat (String "Template") = pure TTemplate parseTemplateFormat (String "Haskell") = pure THaskell parseTemplateFormat c = fail ("[5] unexpected format: " ++ show c) parseWorkInfo (String "Constant") = pure (Just WorkConstant) parseWorkInfo (String "Never") = pure (Just WorkNever) parseWorkInfo (String "Variable") = pure (Just WorkVariable) parseWorkInfo (String "Always") = pure (Just WorkAlways) parseWorkInfo (parseWorkIdentity -> wi@Just{}) = pure wi parseWorkInfo c = fail ("[6] unexpected workInfo: " ++ show c) parseWorkIdentity arg = do String str <- return arg [iStr,xsStr] <- words . S.unpack <$> S.stripPrefix "Identity" str WorkIdentity <$> readMaybe iStr <*> readMaybe xsStr parseBBFN' = either fail return . parseBBFN defTemplateFunction = BlackBoxFunctionName ["Template"] "template" parseResult (Object c) = Just . pure <$> parseTemplate c parseResult e = fail $ "[7] unexpected result: " ++ show e parseJSON unexpected = fail $ "[3] Expected: BlackBox or Primitive object, got: " ++ show unexpected clash-lib-1.8.1/src/Clash/Primitives/Util.hs0000644000000000000000000002567007346545000017007 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2017 , Myrtle Software Ltd 2018 , Google Inc. 2021 , QBayLogic B.V. 2022 , Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Utility functions to generate Primitives -} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Clash.Primitives.Util ( generatePrimMap , hashCompiledPrimMap , constantArgs , decodeOrErrJson , decodeOrErrYaml , getFunctionPlurality ) where import Control.DeepSeq (force) import Control.Monad (forM) import Data.Aeson.Extra (decodeOrErrJson, decodeOrErrYaml) import qualified Data.ByteString.Lazy as LZ import qualified Data.HashMap.Lazy as HashMap import qualified Data.HashMap.Strict as HashMapStrict import qualified Data.Set as Set import Data.Hashable (hash) import Data.List (isSuffixOf, sort, find) import Data.Maybe (fromMaybe) import qualified Data.Text as TS import Data.Text.Lazy (Text) import qualified Data.Text.Lazy.IO as T import GHC.Stack (HasCallStack) import qualified System.Directory as Directory import qualified System.FilePath as FilePath import System.IO.Error (tryIOError) import Clash.Annotations.Primitive ( PrimitiveGuard(HasBlackBox, DontTranslate) , PrimitiveWarning(WarnNonSynthesizable) , extractPrim, extractWarnings) import Clash.Core.Term (Term) import Clash.Core.Type (Type) import Clash.Primitives.Types ( Primitive(BlackBox), CompiledPrimitive, ResolvedPrimitive, ResolvedPrimMap , includes, template, TemplateSource(TFile, TInline), Primitive(..) , UnresolvedPrimitive, CompiledPrimMap, GuardedResolvedPrimitive) import Clash.Netlist.Types (BlackBox(..), NetlistMonad) import Clash.Netlist.Util (preserveState) import Clash.Netlist.BlackBox.Util (walkElement) import Clash.Netlist.BlackBox.Types (Element(Const, Lit), BlackBoxMeta(..)) hashCompiledPrimitive :: CompiledPrimitive -> Int hashCompiledPrimitive (Primitive {name, primSort}) = hash (name, primSort) hashCompiledPrimitive (BlackBoxHaskell {function}) = fst function 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 hashBlackbox (BBFunction bbName bbHash _bbFunc) = hash (bbName, bbHash) -- | Hash a compiled primitive map. It needs a separate function (as opposed to -- just 'hash') as it might contain (obviously unhashable) Haskell functions. This -- function takes the hash value stored with the function instead. hashCompiledPrimMap :: CompiledPrimMap -> Int hashCompiledPrimMap cpm = hash (map (fmap hashCompiledPrimitive) orderedValues) where -- TODO: switch to 'normal' map instead of hashmap? orderedKeys = sort (HashMap.keys cpm) orderedValues = map (cpm HashMapStrict.!) orderedKeys resolveTemplateSource :: HasCallStack => FilePath -> TemplateSource -> IO Text resolveTemplateSource _metaPath (TInline text) = return text resolveTemplateSource metaPath (TFile path) = let path' = FilePath.replaceFileName metaPath path in either (error . show) id <$> (tryIOError $ T.readFile path') -- | Replace file pointers with file contents resolvePrimitive' :: HasCallStack => FilePath -> UnresolvedPrimitive -> IO (TS.Text, GuardedResolvedPrimitive) resolvePrimitive' _metaPath (Primitive name wf primType) = 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 () outputUsage libraries imports functionPlurality <$> mapM (traverse resolveSourceM) i <*> traverse resolveSourceM r <*> traverse resolveSourceM ri <*> resolveSourceM t case warning of Just w -> pure (name, HasBlackBox [WarnNonSynthesizable (TS.unpack w)] bb) Nothing -> pure (name, HasBlackBox [] bb) resolvePrimitive' metaPath (BlackBoxHaskell bbName wf usedArgs multiRes funcName t) = (bbName,) . HasBlackBox [] . BlackBoxHaskell bbName wf usedArgs multiRes funcName <$> (mapM (resolveTemplateSource metaPath) t) -- | Interprets contents of json file as list of @Primitive@s. Throws -- exception if it fails. resolvePrimitive :: HasCallStack => FilePath -> IO [(TS.Text, GuardedResolvedPrimitive)] resolvePrimitive fileName = do prims <- decoder fileName <$> LZ.readFile fileName mapM (resolvePrimitive' fileName) prims where decoder | ".primitives.yaml" `isSuffixOf` fileName = decodeOrErrYaml | ".primitives" `isSuffixOf` fileName = decodeOrErrJson | otherwise = error ("Unexpected filename extension in: " <> fileName) addGuards :: ResolvedPrimMap -> [(TS.Text, PrimitiveGuard ())] -> ResolvedPrimMap addGuards = foldl go where lookupPrim :: TS.Text -> ResolvedPrimMap -> Maybe ([PrimitiveWarning], ResolvedPrimitive) lookupPrim nm primMap = do guardedPrim <- HashMapStrict.lookup nm primMap prim <- extractPrim guardedPrim return (extractWarnings guardedPrim, prim) go primMap (nm, guard) = HashMapStrict.insert nm (case (lookupPrim nm primMap, guard) of (Nothing, DontTranslate) -> DontTranslate (Nothing, HasBlackBox _ ()) -> error $ "No BlackBox definition for '" ++ TS.unpack nm ++ "' even" ++ " though this value was annotated with 'HasBlackBox'." (Just _, DontTranslate) -> error (TS.unpack nm ++ " was annotated with DontTranslate, but a " ++ "BlackBox definition was found anyway.") (Just (ws1, p), HasBlackBox ws2 ()) -> HasBlackBox (ws1 ++ ws2) p ) primMap -- | Generate a set of primitives that are found in the primitive definition -- files in the given directories. generatePrimMap :: HasCallStack => [UnresolvedPrimitive] -- ^ unresolved primitives found in annotations (in LoadModules and -- LoadInterfaceFiles) -> [(TS.Text, PrimitiveGuard ())] -> [FilePath] -- ^ Directories to search for primitive definitions -> IO ResolvedPrimMap generatePrimMap unresolvedPrims primGuards filePaths = do primitiveFiles <- fmap concat $ forM filePaths $ \filePath -> do fpExists <- Directory.doesDirectoryExist filePath if fpExists then do contents <- Directory.getDirectoryContents filePath let jsonPrims = filter (".primitives" `isSuffixOf`) contents yamlPrims = filter (".primitives.yaml" `isSuffixOf`) contents relPrims = jsonPrims <> yamlPrims absPrims = map (FilePath.combine filePath) relPrims return absPrims else return [] primitives0 <- concat <$> mapM resolvePrimitive primitiveFiles let metapaths = map (TS.unpack . name) unresolvedPrims primitives1 <- sequence $ zipWith resolvePrimitive' metapaths unresolvedPrims let primMap = HashMap.fromList (primitives0 ++ primitives1) return (force (addGuards primMap primGuards)) {-# SCC generatePrimMap #-} -- | Determine what argument should be constant / literal constantArgs :: TS.Text -> CompiledPrimitive -> Set.Set Int constantArgs nm BlackBox {template = templ@(BBTemplate _), resultInits = tRIM} = Set.fromList (concat [ fromIntForce , concatMap walkTemplate tRIM , walkTemplate templ ]) where walkTemplate (BBTemplate t) = concatMap (walkElement getConstant) t walkTemplate _ = [] getConstant (Lit i) = Just i getConstant (Const i) = Just i getConstant _ = Nothing -- Ensure that if the 'Integer' arguments are constants, that they are reduced -- to literals, so that the builtin rules can properly fire. -- -- Only in the the case that 'Integer' arguments are truly variables should -- the blackbox rules fire. fromIntForce | nm == "Clash.Sized.Internal.BitVector.fromInteger#" = [2] | nm == "Clash.Sized.Internal.BitVector.fromInteger##" = [0,1] | nm == "Clash.Sized.Internal.Index.fromInteger#" = [1] | nm == "Clash.Sized.Internal.Signed.fromInteger#" = [1] | nm == "Clash.Sized.Internal.Unsigned.fromInteger#" = [1] | nm == "Clash.Sized.Vector.replace_int" = [1,2] | otherwise = [] constantArgs nm (BlackBoxHaskell{}) = Set.fromList fromIntForce where -- There is a special code-path for `index_int` in the Verilog backend in -- case the index is a constant. But this code path only works when the -- vector is (a projection of) a variable. By forcing the arguments of -- index_int we can be sure that arguments are either: -- -- Constant Variable -- Variable Constant -- Variable Variable -- -- As all other cases would be reduced by the evaluator, and even expensive -- primitives under index_int are fully unrolled. fromIntForce | nm == "Clash.Sized.Vector.index_int" = [2] | otherwise = [] constantArgs _ _ = Set.empty -- | Helper function of 'getFunctionPlurality' getFunctionPlurality' :: [(Int, Int)] -> Int -> Int getFunctionPlurality' functionPlurality n = fromMaybe 1 (snd <$> (find ((== n) . fst) functionPlurality)) -- | Looks up the plurality of a function's function argument. See -- 'functionPlurality' for more information. If not set, the returned plurality -- will default to /1/. getFunctionPlurality :: HasCallStack => CompiledPrimitive -> [Either Term Type] -- ^ Arguments passed to blackbox -> [Type] -- ^ Result types -> Int -- ^ Argument number holding the function of interest -> NetlistMonad Int -- ^ Plurality of function. Defaults to 1. Does not err if argument isn't -- a function in the first place. State of monad will not be modified. getFunctionPlurality (Primitive {}) _args _resTys _n = pure 1 getFunctionPlurality (BlackBoxHaskell {name, function, functionName}) args resTys n = do errOrMeta <- preserveState ((snd function) False name args resTys) case errOrMeta of Left err -> error $ concat [ "Tried to determine function plurality for " , TS.unpack name, " by quering ", show functionName , ". Function returned an error message instead:\n\n" , err ] Right (BlackBoxMeta {bbFunctionPlurality}, _bb) -> pure (getFunctionPlurality' bbFunctionPlurality n) getFunctionPlurality (BlackBox {functionPlurality}) _args _resTy n = pure (getFunctionPlurality' functionPlurality n) clash-lib-1.8.1/src/Clash/Primitives/Verification.hs0000644000000000000000000001165307346545000020510 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Clash.Primitives.Verification (checkBBF) where import Data.Either 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 import GHC.Stack (HasCallStack) import Clash.Annotations.Primitive (HDL(..)) import Clash.Backend (Backend, blockDecl, hdlKind) import Clash.Core.HasType import Clash.Core.Term (Term(Var), varToId) import Clash.Core.TermLiteral (termToDataError) import Clash.Util (indexNote) import Clash.Netlist (mkExpr) 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), Usage(Cont), HWType(Bool, KnownDomain), NetlistId(..), DeclarationType(Concurrent), tcCache, bbInputs, Expr(Identifier)) import Clash.Netlist.BlackBox.Types (BlackBoxFunction, BlackBoxMeta(..), TemplateKind(TDecl), RenderVoid(..), emptyBlackBoxMeta) import Clash.Verification.Internal import Clash.Verification.Pretty checkBBF :: BlackBoxFunction checkBBF _isD _primName args _ty = case litArgs of Left err -> pure (Left err) Right (propName, renderAs, cvProperty0) -> do cvProperty1 <- mapM (uncurry bindMaybe) cvProperty0 let decls = concatMap snd cvProperty1 cvProperty2 = fmap fst cvProperty1 pure (Right (meta, bb (checkTF decls (clkExpr, clkId) propName renderAs cvProperty2))) where -- TODO: Improve error handling; currently errors don't indicate what -- TODO: blackbox generated them. _knownDomainArg :< clkArg :< _rstArg :< propNameArg :< renderAsArg :< propArg :< _ = ((0 :: Int)...) (Id.unsafeFromCoreId -> clkId) = varToId (indexNote "clk" (lefts args) clkArg) clkExpr = Identifier clkId Nothing litArgs = do 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 meta = emptyBlackBoxMeta {bbKind=TDecl, bbRenderVoid=RenderVoid} bindMaybe :: Maybe String -- ^ Hint for new identifier -> Term -- ^ 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 (Id.unsafeFromCoreId vId, []) bindMaybe Nothing t = bindMaybe (Just "s") t bindMaybe (Just nm) t = do tcm <- Lens.view tcCache newId <- Id.make (Text.pack nm) (expr0, decls) <- mkExpr False Concurrent (NetlistId newId (inferCoreTypeOf tcm t)) t pure ( newId , decls ++ [sigDecl Bool newId, Assignment newId Cont expr0] ) -- Simple wire without comment sigDecl :: HWType -> Identifier -> Declaration sigDecl typ nm = NetDecl Nothing nm typ checkTF :: [Declaration] -> (Expr, Identifier) -> Text.Text -> RenderAs -> Property' Identifier -> TemplateFunction checkTF decls clk propName renderAs prop = TemplateFunction [] (const True) (checkTF' decls clk propName renderAs prop) checkTF' :: forall s . (HasCallStack, Backend s) => [Declaration] -- ^ Extra decls needed -> (Expr, Identifier) -- ^ Clock -> Text.Text -- ^ Prop name -> RenderAs -> Property' Identifier -> BlackBoxContext -> State s Doc checkTF' decls (clk, clkId) propName renderAs prop bbCtx = do blockName <- Id.makeBasic (propName <> "_block") getAp (blockDecl blockName (renderedPslProperty : decls)) where hdl = hdlKind (undefined :: s) edge = 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 SVA -> sva AutoRenderAs -> case hdl of SystemVerilog -> sva _ -> psl YosysFormal -> case hdl of VHDL -> psl _ -> ysva where sva = pprSvaProperty propName (Id.toText clkId) edge (fmap Id.toText prop) ysva = pprYosysSvaProperty propName clk edge (fmap Id.toText prop) psl = pprPslProperty hdl propName (Id.toText clkId) edge (fmap Id.toText prop) clash-lib-1.8.1/src/Clash/Primitives/Xilinx/0000755000000000000000000000000007346545000016777 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Primitives/Xilinx/ClockGen.hs0000644000000000000000000001314007346545000021017 0ustar0000000000000000{-| 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) clash-lib-1.8.1/src/Clash/Rewrite/0000755000000000000000000000000007346545000015012 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Rewrite/Combinators.hs0000644000000000000000000001064307346545000017632 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente 2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Rewriting combinators and traversals -} module Clash.Rewrite.Combinators ( allR , (!->) , (>-!) , (>-!->) , (>->) , bottomupR , repeatR , topdownR ) where import Control.DeepSeq (deepseq) import Control.Monad ((>=>)) import qualified Control.Monad.Writer as Writer import qualified Data.Monoid as Monoid import Clash.Core.Term (Term (..), CoreContext (..), primArg, patIds) import Clash.Core.VarEnv (extendInScopeSet, extendInScopeSetList) import Clash.Rewrite.Types -- | Apply a transformation on the subtrees of an term allR :: forall m . Monad m => Transform m -- ^ The transformation to apply to the subtrees -> Transform m allR trans (TransformContext is c) (Lam v e) = Lam v <$> trans (TransformContext (extendInScopeSet is v) (LamBody v:c)) e allR trans (TransformContext is c) (TyLam tv e) = TyLam tv <$> trans (TransformContext (extendInScopeSet is tv) (TyLamBody tv:c)) e allR trans (TransformContext is c) (App e1 e2) = do e1' <- trans (TransformContext is (AppFun:c)) e1 e2' <- trans (TransformContext is (AppArg (primArg e1') : c)) e2 pure (App e1' e2') allR trans (TransformContext is c) (TyApp e ty) = TyApp <$> trans (TransformContext is (TyAppC:c)) e <*> pure ty allR trans (TransformContext is c) (Cast e ty1 ty2) = Cast <$> trans (TransformContext is (CastBody:c)) e <*> pure ty1 <*> pure ty2 allR trans (TransformContext is c) (Letrec xes e) = do xes' <- traverse rewriteBind xes e' <- trans (TransformContext is' (LetBody xes:c)) e return (Letrec xes' e') where bndrs = map fst xes is' = extendInScopeSetList is (map fst xes) rewriteBind (b,e') = (b,) <$> trans (TransformContext is' (LetBinding b bndrs:c)) e' allR trans (TransformContext is c) (Case scrut ty alts) = Case <$> trans (TransformContext is (CaseScrut:c)) scrut <*> pure ty <*> traverse rewriteAlt alts where rewriteAlt (p,e) = let (tvs,ids) = patIds p is' = extendInScopeSetList (extendInScopeSetList is tvs) ids in (p,) <$> trans (TransformContext is' (CaseAlt p : c)) e allR trans (TransformContext is c) (Tick sp e) = Tick sp <$> trans (TransformContext is (TickC sp:c)) e allR _ _ tm = pure tm infixr 6 >-> -- | Apply two transformations in succession (>->) :: Monad m => Transform m -> Transform m -> Transform m (>->) = \r1 r2 c -> r1 c >=> r2 c {-# INLINE (>->) #-} infixr 6 >-!-> -- | Apply two transformations in succession, and perform a deepseq in between. (>-!->) :: Monad m => Transform m -> Transform m -> Transform m (>-!->) = \r1 r2 c e -> do e' <- r1 c e deepseq e' (r2 c e') {-# INLINE (>-!->) #-} {- Note [topdown repeatR] ~~~~~~~~~~~~~~~~~~~~~~ In a topdown traversal we need to repeat the transformation r because if r replaces a parent node with one of its children we should still apply r to that child, before continuing with its children. Example: topdownR (inlineBinders (\_ _ -> return True)) on: > letrec > x = 1 > in letrec > y = 2 > in f x y inlineBinders would inline x and return: > letrec > y = 2 > in f 1 y Then we must repeat the transformation to let it also inline y. -} -- | Apply a transformation in a topdown traversal topdownR :: Rewrite m -> Rewrite m -- See Note [topdown repeatR] topdownR r = repeatR r >-> allR (topdownR r) -- | Apply a transformation in a bottomup traversal bottomupR :: Monad m => Transform m -> Transform m bottomupR r = allR (bottomupR r) >-> r infixr 5 !-> -- | Only apply the second transformation if the first one succeeds. (!->) :: Rewrite m -> Rewrite m -> Rewrite m (!->) = \r1 r2 c expr -> do (expr',changed) <- Writer.listen $ r1 c expr if Monoid.getAny changed then r2 c expr' else return expr' {-# INLINE (!->) #-} infixr 5 >-! -- | Only apply the second transformation if the first one fails. (>-!) :: Rewrite m -> Rewrite m -> Rewrite m (>-!) = \r1 r2 c expr -> do (expr',changed) <- Writer.listen $ r1 c expr if Monoid.getAny changed then return expr' else r2 c expr' {-# INLINE (>-!) #-} -- | Keep applying a transformation until it fails. repeatR :: Rewrite m -> Rewrite m repeatR = let go r = r !-> repeatR r in go {-# INLINE repeatR #-} clash-lib-1.8.1/src/Clash/Rewrite/Types.hs0000644000000000000000000002061707346545000016460 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, 2017 , Google Inc., 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Type and instance definitions for Rewrite modules -} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Rewrite.Types where import Control.Concurrent.Supply (Supply, freshId) import Control.DeepSeq (NFData) import Control.Lens (Lens', use, (.=)) import qualified Control.Lens as Lens import Control.Monad.Fix (MonadFix) import Control.Monad.State.Strict (State) #if MIN_VERSION_transformers(0,5,6) import Control.Monad.Reader (MonadReader (..)) import Control.Monad.State (MonadState (..)) import Control.Monad.Trans.RWS.CPS (RWST) import qualified Control.Monad.Trans.RWS.CPS as RWS import Control.Monad.Writer (MonadWriter (..)) #else import Control.Monad.Trans.RWS.Strict (RWST) import qualified Control.Monad.Trans.RWS.Strict as RWS #endif import Data.Binary (Binary) import Data.HashMap.Strict (HashMap) import Data.IntMap.Strict (IntMap) import Data.Monoid (Any) import Data.Text (Text) import GHC.Generics import Clash.Core.PartialEval as PE (Evaluator) import Clash.Core.Evaluator.Types as WHNF (Evaluator, PrimHeap) import Clash.Core.Term (Term, Context) import Clash.Core.Type (Type) import Clash.Core.TyCon (TyConMap, TyConName) import Clash.Core.Var (Id) import Clash.Core.VarEnv (InScopeSet, VarSet, VarEnv) import Clash.Driver.Types (ClashEnv(..), ClashOpts(..), BindingMap, DebugOpts) import Clash.Netlist.Types (FilteredHWType, HWMap) import Clash.Primitives.Types (CompiledPrimMap) import Clash.Rewrite.WorkFree (isWorkFree) import Clash.Util import Clash.Annotations.BitRepresentation.Internal (CustomReprs) -- | State used by the inspection mechanism for recording rewrite steps. data RewriteStep = RewriteStep { t_ctx :: Context -- ^ current context , t_name :: String -- ^ Name of the transformation , t_bndrS :: String -- ^ Name of the current binder , t_before :: Term -- ^ Term before `apply` , t_after :: Term -- ^ Term after `apply` } deriving (Show, Generic, NFData, Binary) -- | State of a rewriting session data RewriteState extra = RewriteState -- TODO Given we now keep transformCounters, this should just be 'fold' -- over that map, otherwise the two counts could fall out of sync. { _transformCounter :: {-# UNPACK #-} !Word -- ^ Total number of applied transformations , _transformCounters :: HashMap Text Word -- ^ Map that tracks how many times each transformation is applied , _bindings :: !BindingMap -- ^ Global binders , _uniqSupply :: !Supply -- ^ Supply of unique numbers , _curFun :: (Id,SrcSpan) -- Initially set to undefined: no strictness annotation -- ^ Function which is currently normalized , _nameCounter :: {-# UNPACK #-} !Int -- ^ Used for 'Fresh' , _globalHeap :: PrimHeap -- ^ Used as a heap for compile-time evaluation of primitives that live in I/O , _workFreeBinders :: VarEnv Bool -- ^ Map telling whether a binder's definition is work-free , _extra :: !extra -- ^ Additional state } Lens.makeLenses ''RewriteState -- | Read-only environment of a rewriting session data RewriteEnv = RewriteEnv { _clashEnv :: ClashEnv -- ^ The global environment of the compiler , _typeTranslator :: CustomReprs -> TyConMap -> Type -> State HWMap (Maybe (Either String FilteredHWType)) -- ^ Hardcode Type -> FilteredHWType translator , _peEvaluator :: PE.Evaluator -- ^ Hardcoded evaluator for partial evaluation , _evaluator :: WHNF.Evaluator -- ^ Hardcoded evaluator for WHNF (old evaluator) , _topEntities :: VarSet -- ^ Functions that are considered TopEntities } Lens.makeLenses ''RewriteEnv debugOpts :: Lens.Getter RewriteEnv DebugOpts debugOpts = clashEnv . Lens.to (opt_debug . envOpts) aggressiveXOpt :: Lens.Getter RewriteEnv Bool aggressiveXOpt = clashEnv . Lens.to (opt_aggressiveXOpt . envOpts) tcCache :: Lens.Getter RewriteEnv TyConMap tcCache = clashEnv . Lens.to envTyConMap tupleTcCache :: Lens.Getter RewriteEnv (IntMap TyConName) tupleTcCache = clashEnv . Lens.to envTupleTyCons customReprs :: Lens.Getter RewriteEnv CustomReprs customReprs = clashEnv . Lens.to envCustomReprs fuelLimit :: Lens.Getter RewriteEnv Word fuelLimit = clashEnv . Lens.to (opt_evaluatorFuelLimit . envOpts) primitives :: Lens.Getter RewriteEnv CompiledPrimMap primitives = clashEnv . Lens.to envPrimitives inlineLimit :: Lens.Getter RewriteEnv Int inlineLimit = clashEnv . Lens.to (opt_inlineLimit . envOpts) inlineFunctionLimit :: Lens.Getter RewriteEnv Word inlineFunctionLimit = clashEnv . Lens.to (opt_inlineFunctionLimit . envOpts) inlineConstantLimit :: Lens.Getter RewriteEnv Word inlineConstantLimit = clashEnv . Lens.to (opt_inlineConstantLimit . envOpts) inlineWFCacheLimit :: Lens.Getter RewriteEnv Word inlineWFCacheLimit = clashEnv . Lens.to (opt_inlineWFCacheLimit . envOpts) newInlineStrategy :: Lens.Getter RewriteEnv Bool newInlineStrategy = clashEnv . Lens.to (opt_newInlineStrat . envOpts) specializationLimit :: Lens.Getter RewriteEnv Int specializationLimit = clashEnv . Lens.to (opt_specLimit . envOpts) normalizeUltra :: Lens.Getter RewriteEnv Bool normalizeUltra = clashEnv . Lens.to (opt_ultra . envOpts) -- | Monad that keeps track how many transformations have been applied and can -- generate fresh variables and unique identifiers. In addition, it keeps track -- if a transformation/rewrite has been successfully applied. newtype RewriteMonad extra a = R { unR :: RWST RewriteEnv Any (RewriteState extra) IO a } deriving newtype ( Applicative , Functor , 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 :: RewriteMonad extra a -> RewriteEnv -> RewriteState extra -> IO (a, RewriteState extra, Any) runR m = RWS.runRWST (unR m) #if MIN_VERSION_transformers(0,5,6) && !MIN_VERSION_mtl(2,3,0) -- For Control.Monad.Trans.RWS.Strict these are already defined, however the -- CPS version of RWS is not included in `mtl` yet. instance MonadState (RewriteState extra) (RewriteMonad extra) where get = R RWS.get {-# INLINE get #-} put = R . RWS.put {-# INLINE put #-} state = R . RWS.state {-# INLINE state #-} instance MonadWriter Any (RewriteMonad extra) where writer = R . RWS.writer {-# INLINE writer #-} tell = R . RWS.tell {-# INLINE tell #-} listen = R . RWS.listen . unR {-# INLINE listen #-} pass = R . RWS.pass . unR {-# INLINE pass #-} instance MonadReader RewriteEnv (RewriteMonad extra) where ask = R RWS.ask {-# INLINE ask #-} local f = R . RWS.local f . unR {-# INLINE local #-} reader = R . RWS.reader {-# INLINE reader #-} #endif instance MonadUnique (RewriteMonad extra) where getUniqueM = do sup <- use uniqSupply let (a,sup') = freshId sup uniqSupply .= sup' a `seq` return a censor :: (Any -> Any) -> RewriteMonad extra a -> RewriteMonad extra a censor f = R . RWS.censor f . unR {-# INLINE censor #-} data TransformContext = TransformContext { tfInScope :: !InScopeSet , tfContext :: Context } -- | Monadic action that transforms a term given a certain context type Transform m = TransformContext -> Term -> m Term -- | A 'Transform' action in the context of the 'RewriteMonad' type Rewrite extra = Transform (RewriteMonad extra) -- Moved into Clash.Rewrite.WorkFree {-# SPECIALIZE isWorkFree :: Lens' (RewriteState extra) (VarEnv Bool) -> BindingMap -> Term -> RewriteMonad extra Bool #-} clash-lib-1.8.1/src/Clash/Rewrite/Util.hs0000644000000000000000000007754107346545000016301 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente, 2016 , Myrtle Software Ltd, 2017 , Google Inc., 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Utilities for rewriting: e.g. inlining, specialisation, etc. -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Rewrite.Util ( module Clash.Rewrite.Util , module Clash.Rewrite.WorkFree ) where import Control.Concurrent.Supply (splitSupply) import Control.DeepSeq import Control.Exception (throw) import Control.Lens ((%=), (+=), (^.)) import qualified Control.Lens as Lens import qualified Control.Monad as Monad import qualified Control.Monad.State.Strict as State #if MIN_VERSION_transformers(0,5,6) import qualified Control.Monad.Trans.RWS.CPS as RWS #else import qualified Control.Monad.Trans.RWS.Strict as RWS #endif import qualified Control.Monad.Writer as Writer import Data.Bifunctor (second) import Data.Coerce (coerce) import Data.Functor.Const (Const (..)) import qualified Data.HashMap.Strict as HashMap import Data.List (group, partition, sort, sortOn) import qualified Data.List as List import qualified Data.List.Extra as List import Data.List.Extra (partitionM) import Data.Maybe import qualified Data.Monoid as Monoid import qualified Data.Set as Set import qualified Data.Set.Lens as Lens import Data.Text (Text) import qualified Data.Text as Text import System.IO.Unsafe (unsafePerformIO) import Data.Binary (encode) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL #if MIN_VERSION_ghc(9,0,0) import GHC.Types.Basic (InlineSpec (..)) #else import BasicTypes (InlineSpec (..)) #endif import Clash.Core.Evaluator.Types (PureHeap, whnf') import Clash.Core.FreeVars (freeLocalVars, termFreeVars', freeLocalIds, globalIdOccursIn) import Clash.Core.HasFreeVars (elemFreeVars, notElemFreeVars) import Clash.Core.HasType import Clash.Core.Name import Clash.Core.Pretty (showPpr) import Clash.Core.Subst (substTmEnv, aeqTerm, aeqType, extendIdSubst, mkSubst, substTm, eqTerm) import Clash.Core.Term import Clash.Core.TyCon (TyConMap) import Clash.Core.Type (Type (..), normalizeType) import Clash.Core.Var (Id, IdScope (..), TyVar, Var (..), mkGlobalId, mkLocalId, mkTyVar) import Clash.Core.VarEnv (InScopeSet, extendInScopeSet, extendInScopeSetList, mkInScopeSet, uniqAway, uniqAway', mapVarEnv, eltsVarEnv, unitVarSet, emptyVarEnv, 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(..), ClashEnv(..), ClashOpts(..), hasDebugInfo, isDebugging) import Clash.Netlist.Util (representableType) import Clash.Pretty (clashPretty, showDoc) import Clash.Rewrite.Types import Clash.Rewrite.WorkFree import Clash.Unique import Clash.Util import Clash.Util.Eq (fastEqBy) import qualified Clash.Util.Interpolate as I -- | Lift an action working in the '_extra' state to the 'RewriteMonad' zoomExtra :: State.State extra a -> RewriteMonad extra a zoomExtra m = R . RWS.rwsT $ \_ s -> let (a, st') = State.runState m (_extra s) in pure (a, s { _extra = st' }, mempty) -- | Some transformations might erroneously introduce shadowing. For example, -- a transformation might result in: -- -- let a = ... -- b = ... -- a = ... -- -- where the last 'a', shadows the first, while Clash assumes that this can't -- happen. This function finds those constructs and a list of found duplicates. -- findAccidentialShadows :: Term -> [[Id]] findAccidentialShadows = \case Var {} -> [] Data {} -> [] Literal {} -> [] Prim {} -> [] Lam _ t -> findAccidentialShadows t TyLam _ t -> findAccidentialShadows t App t1 t2 -> concatMap findAccidentialShadows [t1, t2] TyApp t _ -> findAccidentialShadows t Cast t _ _ -> findAccidentialShadows t Tick _ t -> findAccidentialShadows t Case t _ as -> concatMap (findInPat . fst) as ++ concatMap findAccidentialShadows (t : map snd as) Let NonRec{} t -> findAccidentialShadows t Let (Rec bs) t -> findDups (map fst bs) ++ findAccidentialShadows t where findInPat :: Pat -> [[Id]] findInPat (LitPat _) = [] findInPat (DefaultPat) = [] findInPat (DataPat _ _ ids) = findDups ids findDups :: [Id] -> [[Id]] findDups ids = filter ((1 <) . length) (group (sort ids)) -- | Record if a transformation is successfully applied apply :: String -- ^ Name of the transformation -> Rewrite extra -- ^ Transformation to be applied -> Rewrite extra apply = \s rewrite ctx expr0 -> do opts <- Lens.view debugOpts traceIf (hasDebugInfo TryName s opts) ("Trying: " <> s) (pure ()) (!expr1,anyChanged) <- Writer.listen (rewrite ctx expr0) let hasChanged = Monoid.getAny anyChanged Monad.when hasChanged (transformCounter += 1) -- NB: When -fclash-debug-history is on, emit binary data holding the recorded rewrite steps let rewriteHistFile = dbg_historyFile opts Monad.when (isJust rewriteHistFile && hasChanged) $ do (curBndr, _) <- Lens.use curFun let !_ = unsafePerformIO $ BS.appendFile (fromJust rewriteHistFile) $ BL.toStrict $ encode RewriteStep { t_ctx = tfContext ctx , t_name = s , t_bndrS = showPpr (varName curBndr) , t_before = expr0 , t_after = expr1 } return () if isDebugging opts then applyDebug s expr0 hasChanged expr1 else return expr1 {-# INLINE apply #-} applyDebug :: String -- ^ Name of the transformation -> Term -- ^ Original expression -> Bool -- ^ Whether the rewrite indicated change -> Term -- ^ New expression -> RewriteMonad extra Term applyDebug name exprOld hasChanged exprNew = do nTrans <- Lens.use transformCounter opts <- Lens.view debugOpts let from = fromMaybe 0 (dbg_transformationsFrom opts) let limit = fromMaybe maxBound (dbg_transformationsLimit opts) if | nTrans - from > limit -> error "-fclash-debug-transformations-limit exceeded" | nTrans <= from -> pure exprNew | otherwise -> go opts where go opts = traceIf (hasDebugInfo TryTerm name opts) ("Tried: " ++ name ++ " on:\n" ++ before) $ do nTrans <- pred <$> Lens.use transformCounter Monad.when (dbg_countTransformations opts && hasChanged) $ do transformCounters %= HashMap.insertWith (const succ) (Text.pack name) 1 Monad.when (dbg_invariants opts && hasChanged) $ do tcm <- Lens.view tcCache let beforeTy = inferCoreTypeOf tcm exprOld beforeFV = Lens.setOf freeLocalVars exprOld afterTy = inferCoreTypeOf tcm exprNew afterFV = Lens.setOf freeLocalVars exprNew newFV = not (afterFV `Set.isSubsetOf` beforeFV) accidentalShadows = findAccidentialShadows exprNew Monad.when newFV $ error ( concat [ $(curLoc) , "Error when applying rewrite ", name , " to:\n" , before , "\nResult:\n" ++ after ++ "\n" , "It introduces free variables." , "\nBefore: " ++ showPpr (Set.toList beforeFV) , "\nAfter: " ++ showPpr (Set.toList afterFV) ] ) Monad.when (not (null accidentalShadows)) $ error ( concat [ $(curLoc) , "Error when applying rewrite ", name , " to:\n" , before , "\nResult:\n" ++ after ++ "\n" , "It accidentally creates shadowing let/case-bindings:\n" , " ", showPpr accidentalShadows, "\n" , "This usually means that a transformation did not extend " , "or incorrectly extended its InScopeSet before applying a " , "substitution." ]) -- TODO This check should be an error instead of a trace, however this is -- currently very fragile as Clash doesn't keep casts in core. This should -- be changed when #1064 is merged. Monad.when (hasDebugInfo AppliedTerm name opts && not (normalizeType tcm beforeTy `aeqType` normalizeType tcm afterTy)) $ traceM ( concat [ $(curLoc) , "Error when applying rewrite ", name , " to:\n" , before , "\nResult:\n" ++ after ++ "\n" , "Changes type from:\n", showPpr beforeTy , "\nto:\n", showPpr afterTy ] ) let exprNotEqual = not (fastEqBy eqTerm exprOld exprNew) Monad.when (dbg_invariants opts && not hasChanged && exprNotEqual) $ error $ $(curLoc) ++ "Expression changed without notice(" ++ name ++ "): before" ++ before ++ "\nafter:\n" ++ after traceIf (hasDebugInfo AppliedName name opts && hasChanged) (name <> " {" <> show nTrans <> "}") $ traceIf (hasDebugInfo AppliedTerm name opts && hasChanged) ("Changes when applying rewrite to:\n" ++ before ++ "\nResult:\n" ++ after ++ "\n") $ traceIf (hasDebugInfo TryTerm name opts && not hasChanged) ("No changes when applying rewrite " ++ name ++ " to:\n" ++ after ++ "\n") $ return exprNew where before = showPpr exprOld after = showPpr exprNew -- | Perform a transformation on a Term runRewrite :: String -- ^ Name of the transformation -> InScopeSet -> Rewrite extra -- ^ Transformation to perform -> Term -- ^ Term to transform -> RewriteMonad extra Term runRewrite name is rewrite expr = apply name rewrite (TransformContext is []) expr -- | Evaluate a RewriteSession to its inner monad. runRewriteSession :: RewriteEnv -> RewriteState extra -> RewriteMonad extra a -> IO a runRewriteSession r s m = do (a, s', _) <- runR m r s traceIf (dbg_countTransformations (opt_debug (envOpts (_clashEnv r)))) ("Clash: Transformations:\n" ++ Text.unpack (showCounters (s' ^. transformCounters))) $ traceIf (None < dbg_transformationInfo (opt_debug (envOpts (_clashEnv r)))) ("Clash: Applied " ++ show (s' ^. transformCounter) ++ " transformations") pure a where showCounters = Text.unlines . map (\(nm,cnt) -> nm <> ": " <> Text.pack (show cnt)) . sortOn snd . HashMap.toList -- | Notify that a transformation has changed the expression setChanged :: RewriteMonad extra () setChanged = Writer.tell (Monoid.Any True) -- | Identity function that additionally notifies that a transformation has -- changed the expression changed :: a -> RewriteMonad extra a changed val = do Writer.tell (Monoid.Any True) return val closestLetBinder :: Context -> Maybe Id closestLetBinder [] = Nothing closestLetBinder (LetBinding id_ _:_) = Just id_ closestLetBinder (_:ctx) = closestLetBinder ctx mkDerivedName :: TransformContext -> OccName -> TmName mkDerivedName (TransformContext _ ctx) sf = case closestLetBinder ctx of Just id_ -> appendToName (varName id_) ('_' `Text.cons` sf) _ -> mkUnsafeInternalName sf 0 -- | Make a new binder and variable reference for a term mkTmBinderFor :: (MonadUnique m) => InScopeSet -> TyConMap -- ^ TyCon cache -> Name a -- ^ Name of the new binder -> Term -- ^ Term to bind -> m Id mkTmBinderFor is tcm name e = either id (error "mkTmBinderFor: Result is a TyVar") <$> mkBinderFor is tcm name (Left e) -- | Make a new binder and variable reference for either a term or a type mkBinderFor :: (MonadUnique m) => InScopeSet -> TyConMap -- ^ TyCon cache -> Name a -- ^ Name of the new binder -> Either Term Type -- ^ Type or Term to bind -> m (Either Id TyVar) mkBinderFor is tcm name (Left term) = do name' <- cloneNameWithInScopeSet is name let ty = inferCoreTypeOf tcm term return (Left (mkLocalId ty (coerce name'))) mkBinderFor is tcm name (Right ty) = do name' <- cloneNameWithInScopeSet is name let ki = inferCoreKindOf tcm ty return (Right (mkTyVar ki (coerce name'))) -- | Inline the binders in a let-binding that have a certain property inlineBinders :: (Term -> LetBinding -> RewriteMonad extra Bool) -- ^ Property test -> Rewrite extra inlineBinders condition (TransformContext inScope0 _) expr@(Let (NonRec i x) res) = do inline <- condition expr (i, x) if inline && elemFreeVars i res then let inScope1 = extendInScopeSet inScope0 i subst = extendIdSubst (mkSubst inScope1) i x in changed (substTm "inlineBinders" subst res) else return expr inlineBinders condition (TransformContext inScope0 _) expr@(Let (Rec xes) res) = do (toInline,toKeep) <- partitionM (condition expr) xes case toInline of [] -> return expr _ -> do let inScope1 = extendInScopeSetList inScope0 (map fst xes) (toInlRec,(toKeep1,res1)) = substituteBinders inScope1 toInline toKeep res case toInlRec ++ toKeep1 of [] -> changed res1 xes1 -> changed (Letrec xes1 res1) inlineBinders _ _ e = return e -- | Determine whether a binder is a join-point created for a complex case -- expression. -- -- A join-point is when a local function only occurs in tail-call positions, -- and when it does, more than once. isJoinPointIn :: Id -- ^ 'Id' of the local binder -> Term -- ^ Expression in which the binder is bound -> Bool isJoinPointIn id_ e = case tailCalls id_ e of Just n | n > 1 -> True _ -> False -- | Count the number of (only) tail calls of a function in an expression. -- 'Nothing' indicates that the function was used in a non-tail call position. tailCalls :: Id -- ^ Function to check -> Term -- ^ Expression to check it in -> Maybe Int tailCalls id_ = \case Var nm | id_ == nm -> Just 1 | otherwise -> Just 0 Lam _ e -> tailCalls id_ e TyLam _ e -> tailCalls id_ e App l r -> case tailCalls id_ r of Just 0 -> tailCalls id_ l _ -> Nothing TyApp l _ -> tailCalls id_ l Letrec bs e -> let (bsIds,bsExprs) = unzip bs bsTls = map (tailCalls id_) bsExprs bsIdsUsed = mapMaybe (\(l,r) -> pure l <* r) (zip bsIds bsTls) bsIdsTls = map (`tailCalls` e) bsIdsUsed bsCount = pure . sum $ catMaybes bsTls in case (all isJust bsTls) of False -> Nothing True -> case (all (==0) $ catMaybes bsTls) of False -> case all isJust bsIdsTls of False -> Nothing True -> (+) <$> bsCount <*> tailCalls id_ e True -> tailCalls id_ e Case scrut _ alts -> let scrutTl = tailCalls id_ scrut altsTl = map (tailCalls id_ . snd) alts in case scrutTl of Just 0 | all (/= Nothing) altsTl -> Just (sum (catMaybes altsTl)) _ -> Nothing _ -> Just 0 -- | Determines whether a function has the following shape: -- -- > \(w :: Void) -> f a b c -- -- i.e. is a wrapper around a (partially) applied function 'f', where the -- introduced argument 'w' is not used by 'f' isVoidWrapper :: Term -> Bool isVoidWrapper (Lam bndr e@(collectArgs -> (Var _,_))) = bndr `notElemFreeVars` e isVoidWrapper _ = False -- | Inline the first set of binder into the second set of binders and into the -- body of the original let expression. substituteBinders :: InScopeSet -> [LetBinding] -- ^ Let-binders to substitute -> [LetBinding] -- ^ Let-binders where substitution takes place -> Term -- ^ Body where substitution takes place -> ([LetBinding],([LetBinding],Term)) -- ^ -- 1. Let-bindings that we wanted to substitute, but turned out to be recursive -- 2.1 Let-binders where substitution took place -- 2.2 Body where substitution took place substituteBinders inScope toInline toKeep body = let (subst,toInlRec) = go (mkSubst inScope) [] toInline in ( map (second (substTm "substToInlRec" subst)) toInlRec , ( map (second (substTm "substToKeep" subst)) toKeep , substTm "substBody" subst body) ) where go subst inlRec [] = (subst,inlRec) go !subst !inlRec ((x,e):toInl) = let e1 = substTm "substInl" subst e substE = extendIdSubst (mkSubst inScope) x e1 subst1 = subst { substTmEnv = mapVarEnv (substTm "substSubst" substE) (substTmEnv subst)} subst2 = extendIdSubst subst1 x e1 in if x `elemFreeVars` e1 then go subst ((x,e1):inlRec) toInl else go subst2 inlRec toInl -- | Lift the first set of binders to the level of global bindings, and substitute -- these lifted bindings into the second set of binders and the body of the -- original let expression. liftAndSubsituteBinders :: InScopeSet -> [LetBinding] -- ^ Let-binders to lift, and substitute the lifted result -> [LetBinding] -- ^ Lef-binders where substitution takes place -> Term -- ^ Body where substitution takes place -> RewriteMonad extra ([LetBinding],Term) liftAndSubsituteBinders inScope toLift toKeep body = do subst <- go (mkSubst inScope) toLift pure ( map (second (substTm "liftToKeep" subst)) toKeep , substTm "keepBody" subst body ) where go subst [] = pure subst go !subst ((x,e):inl) = do let e1 = substTm "liftInl" subst e (_,e2) <- liftBinding (x,e1) let substE = extendIdSubst (mkSubst inScope) x e2 subst1 = subst { substTmEnv = mapVarEnv (substTm "liftSubst" substE) (substTmEnv subst) } subst2 = extendIdSubst subst1 x e2 if x `elemFreeVars` e2 then do (_,sp) <- Lens.use curFun throw (ClashException sp [I.i| Internal error: inlineOrLiftBInders failed on: #{showPpr (x,e)} creating a self-recursive let-binding: #{showPpr (x,e2)} given the already built subtitution: #{showDoc (clashPretty (substTmEnv subst))} |] Nothing) else go subst2 inl isFromInt :: Text -> Bool isFromInt nm = nm == "Clash.Sized.Internal.BitVector.fromInteger##" || nm == "Clash.Sized.Internal.BitVector.fromInteger#" || nm == "Clash.Sized.Internal.Index.fromInteger#" || nm == "Clash.Sized.Internal.Signed.fromInteger#" || nm == "Clash.Sized.Internal.Unsigned.fromInteger#" inlineOrLiftBinders :: (LetBinding -> RewriteMonad extra Bool) -- ^ Property test -> (Term -> LetBinding -> Bool) -- ^ Test whether to lift or inline -- -- * True: inline -- * False: lift -> Rewrite extra inlineOrLiftBinders condition inlineOrLift (TransformContext inScope0 _) e@(Letrec bndrs body) = do (toReplace,toKeep) <- partitionM condition bndrs case toReplace of [] -> return e _ -> do let inScope1 = extendInScopeSetList inScope0 (map fst bndrs) let (toInline,toLift) = partition (inlineOrLift e) toReplace -- We first substitute the binders that we can inline both the binders -- that we intend to lift, the other binders, and the body let (toLiftExtra,(toReplace1,body1)) = substituteBinders inScope1 toInline (toLift ++ toKeep) body (toLift1,toKeep1) = splitAt (length toLift) toReplace1 -- We then substitute the lifted binders in the other binders and the body (toKeep2,body2) <- liftAndSubsituteBinders inScope1 (toLiftExtra ++ toLift1) toKeep1 body1 case toKeep2 of [] -> changed body2 _ -> changed (Letrec toKeep2 body2) inlineOrLiftBinders _ _ _ e = return e -- | Create a global function for a Let-binding and return a Let-binding where -- the RHS is a reference to the new global function applied to the free -- variables of the original RHS liftBinding :: LetBinding -> 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 (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 interesting v@(Id {idScope = LocalId}) = varUniq v /= varUniq var interesting _ = True (boundFTVsSet,boundFVsSet) = getConst (Lens.foldMapOf (termFreeVars' interesting) unitFV e) boundFTVs = UniqMap.elems boundFTVsSet boundFVs = UniqMap.elems boundFVsSet -- Make a new global ID tcm <- Lens.view tcCache let newBodyTy = inferCoreTypeOf tcm $ mkTyLams (mkLams e boundFVs) boundFTVs (cf,sp) <- Lens.use curFun binders <- Lens.use bindings newBodyNm <- cloneNameWithBindingMap binders (appendToName (varName cf) ("_" `Text.append` nameOcc idName)) let newBodyId = mkGlobalId newBodyTy newBodyNm {nameSort = Internal} -- Make a new expression, consisting of the the lifted function applied to -- its free variables let newExpr = mkTmApps (mkTyApps (Var newBodyId) (map VarTy boundFTVs)) (map Var boundFVs) inScope0 = mkInScopeSet (coerce boundFVsSet) inScope1 = extendInScopeSetList inScope0 [var,newBodyId] let subst = extendIdSubst (mkSubst inScope1) var newExpr -- Substitute the recursive calls by the new expression e' = substTm "liftBinding" subst e -- Create a new body that abstracts over the free variables newBody = mkTyLams (mkLams e' boundFVs) boundFTVs -- Check if an alpha-equivalent global binder already exists 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 %= 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 -- flattening pass. We don't inline -- right away because we are lifting this -- 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 (b:_) -> let newExpr' = mkTmApps (mkTyApps (Var $ bindingId b) (map VarTy boundFTVs)) (map Var boundFVs) in return (var, newExpr') liftBinding _ = error $ $(curLoc) ++ "liftBinding: invalid core, expr bound to tyvar" -- | Make a global function for a name-term tuple mkFunction :: TmName -- ^ Name of the function -> SrcSpan -> InlineSpec -> Term -- ^ Term bound to the function -> RewriteMonad extra Id -- ^ Name with a proper unique and the type of the function mkFunction bndrNm sp inl body = do tcm <- Lens.view tcCache let bodyTy = inferCoreTypeOf tcm body binders <- Lens.use bindings bodyNm <- cloneNameWithBindingMap binders bndrNm addGlobalBind bodyNm bodyTy sp inl body return (mkGlobalId bodyTy bodyNm) -- | Add a function to the set of global binders addGlobalBind :: TmName -> Type -> SrcSpan -> InlineSpec -> Term -> RewriteMonad extra () addGlobalBind vNm ty sp inl body = do let vId = mkGlobalId ty vNm r = vId `globalIdOccursIn` body (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. cloneNameWithInScopeSet :: (MonadUnique m) => InScopeSet -> Name a -> m (Name a) cloneNameWithInScopeSet is nm = do i <- getUniqueM return (uniqAway is (setUnique nm i)) -- | Create a new name out of the given name, but with another unique. Resulting -- unique is guaranteed to not be in the given BindingMap. cloneNameWithBindingMap :: (MonadUnique m) => BindingMap -> Name a -> m (Name a) cloneNameWithBindingMap binders nm = do i <- getUniqueM return (uniqAway' (`UniqMap.elem` binders) i (setUnique nm i)) {-# INLINE isUntranslatable #-} -- | Determine if a term cannot be represented in hardware isUntranslatable :: Bool -- ^ String representable -> Term -> RewriteMonad extra Bool isUntranslatable stringRepresentable tm = do tcm <- Lens.view tcCache not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view customReprs <*> pure stringRepresentable <*> pure tcm <*> pure (inferCoreTypeOf tcm tm)) {-# INLINE isUntranslatableType #-} -- | Determine if a type cannot be represented in hardware isUntranslatableType :: Bool -- ^ String representable -> Type -> RewriteMonad extra Bool isUntranslatableType stringRepresentable ty = not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view customReprs <*> pure stringRepresentable <*> Lens.view tcCache <*> pure ty) normalizeTermTypes :: TyConMap -> Term -> Term normalizeTermTypes tcm e = case e of Cast e' ty1 ty2 -> Cast (normalizeTermTypes tcm e') (normalizeType tcm ty1) (normalizeType tcm ty2) Var v -> Var (normalizeId tcm v) -- TODO other terms? _ -> e normalizeId :: TyConMap -> Id -> Id normalizeId tcm v@(Id {}) = v {varType = normalizeType tcm (varType v)} normalizeId _ tyvar = tyvar -- | Evaluate an expression to weak-head normal form (WHNF), and apply a -- transformation on the expression in WHNF. whnfRW :: Bool -- ^ Whether the expression we're reducing to WHNF is the subject of a -- case expression. -> TransformContext -> Term -> Rewrite extra -> RewriteMonad extra Term whnfRW isSubj ctx@(TransformContext is0 hist) e rw = do tcm <- Lens.view tcCache bndrs <- Lens.use bindings eval <- Lens.view evaluator ids <- Lens.use uniqSupply let (ids1,ids2) = splitSupply ids uniqSupply Lens..= ids2 gh <- Lens.use globalHeap let lh = localBinders mempty hist case whnf' eval bndrs lh tcm gh ids1 is0 isSubj e of (!gh1,ph,v) -> do globalHeap Lens..= gh1 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 -- -- To prevent unnecessary rewrites only do this when rewrite changed something. bindPureHeap :: TyConMap -> PureHeap -> Rewrite extra -> Rewrite extra bindPureHeap tcm heap rw ctx0@(TransformContext is0 hist) e = do (e1, Monoid.getAny -> hasChanged) <- Writer.listen $ rw ctx e if hasChanged && not (null bndrs) then do -- The evaluator results are post-processed with two operations: -- -- 1. Inline work free binders. We've seen cases in the wild† where the -- evaluator (or rather, 'bindPureHeap') would let-bind work-free -- binders that were crucial for eliminating case constructs. If these -- case constructs were used in a self-referential (but terminating) -- manner, Clash would get stuck in an infinite loop. The proper -- solution would be to use 'isWorkFree', instead of 'isWorkFreeIsh', -- in 'bindConstantVar' such that these work free constructs would get -- inlined again. However, this incurs a great performance penalty so -- we opt to prevent the evaluator from introducing this situation in -- the first place. -- -- I'd like to stress that this is not a proper solution though, as GHC -- might produce a similar situation. We plan on properly solving this -- by eliminating the current lift/bind/eval strategy, instead replacing -- it by a partial evaluator‡. -- -- 2. Remove any unused let-bindings. Similar to (1), we risk Clash getting -- stuck in an infinite loop if we don't remove unused (eliminated by -- evaluation!) binders. -- -- † https://github.com/clash-lang/clash-compiler/pull/1354#issuecomment-635430374 -- ‡ https://www.microsoft.com/en-us/research/wp-content/uploads/2016/07/supercomp-by-eval.pdf bs <- Lens.use bindings inlineBinders (inlineTest bs) ctx0 (Letrec bndrs e1) >>= \case e2@(Let bnders1 e3) -> pure (fromMaybe e2 (removeUnusedBinders bnders1 e3)) e2 -> pure e2 else return e1 where heapIds = map fst bndrs is1 = extendInScopeSetList is0 heapIds ctx = TransformContext is1 (LetBody bndrs : hist) bndrs = map toLetBinding $ UniqMap.toList heap toLetBinding :: (Unique,Term) -> LetBinding toLetBinding (uniq,term) = (nm, term) where ty = inferCoreTypeOf tcm term nm = mkLocalId ty (mkUnsafeSystemName "x" uniq) -- See [Note: Name re-creation] inlineTest bs _ (_, stripTicks -> e_) = isWorkFree workFreeBinders bs e_ -- | Remove unused binders in given let-binding. Returns /Nothing/ if no unused -- binders were found. removeUnusedBinders :: Bind Term -> Term -> Maybe Term removeUnusedBinders (NonRec i _) body = let bodyFVs = Lens.foldMapOf freeLocalIds unitVarSet body in if i `elemVarSet` bodyFVs then Nothing else Just body removeUnusedBinders (Rec binds) body = case eltsVarEnv used of [] -> Just body qqL | not (List.equalLength qqL binds) -> Just (Letrec qqL body) | otherwise -> Nothing where bodyFVs = Lens.foldMapOf freeLocalIds unitVarSet body used = List.foldl' collectUsed emptyVarEnv (eltsVarSet bodyFVs) bindsEnv = mkVarEnv (map (\(x,e0) -> (x,(x,e0))) binds) collectUsed env v = if v `elemVarEnv` env then env else case lookupVarEnv v bindsEnv of Just (x,e0) -> let eFVs = Lens.foldMapOf freeLocalIds unitVarSet e0 in List.foldl' collectUsed (extendVarEnv x (x,e0) env) (eltsVarSet eFVs) Nothing -> env clash-lib-1.8.1/src/Clash/Rewrite/WorkFree.hs0000644000000000000000000001577607346545000017112 0ustar0000000000000000{-| Copyright : (C) 2020-2021, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Check whether a term is work free or not. This is used by transformations / evaluation to check whether it is possible to perform changes without duplicating work in the result, e.g. inlining. -} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskellQuotes #-} module Clash.Rewrite.WorkFree ( isWorkFree , isWorkFreeClockOrResetOrEnable , isWorkFreeIsh , isConstant , isConstantNotClockReset ) where import Control.Lens (Lens') import Control.Monad.Extra (allM, andM, eitherM) import Control.Monad.State.Class (MonadState) import qualified Data.Text.Extra as Text import GHC.Stack (HasCallStack) import Clash.Core.HasFreeVars import Clash.Core.FreeVars import Clash.Core.HasType import Clash.Core.Pretty (showPpr) import Clash.Core.Term import Clash.Core.TyCon (TyConMap) import Clash.Core.Type (isPolyFunTy) import Clash.Core.Util import Clash.Core.Var (Id, isLocalId) import Clash.Core.VarEnv (VarEnv, lookupVarEnv) import Clash.Driver.Types (BindingMap, Binding(..)) import Clash.Normalize.Primitives (removedArg) import Clash.Util (makeCachedU) -- | Determines whether a global binder is work free. Errors if binder does -- not exist. isWorkFreeBinder :: (HasCallStack, MonadState s m) => Lens' s (VarEnv Bool) -> BindingMap -> Id -> m Bool isWorkFreeBinder cache bndrs bndr = makeCachedU bndr cache $ case lookupVarEnv bndr bndrs of Nothing -> error ("isWorkFreeBinder: couldn't find binder: " ++ showPpr bndr) Just (bindingTerm -> t) -> if bndr `globalIdOccursIn` t then pure False else isWorkFree cache bndrs t {-# INLINABLE isWorkFree #-} -- | Determine whether a term does any work, i.e. adds to the size of the -- circuit. This function requires a cache (specified as a lens) to store the -- result for querying work info of global binders. -- isWorkFree :: forall s m . (HasCallStack, MonadState s m) => Lens' s (VarEnv Bool) -> BindingMap -> Term -> m Bool isWorkFree cache bndrs = go True where -- If we are in the outermost level of a term (i.e. not checking a subterm) -- then a term is work free if it simply refers to a local variable. This -- does not apply to subterms, as we do not want to count expressions like -- -- f[LocalId] x[LocalId] -- -- as being work free, as the term bound to f may introduce work. -- go :: HasCallStack => Bool -> Term -> m Bool go isOutermost (collectArgs -> (fun, args)) = case fun of Var i -- We only allow polymorphic / function typed variables to be inlined -- if they are locally scoped, and the term is only a variable. -- -- TODO This could be improved later by passing an InScopeSet to -- isWorkFree with all the local FVs of the term being checked. PE -- would need to be changed to know the FVs of global binders first. -- | isPolyFunTy (coreTypeOf i) -> pure (isLocalId i && isOutermost && null args) | isLocalId i -> pure True | otherwise -> andM [isWorkFreeBinder cache bndrs i, allM goArg args] Data _ -> allM goArg args Literal _ -> pure True Prim pr -> case primWorkInfo pr of -- We can ignore arguments because the primitive outputs a constant -- regardless of their values. WorkConstant -> pure True WorkNever -> allM goArg args WorkIdentity _ _ -> allM goArg args WorkVariable -> pure (all isConstantArg args) WorkAlways -> pure False Lam _ e -> andM [go False e, allM goArg args] TyLam _ e -> andM [go False e, allM goArg args] Let (NonRec _ x) e -> andM [go False e, go False x, allM goArg args] Let (Rec bs) e -> andM [go False e, allM (go False . snd) bs, allM goArg args] Case s _ [(_, a)] -> andM [go False s, go False a, allM goArg args] Case e _ _ -> andM [go False e, allM goArg args] Cast e _ _ -> andM [go False e, allM goArg args] -- (Ty)App's and Ticks are removed by collectArgs Tick _ _ -> error "isWorkFree: unexpected Tick" App {} -> error "isWorkFree: unexpected App" TyApp {} -> error "isWorkFree: unexpected TyApp" goArg e = eitherM (go False) (pure . const True) (pure e) isConstantArg = either isConstant (const True) -- | Determine if a term represents a constant isConstant :: Term -> Bool isConstant e = case collectArgs e of (Data _, args) -> all (either isConstant (const True)) args (Prim _, args) -> all (either isConstant (const True)) args (Lam _ _, _) -> isClosed e (Literal _,_) -> True _ -> False isConstantNotClockReset :: TyConMap -> Term -> Bool isConstantNotClockReset tcm e | isClockOrReset tcm eTy = case fst (collectArgs e) of Prim pr -> primName pr == Text.showt 'removedArg _ -> False | otherwise = isConstant e where eTy = inferCoreTypeOf tcm e -- TODO: Remove function after using WorkInfo in 'isWorkFreeIsh' isWorkFreeClockOrResetOrEnable :: TyConMap -> Term -> Maybe Bool isWorkFreeClockOrResetOrEnable tcm e = let eTy = inferCoreTypeOf tcm e in if isClockOrReset tcm eTy || isEnable tcm eTy then case collectArgs e of (Prim p,_) -> Just (primName p == Text.showt 'removedArg) (Var _, []) -> Just True (Data _, [_dom, Left (stripTicks -> Data _)]) -> Just True -- For Enable True/False (Literal _,_) -> Just True _ -> Just False else Nothing -- | A conservative version of 'isWorkFree'. Is used to determine in 'bindConstantVar' -- to determine whether an expression can be "bound" (locally inlined). While -- binding workfree expressions won't result in extra work for the circuit, it -- might very well cause extra work for Clash. In fact, using 'isWorkFree' in -- 'bindConstantVar' makes Clash two orders of magnitude slower for some of our -- test cases. -- -- In effect, this function is a version of 'isConstant' that also considers -- references to clocks and resets constant. This allows us to bind -- HiddenClock(ResetEnable) constructs, allowing Clash to constant spec -- subconstants - most notably KnownDomain. Doing that enables Clash to -- eliminate any case-constructs on it. isWorkFreeIsh :: TyConMap -> Term -> Bool isWorkFreeIsh tcm e = case isWorkFreeClockOrResetOrEnable tcm e of Just b -> b Nothing -> case collectArgs e of (Data _, args) -> all isWorkFreeIshArg args (Prim pInfo, args) -> case primWorkInfo pInfo of WorkAlways -> False -- Things like clock or reset generator always -- perform work WorkVariable -> all isConstantArg args _ -> all isWorkFreeIshArg args (Lam _ _, _) -> isClosed e (Literal _,_) -> True _ -> False where isWorkFreeIshArg = either (isWorkFreeIsh tcm) (const True) isConstantArg = either isConstant (const True) clash-lib-1.8.1/src/Clash/Unique.hs0000644000000000000000000000042507346545000015174 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} module Clash.Unique ( Unique , Uniquable (..) ) where type Unique = Int class Uniquable a where getUnique :: a -> Unique setUnique :: a -> Unique -> a instance Uniquable Unique where getUnique = id setUnique = flip const clash-lib-1.8.1/src/Clash/Util.hs0000644000000000000000000002330207346545000014642 0ustar0000000000000000{-| Copyright : (C) 2012-2016, University of Twente License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij Assortment of utility function used in the Clash library -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Clash.Util ( module Clash.Util , SrcSpan , noSrcSpan #if MIN_VERSION_transformers(0,6,0) , hoistMaybe #endif ) where import qualified Control.Exception as Exception 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 import qualified Data.List.Extra as List import Data.Maybe (fromMaybe, listToMaybe, catMaybes) import Data.Map.Ordered (OMap) import qualified Data.Map.Ordered as OMap #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter import Prettyprinter.Render.String #else import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.String #endif import Data.Time.Clock (UTCTime) import qualified Data.Time.Clock as Clock import qualified Data.Time.Format as Clock import Data.Typeable (Typeable) import Data.Version (Version) import GHC.Base (Int(..),isTrue#,(==#),(+#)) import GHC.Integer.Logarithms (integerLogBase#) import qualified GHC.LanguageExtensions.Type as LangExt import GHC.Stack (HasCallStack, callStack, prettyCallStack) import Type.Reflection (tyConPackage, typeRepTyCon, typeOf) import qualified Language.Haskell.TH as TH #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (SrcSpan, noSrcSpan) #else import SrcLoc (SrcSpan, noSrcSpan) #endif import Clash.Data.UniqMap (UniqMap) import qualified Clash.Data.UniqMap as UniqMap import Clash.Debug import Clash.Unique #ifdef CABAL import qualified Paths_clash_lib (version) #endif {- $setup >>> :m -Prelude >>> import Clash.Prelude -} data ClashException = ClashException SrcSpan String (Maybe String) instance Show ClashException where show (ClashException _ s eM) = s ++ "\n" ++ maybe "" id eM instance Exception.Exception ClashException assertPanic :: String -> Int -> a assertPanic file ln = Exception.throw (ClashException noSrcSpan ("ASSERT failed! file " ++ file ++ ", line " ++ show ln) Nothing) assertPprPanic :: HasCallStack => String -> Int -> Doc ann -> a assertPprPanic _file _line msg = pprPanic "ASSERT failed!" doc where doc = sep [ msg, callStackDoc ] pprPanic :: String -> Doc ann -> a pprPanic heading prettyMsg = Exception.throw (ClashException noSrcSpan (renderString (layoutPretty defaultLayoutOptions doc)) Nothing) where doc = sep [pretty heading, nest 2 prettyMsg] callStackDoc :: HasCallStack => Doc ann callStackDoc = "Call stack:" <+> hang 4 (vcat (map pretty (lines (prettyCallStack callStack)))) warnPprTrace :: HasCallStack => Bool -- ^ Trigger warning? -> String -- ^ File name -> Int -- ^ Line number -> Doc ann -- ^ Message -> a -- ^ Pass value (like trace) -> a warnPprTrace _ _ _ _ x | not debugIsOn = x warnPprTrace False _ _ _ x = x warnPprTrace True file ln msg x = pprDebugAndThen trace (vcat [heading0, heading1]) msg x where heading0 = hsep ["WARNING: file", pretty file <> comma, "line", pretty ln] heading1 = "WARNING CALLSTACK:" <> line <> pretty (prettyCallStack callStack) pprTrace :: String -> Doc ann -> a -> a pprTrace str = pprDebugAndThen trace (pretty str) pprTraceDebug :: String -> Doc ann -> a -> a pprTraceDebug str doc x | debugIsOn = pprTrace str doc x | otherwise = x pprDebugAndThen :: (String -> a) -> Doc ann -> Doc ann -> a pprDebugAndThen cont heading prettyMsg = cont (renderString (layoutPretty defaultLayoutOptions doc)) where doc = sep [heading, nest 2 prettyMsg] -- | A class that can generate unique numbers class Monad m => MonadUnique m where -- | Get a new unique getUniqueM :: m Int instance Monad m => MonadUnique (StateT Int m) where getUniqueM = do supply <- State.get State.modify (+1) return supply -- | Create a TH expression that returns the a formatted string containing the -- name of the module 'curLoc' is spliced into, and the line where it was spliced. curLoc :: TH.Q TH.Exp curLoc = do (TH.Loc _ _ modName (startPosL,_) _) <- TH.location TH.litE (TH.StringL $ modName ++ "(" ++ show startPosL ++ "): ") -- | Cache the result of a monadic action makeCached :: (MonadState s m, Hashable k, Eq k) => k -- ^ The key the action is associated with -> Lens' s (HashMap k v) -- ^ The Lens to the HashMap that is the cache -> m v -- ^ The action to cache -> m v makeCached key l create = do cache <- use l case HashMapL.lookup key cache of Just value -> return value Nothing -> do value <- create l %= HashMapL.insert key value return value -- | Cache the result of a monadic action using a 'UniqMap' makeCachedU :: (MonadState s m, Uniquable k) => k -- ^ Key the action is associated with -> Lens' s (UniqMap v) -- ^ Lens to the cache -> m v -- ^ Action to cache -> m v makeCachedU key l create = do cache <- use l case UniqMap.lookup key cache of Just value -> return value Nothing -> do value <- create l %= UniqMap.insert key value return value -- | Cache the result of a monadic action using a 'OMap' makeCachedO :: (MonadState s m, Uniquable k) => k -- ^ Key the action is associated with -> Lens' s (OMap Unique v) -- ^ Lens to the cache -> m v -- ^ Action to cache -> m v makeCachedO key l create = do cache <- use l case OMap.lookup (getUnique key) cache of Just value -> return value Nothing -> do value <- create l %= (flip (OMap.|>)) (getUnique key, value) return value -- | Same as 'indexNote' with last two arguments swapped indexNote' :: HasCallStack => String -- ^ Error message to display -> Int -- ^ Index /n/ -> [a] -- ^ List to index -> a -- ^ Error or element /n/ indexNote' = flip . indexNote -- | Unsafe indexing, return a custom error message when indexing fails indexNote :: HasCallStack => String -- ^ Error message to display -> [a] -- ^ List to index -> Int -- ^ Index /n/ -> a -- ^ Error or element /n/ indexNote note = \xs i -> fromMaybe (error note) (List.indexMaybe xs i) clashLibVersion :: Version #ifdef CABAL clashLibVersion = Paths_clash_lib.version #else clashLibVersion = error "development version" #endif -- | \x y -> floor (logBase x y), x > 1 && y > 0 flogBase :: Integer -> Integer -> Maybe Int flogBase x y | x > 1 && y > 0 = Just (I# (integerLogBase# x y)) flogBase _ _ = Nothing -- | \x y -> ceiling (logBase x y), x > 1 && y > 0 clogBase :: Integer -> Integer -> Maybe Int clogBase x y | x > 1 && y > 0 = case y of 1 -> Just 0 _ -> let z1 = integerLogBase# x y z2 = integerLogBase# x (y-1) in if isTrue# (z1 ==# z2) then Just (I# (z1 +# 1#)) else Just (I# z1) clogBase _ _ = Nothing -- | Get the package id of the type of a value -- -- >>> pkgIdFromTypeable (0 :: Unsigned 32) -- "clash-prelude-... -- pkgIdFromTypeable :: Typeable a => a -> String pkgIdFromTypeable = tyConPackage . typeRepTyCon . typeOf reportTimeDiff :: UTCTime -> UTCTime -> String reportTimeDiff end start | diff >= Clock.nominalDay = show days <> "d" <> Clock.formatTime Clock.defaultTimeLocale fmt (Clock.UTCTime (toEnum 0) (fromRational (toRational hms))) | otherwise = Clock.formatTime Clock.defaultTimeLocale fmt (Clock.UTCTime (toEnum 0) (fromRational (toRational diff))) where diff = Clock.diffUTCTime end start (days,hms) = divMod @Integer (floor diff) (floor Clock.nominalDay) fmt | diff >= 3600 = "%-Hh%-Mm%-Ss" | diff >= 60 = "%-Mm%-Ss" | otherwise = "%-S%03Qs" -- | Left-biased choice on maybes orElses :: [Maybe a] -> Maybe a orElses = listToMaybe . catMaybes -- These language extensions are used for -- * the interactive session inside clashi -- * compiling files with clash -- * running output tests with runghc -- * compiling (local) Template/Blackbox functions with Hint -- -- When changing this list please update docs/developing-hardware/language.rst wantedLanguageExtensions :: [LangExt.Extension] wantedLanguageExtensions = [ LangExt.BinaryLiterals , LangExt.ConstraintKinds , LangExt.DataKinds , LangExt.DeriveAnyClass , LangExt.DeriveGeneric , LangExt.DeriveLift , LangExt.DerivingStrategies , LangExt.ExplicitForAll , LangExt.ExplicitNamespaces , LangExt.FlexibleContexts , LangExt.FlexibleInstances , LangExt.KindSignatures , LangExt.MagicHash , LangExt.MonoLocalBinds , LangExt.NumericUnderscores , LangExt.QuasiQuotes , LangExt.ScopedTypeVariables , LangExt.TemplateHaskell , LangExt.TemplateHaskellQuotes , LangExt.TypeApplications , LangExt.TypeFamilies , LangExt.TypeOperators ] unwantedLanguageExtensions :: [LangExt.Extension] unwantedLanguageExtensions = [ LangExt.ImplicitPrelude , LangExt.StarIsType , 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 clash-lib-1.8.1/src/Clash/Util/0000755000000000000000000000000007346545000014306 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Util/Eq.hs0000644000000000000000000000326407346545000015214 0ustar0000000000000000{-| Copyright : (C) 2021 , QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Utilities related to the 'Eq' type class. -} {-# LANGUAGE MagicHash #-} module Clash.Util.Eq ( fastEq , fastEqBy ) where import GHC.Exts (isTrue#, reallyUnsafePtrEquality#) -- | Compare two values using pointer equality. If that fails, use 'Eq' to -- determine equality. Note that this function will only shortcut for values -- that are the same, but will always use 'Eq' for values that differ. -- -- Values are evaluated to WHNF before comparison. This function can therefore -- not be used if any of its arguments is expected to be bottom. fastEq :: Eq a => a -> a -> Bool fastEq = fastEqBy (==) -- | Compare two values using pointer equality. If that fails, use given function -- to determine equality. Note that this function will only shortcut for values -- that are the same, but will always use the given function for values that -- differ. -- -- Values are evaluated to WHNF before comparison. This function can therefore -- not be used if any of its arguments is expected to be bottom. fastEqBy :: (a -> a -> Bool) -> a -> a -> Bool fastEqBy f a1 a2 | a1 `pointerEq` a2 = True | otherwise = f a1 a2 {-# NOINLINE pointerEq #-} -- | Compares two values by comparing their positions on the heap. This function -- will return 'True' if the values are the same object, 'False' otherwise. Note -- that 'False' does *not* mean that the values are *not* the same. Values are -- evaluated to WHNF before comparison. -- -- Note: copied from @unordered-containers@. pointerEq :: a -> a -> Bool pointerEq !x !y = isTrue# (reallyUnsafePtrEquality# x y) clash-lib-1.8.1/src/Clash/Util/Graph.hs0000644000000000000000000001120207346545000015677 0ustar0000000000000000{-| Copyright : (C) 2018, QBayLogic License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij Collection of utilities -} module Clash.Util.Graph ( topSort , reverseTopSort , callGraphBindings ) where import Data.Tuple (swap) import Data.Foldable (foldlM) import qualified Data.IntMap.Strict as IntMap import qualified Data.IntSet as IntSet 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.Normalize.Util (callGraph) data Marker = Temporary | Permanent headSafe :: [a] -> Maybe a headSafe [] = Nothing headSafe (a:_) = Just a topSortVisit' :: IntMap.IntMap [Int] -- ^ Edges -> IntSet.IntSet -- ^ Unmarked nodes -> IntMap.IntMap Marker -- ^ Marked nodes -> [Int] -- ^ Sorted so far -> Int -- ^ Node to visit -> Either String (IntSet.IntSet, IntMap.IntMap Marker, [Int]) topSortVisit' edges unmarked marked sorted node = case IntMap.lookup node marked of Just Permanent -> Right (unmarked, marked, sorted) Just Temporary -> Left "cycle detected: cannot topsort cyclic graph" Nothing -> do let marked' = IntMap.insert node Temporary marked let unmarked' = IntSet.delete node unmarked let nodeToM = IntMap.findWithDefault [] node edges (unmarked'', marked'', sorted'') <- foldlM visit (unmarked', marked', sorted) nodeToM let marked''' = IntMap.insert node Permanent marked'' return (unmarked'', marked''', node : sorted'') where visit (unmarked', marked', sorted') node' = topSortVisit' edges unmarked' marked' sorted' node' topSortVisit :: IntMap.IntMap [Int] -- ^ Edges -> IntSet.IntSet -- ^ Unmarked nodes -> IntMap.IntMap Marker -- ^ Marked nodes -> [Int] -- ^ Sorted so far -> Int -- ^ Node to visit -> Either String (IntSet.IntSet, IntMap.IntMap Marker, [Int]) topSortVisit edges unmarked marked sorted node = do (unmarked', marked', sorted') <- topSortVisit' edges unmarked marked sorted node case headSafe (IntSet.toList unmarked') of Nothing -> return (unmarked', marked', sorted') Just node' -> topSortVisit edges unmarked' marked' sorted' node' -- | See: https://en.wikipedia.org/wiki/Topological_sorting. This function -- errors if edges mention nodes not mentioned in the node list or if the -- given graph contains cycles. topSort :: [(Int, a)] -- ^ Nodes -> [(Int, Int)] -- ^ Edges -> Either String [a] -- ^ Error message or topologically sorted nodes topSort [] [] = Right [] topSort [] _edges = Left "Node list was empty, but edges non-empty" topSort nodes@(node:_) edges = do _ <- mapM (\(n, m) -> checkNode n >> checkNode m) edges (_, _, sorted) <- topSortVisit edges' (IntMap.keysSet nodes') IntMap.empty [] (fst node) mapM lookup' sorted where nodes' = IntMap.fromList nodes edges' = foldl insert IntMap.empty edges -- Construction functions for quick lookup of edges from n to m, given n insert im (n, m) = IntMap.alter (insert' m) n im insert' m Nothing = Just [m] insert' m (Just ms) = Just (m:ms) -- Lookup node in nodes map. If not present, yield error lookup' n = case IntMap.lookup n nodes' of Nothing -> Left ("Node " ++ show n ++ " in edge list, but not in node list.") Just n' -> Right n' -- Check if edge is valid (i.e., mentioned nodes are in node list) checkNode n | IntMap.notMember n nodes' = Left ("Node " ++ show n ++ " in edge list, but not in node list.") | otherwise = Right n -- | Same as `reverse (topSort nodes edges)` if alternative representations are -- considered the same. That is, topSort might produce multiple answers and -- still deliver on its promise of yielding a topologically sorted node list. -- Likewise, this function promises __one__ of those lists in reverse, but not -- necessarily the reverse of topSort itself. reverseTopSort :: [(Int, a)] -- ^ Nodes -> [(Int, Int)] -- ^ Edges -> Either String [a] -- ^ Reversely, topologically sorted nodes reverseTopSort nodes edges = topSort nodes (map swap edges) -- | Get all the terms corresponding to a call graph callGraphBindings :: BindingMap -- ^ All bindings -> Id -- ^ Root of the call graph -> [Term] callGraphBindings bindingsMap tm = map (bindingTerm . (`UniqMap.find` bindingsMap)) (UniqMap.keys cg) where cg = callGraph bindingsMap tm clash-lib-1.8.1/src/Clash/Util/Interpolate.hs0000644000000000000000000003172007346545000017133 0ustar0000000000000000{-| Copyright : (C) 2019-2022, QBayLogic B.V. 2013 , Nikita Volkov License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} {- This is an adaptation of https://github.com/nikita-volkov/neat-interpolation/tree/0fc1dd73ea which is licensed under MIT. The original license will follow. --------- Copyright (c) 2013, Nikita Volkov Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} -- 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) import Language.Haskell.TH.Lib (appE, varE) import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Language.Haskell.TH.Syntax (Q, Exp) import qualified Numeric as N import Data.Char (isHexDigit, chr, isOctDigit, isDigit, isSpace) import Data.Maybe (fromMaybe, isJust, catMaybes) import Text.Read (readMaybe) data Line = EmptyLine | ExprLine Indent String | Line Indent [Node] deriving (Show) data Node = Literal String | Expression String deriving (Show) type Indent = Int format :: [Node] -> String format = stripWhiteSpace . showLines . nodesToLines where go _ [] = [] go n (c:cs) | c == ' ' = go (n+1) cs go 0 (c:cs) = c : go 0 cs go n cs = replicate n ' ' ++ (go 0 cs) stripWhiteSpace = go 0 . dropWhile isSpace showLines :: [Line] -> String showLines [] = "" showLines ns = init (concatMap showLine ns) where showLine :: Line -> String showLine EmptyLine = "\n" showLine (Line n ns') = let theIndent = replicate (n - commonIndent) ' ' in theIndent ++ (concatMap nodeToString ns') ++ "\n" showLine (ExprLine n s) = let theIndent = replicate (n - commonIndent) ' ' in concat [theIndent ++ l ++ "\n" | l <- lines s] nodeToString :: Node -> String nodeToString (Literal s) = s nodeToString (Expression s) = s commonIndent :: Indent commonIndent = foldl1 min (catMaybes (map indent ns)) indent :: Line -> Maybe Indent indent EmptyLine = Nothing indent (ExprLine n _) = Just n indent (Line n _) = Just n -- | Collects nodes into lines. Expressions might still contain newlines! Does -- not start or end with 'EmptyLine'. nodesToLines :: [Node] -> [Line] nodesToLines = concatMap splitLines . mergeLines . dropEmpty . map splitWords . map toLine . map dropTrailingEmpty . collectLines [] . joinLiterals where emptyLit (Literal s) = if all isSpace s then Just (length s) else Nothing emptyLit _ = Nothing isEmptyLine EmptyLine = True isEmptyLine _ = False dropEmpty = reverse . dropWhile isEmptyLine . reverse . dropWhile isEmptyLine dropTrailingEmpty = reverse . dropWhile (isJust . emptyLit) . reverse splitLines :: Line -> [Line] splitLines EmptyLine = [EmptyLine] splitLines e@(ExprLine {}) = [e] splitLines (Line n nodes) = map (Line n) (go 0 [] nodes) where maxLength = 80 go :: Int -> [Node] -> [Node] -> [[Node]] go accLen acc goNodes | accLen > maxLength = reverse acc : go 0 [] goNodes go accLen acc (l@(Literal s):goNodes) = go (accLen + length s) (l:acc) goNodes go accLen acc (e@(Expression s):goNodes) = go (accLen + length s) (e:acc) goNodes go _accLen acc [] = [reverse acc] mergeLines :: [Line] -> [Line] mergeLines (l0@(Line n0 nodes0):l1@(Line n1 nodes1):ls) = if n0 == n1 then mergeLines (Line n0 (nodes0 ++ [Literal " "] ++ nodes1) : ls) else l0:mergeLines (l1:ls) mergeLines (l:ls) = l:mergeLines ls mergeLines [] = [] splitWords :: Line -> Line splitWords EmptyLine = EmptyLine splitWords e@(ExprLine {})= e splitWords (Line n nodes) = Line n (concatMap go nodes) where go (Expression s) = [Expression s] go (Literal "") = [] go (Literal s0) = let pre = takeWhile (not . (==' ')) s0 post = dropWhile (not . (== ' ')) s0 in case post of [] -> [Literal s0] (_:s1) -> Literal (pre ++ " ") : go (Literal s1) -- Convert to 'Line' type toLine = \case [] -> EmptyLine [emptyLit -> Just _] -> EmptyLine [Expression s] -> ExprLine 0 s [emptyLit -> Just n, Expression s] -> ExprLine n s ns@(Expression _:_) -> Line 0 ns (Literal s:ns) -> Line (length (takeWhile (==' ') s)) (Literal (dropWhile (==' ') s):ns) -- collects list of nodes, where each list is a single line collectLines collected todo = case (collected, todo) of ([], []) -> [] (_, []) -> [reverse collected] (_, s@(Expression _):ns) -> collectLines (s:collected) ns (_, Literal s0:ns) -> let pre = takeWhile (/= '\n') s0 post = dropWhile (/= '\n') s0 in case post of [] -> collectLines (Literal s0:collected) ns (_:s1) -> reverse (Literal pre:collected) : collectLines [] (Literal s1:ns) joinLiterals :: [Node] -> [Node] joinLiterals [] = [] 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 , quotePat = err "pattern" , quoteType = err "type" , quoteDec = err "declaration" } where err name = error ("Clash.Util.Interpolate.i: This QuasiQuoter can not be used as a " ++ name ++ "!") toExp:: [Node] -> Q Exp toExp nodes = case nodes of [] -> [|[]|] (x:xs) -> f x `appE` toExp xs where f (Literal s) = [|(Literal s:)|] f (Expression e) = [|(Expression (toString ($(reifyExpression e))):)|] reifyExpression :: String -> Q Exp reifyExpression s = case parseExp s of Left _ -> do fail ("Parse error in expression: " ++ s) :: Q Exp Right e -> return e parseNodes :: String -> [Node] parseNodes = go "" where go :: String -> String -> [Node] go acc input = case input of "" -> [(lit . reverse) acc] '\\':x:xs -> go (x:'\\':acc) xs '#':'{':xs -> goExpr input acc [] xs x:xs -> go (x:acc) xs -- allow '}' to be escaped in code sections goExpr input accLit accExpr xs = case span (\x -> x /= '}' && x /= '\\') xs of (ys, '}' :zs) -> (lit . reverse) accLit : Expression (reverse accExpr ++ ys) : go "" zs (ys, '\\':'}':zs) -> goExpr input accLit ('}' : reverse ys ++ accExpr) zs (ys, '\\':zs) -> goExpr input accLit ('\\' : reverse ys ++ accExpr) zs (_, "") -> [lit (reverse accLit ++ input)] _ -> error "(impossible) parseError in parseNodes" lit :: String -> Node lit = Literal . unescape ------------------------------------------------------------------- -- Everything below this line is unchanged from neat-interpolate -- -- apart from updated module identifier strings -- ------------------------------------------------------------------- decodeNewlines :: String -> String decodeNewlines = go where go xs = case xs of '\r' : '\n' : ys -> '\n' : go ys y : ys -> y : go ys [] -> [] toString :: Show a => a -> String toString a = let s = show a in fromMaybe s (readMaybe s) {-# NOINLINE toString #-} {-# RULES "toString/String" toString = id #-} {-# RULES "toString/Int" toString = show :: Int -> String #-} {-# RULES "toString/Integer" toString = show :: Integer -> String #-} {-# RULES "toString/Float" toString = show :: Float -> String #-} {-# RULES "toString/Double" toString = show :: Double -> String #-} -- Haskell 2010 character unescaping, see: -- http://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6 unescape :: String -> String unescape = go where go input = case input of "" -> "" '\\' : 'x' : x : xs | isHexDigit x -> case span isHexDigit xs of (ys, zs) -> (chr . readHex $ x:ys) : go zs '\\' : 'o' : x : xs | isOctDigit x -> case span isOctDigit xs of (ys, zs) -> (chr . readOct $ x:ys) : go zs '\\' : x : xs | isDigit x -> case span isDigit xs of (ys, zs) -> (chr . read $ x:ys) : go zs '\\' : input_ -> case input_ of '\\' : xs -> '\\' : go xs 'a' : xs -> '\a' : go xs 'b' : xs -> '\b' : go xs 'f' : xs -> '\f' : go xs 'n' : xs -> '\n' : go xs 'r' : xs -> '\r' : go xs 't' : xs -> '\t' : go xs 'v' : xs -> '\v' : go xs '&' : xs -> go xs 'N':'U':'L' : xs -> '\NUL' : go xs 'S':'O':'H' : xs -> '\SOH' : go xs 'S':'T':'X' : xs -> '\STX' : go xs 'E':'T':'X' : xs -> '\ETX' : go xs 'E':'O':'T' : xs -> '\EOT' : go xs 'E':'N':'Q' : xs -> '\ENQ' : go xs 'A':'C':'K' : xs -> '\ACK' : go xs 'B':'E':'L' : xs -> '\BEL' : go xs 'B':'S' : xs -> '\BS' : go xs 'H':'T' : xs -> '\HT' : go xs 'L':'F' : xs -> '\LF' : go xs 'V':'T' : xs -> '\VT' : go xs 'F':'F' : xs -> '\FF' : go xs 'C':'R' : xs -> '\CR' : go xs 'S':'O' : xs -> '\SO' : go xs 'S':'I' : xs -> '\SI' : go xs 'D':'L':'E' : xs -> '\DLE' : go xs 'D':'C':'1' : xs -> '\DC1' : go xs 'D':'C':'2' : xs -> '\DC2' : go xs 'D':'C':'3' : xs -> '\DC3' : go xs 'D':'C':'4' : xs -> '\DC4' : go xs 'N':'A':'K' : xs -> '\NAK' : go xs 'S':'Y':'N' : xs -> '\SYN' : go xs 'E':'T':'B' : xs -> '\ETB' : go xs 'C':'A':'N' : xs -> '\CAN' : go xs 'E':'M' : xs -> '\EM' : go xs 'S':'U':'B' : xs -> '\SUB' : go xs 'E':'S':'C' : xs -> '\ESC' : go xs 'F':'S' : xs -> '\FS' : go xs 'G':'S' : xs -> '\GS' : go xs 'R':'S' : xs -> '\RS' : go xs 'U':'S' : xs -> '\US' : go xs 'S':'P' : xs -> '\SP' : go xs 'D':'E':'L' : xs -> '\DEL' : go xs '^':'@' : xs -> '\^@' : go xs '^':'A' : xs -> '\^A' : go xs '^':'B' : xs -> '\^B' : go xs '^':'C' : xs -> '\^C' : go xs '^':'D' : xs -> '\^D' : go xs '^':'E' : xs -> '\^E' : go xs '^':'F' : xs -> '\^F' : go xs '^':'G' : xs -> '\^G' : go xs '^':'H' : xs -> '\^H' : go xs '^':'I' : xs -> '\^I' : go xs '^':'J' : xs -> '\^J' : go xs '^':'K' : xs -> '\^K' : go xs '^':'L' : xs -> '\^L' : go xs '^':'M' : xs -> '\^M' : go xs '^':'N' : xs -> '\^N' : go xs '^':'O' : xs -> '\^O' : go xs '^':'P' : xs -> '\^P' : go xs '^':'Q' : xs -> '\^Q' : go xs '^':'R' : xs -> '\^R' : go xs '^':'S' : xs -> '\^S' : go xs '^':'T' : xs -> '\^T' : go xs '^':'U' : xs -> '\^U' : go xs '^':'V' : xs -> '\^V' : go xs '^':'W' : xs -> '\^W' : go xs '^':'X' : xs -> '\^X' : go xs '^':'Y' : xs -> '\^Y' : go xs '^':'Z' : xs -> '\^Z' : go xs '^':'[' : xs -> '\^[' : go xs '^':'\\' : xs -> '\^\' : go xs '^':']' : xs -> '\^]' : go xs '^':'^' : xs -> '\^^' : go xs '^':'_' : xs -> '\^_' : go xs xs -> go xs x:xs -> x : go xs readHex :: String -> Int readHex xs = case N.readHex xs of [(n, "")] -> n _ -> error $ (show 'unescape) <> " readHex: no parse" readOct :: String -> Int readOct xs = case N.readOct xs of [(n, "")] -> n _ -> error $ (show 'unescape) <> " readOct: no parse" clash-lib-1.8.1/src/Clash/Verification/0000755000000000000000000000000007346545000016013 5ustar0000000000000000clash-lib-1.8.1/src/Clash/Verification/Pretty.hs0000644000000000000000000002067507346545000017650 0ustar0000000000000000{-| Copyright : (C) 2019, Myrtle Software Ltd License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Verification -} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Verification.Pretty ( pprPslProperty , pprSvaProperty , pprYosysSvaProperty -- * Debugging functions , pprProperty ) where import Clash.Annotations.Primitive (HDL(..)) import Clash.Signal.Internal (ActiveEdge, ActiveEdge(..)) import Clash.Verification.Internal hiding (assertion) import Clash.Netlist.Types (Declaration(..), Seq(..), Expr, CommentOrDirective(..)) import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as Text (pack) data Symbol = TImpliesOverlapping | TImplies | Implies | BiImplies | Not | And | Or | To | Equals -- + [] ? | Assign | Is ------------------------------------------ -- UTIL -- ------------------------------------------ -- | Collapse constructs such as `next (next a)` down to `next[2] a` squashBefore :: Assertion' a -> [Assertion' a] squashBefore (CvBefore e1 e2) = e1s ++ e2s where e1s = case squashBefore e1 of {[] -> [e1]; es -> es} e2s = case squashBefore e2 of {[] -> [e2]; es -> es} squashBefore _ = [] parensIf :: Bool -> Text -> Text parensIf True s = "(" <> s <> ")" parensIf False s = s --------------------------------------- -- PSL -- --------------------------------------- pslBinOp :: HDL -> Bool -> Symbol -> Assertion' Text -> Assertion' Text -> Text pslBinOp hdl parens op e1 e2 = parensIf parens (e1' <> symbol hdl op <> e2') where e1' = pprPslAssertion hdl True e1 e2' = pprPslAssertion hdl True e2 pslEdge :: HDL -> ActiveEdge -> Text -> Text pslEdge SystemVerilog activeEdge clkId = pslEdge Verilog activeEdge clkId pslEdge Verilog Rising clkId = "posedge " <> clkId pslEdge Verilog Falling clkId = "negedge " <> clkId pslEdge VHDL Rising clkId = "rising_edge(" <> clkId <> ")" pslEdge VHDL Falling clkId = "falling_edge(" <> clkId <> ")" -- | Taken from IEEE Std 1850-2010a, Annex B.1, p149 symbol :: HDL -> Symbol -> Text symbol SystemVerilog = symbol Verilog symbol Verilog = \case TImpliesOverlapping -> "|->" TImplies -> "|=>" Implies -> "->" BiImplies -> "<->" Not -> "!" And -> "&&" Or -> "||" To -> ":" Assign -> "<=" Is -> "=" Equals -> "==" symbol VHDL = \case TImpliesOverlapping -> "|->" TImplies -> "|=>" Implies -> " -> " BiImplies -> " <-> " Not -> "not" And -> " and " Or -> " or " To -> " to " Assign -> "<=" Is -> "is" Equals -> "=" -- | Pretty print Property. Doesn't print valid HDL, but can be used for -- debugging purposes. pprProperty :: Property dom -> Declaration pprProperty (Property prop0) = let prop1 = fromMaybe "__autogen__" . fst <$> prop0 in pprPslProperty VHDL "prop" "clk" Rising prop1 pprPslProperty :: HDL -- ^ HDL to generate PSL expression for -> Text -- ^ Property name -> Text -- ^ Clock name -> ActiveEdge -- ^ Edge property should be sensitive to -> Property' Text -- ^ Assertion / Cover statement -> Declaration pprPslProperty hdl propName clkId edge assertion = TickDecl . Comment $ "psl property " <> propName <> " " <> symbol hdl Is <> "\n" <> "(" <> prop <> ") @(" <> pslEdge hdl edge clkId <> ")" <> ";\n" <> "psl " <> coverOrAssert <> " " <> propName <> ";" where (coverOrAssert, prop) = case assertion of CvCover e -> ("cover", pprPslAssertion hdl False e) CvAssert e -> ("assert", pprPslAssertion hdl False e) CvAssume e -> ("assume", pprPslAssertion hdl False e) pprPslAssertion :: HDL -> Bool -> Assertion' Text -> Text pprPslAssertion hdl parens e = case e of (CvPure p) -> p -- ModelSim/QuastaSim doesn't support booleans in PSL. Anytime we want to -- use a boolean literal we use (0 == 0) or (0 == 1) instead. (CvLit False) -> parensIf parens ("0" <> symbol hdl Equals <> "1") (CvLit True) -> parensIf parens ("0" <> symbol hdl Equals <> "0") (CvNot e1) -> parensIf parens (symbol hdl Not <> " " <> pprPslAssertion hdl True e1) (CvAnd e1 e2) -> pslBinOp1 And e1 e2 (CvOr e1 e2) -> pslBinOp1 Or e1 e2 (CvImplies e1 e2) -> pslBinOp1 Implies e1 e2 (CvToTemporal e1) -> "{" <> pprPslAssertion hdl False e1 <> "}" (CvNext 0 e1) -> pprPslAssertion hdl parens e1 (CvNext 1 e1) -> " ## " <> pprPslAssertion hdl True e1 (CvNext n e1) -> " ##" <> Text.pack (show n) <> " " <> pprPslAssertion hdl False e1 (CvBefore _ _) -> "{" <> afters1 <> "}" where afters0 = map (pprPslAssertion hdl False) (squashBefore e) afters1 = foldl1 (\e1 e2 -> e1 <> "; " <> e2) afters0 (CvTemporalImplies 0 e1 e2) -> pslBinOp1 TImpliesOverlapping e1 e2 (CvTemporalImplies 1 e1 e2) -> pslBinOp1 TImplies e1 e2 (CvTemporalImplies n e1 e2) -> pslBinOp1 TImplies e1 (CvNext n e2) (CvAlways e1) -> "always " <> pprPslAssertion hdl True e1 (CvNever e1) -> "never " <> pprPslAssertion hdl True e1 (CvEventually e1) -> "eventually! " <> pprPslAssertion hdl True e1 where pslBinOp1 = pslBinOp hdl True --------------------------------------- -- SVA -- --------------------------------------- svaEdge :: ActiveEdge -> Text -> Text svaEdge Rising clkId = "posedge " <> clkId svaEdge Falling clkId = "negedge " <> clkId svaBinOp :: Bool -> Symbol -> Assertion' Text -> Assertion' Text -> Text svaBinOp parens op e1 e2 = parensIf parens (e1' <> symbol SystemVerilog op <> e2') where e1' = pprSvaAssertion True e1 e2' = pprSvaAssertion True e2 pprSvaAssertion :: Bool -> Assertion' Text -> Text pprSvaAssertion parens e = case e of (CvPure p) -> p (CvLit False) -> "false" (CvLit True) -> "true" (CvNot e1) -> parensIf parens (symbol' Not <> pprSvaAssertion True e1) (CvAnd e1 e2) -> svaBinOp1 And e1 e2 (CvOr e1 e2) -> svaBinOp1 Or e1 e2 (CvImplies e1 e2) -> svaBinOp1 Implies e1 e2 (CvToTemporal e1) -> "{" <> pprSvaAssertion False e1 <> "}" (CvNext 0 e1) -> pprSvaAssertion parens e1 (CvNext n e1) -> "nexttime[" <> Text.pack (show n) <> "] " <> pprSvaAssertion False e1 (CvBefore _ _) -> "{" <> afters1 <> "}" where afters0 = map (pprSvaAssertion False) (squashBefore e) afters1 = foldl1 (\e1 e2 -> "(" <> e1 <> ") ##1 (" <> e2 <> ")") afters0 (CvTemporalImplies 0 e1 e2) -> svaBinOp1 TImpliesOverlapping e1 e2 (CvTemporalImplies 1 e1 e2) -> svaBinOp1 TImplies e1 e2 (CvTemporalImplies n e1 e2) -> svaBinOp1 TImplies e1 (CvNext n e2) (CvAlways e1) -> "always (" <> pprSvaAssertion False e1 <> ")" (CvNever _e) -> error "'never' not supported in SVA" (CvEventually e1) -> "s_eventually (" <> pprSvaAssertion False e1 <> ")" where svaBinOp1 = svaBinOp parens symbol' = symbol SystemVerilog pprSvaProperty :: Text -- ^ Property name -> Text -- ^ Clock name -> ActiveEdge -- ^ Edge property should be sensitive to -> Property' Text -- ^ Assertion / Cover statement -> Declaration pprSvaProperty propName clkId edge assertion = TickDecl . Comment $ propName <> ": " <> coverOrAssert <> " property (@(" <> svaEdge edge clkId <> ") " <> prop <> ");" where (coverOrAssert, prop) = case assertion of CvCover e -> ("cover", pprSvaAssertion False e) CvAssert e -> ("assert", pprSvaAssertion False e) CvAssume e -> ("assume", pprSvaAssertion False e) --------------------------------------- -- Yosys Formal Extensions -- --------------------------------------- -- | Generate something like: -- @always @(posedge clk_i) isOn: cover (result);@ pprYosysSvaProperty :: Text -- ^ Property name -> Expr -- ^ Clock expression -> ActiveEdge -- ^ Edge property should be sensitive to -> Property' Text -- ^ Assertion / Cover statement -> Declaration pprYosysSvaProperty propName clk edge assertion = ConditionalDecl "FORMAL" [Seq [AlwaysClocked edge clk [SeqDecl (TickDecl directive)]]] where directive = Directive (propName <> ": " <> coverOrAssert <> " property (" <> prop <> ")") (coverOrAssert, prop) = case assertion of CvCover e -> ("cover", pprSvaAssertion False e) CvAssert e -> ("assert", pprSvaAssertion False e) CvAssume e -> ("assume", pprSvaAssertion False e) clash-lib-1.8.1/src/0000755000000000000000000000000007346545000012337 5ustar0000000000000000clash-lib-1.8.1/src/ClashDebug.h0000755000000000000000000000041507346545000014514 0ustar0000000000000000#pragma once #define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else #define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else #define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $ clash-lib-1.8.1/src/Data/Aeson/0000755000000000000000000000000007346545000014255 5ustar0000000000000000clash-lib-1.8.1/src/Data/Aeson/Extra.hs0000644000000000000000000001675707346545000015714 0ustar0000000000000000{-| Copyright : (C) 2015-2016, University of Twente License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} {-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} module Data.Aeson.Extra where import Control.Exception (throw) import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import qualified Data.Ix as Ix import qualified Data.Text as T import Data.Text (Text,pack,unpack) import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT import Data.Text.Encoding.Error (UnicodeException(..)) import Data.List (intercalate) 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) import Data.Attoparsec.Lazy (Result (..), parse) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BSChar import qualified Data.Yaml as Yaml import System.FilePath () import qualified Clash.Util.Interpolate as I import Clash.Util (ClashException(..)) #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (mkGeneralSrcSpan) import GHC.Data.FastString (mkFastString) #else import SrcLoc (mkGeneralSrcSpan) import FastString (mkFastString) #endif import GHC.Stack (HasCallStack) -- | See 'toSpecNewlines'. A line map maps "virtual" lines to a range of -- "real" lines. E.g., a map of {0: (0, 3), 1: (4, 5)} would mean that line -- 0 in the virtual JSON (i.e., the one with newlines replaced) file map to -- lines 0 up to and including 3 in the original user-supplied one. type LineMap = IntMap (Int, Int) -- | Aeson versions <1.5.0 accept unescaped newlines in JSON strings. This is in -- violation of RFC 7159. Aeson 1.5.0 fixes this bug. Unfortunately, "Clash -- JSON" files rely on the old behavior. This function replaces newlines (in -- strings) with their escaped variants. toSpecNewlines :: ByteString -> Either UnicodeException (LineMap, ByteString) toSpecNewlines bs = do s0 <- LT.unpack <$> LT.decodeUtf8' bs Right ( toLineMap (go2 0 False s0) , LT.encodeUtf8 (LT.pack (go False s0))) where -- replace newlines with escaped ones go :: Bool -> String -> String go _ [] = [] go True ('\n':rest) = '\\' : 'n' : go True rest go True ('\r':rest) = '\\' : 'r' : go True rest go True ('\t':rest) = '\\' : 't' : go True rest go inString ('\\':r:rest) = '\\' : r : go inString rest go inString ('"':rest) = '"' : go (not inString) rest go inString (r:rest) = r : go inString rest -- Calculate real:virtual mapping go2 -- virtual line counter. :: Int -- Processing a JSON string? -> Bool -- String left to process -> String -- Virtual line numbers. [0, 1, 1, 2, 2, ..] would mean: -- -- real | virtual -- -------------- -- 0 | 0 -- 1 | 1 -- 2 | 1 -- 3 | 2 -- 4 | 2 -- ... | ... -- -> [Int] go2 n _ [] = [n] go2 n True ('\n':rest) = n : go2 n True rest go2 n False ('\n':rest) = n : go2 (succ n) False rest go2 n inString ('\\':_:rest) = go2 n inString rest go2 n inString ('"':rest) = go2 n (not inString) rest go2 n inString (_:rest) = go2 n inString rest toLineMap :: [Int] -> LineMap toLineMap [] = IntMap.empty toLineMap (v:virtuals) = IntMap.fromList $ map (second (\reals -> (minimum reals, maximum reals))) $ 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 = T.unlines [ T.concat [ if elem i errorLines then pack ">> " else pack " " , pack $ show (i + 1) , pack ". " , allLines !! i ] | i <- Ix.range range] -- | Pretty print part of json file related to error genLineErr :: LineMap -> ByteString -> ByteString -> ByteString -> Text genLineErr lineMap fullOrig full part = genLineErr' allLinesOrig interval [errorLineMin..errorLineMax] where -- Determine error line in "virtual" json file nLastLines = 1 + (length $ LT.lines $ LT.decodeUtf8 part) errorLineN = min (length allLines - 1) (length allLines - nLastLines + 1) allLines = T.lines $ LT.toStrict $ LT.decodeUtf8 full -- Convert to error lines in actual json file, and calculate interval -- to display to user. allLinesOrig = T.lines $ LT.toStrict $ LT.decodeUtf8 fullOrig (errorLineMin, errorLineMax) = lineMap IntMap.! errorLineN interval = ( max 0 (errorLineMin - 5) , min (max 0 $ length allLinesOrig - 1) (errorLineMax + 5) ) -- | Parse a ByteString according to the given JSON template. Throws exception -- if it fails. decodeOrErrYaml :: (HasCallStack, FromJSON a) => FilePath -- ^ Path read from (for error message) -> ByteString -- ^ Bytestring to parse -> a decodeOrErrYaml path contents = case Yaml.decodeEither' (BS.toStrict contents) of Left (Yaml.prettyPrintParseException -> err) -> clashError [I.i| Failed to decode YAML: #{path} Decoder reported: #{err} |] Right a -> a where clashError msg = throw (ClashException loc msg Nothing) loc = mkGeneralSrcSpan (mkFastString path) -- | Parse a ByteString according to the given JSON template. Throws exception -- if it fails. decodeOrErrJson :: (HasCallStack, FromJSON a) => FilePath -- ^ Path read from (for error message) -> ByteString -- ^ Bytestring to parse -> a decodeOrErrJson path contents0 = case toSpecNewlines contents0 of Left (DecodeError err _) -> clashError [I.i| Failed to decode JSON file as UTF8: #{path} Decoder reported: #{err} |] Left _ -> error "unreachable" Right (!lineMap, !contents1) -> case parse json contents1 of Done leftover v -> case fromJSON v of Success _ | BS.any notWhitespace leftover -> clashError ("After parsing " ++ show path ++ ", found unparsed trailing garbage:\n" ++ BSChar.unpack leftover) Success a -> a Error msg -> clashError ( "Could not deduce valid scheme for json in " ++ show path ++ ". Error was: \n\n" ++ msg ) -- JSON parse error: Fail bytes cntxs msg -> clashError ( "Could not read or parse json in " ++ show path ++ ". " ++ (if null cntxs then "" else "Context was:\n " ++ intercalate "\n " cntxs) ++ "\n\nError reported by Attoparsec was:\n " ++ msg ++ "\n\nApproximate location of error:\n\n" -- HACK: Replace with proper parser/fail logic in future. Or don't. It's not important. ++ (unpack $ genLineErr lineMap contents0 contents1 bytes) ) where loc = mkGeneralSrcSpan $ mkFastString path clashError msg = throw $ ClashException loc msg Nothing notWhitespace c = BS.notElem c whitespace where whitespace = BSChar.pack " \t\n\r" clash-lib-1.8.1/src/Data/IntMap/0000755000000000000000000000000007346545000014400 5ustar0000000000000000clash-lib-1.8.1/src/Data/IntMap/Extra.hs0000644000000000000000000000230007346545000016012 0ustar0000000000000000{-# LANGUAGE CPP #-} module Data.IntMap.Extra where #if !MIN_VERSION_containers(0,6,2) import Data.IntMap.Internal -- TODO We can remove this when support for GHC 8.6 is dropped. -- | /O(n+m)/. Check whether the key sets of two maps are disjoint -- (i.e. their 'intersection' is empty). -- -- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())]) == True -- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False -- > disjoint (fromList []) (fromList []) == True -- -- > disjoint a b == null (intersection a b) -- disjoint :: IntMap a -> IntMap b -> Bool disjoint Nil _ = True disjoint _ Nil = True disjoint (Tip kx _) ys = notMember kx ys disjoint xs (Tip ky _) = notMember ky xs disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) | shorter m1 m2 = disjoint1 | shorter m2 m1 = disjoint2 | p1 == p2 = disjoint l1 l2 && disjoint r1 r2 | otherwise = True where disjoint1 | nomatch p2 p1 m1 = True | zero p2 m1 = disjoint l1 t2 | otherwise = disjoint r1 t2 disjoint2 | nomatch p1 p2 m2 = True | zero p1 m2 = disjoint t1 l2 | otherwise = disjoint t1 r2 #endif clash-lib-1.8.1/src/Data/List/0000755000000000000000000000000007346545000014123 5ustar0000000000000000clash-lib-1.8.1/src/Data/List/Extra.hs0000644000000000000000000000567407346545000015556 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} module Data.List.Extra ( partitionM , mapAccumLM , iterateNM , (<:>) , indexMaybe , splitAtList , equalLength , countEq , zipEqual , all2 -- * From Control.Monad.Extra , anyM , allM , orM -- * From "extra" , module NeilsExtra ) where 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) #endif -- | Monadic version of 'Data.List.mapAccumL' mapAccumLM :: (Monad m) => (acc -> x -> m (acc,y)) -> acc -> [x] -> m (acc,[y]) mapAccumLM _ acc [] = return (acc,[]) mapAccumLM f acc (x:xs) = do (acc',y) <- f acc x (acc'',ys) <- mapAccumLM f acc' xs return (acc'',y:ys) -- | Monadic version of 'iterate'. A carbon copy ('iterateM') would not -- terminate, hence the first argument. iterateNM :: Monad m => Word -- ^ Only iterate /n/ times. Note that /n/ is the length of the resulting -- list, _not_ the number of times the iteration function has been invoked -> (a -> m a) -- ^ Iteration function -> a -- ^ Start value -> m [a] iterateNM 0 _f _a = pure [] iterateNM limit f a = fmap (a:) (go (limit - 1) a) where go 0 _a0 = pure [] go n a0 = do a1 <- f a0 fmap (a1:) (go (n - 1) a1) infixr 5 <:> -- | Applicative version of 'GHC.Types.(:)' (<:>) :: Applicative f => f a -> f [a] -> f [a] (<:>) = liftA2 (:) -- | Safe indexing, returns a 'Nothing' if the index does not exist indexMaybe :: [a] -> Int -> Maybe a indexMaybe [] _ = Nothing indexMaybe (x:_) 0 = Just x indexMaybe (_:xs) n = indexMaybe xs (n-1) splitAtList :: [b] -> [a] -> ([a], [a]) splitAtList [] xs = ([], xs) splitAtList _ xs@[] = (xs, xs) splitAtList (_:xs) (y:ys) = (y:ys', ys'') where (ys', ys'') = splitAtList xs ys equalLength :: [a] -> [b] -> Bool equalLength [] [] = True equalLength (_:as) (_:bs) = equalLength as bs equalLength _ _ = False -- | Like 'all', but the predicate operates over two lists. Asserts to 'False' -- when the lists are of unequal length all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool all2 _ [] [] = True all2 p (a:as) (b:bs) = p a b && all2 p as bs all2 _ _ _ = False -- | Return number of occurrences of an item in a list countEq :: Eq a => a -- ^ Needle -> [a] -- ^ Haystack -> Int -- ^ Times needle was found in haystack countEq a as = length (filter (== a) as) -- | Zip two lists of equal length -- -- NB Errors out for a DEBUG compiler when the two lists are not of equal length #if !defined(DEBUG) zipEqual :: [a] -> [b] -> [(a,b)] zipEqual = zip {-# INLINE zipEqual #-} #else zipEqual :: HasCallStack => [a] -> [b] -> [(a,b)] zipEqual = go where go [] [] = [] go (a:as) (b:bs) = (a,b) : go as bs go (_:_) [] = error "zipEqual: left list is longer" go [] (_:_) = error "zipEqual: right list is longer" #endif clash-lib-1.8.1/src/Data/Map/Ordered/0000755000000000000000000000000007346545000015311 5ustar0000000000000000clash-lib-1.8.1/src/Data/Map/Ordered/Extra.hs0000644000000000000000000000041107346545000016724 0ustar0000000000000000{-# OPTIONS_GHC -Wno-orphans #-} module Data.Map.Ordered.Extra where import Control.DeepSeq (NFData(rnf)) import Data.Map.Ordered (OMap) import qualified Data.Map.Ordered as OMap instance (NFData k, NFData v) => NFData (OMap k v) where rnf = rnf . OMap.assocs clash-lib-1.8.1/src/Data/Monoid/0000755000000000000000000000000007346545000014435 5ustar0000000000000000clash-lib-1.8.1/src/Data/Monoid/Extra.hs0000644000000000000000000000055107346545000016055 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Data.Monoid.Extra where import Control.Monad.State (MonadState(..)) import Data.Monoid (Ap(Ap)) instance (MonadState s m) => MonadState s (Ap m) where get = Ap get put = Ap . put state = Ap . state clash-lib-1.8.1/src/Data/Primitive/ByteArray/0000755000000000000000000000000007346545000017062 5ustar0000000000000000clash-lib-1.8.1/src/Data/Primitive/ByteArray/Extra.hs0000644000000000000000000000254307346545000020505 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} module Data.Primitive.ByteArray.Extra where import Data.Binary (Binary(..)) import Data.Primitive.ByteArray (ByteArray) import GHC.Exts (IsList(..)) #if !MIN_VERSION_primitive(0,7,1) import Control.DeepSeq (NFData(..)) #endif -- hashable 1.4.2 defines Hashable for Data.Array.Byte.ByteArray, either from -- base or from the data-array-byte compat package for GHC < 9.4. -- primitive 0.8.0.0 re-exports this ByteArray. #if !MIN_VERSION_primitive(0,8,0) -- In primitive < 0.8.0.0, its ByteArray is a distinct type from -- Data.Array.Byte.ByteArray (insofar as the latter even exists). #define DEFINE_HASHABLE_BYTEARRAY #elif !MIN_VERSION_hashable(1,4,1) -- hashable < 1.4.1 doesn't define a Hashable ByteArray instance at all. #define DEFINE_HASHABLE_BYTEARRAY #elif !MIN_VERSION_hashable(1,4,2) -- hashable 1.4.1 defines hashable for the ByteArray added to base 4.17. #if !MIN_VERSION_base(4,17,0) #define DEFINE_HASHABLE_BYTEARRAY #endif #endif #ifdef DEFINE_HASHABLE_BYTEARRAY import Data.Hashable (Hashable(..)) #endif #if !MIN_VERSION_primitive(0,7,1) instance NFData ByteArray where rnf x = x `seq` () #endif instance Binary ByteArray where get = fmap fromList get put = put . toList #ifdef DEFINE_HASHABLE_BYTEARRAY instance Hashable ByteArray where hashWithSalt salt = hashWithSalt salt . toList #endif clash-lib-1.8.1/src/Data/Set/Ordered/0000755000000000000000000000000007346545000015327 5ustar0000000000000000clash-lib-1.8.1/src/Data/Set/Ordered/Extra.hs0000644000000000000000000000111707346545000016746 0ustar0000000000000000{-| Copyright : (C) 2019,2021, QBayLogic B.V License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V Convenience functions for "Data.Set.Ordered" from the package "ordered-containers". -} module Data.Set.Ordered.Extra ( OLSet , toListL ) where import Data.Coerce (coerce) import Data.Foldable (toList) import qualified Data.Set.Ordered as OSet type OLSet a = OSet.Bias OSet.L (OSet.OSet a) toListL :: forall a. OLSet a -> [a] toListL = toList . coerce @(OLSet a) @(OSet.OSet a) clash-lib-1.8.1/src/Data/Text/0000755000000000000000000000000007346545000014134 5ustar0000000000000000clash-lib-1.8.1/src/Data/Text/Extra.hs0000644000000000000000000000036407346545000015556 0ustar0000000000000000module Data.Text.Extra ( showt , showtl ) where import qualified Data.Text as TS import qualified Data.Text.Lazy as TL showt :: (Show a) => a -> TS.Text showt = TS.pack . show showtl :: (Show a) => a -> TL.Text showtl = TL.pack . show clash-lib-1.8.1/src/Data/Text/Prettyprint/Doc/0000755000000000000000000000000007346545000017205 5ustar0000000000000000clash-lib-1.8.1/src/Data/Text/Prettyprint/Doc/Extra.hs0000644000000000000000000001162107346545000020625 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Data.Text.Prettyprint.Doc.Extra ( module Data.Text.Prettyprint.Doc.Extra , LayoutOptions (..) , PageWidth (..) , layoutCompact , layoutPretty , renderLazy ) where import Control.Applicative import Data.String (IsString (..)) import Data.Text as T import Data.Text.Lazy as LT #if MIN_VERSION_prettyprinter(1,7,0) import qualified Prettyprinter as PP import Prettyprinter.Internal hiding (Doc) import Prettyprinter.Render.Text #else import qualified Data.Text.Prettyprint.Doc as PP import Data.Text.Prettyprint.Doc.Internal hiding (Doc) import Data.Text.Prettyprint.Doc.Render.Text #endif type Doc = PP.Doc () layoutOneLine :: PP.Doc ann -> SimpleDocStream ann layoutOneLine doc = scan 0 [doc] where scan _ [] = SEmpty scan !col (d:ds) = case d of Fail -> SFail Empty -> scan col ds Char c -> SChar c (scan (col+1) ds) Text l t -> let !col' = col+l in SText l t (scan col' ds) FlatAlt x _ -> scan col (x:ds) Line -> scan col ds Cat x y -> scan col (x:y:ds) Nest _ x -> scan col (x:ds) Union _ y -> scan col (y:ds) Column f -> scan col (f col:ds) WithPageWidth f -> scan col (f Unbounded : ds) Nesting f -> scan col (f 0 : ds) Annotated _ x -> scan col (x:ds) renderOneLine :: PP.Doc ann -> LT.Text renderOneLine = renderLazy . layoutPretty defaultLayoutOptions int :: Applicative f => Int -> f Doc int = pure . PP.pretty integer :: Applicative f => Integer -> f Doc integer = pure . PP.pretty char :: Applicative f => Char -> f Doc char = pure . PP.pretty lbrace :: Applicative f => f Doc lbrace = pure PP.lbrace rbrace :: Applicative f => f Doc rbrace = pure PP.rbrace colon :: Applicative f => f Doc colon = pure PP.colon semi :: Applicative f => f Doc semi = pure PP.semi equals :: Applicative f => f Doc equals = pure PP.equals comma :: Applicative f => f Doc comma = pure PP.comma dot :: Applicative f => f Doc dot = pure PP.dot lparen :: Applicative f => f Doc lparen = pure PP.lparen rparen :: Applicative f => f Doc rparen = pure PP.rparen space :: Applicative f => f Doc space = pure PP.space brackets :: Functor f => f Doc -> f Doc brackets = fmap PP.brackets braces :: Functor f => f Doc -> f Doc braces = fmap PP.braces tupled :: Functor f => f [Doc] -> f Doc tupled = fmap PP.tupled (<+>) :: Applicative f => f Doc -> f Doc -> f Doc (<+>) = liftA2 (PP.<+>) infixr 6 <+> vcat :: Functor f => f [Doc] -> f Doc vcat = fmap PP.vcat hcat :: Functor f => f [Doc] -> f Doc hcat = fmap PP.hcat nest :: Functor f => Int -> f Doc -> f Doc nest i = fmap (PP.nest i) indent :: Functor f => Int -> f Doc -> f Doc indent i = fmap (PP.indent i) parens :: Functor f => f Doc -> f Doc parens = fmap PP.parens emptyDoc :: Applicative f => f Doc emptyDoc = pure PP.emptyDoc punctuate :: Applicative f => f Doc -> f [Doc] -> f [Doc] punctuate = liftA2 PP.punctuate encloseSep :: Applicative f => f Doc -> f Doc -> f Doc -> f [Doc] -> f Doc encloseSep l r s is = PP.encloseSep <$> l <*> r <*> s <*> is enclose :: Applicative f => f Doc -> f Doc -> f Doc -> f Doc enclose = liftA3 PP.enclose line :: Applicative f => f Doc line = pure PP.line line' :: Applicative f => f Doc line' = pure PP.line' softline :: Applicative f => f Doc softline = pure PP.softline softline' :: Applicative f => f Doc softline' = pure PP.softline' pretty :: (Applicative f, Pretty a) => a -> f Doc pretty = pure . PP.pretty stringS :: Applicative f => T.Text -> f Doc stringS = pure . PP.pretty string :: Applicative f => LT.Text -> f Doc string = pure . PP.pretty squotes :: Applicative f => f Doc -> f Doc squotes = fmap PP.squotes dquotes :: Functor f => f Doc -> f Doc dquotes = fmap PP.dquotes align :: Functor f => f Doc -> f Doc align = fmap PP.align hsep :: Functor f => f [Doc] -> f Doc hsep = fmap PP.hsep vsep :: Functor f => f [Doc] -> f Doc vsep = fmap PP.vsep isEmpty :: Doc -> Bool isEmpty Empty = True isEmpty _ = False fill :: Applicative f => Int -> f Doc -> f Doc fill = fmap . PP.fill column :: Functor f => f (Int -> Doc) -> f Doc column = fmap PP.column nesting :: Functor f => f (Int -> Doc) -> f Doc nesting = fmap PP.nesting flatAlt :: Applicative f => f Doc -> f Doc -> f Doc flatAlt = liftA2 PP.flatAlt instance Applicative f => IsString (f Doc) where fromString = string . fromString comment :: Applicative f => T.Text -> T.Text -> f Doc comment prefix comm = let go s = PP.pretty prefix PP.<+> PP.pretty s in pure (PP.vsep (Prelude.map go (T.lines comm))) squote :: Applicative f => f Doc squote = string (LT.pack "'") clash-lib-1.8.1/src/GHC/BasicTypes/0000755000000000000000000000000007346545000015006 5ustar0000000000000000clash-lib-1.8.1/src/GHC/BasicTypes/Extra.hs0000644000000000000000000000313607346545000016430 0ustar0000000000000000{-| Copyright : (C) 2017, Google Inc. 2023, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.BasicTypes.Extra where #if MIN_VERSION_ghc(9,0,0) import GHC.Types.Basic #else import BasicTypes #endif import Control.DeepSeq 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 clash-lib-1.8.1/src/GHC/SrcLoc/0000755000000000000000000000000007346545000014125 5ustar0000000000000000clash-lib-1.8.1/src/GHC/SrcLoc/Extra.hs0000644000000000000000000000463207346545000015551 0ustar0000000000000000{-| Copyright : (C) 2017, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.SrcLoc.Extra where import Data.Binary import Data.Hashable (Hashable (..)) import GHC.Generics #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (SrcSpan (..), RealSrcLoc, RealSrcSpan, BufSpan (..), BufPos (..), UnhelpfulSpanReason (..), mkRealSrcLoc, mkRealSrcSpan, realSrcSpanStart, realSrcSpanEnd, srcLocFile, srcLocLine, srcLocCol, srcSpanFile, srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol) import GHC.Data.FastString (FastString (..), bytesFS, mkFastStringByteList) #else import SrcLoc (SrcSpan (..), RealSrcLoc, RealSrcSpan, mkRealSrcLoc, mkRealSrcSpan, realSrcSpanStart, realSrcSpanEnd, srcLocFile, srcLocLine, srcLocCol, 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,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 instance Hashable SrcSpan instance Hashable RealSrcSpan where hashWithSalt salt rss = hashWithSalt salt (srcSpanFile rss,srcSpanStartLine rss, srcSpanEndLine rss ,srcSpanStartCol rss, srcSpanEndCol rss) instance Hashable FastString where hashWithSalt salt fs = hashWithSalt salt (uniq fs) instance Binary SrcSpan instance Binary RealSrcSpan where put r = put (realSrcSpanStart r, realSrcSpanEnd r) get = uncurry mkRealSrcSpan <$> get instance Binary RealSrcLoc where put r = put (srcLocFile r, srcLocLine r, srcLocCol r) get = (\(file,line,col) -> mkRealSrcLoc file line col) <$> get instance Binary FastString where put str = put $ bytesFS str get = mkFastStringByteList <$> get #if MIN_VERSION_ghc(9,0,0) deriving instance Generic BufPos instance Binary BufPos instance Hashable BufPos deriving instance Generic UnhelpfulSpanReason instance Binary UnhelpfulSpanReason instance Hashable UnhelpfulSpanReason deriving instance Generic BufSpan instance Binary BufSpan instance Hashable BufSpan #endif clash-lib-1.8.1/tests/Clash/Tests/Core/0000755000000000000000000000000007346545000015736 5ustar0000000000000000clash-lib-1.8.1/tests/Clash/Tests/Core/FreeVars.hs0000644000000000000000000000367607346545000020023 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Tests.Core.FreeVars (tests) where #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (noSrcSpan) #else import SrcLoc (noSrcSpan) #endif import qualified Control.Lens as Lens import Test.Tasty import Test.Tasty.HUnit import Clash.Core.FreeVars (globalIds) import Clash.Core.Name (Name(..), NameSort(..)) import Clash.Core.Term (Term(Var, App, Lam)) import Clash.Core.Type (ConstTy(..), Type(ConstTy)) import Clash.Core.Var (IdScope(..), Var(..)) -- TODO: We need tooling to create these mock constructs fakeName :: Name a fakeName = Name { nameSort=User , nameOcc="fake" , nameUniq=0 , nameLoc=noSrcSpan } f :: IdScope -> Var Term f scope = let unique = 20 in Id { varName = Name { nameSort=User , nameOcc="f" , nameUniq=unique , nameLoc=noSrcSpan } , varUniq = unique , varType = ConstTy (TyCon fakeName) , idScope = scope } fLocalId, fGlobalId :: Var Term fLocalId = f LocalId fGlobalId = f GlobalId -- 'term1' is a simple lambda function: -- -- \f -> g f -- -- where f and g have the same unique, but f has been marked as _local_ while -- g is _global_. In other words: -- -- \f[l] -> f[g] f[l] -- -- This term is tested against to check whether various functions account for -- the distinction between local/global variables correctly. term1 :: Term term1 = Lam fLocalId (Var fGlobalId `App` Var fLocalId) tests :: TestTree tests = let globs1 = Lens.toListOf globalIds term1 in testGroup "Clash.Tests.Core.FreeVars" [ testCase "globalIds1" $ globs1 @=? [fGlobalId] , testCase "globalIds2" $ assertBool "Global and local id can't BOTH be in globs1" (fLocalId `notElem` globs1) ] clash-lib-1.8.1/tests/Clash/Tests/Core/Subst.hs0000644000000000000000000000225107346545000017372 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Tests.Core.Subst (tests) where #if MIN_VERSION_ghc(9,0,0) import GHC.Types.SrcLoc (noSrcSpan) #else import SrcLoc (noSrcSpan) #endif import Test.Tasty import Test.Tasty.HUnit import Clash.Core.Name (Name(..), NameSort(..)) import Clash.Core.Term (Term(Var)) import Clash.Core.Type (ConstTy(..), Type(ConstTy)) import Clash.Core.Subst import Clash.Core.VarEnv import Clash.Core.Var (IdScope(..), Var(..)) fakeName :: Name a fakeName = Name { nameSort=User , nameOcc="fake" , nameUniq=0 , nameLoc=noSrcSpan } unique :: Int unique = 20 termVar :: Var Term termVar = Id { varName = fakeName {nameUniq=unique, nameOcc="term"} , varUniq = unique , varType = ConstTy (TyCon fakeName) , idScope = LocalId } term1 :: Term term1 = Var termVar tests :: TestTree tests = testGroup "Clash.Tests.Core.Subst" [ testCase "deShadow type/term" $ term1 @=? deShadowTerm (extendInScopeSet emptyInScopeSet termVar) term1 ] clash-lib-1.8.1/tests/Clash/Tests/Core/TermLiteral.hs0000644000000000000000000000340307346545000020516 0ustar0000000000000000{-| 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)] clash-lib-1.8.1/tests/Clash/Tests/Core/TermLiteral/0000755000000000000000000000000007346545000020162 5ustar0000000000000000clash-lib-1.8.1/tests/Clash/Tests/Core/TermLiteral/Types.hs0000644000000000000000000000016407346545000021623 0ustar0000000000000000module Clash.Tests.Core.TermLiteral.Types where import Clash.Promoted.Nat data NatTypeArg n = NatTypeArg (SNat n) clash-lib-1.8.1/tests/Clash/Tests/Driver/0000755000000000000000000000000007346545000016301 5ustar0000000000000000clash-lib-1.8.1/tests/Clash/Tests/Driver/Manifest.hs0000644000000000000000000000627007346545000020410 0ustar0000000000000000{-# LANGUAGE NamedFieldPuns #-} module Clash.Tests.Driver.Manifest where import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encode.Pretty as Aeson 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 import qualified Data.Text.Encoding as Text import Test.Tasty import qualified Test.Tasty.QuickCheck as Q import qualified Test.QuickCheck.Utf8 as Q import Clash.Driver.Manifest import Clash.Explicit.Signal newtype ArbitraryText = ArbitraryText Text deriving (Show) instance Q.Arbitrary ArbitraryText where arbitrary = coerce Q.genValidUtf8 shrink = coerce Q.shrinkValidUtf8 newtype ArbitraryPortDirection = ArbitraryPortDirection PortDirection deriving (Show) instance Q.Arbitrary ArbitraryPortDirection where arbitrary = ArbitraryPortDirection <$> Q.elements [In, Out, InOut] genDigest :: Q.Gen ByteString genDigest = Base16.encode . Text.encodeUtf8 . coerce @ArbitraryText <$> Q.arbitrary genString :: Q.Gen FilePath genString = Text.unpack . coerce @ArbitraryText <$> Q.arbitrary genDomain :: Q.Gen (Text, VDomainConfiguration) genDomain = do nm <- coerce @(Q.Gen ArbitraryText) Q.arbitrary dom <- VDomainConfiguration <$> pure (Text.unpack nm) <*> (fromIntegral @Int . abs <$> Q.arbitraryBoundedIntegral) <*> Q.elements [Rising, Falling] <*> Q.elements [Synchronous, Asynchronous] <*> Q.elements [Defined, Unknown] <*> Q.elements [ActiveHigh, ActiveLow] pure (nm, dom) genPort :: Q.Gen ManifestPort genPort = ManifestPort <$> coerce @(Q.Gen ArbitraryText) Q.arbitrary <*> coerce @(Q.Gen ArbitraryText) Q.arbitrary <*> coerce @(Q.Gen ArbitraryPortDirection) Q.arbitrary <*> (fromIntegral @Int . abs <$> Q.arbitraryBoundedIntegral) <*> Q.elements [False, True] <*> coerce @(Q.Gen (Maybe ArbitraryText)) Q.arbitrary genManifest :: Q.Gen Manifest genManifest = Manifest <$> genDigest -- hash <*> Q.arbitrary -- flags <*> Q.listOf genPort -- ports <*> coerce @(Q.Gen [ArbitraryText]) @(Q.Gen [Text]) Q.arbitrary -- comp names <*> coerce @(Q.Gen ArbitraryText) @(Q.Gen Text) Q.arbitrary -- top name <*> Q.listOf ((,) <$> genString <*> genDigest) -- files <*> (HashMap.fromList <$> Q.listOf genDomain) -- domains <*> coerce @(Q.Gen [ArbitraryText]) @(Q.Gen [Text]) Q.arbitrary -- dependencies tests :: TestTree tests = adjustOption (\_ -> Q.QuickCheckTests 100) $ testGroup "Clash.Tests.Driver.Manifest" [ Q.testProperty "decode . encode ~ id" $ do manifest <- genManifest let encoded = Aeson.encodePretty manifest decoded = Aeson.eitherDecode encoded pure (decoded Q.=== Right manifest) , Q.testProperty "FilesManifest can decode encoded Manifest" $ do manifest@Manifest{fileNames} <- genManifest let encoded = Aeson.encodePretty manifest FilesManifest fileNamesDecoded = fromRight (error "Failed to decode manifest") (Aeson.eitherDecode encoded) pure (fileNamesDecoded Q.=== fileNames) ] clash-lib-1.8.1/tests/Clash/Tests/Netlist/0000755000000000000000000000000007346545000016470 5ustar0000000000000000clash-lib-1.8.1/tests/Clash/Tests/Netlist/Id.hs0000644000000000000000000002211607346545000017362 0ustar0000000000000000{-| Copyright : (C) 2019, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MagicHash #-} module Clash.Tests.Netlist.Id ( module Clash.Tests.Netlist.Id ) where import qualified Clash.Netlist.Types as Id import qualified Clash.Netlist.Id as Id import Clash.Annotations.Primitive import Control.Monad.Trans.State.Lazy import qualified Data.ByteString as BS import Data.Coerce import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import qualified Data.Text as Text import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) import Test.QuickCheck.Utf8 newtype NonEmptyText = NonEmptyText Text deriving (Show) newtype ArbitraryText = ArbitraryText Text deriving (Show) newtype ArbitraryAsciiText = ArbitraryAsciiText Text deriving (Show) instance Arbitrary ArbitraryAsciiText where arbitrary = coerce (decodeUtf8 . BS.concat <$> listOf oneByte) shrink = coerce shrinkValidUtf8 instance Arbitrary ArbitraryText where arbitrary = coerce genValidUtf8 shrink = coerce shrinkValidUtf8 instance Arbitrary NonEmptyText where arbitrary = coerce genValidUtf81 shrink = coerce shrinkValidUtf81 eval :: Bool -> HDL -> State Id.IdentifierSet a -> a eval esc hdl a = evalState a (Id.emptyIdentifierSet esc Id.PreserveCase hdl) eval' :: State Id.IdentifierSet a -> a eval' = eval True VHDL roundTrip :: Bool -> HDL -> Text -> Text roundTrip esc hdl = Id.toText . eval esc hdl . Id.make roundTrip' :: Text -> Text roundTrip' = roundTrip True VHDL roundTripTest :: Text -> TestTree roundTripTest t = testCase (Text.unpack ("roundTrip: " <> t)) (t @=? roundTrip' t) -- | Raw identifiers should always come up the same after 'Id.toText' rawToIdProperty :: NonEmptyText -> Property rawToIdProperty t = coerce t === Id.toText (eval' (Id.addRaw (coerce t))) xor :: Bool -> Bool -> Bool xor True True = False xor True False = True xor False True = True xor False False = False tests :: TestTree tests = testGroup "Clash.Tests.Netlist.Id" [ testCase "roundTrip: empty id" ("clash_internal" @=? roundTrip' "") -- Round trip tests tess whether a "make -> to text" roundtrip ~ id , roundTripTest "foo_bar" , roundTripTest "foo_1" , roundTripTest "foo_1_2" , roundTripTest "foo_1_2_ab" , roundTripTest "foo_1_ab_2" , testGroup "no collisions (one id)" $ flip map [minBound..maxBound] $ \hdl -> testProperty (show hdl) $ \id0 -> eval True hdl $ do id0t <- Id.toText <$> Id.make (coerce @ArbitraryAsciiText id0) id1t <- Id.toText <$> Id.make (coerce @ArbitraryAsciiText id0) pure (id0t /= id1t) , testGroup "no collisions (two ids)" $ flip map [minBound..maxBound] $ \hdl -> testProperty (show hdl) $ \id0 id1 -> eval True hdl $ do id0t <- Id.toText <$> Id.make (coerce @ArbitraryAsciiText id0) id1t <- Id.toText <$> Id.make (coerce @ArbitraryAsciiText id1) pure (id0t /= id1t) , testGroup "make0" $ eval' $ do id0 <- Id.toText <$> Id.make "foo" id1 <- Id.toText <$> Id.make "foo" id2 <- Id.toText <$> Id.make "foo_0" id3 <- Id.toText <$> Id.make "foo" id4 <- Id.toText <$> Id.make "foo_0" pure [ testCase "id0 == foo" $ id0 @?= "foo" , testCase "id1 == foo_0" $ id1 @?= "foo_0" , testCase "id2 == foo_0_0" $ id2 @?= "foo_0_0" , testCase "id3 == foo_0_1" $ id3 @?= "foo_1" , testCase "id4 == foo_0_0" $ id4 @?= "foo_0_1" ] , testGroup "make1" $ eval' $ do id0 <- Id.toText <$> Id.make "foo" id1 <- Id.toText <$> Id.make "foo_37" id2 <- Id.toText <$> Id.make "foo" id3 <- Id.toText <$> Id.make "foo_3" pure [ testCase "id0 == foo" $ id0 @?= "foo" , testCase "id1 == foo_37" $ id1 @?= "foo_37" , testCase "id2 == foo_38" $ id2 @?= "foo_38" , testCase "id3 == foo_3" $ id3 @?= "foo_3" ] , testGroup "Id.add" $ eval' $ do old <- get id0 <- Id.addRaw "LED" put old Id.add id0 id1 <- Id.toText <$> Id.make "led" pure [ testCase "id1 == led_0" $ id1 @?= "led_0" ] -- Some tools/hdls are case insensitive, so we should make sure we are too , testGroup "case sensitivity" $ eval' $ do id0 <- Id.toText <$> Id.make "foobar" id1 <- Id.toText <$> Id.make "fOoBAr" pure [ testCase "id0 == foobar" $ id0 @?= "foobar" , testCase "id1 == fOoBAr_0" $ id1 @?= "fOoBAr_0" ] -- An identifier made with 'mkBasic' should pass the 'isBasic' test , testGroup "mkBasic" $ concat $ flip map [minBound..maxBound] $ \hdl -> [ testProperty (show hdl <> " (ascii)") (Id.isBasic# hdl . roundTrip False hdl . coerce @ArbitraryAsciiText) , testProperty (show hdl <> " (UTF8)") (Id.isBasic# hdl . roundTrip False hdl . coerce @ArbitraryText) ] -- We expect a processed identifier to be either a valid basic xor -- extended identifier. Anything "in between" is an error. , testGroup "Basic XOR Extended" $ flip map [minBound..maxBound] $ \hdl -> testProperty (show hdl) $ \id0 -> let id1 = roundTrip True hdl (coerce @ArbitraryText id0) in Id.isBasic# hdl id1 `xor` Id.isExtended# hdl id1 , testCase "keyword (use => \\use\\)" ("\\use\\" @=? roundTrip' "use") , testCase "keyword (else => \\else\\)" ("\\else\\" @=? roundTrip' "else") , testCase "keyword (record => \\record\\)" ("\\record\\" @=? roundTrip' "record") , testCase "keyword (configuration => \\configuration\\)" ("\\configuration\\" @=? roundTrip' "configuration") , testCase "keyword (cOnFiGUrAtiON => \\cOnFiGUrAtiON\\)" ("\\cOnFiGUrAtiON\\" @=? roundTrip' "cOnFiGUrAtiON") , testCase "Verilog keyword in VHDL (always => always)" ("always" @=? roundTrip' "always") , testGroup "extended identifiers" [ testCase "(1) foo bar => \\foo bar\\" $ "\\foo bar\\" @=? roundTrip' "foo bar" , testCase "(2) foo bar => \\foo bar\\" $ 9 @=? Text.length (roundTrip' "foo bar") , testCase "foo\\bar => foobar" $ "foobar" @=? roundTrip' "foo\\bar" , testCase "\\foobar\\ => foobar" $ "foobar" @=? roundTrip' "\\foobar\\" -- This behavior makes sense, but it results in ugly identifiers, so -- backslashes are stripped -- , testCase "foo\\bar => \\foo\\\\bar\\" $ "\\foo\\\\bar\\" @=? roundTrip' "foo\\bar" -- , testCase "\\foobar\\ => \\\\\\foobar\\\\\\" $ "\\\\\\foobar\\\\\\" @=? roundTrip' "\\foobar\\" ] , testGroup "pretty names" [ testCase "(# #) => Unit" $ "Unit" @=? roundTrip' "(# #)" , testCase "() => Unit" $ "Unit" @=? 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 "(,,) => Tuple3" $ "Tuple3" @=? roundTrip False VHDL "(,,)" , testCase "(#,,,,#) => Tuple5" $ "Tuple5" @=? roundTrip False VHDL "(,,,,)" ] , testGroup "disallow escaped identifiers" [ testCase "foo bar => foobar" $ "foobar" @=? roundTrip False VHDL "foo bar" , testCase "foo\\bar => foobar" $ "foobar" @=? roundTrip False VHDL "foo\\bar" ] -- Raw identifiers are a bit weird: they're passed in by users and should -- be spliced into the HDL at verbatim. Clash shouldn't generate collisions -- though. , testGroup "raw identifiers" [ testProperty "id" rawToIdProperty , testGroup "Verilog: \\foo bar␣" $ eval True Verilog $ do id0 <- Id.toText <$> Id.addRaw "\\foo bar " id1 <- Id.toText <$> Id.make "foo bar" pure [ testCase "id0 == \\foo bar " $ id0 @?= "\\foo bar " , testCase "id1 == \\foo bar_0 " $ id1 @?= "\\foo bar_0 " ] , testGroup "Verilog: \\foo bar␣␣" $ eval True Verilog $ do id0 <- Id.toText <$> Id.addRaw "\\foo bar " id1 <- Id.toText <$> Id.make "foo bar" pure [ testCase "id0 == \\foo bar " $ id0 @?= "\\foo bar " , testCase "id1 == \\foo bar_0 " $ id1 @?= "\\foo bar_0 " ] , testGroup "VHDL: \\foo bar\\" $ eval True VHDL $ do id0 <- Id.toText <$> Id.addRaw "\\foo bar\\" id1 <- Id.toText <$> Id.make "foo bar" pure [ testCase "id0 == \\foo bar\\" $ id0 @?= "\\foo bar\\" , testCase "id1 == \\foo bar_0\\ " $ id1 @?= "\\foo bar_0\\" ] , testGroup "VHDL: \\foo bar \\" $ eval True VHDL $ do id0 <- Id.toText <$> Id.addRaw "\\foo bar \\" id1 <- Id.toText <$> Id.make "foo bar" -- While 'id1' could strictly be \foo bar\, it's probably best to be -- whitespace insensitive. pure [ testCase "id0 == \\foo bar \\" $ id0 @?= "\\foo bar \\" , testCase "id1 == \\foo bar_0\\ " $ id1 @?= "\\foo bar_0\\" ] ] ] clash-lib-1.8.1/tests/Clash/Tests/Normalize/0000755000000000000000000000000007346545000017006 5ustar0000000000000000clash-lib-1.8.1/tests/Clash/Tests/Normalize/Transformations.hs0000644000000000000000000000600007346545000022527 0ustar0000000000000000{-| Copyright : (C) 2020, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} {-# 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) import Clash.Core.FreeVars (countFreeOccurances) import Clash.Core.Term import Test.Tasty import Test.Tasty.HUnit import Test.Clash.Rewrite (parseToTermQQ, parseToTerm) t1337a :: Term t1337a = fromMaybe (error "failed to build term") $ do Letrec binds result <- pure $ [parseToTermQQ| let -- Types don't mean anything for this example result_1, a_2, b_3, c_4 :: Int result_1 = a_2 a_2 = b_3 b_3 = c_4 c_4 = a_2 b_3 in 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 result_1, b_3 :: Int result_1 = b_3 b_3 = b_3 b_3 in result_1 |] t1337b :: Term t1337b = fromMaybe (error "failed to build term") $ do Letrec binds result <- pure $ [parseToTermQQ| let -- Types don't mean anything for this example result_1, a_2, b_3, c_4, d_5 :: Int result_1 = a_2 a_2 = b_3 b_3 = c_4 c_4 = d_5 d_5 = a_2 b_3 c_4 in 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 result_1, c_4 :: Int result_1 = c_4 c_4 = c_4 c_4 c_4 in result_1 |] t1337c :: Term t1337c = fromMaybe (error "failed to build term") $ do Letrec binds result <- pure $ [parseToTermQQ| let result_1, a_2, b_3, c_4 :: Int result_1 = a_2 a_2 = b_3 b_3 = c_4 c_4 = a_2 b_3 (freevar_5 :: Int) 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| let result_1, b_3 :: Int result_1 = b_3 b_3 = b_3 b_3 (freevar_5 :: Int) in result_1 |] tests :: TestTree tests = testGroup "Clash.Tests.Core.Util.Interpolation" [ testCase "T1337a" $ t1337a_result @=? t1337a , testCase "T1337b" $ t1337b_result @=? t1337b , testCase "T1337c" $ t1337c_result @=? t1337c ] clash-lib-1.8.1/tests/Clash/Tests/Util/0000755000000000000000000000000007346545000015763 5ustar0000000000000000clash-lib-1.8.1/tests/Clash/Tests/Util/Interpolate.hs0000644000000000000000000000323407346545000020607 0ustar0000000000000000{-| Copyright : (C) 2019, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} {-# LANGUAGE QuasiQuotes #-} module Clash.Tests.Util.Interpolate where import qualified Clash.Util.Interpolate as I import Test.Tasty import Test.Tasty.HUnit test1, test2, test3, test4, test5, test6, test7, test8, test9 :: String test1 = [I.i| Simple |] test2 = [I.i| Single line |] test3 = [I.i| Surrounded by newlines |] test4 = [I.i| One Two Three |] test5 = [I.i| One Two Three |] test6 = [I.i| #{test5} |] test7 = [I.i| The big test: #{test5} |] test8 = [I.i| looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong word |] data SomeRecord = SomeRecord { getField :: Int } someRecord :: SomeRecord someRecord = SomeRecord 5 -- test that we can escape closing '}' test9 = [I.i| #{ "\\" ++ show (getField someRecord { getField=6*7 \} ) } |] tests :: TestTree tests = testGroup "Clash.Tests.Core.Util.Interpolation" [ testCase "test1" $ "Simple" @=? test1 , testCase "test2" $ "Single line" @=? test2 , testCase "test3" $ "Surrounded by newlines" @=? test3 , testCase "test4" $ "One Two Three" @=? test4 , testCase "test5" $ "One\n Two\nThree" @=? test5 , testCase "test6" $ test5 @=? test6 , testCase "test7" $ test7 @?= ("The big test:\n\n" ++ test5) , testCase "test8" $ test8 @?= "looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong \nword" , testCase "test9" $ test9 @?= "\\42" ] clash-lib-1.8.1/tests/Test/Clash/0000755000000000000000000000000007346545000014663 5ustar0000000000000000clash-lib-1.8.1/tests/Test/Clash/Rewrite.hs0000644000000000000000000002242307346545000016643 0ustar0000000000000000{-| Copyright : (C) 2020,2022 QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. Utilities to write unit tests on transformations -} {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskellQuotes #-} module Test.Clash.Rewrite where import Clash.Annotations.BitRepresentation.Internal (buildCustomReprs) import qualified Clash.Core.Name as C import qualified Clash.Core.Term as C import qualified Clash.Core.Literal as C import qualified Clash.Core.Type as C import qualified Clash.Core.Var as C import Clash.Core.VarEnv (InScopeSet, emptyVarSet, emptyVarEnv, emptyInScopeSet) import Clash.Driver.Types (ClashEnv(..), ClashOpts(..), defClashOpts, debugSilent) import Clash.Rewrite.Types import Clash.Rewrite.Util (runRewrite) import Clash.Normalize.Types import qualified Clash.Util.Interpolate as I import Control.Applicative ((<|>)) import Control.Concurrent.Supply (newSupply) import Data.Default import Language.Haskell.Exts.Syntax import Language.Haskell.Exts.Parser (parseExp, fromParseResult) import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe) import GHC.Stack (HasCallStack) import qualified Language.Haskell.TH.Syntax as TH import qualified Language.Haskell.TH.Quote as TH import qualified Data.List as List import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import qualified Data.IntMap as IntMap import qualified Data.Text as Text type TypeMap = HashMap.HashMap Int C.Type lookupTM :: Int -> TypeMap -> C.Type lookupTM u tm = case HashMap.lookup u tm of Just t -> t Nothing -> error [I.i| Tried to lookup unique '#{u}' in typemap, but couldn't find it. This usually means you forgot to (explicitely) declare a variable's type. |] instance Default RewriteEnv where def = RewriteEnv { _clashEnv = ClashEnv { envOpts = defClashOpts { opt_debug = debugSilent } , envTyConMap = mempty , envTupleTyCons = IntMap.empty , envPrimitives = HashMap.empty , envCustomReprs = buildCustomReprs [] , envDomains = HashMap.empty } , _typeTranslator=error "_typeTranslator: NYI" , _peEvaluator=error "_peEvaluator: NYI" , _evaluator=error "_evaluator: NYI" , _topEntities=emptyVarSet } instance Default extra => Default (RewriteState extra) where def = RewriteState { _transformCounter=0 , _transformCounters=mempty , _bindings=emptyVarEnv , _uniqSupply=unsafePerformIO newSupply , _curFun=error "_curFun: NYI" , _nameCounter=2 , _workFreeBinders=emptyVarEnv , _globalHeap=error "_globalHeap: NYI" , _extra=def } instance Default NormalizeState where def = NormalizeState { _normalized=emptyVarEnv , _specialisationCache=Map.empty , _specialisationHistory=emptyVarEnv , _inlineHistory=emptyVarEnv , _primitiveArgs=Map.empty , _recursiveComponents=emptyVarEnv } instance Default InScopeSet where def = emptyInScopeSet -- | Run a single transformation given a certain context runSingleTransformation :: RewriteEnv -- ^ Rewrite environment -> RewriteState extra -- ^ Rewrite state -> InScopeSet -- ^ Variables in scope in transformation -> Rewrite extra -- ^ Transformation to perform -> C.Term -- ^ Term to transform -> IO C.Term runSingleTransformation rwEnv rwState is trans term = do (t, _, _) <- runR (runRewrite "" is trans term) rwEnv rwState pure t -- | Run a single transformation with an empty environment and empty -- InScopeSet. See Default instances ^ to inspect the precise definition of -- "empty". -- -- Note that at the time of writing (May 2020) the default environment does not -- include a type translator, evaluator, current function, or global heap. Maps, -- like the primitive and tycon map, are also empty. If the transformation under -- test needs these definitions, you should add them manually. runSingleTransformationDef :: Default extra => Rewrite extra -> C.Term -> IO C.Term runSingleTransformationDef = runSingleTransformation def def def parseType :: Show l => Type l -> C.Type parseType = \case -- Type constructor: T TyCon _ (UnQual _ (Ident _ typNm)) -> -- TODO: We could/should build a TyConMap here C.ConstTy (C.TyCon (C.Name C.User (Text.pack typNm) 0 C.noSrcSpan)) -- Unsupported type: t -> error ("parseType: " <> show t) -- | Parse an identifier into a Clash Name. Identifiers must include a unique -- and might include a modifier indicating whether its NameSort. Examples: -- -- * x_3: User identifier with human readable name "x", unique "3" -- * x_I3: Internal identifier with human readable name "x", unique "3" -- * x_S3: System identifier with human readable name "x", unique "3" -- parseName :: Show l => Name l -> C.Name a parseName = \case Ident _ s -> failOnNothing s (go "" s) Symbol _ s -> failOnNothing s (go "" s) where failOnNothing _ (Just (nmSort, nm, uniq)) = C.mkUnsafeName nmSort (Text.pack nm) uniq failOnNothing s Nothing = error [I.i| Not a valid id: #{s}. Identifiers must be of form 'foobar_123', where 'foobar' is a human-readable (but ultimately unused) name and '123' is the unique. Additionally, 'I', 'U', or 'S' might be prefixed to create an Internal, User, or System name respectively. For example, 'foobar_S123'. |] go _seen "" = Nothing go seen0 ('_':s:ss) | 'U' <- s = fmap (C.User,seen1,) (readMaybe ss) <|> cont | 'S' <- s = fmap (C.System,seen1,) (readMaybe ss) <|> cont | 'I' <- s = fmap (C.Internal,seen1,) (readMaybe ss) <|> cont | otherwise = fmap (C.User,seen1,) (readMaybe (s:ss)) <|> cont where seen1 = reverse seen0 cont = go ('_':seen0) (s:ss) go seen (s:ss) = go (s:seen) ss -- | Parse declarations (as, amongst others, used in let expressions). Note that -- every binder needs an explicit type annotation, as we don't do any type -- inference. Type annotations may occur anywhere though. Example, this is OK: -- -- let -- x_0 :: Int -- x_0 = 2 -- -- x_1 :: Int -- x_1 = x_0 -- in -- x_1 -- -- But this is not: -- -- let -- x_0 :: Int -- x_0 = 2 -- -- x_1 = x_0 -- in -- x_1 -- parseDecls :: forall l . (HasCallStack, Show l) => TypeMap -> [Decl l] -> (TypeMap, [C.LetBinding]) parseDecls typs0 decls = (typs1, map parseOtherDecl otherDecls) where (typDecls, otherDecls) = List.partition isTypeDecl decls insertTyp (nm, t) = HashMap.insert nm t typs1 = foldr insertTyp typs0 (concatMap parseTypeDecl typDecls) parseOtherDecl :: HasCallStack => Decl l -> C.LetBinding parseOtherDecl = \case PatBind _ (PVar _ (parseName -> nm)) (UnGuardedRhs _ e) Nothing -> let uniq = C.nameUniq nm typ = lookupTM (C.nameUniq nm) typs1 in (C.Id nm uniq typ C.LocalId, expToTerm typs1 e) e -> error ("parseOtherDecl: " <> show e) parseTypeDecl :: Decl l -> [(Int, C.Type)] parseTypeDecl (TypeSig _ nms t) = map (\nm -> (C.nameUniq (parseName nm), parseType t)) nms parseTypeDecl _ = error "impossible" isTypeDecl :: Decl l -> Bool isTypeDecl (TypeSig {}) = True isTypeDecl _ = False -- | Parse a haskell-src-exts expression into Clash Core. expToTerm :: forall l . (HasCallStack, Show l) => TypeMap -> Exp l -> C.Term expToTerm typs0 = \case -- Parentheses: (...) Paren _ e -> expToTerm typs0 e -- Local variable reference with type signature: x :: t ExpTypeSig _ (Var _ (UnQual _ (parseName -> nm))) (parseType -> t) -> C.Var (C.Id nm (C.nameUniq nm) t C.LocalId) -- Term application: e1 e2 App _ e1 e2 -> C.App (expToTerm typs0 e1) (expToTerm typs0 e2) -- Variable reference: e Var _ (UnQual _ (parseName -> nm)) -> let uniq = C.nameUniq nm typ = lookupTM (C.nameUniq nm) typs0 in C.Var (C.Id nm uniq typ C.LocalId) -- Literal: 3 Lit _ (Int _ i _) -> C.Literal (C.IntLiteral i) -- Let expression: let {e1 = .., e2 = ..} in r Let _ (BDecls _ decls0) body0 -> let (typs1, decls1) = parseDecls typs0 decls0 body1 = expToTerm typs1 body0 in C.Letrec decls1 body1 -- Unsupported expression e -> error ("expToTerm: " <> show e) -- | Parse a string representing a Haskell expression into Clash Core. This can -- only parse very simple expressions. In the future we should make an effort to -- build a proper TyConMap (using LoadModules) to faithfully reproduce more -- complex expressions. parseToTerm :: String -> C.Term parseToTerm = expToTerm HashMap.empty . fromParseResult . parseExp -- | See documentation of 'parseToTerm'. Example usage: -- -- letrec = [parseToTermQQ| -- let -- x_0, x_1 :: Int -- x_0 = 5 -- x_1 = 6 -- in -- x_0 -- |] -- -- Note that this is parsed at runtime, not at compile time. There's no good -- technical reason for this though. We'd just need to implement a Template -- Haskell Lift instance for Term. -- -- For more information on the format of identifiers, see 'parseName'. parseToTermQQ :: TH.QuasiQuoter parseToTermQQ = TH.QuasiQuoter{ TH.quoteExp = fmap (TH.AppE (TH.VarE 'parseToTerm)) . TH.lift , TH.quotePat = error "parseToTerm.quotePat: NYI" , TH.quoteType = error "parseToTerm.quoteType: NYI" , TH.quoteDec = error "parseToTerm.quoteDec: NYI" } clash-lib-1.8.1/tests/0000755000000000000000000000000007346545000012712 5ustar0000000000000000clash-lib-1.8.1/tests/doctests.hs0000644000000000000000000000022707346545000015077 0ustar0000000000000000module Main where import System.Environment (getArgs) import Test.DocTest (mainFromCabal) main :: IO () main = mainFromCabal "clash-lib" =<< getArgs clash-lib-1.8.1/tests/unittests.hs0000644000000000000000000000204107346545000015305 0ustar0000000000000000module Main where import Test.Tasty import Test.Tasty.QuickCheck 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.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. setDefaultQuickCheckTests :: QuickCheckTests -> QuickCheckTests setDefaultQuickCheckTests (QuickCheckTests 100) = 10000 setDefaultQuickCheckTests opt = opt tests :: TestTree 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.Netlist.Id.tests , Clash.Tests.Normalize.Transformations.tests , Clash.Tests.Util.Interpolate.tests ] main :: IO () main = defaultMain $ adjustOption setDefaultQuickCheckTests $ tests clash-lib-1.8.1/tools/0000755000000000000000000000000007346545000012710 5ustar0000000000000000clash-lib-1.8.1/tools/static-files.hs0000644000000000000000000000455307346545000015642 0ustar0000000000000000{-| 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 clash-lib-1.8.1/tools/v16-upgrade-primitives.hs0000644000000000000000000001003207346545000017472 0ustar0000000000000000{- Utility executable to convert "old-style" JSON primitives to "new-style" YAML ones. See https://github.com/clash-lang/clash-compiler/pull/2009. -} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Main where #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as Aeson import Data.ByteString.Lazy.Search (replace) import Data.String (IsString) #endif import qualified Data.Aeson.Extra as AesonExtra import qualified Data.Aeson as Aeson import qualified Data.Yaml as Yaml import qualified Data.ByteString.Lazy as ByteString import qualified Data.Set as Set import Control.Monad (forM_, when) import Data.ByteString.Lazy (ByteString) import System.Directory (removeFile) import System.Environment (getArgs) import System.FilePath.Glob (glob) help :: String help = unlines [ "Convert JSON primitive files into YAML ones. YAML files will be written to " , "the original filename with '.yaml' appended." , "" , "Usage:" , " v16-upgrade-primitives [options]... ..." , "" , "Options:" , " --dry-run Do not write YAML files." , " --delete Delete JSON files after writing." , " --help | -h Show this screen." , "" , "Example:" , " v16-upgrade-primitives --dry-run prims/**/*.primitives" ] -- | Same as 'glob', but errors on patterns matching no files. globOrErr :: FilePath -> IO [FilePath] globOrErr pattern = do files <- glob pattern when (null files) (error ("Pattern does not match any files: " <> pattern)) pure files -- | 'concatMap', but its monadic cousin concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f = fmap concat . mapM f -- | Read file and output YAML ByteString jsonToYaml :: FilePath -> IO ByteString jsonToYaml path = do contents <- ByteString.readFile path let decoded = AesonExtra.decodeOrErrJson path contents pure . removeTempKey . ByteString.fromStrict . Yaml.encode . customSortOutput $ decoded {- NOTE [Sorting YAML object keys] 'Yaml.encode' encodes object with their keys in alphabetical order. For readability we like `name` to be at the top, and `type` to be just above `template`. We accomplice this here by renaming those keys to something there sorts where we like them to be. And find-and-replace those temporary names back in the resulting ByteString. -} #if MIN_VERSION_aeson(2,0,0) keySortingRenames :: IsString str => [(str,str)] keySortingRenames = [ ("name", "aaaa_really_should_be_name_but_renamed_to_get_the_sorting_we_like") , ("type", "really_should_be_type_but_renamed_to_get_the_sorting_we_like") ] customSortOutput :: Aeson.Value -> Aeson.Value customSortOutput x = case x of Aeson.Object o -> Aeson.Object $ fmap customSortOutput $ renameKeys $ o Aeson.Array xs -> Aeson.Array $ fmap customSortOutput xs _ -> x where renameKeys obj = foldl renameKey obj keySortingRenames renameKey obj (kOld,kNew) = case Aeson.lookup kOld obj of Nothing -> obj Just val -> Aeson.insert kNew val (Aeson.delete kOld obj) removeTempKey :: ByteString -> ByteString removeTempKey inp = foldl go inp keySortingRenames where go bs (orig,temp) = replace (ByteString.toStrict temp) orig bs #else -- < aeson-2.0 stores keys in HashMaps, whose order we can't possibly predict. removeTempKey :: ByteString -> ByteString removeTempKey = id customSortOutput:: Aeson.Value -> Aeson.Value customSortOutput = id #endif main :: IO () main = do args0 <- Set.fromList <$> getArgs let doDryRun = Set.member "--dry-run" args0 doWrite = not doDryRun doDelete = Set.member "--delete" args0 && doWrite doHelp = Set.member "-h" args0 || Set.member "--help" args0 || Set.null args1 args1 = foldr Set.delete args0 ["--dry-run", "--delete", "--help", "-h"] if doHelp then putStrLn help else do files <- concatMapM globOrErr (Set.toList args1) forM_ files $ \path -> do let newPath = path <> ".yaml" putStrLn $ "Converting " <> path <> ".." decoded <- jsonToYaml path when doWrite $ ByteString.writeFile newPath decoded when doDelete $ removeFile path