packages feed

clash-prelude 1.0.1 → 1.10.0

raw patch · 182 files changed

Files

AUTHORS.md view
@@ -1,2 +1,1 @@-* [Christiaan Baaij](mailto:christiaan.baaij@gmail.com) [@christiaanb](https://github.com/christiaanb)-* John Ericson [@Ericson2314](https://github.com/Ericson2314)+See [GitHub contributors statistics](https://github.com/clash-lang/clash-compiler/graphs/contributors) and [clash-lang.org/publications](https://clash-lang.org/publications/).
CHANGELOG.md view
@@ -1,438 +1,1070 @@-# Changelog for [`clash-prelude` package](http://hackage.haskell.org/package/clash-prelude)--## 1.0.0 *September 3rd 2019*-* 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-prelude/issues/316)-  * [#319](https://github.com/clash-lang/clash-prelude/issues/319)-  * [#323](https://github.com/clash-lang/clash-prelude/issues/323)-  * [#324](https://github.com/clash-lang/clash-prelude/issues/324)-  * [#329](https://github.com/clash-lang/clash-prelude/issues/329)-  * [#331](https://github.com/clash-lang/clash-prelude/issues/331)-  * [#332](https://github.com/clash-lang/clash-prelude/issues/332)-  * [#335](https://github.com/clash-lang/clash-prelude/issues/335)-  * [#348](https://github.com/clash-lang/clash-prelude/issues/348)-  * [#349](https://github.com/clash-lang/clash-prelude/issues/349)-  * [#350](https://github.com/clash-lang/clash-prelude/issues/350)-  * [#351](https://github.com/clash-lang/clash-prelude/issues/351)-  * [#352](https://github.com/clash-lang/clash-prelude/issues/352)-  * [#353](https://github.com/clash-lang/clash-prelude/issues/353)-  * [#358](https://github.com/clash-lang/clash-prelude/issues/358)-  * [#359](https://github.com/clash-lang/clash-prelude/issues/359)-  * [#363](https://github.com/clash-lang/clash-prelude/issues/363)-  * [#364](https://github.com/clash-lang/clash-prelude/issues/364)-  * [#365](https://github.com/clash-lang/clash-prelude/issues/365)-  * [#371](https://github.com/clash-lang/clash-prelude/issues/371)-  * [#372](https://github.com/clash-lang/clash-prelude/issues/372)-  * [#373](https://github.com/clash-lang/clash-prelude/issues/373)-  * [#378](https://github.com/clash-lang/clash-prelude/issues/378)-  * [#380](https://github.com/clash-lang/clash-prelude/issues/380)-  * [#381](https://github.com/clash-lang/clash-prelude/issues/381)-  * [#382](https://github.com/clash-lang/clash-prelude/issues/382)-  * [#383](https://github.com/clash-lang/clash-prelude/issues/383)-  * [#387](https://github.com/clash-lang/clash-prelude/issues/387)-  * [#393](https://github.com/clash-lang/clash-prelude/issues/393)-  * [#396](https://github.com/clash-lang/clash-prelude/issues/396)-  * [#398](https://github.com/clash-lang/clash-prelude/issues/398)-  * [#399](https://github.com/clash-lang/clash-prelude/issues/399)-  * [#401](https://github.com/clash-lang/clash-prelude/issues/401)-  * [#403](https://github.com/clash-lang/clash-prelude/issues/403)-  * [#407](https://github.com/clash-lang/clash-prelude/issues/407)-  * [#412](https://github.com/clash-lang/clash-prelude/issues/412)-  * [#413](https://github.com/clash-lang/clash-prelude/issues/413)-  * [#420](https://github.com/clash-lang/clash-prelude/issues/420)-  * [#422](https://github.com/clash-lang/clash-prelude/issues/422)-  * [#423](https://github.com/clash-lang/clash-prelude/issues/423)-  * [#424](https://github.com/clash-lang/clash-prelude/issues/424)-  * [#438](https://github.com/clash-lang/clash-prelude/issues/438)-  * [#450](https://github.com/clash-lang/clash-prelude/issues/450)-  * [#452](https://github.com/clash-lang/clash-prelude/issues/452)-  * [#455](https://github.com/clash-lang/clash-prelude/issues/455)-  * [#460](https://github.com/clash-lang/clash-prelude/issues/460)-  * [#461](https://github.com/clash-lang/clash-prelude/issues/461)-  * [#463](https://github.com/clash-lang/clash-prelude/issues/463)-  * [#468](https://github.com/clash-lang/clash-prelude/issues/468)-  * [#475](https://github.com/clash-lang/clash-prelude/issues/475)-  * [#476](https://github.com/clash-lang/clash-prelude/issues/476)-  * [#500](https://github.com/clash-lang/clash-prelude/issues/500)-  * [#507](https://github.com/clash-lang/clash-prelude/issues/507)-  * [#512](https://github.com/clash-lang/clash-prelude/issues/512)-  * [#516](https://github.com/clash-lang/clash-prelude/issues/516)-  * [#517](https://github.com/clash-lang/clash-prelude/issues/517)-  * [#526](https://github.com/clash-lang/clash-prelude/issues/526)-  * [#556](https://github.com/clash-lang/clash-prelude/issues/556)-  * [#560](https://github.com/clash-lang/clash-prelude/issues/560)-  * [#566](https://github.com/clash-lang/clash-prelude/issues/566)-  * [#567](https://github.com/clash-lang/clash-prelude/issues/567)-  * [#569](https://github.com/clash-lang/clash-prelude/issues/569)-  * [#573](https://github.com/clash-lang/clash-prelude/issues/573)-  * [#575](https://github.com/clash-lang/clash-prelude/issues/575)-  * [#581](https://github.com/clash-lang/clash-prelude/issues/581)-  * [#582](https://github.com/clash-lang/clash-prelude/issues/582)-  * [#586](https://github.com/clash-lang/clash-prelude/issues/586)-  * [#588](https://github.com/clash-lang/clash-prelude/issues/588)-  * [#591](https://github.com/clash-lang/clash-prelude/issues/591)-  * [#596](https://github.com/clash-lang/clash-prelude/issues/596)-  * [#601](https://github.com/clash-lang/clash-prelude/issues/601)-  * [#607](https://github.com/clash-lang/clash-prelude/issues/607)-  * [#629](https://github.com/clash-lang/clash-prelude/issues/629)-  * [#637](https://github.com/clash-lang/clash-prelude/issues/637)-  * [#644](https://github.com/clash-lang/clash-prelude/issues/644)-  * [#647](https://github.com/clash-lang/clash-prelude/issues/647)-  * [#661](https://github.com/clash-lang/clash-prelude/issues/661)-  * [#668](https://github.com/clash-lang/clash-prelude/issues/668)-  * [#677](https://github.com/clash-lang/clash-prelude/issues/677)-  * [#678](https://github.com/clash-lang/clash-prelude/issues/678)-  * [#682](https://github.com/clash-lang/clash-prelude/issues/682)-  * [#691](https://github.com/clash-lang/clash-prelude/issues/691)-  * [#703](https://github.com/clash-lang/clash-prelude/issues/703)-  * [#713](https://github.com/clash-lang/clash-prelude/issues/713)-  * [#715](https://github.com/clash-lang/clash-prelude/issues/715)-  * [#727](https://github.com/clash-lang/clash-prelude/issues/727)-  * [#730](https://github.com/clash-lang/clash-prelude/issues/730)-  * [#736](https://github.com/clash-lang/clash-prelude/issues/736)-  * [#738](https://github.com/clash-lang/clash-prelude/issues/738)--## 0.99.3 *July 26th 2018*-* 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*-* 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*-* 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)`)--## 0.11.2-* New features:-  * Add `riseEvery`: Give a pulse every @n@ clock cycles. (Thanks to @thoughtpolice)-  * Add `oscillate`: Oscillate a @'Bool'@ with a given half-period of cycles. (Thanks to @thoughtpolice)-* Fixes bugs:-  * Eagerness bug in `regEn` [#104](https://github.com/clash-lang/clash-prelude/issues/104) (Thanks to @cbiffle)--## 0.11.1-* Changes:-  * Bundle instance for `()` behaves like a product-type instance [#96](https://github.com/clash-lang/clash-prelude/issues/96)-* Fixes bugs:-  * Ensure that `fold` gets correctly type-applied in `Vec.==` [#202](https://github.com/clash-lang/clash-compiler/issues/202)--## 0.11-* New features:-  * `CLaSH.XException`: a module defining an exception representing uninitialised values. Additionally adds the `ShowX` class which has methods that prints values as "X" where they would normally raise an `XException` exception.-  * Add `BNat` (and supporting functions) to `CLaSH.Promoted.Nat`: base-2 encoded natural numbers.-  * Add `divSNat` and `logBaseSNat` to `CLaSH.Promoted.Nat`: division and logarithm for singleton natural numbers.-  * Add `predUNat` and `subUNat` to `CLaSH.Promoted.Nat`: predecessor and subtraction for unary-encoded natural numbers.-  * Add `dtfold` to `CLaSH.Sized.Vector`: a dependently-typed tree-fold over `Vec`.-  * Add the perfect-depth binary trees module `CLaSH.Sized.RTree`-  * Synthesisable definitions of `countLeadingZeros` and `countTrailingZeros` for: `BitVector`, `Signed`, `Unsigned`, and `Fixed`-  * Add the `(:::)` type alias in `CLaSH.NamedTypes` which allows you to annotate types with documentation-* Changes:-  * `asyncRam`, `blockRam`, `blockRamFile` have a `Maybe (addr,a)` as write input instead of three separate `Bool`, `addr`, and `a` inputs.-  * `asyncFIFOSynchronizer` has a `Maybe a` as write-request instead of a separate `Bool` and `a` input-  * `bundle'` and `unbundle'` are removed; `bundle` now has type `Unbundled' clk a -> Signal' clk a`, `unbundle` now has type `Signal' clk a -> Unbundled' clk a`-  * `subSNat` now has the type `SNat (a+b) -> SNat b -> SNat a` (where it used to be `SNat a -> SNat b -> SNat (a-b)`)-  * Renamed `multUNat` to `mulUNat` to be in sync with `mulSNat` and `mulBNat`.-  * The function argument of `vfold` in `CLaSH.Sized.Vector` is now `(forall l . SNat l -> a -> Vec l b -> Vec (l + 1) b)` (where it used to be `(forall l . a -> Vec l b -> Vec (l + 1) b)`)-  * `Cons` constructor of `Vec` is no longer visible; `(:>)` and `(:<)` are now listed as constructors of `Vec`-  * Simulation speed improvements for numeric types--## 0.10.12-* Fixes bugs:-  * `Vec`s `unbundle` is too strict, i.e. `register (undefined :: Vec 2 Int)` /= `bundle . unbundle . register (undefined :: Vec 2 Int)`--## 0.10.11 *August 3rd 2016*-* New features:-  * Add strict version of: `sample`, `sampleN`, `fromList`, and `simulate`-  * Make `Signal`s `<*>` slightly stricter:-    * Feedback loops still work with this new implementation-    * No more space-leaks when used in combination with the strict version of `sample`, `sampleN`, and `simulate`-  * Add `NFData` instances for the numeric types-* Speed up arithmetic operations of `Signed`, `Unsigned` and `BitVector`-* Fixes bugs:-  * CLaSH compiler sees internals of numeric types in their `Lift` functions--## 0.10.10 *July 15th 2016*-* Fixes bugs:-  * `shrink` functions for numeric types throw exceptions [#153](https://github.com/clash-lang/clash-compiler/issues/153)-  * CLaSH compiler sees internals of numeric types in their Show functions--## 0.10.9 *June 9th 2016*-* Fixes bugs:-  * `Eq` instance of `Vec` sometimes not synthesisable--## 0.10.8 *June 7th 2016*-* New features:-  * Instances of `Data` for numeric types.-  * Instances of `Read` for {Index, Signed, Unsigned, Fixed}-  * Instances of `BitPack` for 3-8 tuples--## 0.10.7 *April 7th 2016*-* Support doctest-0.11.0--## 0.10.6 *February 10th 2016*-* Fixes bugs:-  * `CLaSH.Prelude.DataFlow.parNDF` is not lazy enough--## 0.10.5 *January 13th 2016*-* New features:-  * Add `readNew` to `CLaSH.Prelude.BlockRam`: create a read-after-write blockRAM from a read-before-write blockRAM.-  * `popCount` functions for `BitVector`, `Signed`, and `Unsigned` are now synthesisable.-  * Add `parNDF` to `CLaSH.Prelude.DataFlow`: compose _N_ dataflow circuits in parallel.-  * Add and instance `Vec n a` for `LockStep` in `CLaSH.Prelude.DataFlow`: have _N_ dataflow circuits operate in lock-step.--## 0.10.4 *December 11th 2015*-* New features:-  * Add `pureDF` to `CLaSH.Prelude.DataFlow`: lift combinational circuits to `DataFlow` circuits.-  * Add `fifoDF` to `CLaSH.Prelude.DataFlow`: a simple FIFO buffer adhering to the `DataFlow` protocol.-  * `loopDF` no longer uses the `lockStep` and `stepLock` automatically, and now includes a FIFO buffer on the feedback path.-  * Add `loopDF_nobuf` to `CLaSH.Prelude.DataFlow`: a version of `loopDF` with no FIFO buffer on the feedback path.-  * Add `boolToBV` to `CLaSH.CLass.BitPack`: convert `Bool`eans to `n`-bit `BitVector`s.-  * `ClockSource` in `CLaSH.Annotations.TopEntity` can now have multiple clock inputs [#33](https://github.com/clash-lang/clash-prelude/issues/33)-* Bug fixes:-  * `asyncRomFile` reads file multiple times.--## 0.10.3 *October 24th 2015*-* Disable CPR analysis (See https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c):-  * GHC < 7.11: In all modules using `-fcpr-off`-  * GHC >= 7.11: In `CLaSH.Signal.Internal` and `CLaSH.Prelude.RAM` using `-fno-cpr-anal`--## 0.10.2 *October 21st 2015*-* New features:-  * `ExtendingNum`, `BitPack`, and `Resize` instance for `Index`-  * Add `bv2i`: convert `BitVector n` to `Index (2^n)`-  * Export type-level operations from [ghc-typelits-extra](http://hackage.haskell.org/package/ghc-typelits-extra)--## 0.10.1 *October 16th 2015*-* New features:-  * The `f` in `dfold p f`, now has an `SNat l` instead of a `Proxy l` as its first argument.-  * Add `bv2v` and `v2bv` functions that convert between `Vec n Bit` and `BitVector n`.-  * Add `smap`: apply a function to every element of a vector and the element's position (as an 'SNat' value) in the vector.--## 0.10 *October 3rd 2015*-* New features:-  * The Vec constructor `:>` is now an explicitly bidirectional pattern synonym (the actual constructor has been renamed to Cons).-    As a result, pattern matching on `:>` is now synthesisable by the CLaSH compiler.-  * The function `<:` is replaced by the the explicitly bidirectional pattern synonym `:<`.-    This allows you to pattern match on: "all but the last element of a vector" and "the last element" of the vector.-    Because it is a bidirectional pattern, `:<` can also be used as an expression that appends an element to the tail of a vector.-  * Add a `transpose` function in `CLaSH.Sized.Vector`.-  * Add `stencil1d` and `stensil2d` stencil computation functions in `CLaSH.Sized.Vector`.-  * Add `permute`, `backpermute`, `scatter`, and `gather` permutation functions in `CLaSH.Sized.Vector`.-  * Add specialised permutation functions `interleave`, `rotateLeft`, and `rotateRight` in `CLaSH.Sized.Vector`.-  * `sscanl` and `sscanr` in `CLaSH.Sized.Vector` are renamed to `postscanl` and postscanr` to be more in line with existing Haskell packages such as `vector` and `accelerate`.-  * The `Foldable` and `Traversable` instances of `Vec` now only works for non-empty vectors.-  * Where possible, members of the `Foldable` instance of `Vec` are described in terms of `fold`, which builds a tree (of depth `log(n)`) of computations, instead of `foldr` which had depth `n` computations.-    This reduces the critical path length in your circuits when using these functions.-  * `maxIndex` and `length` in `CLaSH.Sized.Vector` return an `Int` instead of an `Integer`.-  * Add functions that involve an index into a vector to the `CLaSH.Sized.Vector` module: `indices`, `indicesI`, `imap`, `izipWith`, `ifoldr`, `ifoldl`, `findIndex`, `elemIndex`.-  * `CLaSH.Sized.Vector`'s `fold`, `dfold`, `vfold`, and `toList` are now synthesisable by the CLaSH compiler.--## 0.9.3 *September 21st 2015*-* Fixes bugs:-  * Cannot build against singletons-0.2-  * Numerous documentation fixes--## 0.9.2 *August 2nd 2015*-* Disable strictness analysis in `CLaSH.Signal.Internal`, this allows turning on strictness analysis in the GHC front-end of the CLaSH compiler.--## 0.9.1 *June 26th 2015*-* Updated documentation on data-file support on Altera/Quartus--## 0.9 *June 25th 2015*-* New features:-  * Add operations on singleton natural numbers: `addSNat`, `subSNat`, `mulSNat`, and `powSNat`.-  * Add asynchronous RAM functions in `CLaSH.Prelude.RAM`, which have an asynchronous/combinational read port.-  * Add ROM functions in modules `CLaSH.Prelude.ROM` and `CLaSH.Prelude.ROM.File`, where the latter module contains functions that instantiate a ROM from the content specified in an external data-file.-  * Add BlockRam functions, in the `CLaSH.Prelude.BlockRam.File` module, whose content can be initialised with the content specified in an external data-file.-  * `assert` now takes an extra `String` argument so you can distinguish one `assert` from the others.-  Additionally, `assert'` is added which takes an additional `SClock` argument.-  This is needed, because `assert` now reports the clock cycle, and clock domain, when an assertion fails.-  * `defClkAltera` and `defClkXilinx` are replaced by, `altpll` and `alteraPll` for Altera clock sources, and `clockWizard` for Xilinx clock sources.-  These names correspond to the names of the generator utilities in Quartus and ISE/Vivado.-  * Add [Safe](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/safe_haskell.html) versions of the prelude modules: `CLaSH.Prelude.Safe` and `CLaSH.Prelude.Explicit.Safe`-  * Add synchronizers in the `CLaSH.Prelude.Synchronizer` module--## 0.8 *June 3rd 2015*-* New features:-  * Make the (Bit)Vector argument the _last_ argument for the following functions: `slice`, `setSlice`, `replaceBit`, `replace`. The signatures for the above functions are now:--    ```-    slice      :: BitPack a => SNat m -> SNat n -> a -> BitVector (m + 1 - n)-    setSlice   :: BitPack a => SNat m -> SNat n -> BitVector (m + 1 - n) -> a -> a-    replaceBit :: Integral i => i -> Bit -> a -> a-    replace    :: Integral i => i -> a -> Vec n a -> Vec n a-    ```--    This allows for easier chaining, e.g.:--    ```-    replaceBit 0 1 $-    repleceBit 4 0 $-    replaceBit 6 1 bv-    ```-  * Until version 0.7.5, given `x :: Vec 8 Bit` and `y :: BitVector 8`, it used to be `last x == msb y`.-    This is quite confusing when printing converted values.-    Until version 0.7.5 we would get:--    ```-    > 0x0F :: BitVector 8-    0000_1111-    > unpack 0x0F :: Vec 8 Bit-    <1,1,1,1,0,0,0,0>-    ```--    As of version 0.8, we have `head x == msb y`:--    ```-    > 0x0F :: BitVector 8-    0000_1111-    > unpack 0x0F :: Vec 8 Bit-    <0,0,0,0,1,1,1,1>-    ```--    So converting for `Vec`tors of `Bit`s to `BitVector`s is no longer _index_-preserving, but it is _order_-preserving.-  * Add [QuickCheck](http://hackage.haskell.org/package/QuickCheck) `Arbitary` and `CoArbitary` instances for all data types-  * Add [lens](http://hackage.haskell.org/package/lens) `Ixed` instances for `BitVector`, `Signed`, `Unsigned`, and `Vec`--## 0.7.5 **May 7th 2015**-* New features:-  * Moore machine combinators--## 0.7.4 **May 5th 2015*-* New features:-  * Add `TopEntity` annotations--## 0.7.3 *April 22nd 2015*-* New features:-  * Add the vector functions: `zip3`, `unzip3`, and `zipWith3`-  * Use version 0.2 of the [`ghc-typelits-natnormalise` package](http://hackage.haskell.org/package/ghc-typelits-natnormalise)--## 0.7.2 *April 20th 2015*-* New features:-  * Support for GHC 7.10 => only works with GHC 7.10 and higher-  * Use http://hackage.haskell.org/package/ghc-typelits-natnormalise typechecker plugin for better type-level natural number handling--## 0.7.1 *March 25th 2015*-* Fixes bugs:-  * Fix laziness bug in Vector.(!!) and Vector.replace--## 0.7 *March 13th 2015*-* New features:-  * Switch types of `bundle` and `bundle'`, and `unbundle` and `unbundle'`.-  * Rename all explicitly clocked versions of Signal functions, to the primed-    name of the implicitly clocked Signal functions. E.g. `cregister` is now-    called `register'` (where the implicitly clocked function is callled `register`)-  * Add new instances for `DSignal`-  * Add experimental `antiDelay` function for `DSignal`-  * Generalize lifted functions over Signals (e.g. (.==.))--* Fixes bugs:-  * Faster versions of Vector.(!!) and Vector.replace--## 0.6.0.1 *November 17th 2014*-* Fixes bugs:-  * Add missing 'CLaSH.Sized.BitVector' module to .cabal file.--## 0.6 *November 17th 2014*--* New features:-  * Add `Fractional` instance for `Fixed` [#9](https://github.com/christiaanb/clash-prelude/issues/9)-  * Make indexing/subscript of `Vec` ascending [#4](https://github.com/christiaanb/clash-prelude/issues/4)-  * Add separate `BitVector` type, which has a descending index.-  * Add bit indexing operators, including the index/subscript operator `(!)`.-  * Add bit reduction operators: `reduceOr`, `reduceAnd`, `reduceOr`.-  * Rename `BitVector` class to `BitPack` with `pack` and `unpack` class methods.-  * Rename `Pack` class to `Bundle` with `bundle` and `unbundle` class methods.-  * Strip all `Vec` functions from their `v` prefix, i.e. `vmap` -> `map`.-  * Rename `Vec` indexing operator from `(!)` to `(!!)`.-  * Combine `Add` and `Mult` class into `ExtendingNum` class.-  * Add extend and truncate methods to the `Resize` class.-  * Add `SaturatingNum` class with saturating numeric operators.-  * Add multitude of lifted `Signal` operators, i.e. `(.==.) :: Eq a => Signal a -> Signal a -> Signal Bool`-  * Add `CLaSH.Signal.Delayed` with functions and data types for delay-annotated signals to support safe synchronisation.-  * Add `CLASH.Prelude.DataFlow` with functions and data types to create self-synchronising circuits based on data-flow principles.--* Fixes bugs:-  * Remove deprecated 'Arrow' instance for and related functions for `Comp` [#5](https://github.com/christiaanb/clash-prelude/issues/5)--## 0.5.1 *June 5th 2014*--* New features:-  * Add `Default` instance for `Vec` [#2](https://github.com/christiaanb/clash-prelude/issues/2)-  * Instantiation for `blockRam` [#3](https://github.com/christiaanb/clash-prelude/issues/2)--* Fixes bugs:-  * Fixed error on documentation of fLit in Fixed.hs [#6](https://github.com/christiaanb/clash-prelude/issues/6)-  * Non-translatable `Enum` function interfere with `sassert` compilation [#7](https://github.com/christiaanb/clash-prelude/issues/7)-  * Substituted the word 'list' into 'vector' in some places in the documentation. [#8](https://github.com/christiaanb/clash-prelude/issues/8)-  * mark vselectI INLINEABLE [#10](https://github.com/christiaanb/clash-prelude/issues/10)--## 0.5 *April 3rd 2014*-  * Add explicitly clocked synchronous signals for multi-clock circuits--## 0.4.1 *March 27th 2014*-  * Add saturation to fixed-point operators-  * Finalize most documentation--## 0.4 *March 20th 2014*-  * Add fixed-point integers-  * Extend documentation-  * 'bit' and 'testBit' functions give run-time errors on out-of-bound positions--## 0.3 *March 14th 2014*-  * Add Documentation-  * Easy SNat literals for 0..1024, e.g. d4 = snat :: SNat 4-  * Fix blockRamPow2--## 0.2 *March 5th 2014*-  * Initial release+# Changelog for the Clash project++## 1.10.0 *Apr 23rd, 2026*++Release highlight:+* `Clash.Class.NumConvert`: Utilities for safely converting between various Clash number types [#2915](https://github.com/clash-lang/clash-compiler/pull/2915)++Added:+* Added GHC 9.12 support+* `Clash.Class.NumConvert`: Utilities for safely converting between various Clash number types [#2915](https://github.com/clash-lang/clash-compiler/pull/2915)+* Add `Clash.XException.ShowX` instance for `Foreign.C.Types.CUShort`. [#2397](https://github.com/clash-lang/clash-compiler/pull/2397)+* Introduced various new types to `Clash.Signal` to more easily represent time and its relation to your clock domain. New types: `Seconds`, `Milliseconds`, `Microseconds`, `Nanoseconds`, `Picoseconds`, `DomainToHz`, `HzToPeriod`, `PeriodToHz`, `PeriodToCycles`, `ClockDivider`. [#2734](https://github.com/clash-lang/clash-compiler/pull/2734)+* `Distributive` and `Representable` instances for `Vec`+* Resize functions `maybeResize` and `maybeTruncateB` to `Clash.Class.Resize`. Can be used to resize without loss of information. [#2779](https://github.com/clash-lang/clash-compiler/issues/2779)+* Alongside the existing Eq-like and Ord-like signal operators like `.==.` and `.<=.` etc., there are now new functions for comparing with constants: `.==`, `==.`, `./=`, `/=.`, `.<=`, `<=.`, `.>=`, `>=.`, `.>`, `>.`, `.<`, `<.`, `.&&`, `&&.`, `.||`, `||.`. These are useful for comparing signals with constants in a more readable way. For example, `a .==. pure True` can now be replaced with `a .== True`. [#2545](https://github.com/clash-lang/clash-compiler/pull/2545)+* instance `HasField f (Signal dom r) (Signal dom a)`. This means record dot accesses will be passed to the underlying type. For example, this will work:++  ```haskell+  data MyRecord = MyRecord { myField :: Int }++  a :: Signal dom MyRecord+  a = pure (MyRecord 3)++  b :: Signal dom Int+  b = a.myField+  ```+* `BitPack` instance for `Data.Proxy.Proxy`+* `apEn`, which is a `mux` that optionally applies an update function to a value. [#3029](https://github.com/clash-lang/clash-compiler/pull/3029)+* `regEnN`, which is a chain of `regEn`s. [#3029](https://github.com/clash-lang/clash-compiler/pull/3029)+* `Index 0` instances for `BitPack`, `Bits`, `Counter`, `FiniteBits`, `Parity`, and `SaturatingNum`. [#2784](https://github.com/clash-lang/clash-compiler/pull/2784)+* Zero-sized block RAM implementations for `blockRam1` and `blockRamU`. [#2784](https://github.com/clash-lang/clash-compiler/pull/2784)+* `Counter a => Counter (Vec 0 a)` instance. [#2784](https://github.com/clash-lang/clash-compiler/pull/2784)+* `SaturatingNum` and `Bounded` instances for `Signal dom a`. The `sat` family (`satAdd`, `satSucc`, ...) can now be used on `Signal`s and `{min,max}Bound` can be used to construct them [#2931](https://github.com/clash-lang/clash-compiler/issues/2931)+* `-fclash-no-concurrent-topentity-compilation` flag to disable concurrent compilation of top entities. This is mostly useful to get a consistent debug output.+* `SomeBoundedSNat` and Hedgehog generators [#3183](https://github.com/clash-lang/clash-compiler/pull/3183)+* `Eq`, `NFData`, `ShowX` and `BitPack` instances for `RamOp`.+* `smapWithBounds` extending `smap` via offering a proof witness for the upper bound of the vector size to the mapping function. [#2686](https://github.com/clash-lang/clash-compiler/pull/2686)+* The function `Clash.Explicit.DDR.ddrForwardClock`, which uses a DDR output primitive to forward a clock signal to a DDR-capable output pin. [#2876](https://github.com/clash-lang/clash-compiler/pull/2876)++Removed:+* Support for GHC versions 9.4 and older+* Newer Verilators (> v5) can deal with delay statements, hence removing the need for Clash specific workarounds. If you relied on Clash-generated Verilator shims, consider using `verilator --build --binary` instead.+* Experimental feature "multiple hidden domains" [#2750](https://github.com/clash-lang/clash-compiler/pull/2750)+* The deprecated module `Clash.Prelude.DataFlow` was removed. The `clash-protocols` package provides dataflow-based protocols and circuits. [#3181](https://github.com/clash-lang/clash-compiler/pull/3181)+* The deprecated functions `altpll` and `alteraPll` were removed from the `Clash.Intel.ClockGen` module. Clash 1.8 introduced the new functions `altpllSync`, `alteraPllSync`, `unsafeAltpll` and `unsafeAlteraPll`. A name for the IP instantiation, handled by the _name_ argument to `altpll` and `alteraPll`, can be provided with the `Clash.Magic.setName` function. [#3181](https://github.com/clash-lang/clash-compiler/pull/3181)++Changed:+* `dfold` now offers a proof witness for the upper bound of the vector size to the folding function. Note that this change may require additional type annotations, as solutions working in the past may complain with an untouchable type error now. [#2686](https://github.com/clash-lang/clash-compiler/pull/2686)+* You can now only create an `SDomainConfiguration` when the `period` of the domain is at least `1`. Pattern matching on an `SDomainConfiguration` bring the `1 <= period` into scope. This in turns enables the following code to typecheck:+  ```+  import Clash.Prelude+  import Data.Proxy++  f ::+    forall dom .+    KnownDomain dom =>+    Proxy dom ->+    SNat (PeriodToCycles dom (Milliseconds 1))+  f Proxy = case knownDomain @dom of+      SDomainConfiguration {} -> SNat+  ```+  where the `DivRU` in+  ```+  type PeriodToCycles (dom :: Domain) (period :: Nat) =  period `DivRU` DomainPeriod dom+  ```+  requires that the `DomainPeriod dom` is at least `1`. [#2740](https://github.com/clash-lang/clash-compiler/pull/2740)+* `select` and `selectI` now use `<=` constraints instead of `CmpNat`. [#2873](https://github.com/clash-lang/clash-compiler/pull/2873)+* `ResetStrategy` now contains the reset function, to avoid dummy arguments on `NoClearOnReset` [#2849](https://github.com/clash-lang/clash-compiler/pull/2849)+* `Clash.Explicit.DDR`, `Clash.Intel.DDR` and `Clash.Xilinx.DDR`: [#2833](https://github.com/clash-lang/clash-compiler/pull/2833)+    - The constraints for the functions have been rewritten to use `DomainPeriod`, which makes them more readable and relaxes unnecessary constraints on the virtual DDR domain. The type-level variables for the domains have been renamed. `dom` is a real domain, `domDDR` is the virtual DDR domain.+    - The Xilinx and Intel primitives only support domains where the rising edge is the active edge. This is now enforced at the type level by adding a constraint.+    - The Xilinx and Intel primitives now directly support any data type that has a `BitPack` instance.+* Order of type arguments for functions in `clash-prelude-hedgehog` now follows _size_, _domain_, _monad_. [#2880](https://github.com/clash-lang/clash-compiler/pull/2880)+* The Clash Prelude now exports the `Default` class from the package `data-default` instead of from the now superseded `data-default-class`. If you import the `Default` class name or the `def` function from the `data-default-class` package _older than version 0.2_, or one of your dependencies does, you might get a bewildering error message. You might get the error "No instance for (Default T)" even though there appears to be such an instance. The best solution is to make sure all your packages and dependencies use the `data-default` package and not the `data-default-class` package. The next most obvious solution is to make sure `data-default-class` is of version 0.2 or higher, for instance by depending on it in your own package. If this creates a dependency conflict, another solution is to import the correct module. `Default` and `def` from `Clash.Prelude` or `Data.Default` are for the new `data-default` package. `Data.Default.Class` is for the `data-default-class` package. There are situations where this will still not be enough, but luckily the `Default` class is not used all that much. [#2891](https://github.com/clash-lang/clash-compiler/pull/2891)+* Changed implementation of `(+>>)` to no longer require `KnownNat`+* The `clash-prelude` package now uses `PolyKinds` by default, meaning all its type class instances are now more general than before. As an example, without `PolyKinds`, `BitPack (Proxy a)` would only be defined when `a :: Type`, with the extension it would be defined for any  `a :: k`. After this change, some instances in user code might now overlap. [#2994](https://github.com/clash-lang/clash-compiler/pull/2994)+* When generating (System)Verilog, Clash now resets the default net type from none to the verilog default after the generated module. [#3005](https://github.com/clash-lang/clash-compiler/pull/3005)+* The content from the `Clash.Tutorial` module and from https://clash-lang.readthedocs.io/ has been split and moved to two new locations.+  1. The actual tutorial parts has been moved to: https://docs.clash-lang.org/tutorial/+  2. Parts that fit better in the clash compiler user guide have been moved to: https://docs.clash-lang.org/compiler-user-guide/++  Moving the documentation to these locations makes it easier to update their content as it is no longer needed to release a new version of the `clash-prelude` package for the publication of this content.+* Vector functions in Verilog now have indices consistent with the Vec inputs/outputs (before they were reversed). This is convenient when writing design constraints, which can now be referenced consistently like `imap[0],imap[1],..`. See [#3088](https://github.com/clash-lang/clash-compiler/issues/3088).++Fixed:+* Clash no longer gives `Dubious primitive instantiation warning` when using `unpack` [#2386](https://github.com/clash-lang/clash-compiler/issues/2386).+* Clash now generates more intuitive names for specialized binders. See [#2508](https://github.com/clash-lang/clash-compiler/issues/2508).+* `foldl` on `Vec` is now strict. See [this GitHub discussion](https://github.com/hasura/graphql-engine/pull/2933#discussion_r328821960) and [this blog post](https://well-typed.com/blog/90/) for more information. [#2482](https://github.com/clash-lang/clash-compiler/issues/2482)+* Type families that appear in GHC core types are now normalized before being translated into their Clash core equivalent. See [#3063](https://github.com/clash-lang/clash-compiler/issues/3063).+* Added an evaluator rule for `bigNatEq#` with compile-time constant arguments [#3084](https://github.com/clash-lang/clash-compiler/issues/3084)+* Reduce constants to NF before specialization [#3129](https://github.com/clash-lang/clash-compiler/issues/3129)+* `rotateL` and `rotateR` no longer error when used on `BitVector 0` [#2980](https://github.com/clash-lang/clash-compiler/issues/2980)+* Behavior of `shiftR` is now documented for `Unsigned`, `BitVector`, `Index`, and `Signed` [#2959](https://github.com/clash-lang/clash-compiler/issues/2959)+* Clash will no longer error if it finds the same data file more than once due to duplicate `-i` flags [#3141](https://github.com/clash-lang/clash-compiler/issues/3141)+* Higher order blackboxes not propagating usage metadata for generated results [#3147](https://github.com/clash-lang/clash-compiler/issues/3147)+* Run `caseCon` after post-normalization `inlineCleanup` [#3159](https://github.com/clash-lang/clash-compiler/issues/3159)+* Failure to generate binder assignments in very specific cases [#3185](https://github.com/clash-lang/clash-compiler/issues/3185)+* Clash won't create (invalid) netlist cases on Integer and Natural constructors anymore [#3157](https://github.com/clash-lang/clash-compiler/issues/3157)+* Post-normalization flattening could leave a `Just` constructor as the scrutinee of a `case` after simplifying tuple projections [#3204](https://github.com/clash-lang/clash-compiler/issues/3204)+* Clash no longer crashes on false positive free variable introduction in `reduceConst` and `constantSpec`. Fixes [#3206](https://github.com/clash-lang/clash-compiler/issues/3206).+* `negate` for `Num Bit` is now defined as the additive inverse, i.e., `negate = id`. [#2999](https://github.com/clash-lang/clash-compiler/issues/2999)++## 1.8.5 *Mar 24th, 2026*++Added:+* `Clash.Annotation.SynthesisAtrributes.annotateReg`, a function to add synthesis attributes (e.g. `ASYNC_REG`) to register declarations in the HDL generated by the Clash compiler.+  [#3093](https://github.com/clash-lang/clash-compiler/pull/3093)+* `registerSyncReset` [#3115](https://github.com/clash-lang/clash-compiler/issues/3115)++Fixed:+* The `Clash.Explicit.Verification.check` blackbox now correctly uses the given clock line, not assuming any longer that it is already bound to an identifier in the first place. [#2907](https://github.com/clash-lang/clash-compiler/issues/2907)+* The type of string literals passed to the `Clash.Explicit.Verification.check` blackbox now matches with the input provided via `Clash.Explicit.Verification.name`. [#2908](https://github.com/clash-lang/clash-compiler/issues/2908)+* `toInteger`, `toEnum`, and `fromEnum` now correctly sign extend when using Verilog backend. [#2729](https://github.com/clash-lang/clash-compiler/issues/2729).+* `dumpVCD` now properly aligns the first clock edges in multi-domain designs. [#3075](https://github.com/clash-lang/clash-compiler/issues/3075)+* Removed the limit on the number of traces in `dumpVCD`. Also removed unnecessary double newlines after 1-bit signals. [#3082](https://github.com/clash-lang/clash-compiler/issues/3082)+* In Clash simulation, `pack` for `Vec` and `RTree` had all bits undefined when the spine of the value had an `XException`. Now, those elements with defined bits will output those defined bits. In HDL, this was already the case. Example: consider `xs = 1 :> undefined :> Nil :: Vec 2 (Unsigned 4)` and `ys = 1 :> undefined :: Vec 2 (Unsigned 4)`. `xs` merely has an undefined element, but `ys` has an undefined spine: it is a `:>` constructor that is undefined. `pack ys` used to be `0b...._....` but is now `0b0001_....`, just as `pack xs` already was.+  [#3114](https://github.com/clash-lang/clash-compiler/pull/3114)+* Clash drops cached normalization result. [#3109](https://github.com/clash-lang/clash-compiler/issues/3109)+* Fix `holdReset` glitch behavior for asynchronous resets and wrong hold cycles for sync resets. [#3115](https://github.com/clash-lang/clash-compiler/issues/3115)+* Do not emit source locations if `-g` is not passed to clash [#3132](https://github.com/clash-lang/clash-compiler/issues/3132)+* `clash-ghc`: Remove `Opt_LlvmTBAA` from unwanted flags [#2508](https://github.com/clash-lang/clash-compiler/issues/2823)++## 1.8.4 *Nov 6th 2025*++Changed:+* Nix flake updated to make it more suitable for use in downstream projects. [#2987](https://github.com/clash-lang/clash-compiler/pull/2987) [#3060](https://github.com/clash-lang/clash-compiler/pull/3060)++Fixed:+* `collapseRHSNoops` now runs after constant folding, making Clash able to constant fold more expressions than before. See [#3036](https://github.com/clash-lang/clash-compiler/issues/3036).+* The `unzip` family no longer retains a reference to the original input for every (unevaluated) part of the output tuple. Similarly, `mapAccumL` and `mapAccumR` are now also more eager to drop references. This can help to prevent space leaks. See [#3038](https://github.com/clash-lang/clash-compiler/issues/3038).+* Individual items of `iterateI` no longer retain a reference to the whole list, preventing space leaks. See [#3042](https://github.com/clash-lang/clash-compiler/issues/3042).+* The compiler now tracks assignment types in more places, which can prevent "clash error call" errors in some specific cases. See [#3045](https://github.com/clash-lang/clash-compiler/issues/3045).+* Test bench primitives now assign the string they want to pass to Verilog's `$display` to a variable before printing. This works around a limitation in IVerilog. See [#3046](https://github.com/clash-lang/clash-compiler/issues/3046).++## 1.8.3 *Oct 6th 2025*++Added:+* `Counter` instances for `Bool`, `Bit`, `Int`, `Int8`, `Int16`, `Int32`, `Int64`, `Word`, `Word8`, `Word16`, `Word32`, `Word64`, `Identity` and `Maybe`. [#2692](https://github.com/clash-lang/clash-compiler/pull/2692)+* The Vec type now has a [COMPLETE pragma](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/pragmas.html#complete-pragma) to avoid incomplete pattern matches when using the `(:>)` pattern. [#3020](https://github.com/clash-lang/clash-compiler/pull/3020)+* RamOp now has an AutoReg instance. [#2792](https://github.com/clash-lang/clash-compiler/pull/2792)+* Added instance `NFDataX (SimOnly a)` [#2900](https://github.com/clash-lang/clash-compiler/pull/2900)+* Support for GHC 9.10 on Windows (macOS and Linux were already supported) [#2945](https://github.com/clash-lang/clash-compiler/pull/2945)+* Added a `BitPack` instance for `Char` [#2957](https://github.com/clash-lang/clash-compiler/pull/2957)+* Support for GHC 9.10.2 [#3003](https://github.com/clash-lang/clash-compiler/pull/3003)++Changed:+* Functions defined on `Clash.Class.Counter` are now public [#2692](https://github.com/clash-lang/clash-compiler/pull/2692)++Fixed:+* Clash hanging when rendering `Index n` literals, for large values of `n` [#2813](https://github.com/clash-lang/clash-compiler/issues/2813)+* Render overflowed Index literals as don't-cares in HDL [#2970](https://github.com/clash-lang/clash-compiler/pull/2970)+* Clash errors out when `Clash.Sized.Vector.splitAt` is compile-time evaluated in an illegal context [#2831]https://github.com/clash-lang/clash-compiler/issues/2831+* `Clash.Explicit.DDR`: [#2911](https://github.com/clash-lang/clash-compiler/pull/2911)+  - `ddrIn`: VHDL: Remove data input from sensitivity list of `ddrIn_neg_latch` register as it is superfluous. This should not affect functionality.+  - `ddrOut`: VHDL: Fix incorrect usage of `Enable` input when the domain is set to asynchronous resets. Deasserting the `Enable` exhibited wrong behavior before this fix.+* `Clash.Xilinx.DDR`: [#2911](https://github.com/clash-lang/clash-compiler/pull/2911)+  - These primitives only support clocks where the rising edge is the active edge. Using them in a domain with falling active edges now causes an error.+  - `oddr`: Fix VHDL and SystemVerilog erroring out during HDL generation+  - Symbols in HDL for both `iddr` and `oddr` were renamed to match their function.+* `Clash.Intel.DDR`: [#2911](https://github.com/clash-lang/clash-compiler/pull/2911)+  - These primitives only support clocks where the rising edge is the active edge. Using them in a domain with falling active edges now causes an error.+  - Fix rendering HDL. It variously errored out or generated non-working HDL.+  - Rendering HDL no longer causes Clash to issue a warning about an argument unused in Haskell but used in the primitive black box.+* `makeTopEntity` now accounts for `SimOnly` constructs. This can prevent warnings in situtations where the `SimOnly` type would contain types `makeTopEntity` cannot handle. [#2897](https://github.com/clash-lang/clash-compiler/pull/2897)+* Clash did not build on GHC 9.6.7 (but did on 9.6.6) [#2916](https://github.com/clash-lang/clash-compiler/issues/2916)+* Ignore `Tick`s in `TermLiteral Integer`, `TermLiteral Char`, `TermLiteral Natural`, and `TermLiteral (SNat n)` [#2925](https://github.com/clash-lang/clash-compiler/pull/2925)+* Fixed laziness issue in internal black box `imap_go` [#2542](https://github.com/clash-lang/clash-compiler/issues/2542)+* Clash's evaluator now uses `TemplateHaskell` names to detect renamed symbols in `GHC.*` and `Clash.*`. Fixes errors similar to `No blackbox found for: GHC.Internal.Base.eqString` [#2972](https://github.com/clash-lang/clash-compiler/issues/2972)+* No blackbox found for: `GHC.Internal.Control.Exception.Base.recSelError` on GHC 9.10 [#2966](https://github.com/clash-lang/clash-compiler/issues/2966)+* Verilog and System Verilog code gen bug for `map head` [#2809](https://github.com/clash-lang/clash-compiler/issues/2809)+* Error parsing blackbox: `Clash.Sized.Vector.head` [#2988](https://github.com/clash-lang/clash-compiler/issues/2988)+* Clash no longer duplicates included datafiles when component is instantiated multiple times [#3008](https://github.com/clash-lang/clash-compiler/issues/3008)+* Clash will no longer emit "no blackbox found for" `GHC.Real`'s exponentiation function if it is applied to constants [#3010](https://github.com/clash-lang/clash-compiler/pull/3010)+* Clash will no longer error out when converting `ensureSpine` on Clash number types to HDL [#3021](https://github.com/clash-lang/clash-compiler/issues/3021)+* Clash will no longer ignore Synthesize annotations when the function is used in an argument position [#3024](https://github.com/clash-lang/clash-compiler/issues/3024)++## 1.8.2 *Jan 3rd 2025*++Added:+* Support for GHC 9.10 [#2758](https://github.com/clash-lang/clash-compiler/pull/2758)+* Support for GHC 9.8.4 [#2852](https://github.com/clash-lang/clash-compiler/issues/2852)+* Add `ShowX`, `NFDataX` instances for `Proxy` [#2637](https://github.com/clash-lang/clash-compiler/pull/2637)+* Added `Clash.Sized.Vector.ToTuple.vecToTuple`: a way to safely work around incomplete patterns warnings on patterns involving `Vec`tors. [#2862](https://github.com/clash-lang/clash-compiler/pull/2682)+* Added operator precedences for infix usage of functions exported from `Clash.Class.Num`: `mul`, `add`, `sub`, `satMul`, `satAdd`, `satSub`, `boundedMul`, `boundedAdd`, and `boundedSub`. This means that expressions such as `` a `add` b `mul` c `` now get parsed as `` a `add` (b `mul` c) `` instead of `` (a `add` b) `mul` c ``. [#2719](https://github.com/clash-lang/clash-compiler/pull/2719)++Changed:+* `BitVector n` now has an implementation for `ensureSpine` which ensures the constructor is present. [#2702](https://github.com/clash-lang/clash-compiler/pull/2702)+* `xToBV` is now located in `Clash.Sized.Internal.BitVector` to avoid circular dependencies. [#2702](https://github.com/clash-lang/clash-compiler/pull/2702)+* The error messages that mention the valid ranges for out-of-range inputs have been improved to be more intuitive: one of `<empty range>`, `[n]` or `[n..m]`. All _n..m_ ranges are now ordered with the lower bound on the left. [#2733](https://github.com/clash-lang/clash-compiler/pull/2733)++Fixed:+* cabal: Make `workaround-ghc-mmap-crash` a noop on non-x86_64. Fixes [#2656](https://github.com/clash-lang/clash-compiler/issues/2656)+* Clash no longer hides error messages if it fails to load external (precompiled) modules. Note: this fix only works from GHC 9.0 on. See [#2365](https://github.com/clash-lang/clash-compiler/issues/2365)+* HDL generation fails when using multiple-hidden feature in combination with synthesis attributes [#2593](https://github.com/clash-lang/clash-compiler/issues/2593)+* Clash no longer errors out in the netlist generation stage when a polymorphic function is applied to type X in one alternative of a case-statement and applied to a newtype wrapper of type X in a different alternative. See [#2828](https://github.com/clash-lang/clash-compiler/issues/2628)+* various issues with black boxes and evaluator rules for number-related primitives [#2689](https://github.com/clash-lang/clash-compiler/pull/2689)+* `genBitVector` no longer contains off-by-one error on for generated Naturals [#2704](https://github.com/clash-lang/clash-compiler/pull/2704)+* (+>>.) and (.<<+) such that they are compliant with (+>>) and (<<+) for vectors of zero length in the sense that the input vector is kept unchanged. [#2730](https://github.com/clash-lang/clash-compiler/issues/2730)+* Removed `stringsearch` dependency from `v16-upgrade-primitives`. See [#2726](https://github.com/clash-lang/clash-compiler/issues/2726)+* Bug in the compile-time evaluator [#2781](https://github.com/clash-lang/clash-compiler/issues/2781)+* Exponentiation (`Clash.Class.Exp`) is now right-associative with a precedence level of 8 (`infixr 8`). By accident, it used to lack a fixity declaration, meaning it was implicitly left-associative at level 9. [#2818](https://github.com/clash-lang/clash-compiler/pull/2818)+* Unused argument warnings on writeToBiSignal# [#2822](https://github.com/clash-lang/clash-compiler/pull/2822)+* Clash errored saying it cannot translate a globally recursive function in code that originally only contains let-bound (local) recursion [#2839](https://github.com/clash-lang/clash-compiler/issues/2839)+* Clash generates illegal Verilog names [#2845](https://github.com/clash-lang/clash-compiler/issues/2845)++## 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`. [#1839](https://github.com/clash-lang/clash-compiler/pull/1839)+  * `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 combinational 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
LICENSE view
@@ -1,6 +1,6 @@ Copyright (c) 2013-2016, University of Twente,               2016-2019, Myrtle Software Ltd,-              2017-2019, QBayLogic B.V., Google Inc.+              2017-2025, QBayLogic B.V., Google Inc. All rights reserved.  Redistribution and use in source and binary forms, with or without
README.md view
@@ -2,7 +2,6 @@  [![Pipeline status](https://gitlab.com/clash-lang/clash-compiler/badges/master/pipeline.svg)](https://gitlab.com/clash-lang/clash-compiler/commits/master) [![Hackage](https://img.shields.io/hackage/v/clash-prelude.svg)](https://hackage.haskell.org/package/clash-prelude)-[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/clash-prelude.svg?style=flat)](http://packdeps.haskellers.com/feed?needle=exact%3Aclash-prelude)  Clash is a functional hardware description language that borrows both its syntax and semantics from the functional programming language@@ -25,7 +24,13 @@    * 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)+# Open-source community+Clash benefits from an active community. Whether you need a question answered or+want to contribute to open-source features, browse the features below to make+the most of Clash.++- [Discourse: long form discussions and questions](https://clash-lang.discourse.group/)+- [Discord: short form discussions and community chat room](https://discord.gg/rebGq25FB4)+- [Fosstodon: microblogging and community chat room](https://fosstodon.org/@ClashHDL)+- [Bluesky: microblogging and community chat room](https://bsky.app/profile/clash-lang.bsky.social)+- [Github: issue tracker](https://github.com/clash-lang/clash-compiler/issues)
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
benchmarks/BenchBitVector.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-}+{-# LANGUAGE NoStarIsType #-}  {-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-} @@ -6,12 +7,53 @@  module BenchBitVector where -import Clash.Sized.Internal.BitVector+import Data.Bits+import Clash.Sized.BitVector import Clash.Class.Num+import Clash.Class.BitPack.BitIndex import GHC.TypeLits                   (type (*))-import Criterion                      (Benchmark, env, bench, nf)+import Criterion                      (Benchmark, env, bench, nf, bgroup) import Language.Haskell.TH.Syntax     (lift) +import BenchCommon++bitVectorBench :: Benchmark+bitVectorBench = bgroup "BitVector"+  [ fromIntegerBench+  , addBench+  , addBenchL+  , negateBench+  , negateBenchL+  , subBench+  , subBenchL+  , multBench+  , multBenchL+  , plusBench+  , minusBench+  , timesBench+  , boundedAddBench+  , boundedSubBench+  , boundedMulBench+  , msbBench+  , msbBenchL+  , appendBench+  , appendBenchL+  , splitBench+  , splitBenchL+  , xorBench+  , xorBenchL+  , andBench+  , andBenchL+  , orBench+  , orBenchL+  , complementBench+  , complementBenchL+  ]++smallValueI :: Integer+smallValueI = $(lift (2^(16::Int)-10 :: Integer))+{-# INLINE smallValueI #-}+ smallValue1 :: BitVector WORD_SIZE_IN_BITS smallValue1 = $(lift (2^(16::Int)-10 :: BitVector WORD_SIZE_IN_BITS)) {-# INLINE smallValue1 #-}@@ -21,105 +63,184 @@ {-# INLINE smallValue2 #-}  largeValue1 :: BitVector (3*WORD_SIZE_IN_BITS)-largeValue1 =  2^(2*WORD_SIZE_IN_BITS :: Int)-10 :: BitVector (3*WORD_SIZE_IN_BITS)+largeValue1 = $(lift (2^(2*WORD_SIZE_IN_BITS :: Int)-10 :: BitVector (3*WORD_SIZE_IN_BITS))) {-# INLINE largeValue1 #-}  largeValue2 :: BitVector (3*WORD_SIZE_IN_BITS)-largeValue2 =  2^(2*WORD_SIZE_IN_BITS :: Int)-100 :: BitVector (3*WORD_SIZE_IN_BITS)+largeValue2 = $(lift (2^(2*WORD_SIZE_IN_BITS :: Int)-100 :: BitVector (3*WORD_SIZE_IN_BITS))) {-# INLINE largeValue2 #-} +fromIntegerBench :: Benchmark+fromIntegerBench = env setup $ \m ->+  bench "fromInteger WORD_SIZE_IN_BITS" $+  nf (fromInteger :: Integer -> BitVector WORD_SIZE_IN_BITS) m+  where+    setup = return smallValueI+ addBench :: Benchmark addBench = env setup $ \m ->-  bench "+# WORD_SIZE_IN_BITS" $ nf (uncurry (+#)) m+  bench "+ WORD_SIZE_IN_BITS" $ nf (apSwapAp (+)) m   where     setup = return (smallValue1,smallValue2) +addBenchL :: Benchmark+addBenchL = env setup $ \m ->+  bench "+ 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (+)) m+  where+    setup = return (largeValue1,largeValue2)+ negateBench :: Benchmark negateBench = env setup $ \m ->-  bench "negate# WORD_SIZE_IN_BITS" $ nf negate# m+  bench "negate WORD_SIZE_IN_BITS" $ nf negate m   where     setup = return smallValue1 +negateBenchL :: Benchmark+negateBenchL = env setup $ \m ->+  bench "negate 3*WORD_SIZE_IN_BITS" $ nf negate m+  where+    setup = return largeValue1+ subBench :: Benchmark subBench = env setup $ \m ->-  bench "-# WORD_SIZE_IN_BITS" $ nf (uncurry (-#)) m+  bench "- WORD_SIZE_IN_BITS" $ nf (apSwapAp (-)) m   where     setup = return (smallValue1,smallValue2) +subBenchL :: Benchmark+subBenchL = env setup $ \m ->+  bench "- 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (-)) m+  where+    setup = return (largeValue1,largeValue2)+ multBench :: Benchmark multBench = env setup $ \m ->-  bench "*# WORD_SIZE_IN_BITS" $ nf (uncurry (*#)) m+  bench "* WORD_SIZE_IN_BITS" $ nf (apSwapAp (*)) m   where     setup = return (smallValue1,smallValue2) +multBenchL :: Benchmark+multBenchL = env setup $ \m ->+  bench "* 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (*)) m+  where+    setup = return (largeValue1,largeValue2)+ plusBench :: Benchmark plusBench = env setup $ \m ->-  bench "plus# WORD_SIZE_IN_BITS" $ nf (uncurry (plus#)) m+  bench "plus WORD_SIZE_IN_BITS" $ nf (apSwapAp2 add add) m   where     setup = return (smallValue1,smallValue2)  minusBench :: Benchmark minusBench = env setup $ \m ->-  bench "minus# WORD_SIZE_IN_BITS" $ nf (uncurry (minus#)) m+  bench "minus WORD_SIZE_IN_BITS" $ nf (apSwapAp2 sub sub) m   where     setup = return (smallValue1,smallValue2)  timesBench :: Benchmark timesBench = env setup $ \m ->-  bench "times# WORD_SIZE_IN_BITS" $ nf (uncurry (times#)) m+  bench "times WORD_SIZE_IN_BITS" $ nf (apSwapAp2 mul mul) m   where     setup = return (smallValue1,smallValue2)  boundedAddBench :: Benchmark boundedAddBench = env setup $ \m ->-  bench "boundedAdd WORD_SIZE_IN_BITS" $ nf (uncurry (boundedAdd)) m+  bench "boundedAdd WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedAdd) m   where     setup = return (smallValue1,smallValue2)  boundedSubBench :: Benchmark boundedSubBench = env setup $ \m ->-  bench "boundedSub WORD_SIZE_IN_BITS" $ nf (uncurry (boundedSub)) m+  bench "boundedSub WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedSub) m   where     setup = return (smallValue1,smallValue2)  boundedMulBench :: Benchmark boundedMulBench = env setup $ \m ->-  bench "boundedMul WORD_SIZE_IN_BITS" $ nf (uncurry (boundedMul)) m+  bench "boundedMul WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedMul) m   where     setup = return (smallValue1,smallValue2)  msbBench :: Benchmark msbBench = env setup $ \m ->-  bench "msb# WORD_SIZE_IN_BITS" $ nf msb# m+  bench "msb# WORD_SIZE_IN_BITS" $ nf msb m   where     setup = return smallValue1  msbBenchL :: Benchmark msbBenchL = env setup $ \m ->-  bench "msb# (3*WORD_SIZE_IN_BITS)" $ nf msb# m+  bench "msb# (3*WORD_SIZE_IN_BITS)" $ nf msb m   where     setup = return largeValue1  appendBench :: Benchmark appendBench = env setup $ \m ->-  bench "++# WORD_SIZE_IN_BITS" $ nf (uncurry (++#)) m+  bench "++# WORD_SIZE_IN_BITS" $ nf (apSwapAp2 (++#) (++#)) m   where     setup = return (smallValue1,smallValue2)  appendBenchL :: Benchmark appendBenchL = env setup $ \m ->-  bench "++# (3*WORD_SIZE_IN_BITS)" $ nf (uncurry (++#)) m+  bench "++# (3*WORD_SIZE_IN_BITS)" $ nf (apSwapAp2 (++#) (++#)) m   where     setup = return (largeValue1,largeValue2)  splitBench :: Benchmark splitBench = env setup $ \m ->-  bench "split# WORD_SIZE_IN_BITS" $ nf (split# :: BitVector WORD_SIZE_IN_BITS -> (BitVector 18, BitVector 46)) m+  bench "split# WORD_SIZE_IN_BITS" $ nf (split :: BitVector WORD_SIZE_IN_BITS -> (BitVector 18, BitVector 46)) m   where     setup = return smallValue1  splitBenchL :: Benchmark splitBenchL = env setup $ \m ->-  bench "split# (3*WORD_SIZE_IN_BITS)" $ nf (split# :: BitVector (3*WORD_SIZE_IN_BITS) -> (BitVector 18, BitVector 174)) m+  bench "split# (3*WORD_SIZE_IN_BITS)" $ nf (split :: BitVector (3*WORD_SIZE_IN_BITS) -> (BitVector 18, BitVector 174)) m+  where+    setup = return largeValue1++xorBench :: Benchmark+xorBench = env setup $ \m ->+  bench "xor WORD_SIZE_IN_BITS" $ nf (apSwapAp xor) m+  where+    setup = return (smallValue1,smallValue2)++xorBenchL :: Benchmark+xorBenchL = env setup $ \m ->+  bench "xor 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp xor) m+  where+    setup = return (largeValue1,largeValue2)++andBench :: Benchmark+andBench = env setup $ \m ->+  bench ".&. WORD_SIZE_IN_BITS" $ nf (apSwapAp (.&.)) m+  where+    setup = return (smallValue1,smallValue2)++andBenchL :: Benchmark+andBenchL = env setup $ \m ->+  bench ".&. 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (.&.)) m+  where+    setup = return (largeValue1,largeValue2)++orBench :: Benchmark+orBench = env setup $ \m ->+  bench ".|. WORD_SIZE_IN_BITS" $ nf (apSwapAp (.|.)) m+  where+    setup = return (smallValue1,smallValue2)++orBenchL :: Benchmark+orBenchL = env setup $ \m ->+  bench ".|. 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (.|.)) m+  where+    setup = return (largeValue1,largeValue2)++complementBench :: Benchmark+complementBench = env setup $ \m ->+  bench "complement WORD_SIZE_IN_BITS" $ nf complement m+  where+    setup = return smallValue1++complementBenchL :: Benchmark+complementBenchL = env setup $ \m ->+  bench "complement 3*WORD_SIZE_IN_BITS" $ nf complement m   where     setup = return largeValue1
+ benchmarks/BenchCommon.hs view
@@ -0,0 +1,9 @@+module BenchCommon where++apSwapAp :: (a -> a -> a) -> (a,a) -> a+apSwapAp f (a,b) = f (f a b) (f b a)+{-# INLINE apSwapAp #-}++apSwapAp2 :: (a -> a -> b) -> (b -> b -> c) -> (a,a) -> c+apSwapAp2 f g (a,b) = g (f a b) (f b a)+{-# INLINE apSwapAp2 #-}
benchmarks/BenchFixed.hs view
@@ -4,13 +4,22 @@  #define WORD_SIZE_IN_BITS 64 -module BenchFixed where+module BenchFixed (fixedBench) where  import Clash.Class.Num import Clash.Sized.Fixed import Clash.Sized.Unsigned-import Criterion                   (Benchmark, env, bench, nf)+import Criterion                   (Benchmark, env, bench, nf, bgroup) import Language.Haskell.TH.Syntax  (lift)++fixedBench :: Benchmark+fixedBench = bgroup "Fixed"+  [ fromRationalBench+  , addBench+  , subBench+  , multBench+  , multBench_wrap+  ]  smallValueR_pos :: Rational smallValueR_pos = $(lift (5126.889117 :: Rational))
+ benchmarks/BenchRAM.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE MagicHash, TypeApplications, DataKinds #-}+module BenchRAM (ramBench) where++import Criterion (Benchmark, env, bench, nf, bgroup, envWithCleanup)+import System.Directory+import System.IO++import Clash.Explicit.BlockRam+import Clash.Explicit.BlockRam.File+import Clash.Explicit.RAM+import Clash.Explicit.ROM+import Clash.Explicit.Signal+import Clash.Prelude.ROM+import Clash.Promoted.Nat+import Clash.Promoted.Nat.Literals+import qualified Clash.Sized.Vector as V+import Clash.Sized.Internal.BitVector (undefined#)++ramBench :: Benchmark+ramBench = bgroup "RAMs"+  [ asyncRamBench+  , asyncRomBench+  , blockRamBench+  , blockRamROBench+  , blockRamFileBench+  , blockRamFileROBench+  , romBench+  ]++asyncRamBench :: Benchmark+asyncRamBench = env setup $ \m ->+  bench "asyncRam#" $+  nf (take 298 . drop 2 . simulate_lazy+        (\rw -> let (r,w) = unbundle rw+                in  asyncRam# @System+                      clockGen+                      clockGen+                      enableGen+                      (SNat @4096)+                      r+                      (pure True)+                      w+                      w+                   )) m+  where+    setup   = pure (zip [556,557..856] [557,558..857])++asyncRomBench :: Benchmark+asyncRomBench = env setup $ \m ->+  bench "asyncRom#" $+  nf (take 98 . drop 2 . fmap (asyncRom# ramInit)) m+  where+    ramInit = V.replicate d1024 (1 :: Int)+    setup   = pure ([557,558..857])++blockRamBench :: Benchmark+blockRamBench = env setup $ \m ->+  bench "blockRam# (100% writes)" $+  nf (take 8298 . drop 2 . simulate_lazy+        (\w -> ram w+                    (pure True)+                    w+                    w+                   )) (cycle m)+  where+    ramInit = V.replicate (SNat @4096) (1 :: Int)+    setup   = pure ([557,558..857])+    ram     = blockRam# @System+                    clockGen+                    enableGen+                    ramInit++blockRamROBench :: Benchmark+blockRamROBench = env setup $ \m ->+  bench "blockRam# (0% writes)" $+  nf (take 8298 . drop 2 . simulate_lazy+        (\w -> ram w+                    (pure False)+                    w+                    w+                   )) (cycle m)+  where+    ramInit = V.replicate (SNat @4096) (1 :: Int)+    setup   = pure ([557,558..857])+    ram     = blockRam# @System+                    clockGen+                    enableGen+                    ramInit++blockRamFileBench :: Benchmark+blockRamFileBench = envWithCleanup setup cleanup $ \(~(m,_,ram)) ->+  bench "blockRamFile# (100% writes)" $+  nf (take 8298 . drop 2 . simulate_lazy+        (\w -> ram  w+                    (pure True)+                    w+                    (pure undefined#)+                   )) (cycle m)+  where+    setup = do+      (fp,h) <- openTempFile "." "mem.bin"+      hPutStr h (unlines (replicate 4096 (replicate 63 '0' ++ ['1'])))+      hClose h+      let ram = blockRamFile# @64 @System+              clockGen+              enableGen+              (SNat @4096)+              fp+      fp `seq` ram `seq` return ([557,558..857],fp,ram)++    cleanup (_,f,_) = removeFile f++blockRamFileROBench :: Benchmark+blockRamFileROBench = envWithCleanup setup cleanup $ \(~(m,_,ram)) ->+  bench "blockRamFile# (0% writes)" $+  nf (take 8298 . drop 2 . simulate_lazy+        (\w -> ram w+                   (pure False)+                   w+                   (pure undefined#)+                   )) (cycle m)+  where+    setup = do+      (fp,h) <- openTempFile "." "mem.bin"+      hPutStr h (unlines (replicate 4096 (replicate 63 '0' ++ ['1'])))+      hClose h+      let ram = blockRamFile# @64 @System+                    clockGen+                    enableGen+                    (SNat @4096)+                    fp+      fp `seq` ram `seq` return ([557,558..857], fp, ram)++    cleanup (_,f,_) = removeFile f++romBench :: Benchmark+romBench = env setup $ \m ->+  bench "rom#" $+  nf (take 98 . drop 2 . simulate_lazy+        (\r -> rom# @System+                    clockGen+                    enableGen+                    ramInit+                    r+                   )) m+  where+    ramInit = V.replicate d1024 (1 :: Int)+    setup   = pure ([557,558..857])
benchmarks/BenchSigned.hs view
@@ -1,94 +1,224 @@ {-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-}+{-# LANGUAGE NoStarIsType #-}  {-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-}  #define WORD_SIZE_IN_BITS 64 -module BenchSigned where+module BenchSigned (signedBench) where +import Data.Bits+import Clash.Class.Num+import Clash.Class.BitPack import Clash.Sized.BitVector-import Clash.Sized.Internal.Signed-import Criterion                   (Benchmark, env, bench, nf)+import Clash.Sized.Signed+import Criterion                   (Benchmark, env, bench, nf, bgroup) import Language.Haskell.TH.Syntax  (lift)+import GHC.TypeLits                (type (*)) -smallValueI_pos :: Integer-smallValueI_pos = $(lift (2^(16::Int)-10 :: Integer))-{-# INLINE smallValueI_pos #-}+import BenchCommon -smallValue_pos1 :: Signed WORD_SIZE_IN_BITS-smallValue_pos1 = $(lift (2^(16::Int)-100 :: Signed WORD_SIZE_IN_BITS))-{-# INLINE smallValue_pos1 #-}+signedBench :: Benchmark+signedBench = bgroup "Signed"+  [ fromIntegerBench+  , addBench+  , addBenchL+  , negateBench+  , negateBenchL+  , subBench+  , subBenchL+  , multBench+  , multBenchL+  , plusBench+  , minusBench+  , timesBench+  , boundedAddBench+  , boundedSubBench+  , boundedMulBench+  , packBench+  , unpackBench+  , xorBench+  , xorBenchL+  , andBench+  , andBenchL+  , orBench+  , orBenchL+  , complementBench+  , complementBenchL+  ] -smallValue_pos2 :: Signed WORD_SIZE_IN_BITS-smallValue_pos2 = $(lift (2^(16::Int)-100 :: Signed WORD_SIZE_IN_BITS))-{-# INLINE smallValue_pos2 #-}+smallValueI :: Integer+smallValueI = $(lift (2^(16::Int)-10 :: Integer))+{-# INLINE smallValueI #-} +smallValue1 :: Signed WORD_SIZE_IN_BITS+smallValue1 = $(lift (2^(16::Int)-10 :: Signed WORD_SIZE_IN_BITS))+{-# INLINE smallValue1 #-}++smallValue2 :: Signed WORD_SIZE_IN_BITS+smallValue2 = $(lift (2^(16::Int)-100 :: Signed WORD_SIZE_IN_BITS))+{-# INLINE smallValue2 #-}+ smallValueBV :: BitVector WORD_SIZE_IN_BITS smallValueBV = $(lift (2^(16::Int)-10 :: BitVector WORD_SIZE_IN_BITS)) {-# INLINE smallValueBV #-} +largeValue1 :: Signed (3*WORD_SIZE_IN_BITS)+largeValue1 = $(lift (2^(2*WORD_SIZE_IN_BITS :: Int)-10 :: Signed (3*WORD_SIZE_IN_BITS)))+{-# INLINE largeValue1 #-}++largeValue2 :: Signed (3*WORD_SIZE_IN_BITS)+largeValue2 = $(lift (2^(2*WORD_SIZE_IN_BITS :: Int)-100 :: Signed (3*WORD_SIZE_IN_BITS)))+{-# INLINE largeValue2 #-}++fromIntegerBench :: Benchmark+fromIntegerBench = env setup $ \m ->+  bench "fromInteger WORD_SIZE_IN_BITS" $+  nf (fromInteger :: Integer -> Signed WORD_SIZE_IN_BITS) m+  where+    setup = return smallValueI+ addBench :: Benchmark addBench = env setup $ \m ->-  bench "+# WORD_SIZE_IN_BITS" $ nf (uncurry (+#)) m+  bench "+ WORD_SIZE_IN_BITS" $ nf (apSwapAp (+)) m   where-    setup = return (smallValue_pos1,smallValue_pos2)+    setup = return (smallValue1,smallValue2) +addBenchL :: Benchmark+addBenchL = env setup $ \m ->+  bench "+ 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (+)) m+  where+    setup = return (largeValue1,largeValue2)+ negateBench :: Benchmark negateBench = env setup $ \m ->-  bench "negate# WORD_SIZE_IN_BITS" $ nf negate# m+  bench "negate WORD_SIZE_IN_BITS" $ nf negate m   where-    setup = return smallValue_pos1+    setup = return smallValue1 -absBench :: Benchmark-absBench = env setup $ \m ->-  bench "abs# WORD_SIZE_IN_BITS" $ nf abs# m+negateBenchL :: Benchmark+negateBenchL = env setup $ \m ->+  bench "negate 3*WORD_SIZE_IN_BITS" $ nf negate m   where-    setup = return smallValue_pos1+    setup = return largeValue1  subBench :: Benchmark subBench = env setup $ \m ->-  bench "-# WORD_SIZE_IN_BITS" $ nf (uncurry (-#)) m+  bench "- WORD_SIZE_IN_BITS" $ nf (apSwapAp (-)) m   where-    setup = return (smallValue_pos1,smallValue_pos2)+    setup = return (smallValue1,smallValue2) +subBenchL :: Benchmark+subBenchL = env setup $ \m ->+  bench "- 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (-)) m+  where+    setup = return (largeValue1,largeValue2)+ multBench :: Benchmark multBench = env setup $ \m ->-  bench "*# WORD_SIZE_IN_BITS" $ nf (uncurry (*#)) m+  bench "* WORD_SIZE_IN_BITS" $ nf (apSwapAp (*)) m   where-    setup = return (smallValue_pos1,smallValue_pos2)+    setup = return (smallValue1,smallValue2) +multBenchL :: Benchmark+multBenchL = env setup $ \m ->+  bench "* 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (*)) m+  where+    setup = return (largeValue1,largeValue2)+ plusBench :: Benchmark plusBench = env setup $ \m ->-  bench "plus# WORD_SIZE_IN_BITS" $ nf (uncurry (plus#)) m+  bench "plus WORD_SIZE_IN_BITS" $ nf (apSwapAp2 add add) m   where-    setup = return (smallValue_pos1,smallValue_pos2)+    setup = return (smallValue1,smallValue2)  minusBench :: Benchmark minusBench = env setup $ \m ->-  bench "minus# WORD_SIZE_IN_BITS" $ nf (uncurry (minus#)) m+  bench "minus WORD_SIZE_IN_BITS" $ nf (apSwapAp2 sub sub) m   where-    setup = return (smallValue_pos1,smallValue_pos2)+    setup = return (smallValue1,smallValue2)  timesBench :: Benchmark timesBench = env setup $ \m ->-  bench "times# WORD_SIZE_IN_BITS" $ nf (uncurry (times#)) m+  bench "times WORD_SIZE_IN_BITS" $ nf (apSwapAp2 mul mul) m   where-    setup = return (smallValue_pos1,smallValue_pos2)+    setup = return (smallValue1,smallValue2) -fromIntegerBench :: Benchmark-fromIntegerBench = env setup $ \m ->-  bench "fromInteger# WORD_SIZE_IN_BITS" $ nf (fromInteger# :: Integer -> Signed WORD_SIZE_IN_BITS) m+boundedAddBench :: Benchmark+boundedAddBench = env setup $ \m ->+  bench "boundedAdd WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedAdd) m   where-    setup = return smallValueI_pos+    setup = return (smallValue1,smallValue2) +boundedSubBench :: Benchmark+boundedSubBench = env setup $ \m ->+  bench "boundedSub WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedSub) m+  where+    setup = return (smallValue1,smallValue2)++boundedMulBench :: Benchmark+boundedMulBench = env setup $ \m ->+  bench "boundedMul WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedMul) m+  where+    setup = return (smallValue1,smallValue2)+ packBench :: Benchmark packBench = env setup $ \m ->-  bench "pack# WORD_SIZE_IN_BITS" $ nf pack# m+  bench "pack WORD_SIZE_IN_BITS" $ nf pack m   where-    setup = return smallValue_pos1+    setup = return smallValue1  unpackBench :: Benchmark unpackBench = env setup $ \m ->-  bench "unpack# WORD_SIZE_IN_BITS" $ nf unpack# m+  bench "unpack WORD_SIZE_IN_BITS" $+  nf (unpack :: BitVector WORD_SIZE_IN_BITS -> Signed WORD_SIZE_IN_BITS) m   where     setup = return smallValueBV++xorBench :: Benchmark+xorBench = env setup $ \m ->+  bench "xor WORD_SIZE_IN_BITS" $ nf (apSwapAp xor) m+  where+    setup = return (smallValue1,smallValue2)++xorBenchL :: Benchmark+xorBenchL = env setup $ \m ->+  bench "xor 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp xor) m+  where+    setup = return (largeValue1,largeValue2)++andBench :: Benchmark+andBench = env setup $ \m ->+  bench ".&. WORD_SIZE_IN_BITS" $ nf (apSwapAp (.&.)) m+  where+    setup = return (smallValue1,smallValue2)++andBenchL :: Benchmark+andBenchL = env setup $ \m ->+  bench ".&. 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (.&.)) m+  where+    setup = return (largeValue1,largeValue2)++orBench :: Benchmark+orBench = env setup $ \m ->+  bench ".|. WORD_SIZE_IN_BITS" $ nf (apSwapAp (.|.)) m+  where+    setup = return (smallValue1,smallValue2)++orBenchL :: Benchmark+orBenchL = env setup $ \m ->+  bench ".|. 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (.|.)) m+  where+    setup = return (largeValue1,largeValue2)++complementBench :: Benchmark+complementBench = env setup $ \m ->+  bench "complement WORD_SIZE_IN_BITS" $ nf complement m+  where+    setup = return smallValue1++complementBenchL :: Benchmark+complementBenchL = env setup $ \m ->+  bench "complement 3*WORD_SIZE_IN_BITS" $ nf complement m+  where+    setup = return largeValue1
+ benchmarks/BenchUnsigned.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-}+{-# LANGUAGE NoStarIsType #-}++{-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-}++#define WORD_SIZE_IN_BITS 64++module BenchUnsigned (unsignedBench) where++import Data.Bits+import Data.Word+import Clash.Class.Num+import Clash.Class.BitPack+import Clash.Sized.BitVector+import Clash.Sized.Unsigned+import Criterion                   (Benchmark, env, bench, nf, bgroup)+import Language.Haskell.TH.Syntax  (lift)+import GHC.TypeLits                (type (*))++import BenchCommon++unsignedBench :: Benchmark+unsignedBench = bgroup "Unsigned"+  [ fromIntegerBench+  , addBench+  , addBenchL+  , negateBench+  , negateBenchL+  , subBench+  , subBenchL+  , multBench+  , multBenchL+  , plusBench+  , minusBench+  , timesBench+  , boundedAddBench+  , boundedSubBench+  , boundedMulBench+  , packBench+  , unpackBench+  , xorBench+  , xorBenchL+  , andBench+  , andBenchL+  , orBench+  , orBenchL+  , complementBench+  , complementBenchL+  , unsigned8toWord8Bench+  , unsigned16toWord16Bench+  , unsigned32toWord32Bench+  , unsignedToWordBench+  ]++smallValueI :: Integer+smallValueI = $(lift (2^(16::Int)-10 :: Integer))+{-# INLINE smallValueI #-}++smallValue1 :: Unsigned WORD_SIZE_IN_BITS+smallValue1 = $(lift (2^(16::Int)-10 :: Unsigned WORD_SIZE_IN_BITS))+{-# INLINE smallValue1 #-}++smallValue2 :: Unsigned WORD_SIZE_IN_BITS+smallValue2 = $(lift (2^(16::Int)-100 :: Unsigned WORD_SIZE_IN_BITS))+{-# INLINE smallValue2 #-}++smallValueW8 :: Unsigned 8+smallValueW8 = $(lift (2^(4::Int)-10 :: Unsigned 8))+{-# INLINE smallValueW8 #-}++smallValueW16 :: Unsigned 16+smallValueW16 = $(lift (2^(8::Int)-10 :: Unsigned 16))+{-# INLINE smallValueW16 #-}++smallValueW32 :: Unsigned 32+smallValueW32 = $(lift (2^(16::Int)-10 :: Unsigned 32))+{-# INLINE smallValueW32 #-}++smallValueBV :: BitVector WORD_SIZE_IN_BITS+smallValueBV = $(lift (2^(16::Int)-10 :: BitVector WORD_SIZE_IN_BITS))+{-# INLINE smallValueBV #-}++largeValue1 :: Unsigned (3*WORD_SIZE_IN_BITS)+largeValue1 = $(lift (2^(2*WORD_SIZE_IN_BITS :: Int)-10 :: Unsigned (3*WORD_SIZE_IN_BITS)))+{-# INLINE largeValue1 #-}++largeValue2 :: Unsigned (3*WORD_SIZE_IN_BITS)+largeValue2 = $(lift (2^(2*WORD_SIZE_IN_BITS :: Int)-100 :: Unsigned (3*WORD_SIZE_IN_BITS)))+{-# INLINE largeValue2 #-}++fromIntegerBench :: Benchmark+fromIntegerBench = env setup $ \m ->+  bench "fromInteger WORD_SIZE_IN_BITS" $+  nf (fromInteger :: Integer -> Unsigned WORD_SIZE_IN_BITS) m+  where+    setup = return smallValueI++addBench :: Benchmark+addBench = env setup $ \m ->+  bench "+ WORD_SIZE_IN_BITS" $ nf (apSwapAp (+)) m+  where+    setup = return (smallValue1,smallValue2)++addBenchL :: Benchmark+addBenchL = env setup $ \m ->+  bench "+ 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (+)) m+  where+    setup = return (largeValue1,largeValue2)++negateBench :: Benchmark+negateBench = env setup $ \m ->+  bench "negate WORD_SIZE_IN_BITS" $ nf negate m+  where+    setup = return smallValue1++negateBenchL :: Benchmark+negateBenchL = env setup $ \m ->+  bench "negate 3*WORD_SIZE_IN_BITS" $ nf negate m+  where+    setup = return largeValue1++subBench :: Benchmark+subBench = env setup $ \m ->+  bench "- WORD_SIZE_IN_BITS" $ nf (apSwapAp (-)) m+  where+    setup = return (smallValue1,smallValue2)++subBenchL :: Benchmark+subBenchL = env setup $ \m ->+  bench "- 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (-)) m+  where+    setup = return (largeValue1,largeValue2)++multBench :: Benchmark+multBench = env setup $ \m ->+  bench "* WORD_SIZE_IN_BITS" $ nf (apSwapAp (*)) m+  where+    setup = return (smallValue1,smallValue2)++multBenchL :: Benchmark+multBenchL = env setup $ \m ->+  bench "* 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (*)) m+  where+    setup = return (largeValue1,largeValue2)++plusBench :: Benchmark+plusBench = env setup $ \m ->+  bench "plus WORD_SIZE_IN_BITS" $ nf (apSwapAp2 add add) m+  where+    setup = return (smallValue1,smallValue2)++minusBench :: Benchmark+minusBench = env setup $ \m ->+  bench "minus WORD_SIZE_IN_BITS" $ nf (apSwapAp2 sub sub) m+  where+    setup = return (smallValue1,smallValue2)++timesBench :: Benchmark+timesBench = env setup $ \m ->+  bench "times WORD_SIZE_IN_BITS" $ nf (apSwapAp2 mul mul) m+  where+    setup = return (smallValue1,smallValue2)++boundedAddBench :: Benchmark+boundedAddBench = env setup $ \m ->+  bench "boundedAdd WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedAdd) m+  where+    setup = return (smallValue1,smallValue2)++boundedSubBench :: Benchmark+boundedSubBench = env setup $ \m ->+  bench "boundedSub WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedSub) m+  where+    setup = return (smallValue1,smallValue2)++boundedMulBench :: Benchmark+boundedMulBench = env setup $ \m ->+  bench "boundedMul WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedMul) m+  where+    setup = return (smallValue1,smallValue2)++packBench :: Benchmark+packBench = env setup $ \m ->+  bench "pack WORD_SIZE_IN_BITS" $ nf pack m+  where+    setup = return smallValue1++unpackBench :: Benchmark+unpackBench = env setup $ \m ->+  bench "unpack WORD_SIZE_IN_BITS" $+  nf (unpack :: BitVector WORD_SIZE_IN_BITS -> Unsigned WORD_SIZE_IN_BITS) m+  where+    setup = return smallValueBV++xorBench :: Benchmark+xorBench = env setup $ \m ->+  bench "xor WORD_SIZE_IN_BITS" $ nf (apSwapAp xor) m+  where+    setup = return (smallValue1,smallValue2)++xorBenchL :: Benchmark+xorBenchL = env setup $ \m ->+  bench "xor 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp xor) m+  where+    setup = return (largeValue1,largeValue2)++andBench :: Benchmark+andBench = env setup $ \m ->+  bench ".&. WORD_SIZE_IN_BITS" $ nf (apSwapAp (.&.)) m+  where+    setup = return (smallValue1,smallValue2)++andBenchL :: Benchmark+andBenchL = env setup $ \m ->+  bench ".&. 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (.&.)) m+  where+    setup = return (largeValue1,largeValue2)++orBench :: Benchmark+orBench = env setup $ \m ->+  bench ".|. WORD_SIZE_IN_BITS" $ nf (apSwapAp (.|.)) m+  where+    setup = return (smallValue1,smallValue2)++orBenchL :: Benchmark+orBenchL = env setup $ \m ->+  bench ".|. 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (.|.)) m+  where+    setup = return (largeValue1,largeValue2)++complementBench :: Benchmark+complementBench = env setup $ \m ->+  bench "complement WORD_SIZE_IN_BITS" $ nf complement m+  where+    setup = return smallValue1++complementBenchL :: Benchmark+complementBenchL = env setup $ \m ->+  bench "complement 3*WORD_SIZE_IN_BITS" $ nf complement m+  where+    setup = return largeValue1++unsigned8toWord8Bench :: Benchmark+unsigned8toWord8Bench = env setup $ \m ->+  bench "unsigned8toWord8 WORD_SIZE_IN_BITS" $ nf (bitCoerce :: Unsigned 8 -> Word8) m+  where+    setup = return smallValueW8++unsigned16toWord16Bench :: Benchmark+unsigned16toWord16Bench = env setup $ \m ->+  bench "unsigned16toWord16 WORD_SIZE_IN_BITS" $ nf (bitCoerce :: Unsigned 16 -> Word16) m+  where+    setup = return smallValueW16++unsigned32toWord32Bench :: Benchmark+unsigned32toWord32Bench = env setup $ \m ->+  bench "unsigned32toWord32 WORD_SIZE_IN_BITS" $ nf (bitCoerce :: Unsigned 32 -> Word32) m+  where+    setup = return smallValueW32++unsignedToWordBench :: Benchmark+unsignedToWordBench = env setup $ \m ->+  bench "unsignedToWord WORD_SIZE_IN_BITS" $ nf (bitCoerce :: Unsigned WORD_SIZE_IN_BITS -> Word) m+  where+    setup = return smallValue1
+ benchmarks/BenchVector.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-}+{-# LANGUAGE NoStarIsType #-}++{-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-}++#define WORD_SIZE_IN_BITS 64++module BenchVector (vectorBench) where++import Clash.Class.BitPack+import Clash.Promoted.Nat.Literals+import Clash.Sized.BitVector+import Clash.Sized.Vector+import Criterion                   (Benchmark, env, bench, nf, bgroup)+import Language.Haskell.TH.Syntax  (lift)+import Prelude                     hiding (replicate)++vectorBench :: Benchmark+vectorBench = bgroup "Vector"+  [ vectorPackBench+  , vectorUnpackBench+  ]++smallValue1 :: Vec 8 (BitVector 24)+smallValue1 = $(lift (replicate d8 (2^(16::Int)-10 :: BitVector 24)))+{-# INLINE smallValue1 #-}++smallValue2 :: BitVector 192+smallValue2 = $(lift (maxBound :: BitVector 192))+{-# INLINE smallValue2 #-}++vectorPackBench :: Benchmark+vectorPackBench = env setup $ \m ->+  bench "pack" $+  nf (pack :: Vec 8 (BitVector 24) -> BitVector 192) m+  where+    setup = return smallValue1++vectorUnpackBench :: Benchmark+vectorUnpackBench = env setup $ \m ->+  bench "unpack" $+  nf (unpack :: BitVector 192 -> Vec 8 (BitVector 24)) m+  where+    setup = return smallValue2
benchmarks/benchmark-main.hs view
@@ -2,50 +2,20 @@  import Criterion.Main -import qualified BenchBitVector as BV-import qualified BenchFixed     as F-import qualified BenchSigned    as S+import BenchRAM+import BenchBitVector+import BenchFixed+import BenchSigned+import BenchUnsigned+import BenchVector  main :: IO () main =   defaultMain-  [-    bgroup "BitVector"-        [ BV.addBench-        , BV.negateBench-        , BV.subBench-        , BV.multBench-        , BV.plusBench-        , BV.minusBench-        , BV.timesBench-        , BV.boundedAddBench-        , BV.boundedSubBench-        , BV.boundedMulBench-        , BV.msbBench-        , BV.msbBenchL-        , BV.appendBench-        , BV.appendBenchL-        , BV.splitBench-        , BV.splitBenchL-        ]-  , bgroup "Signed"-        [ S.fromIntegerBench-        , S.addBench-        , S.negateBench-        , S.absBench-        , S.subBench-        , S.multBench-        , S.plusBench-        , S.minusBench-        , S.timesBench-        , S.packBench-        , S.unpackBench-        ]-  , bgroup "Fixed"-        [ F.fromRationalBench-        , F.addBench-        , F.subBench-        , F.multBench-        , F.multBench_wrap-        ]+  [ ramBench+  , bitVectorBench+  , fixedBench+  , signedBench+  , unsignedBench+  , vectorBench   ]
clash-prelude.cabal view
@@ -1,6 +1,7 @@+Cabal-version:        2.2 Name:                 clash-prelude-Version:              1.0.1-Synopsis:             CAES Language for Synchronous Hardware - Prelude library+Version:              1.10.0+Synopsis:             Clash: a functional hardware description language - Prelude library Description:   Clash is a functional hardware description language that borrows both its   syntax and semantics from the functional programming language Haskell. The@@ -38,20 +39,26 @@     "Clash.Prelude" and "Clash.Explicit.Prelude" at the same time as they     have overlapping definitions.   .-  A preliminary version of a tutorial can be found in "Clash.Tutorial", for a-  general overview of the library you should however check out "Clash.Prelude".-  Some circuit examples can be found in "Clash.Examples".-Homepage:             http://www.clash-lang.org/-bug-reports:          http://github.com/clash-lang/clash-compiler/issues-License:              BSD2+  A preliminary version of a tutorial can be found at+  <https://docs.clash-lang.org/tutorial>, for a general overview of the library+  you should however check out "Clash.Prelude". Some circuit examples can be+  found in "Clash.Examples".+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. <devops@qbaylogic.com> Copyright:            Copyright © 2013-2016, University of Twente,                                   2016-2017, Myrtle Software Ltd,-                                  2017-2019, QBayLogic B.V., Google Inc.+                                  2017-2019, QBayLogic B.V., Google Inc.,+                                  2021-2026, QBayLogic B.V. Category:             Hardware Build-type:           Simple+tested-with:          GHC == 9.6.7,+                      GHC == 9.8.4,+                      GHC == 9.10.3,+                      GHC == 9.12.4  Extra-source-files:   README.md                       CHANGELOG.md@@ -59,13 +66,19 @@  extra-doc-files:      doc/*.svg -Cabal-version:        >=1.18-Tested-with:          GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1- source-repository head   type: git-  location: https://github.com/clash-lang/clash-prelude.git+  location: https://github.com/clash-lang/clash-compiler.git+  subdir: clash-prelude +flag large-tuples+  description:+    Generate instances for classes such as `NFDataX` and `BitPack` for tuples+    up to and including 62 elements - the GHC imposed maximum. Note that this+    greatly increases compile times for `clash-prelude`.+  default: False+  manual: True+ flag super-strict   description:     Use `deepseqX` (instead of `seqX`) in register-like constructs. This can@@ -75,12 +88,10 @@   default: False   manual: True -flag multiple-hidden+flag strict-mapSignal   description:-    Allow multiple hidden clocks, resets, and enables to be used. This is an-    experimental feature, possibly triggering confusing error messages. By-    default, it is enabled on development versions of Clash and disabled on-    releases.+    Use `seqX` in 'mapSignal#'. This can help to eliminate space leaks in long+    running simulations.   default: False   manual: True @@ -102,21 +113,55 @@   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+                      MagicHash+                      NoStarIsType+                      PolyKinds+                      PostfixOperators+                      ScopedTypeVariables+                      StandaloneDeriving+                      TupleSections+                      TypeApplications+                      TypeOperators+                      ViewPatterns+ Library+  import:             common-options   HS-Source-Dirs:     src -  default-language:   Haskell2010-  ghc-options:        -Wall -fexpose-all-unfoldings -fno-worker-wrapper+  ghc-options:        -Wall -Wcompat -fexpose-all-unfoldings -fno-worker-wrapper   CPP-Options:        -DCABAL +  if flag(large-tuples)+    CPP-Options: -DLARGE_TUPLES+   if flag(super-strict)     CPP-Options: -DCLASH_SUPER_STRICT -  if flag(multiple-hidden)-    CPP-Options: -DCLASH_MULTIPLE_HIDDEN+  if flag(strict-mapSignal)+    CPP-Options: -DCLASH_STRICT_MAPSIGNAL -  if flag(multiple-hidden)-    Exposed-modules:  Clash.Prelude.Synchronizer+  Autogen-Modules:    Paths_clash_prelude    Exposed-modules:    Clash.Annotations.TopEntity                       Clash.Annotations.Primitive@@ -125,8 +170,18 @@                       Clash.Annotations.BitRepresentation.Internal                       Clash.Annotations.BitRepresentation.Util                       Clash.Annotations.SynthesisAttributes+                      Clash.Annotations.TH +                      Clash.Class.AutoReg+                      Clash.Class.AutoReg.Internal                       Clash.Class.BitPack+                      Clash.Class.BitPack.BitIndex+                      Clash.Class.BitPack.BitReduction+                      Clash.Class.BitPack.Internal+                      Clash.Class.BitPack.Internal.TH+                      Clash.Class.Counter+                      Clash.Class.Counter.Internal+                      Clash.Class.Counter.TH                       Clash.Class.Exp                       Clash.Class.HasDomain                       Clash.Class.HasDomain.HasSingleDomain@@ -134,25 +189,36 @@                       Clash.Class.HasDomain.CodeGen                       Clash.Class.HasDomain.Common                       Clash.Class.Num+                      Clash.Class.NumConvert+                      Clash.Class.NumConvert.Internal.NumConvert+                      Clash.Class.NumConvert.Internal.MaybeNumConvert+                      Clash.Class.NumConvert.Internal.Canonical+                      Clash.Class.Parity                       Clash.Class.Resize                        Clash.Clocks-                      Clash.Clocks.Deriving                        Clash.Explicit.BlockRam+                      Clash.Explicit.BlockRam.Blob                       Clash.Explicit.BlockRam.File+                      Clash.Explicit.BlockRam.Internal+                      Clash.Explicit.BlockRam.Model                       Clash.Explicit.DDR                       Clash.Explicit.Mealy                       Clash.Explicit.Moore                       Clash.Explicit.RAM                       Clash.Explicit.ROM+                      Clash.Explicit.ROM.Blob                       Clash.Explicit.ROM.File                       Clash.Explicit.Prelude                       Clash.Explicit.Prelude.Safe+                      Clash.Explicit.Reset+                      Clash.Explicit.SimIO                       Clash.Explicit.Signal                       Clash.Explicit.Signal.Delayed                       Clash.Explicit.Synchronizer                       Clash.Explicit.Testbench+                      Clash.Explicit.Verification                        Clash.HaskellPrelude @@ -163,18 +229,23 @@                        Clash.Magic +                      Clash.Num.Erroring+                      Clash.Num.Overflowing+                      Clash.Num.Saturating+                      Clash.Num.Wrapping+                      Clash.Num.Zeroing+                       Clash.NamedTypes                        Clash.Prelude-                      Clash.Prelude.BitIndex-                      Clash.Prelude.BitReduction                       Clash.Prelude.BlockRam+                      Clash.Prelude.BlockRam.Blob                       Clash.Prelude.BlockRam.File-                      Clash.Prelude.DataFlow                       Clash.Prelude.Mealy                       Clash.Prelude.Moore                       Clash.Prelude.RAM                       Clash.Prelude.ROM+                      Clash.Prelude.ROM.Blob                       Clash.Prelude.ROM.File                       Clash.Prelude.Safe                       Clash.Prelude.Testbench@@ -202,89 +273,102 @@                       Clash.Sized.Signed                       Clash.Sized.Unsigned                       Clash.Sized.Vector+                      Clash.Sized.Vector.ToTuple+                      Clash.Sized.Vector.ToTuple.TH                        Clash.Sized.Internal.BitVector                       Clash.Sized.Internal.Index+                      Clash.Sized.Internal.Mod                       Clash.Sized.Internal.Signed                       Clash.Sized.Internal.Unsigned +                      Clash.Verification+                      Clash.Verification.DSL+                      Clash.Verification.Internal+                       Clash.XException+                      Clash.XException.Internal+                      Clash.XException.MaybeX+                      Clash.XException.TH                        Clash.Xilinx.ClockGen                       Clash.Xilinx.DDR                        Clash.Tutorial                       Clash.Examples+                      Clash.Examples.Internal -  other-modules:      Clash.Class.BitPack.Internal+  other-modules:+                      Clash.Class.AutoReg.Instances+                      Clash.Clocks.Internal                       Clash.CPP                       Clash.Signal.Bundle.Internal+                      Clash.Sized.Internal                       Language.Haskell.TH.Compat                       Paths_clash_prelude    other-extensions:   CPP-                      BangPatterns                       ConstraintKinds-                      DataKinds-                      DefaultSignatures-                      DeriveDataTypeable-                      DeriveTraversable-                      DeriveLift                       FlexibleContexts                       FlexibleInstances                       GADTs                       GeneralizedNewtypeDeriving-                      InstanceSigs-                      KindSignatures-                      MagicHash                       MultiParamTypeClasses                       PatternSynonyms-                      Rank2Types-                      ScopedTypeVariables-                      StandaloneDeriving+                      RankNTypes                       TemplateHaskell-                      TupleSections-                      TypeApplications                       TypeFamilies-                      TypeOperators                       UndecidableInstances-                      ViewPatterns -  Build-depends:      array                     >= 0.5.1.0 && < 0.6,-                      base                      >= 4.10    && < 5,-                      bifunctors                >= 5.4.0   && < 6.0,+  Build-depends:      adjunctions               >= 4.0     && < 5.0,+                      array                     >= 0.5.1.0 && < 0.6,+                      arrows                    >= 0.4     && < 0.5,+                      base                      >= 4.18    && < 5,                       binary                    >= 0.8.5   && < 0.11,-                      bytestring                >= 0.10.8  && < 0.11,+                      bytestring                >= 0.10.8  && < 0.13,                       constraints               >= 0.9     && < 1.0,-                      containers                >= 0.4.0   && < 0.7,+                      containers                >= 0.4.0   && < 0.9,                       data-binary-ieee754       >= 0.4.4   && < 0.6,-                      data-default-class        >= 0.1.2   && < 0.2,-                      integer-gmp               >= 0.5.1.0 && < 1.1,-                      deepseq                   >= 1.4.1.0 && < 1.5,-                      ghc-prim                  >= 0.5.1.0 && < 0.6,-                      ghc-typelits-extra        >= 0.3.1   && < 0.4,-                      ghc-typelits-knownnat     >= 0.6     && < 0.8,-                      ghc-typelits-natnormalise >= 0.6     && < 0.8,-                      hashable                  >= 1.2.1.0  && < 1.4,+                      data-default              >= 0.7     && < 0.9,+                      deepseq                   >= 1.4.1.0 && < 1.6,+                      distributive              >= 0.1     && < 1.0,+                      extra                     >= 1.6.17  && < 1.9,+                      ghc-bignum                >= 1.0     && < 1.4,+                      ghc-prim                  >= 0.5.1.0 && < 0.14,+                      ghc-typelits-extra        >= 0.5.3   && < 0.6,+                      ghc-typelits-knownnat     >= 0.8.3   && < 0.9,+                      ghc-typelits-natnormalise >= 0.9.5   && < 0.10,+                      hashable                  >= 1.2.1.0  && < 1.6,                       half                      >= 0.2.2.3 && < 1.0,-                      lens                      >= 4.9     && < 4.19,-                      QuickCheck                >= 2.7     && < 2.14,+                      infinite-list           ^>= 0.1,+                      lens                      >= 4.10    && < 5.4,+                      QuickCheck                >= 2.7     && < 2.16,+                      recursion-schemes         >= 5.1     && < 5.3,                       reflection                >= 2       && < 2.2,-                      singletons                >= 1.0     && < 3.0,-                      template-haskell          >= 2.12.0.0 && < 2.16,+                      singletons                >= 2.0     && < 3.1,+                      string-interpolate        ^>= 0.3,+                      tagged                    >= 0.8     && < 0.9,+                      template-haskell          >= 2.20.0.0 && < 2.24,+                      th-abstraction            >= 0.3.0 && < 0.8.0,                       th-lift                   >= 0.7.0    && < 0.9,                       th-orphans                >= 0.13.1   && < 1.0,-                      text                      >= 0.11.3.1 && < 1.3,-                      time                      >= 1.8     && < 1.10,-                      transformers              >= 0.5.2.0 && < 0.6,+                      text                      >= 0.11.3.1 && < 2.2,+                      time                      >= 1.8     && < 1.15,+                      transformers              >= 0.5.2.0 && < 0.7,                       type-errors               >= 0.2.0.0 && < 0.3,-                      vector                    >= 0.11    && < 1.0+                      uniplate                  >= 1.6.12  && < 1.7,+                      vector                    >= 0.11    && < 1.0,+                      mtl                       >= 2.0     && < 3.0+  -- Depend on GHC to obtain the maximum tuple size via+  -- import GHC.Settings.Constants (mAX_TUPLE_SIZE)+  if flag(large-tuples)+    Build-Depends:    ghc                       >= 9.6.0 && < 9.13  test-suite doctests   type:             exitcode-stdio-1.0   default-language: Haskell2010   main-is:          doctests.hs-  ghc-options:      -Wall -threaded+  ghc-options:      -Wall -Wcompat -threaded   hs-source-dirs:   tests    if !flag(doctests)@@ -292,17 +376,25 @@   else     build-depends:       base,-      doctest >= 0.9.1 && < 0.17,-      clash-prelude-  if impl(ghc >= 8.6)-    build-depends:-      doctest >= 0.16.1+      clash-prelude,+      doctest-parallel >= 0.3.1 && < 0.5,+      filepath +  if arch(x86_64) && flag(workaround-ghc-mmap-crash)+    ghc-options:    -with-rtsopts=-xm20000000++ test-suite unittests+  import:           common-options   type:             exitcode-stdio-1.0-  default-language: Haskell2010   main-is:          unittests.hs-  ghc-options:      -Wall+  ghc-options:      -Wall -Wcompat -threaded+  -- Note that multiple -with-rtsopts are not cumulative+  if arch(x86_64) && flag(workaround-ghc-mmap-crash)+    ghc-options:    "-with-rtsopts=-N -xm20000000"+  else+    ghc-options:    -with-rtsopts=-N+   hs-source-dirs:   tests    if !flag(unittests)@@ -312,20 +404,67 @@       clash-prelude,        ghc-typelits-knownnat,+      ghc-typelits-natnormalise,+      ghc-typelits-extra,        base,+      binary,+      bytestring,+      containers,+      deepseq,+      hedgehog      >= 1.0.3    && < 1.6,       hint          >= 0.7      && < 0.10,-      tasty         >= 1.2      && < 1.3,-      tasty-hunit+      mmorph        >= 1.1.5    && < 1.3,+      quickcheck-classes-base >= 0.6 && < 1.0,+      tasty         >= 1.2      && < 1.6,+      tasty-hedgehog >= 1.2.0,+      tasty-hunit,+      tasty-th,+      tasty-quickcheck,+      template-haskell,+      text -  Other-Modules: Clash.Tests.BitPack+  Other-Modules:+                 Clash.Tests.AsyncFIFOSynchronizer+                 Clash.Tests.AutoReg+                 Clash.Tests.BitPack                  Clash.Tests.BitVector+                 Clash.Tests.BlockRam+                 Clash.Tests.BlockRam.Blob+                 Clash.Tests.Clocks+                 Clash.Tests.Counter+                 Clash.Tests.DumpVCD+                 Clash.Tests.NumConvert                  Clash.Tests.DerivingDataRepr                  Clash.Tests.DerivingDataReprTypes-                 Clash.Tests.Signal+                 Clash.Tests.Fixed+                 Clash.Tests.FixedExhaustive+                 Clash.Tests.Index+                 Clash.Tests.MaybeNumConvert+                 Clash.Tests.MaybeX                  Clash.Tests.NFDataX+                 Clash.Tests.NumNewtypes+                 Clash.Tests.Ram+                 Clash.Tests.Reset+                 Clash.Tests.Resize+                 Clash.Tests.Signal+                 Clash.Tests.Signed+                 Clash.Tests.SizedNum+                 Clash.Tests.TopEntityGeneration+                 Clash.Tests.Unsigned+                 Clash.Tests.Vector+                 Clash.Tests.XException +                 Clash.Tests.Laws.Enum+                 Clash.Tests.Laws.Num+                 Clash.Tests.Laws.SaturatingNum +                 Hedgehog.Extra++                 Test.Tasty.HUnit.Extra+                 Test.Tasty.Hedgehog.Extra+                 Test.QuickCheck.Extra+ benchmark benchmark-clash-prelude   type:             exitcode-stdio-1.0   default-language: Haskell2010@@ -333,16 +472,23 @@   ghc-options:      -O2 -Wall   hs-source-dirs:   benchmarks +  ghc-options:      -with-rtsopts=-T+   if !flag(benchmarks)     buildable: False   else     build-depends:       base,       clash-prelude,-      criterion         >= 1.3.0.0 && < 1.6,+      criterion         >= 1.3.0.0 && < 1.7,+      directory,       deepseq,       template-haskell    Other-Modules:    BenchBitVector+                    BenchCommon                     BenchFixed+                    BenchRAM                     BenchSigned+                    BenchUnsigned+                    BenchVector
+ doc/scanlPar.svg view
@@ -0,0 +1,122 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg version="1.1" xmlns:xl="http://www.w3.org/1999/xlink" xmlns:dc="http://purl.org/dc/elements/1.1/" xmlns="http://www.w3.org/2000/svg" viewBox="219 175.5 192.5075 238.23173" width="192.5075" height="238.23173">+  <defs>+    <marker orient="auto" overflow="visible" markerUnits="strokeWidth" id="FilledArrow_Marker" stroke-linejoin="miter" stroke-miterlimit="10" viewBox="-1 -4 10 8" markerWidth="10" markerHeight="8" color="black">+      <g>+        <path d="M 8 0 L 0 -3 L 0 3 Z" fill="currentColor" stroke="currentColor" stroke-width="1"/>+      </g>+    </marker>+  </defs>+  <g id="Canvas_1" stroke="none" stroke-dasharray="none" stroke-opacity="1" fill="none" fill-opacity="1">+    <title>Canvas 1</title>+    <rect fill="white" x="219" y="175.5" width="192.5075" height="238.23173"/>+    <g id="Canvas_1_Layer_1">+      <title>Layer 1</title>+      <g id="Graphic_6">+        <path d="M 296.5717 223.9904 L 264.4283 223.9904 C 261.66686 223.9904 259.42828 226.22897 259.42828 228.9904 L 259.42828 261.13382 C 259.42828 263.89524 261.66686 266.13382 264.4283 266.13382 L 296.5717 266.13382 C 299.33314 266.13382 301.5717 263.89524 301.5717 261.13382 L 301.5717 228.9904 C 301.5717 226.22897 299.33314 223.9904 296.5717 223.9904 Z" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Graphic_5">+        <text transform="translate(221.09912 178.5)" fill="black">+          <tspan font-family="Courier" font-size="9" fill="black" x="0" y="9">x0</tspan>+        </text>+      </g>+      <g id="Graphic_4">+        <text transform="translate(277.89868 239.5621)" fill="black">+          <tspan font-family="Courier" font-size="9" fill="black" x="0" y="9">f</tspan>+        </text>+      </g>+      <g id="Graphic_10">+        <text transform="translate(275.09912 178.5)" fill="black">+          <tspan font-family="Courier" font-size="9" fill="black" x="0" y="9">x1</tspan>+        </text>+      </g>+      <g id="Graphic_16">+        <text transform="translate(328.817 177.5)" fill="black">+          <tspan font-family="Courier" font-size="9" fill="black" x="0" y="9">x2</tspan>+        </text>+      </g>+      <g id="Graphic_22">+        <text transform="translate(382.5349 178.5)" fill="black">+          <tspan font-family="Courier" font-size="9" fill="black" x="0" y="9">x3</tspan>+        </text>+      </g>+      <g id="Line_32">+        <line x1="280.5" y1="189.5" x2="280.50002" y2="223.9904" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Graphic_44">+        <path d="M 404.0075 223.9904 L 371.86407 223.9904 C 369.10265 223.9904 366.86407 226.22897 366.86407 228.9904 L 366.86407 261.13382 C 366.86407 263.89524 369.10265 266.13382 371.86407 266.13382 L 404.0075 266.13382 C 406.76893 266.13382 409.0075 263.89524 409.0075 261.13382 L 409.0075 228.9904 C 409.0075 226.22897 406.76893 223.9904 404.0075 223.9904 Z" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Graphic_43">+        <text transform="translate(385.33447 239.5621)" fill="black">+          <tspan font-family="Courier" font-size="9" fill="black" x="0" y="9">f</tspan>+        </text>+      </g>+      <g id="Line_45">+        <line x1="387.9358" y1="189.5" x2="387.9358" y2="223.9904" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Graphic_54">+        <path d="M 350.2896 290.9 L 318.14618 290.9 C 315.38475 290.9 313.14618 293.1386 313.14618 295.9 L 313.14618 328.04344 C 313.14618 330.80486 315.38475 333.04344 318.14618 333.04344 L 350.2896 333.04344 C 353.05103 333.04344 355.2896 330.80486 355.2896 328.04344 L 355.2896 295.9 C 355.2896 293.1386 353.05103 290.9 350.2896 290.9 Z" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Graphic_53">+        <text transform="translate(331.51745 306.47172)" fill="black">+          <tspan font-family="Courier" font-size="9" fill="black" x="0" y="9">f</tspan>+        </text>+      </g>+      <g id="Line_57">+        <line x1="334.2179" y1="188.5" x2="334.2179" y2="290.9" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_58">+        <line x1="280.50002" y1="266.13382" x2="313.14618" y2="311.9717" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_59">+        <line x1="337.11103" y1="188.5" x2="366.86407" y2="245.0621" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_60">+        <line x1="229.46592" y1="189.5" x2="259.42828" y2="245.0621" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Graphic_62">+        <path d="M 404.0075 352.3 L 371.86407 352.3 C 369.10265 352.3 366.86407 354.5386 366.86407 357.3 L 366.86407 389.44344 C 366.86407 392.20486 369.10265 394.44344 371.86407 394.44344 L 404.0075 394.44344 C 406.76893 394.44344 409.0075 392.20486 409.0075 389.44344 L 409.0075 357.3 C 409.0075 354.5386 406.76893 352.3 404.0075 352.3 Z" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Graphic_61">+        <text transform="translate(385.33447 367.87172)" fill="black">+          <tspan font-family="Courier" font-size="9" fill="black" x="0" y="9">f</tspan>+        </text>+      </g>+      <g id="Line_64">+        <line x1="387.9358" y1="266.13382" x2="387.9358" y2="352.3" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_65">+        <line x1="334.2179" y1="333.04344" x2="366.86407" y2="373.3717" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_69">+        <line x1="387.5349" y1="394.4435" x2="387.5349" y2="401.05173" marker-end="url(#FilledArrow_Marker)" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_74">+        <line x1="334.2179" y1="333.04344" x2="333.78143" y2="401.05193" marker-end="url(#FilledArrow_Marker)" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_75">+        <line x1="280.50002" y1="266.13382" x2="280.03418" y2="401.0518" marker-end="url(#FilledArrow_Marker)" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_78">+        <line x1="387.8149" y1="394.7235" x2="387.8149" y2="401.33173" marker-end="url(#FilledArrow_Marker)" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_80">+        <line x1="226.2908" y1="190.02326" x2="226.5296" y2="401.0535" marker-end="url(#FilledArrow_Marker)" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_82">+        <line x1="226.2908" y1="190.02326" x2="226.2908" y2="199.4823" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_83"/>+      <g id="Line_86"/>+      <g id="Line_91"/>+      <g id="Line_97">+        <line x1="337.11103" y1="188.5" x2="337.21555" y2="188.6987" marker-end="url(#FilledArrow_Marker)" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_98">+        <line x1="229.46592" y1="189.5" x2="229.52266" y2="189.60521" marker-end="url(#FilledArrow_Marker)" stroke="black" stroke-linecap="round" stroke-linejoin="round" stroke-width="1"/>+      </g>+      <g id="Line_99"/>+    </g>+  </g>+</svg>
src/Clash/Annotations/BitRepresentation.hs view
@@ -8,12 +8,8 @@  -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE DeriveLift         #-}-{-# LANGUAGE RankNTypes         #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}  {-# OPTIONS_GHC -Wno-orphans #-} @@ -33,7 +29,9 @@  ) where  import           Data.Data                  (Data)+#if __GLASGOW_HASKELL__ <= 910 import           Data.Typeable              (Typeable)+#endif import           Language.Haskell.TH.Instances () import qualified Language.Haskell.TH.Lift   () import qualified Language.Haskell.TH.Syntax as TH@@ -43,6 +41,7 @@ type Value    = Integer type Size     = Int +-- | BitMask used to mask fields type FieldAnn = BitMask  -- | Lift values inside of 'TH.Q' to a Template Haskell expression@@ -71,12 +70,12 @@ -- -- @ -- data Color = R | G | B--- {-# ANN module (DataReprAnn---                   $(liftQ [t|Color|])+-- {-# ANN module ('DataReprAnn'+--                   $('liftQ' [t|Color|]) --                   2---                   [ ConstrRepr 'R 0b11 0b00 []---                   , ConstrRepr 'G 0b11 0b01 []---                   , ConstrRepr 'B 0b11 0b10 []+--                   [ 'ConstrRepr' 'R 0b11 0b00 []+--                   , 'ConstrRepr' 'G 0b11 0b01 []+--                   , 'ConstrRepr' 'B 0b11 0b10 [] --                   ]) #-} -- @ --@@ -88,11 +87,11 @@ -- Or if we want to annotate @Maybe Color@: -- -- @--- {-# ANN module ( DataReprAnn---                    $(liftQ [t|Maybe Color|])+-- {-# ANN module ( 'DataReprAnn'+--                    $('liftQ' [t|Maybe Color|]) --                    2---                    [ ConstrRepr 'Nothing 0b11 0b11 []---                    , ConstrRepr 'Just 0b00 0b00 [0b11]+--                    [ 'ConstrRepr' 'Nothing 0b11 0b11 []+--                    , 'ConstrRepr' 'Just 0b00 0b00 [0b11] --                    ] ) #-} -- @ --@@ -105,6 +104,9 @@ -- underlying @Color@ field of @Just@ by passing /[0b11]/ to ConstrRepr. This -- indicates that the first field is encoded in the first and second bit of the -- whole datatype (0b11).+--+-- __NB__: BitPack for a custom encoding can be derived using+-- 'Clash.Annotations.BitRepresentation.Deriving.deriveBitPack'. data DataReprAnn =   DataReprAnn     -- Type this annotation is for:@@ -113,7 +115,10 @@     Size     -- Constructors:     [ConstrRepr]-      deriving (Show, Data, Typeable, Eq, Generic, TH.Lift)+      deriving (Show, Data, Eq, Generic, TH.Lift)+#if __GLASGOW_HASKELL__ <= 910+      deriving Typeable+#endif  -- | Annotation for constructors. Indicates how to match this constructor based -- off of the whole datatype.@@ -127,4 +132,7 @@     Value     -- Masks for fields. Indicates where fields are stored:     [FieldAnn]-      deriving (Show, Data, Typeable, Eq, Generic, TH.Lift)+      deriving (Show, Data, Eq, Generic, TH.Lift)+#if __GLASGOW_HASKELL__ <= 910+      deriving Typeable+#endif
src/Clash/Annotations/BitRepresentation/Deriving.hs view
@@ -1,7 +1,9 @@ {-|-Copyright  :  (C) 2018, Google Inc.+Copyright  :  (C) 2018, Google Inc.,+                  2022, QBayLogic B.V.+                  2022, LUMI GUIDE FIETSDETECTIE B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  This module contains: @@ -13,23 +15,13 @@     e.g. one-hot, for a data type.  -}-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DataKinds          #-}-{-# LANGUAGE DeriveAnyClass     #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE DeriveLift         #-}-{-# LANGUAGE LambdaCase         #-}-{-# LANGUAGE MagicHash          #-}-{-# LANGUAGE MultiWayIf         #-}-{-# LANGUAGE QuasiQuotes        #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell    #-}-{-# LANGUAGE ViewPatterns       #-}---- See: https://ghc.haskell.org/trac/ghc/ticket/14959. TODO: Consider putting--- the offending function (bitsToInteger') in a separate module.-{-# OPTIONS_GHC -O0 #-}+{-# LANGUAGE TemplateHaskell #-}  module Clash.Annotations.BitRepresentation.Deriving   (@@ -65,31 +57,37 @@ import qualified Clash.Annotations.BitRepresentation.Util   as Util +import           Clash.Annotations.Primitive  (hasBlackBox) import           Clash.Class.BitPack   (BitPack, BitSize, pack, packXWith, unpack)-import           Clash.Class.Resize         (resize)-import           Language.Haskell.TH.Compat (mkTySynInstD)-import           Clash.Sized.BitVector      (BitVector, low, (++#))+import           Clash.Class.Resize           (resize)+import           Language.Haskell.TH.Compat   (mkTySynInstD)+import           Clash.Sized.BitVector        (BitVector, low, (++#)) import           Clash.Sized.Internal.BitVector (undefined#)-import           Control.DeepSeq            (NFData)-import           Control.Monad              (forM)+import           Control.Applicative          (liftA3)+import           Control.DeepSeq              (NFData)+import           Control.Monad                (forM) import           Data.Bits   (shiftL, shiftR, complement, (.&.), (.|.), zeroBits, popCount, bit, testBit,    Bits, setBit)-import           Data.Data                  (Data)+import           Data.Data                    (Data)+import           Data.Containers.ListUtils    (nubOrd) import           Data.List-  (mapAccumL, zipWith4, sortOn, partition)-import           Data.Typeable              (Typeable)-import qualified Data.Map                   as Map-import           Data.Maybe                 (fromMaybe)-import qualified Data.Set                   as Set-import           Data.Proxy                 (Proxy(..))-import           GHC.Exts                   (Int(I#))-import           GHC.Generics               (Generic)-import           GHC.Integer.Logarithms     (integerLog2#)-import           GHC.TypeLits               (natVal)+  (mapAccumL, zipWith4, sortOn, partition, uncons)+#if __GLASGOW_HASKELL__ < 912+import           Data.Typeable                (Typeable)+#endif+import qualified Data.Map                     as Map+import           Data.Maybe                   (fromMaybe)+import qualified Data.Set                     as Set+import           Data.Proxy                   (Proxy(..))+import           GHC.Exts                     (Int(I#))+import           GHC.Generics                 (Generic)+import           GHC.Integer.Logarithms       (integerLog2#)+import           GHC.TypeLits                 (natVal) import           Language.Haskell.TH import           Language.Haskell.TH.Syntax+import           Language.Haskell.TH.Datatype (resolveTypeSynonyms)  -- | Used to track constructor bits in packed derivation data BitMaskOrigin@@ -97,7 +95,10 @@   -- ^ Constructor bit should be stored externally   | Embedded BitMask Value   -- ^ Constructor bit should be stored in one of the constructor's fields-    deriving (Show, Data, Typeable, Lift)+    deriving (Show, Data, Lift)+#if __GLASGOW_HASKELL__ < 912+    deriving (Typeable)+#endif  isExternal :: BitMaskOrigin -> Bool isExternal External = True@@ -166,9 +167,9 @@ bitsNeeded :: Integer -> Int bitsNeeded = integerLog2Ceil -tyVarBndrName :: TyVarBndr -> Name-tyVarBndrName (PlainTV n) = n-tyVarBndrName (KindedTV n _k) = n+tyVarBndrName :: TyVarBndr f -> Name+tyVarBndrName (PlainTV n _f) = n+tyVarBndrName (KindedTV n _f _k) = n  -- | Replace Vars types given in mapping resolve :: NameMap -> Type -> Type@@ -182,6 +183,10 @@ resolveCon :: NameMap -> Con -> Con resolveCon nmap (NormalC t (unzip -> (bangs, fTypes))) =   NormalC t $ zip bangs $ map (resolve nmap) fTypes+resolveCon nmap (RecC t (unzip3 -> (name, bangs, fTypes))) =+  RecC t $ zip3 name bangs $ map (resolve nmap) fTypes+resolveCon nmap (InfixC (leftB, leftTy) t (rightB, rightTy)) =+  InfixC (leftB, resolve nmap leftTy) t (rightB, resolve nmap rightTy) resolveCon _name constr =   error $ "Unexpected constructor: " ++ show constr @@ -201,19 +206,15 @@   bitSizeInstances <- reifyInstances ''BitSize [typ]   case bitSizeInstances of     [] ->-      error $ unwords [+      fail $ unwords [           "Could not find custom bit representation nor BitSize instance"         , "for", show typ ++ "." ]-#if MIN_VERSION_template_haskell(2,15,0)     [TySynInstD (TySynEqn _ _ (LitT (NumTyLit n)))] ->-#else-    [TySynInstD _ (TySynEqn _ (LitT (NumTyLit n)))] ->-#endif       [| n |]     [_impl] ->       [| fromIntegral $ natVal (Proxy :: Proxy (BitSize $(return typ))) |]     unexp ->-      error $ "Unexpected result from reifyInstances: " ++ show unexp+      fail $ "Unexpected result from reifyInstances: " ++ show unexp  -- | Generate bitmask from a given bit, with a certain size bitmask@@ -247,12 +248,24 @@   InfixC _ nm _ -> nm   _ -> error $ "No GADT support" -constrFieldSizes-  :: Con-  -> (Name, [Q Exp])-constrFieldSizes con = do-  (conName con, map typeSize $ fieldTypes con)+mkLet :: String -> Q Exp -> (Q Dec, Q Exp)+mkLet nm qe = do+  let nm' = mkName nm+  (valD (varP nm') (normalB qe) [], varE nm') +fieldSizeLets :: [[Type]] -> ([Q Dec], [[Q Exp]])+fieldSizeLets fieldtypess = (fieldSizeDecls, fieldSizessExps)+  where+    nums = map show [(0 :: Int)..]+    uqFieldTypes = nubOrd (concat fieldtypess)+    uqFieldSizes = map typeSize uqFieldTypes+    (fieldSizeDecls, szVars) = unzip $ zipWith+                                 (\i sz -> mkLet ("_f" ++ i) sz)+                                 nums+                                 uqFieldSizes+    tySizeMap = Map.fromList (zip uqFieldTypes szVars)+    fieldSizessExps = map (map (tySizeMap Map.!)) fieldtypess+ complementInteger :: Int -> Integer -> Integer complementInteger 0 _i = 0 complementInteger size i =@@ -303,101 +316,145 @@   where     values = [shiftL 1 n | n <- ns] -overlapFieldAnnsL :: [[Q Exp]] -> [[Q Exp]]-overlapFieldAnnsL fieldSizess = map go fieldSizess+overlapFieldAnnsL :: [[Q Exp]] -> ([Q Dec], [[Q Exp]])+overlapFieldAnnsL fieldSizess = ([maxDecl],  resExp)   where-    fieldSizess'  = listE $ map listE fieldSizess-    constructorSizes = [| map sum $fieldSizess' |]-    go fieldSizes =+    (maxDecl, maxExp) = mkLet "_maxf" maxConstrSize+    resExp = map go fieldSizess+    fieldSizess' = listE $ map listE fieldSizess+    constructorSizes = [| map (sum @[] @Int) $fieldSizess' |]+    maxConstrSize = [| maximum $constructorSizes - 1 |]+    go fieldsizes =       snd $       mapAccumL         (\start size -> ([| $start - $size |], [| bitmask $start $size |]))-        [| maximum $constructorSizes - 1 |]-        fieldSizes+        maxExp+        fieldsizes -overlapFieldAnnsR :: [[Q Exp]] -> [[Q Exp]]-overlapFieldAnnsR fieldSizess = map go fieldSizess+overlapFieldAnnsR :: [[Q Exp]] -> ([Q Dec], [[Q Exp]])+overlapFieldAnnsR fieldSizess = (sumFieldDecl, resExp)   where-    fieldSizess'  = listE $ map listE fieldSizess-    constructorSizes = [| map sum $fieldSizess' |]-    go fieldSizes =+    resExp = zipWith go fieldSizess sumFieldExp++    nums = map show [(0 :: Int) ..]++    (sumFieldDecl, sumFieldExp)+      = unzip $ zipWith+          (\fs i -> mkLet ("_sumf" ++ i) [|sum @[] @Int $(listE fs)|])+          fieldSizess+          nums++    go fieldSizes sumFieldsSize =       snd $       mapAccumL         (\start size -> ([| $start - $size |], [| bitmask $start $size |]))-        [| maximum $constructorSizes - (maximum $constructorSizes - sum $(listE fieldSizes)) - 1 |]+        [| $sumFieldsSize - 1 |]         fieldSizes -wideFieldAnns :: [[Q Exp]] -> [[Q Exp]]-wideFieldAnns fieldSizess = zipWith id (map go constructorOffsets) fieldSizess+wideFieldAnns :: [[Q Exp]] -> ([Q Dec], [[Q Exp]])+wideFieldAnns fieldSizess = (decs, resExp)   where-    constructorSizes =-      map (AppE (VarE 'sum) <$>) (map listE fieldSizess)+    decs = (dataSizeDec:constrSizeDecs) ++ constrOffsetDecs+    resExp = zipWith id (map go constrOffsetsExps) fieldSizess+    nums = map show [(0 :: Int) ..] -    constructorOffsets :: [Q Exp]-    constructorOffsets =-      init $-      scanl-        (\offset size -> [| $offset + $size |])-        [| 0 |]-        constructorSizes+    constrSizeExps :: [Q Exp]+    (constrSizeDecs, constrSizeExps)+      = unzip $ zipWith+          (\fs i -> mkLet ("_sumf" ++ i) [|sum @[] @Int $(listE fs)|])+          fieldSizess+          nums -    dataSize = [| sum $(listE constructorSizes) |]+    constrOffsetsExps :: [Q Exp]+    (last -> constrOffsetDecs, constrOffsetsExps) =+      unzip $ init $ scanl+        (\(ds, offset) (size, i) ->+          let e = [| $offset + $size |]+              (d, ve) = mkLet ("_constroffset" ++ i) e+          in (d:ds, ve)+        )+        ([], [| 0 |])+        (zip constrSizeExps nums) +    dataSizeExp :: Q Exp+    (dataSizeDec, dataSizeExp)+      = mkLet "_widedatasize" [| sum @[] @Int $(listE constrSizeExps) - 1 |]     go :: Q Exp -> [Q Exp] -> [Q Exp]     go offset fieldSizes =       snd $       mapAccumL         (\start size -> ([| $start - $size |], [| bitmask $start $size |]))-        [| $dataSize - 1 - $offset |]+        [| $dataSizeExp - $offset |]         fieldSizes  -- | Derive DataRepr' for a specific type. deriveDataRepr   :: ([Int] -> [(BitMask, Value)])   -- ^ Constructor derivator-  -> ([[Q Exp]] -> [[Q Exp]])+  -> ([[Q Exp]] -> ([Q Dec], [[Q Exp]]) )   -- ^ Field derivator   -> Derivator deriveDataRepr constrDerivator fieldsDerivator typ = do+  let (fun, typeArgs) = collectTypeArgs typ+      tyConstrName = case fun of+        ConT t -> t+        _ -> error ("deriveDataRep: expecting type constructor, but got: " <> show fun)   info <- reify tyConstrName   case info of     (TyConI (DataD [] _constrName vars _kind dConstructors _clauses)) ->       let varMap = Map.fromList $ zip (map tyVarBndrName vars) typeArgs in       let resolvedConstructors = map (resolveCon varMap) dConstructors in do+      let nums = map show [(0 :: Int)..]+      let fieldtypess = map fieldTypes resolvedConstructors +      let (fieldSzDecs, fieldSizess) = fieldSizeLets fieldtypess+       -- Get sizes and names of all constructors-      let-        (constrNames, fieldSizess) =-          unzip $ map constrFieldSizes resolvedConstructors+      let constrNames = map conName resolvedConstructors        let         (constrMasks, constrValues) =           unzip $ constrDerivator [0..length dConstructors - 1] -      let constrSize    = 1 + (msb $ maximum constrMasks)-      let fieldAnns     = fieldsDerivator fieldSizess-      let fieldAnnsFlat = listE $ concat fieldAnns+      let constrSize = 1 + (msb $ maximum @[] @Integer constrMasks)+      let (fieldDecs, fieldAnns) = fieldsDerivator fieldSizess +      -- extract field annotations into declarations+      let mkAnnDecl i j an = mkLet ("_fa" ++ i ++ "_" ++ j) an+      let+        fieldAnnTup =+          zipWith (\i -> zipWith (mkAnnDecl i) nums) nums fieldAnns++      let+        (fieldAnnDecs, fieldAnnVars) =+          (concat $ map (map fst) fieldAnnTup, map (map snd) fieldAnnTup)++      let fieldAnnsFlat = listE $ concat fieldAnnVars+       let dataSize | null $ concat fieldAnns = [| 0 |]-                   | otherwise = [| 1 + (msb $ maximum $ $fieldAnnsFlat) |]+                   | otherwise = [| 1 + (msb $ maximum @[] @Integer $ $fieldAnnsFlat) |] +      -- Extract data size into a declaration+      let (dataSizeDec, dataSizeExp) = mkLet "_datasize" dataSize++      let decls = (dataSizeDec:fieldSzDecs) ++ fieldDecs ++ fieldAnnDecs+       -- Determine at which bits various fields start       let constrReprs = zipWith4-                          (buildConstrRepr dataSize)+                          (buildConstrRepr dataSizeExp)                           constrNames-                          fieldAnns+                          fieldAnnVars                           constrMasks                           constrValues -      [| DataReprAnn-          $(liftQ $ return typ)-          ($dataSize + constrSize)+      resolvedType <- resolveTypeSynonyms typ++      letE decls [| DataReprAnn+          $(liftQ $ return resolvedType)+          ($dataSizeExp + constrSize)           $(listE constrReprs) |]     _ ->-      error $ "Could not derive dataRepr for: " ++ show info--    where-      (ConT tyConstrName, typeArgs) = collectTypeArgs typ+      fail $ "Could not derive dataRepr for: " ++ show info  -- | Simple derivators change the (default) way Clash stores data types. It -- assumes no overlap between constructors and fields.@@ -495,19 +552,19 @@   | H `elem` xs'                 = [[L]]   | otherwise                    = [[H]]   where-    xs' = map head xs+    xs' = map (maybe (error "complementValues: expected at least 1 bit") fst . uncons) xs complementValues size [] = [replicate size U] complementValues size values =-  if | all (==U) (map head values') -> map (U:) (recc (map tail values'))-     | any (==X) (map head values') -> map (X:) (recc (map tail values'))+  if | all (maybe False ((==U) . fst) . uncons) values' -> map (U:) (recc (map (drop 1) values'))+     | any (maybe False ((==X) . fst) . uncons) values' -> map (X:) (recc (map (drop 1) values'))      | otherwise ->-        (map (L:) (recc (map tail lows))) ++-        (map (H:) (recc (map tail highs')))+        (map (L:) (recc (map (drop 1) lows))) +++        (map (H:) (recc (map (drop 1) highs')))   where     values'       = filter (any (/= U)) values     recc          = complementValues (size - 1)-    (highs, lows) = partition ((== H) . head) values'-    highs'        = highs ++ filter ((`elem` [X, U]) . head) values'+    (highs, lows) = partition (maybe False ((== H) . fst) . uncons) values'+    highs'        = highs ++ filter (maybe False ((`elem` [X, U]) . fst) . uncons) values'  -- | Generate all bitvalues the given type can assume. possibleValues@@ -516,9 +573,10 @@   -> Size   -> Q [[Bit']] possibleValues typeMap typ size =-  let (ConT typeName, _typeArgs) = collectTypeArgs typ in--  case Map.lookup typ typeMap of+  let typeName = case fst (collectTypeArgs typ) of+        ConT t -> t+        fun -> error ("possibleValues: expected a type constructor, but got" <> show fun)+  in case Map.lookup typ typeMap of     -- No custom data representation found.     Nothing -> do       info <- reify typeName@@ -572,18 +630,20 @@ packedMaybeDerivator (DataReprAnn _ size _) typ =   case maybeCon of     ConT nm ->-      if nm == ''Maybe then+      if nm == ''Maybe then do         let err = unwords [ "Could not derive packed maybe for:", show typ                           , ";", "Does its subtype have any space left to store"-                          , "the constructor in?" ] in-        lift =<< (fromMaybe $ error err) <$> (packedMaybe (size - 1) maybeTyp)+                          , "the constructor in?" ]+        packedM <- packedMaybe (size - 1)+                    (maybe (error "Maybe type without argument") fst (uncons maybeTyps))+        (fromMaybe (fail err) . fmap lift) packedM       else-        error $ unwords [ "You can only pass Maybe types to packedMaybeDerivator,"+        fail $ unwords [ "You can only pass Maybe types to packedMaybeDerivator,"                         , "not", show nm]     unexpected ->-      error $ "packedMaybeDerivator: unexpected constructor: " ++ show unexpected+      fail $ "packedMaybeDerivator: unexpected constructor: " ++ show unexpected   where-    (maybeCon, head -> maybeTyp) = collectTypeArgs typ+    (maybeCon, maybeTyps) = collectTypeArgs typ  -- | Derive a compactly represented version of @Maybe a@. derivePackedMaybeAnnotation :: DataReprAnn -> Q [Dec]@@ -650,17 +710,17 @@ storeInFields _dataWidth _additionalMask [_] =   -- Last constructor is implict   [Embedded 0 0]-storeInFields dataWidth additionalMask constrs =+storeInFields dataWidth additionalMask constrs@(constr:constrRest) =   if commonMask == fullMask then     -- We can't store the constructor anywhere special, so we need a special     -- constructor bit stored besides fields-    External : storeInFields dataWidth additionalMask (tail constrs)+    External : storeInFields dataWidth additionalMask constrRest   else     -- Hooray, we can store it somewhere.     maskOrigins ++ (storeInFields dataWidth additionalMask' (drop storeSize constrs))    where-    headMask   = head constrs+    headMask   = constr     commonMask = (.|.) headMask additionalMask      -- Variables for the case that we can store something:@@ -720,8 +780,11 @@ collectDataReprs :: Q [DataReprAnn] collectDataReprs = do   thisMod <- thisModule-  go [thisMod] Set.empty []+  unresolved <- go [thisMod] Set.empty []+  mapM resolveTyps unresolved   where+    resolveTyps (DataReprAnn t s c)+      = liftA3 DataReprAnn (resolveTypeSynonyms t) (pure s) (pure c)     go []     _visited acc = return acc     go (x:xs) visited  acc       | x `Set.member` visited = go xs visited acc@@ -732,14 +795,14 @@  group :: [Bit] -> [(Int, Bit)] group [] = []-group bs = (length head', head bs) : rest+group bs@(b:_) = (length head', b) : rest   where-    tail' = dropWhile (==head bs) bs-    head' = takeWhile (==head bs) bs+    tail' = dropWhile (==b) bs+    head' = takeWhile (==b) bs     rest  = group tail'  bitToExpr' :: (Int, Bit) -> Q Exp -- BitVector n-bitToExpr' (0, _) = error $ "Unexpected group length: 0"+bitToExpr' (0, _) = fail $ "Unexpected group length: 0" bitToExpr' (numTyLit' -> n, Util.H) =   [| complement (resize (pack low) :: BitVector $n) |] bitToExpr' (numTyLit' -> n, Util.L) =@@ -748,7 +811,7 @@   [| undefined# :: BitVector $n |]  bitsToExpr :: [Bit] -> Q Exp -- BitVector n-bitsToExpr [] = error $ "Unexpected empty bit list"+bitsToExpr [] = fail $ "Unexpected empty bit list" bitsToExpr bits =   foldl1     (\v1 v2 -> [| $v1 ++# $v2 |])@@ -763,7 +826,7 @@   -> [(Int, Int)]   -> Q Exp select' _vec [] =-  error $ "Unexpected empty list of intervals"+  fail $ "Unexpected empty list of intervals" select' vec ranges =   foldl1 (\v1 v2 -> [| $v1 ++# $v2 |]) $ map (return . select'') ranges     where@@ -793,7 +856,7 @@   -- ^ Select bits   -> Q Exp select _fields (Lit []) =-  error $ "Unexpected empty literal."+  fail $ "Unexpected empty literal." select _fields (Lit lits) = do   let size = length lits   vec <- bitsToExpr lits@@ -827,7 +890,7 @@               (\v1 v2 -> [| $v1 ++# $v2 |])               (map (select $ map VarE fieldPackedNames) origins) -  return $ Match (ConP name (VarP <$> fieldNames)) (NormalB vec) fieldPackedDecls+  return $ Match (ConP name [] (VarP <$> fieldNames)) (NormalB vec) fieldPackedDecls  -- | Build a /pack/ function corresponding to given DataRepr buildPack@@ -850,7 +913,8 @@ -- This is used in the generated pack/unpack to not do anything in HDL. dontApplyInHDL :: (a -> b) -> a -> b dontApplyInHDL f a = f a-{-# NOINLINE dontApplyInHDL #-}+{-# OPAQUE dontApplyInHDL #-}+{-# ANN dontApplyInHDL hasBlackBox #-}  buildUnpackField   :: Name@@ -894,15 +958,39 @@ -- the generated instance might conflict with existing implementations (for -- example, an instance for /Maybe a/ exists, yielding conflicts for any -- alternative implementations).+--+--+-- Usage:+--+-- @+-- data Color = R | G | B+-- {-# ANN module (DataReprAnn+--                   $(liftQ [t|Color|])+--                   2+--                   [ ConstrRepr 'R 0b11 0b00 []+--                   , ConstrRepr 'G 0b11 0b01 []+--                   , ConstrRepr 'B 0b11 0b10 []+--                   ]) #-}+-- deriveBitPack [t| Color |]+--+-- data MaybeColor = JustColor Color+--                 | NothingColor deriving (Generic,BitPack)+--+-- @+--+-- __NB__: Because of the way template haskell works the order here matters,+-- if you try to derive MaybeColor before deriveBitPack Color it will complain+-- about missing an instance BitSize Color. deriveBitPack :: Q Type -> Q [Dec] deriveBitPack typQ = do   anns <- collectDataReprs   typ  <- typQ+  rTyp <- resolveTypeSynonyms typ -  let ann = case filter (\(DataReprAnn t _ _) -> t == typ) anns of-              [a] -> a-              []  -> error $ "No custom bit annotation found."-              _   -> error $ "Overlapping bit annotations found."+  ann <- case filter (\(DataReprAnn t _ _) -> t == rTyp) anns of+              [a] -> return a+              []  -> fail "No custom bit annotation found."+              _   -> fail "Overlapping bit annotations found."    packFunc   <- buildPack ann   unpackFunc <- buildUnpack ann@@ -923,6 +1011,6 @@                ]   alreadyIsInstance <- isInstance ''BitPack [typ]   if alreadyIsInstance then-    error $ show typ ++ " already has a BitPack instance."+    fail $ show typ ++ " already has a BitPack instance."   else     return bpInst
src/Clash/Annotations/BitRepresentation/Internal.hs view
@@ -1,21 +1,21 @@ {-| Copyright  :  (C) 2018, Google Inc.+                  2022, LUMI GUIDE FIETSDETECTIE B.V. License    :  BSD2 (see the file LICENSE) Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DeriveAnyClass     #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE RankNTypes         #-}-{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}  module Clash.Annotations.BitRepresentation.Internal   ( buildCustomReprs   , dataReprAnnToDataRepr'   , constrReprToConstrRepr'   , getConstrRepr+  , uncheckedGetConstrRepr   , getDataRepr   , thTypeToType'   , ConstrRepr'(..)@@ -29,10 +29,14 @@ import           Control.DeepSeq                          (NFData) import           Data.Hashable                            (Hashable) import qualified Data.Map                                 as Map+import           Data.Maybe                               (fromMaybe) import qualified Data.Text                                as Text+#if __GLASGOW_HASKELL__ <= 910 import           Data.Typeable                            (Typeable)+#endif import qualified Language.Haskell.TH.Syntax               as TH import           GHC.Generics                             (Generic)+import           GHC.Stack                                (HasCallStack)   -- | Simple version of template haskell type. Used internally to match on.@@ -43,33 +47,44 @@   -- ^ Qualified name of type   | LitTy' Integer   -- ^ Numeral literal (used in BitVector 10, for example)-    deriving (Generic, NFData, Eq, Typeable, Hashable, Ord, Show)+  | SymLitTy' Text.Text+  -- ^ Symbol literal (used in for example (Signal "System" Int))+  deriving (Generic, NFData, Eq, Hashable, Ord, Show)+#if __GLASGOW_HASKELL__ <= 910+  deriving Typeable+#endif  -- | Internal version of DataRepr-data DataRepr' =-  DataRepr'-    -- Qualified name of type (recursive):-    Type'-    -- Size of data type:-    Size-    -- Constructors:-    [ConstrRepr']-      deriving (Show, Generic, NFData, Eq, Typeable, Hashable, Ord)+data DataRepr' = DataRepr'+  { drType :: Type'+  -- ^ Simple representation of data type+  , drSize :: Size+  -- ^ Size of data type+  , drConstrs :: [ConstrRepr']+  -- ^ Constructors+  }+  deriving (Show, Generic, NFData, Eq, Hashable, Ord)+#if __GLASGOW_HASKELL__ <= 910+  deriving Typeable+#endif  -- | Internal version of ConstrRepr-data ConstrRepr' =-  ConstrRepr'-    -- Qualified name of constructor:-    Text.Text-    -- Syntactical position in the custom representations definition:-    Int-    -- Mask needed to determine constructor:-    BitMask-    -- Value after applying mask:-    Value-    -- Indicates where fields are stored:-    [FieldAnn]-      deriving (Show, Generic, NFData, Eq, Typeable, Ord, Hashable)+data ConstrRepr' = ConstrRepr'+  { crName :: Text.Text+  -- ^ Qualified name of constructor+  , crPosition :: Int+  -- ^ Syntactical position in the custom representations definition+  , crMask :: BitMask+  -- ^ Mask needed to determine constructor+  , crValue :: Value+  -- ^ Value after applying mask+  , crFieldAnns :: [FieldAnn]+  -- ^ Indicates where fields are stored+  }+  deriving (Show, Generic, NFData, Eq, Ord, Hashable)+#if __GLASGOW_HASKELL__ <= 910+  deriving Typeable+#endif  constrReprToConstrRepr' :: Int -> ConstrRepr -> ConstrRepr' constrReprToConstrRepr' n (ConstrRepr name mask value fieldanns) =@@ -89,8 +104,10 @@ thTypeToType' ty = go ty   where     go (TH.ConT name')   = ConstTy' (thToText name')+    go (TH.PromotedT name') = ConstTy' (thToText name')     go (TH.AppT ty1 ty2) = AppTy' (go ty1) (go ty2)     go (TH.LitT (TH.NumTyLit n)) = LitTy' n+    go (TH.LitT (TH.StrTyLit lit)) = SymLitTy' (Text.pack lit)     go _ = error $ "Unsupported type: " ++ show ty  -- | Convenience type for index built by buildCustomReprs@@ -107,12 +124,23 @@ getConstrRepr :: Text.Text -> CustomReprs -> Maybe ConstrRepr' getConstrRepr name (_, reprs) = Map.lookup name reprs +-- | Unchecked version of getConstrRepr+uncheckedGetConstrRepr+  :: HasCallStack+  => Text.Text+  -> CustomReprs+  -> ConstrRepr'+uncheckedGetConstrRepr name (_, reprs) =+  fromMaybe+    (error ("Could not find custom representation for" ++ Text.unpack name))+    (Map.lookup name reprs)+ -- | Add CustomRepr to existing index-buildCustomRepr :: CustomReprs -> DataRepr' -> CustomReprs-buildCustomRepr (dMap, cMap) d@(DataRepr' name _size constrReprs) =+addCustomRepr :: CustomReprs -> DataRepr' -> CustomReprs+addCustomRepr (dMap, cMap) d@(DataRepr' name _size constrReprs) =   let insertConstr c@(ConstrRepr' name' _ _ _ _) cMap' = Map.insert name' c cMap' in   (Map.insert name d dMap, foldr insertConstr cMap constrReprs)  -- | Create indices based on names of constructors and data types buildCustomReprs :: [DataRepr'] -> CustomReprs-buildCustomReprs = foldl buildCustomRepr (Map.empty, Map.empty)+buildCustomReprs = foldl addCustomRepr (Map.empty, Map.empty)
src/Clash/Annotations/BitRepresentation/Util.hs view
@@ -4,8 +4,6 @@ Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE TemplateHaskell #-}- module Clash.Annotations.BitRepresentation.Util   ( bitOrigins   , bitOrigins'@@ -19,7 +17,7 @@ import Clash.Annotations.BitRepresentation.Internal   (DataRepr'(..), ConstrRepr'(..)) import Data.Bits  (Bits, testBit, testBit, shiftR, (.|.))-import Data.List  (findIndex, group, mapAccumL)+import Data.List  (findIndex, group, mapAccumL, uncons) import Data.Tuple (swap)  data Bit@@ -111,8 +109,10 @@ -- Output is ordered from least to most significant bit. -- Only outputs bits until the highest set bit. ----- >>> map bitsToBools [0..2]+-- @+-- > map bitsToBools [0..2] -- [[],[True],[False,True]])+-- @ -- -- This also works for variable sized number like Integer. -- But not for negative numbers, because negative Integers have infinite bits set.@@ -142,7 +142,7 @@ bitRanges word = reverse $ map swap ranges   where     ranges  = map (\(ofs, grp) -> (ofs, ofs+length grp-1)) groups'-    groups' = filter (head . snd) groups+    groups' = filter (maybe False fst . uncons . snd) groups     groups  = snd $ mapAccumL offsets 0 (group bits)     bits    = bitsToBools word
src/Clash/Annotations/Primitive.hs view
@@ -1,19 +1,18 @@ {-|-Copyright  :  (C) 2017-2019, Myrtle Software, QBayLogic+Copyright  :  (C) 2017-2019, Myrtle Software+                  2022,      QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -Instruct the clash compiler to look for primitive HDL templates in the-indicated directory. For distribution of new packages with primitive HDL-templates.+Instruct the Clash compiler to look for primitive HDL templates provided inline+or in a specified directory. For distribution of new packages with primitive+HDL templates. Primitive guards can be added to warn on instantiating+primitives. -} -{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE DeriveFunctor         #-}-{-# LANGUAGE DeriveTraversable     #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskellQuotes #-}  {-# LANGUAGE Safe #-}@@ -26,9 +25,11 @@   , warnNonSynthesizable   , warnAlways   , Primitive(..)-  , PrimitiveGuard(..)   , HDL(..)+  , PrimitiveGuard(..)+  , PrimitiveWarning(..)   , extractPrim+  , extractWarnings   ) where  import           Control.DeepSeq                          (NFData)@@ -39,7 +40,7 @@   -- The commented code directly below this comment is affected by an old--- GHC bug: https://ghc.haskell.org/trac/ghc/ticket/5463. In short, NOINLINE+-- GHC bug: https://gitlab.haskell.org/ghc/ghc/-/issues/5463. In short, NOINLINE -- pragmas generated by Template Haskell, get ignored. We'd still like a better -- API than manually having to write all the guard/inline pragmas some day, -- so I'm leaving the code in for now.@@ -138,23 +139,54 @@     nm -} +-- | Marks value as not translatable. Clash will error if it finds a blackbox+-- definition for it, or when it is forced to translate it. You can annotate a+-- variable or function @f@ like:+--+-- @+-- {\-\# ANN f dontTranslate \#-\}+-- @ dontTranslate :: PrimitiveGuard () dontTranslate = DontTranslate +-- | Marks a value as having a blackbox. Clash will error if it hasn't found+-- a blackbox. You can annotate a variable or function @f@ like:+--+-- @+-- {\-\# ANN f hasBlackBox \#-\}+-- @ hasBlackBox :: PrimitiveGuard ()-hasBlackBox = HasBlackBox ()+hasBlackBox = HasBlackBox [] () +-- | Marks value as non-synthesizable. This will trigger a warning if+-- instantiated in a non-testbench context. You can annotate a variable or+-- function @f@ like:+--+-- @+-- {\-\# ANN f (warnNonSynthesizable "Tread carefully, user!") \#-\}+-- @+--+-- Implies `hasBlackBox`. warnNonSynthesizable :: String -> PrimitiveGuard ()-warnNonSynthesizable s = WarnNonSynthesizable s ()+warnNonSynthesizable s = HasBlackBox [WarnNonSynthesizable s] () +-- | Always emit warning upon primitive instantiation. You can annotate a+-- variable or function @f@ like:+--+-- @+-- {\-\# ANN f (warnAlways "Tread carefully, user!") \#-\}+-- @+--+-- Implies `hasBlackBox`. warnAlways :: String -> PrimitiveGuard ()-warnAlways s = WarnAlways s ()+warnAlways s = HasBlackBox [WarnAlways s] () +-- | A compilation target HDL. data HDL   = SystemVerilog   | Verilog   | VHDL-  deriving (Eq, Show, Read, Data, Generic, NFData, Hashable)+  deriving (Eq, Show, Read, Data, Generic, NFData, Hashable, Enum, Bounded)  -- | The 'Primitive' constructor instructs the clash compiler to look for primitive -- HDL templates in the indicated directory. 'InlinePrimitive' is equivalent but@@ -169,10 +201,8 @@ -- -- You create a package which has a @myfancyip.cabal@ file with the following stanza: ----- @--- data-files: path\/to\/MyFancyIP.json--- cpp-options: -DCABAL--- @+-- > data-files: path/to/MyFancyIP.primitives+-- > cpp-options: -DCABAL -- -- and a @MyFancyIP.hs@ module with the simulation definition and primitive. --@@ -197,89 +227,76 @@ -- import qualified Paths_myfancyip -- import           System.IO.Unsafe ----- {\-\# ANN module (Primitive VHDL (unsafePerformIO Paths_myfancyip.getDataDir \<\/\> "path" \<\/\> "to")) \#-\}+-- {\-\# ANN module (Primitive [VHDL] (unsafePerformIO Paths_myfancyip.getDataDir \<\/\> "path" \<\/\> "to")) \#-\} -- \#endif -- @ -- -- Add more files to the @data-files@ stanza in your @.cabal@ files and more -- @ANN@ pragma's if you want to add more primitive templates for other HDLs ----- === Example of 'InlinePrimitive'+-- === Example of 'InlineYamlPrimitive' -- -- The following example shows off an inline HDL primitive template. It uses the--- [interpolate](https://hackage.haskell.org/package/interpolate) package for--- nicer multiline strings.+-- [string-interpolate](https://hackage.haskell.org/package/string-interpolate)+-- package for nicer multiline strings. -- -- @+-- {\-\# LANGUAGE QuasiQuotes \#-\} -- module InlinePrimitive where -- -- import           Clash.Annotations.Primitive -- import           Clash.Prelude--- import           Data.String.Interpolate      (i)--- import           Data.String.Interpolate.Util (unindent)+-- import           Data.String.Interpolate      (__i) ----- {\-\# ANN example (InlinePrimitive VHDL $ unindent [i|---   [ { \"BlackBox\" :---       { "name" : "InlinePrimitive.example"---       , "kind": "Declaration"---       , "template" :---   "-- begin InlinePrimitive example:---   ~GENSYM[example][0] : block---   ~RESULT <= 1 + ~ARG[0];---   end block;---   -- end InlinePrimitive example"---       }---     }---   ]+-- {\-\# ANN example (InlineYamlPrimitive [VHDL] [__i|+--   BlackBox:+--     kind: Declaration+--     name: InlinePrimitive.example+--     template: |-+--       -- begin InlinePrimitive example:+--       ~GENSYM[example][0] : block+--       ~RESULT <= 1 + ~ARG[0];+--       end block;+--       -- end InlinePrimitive example --   |]) \#-\} -- {\-\# NOINLINE example \#-\} -- example :: Signal System (BitVector 2) -> Signal System (BitVector 2) -- example = fmap succ -- @ data Primitive-  = Primitive HDL FilePath-  -- ^ Description of a primitive for a given 'HDL' in a file at 'FilePath'-  | InlinePrimitive HDL String-  -- ^ Description of a primitive for a given 'HDL' as an inline 'String'-  deriving (Show, Read, Data, Generic, NFData, Hashable)---- | Guard primitive functions. This will help Clash generate better error--- messages. You can annotate a function like:+  = Primitive [HDL] FilePath+  -- ^ Description of a primitive for given 'HDL's in a file at 'FilePath'+  | InlinePrimitive [HDL] String+  -- ^ Description of a primitive for given 'HDL's as an inline JSON 'String'+  | InlineYamlPrimitive [HDL] String+  -- ^ Description of a primitive for given 'HDL's as an inline YAML 'String'+  deriving (Show, Read, Data, Generic, NFData, Hashable, Eq) --- @--- {-# ANN f dontTranslate #-}--- @------ or------ @--- {-# ANN f hasBlackBox #-}--- @------ or------ @--- {-# ANN f (warnNonSynthesizable "Tread carefully, user!") #-}--- @------ or+-- | Primitive guard to mark a value as either not translatable or as having a+-- blackbox with an optional extra warning. Helps Clash generate better error+-- messages. ----- @--- {-# ANN f (warnAlways "Tread carefully, user!") #-}--- @+-- For use, see 'dontTranslate', 'hasBlackBox', 'warnNonSynthesizable' and+-- 'warnAlways'. data PrimitiveGuard a   = DontTranslate   -- ^ Marks value as not translatable. Clash will error if it finds a blackbox   -- definition for it, or when it is forced to translate it.-  | HasBlackBox a-  -- ^ Marks a value as having a blackbox. Clash will err if it hasn't found-  -- a blackbox-  | WarnNonSynthesizable String a+  | HasBlackBox [PrimitiveWarning] a+  -- ^ Marks a value as having a blackbox. Clash will error if it hasn't found+  -- a blackbox.+  deriving+    ( Show, Read, Data, Generic, NFData, Hashable, Functor, Foldable+    , Traversable, Binary, Eq )++-- | Warning that will be emitted on instantiating a guarded value.+data PrimitiveWarning+  = WarnNonSynthesizable String   -- ^ Marks value as non-synthesizable. This will trigger a warning if-  -- instantiated in a non-testbench context. Implies @HasBlackBox@.-  | WarnAlways String a-  -- ^ Always emit warning upon instantiation. Implies @HasBlackBox@.-    deriving (Show, Read, Data, Generic, NFData, Hashable, Functor, Foldable, Traversable, Binary)+  -- instantiated in a non-testbench context.+  | WarnAlways String+  -- ^ Always emit warning upon primitive instantiation.+    deriving (Show, Read, Data, Generic, NFData, Hashable, Binary, Eq)  -- | Extract primitive definition from a PrimitiveGuard. Will yield Nothing -- for guards of value 'DontTranslate'.@@ -288,7 +305,15 @@   -> Maybe a extractPrim =   \case-    HasBlackBox a            -> Just a-    WarnNonSynthesizable _ a -> Just a-    WarnAlways _ a           -> Just a-    DontTranslate            -> Nothing+    HasBlackBox _ p -> Just p+    DontTranslate   -> Nothing++-- | Extract primitive warnings from a PrimitiveGuard. Will yield an empty list+-- for guards of value 'DontTranslate'.+extractWarnings+  :: PrimitiveGuard a+  -> [PrimitiveWarning]+extractWarnings =+  \case+    HasBlackBox w _ -> w+    DontTranslate   -> []
src/Clash/Annotations/SynthesisAttributes.hs view
@@ -1,37 +1,49 @@ {-|-  Copyright   :  (C) 2018, Google Inc.+  Copyright   :  (C) 2018,      Google Inc.,+                     2021-2025, QBayLogic B.V.   License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com> -  API for synthesis attributes (sometimes refered to as "synthesis directives",+  API for synthesis attributes (sometimes referred to as "synthesis directives",   "pragmas", or "logic synthesis directives"). This is an experimental feature,   please report any unexpected or broken behavior to Clash's GitHub page   (<https://github.com/clash-lang/clash-compiler/issues>). -}+ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE PolyKinds     #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE Safe #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}  module Clash.Annotations.SynthesisAttributes   ( Attr(..)   , Annotate+  , annotate+  , annotateReg+  , markDebug   ) where -import GHC.TypeLits (Symbol)+import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Hashable (Hashable) import Data.Kind (Type)+import Data.String.Interpolate (__i)+import GHC.Generics (Generic)+import Language.Haskell.TH.Syntax (Lift) +import Clash.Annotations.Primitive (Primitive(InlineYamlPrimitive), hasBlackBox)+import Clash.Signal.Internal (Signal)+import Clash.Sized.Vector (Vec(..))+ type Annotate (a :: Type) (attrs :: k) = a --- | Synthesis attributes are directives passed to sythesis tools, such as+-- | Synthesis attributes are directives passed to synthesis tools, such as -- Quartus. An example of such an attribute in VHDL: ----- @---   attribute chip_pin : string;---   attribute chip_pin of sel : signal is \"C4\";---   attribute chip_pin of data : signal is "D1, D2, D3, D4";--- @+-- > attribute chip_pin : string;+-- > attribute chip_pin of sel : signal is "C4";+-- > attribute chip_pin of data : signal is "D1, D2, D3, D4"; -- -- This would instruct the synthesis tool to map the wire /sel/ to pin /C4/, and -- wire /data/ to pins /D1/, /D2/, /D3/, and /D4/. To achieve this in Clash, /Attr/s@@ -45,7 +57,7 @@ --     -> (Signal System Int4 \`Annotate\` 'StringAttr "chip_pin" "D1, D2, D3, D4") --     -> ... -- myFunc sel data = ...--- {-# NOINLINE myFunc #-}+-- {\-\# NOINLINE myFunc \#-\} -- @ -- -- To ensure this function will be rendered as its own module, do not forget a@@ -69,18 +81,166 @@ -- For VHDL, see: --     <https://www.intel.com/content/www/us/en/programmable/quartushelp/current/index.htm#hdl/vhdl/vhdl_file_dir.htm> ----- Warning: This is an experimental feature, please report any unexpected or broken+-- = Warnings+--+-- When using annotations, it is important that annotated arguments are not+-- eta-reduced, as this may result in the annotation being stripped by GHC. For+-- example+--+-- @+-- f :: Signal System Bool \`Annotate\` 'StringAttr \"chip_pin\" \"C4\"+--   -> Signal System Bool+-- f x = id x -- Using a lambda, i.e. f = \\x -> id x also works+-- @+--+-- will reliably show the annotation in the generated HDL, but+--+-- @+-- g :: Signal System Bool \`Annotate\` 'StringAttr \"chip_pin\" \"C4\"+--   -> Signal System Bool+-- g = id+-- @+--+-- will not work.+--+-- This is an experimental feature, please report any unexpected or broken -- behavior to Clash's GitHub page (<https://github.com/clash-lang/clash-compiler/issues>).-data Attr-  = BoolAttr Symbol Bool+--+-- Use 'annotate' if you wish to annotate an intermediate signal. Its use is+-- preferred over type level annotations.+data Attr a+  = BoolAttr a Bool   -- ^ Attribute which argument is rendered as a bool. Example:   -- <https://www.intel.com/content/www/us/en/programmable/quartushelp/current/index.htm#hdl/vlog/vlog_file_dir_direct_enable.htm>-  | IntegerAttr Symbol Integer+  | IntegerAttr a Integer   -- ^ Attribute which argument is rendered as a integer. Example:   -- <https://www.intel.com/content/www/us/en/programmable/quartushelp/current/index.htm#hdl/vlog/vlog_file_dir_max_depth.htm>-  | StringAttr Symbol Symbol+  | StringAttr a a   -- ^ Attribute which argument is rendered as a string. Example:   -- <https://www.intel.com/content/www/us/en/programmable/quartushelp/current/index.htm#hdl/vlog/vlog_file_dir_chip.htm>-  | Attr Symbol+  | Attr a   -- ^ Attribute rendered as constant. Example:   -- <https://www.intel.com/content/www/us/en/programmable/quartushelp/current/index.htm#hdl/vlog/vlog_file_dir_keep.htm>+  deriving (Show, Generic, NFData, Binary, Lift, Eq, Ord, Hashable, Functor)++-- | Create a new identifier in HDL and inserts given synthesis attributes. The+-- name of the intermediate signal can be influenced using naming functions in+-- "Clash.Magic".+annotate :: forall n dom a . Vec n (Attr String) -> Signal dom a -> Signal dom a+annotate !_attrs !a = a+{-# OPAQUE annotate #-}+{-# ANN annotate hasBlackBox #-}+{-# ANN annotate+  let primName = show 'annotate+  in InlineYamlPrimitive [minBound..] [__i|+    BlackBoxHaskell:+        name: #{primName}+        templateFunction: "Clash.Primitives.Annotations.SynthesisAttributes.annotateBBF"+        workInfo: Always+  |] #-}++-- | Insert attributes such that signals are preserved in major synthesis tools.+-- Also inserts "mark_debug", a way of signalling Vivado a signal should show up+-- in a list of signals desired for ILA/VIO insertion.+--+-- Attributes inserted: @keep@, @mark_debug@, @noprune@, and @preserve@.+markDebug :: Signal dom a -> Signal dom a+markDebug = annotate $+     BoolAttr "keep" True++  -- Vivado:+  :> BoolAttr "mark_debug" True++  -- Quartus:+  :> Attr "noprune"+  :> Attr "preserve"+  :> Nil++{- | Add synthesis attributes to register declarations in the HDL generated by the Clash+compiler.++For example, given the following code:++> import Clash.Explicit.Prelude+> import Clash.Annotations.SynthesisAttributes+>+> topEntity ::+>   Clock System ->+>   Reset System ->+>   Signal System Bool ->+>   Signal System Bool+> topEntity clk rst x =+>   let r1 = setName @"r1" (annotateReg attrs (dflipflop clk x))+>       r2 = setName @"r2" (annotateReg attrs (register clk rst enableGen False r1))+>    in r2+>  where+>   attrs = Attr "ASYNC_REG" :> Nil++The clash compiler would generate the following Verilog:++> `default_nettype none+> `timescale 100fs/100fs+> module topEntity+>     ( // Inputs+>       input wire  clk // clock+>     , input wire  rst // reset+>     , input wire  x+>+>       // Outputs+>     , output wire  result+>     );+>   (* ASYNC_REG *) reg  r1 = ({1 {1'bx}});+>   (* ASYNC_REG *) reg  r2 = 1'b0;+>+>   // delay begin+>   always @(posedge clk) begin : r1_delay+>     r1 <= x;+>   end+>   // delay end+>+>   // register begin+>   always @(posedge clk or  posedge  rst) begin : r2_register+>     if ( rst) begin+>       r2 <= 1'b0;+>     end else begin+>       r2 <= r1;+>     end+>   end+>   // register end+>+>   assign result = r2;+>+>+> endmodule+> `default_nettype wire++Where we can see that the /r1/ and /r2/ registers are given the specified+/ASYNC_REG/ attribute.++The above pattern can also be abstracted over, e.g. you could write:++> topEntity ::+>   Clock System ->+>   Reset System ->+>   Signal System Bool ->+>   Signal System Bool+> topEntity clk rst =+>   markAsync @"r1" (dflipflop clk) .+>   markAsync @"r2" (register clk rst enableGen False)+>+> markAsync ::+>   forall (name :: Symbol) dom a .+>   (Signal dom a -> Signal dom a) ->+>   Signal dom a ->+>   Signal dom a+> markAsync f = \x -> setName @name (annotateReg attrs (f x))+>  where+>   attrs = Attr "ASYNC_REG" :> Nil+> {-# INLINE markAsync #-}++And it will generate exactly the same Verilog as above.+-}+annotateReg :: forall n dom a . Vec n (Attr String) -> Signal dom a -> Signal dom a+annotateReg !_ x = x+{-# OPAQUE annotateReg #-}+{-# ANN annotateReg hasBlackBox #-}
+ src/Clash/Annotations/TH.hs view
@@ -0,0 +1,514 @@+{-|++This module can automatically generate TopEntity definitions from "Clash.NamedTypes"+annotations. Annotations involving data\/type families must be inspected for correctness.+Not all cases can be handled with automatic generation due to the difficulty of type manipulation+in template Haskell. In particular annotations __inside__ the following is unlikely to work:++- Data\/type family referencing other data\/type families.+- Annotations inside recursive data types+- Clock constraints other than a single HiddenClockResetEnable. (You can still+  use arbitrary explicit clock\/reset\/enables!)++See <https://github.com/clash-lang/clash-compiler/blob/master/clash-prelude/tests/Clash/Tests/TopEntityGeneration.hs Clash.Tests.TopEntityGeneration>+for more examples.++@+import Clash.Annotations.TH++data Named+  = Named+  { name1 :: "named1" ::: BitVector 3+  , name2 :: "named2" ::: BitVector 5+  }++topEntity :: "tup1" ::: Signal System (Int, Bool)+          -> "tup2" ::: (Signal System Int, Signal System Bool)+          -> "tup3" ::: Signal System ("int":::Int, "bool":::Bool)+          -> "tup4" ::: ("int":::Signal System Int, "bool":::Signal System Bool)+          -> "custom" ::: Signal System Named+          -> "outTup" ::: Signal System ("outint":::Int, "outbool":::Bool)+topEntity = undefined+makeTopEntity 'topEntity+-- ===>+--  {-# ANN topEntity Synthesize "topEntity3"+--     [ PortName "tup1"+--     , PortName "tup2"+--     , PortProduct "tup3" [PortName "int",PortName "bool"]+--     , PortProduct "tup4" [PortName "int",PortName "bool"]+--     , PortProduct "custom" [PortName "named1",PortName "named2"]+--     ]+--     (PortProduct "outTup" [PortName "outint",PortName "outbool"])+--     #-}+@++-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+-- Required to 'makeBaseFunctor' of 'Language.Haskell.TH.Syntax.Type'++{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Clash.Annotations.TH+  ( -- * To create a Synthesize annotation pragma+    makeTopEntity+  , makeTopEntityWithName+  , makeTopEntityWithName'+    -- * To create a TopEntity value+  , buildTopEntity+  , maybeBuildTopEntity+  , getNameBinding+  )+where++import           Data.Foldable                  ( fold)+import qualified Data.Set                      as Set+import qualified Data.Map                      as Map+import           Data.Maybe                     ( catMaybes )+import           Language.Haskell.TH++import           Data.Functor.Foldable          ( para )+import           Data.Functor.Foldable.TH+import           Control.Lens                   ( (%~), (&), (.~)+                                                , _1, _2, _3, view+                                                )+import           Control.Monad                  (mfilter, liftM2, forM, zipWithM)+import           Control.Monad.Trans.Reader     (ReaderT(..), asks, local)+import           Control.Monad.Trans.Class      (lift)+import           Language.Haskell.TH.Instances  ( )+import           Language.Haskell.TH.Datatype+import           Language.Haskell.TH.Syntax     (qRecover)+import           Data.Generics.Uniplate.Data    (rewrite)++import           Clash.Annotations.TopEntity    ( PortName(..)+                                                , TopEntity(..)+                                                )+import           Clash.Magic                    (SimOnly)+import           Clash.NamedTypes               ((:::))+import           Clash.Signal                   ( HiddenClockResetEnable+                                                , HiddenClock, HiddenReset, HiddenEnable+                                                , Signal)+import           Clash.Signal.Delayed           (DSignal)++$(makeBaseFunctor ''Type)++-- | A datatype to track failing naming in a subtree.+data Naming a = Complete a | HasFail String | BackTrack (Set.Set Name)+  deriving Functor++instance Semigroup a => Semigroup (Naming a) where+  Complete a <> Complete b     = Complete $ a <> b+  BackTrack n1 <> BackTrack n2 = BackTrack $ n1 <> n2+  BackTrack n <> _             = BackTrack n+  _ <> BackTrack n             = BackTrack n+  HasFail e1 <> HasFail e2     = HasFail $ e1 ++ "\n" ++ e2+  _ <> HasFail e               = HasFail e+  HasFail e <> _               = HasFail e++instance Monoid a => Monoid (Naming a) where+  mempty = Complete mempty++-- | Track seen 'Name's, and track current 'Info' for error reporting.+type ErrorContext = String+type TrackData = (Set.Set Name, ErrorContext)+type Tracked m a = ReaderT TrackData m a++-- * Utility functions++-- | Matches a type `a -> b`+pattern ArrowTy :: Type -> Type -> Type+pattern ArrowTy a b = AppT (AppT ArrowT a) b++-- | Greedily split on top level 'AppT' to recover basic type+-- application as a list of 'Type'.+unapp :: Type -> [Type]+unapp (AppT l r) = unapp l ++ [r]+unapp t = [t]++-- | Greedily split on top level outer arrows, splitting a function 'Type' into+-- it's arguments. (Result type discarded)+unarrow :: Type -> [Type]+unarrow (ArrowTy x y) = x : unarrow y+unarrow _ = []++-- | Collapse a list of 'PortName's into a single 'PortName'+collapseNames :: [PortName] -> [PortName]+collapseNames [] = []+collapseNames [x] = [x]+collapseNames xs = [PortProduct "" xs]++-- | Failure message with a prefix to add some context for end users.+failMsg :: String -> String+failMsg s = "TopEntity generation error: " ++ s++-- | Retrieve current error context+errorContext :: Tracked Q String+errorContext = asks snd++-- Failure message with prefix in a 'Tracked' context+failMsgWithContext :: String -> Tracked Q String+failMsgWithContext s = (++) (failMsg s) <$> errorContext++-- | Track a new seen 'Name' and update 'Info' for error handling+visit :: (Show b) => Name -> b -> Tracked m a -> Tracked m a+visit name a = local (\t -> t & _1 %~ Set.insert name+                              & _2 .~ show a)++-- | Grab the 'Name's of type variables in a datatype+datatypeVars' :: DatatypeInfo -> [Name]+datatypeVars' d = tvName <$> datatypeVars d++-- | Run a 'Name' through the template haskell machinery, getting a+-- 'DatatypeInfo' if the 'Name' specified a datatype. The result is processed by+-- a given function or a default @a@ is returned in the style of 'maybe'.+tryReifyDatatype :: a -> (DatatypeInfo -> a) -> Name -> Tracked Q a+tryReifyDatatype a f name = lift (recover (pure a) $ f <$> reifyDatatype name)++-- * Type tree folding \/ unfolding++-- | Flag constructors with partially named fields as failing.+portsFromTypes+  :: [Type]+  -> Tracked Q (Naming [PortName])+portsFromTypes xs = do+  (mconcat <$> mapM f xs)+  >>= \case+    Complete names | length names > 0 && length names /= length xs ->+      HasFail <$> failMsgWithContext "Partially named constructor arguments!\n"+    x -> return x+ where+  f = fmap (fmap collapseNames) . gatherNames++-- | Flag sum types as failing if they have any constructors with names.+handleNamesInSum+  :: [ConstructorInfo]+  -> Tracked Q (Naming [PortName])+handleNamesInSum xs =+  (fold <$> mapM portsFromTypes (constructorFields <$> xs)) >>= \case+    Complete [] -> return $ Complete []+    x ->+      mappend x . HasFail <$> failMsgWithContext "Annotated sum types not supported!\n"++-- | Build a list of 'PortName's from a Template Haskell 'Con' and a free+-- variable mapping+constructorToPorts :: Con -> Map.Map Name Type -> Tracked Q (Naming [PortName])+constructorToPorts c m = do+  let xs = applySubstitution m (ctys c)+  portsFromTypes xs+ where+  ctys (NormalC _ (fmap snd -> tys)) = tys+  ctys (RecC _ (fmap (view _3) -> tys)) = tys+  ctys (InfixC _ _ (snd -> ty)) = [ty]+  ctys (ForallC _ _ c') = ctys c'+  ctys (GadtC _ (fmap snd -> tys) _) = tys+  ctys (RecGadtC _ (fmap (view _3) -> tys) _) = tys++-- | Build a list of 'PortName's from a Template Haskell 'Name'+datatypeNameToPorts+  :: Name+  -> Tracked Q (Naming [PortName])+datatypeNameToPorts name = do+  constructors <- tryReifyDatatype [] datatypeCons name++  names <- case constructors of+    _ | name == ''SimOnly -> return $ Complete []+    []  -> return $ Complete []+    [x] -> portsFromTypes (constructorFields x)+    xs  -> handleNamesInSum xs++  case names of+    BackTrack ns | Set.member name ns -> do+      lift $ reportWarning $ "Make sure HDL port names are correct:\n"+                           ++ "Backtracked when constructing " ++ pprint name+                           ++ "\n(Type appears recursive)"+      return $ case (Set.delete name ns) of+        e | e == Set.empty -> Complete []+        xs -> BackTrack xs+    _ -> return names++-- This shouldn't reduce+type family PortLabel where++-- Replace (:::) annotations with a stuck type family, to inhibit unifyTypes to reduce it+guardPorts :: Type -> Type+guardPorts = rewrite $ \case+    AppT (ConT split) name@(LitT (StrTyLit _)) | split == ''(:::) -> Just $ AppT (ConT ''PortLabel) name+    _ -> Nothing++-- | Recursively walking a 'Type' tree and building a list of 'PortName's.+typeTreeToPorts+  :: TypeF (Type, Tracked Q (Naming [PortName]))+  -- ^ Case under scrutiny, paramorphism style+  -> Tracked Q (Naming [PortName])+typeTreeToPorts (AppTF (AppT (ConT split) (LitT (StrTyLit name)), _) (_,c))+  -- Is there a '<String> ::: <something>' annotation?+  | split == ''PortLabel+  -- We found our split. If:+  -- - We only have no names from children: use split name as PortName+  -- - We have children reporting names: use split name as name to PortProduct+  = c >>= \case+    Complete []  -> return $ Complete [PortName name]+    Complete [PortName n2] -> return $ Complete [PortName (name ++ "_" ++ n2)]+    Complete xs  -> return $ Complete [PortProduct name xs]+    x            -> return x++typeTreeToPorts (ConTF name) = do+  -- Only attempt to resolve a subtree for names we haven't seen before+  seen <- asks fst+  if Set.member name seen+  then return $ BackTrack $ Set.singleton name+  else visit name name $ do+    info <- lift $ reify name+    case info of+      -- Either `name` is an unannotated primitive+      PrimTyConI _ _ _ -> return $ Complete []+      -- ... or a type synonym+      TyConI (TySynD _ _ t) -> gatherNames t+      -- ... or something "datatype" like+      _ -> datatypeNameToPorts name++typeTreeToPorts f@(AppTF (a,a') (b,b')) = do+  -- Gather types applied to a head type+  case unapp (AppT a b) of+    -- Skip SimOnly constructs - they're always zero bits+    (ConT x : _) | x == ''SimOnly -> pure (Complete [])+    -- Return the inner type for signals+    (ConT x : _ : _ : []) | x == ''Clash.Signal.Signal -> b'+    (ConT x : _ : _ : _ : []) | x == ''Clash.Signal.Delayed.DSignal -> b'++    -- Other handled type applications are+    -- 1. Type synonyms+    -- 2. Closed type families+    -- 3. Open type and data families+    -- 4. Regular data types+    (ConT x : xs) -> do+      info <- lift $ reify x+      case info of+        -- 1. Type synonym case is just inserting the relevant port tree+        (TyConI (TySynD _ synvars def)) -> do+          gatherNames $ applyContext xs (tvName <$> synvars) def++        -- 2. Match argument lengths, substitute types, and then insert the port+        -- tree+        FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bds _ _) eqs) _+          | length bds == length xs -> do+              matches <- lift $ forM eqs $ \eq -> qRecover (return Nothing) . fmap Just $ do+                  sub <- mconcat <$> zipWithM (\l r -> unifyTypes [l, r]) xs (tySynArgs eq)+                  return $ applySubstitution sub $ tySynRHS eq+              case catMaybes matches of+                  (r:_) -> gatherNames r+                  -- We didn't find any matching instances (i.e. the+                  -- type family application is stuck) so give up.+                  [] -> return $ Complete []++        -- 3. Match argument lengths then:+        --   - Substitute port tree for type family+        --   - Try to get a unique constructor for data families and build+        --     port tree from the constructor+        _ | familyArity info == Just (length xs) -> do+          (lift $ reifyInstances x xs) >>= \case+            [TySynInstD (TySynEqn _ _ r)] ->+                gatherNames (applyFamilyBindings xs info r)++            [NewtypeInstD _ _ _ _ c _] -> constructorToPorts c (familyTyMap xs info)+            [DataInstD    _ _ _ _ cs _] -> do+              case cs of+                [c] -> constructorToPorts c (familyTyMap xs info)+                _ -> return $ Complete []+            y -> fail $ failMsg "Encountered unexpected type during family application!"+                      ++ pprint y++        -- 4. Check if head really is a datatype, apply free variables,+        --    and attempt to get a unique constructor+        _ -> do+          dataTy <- tryReifyDatatype Nothing Just x++          let -- Apply tail types to head datatype free type variables+              hasAllArgs   = \vs -> length xs == length (datatypeVars vs)+              constructors = applyDatatypeContext xs <$> mfilter hasAllArgs dataTy++              -- Attempt to get a unique constructor+              getSingleConstructor cs = do [c] <- cs; return c+              constructor = getSingleConstructor constructors++          -- If any steps failed, return the PortNames according to the head type.+          maybe a' (visit x (ppr x) . portsFromTypes . constructorFields) constructor++    -- If head is a tuple or list then we take all the names+    (ListT:_)    -> fold <$> mapM snd f+    (TupleT _:_) -> fold <$> mapM snd f++    -- We're not applying to a head 'ConT' so lets try best effort of getting names+    -- from all applied types+    _ -> do+      lift $ reportWarning $ "Make sure HDL port names are correct:\n"+                           ++ "Type application with non ConT head:\n:("+                           ++ pprint (AppT a b)+      f' <- mapM snd f+      return $ fold f'+ where+  tyMap ctx holes = Map.fromList $ zip holes ctx+  familyTyMap ctx (familyBindings -> Just holes) = tyMap ctx (tvName <$> holes)+  familyTyMap _ _  = error "familyTyMap called with non family argument!"+  applyContext ctx holes = applySubstitution (tyMap ctx holes)+  applyDatatypeContext ctx d = applyContext ctx (datatypeVars' d) <$> datatypeCons d+  applyFamilyBindings ctx (familyBindings -> Just holes) t+    = applyContext ctx (tvName <$> holes) t+  applyFamilyBindings _ _ _ = error "familyTyMap called with non family argument!"++  tySynArgs (TySynEqn _ args _) = drop 1 (unapp args)++  tySynRHS (TySynEqn _ _ r) = r++  familyBindings (FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ xs _ _) _) _) = Just xs+  familyBindings (FamilyI (OpenTypeFamilyD (TypeFamilyHead _ xs _ _)) _) = Just xs+  familyBindings (FamilyI (DataFamilyD _ xs _) _) = Just xs+  familyBindings _ = Nothing+  familyArity = fmap length . familyBindings++typeTreeToPorts f = do+  -- Just collect names+  f' <- mapM snd f+  return $ fold f'++-- | Gather naming tree attached to a 'Type' and its inner 'Type's+gatherNames+  :: Type+  -- ^ Type to investigate+  -> Tracked Q (Naming [PortName])+gatherNames =+  para typeTreeToPorts . guardPorts++-- Build a possible failing 'PortName' tree and unwrap the 'Naming' result.+buildPorts+  :: Type+  -- ^ Type to investigate+  -> Q [PortName]+buildPorts x = do+  flip runReaderT (Set.empty, "") $ gatherNames x+    >>= \case+      Complete xs -> return xs+      HasFail err -> fail err+      BackTrack n -> fail $ failMsg "Encountered recursive type at entry! " ++ show n++-- | Get the result 'PortName' from a function type+toReturnName :: Type -> Q PortName+toReturnName (ArrowTy _ b) = toReturnName b+toReturnName b             =+  buildPorts b+  >>= \case+     [] -> fail $ failMsg "No return name specified!"+     [x] -> return x+     xs -> return $ PortProduct "" xs++-- | Get the argument 'PortName's from a function type+toArgNames :: Type -> Q [PortName]+toArgNames ty = traverse build (unarrow ty)+ where+  build x = buildPorts x >>= check x+  check x []  = fail $ failMsg "Unnamed argument " ++ pprint x+  check _ [a] = return a+  check _ xs  = return $ PortProduct "" xs++data ClockType = None | SingleClockResetEnable | Other+  deriving Eq++-- | Strip constraints from a type.+--+-- Fail if:+-- - There are free type variables.+handleConstraints :: Type -> ClockType -> Q (Type, ClockType)+handleConstraints (ForallT [] [] x) clk = handleConstraints x clk+handleConstraints (ForallT xs@(_:_) _ _) _ =+  fail $ failMsg "Free type variables!\n"+       ++ pprint xs+handleConstraints (ForallT _ c x) clk = handleConstraints x hiddenClocks+ where+  hiddenClocks = foldl findHiddenClocks clk c+  findHiddenClocks a (AppT (ConT b) _)+    | b == ''Clash.Signal.HiddenClockResetEnable && a == None+      = SingleClockResetEnable+    | b == ''Clash.Signal.HiddenClockResetEnable && a /= None+      = Other+    | b == ''Clash.Signal.HiddenClock+      || b == ''Clash.Signal.HiddenReset+      || b == ''Clash.Signal.HiddenEnable+      = Other+  findHiddenClocks a _ = a+handleConstraints x clk = return (x, clk)++clockToPorts :: ClockType -> Q [PortName]+clockToPorts None = return []+clockToPorts (SingleClockResetEnable) =+  return [PortProduct "" [ PortName "clk" , PortName "rst" , PortName "en" ]]+clockToPorts Other =+  fail $ failMsg "TH generation for"+       ++ " HiddenClock/HiddenReset/HiddenEnable currently unsupported!"++-- *++-- | Return a typed expression for a 'TopEntity' of a given @('Name', 'Type')@.+buildTopEntity :: Maybe String -> (Name, Type) -> TExpQ TopEntity+buildTopEntity topName (name, ty) = do+    (ty', clock) <- handleConstraints ty None++    ins   <- liftM2 (<>) (clockToPorts clock) (toArgNames ty')+    out   <- toReturnName ty'++    let outName = case topName of+          Just name' -> name'          -- user specified name+          Nothing    -> nameBase name  -- auto-generated from Haskell name++    (examineCode+                  [|| Synthesize+                     { t_name   = outName+                     , t_inputs = ins+                     , t_output = out+                     } ||])++-- | Return a typed 'Maybe TopEntity' expression given a 'Name'.+-- This will return an 'TExp' of 'Nothing' if 'TopEntity' generation failed.+maybeBuildTopEntity :: Maybe String -> Name -> Q (TExp (Maybe TopEntity))+maybeBuildTopEntity topName name = do+  recover (examineCode [|| Nothing ||]) $ do+    let expr = liftCode (getNameBinding name >>= buildTopEntity topName)+    examineCode [|| Just ($$expr) ||]++-- | Turn the 'Name' of a value to a @('Name', 'Type')@+getNameBinding :: Name -> Q (Name, Type)+getNameBinding n = reify n >>= \case+  VarI name ty _ -> return (name, ty)+  _ -> fail "getNameBinding: Invalid Name, must be a top-level binding!"++-- | Wrap a 'TopEntity' expression in an annotation pragma+makeTopEntityWithName' :: Name -> Maybe String -> DecQ+makeTopEntityWithName' n topName = do+  (name,ty) <- getNameBinding n+  topEntity <- buildTopEntity topName (name,ty)+  let prag t = PragmaD (AnnP (valueAnnotation name) t)+  return $ prag $ unType topEntity++-- | Automatically create a @'TopEntity'@ for a given @'Name'@, using the given+-- @'String'@ to specify the name of the generated RTL entity.+--+-- The function arguments and return values of the function specified by the+-- given @'Name'@ must be annotated with @'(:::)'@. This annotation provides the+-- given name of the port.+makeTopEntityWithName :: Name -> String -> DecsQ+makeTopEntityWithName nam top = pure <$> makeTopEntityWithName' nam (Just top)++-- | Automatically create a @'TopEntity'@ for a given @'Name'@. The name of the+-- generated RTL entity will be the name of the function that has been+-- specified; e.g. @'makeTopEntity' 'foobar@ will generate a @foobar@ module.+--+-- The function arguments and return values of the function specified by the+-- given @'Name'@ must be annotated with @'(:::)'@. This annotation provides the+-- given name of the port.+makeTopEntity :: Name -> DecsQ+makeTopEntity nam = pure <$> makeTopEntityWithName' nam Nothing
src/Clash/Annotations/TopEntity.hs view
@@ -1,8 +1,9 @@ {-| Copyright  :  (C) 2015-2016, University of Twente,-                  2017     , Google Inc.+                  2017     , Google Inc.,+                  2021-2023, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  'TopEntity' annotations allow us to control hierarchy and naming aspects of the Clash compiler. We have the 'Synthesize' and 'TestBench' annotation.@@ -61,21 +62,41 @@ import Clash.Prelude import Clash.Intel.ClockGen -type Dom50 = Dom \"System\" 20000+-- Define a synthesis domain with a clock with a period of 20000 \/ps\/. Signal+-- coming from the reset button is low when pressed, and high when not pressed.+'Clash.Explicit.Signal.createDomain'+  vSystem{vName=\"DomInput\", vPeriod=20000, vResetPolarity=ActiveLow}+-- Define a synthesis domain with a clock with a period of 50000 \/ps\/.+'Clash.Explicit.Signal.createDomain' vSystem{vName=\"Dom50\", vPeriod=50000}  topEntity-  :: Clock Dom50-  -> Reset Dom50+  :: Clock DomInput+  -> Reset DomInput+  -> Enable Dom50   -> Signal Dom50 Bit   -> Signal Dom50 (BitVector 8)-topEntity clk rst key1 =-    let  (pllOut,pllStable) = 'Clash.Intel.ClockGen.altpll' (SSymbol @ "altpll50") clk rst-         rstSync            = 'Clash.Signal.resetSynchronizer' pllOut ('Clash.Signal.unsafeToAsyncReset' pllStable)-    in   'Clash.Signal.exposeClockResetEnable' leds pllOut rstSync-  where-    key1R  = 'Clash.Prelude.isRising' 1 key1-    leds   = 'Clash.Prelude.mealy' blinkerT (1,False,0) key1R+topEntity clk20 rstBtn enaBtn modeBtn =+  'Clash.Signal.exposeClockResetEnable'+    ('Clash.Prelude.mealy' blinkerT initialStateBlinkerT . 'Clash.Prelude.isRising' 1)+    clk50+    rst50+    enaBtn+    modeBtn+ where+  -- Start with the first LED turned on, in rotate mode, with the counter on zero+  initialStateBlinkerT = (1, False, 0) +  -- Instantiate a PLL: this stabilizes the incoming clock signal and releases+  -- the reset output when the signal is stable. We're also using it to+  -- transform an incoming clock signal running at 20 MHz to a clock signal+  -- running at 50 MHz. Since the signature of topEntity already specifies the+  -- Dom50 domain, we don't need any type signatures to specify the domain here.+  (clk50, rst50) = 'Clash.Intel.ClockGen.altpllSync' clk20 rstBtn++blinkerT+  :: (BitVector 8, Bool, Index 16650001)+  -> Bool+  -> ((BitVector 8, Bool, Index 16650001), BitVector 8) blinkerT (leds,mode,cntr) key1R = ((leds',mode',cntr'),leds)   where     -- clock frequency = 50e6  (50 MHz)@@ -94,37 +115,31 @@ @  The Clash compiler would normally generate the following-@blinker_topentity.vhdl@ file:--@--- Automatically generated VHDL-93-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.blinker_types.all;--entity blinker_topentity is-  port(-- clock-       input_0  : in std_logic;-       -- asynchronous reset: active high-       input_1  : in std_logic;-       input_2  : in std_logic_vector(0 downto 0);-       output_0 : out std_logic_vector(7 downto 0));-end;+@topEntity.vhdl@ file: -architecture structural of blinker_topentity is-begin-  blinker_topentity_0_inst : entity blinker_topentity_0-    port map-      (clk    => input_0-      ,rst    => input_1-      ,key1   => input_2-      ,result => output_0);-end;-@+> -- Automatically generated VHDL-93+> 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.Blinker_topEntity_types.all;+>+> entity topEntity is+>   port(-- clock+>        clk20   : in Blinker_topEntity_types.clk_DomInput;+>        -- reset+>        rstBtn  : in Blinker_topEntity_types.rst_DomInput;+>        -- enable+>        enaBtn  : in Blinker_topEntity_types.en_Dom50;+>        modeBtn : in std_logic;+>        result  : out std_logic_vector(7 downto 0));+> end;+>+> architecture structural of topEntity is+>   ...+> end;  However, if we add the following 'Synthesize' annotation in the file: @@ -134,73 +149,70 @@     { t_name   = "blinker"     , t_inputs = [ PortName \"CLOCK_50\"                  , PortName \"KEY0\"-                 , PortName \"KEY1\" ]+                 , PortName \"KEY1\"+                 , PortName \"KEY2\" ]     , t_output = PortName \"LED\"     }) \#-\} @  The Clash compiler will generate the following @blinker.vhdl@ file instead: -@--- Automatically generated VHDL-93-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.blinker_types.all;--entity blinker is-  port(-- clock-       CLOCK_50 : in std_logic;-       -- asynchronous reset: active high-       KEY0     : in std_logic;-       KEY1     : in std_logic_vector(0 downto 0);-       LED      : out std_logic_vector(7 downto 0));-end;--architecture structural of blinker is-begin-  blinker_topentity_inst : entity blinker_topentity-    port map-      (clk    => CLOCK_50-      ,rst    => KEY0-      ,key1   => KEY1-      ,result => LED);-end;-@+> -- Automatically generated VHDL-93+> 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.blinker_types.all;+>+> entity blinker is+>   port(-- clock+>        CLOCK_50 : in blinker_types.clk_DomInput;+>        -- reset+>        KEY0     : in blinker_types.rst_DomInput;+>        -- enable+>        KEY1     : in blinker_types.en_Dom50;+>        KEY2     : in std_logic;+>        LED      : out std_logic_vector(7 downto 0));+> end;+>+> architecture structural of blinker is+>   ...+> end;  Where we now have:  * A top-level component that is called @blinker@.-* Inputs and outputs that have a /user/-chosen name: @CLOCK_50@, @KEY0@, @KEY1@, @LED@, etc.+* Inputs and outputs that have a /user/-chosen name: @CLOCK_50@, @KEY0@, @KEY1@, @KEY2@, @LED@, etc.  See the documentation of 'Synthesize' for the meaning of all its fields.  === 'TestBench' annotation -Tell what binder is the 'TestBench' for a 'Synthesize'-annotated binder.--So in the following example, /f/ has a 'Synthesize' annotation, and /g/ is-the HDL test bench for /f/.+Tell what binder is the test bench for a 'Synthesize'-annotated binder.  @-f :: Bool -> Bool-f = ...-{\-\# ANN f (defSyn "f") \#-\}-{\-\# ANN f (TestBench \'g) \#-\}+entityBeingTested :: ...+entityBeingTested = ...+{\-\# NOINLINE entityBeingTested \#-\}+{\-\# ANN entityBeingTested (defSyn "entityBeingTested") \#-\} -g :: Signal Bool-g = ...++myTestBench :: Signal System Bool+myTestBench = ... entityBeingTested ...+{\-\# NOINLINE myTestBench \#-\}+{\-\# ANN myTestBench (TestBench \'entityBeingTested) \#-\} @ +The 'TestBench' annotation actually already implies a 'Synthesize' annotation on+the device under test, so the 'defSyn' in the example could have been omitted.+We recommend you supply 'defSyn' explicitly nonetheless. In any case, it will+still need the @NOINLINE@ annotation. -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE DeriveLift         #-}-+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskellQuotes #-}  {-# LANGUAGE Safe #-}@@ -218,7 +230,8 @@  import           GHC.Generics import qualified Language.Haskell.TH        as TH-import           Language.Haskell.TH.Syntax (Lift(lift))+import           Language.Haskell.TH.Syntax (Lift(..))+import           Language.Haskell.TH.Compat import           Data.Data  -- | TopEntity annotation@@ -240,20 +253,12 @@   }   -- | Tell what binder is the 'TestBench' for a 'Synthesize'-annotated binder.   ---  -- So in the following example, /f/ has a 'Synthesize' annotation, and /g/ is-  -- the HDL test bench for /f/.-  --   -- @-  -- f :: Bool -> Bool-  -- f = ...-  -- {\-\# ANN f (defSyn "f") \#-\}-  -- {\-\# ANN f (TestBench \'g) \#-\}-  ---  -- g :: Signal Bool-  -- g = ...+  -- {\-\# NOINLINE myTestBench \#-\}+  -- {\-\# ANN myTestBench (TestBench \'entityBeingTested) \#-\}   -- @   | TestBench TH.Name-  deriving (Data,Show,Generic)+  deriving (Eq,Data,Show,Generic)  instance Lift TopEntity where   lift (Synthesize name inputs output) =@@ -264,6 +269,7 @@       , lift output       ]   lift (TestBench _) = error "Cannot lift a TestBench"+  liftTyped = liftTypedFromUntyped  -- | Give port names for arguments/results. --@@ -272,28 +278,24 @@ -- @ -- data T = MkT Int Bool ----- {\-\# ANN topEntity (defSyn "f") \#-\}+-- {\-\# ANN f (defSyn "f") \#-\} -- f :: Int -> T -> (T,Bool) -- f a b = ... -- @ -- -- Clash would normally generate the following VHDL entity: ----- @--- entity f is---   port(input_0      : in signed(63 downto 0);---        input_1_0    : in signed(63 downto 0);---        input_1_1    : in boolean;---        output_0_0_0 : out signed(63 downto 0);---        output_0_0_1 : out boolean;---        output_0_1   : out boolean);--- end;--- @+-- > entity f is+-- >   port(a      : in signed(63 downto 0);+-- >        b_0    : in signed(63 downto 0);+-- >        b_1    : in boolean;+-- >        result : out std_logic_vector(65 downto 0));+-- > end; -- -- However, we can change this by using 'PortName's. So by: -- -- @--- {\-\# ANN topEntity+-- {\-\# ANN f --    (Synthesize --       { t_name   = "f" --       , t_inputs = [ PortName \"a\"@@ -305,18 +307,16 @@ -- -- we get: ----- @--- entity f is---   port(a   : in signed(63 downto 0);---        b   : in f_types.t;---        res : out f_types.tup2);--- end;--- @+-- > entity f is+-- >   port(a   : in signed(63 downto 0);+-- >        b   : in std_logic_vector(64 downto 0);+-- >        res : out std_logic_vector(65 downto 0));+-- > end; -- -- If we want to name fields for tuples/records we have to use 'PortProduct' -- -- @--- {\-\# ANN topEntity+-- {\-\# ANN f --    (Synthesize --       { t_name   = "f" --       , t_inputs = [ PortName \"a\"@@ -328,15 +328,13 @@ -- -- So that we get: ----- @--- entity f is---   port(a     : in signed(63 downto 0);---        b     : in signed(63 downto 0);---        c     : in boolean;---        q     : out f_types.t;---        res_1 : out boolean);--- end;--- @+-- > entity f is+-- >   port(a     : in signed(63 downto 0);+-- >        b     : in signed(63 downto 0);+-- >        c     : in boolean;+-- >        res_q : out std_logic_vector(64 downto 0);+-- >        res_1 : out boolean);+-- > end; -- -- Notice how we didn't name the second field of the result, and the second -- output port got 'PortProduct' name, \"res\", as a prefix for its name.@@ -344,7 +342,7 @@   = PortName String   -- ^ You want a port, with the given name, for the entire argument\/type   ---  -- You can use an empty String ,\"\" , in case you want an auto-generated name.+  -- You can use an empty String ,@""@ , in case you want an auto-generated name.   | PortProduct String [PortName]   -- ^ You want to assign ports to fields of a product argument\/type   --@@ -354,8 +352,8 @@   --   -- 2. The prefix for any unnamed ports below the 'PortProduct'   ---  -- You can use an empty String ,\"\" , in case you want an auto-generated name.-  deriving (Data,Show,Generic,Lift)+  -- You can use an empty String ,@""@ , in case you want an auto-generated name.+  deriving (Eq,Data,Show,Generic,Lift)  -- | Default 'Synthesize' annotation which has no specified names for the input -- and output ports.
src/Clash/CPP.hs view
@@ -1,19 +1,62 @@ {-|-Copyright  :  (C) 2019, Myrtle Software Ltd+Copyright  :  (C) 2019     , Myrtle Software Ltd,+                  2023     , QBayLogic B.V., License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# LANGUAGE CPP#-}-{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE CPP #-} -#ifndef MAX_TUPLE_SIZE-#define MAX_TUPLE_SIZE 62-#endif+{-# OPTIONS_HADDOCK hide #-}  module Clash.CPP  ( maxTupleSize+ , haddockOnly++ -- ** Cabal flags+ , fSuperStrict+ , fStrictMapSignal  ) where +#ifndef MAX_TUPLE_SIZE+#ifdef LARGE_TUPLES++import GHC.Settings.Constants (mAX_TUPLE_SIZE)+#define MAX_TUPLE_SIZE (fromIntegral mAX_TUPLE_SIZE)++#else+#ifdef HADDOCK_ONLY+#define MAX_TUPLE_SIZE 3+#else+#define MAX_TUPLE_SIZE 12+#endif+#endif+#endif+ maxTupleSize :: Num a => a maxTupleSize = MAX_TUPLE_SIZE++haddockOnly :: Bool+#ifdef HADDOCK_ONLY+haddockOnly = True+#else+haddockOnly = False+#endif++-- | Whether clash-prelude was compiled with -fsuper-strict+fSuperStrict :: Bool+#ifdef CLASH_SUPER_STRICT+fSuperStrict = True+#else+fSuperStrict = False+#endif+{-# INLINE fSuperStrict #-}++-- | Whether clash-prelude was compiled with -fstrict-mapSignal+fStrictMapSignal :: Bool+#ifdef CLASH_STRICT_MAPSIGNAL+fStrictMapSignal = True+#else+fStrictMapSignal = False+#endif+{-# INLINE fStrictMapSignal #-}
+ src/Clash/Class/AutoReg.hs view
@@ -0,0 +1,13 @@+{-|+  Copyright   :  (C) 2019, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++module Clash.Class.AutoReg+  ( AutoReg (autoReg)+  , deriveAutoReg+  ) where++import Clash.Class.AutoReg.Internal+import Clash.Class.AutoReg.Instances ()
+ src/Clash/Class/AutoReg/Instances.hs view
@@ -0,0 +1,28 @@+{-|+  Copyright   :  (C) 2019, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}+{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -Wno-orphans #-}+-- {-# OPTIONS_GHC -ddump-splices #-}++module Clash.Class.AutoReg.Instances where++import           Clash.Class.AutoReg.Internal+import           Clash.CPP                           (maxTupleSize)++import           Data.Complex (Complex)+import           Data.Ord (Down)+import           Data.Ratio (Ratio)++deriveAutoReg ''Complex+deriveAutoReg ''Down+deriveAutoReg ''Ratio++-- | __NB__: The documentation only shows instances up to /3/-tuples. By+-- default, instances up to and including /12/-tuples will exist. If the flag+-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The+-- GHC imposed limit is either 62 or 64 depending on the GHC version.+deriveAutoRegTuples [2..maxTupleSize]
+ src/Clash/Class/AutoReg/Internal.hs view
@@ -0,0 +1,466 @@+{-|+  Copyright   :  (C) 2019     , Google Inc.,+                     2021-2022, QBayLogic B.V.,+                     2021-2022, Myrtle.ai+  License     :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- needed for constraint on the Fixed instance++module Clash.Class.AutoReg.Internal+  ( AutoReg (..)+  , deriveAutoReg+  , deriveAutoRegTuples+  )+  where++import           Data.List                    (nub,zipWith4)+import           Data.Maybe                   (fromMaybe,isJust)++import           GHC.Stack                    (HasCallStack)+import           GHC.TypeNats                 (KnownNat,Nat,type (+))+import           Clash.Explicit.Signal+import           Clash.Promoted.Nat+import           Clash.Magic+import           Clash.XException             (NFDataX, deepErrorX)++import           Clash.Sized.BitVector+import           Clash.Sized.Fixed+import           Clash.Sized.Index+import           Clash.Sized.RTree+import           Clash.Sized.Signed+import           Clash.Sized.Unsigned+import           Clash.Sized.Vector           (Vec, lazyV, smap)++import           Data.Int+import           Data.Word+import           Foreign.C.Types              (CUShort)+import           Numeric.Half                 (Half)++import           Language.Haskell.TH.Datatype+import           Language.Haskell.TH.Syntax+import           Language.Haskell.TH.Lib+import           Language.Haskell.TH.Ppr++import           Control.Lens.Internal.TH     (conAppsT)++-- $setup+-- >>> import Data.Maybe+-- >>> import Clash.Prelude+-- >>> :set -fplugin GHC.TypeLits.Normalise+-- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver++-- | 'autoReg' is a "smart" version of 'register'. It does two things:+--+--   1. It splits product types over their fields. For example, given a 3-tuple,+--   the corresponding HDL will end up with three instances of a register (or+--   more if the three fields can be split up similarly).+--+--   2. Given a data type where a constructor indicates (parts) of the data will+--   (not) be updated a given cycle, it will split the data in two parts. The+--   first part will contain the "always interesting" parts (the constructor+--   bits). The second holds the "potentially uninteresting" data (the rest).+--   Both parts will be stored in separate registers. The register holding the+--   "potentially uninteresting" part will only be enabled if the constructor+--   bits indicate they're interesting.+--+--   The most important example of this is 'Maybe'. Consider @Maybe (Signed 16)@;+--   when viewed as bits, a 'Nothing' would look like:+--+--     >>> pack @(Maybe (Signed 16)) Nothing+--     0b0_...._...._...._....+--+--   and 'Just'+--+--     >>> pack @(Maybe (Signed 16)) (Just 3)+--     0b1_0000_0000_0000_0011+--+--   In the first case, Nothing, we don't particularly care about updating the+--   register holding the @Signed 16@ field, as they'll be unknown anyway. We+--   can therefore deassert its enable line.+--+-- Making Clash lay it out like this increases the chances of synthesis tools+-- clock gating the registers, saving energy.+--+-- This version of 'autoReg' will split the given data type up recursively. For+-- example, given @a :: Maybe (Maybe Int, Maybe Int)@, a total of five registers+-- will be rendered. Both the "interesting" and "uninteresting" enable lines of+-- the inner Maybe types will be controlled by the outer one, in addition to+-- the inner parts controlling their "uninteresting" parts as described in (2).+--+-- The default implementation is just 'register'. If you don't need or want+-- the special features of "AutoReg", you can use that by writing an empty instance.+--+-- > data MyDataType = ...+-- > instance AutoReg MyDataType+--+-- If you have a product type you can use 'deriveAutoReg' to derive an instance.+--+class NFDataX a => AutoReg a where+  -- | For documentation see class 'AutoReg'.+  --+  -- This is the version with explicit clock\/reset\/enable inputs,+  -- "Clash.Prelude" exports an implicit version of this: 'Clash.Prelude.autoReg'+  autoReg+    :: (HasCallStack, KnownDomain dom)+    => Clock dom -> Reset dom -> Enable dom+    -> a  -- ^ Reset value+    -> Signal dom a+    -> Signal dom a+  autoReg = register+  {-# INLINE autoReg #-}++instance AutoReg ()+instance AutoReg Bool++instance AutoReg Double+instance AutoReg Float+instance AutoReg CUShort+instance AutoReg Half++instance AutoReg Char++instance AutoReg Integer+instance AutoReg Int+instance AutoReg Int8+instance AutoReg Int16+instance AutoReg Int32+instance AutoReg Int64+instance AutoReg Word+instance AutoReg Word8+instance AutoReg Word16+instance AutoReg Word32+instance AutoReg Word64++instance AutoReg Bit+instance KnownNat n => AutoReg (BitVector n)+instance AutoReg (Signed n)+instance AutoReg (Unsigned n)+instance AutoReg (Index n)+instance NFDataX (rep (int + frac)) => AutoReg (Fixed rep int frac)++instance AutoReg a => AutoReg (Maybe a) where+  autoReg clk rst en initVal input =+    createMaybe <$> tagR <*> valR+   where+     tag = isJust <$> input+     tagInit = isJust initVal+     tagR = register clk rst en tagInit tag++     val = fromMaybe (deepErrorX "autoReg'.val") <$> input+     valInit = fromMaybe (deepErrorX "autoReg'.valInit") initVal++     valR = autoReg clk rst (andEnable en tag) valInit val++     createMaybe t v = case t of+       True -> Just v+       False -> Nothing+  {-# INLINE autoReg #-}++instance (KnownNat n, AutoReg a) => AutoReg (Vec n a) where+  autoReg+    :: forall dom. (HasCallStack, KnownDomain dom)+    => Clock dom -> Reset dom -> Enable dom+    -> Vec n a -- ^ Reset value+    -> Signal dom (Vec n a)+    -> Signal dom (Vec n a)+  autoReg clk rst en initVal xs =+    bundle $ smap go (lazyV initVal) <*> unbundle xs+   where+    go :: forall (i :: Nat). SNat i -> a  -> Signal dom a -> Signal dom a+    go SNat = suffixNameFromNatP @i . autoReg clk rst en+  {-# INLINE autoReg #-}++instance (KnownNat d, AutoReg a) => AutoReg (RTree d a) where+  autoReg clk rst en initVal xs =+    bundle $ (autoReg clk rst en) <$> lazyT initVal <*> unbundle xs+  {-# INLINE autoReg #-}+++-- | Decompose an applied type into its individual components. For example, this:+--+-- @+-- Either Int Char+-- @+--+-- would be unfolded to this:+--+-- @+-- ('ConT' ''Either, ['ConT' ''Int, 'ConT' ''Char])+-- @+--+-- This function ignores explicit parentheses and visible kind applications.+--+-- NOTE: Copied from "Control.Lens.Internal.TH".+-- TODO: Remove this function. Can be removed once we can upgrade to lens 4.18.+-- TODO: This is currently difficult due to issue with nix.+unfoldType :: Type -> (Type, [Type])+unfoldType = go []+  where+    go :: [Type] -> Type -> (Type, [Type])+    go acc (ForallT _ _ ty) = go acc ty+    go acc (AppT ty1 ty2)   = go (ty2:acc) ty1+    go acc (SigT ty _)      = go acc ty+    go acc (ParensT ty)     = go acc ty+    go acc (AppKindT ty _)  = go acc ty+    go acc ty               = (ty, acc)++-- | Automatically derives an 'AutoReg' instance for a product type+--+-- Usage:+--+-- > data Pair a b = MkPair { getA :: a, getB :: b } deriving (Generic, NFDataX)+-- > data Tup3 a b c = MkTup3 { getAB :: Pair a b, getC :: c } deriving (Generic, NFDataX)+-- > deriveAutoReg ''Pair+-- > deriveAutoReg ''Tup3+--+-- __NB__: Because of the way template haskell works the order here matters,+-- if you try to @deriveAutoReg ''Tup3@ before @Pair@ it will complain+-- about missing an @instance AutoReg (Pair a b)@.+deriveAutoReg :: Name -> DecsQ+deriveAutoReg tyNm = do+  tyInfo <- reifyDatatype tyNm+  case datatypeCons tyInfo of+    [] -> fail "Can't deriveAutoReg for empty types"+    [conInfo] -> deriveAutoRegProduct tyInfo conInfo+    _ -> fail "Can't deriveAutoReg for sum types"++++{-+For a type like:+   data Product a b .. = MkProduct { getA :: a, getB :: b, .. }+This generates the following instance:++instance (AutoReg a, AutoReg b, ..) => AutoReg (Product a b ..) where+  autoReg clk rst en initVal input =+    MkProduct <$> sig0 <*> sig1 ...+    where+      field0 = (\(MkProduct x _ ...) -> x) <$> input+      field1 = (\(MkProduct _ x ...) -> x) <$> input+      ...+      MkProduct initVal0 initVal1 ... = initVal+      sig0 = suffixNameP @"getA" autoReg clk rst en initVal0 field0+      sig1 = suffixNameP @"getB" autoReg clk rst en initVal1 field1+      ...+-}+deriveAutoRegProduct :: DatatypeInfo -> ConstructorInfo -> DecsQ+deriveAutoRegProduct tyInfo conInfo = go (constructorName conInfo) fieldInfos+ where+  tyNm = datatypeName tyInfo+  tyArgs = datatypeInstTypes tyInfo+  ty = conAppsT tyNm tyArgs++  fieldInfos =+    zip fieldNames (constructorFields conInfo)+   where+    fieldNames =+      case constructorVariant conInfo of+        RecordConstructor nms -> map Just nms+        _ -> repeat Nothing++  go :: Name -> [(Maybe Name,Type)] -> Q [Dec]+  go dcNm fields = do+    clkN     <- newName "clk"+    rstN     <- newName "rst"+    enN      <- newName "en"+    initValN <- newName "initVal"+    inputN   <- newName "input"+    let+      initValE = varE initValN+      inputE = varE inputN+      argsP = map varP [clkN, rstN, enN, initValN, inputN]+      fieldNames = map fst fields++      field :: Name -> Int -> DecQ+      field nm nr =+        valD (varP nm) (normalB [| $fieldSel <$> $inputE |]) []+       where+        fieldSel = do+          xNm <- newName "x"+          let fieldP = [ if nr == n then varP xNm else wildP+                       | (n,_) <- zip [0..] fields]+          lamE [conP dcNm fieldP] (varE xNm)   -- "\(Dc _ _ .. x _ ..) -> x"++    parts <- generateNames "field" fields+    fieldDecls <- sequence $ zipWith field parts [0..]+    sigs <- generateNames "sig" fields+    initVals <- generateNames "initVal" fields+    let initPat = conP dcNm (map varP initVals)+    initDecl <- valD initPat (normalB initValE) []++    let+      clkE = varE clkN+      rstE = varE rstN+      enE  = varE enN+      genAutoRegDecl :: PatQ -> ExpQ -> ExpQ -> Maybe Name -> DecsQ+      genAutoRegDecl s v i nameM =+        [d| $s = $nameMe autoReg $clkE $rstE $enE $i $v |]+       where+        nameMe = case nameM of+          Nothing -> [| id |]+          Just nm -> let nmSym = litT $ strTyLit (nameBase nm)+                     in [| suffixNameP @($nmSym) |]++    partDecls <- concat <$> (sequence $ zipWith4 genAutoRegDecl+                                                 (varP <$> sigs)+                                                 (varE <$> parts)+                                                 (varE <$> initVals)+                                                 (fieldNames)+                            )+    let+        decls :: [DecQ]+        decls = map pure (initDecl : fieldDecls ++ partDecls)+        tyConE = conE dcNm+        body =+          case map varE sigs of+            (sig0:rest) -> foldl+                             (\acc sigN -> [| $acc <*> $sigN |])+                             [| $tyConE <$> $sig0 |]+                             rest+            [] -> [| $tyConE |]++    autoRegDec <- funD 'autoReg [clause argsP (normalB body) decls]+    ctx <- calculateRequiredContext conInfo+    return [InstanceD Nothing ctx (AppT (ConT ''AutoReg) ty)+              [ autoRegDec+              , PragmaD (InlineP 'autoReg Inline FunLike AllPhases) ]]++-- Calculate the required constraint to call autoReg on all the fields of a+-- given constructor+calculateRequiredContext :: ConstructorInfo -> Q Cxt+calculateRequiredContext conInfo = do+  let fieldTys = constructorFields conInfo+  wantedInstances <- mapM (\ty -> constraintsWantedFor ''AutoReg [ty]) (nub fieldTys)+  return $ nub (concat wantedInstances)++constraintsWantedFor :: Name -> [Type] -> Q Cxt+constraintsWantedFor clsNm tys+  | show clsNm == "GHC.TypeNats.KnownNat" = do+  -- KnownNat is special, you can't just lookup instances with reifyInstances.+  -- So we just pass KnownNat constraints.+  -- This will most likely require UndecidableInstances.+    return [conAppsT clsNm tys]++constraintsWantedFor clsNm [ty] = case ty of+  VarT _ -> return [AppT (ConT clsNm) ty]+  ConT _ -> return []+  _ -> do+    insts <- reifyInstances clsNm [ty]+    case insts of+      [InstanceD _ cxtInst (AppT autoRegCls instTy) _]+        | autoRegCls == ConT clsNm -> do+          let substs = findTyVarSubsts instTy ty+              cxt2 = map (applyTyVarSubsts substs) cxtInst+              okCxt = filter isOk cxt2+              recurseCxt = filter needRecurse cxt2+          recursed <- mapM recurse recurseCxt+          return (okCxt ++ concat recursed)+      []      -> fail $ "Missing instance " ++ show clsNm ++ " (" ++ pprint ty ++ ")"+      (_:_:_) -> fail $ "There are multiple " ++ show clsNm ++ " instances for "+                     ++ pprint ty ++ ":\n" ++ pprint insts+      _ -> fail $ "Got unexpected instance: " ++ pprint insts+ where+  isOk :: Type -> Bool+  isOk (unfoldType -> (_cls,tys)) =+    case tys of+      [VarT _] -> True+      [_] -> False+      _ -> True -- see [NOTE: MultiParamTypeClasses]+  needRecurse :: Type -> Bool+  needRecurse (unfoldType -> (cls,tys)) =+    case tys of+      [AppT _ _] -> True+      [VarT _] -> False  -- gets copied by "filter isOk" above+      [ConT _] -> False  -- we can just drop constraints like: "AutoReg Bool => ..."+      [LitT _] -> False  -- or "KnownNat 4 =>"+      [TupleT 0] -> False  -- handle Unit ()+      [_] -> error ( "Error while deriveAutoReg: don't know how to handle: "+                  ++ pprint cls ++ " (" ++ pprint tys ++ ")" )+      _ -> False  -- see [NOTE: MultiParamTypeClasses]++  recurse :: Type -> Q Cxt+  recurse (unfoldType -> (ConT cls,tys)) = constraintsWantedFor cls tys+  recurse t =+    fail ("Expected a class applied to some arguments but got " ++ pprint t)++constraintsWantedFor clsNm tys =+  return [conAppsT clsNm tys] -- see [NOTE: MultiParamTypeClasses]++-- [NOTE: MultiParamTypeClasses]+-- The constraint calculation code doesn't handle MultiParamTypeClasses+-- "properly", but it will try to pass them on, so the resulting instance should+-- still compile with UndecidableInstances enabled.+++-- | Find tyVar substitutions between a general type and a second possibly less+-- general type. For example:+--+-- @+-- findTyVarSubsts "Either a b" "Either c [Bool]"+--   == "[(a,c), (b,[Bool])]"+-- @+findTyVarSubsts :: Type -> Type -> [(Name,Type)]+findTyVarSubsts = go+ where+  go ty1 ty2 = case (ty1,ty2) of+    (VarT nm1       , VarT nm2) | nm1 == nm2 -> []+    (VarT nm        , t)                     -> [(nm,t)]+    (ConT _         , ConT _)                -> []+    (AppT x1 y1     , AppT x2 y2)            -> go x1 x2 ++ go y1 y2+    (SigT t1 k1     , SigT t2 k2)            -> go t1 t2 ++ go k1 k2+    (InfixT x1 _ y1 , InfixT x2 _ y2)        -> go x1 x2 ++ go y1 y2+    (UInfixT x1 _ y1, UInfixT x2 _ y2)       -> go x1 x2 ++ go y1 y2+    (ParensT x1     , ParensT x2)            -> go x1 x2+    (AppKindT t1 k1     , AppKindT t2 k2)      -> go t1 t2 ++ go k1 k2+    (ImplicitParamT _ x1, ImplicitParamT _ x2) -> go x1 x2+    (PromotedT _          , PromotedT _          ) -> []+    (TupleT _             , TupleT _             ) -> []+    (UnboxedTupleT _      , UnboxedTupleT _      ) -> []+    (UnboxedSumT _        , UnboxedSumT _        ) -> []+    (ArrowT               , ArrowT               ) -> []+    (EqualityT            , EqualityT            ) -> []+    (ListT                , ListT                ) -> []+    (PromotedTupleT _     , PromotedTupleT _     ) -> []+    (PromotedNilT         , PromotedNilT         ) -> []+    (PromotedConsT        , PromotedConsT        ) -> []+    (StarT                , StarT                ) -> []+    (ConstraintT          , ConstraintT          ) -> []+    (LitT _               , LitT _               ) -> []+    (WildCardT            , WildCardT            ) -> []+    _ -> error $ unlines [ "findTyVarSubsts: Unexpected types"+                         , "ty1:", pprint ty1,"ty2:", pprint ty2]++applyTyVarSubsts :: [(Name,Type)] -> Type -> Type+applyTyVarSubsts substs ty = go ty+  where+    go ty' = case ty' of+      VarT n -> case lookup n substs of+                  Nothing -> ty'+                  Just m  -> m+      ConT _ -> ty'+      AppT ty1 ty2 -> AppT (go ty1) (go ty2)+      LitT _ -> ty'+      _ -> error $ "TODO applyTyVarSubsts: " ++ show ty'+++-- | Generate a list of fresh Name's:+-- prefix0_.., prefix1_.., prefix2_.., ..+generateNames :: String -> [a] -> Q [Name]+generateNames prefix xs =+  sequence (zipWith (\n _ -> newName $ prefix ++ show @Int n) [0..] xs)++deriveAutoRegTuples :: [Int] -> DecsQ+deriveAutoRegTuples xs = concat <$> mapM deriveAutoRegTuple xs++deriveAutoRegTuple :: Int -> DecsQ+deriveAutoRegTuple n+  | n < 2 = fail $ "deriveAutoRegTuple doesn't work for " ++ show n ++ "-tuples"+  | otherwise = deriveAutoReg tupN+  where+    tupN = mkName $ "(" ++ replicate (n-1) ',' ++ ")"
src/Clash/Class/BitPack.hs view
@@ -1,411 +1,41 @@+ {-|-Copyright  :  (C) 2013-2016, University of Twente,+Copyright  :  (C) 2013-2016, University of Twente                   2016-2017, Myrtle Software Ltd+                       2021, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# LANGUAGE CPP                  #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE DefaultSignatures    #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE MagicHash            #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeApplications     #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns         #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}-{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}-{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}--#include "MachDeps.h"+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}  module Clash.Class.BitPack   ( BitPack (..)+  , isLike   , bitCoerce+  , bitCoerceMap   , boolToBV   , boolToBit   , bitToBool   , packXWith-  )-where -import Control.Exception              (catch, evaluate)-import Data.Binary.IEEE754            (doubleToWord, floatToWord, wordToDouble,-                                       wordToFloat)--#if MIN_VERSION_base(4,12,0)-import Data.Complex                   (Complex)-import Data.Ord                       (Down)-#endif--import Data.Int-import Data.Word-import Foreign.C.Types                (CUShort)-import GHC.TypeLits                   (KnownNat, Nat, type (+), type (-))-import Numeric.Half                   (Half (..))-import GHC.Generics-import GHC.TypeLits.Extra             (CLog, Max)-import Prelude                        hiding (map)-import System.IO.Unsafe               (unsafeDupablePerformIO)--import Clash.Promoted.Nat             (SNat(..), snatToNum)-import Clash.Class.BitPack.Internal   (deriveBitPackTuples)-import Clash.Class.Resize             (zeroExtend, resize)-import Clash.Sized.BitVector          (Bit, BitVector, (++#))-import Clash.Sized.Internal.BitVector-  (pack#, split#, checkUnpackUndef, undefined#, unpack#, unsafeToInteger)-import Clash.XException--{- $setup->>> :set -XDataKinds->>> import Clash.Prelude--}---- | Convert to and from a 'BitVector'-class BitPack a where-  -- | Number of 'Clash.Sized.BitVector.Bit's needed to represents elements-  -- of type @a@-  ---  -- Can be derived using `GHC.Generics`:-  ---  -- > import Clash.Prelude-  -- > import GHC.Generics-  -- >-  -- > data MyProductType = MyProductType { a :: Int, b :: Bool }-  -- >   deriving (Generic, BitPack)-  type BitSize a :: Nat-  type BitSize a = (CLog 2 (GConstructorCount (Rep a))) + (GFieldSize (Rep a))-  -- | Convert element of type @a@ to a 'BitVector'-  ---  -- >>> pack (-5 :: Signed 6)-  -- 11_1011-  pack   :: a -> BitVector (BitSize a)-  default pack-    :: ( Generic a-       , GBitPack (Rep a)-       , KnownNat (BitSize a)-       , KnownNat constrSize-       , KnownNat fieldSize-       , constrSize ~ CLog 2 (GConstructorCount (Rep a))-       , fieldSize ~ GFieldSize (Rep a)-       , (constrSize + fieldSize) ~ BitSize a-       )-    => a -> BitVector (BitSize a)-  pack = packXWith go-   where-    go a = resize (pack sc) ++# packedFields-     where-      (sc, packedFields) = gPackFields 0 (from a)--  -- | Convert a 'BitVector' to an element of type @a@-  ---  -- >>> pack (-5 :: Signed 6)-  -- 11_1011-  -- >>> let x = pack (-5 :: Signed 6)-  -- >>> unpack x :: Unsigned 6-  -- 59-  -- >>> pack (59 :: Unsigned 6)-  -- 11_1011-  unpack :: BitVector (BitSize a) -> a-  default unpack-    :: ( Generic a-       , GBitPack (Rep a)-       , KnownNat constrSize-       , KnownNat fieldSize-       , constrSize ~ CLog 2 (GConstructorCount (Rep a))-       , fieldSize ~ GFieldSize (Rep a)-       , (constrSize + fieldSize) ~ BitSize a-       )-    => BitVector (BitSize a) -> a-  unpack b =-    to (gUnpack sc 0 bFields)-   where-    (checkUnpackUndef unpack . resize -> sc, bFields) = split# b--packXWith-  :: KnownNat n-  => (a -> BitVector n)-  -> a-  -> BitVector n-packXWith f x =-  unsafeDupablePerformIO (catch (f <$> evaluate x)-                                (\(XException _) -> return undefined#))-{-# NOINLINE packXWith #-}--{-# INLINE bitCoerce #-}--- | Coerce a value from one type to another through its bit representation.------ >>> pack (-5 :: Signed 6)--- 11_1011--- >>> bitCoerce (-5 :: Signed 6) :: Unsigned 6--- 59--- >>> pack (59 :: Unsigned 6)--- 11_1011-bitCoerce :: (BitPack a, BitPack b, BitSize a ~ BitSize b)-          => a-          -> b-bitCoerce = unpack . pack--instance BitPack Bool where-  type BitSize Bool = 1-  pack   = let go b = if b then 1 else 0 in packXWith go-  unpack = checkUnpackUndef $ \bv -> if bv == 1 then True else False--instance KnownNat n => BitPack (BitVector n) where-  type BitSize (BitVector n) = n-  pack     = packXWith id-  unpack v = v--instance BitPack Bit where-  type BitSize Bit = 1-  pack   = packXWith pack#-  unpack = unpack#--instance BitPack Int where-  type BitSize Int = WORD_SIZE_IN_BITS-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Int8 where-  type BitSize Int8 = 8-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Int16 where-  type BitSize Int16 = 16-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Int32 where-  type BitSize Int32 = 32-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--#if WORD_SIZE_IN_BITS >= 64-instance BitPack Int64 where-  type BitSize Int64 = 64-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral-#endif--instance BitPack Word where-  type BitSize Word = WORD_SIZE_IN_BITS-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Word8 where-  type BitSize Word8 = 8-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Word16 where-  type BitSize Word16 = 16-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Word32 where-  type BitSize Word32 = 32-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--#if WORD_SIZE_IN_BITS >= 64-instance BitPack Word64 where-  type BitSize Word64 = 64-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral-#endif--instance BitPack Float where-  type BitSize Float = 32-  pack   = packXWith packFloat#-  unpack = checkUnpackUndef unpackFloat#--packFloat# :: Float -> BitVector 32-packFloat# = fromIntegral . floatToWord-{-# NOINLINE packFloat# #-}--unpackFloat# :: BitVector 32 -> Float-unpackFloat# = wordToFloat . fromInteger . unsafeToInteger-{-# NOINLINE unpackFloat# #-}--instance BitPack Double where-  type BitSize Double = 64-  pack   = packXWith packDouble#-  unpack = checkUnpackUndef unpackDouble#--packDouble# :: Double -> BitVector 64-packDouble# = fromIntegral . doubleToWord-{-# NOINLINE packDouble# #-}--unpackDouble# :: BitVector 64 -> Double-unpackDouble# = wordToDouble . fromInteger . unsafeToInteger-{-# NOINLINE unpackDouble# #-}--instance BitPack CUShort where-  type BitSize CUShort = 16-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Half where-  type BitSize Half = 16-  pack (Half x) = pack x-  unpack        = checkUnpackUndef $ \x -> Half (unpack x)--instance BitPack () where-  type BitSize () = 0-  pack   _ = minBound-  unpack _ = ()--instance (KnownNat (BitSize a), KnownNat (BitSize b), BitPack a, BitPack b) =>-    BitPack (a,b) where-  type BitSize (a,b) = BitSize a + BitSize b-  pack = let go (a,b) = pack a ++# pack b in packXWith go-  unpack ab  = let (a,b) = split# ab in (unpack a, unpack b)--class GBitPack f where-  -- | Size of fields. If multiple constructors exist, this is the maximum of-  -- the sum of each of the constructors fields.-  type GFieldSize f :: Nat--  -- | Number of constructors this type has. Indirectly indicates how many bits-  -- are needed to represent the constructor.-  type GConstructorCount f :: Nat--  -- | Pack fields of a type. Caller should pack and prepend the constructor bits.-  gPackFields-    :: Int-    -- ^ Current constructor-    -> f a-    -- ^ Data to pack-    -> (Int, BitVector (GFieldSize f))-    -- ^ (Constructor number, Packed fields)--  -- | Unpack whole type.-  gUnpack-    :: Int-    -- ^ Construct with constructor /n/-    -> Int-    -- ^ Current constructor-    -> BitVector (GFieldSize f)-    -- ^ BitVector containing fields-    -> f a-    -- ^ Unpacked result--instance GBitPack a => GBitPack (M1 m d a) where-  type GFieldSize (M1 m d a) = GFieldSize a-  type GConstructorCount (M1 m d a) = GConstructorCount a--  gPackFields cc (M1 m1) = gPackFields cc m1-  gUnpack c cc b = M1 (gUnpack c cc b)--instance ( KnownNat (GFieldSize g)-         , KnownNat (GFieldSize f)-         , KnownNat (GConstructorCount f)-         , GBitPack f-         , GBitPack g-         ) => GBitPack (f :+: g) where-  type GFieldSize (f :+: g) = Max (GFieldSize f) (GFieldSize g)-  type GConstructorCount (f :+: g) = GConstructorCount f + GConstructorCount g--  gPackFields cc (L1 l) =-    let (sc, packed) = gPackFields cc l in-    let padding = undefined# :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize f) in-    (sc, packed ++# padding)-  gPackFields cc (R1 r) =-    let cLeft = snatToNum (SNat @(GConstructorCount f)) in-    let (sc, packed) = gPackFields (cc + cLeft) r in-    let padding = undefined# :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize g) in-    (sc, packed ++# padding)--  gUnpack c cc b =-    let cLeft = snatToNum (SNat @(GConstructorCount f)) in-    if c < cc + cLeft then-      L1 (gUnpack c cc f)-    else-      R1 (gUnpack c (cc + cLeft) g)--   where-    -- It's a thing of beauty, if I may say so myself!-    (f, _ :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize f)) = split# b-    (g, _ :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize g)) = split# b---instance (KnownNat (GFieldSize g), KnownNat (GFieldSize f), GBitPack f, GBitPack g) => GBitPack (f :*: g) where-  type GFieldSize (f :*: g) = GFieldSize f + GFieldSize g-  type GConstructorCount (f :*: g) = 1--  gPackFields cc fg =-    (cc, packXWith go fg)-   where-    go (l0 :*: r0) =-      let (_, l1) = gPackFields cc l0 in-      let (_, r1) = gPackFields cc r0 in-      l1 ++# r1--  gUnpack c cc b =-    gUnpack c cc front :*: gUnpack c cc back-   where-    (front, back) = split# b--instance BitPack c => GBitPack (K1 i c) where-  type GFieldSize (K1 i c) = BitSize c-  type GConstructorCount (K1 i c)  = 1--  gPackFields cc (K1 i) = (cc, pack i)-  gUnpack _c _cc b      = K1 (unpack b)--instance GBitPack U1 where-  type GFieldSize U1 = 0-  type GConstructorCount U1 = 1--  gPackFields cc U1 = (cc, 0)-  gUnpack _c _cc _b = U1---- Instances derived using Generic-instance ( BitPack a-         , KnownNat (BitSize a)-         , BitPack b-         , KnownNat (BitSize b)-         ) => BitPack (Either a b)--instance ( BitPack a-         , KnownNat (BitSize a)-         ) => BitPack (Maybe a)--#if MIN_VERSION_base(4,12,0)-instance ( BitPack a-         , KnownNat (BitSize a)-         ) => BitPack (Complex a)--instance ( BitPack a-         , KnownNat (BitSize a)-         ) => BitPack (Down a)-#endif---- | Zero-extend a 'Bool'ean value to a 'BitVector' of the appropriate size.------ >>> boolToBV True :: BitVector 6--- 00_0001--- >>> boolToBV False :: BitVector 6--- 00_0000-boolToBV :: KnownNat n => Bool -> BitVector (n + 1)-boolToBV = zeroExtend . pack---- | Convert a Bool to a Bit-boolToBit :: Bool -> Bit-boolToBit = bitCoerce+  -- * Bit Indexing+  , (!)+  , slice+  , split+  , replaceBit+  , setSlice+  , msb+  , lsb --- | Convert a Bool to a Bit-bitToBool :: Bit -> Bool-bitToBool = bitCoerce+  -- * Bit Reduction+  , reduceAnd+  , reduceOr+  , reduceXor+  )+where --- Derive the BitPack instance for tuples of size 3 to 62-deriveBitPackTuples ''BitPack ''BitSize 'pack 'unpack+import Clash.Class.BitPack.Internal+import Clash.Class.BitPack.BitIndex+import Clash.Class.BitPack.BitReduction
+ src/Clash/Class/BitPack/BitIndex.hs view
@@ -0,0 +1,211 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente+                  2021-2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Class.BitPack.BitIndex where++import GHC.TypeLits                   (KnownNat, type (+), type (-))++import Clash.Class.BitPack.Internal   (BitPack (..))+import Clash.Promoted.Nat             (SNat (..))+import Clash.Sized.Internal.BitVector+  (BitVector, Bit, index#, lsb#, msb#, replaceBit#, setSlice#, slice#, split#)++{- $setup+>>> :set -XDataKinds+>>> import Clash.Prelude+-}++{-# INLINE (!) #-}+-- | Get the bit at the specified bit index.+--+-- __NB__: Bit indices are __DESCENDING__.+--+-- >>> pack (7 :: Unsigned 6)+-- 0b00_0111+-- >>> (7 :: Unsigned 6) ! 1+-- 1+-- >>> (7 :: Unsigned 6) ! 5+-- 0+-- >>> (7 :: Unsigned 6) ! 6+-- *** Exception: (!): 6 is out of range [0..5]+-- ...+(!) :: (BitPack a, Enum i) => a -> i -> Bit+(!) v i = index# (pack v) (fromEnum i)++{-# INLINE slice #-}+{- | Get a slice between bit index @m@ and and bit index @n@.++__NB__: Bit indices are __DESCENDING__.++>>> pack (7 :: Unsigned 6)+0b00_0111+>>> slice d4 d2 (7 :: Unsigned 6)+0b001++#if __GLASGOW_HASKELL__ >= 910+>>> slice d6 d4 (7 :: Unsigned 6)+<interactive>:...+    • Couldn't match type ‘7 + i0’ with ‘6’+        arising from a use of ‘slice’+      The type variable ‘i0’ is ambiguous+    • In the expression: slice d6 d4 (7 :: Unsigned 6)+      In an equation for ‘it’: it = slice d6 d4 (7 :: Unsigned 6)+<BLANKLINE>++#elif __GLASGOW_HASKELL__ == 906+>>> slice d6 d4 (7 :: Unsigned 6)+<BLANKLINE>+<interactive>:...+    • Couldn't match type ‘7 + i0’ with ‘6’+        arising from a use of ‘slice’+        The type variable ‘i0’ is ambiguous+    • In the expression: slice d6 d4 (7 :: Unsigned 6)+      In an equation for ‘it’: it = slice d6 d4 (7 :: Unsigned 6)++#else+>>> slice d6 d4 (7 :: Unsigned 6)+<BLANKLINE>+<interactive>:...+    • Couldn't match type ‘7 + i0’ with ‘6’+        arising from a use of ‘slice’+      The type variable ‘i0’ is ambiguous+    • In the expression: slice d6 d4 (7 :: Unsigned 6)+      In an equation for ‘it’: it = slice d6 d4 (7 :: Unsigned 6)++#endif+-}+slice+  :: (BitPack a, BitSize a ~ ((m + 1) + i))+  => SNat m+  -> SNat n+  -> a+  -> BitVector (m + 1 - n)+slice m n v = slice# (pack v) m n++{-# INLINE split #-}+-- | Split a value of a bit size @m + n@ into a tuple of values with size @m@+-- and size @n@.+--+-- >>> pack (7 :: Unsigned 6)+-- 0b00_0111+-- >>> split (7 :: Unsigned 6) :: (BitVector 2, BitVector 4)+-- (0b00,0b0111)+split+  :: (BitPack a, BitSize a ~ (m + n), KnownNat n)+  => a+  -> (BitVector m, BitVector n)+split v = split# (pack v)++{-# INLINE replaceBit #-}+-- | Set the bit at the specified index+--+-- __NB__: Bit indices are __DESCENDING__.+--+-- >>> pack (-5 :: Signed 6)+-- 0b11_1011+-- >>> replaceBit 4 0 (-5 :: Signed 6)+-- -21+-- >>> pack (-21 :: Signed 6)+-- 0b10_1011+-- >>> replaceBit 5 0 (-5 :: Signed 6)+-- 27+-- >>> pack (27 :: Signed 6)+-- 0b01_1011+-- >>> replaceBit 6 0 (-5 :: Signed 6)+-- *** Exception: replaceBit: 6 is out of range [0..5]+-- ...+replaceBit :: (BitPack a, Enum i) => i -> Bit -> a -> a+replaceBit i b v = unpack (replaceBit# (pack v) (fromEnum i) b)++{-# INLINE setSlice #-}+{- | Set the bits between bit index @m@ and bit index @n@.++__NB__: Bit indices are __DESCENDING__.++>>> pack (-5 :: Signed 6)+0b11_1011+>>> setSlice d4 d3 0 (-5 :: Signed 6)+-29+>>> pack (-29 :: Signed 6)+0b10_0011++#if __GLASGOW_HASKELL__ >= 910+>>> setSlice d6 d5 0 (-5 :: Signed 6)+<interactive>:...+    • Couldn't match type ‘7 + i0’ with ‘6’+        arising from a use of ‘setSlice’+      The type variable ‘i0’ is ambiguous+    • In the expression: setSlice d6 d5 0 (- 5 :: Signed 6)+      In an equation for ‘it’: it = setSlice d6 d5 0 (- 5 :: Signed 6)+<BLANKLINE>++#elif __GLASGOW_HASKELL__ == 906+>>> setSlice d6 d5 0 (-5 :: Signed 6)+<BLANKLINE>+<interactive>:...+    • Couldn't match type ‘7 + i0’ with ‘6’+        arising from a use of ‘setSlice’+        The type variable ‘i0’ is ambiguous+    • In the expression: setSlice d6 d5 0 (- 5 :: Signed 6)+      In an equation for ‘it’: it = setSlice d6 d5 0 (- 5 :: Signed 6)++#else+>>> setSlice d6 d5 0 (-5 :: Signed 6)+<BLANKLINE>+<interactive>:...+    • Couldn't match type ‘7 + i0’ with ‘6’+        arising from a use of ‘setSlice’+      The type variable ‘i0’ is ambiguous+    • In the expression: setSlice d6 d5 0 (- 5 :: Signed 6)+      In an equation for ‘it’: it = setSlice d6 d5 0 (- 5 :: Signed 6)++#endif+-}+setSlice+  :: (BitPack a, BitSize a ~ ((m + 1) + i))+  => SNat m+  -> SNat n+  -> BitVector (m + 1 - n)+  -> a+  -> a+setSlice m n w v = unpack (setSlice# SNat (pack v) m n w)++{-# INLINE msb #-}+-- | Get the most significant bit.+--+-- >>> pack (-4 :: Signed 6)+-- 0b11_1100+-- >>> msb (-4 :: Signed 6)+-- 1+-- >>> pack (4 :: Signed 6)+-- 0b00_0100+-- >>> msb (4 :: Signed 6)+-- 0+msb :: BitPack a => a -> Bit+msb v = msb# (pack v)++{-# INLINE lsb #-}+-- | Get the least significant bit.+--+-- >>> pack (-9 :: Signed 6)+-- 0b11_0111+-- >>> lsb (-9 :: Signed 6)+-- 1+-- >>> pack (-8 :: Signed 6)+-- 0b11_1000+-- >>> lsb (-8 :: Signed 6)+-- 0+lsb :: BitPack a => a -> Bit+lsb v = lsb# (pack v)
+ src/Clash/Class/BitPack/BitReduction.hs view
@@ -0,0 +1,83 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2021,      QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleContexts #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Class.BitPack.BitReduction where++import Clash.Class.BitPack.Internal   (BitPack (..))+import Clash.Sized.Internal.BitVector (Bit, reduceAnd#, reduceOr#, reduceXor#)++{- $setup+>>> :set -XDataKinds+>>> import Clash.Prelude+-}++{-# INLINE reduceAnd #-}+-- | Are all bits set to '1'?+--+-- >>> pack (-2 :: Signed 6)+-- 0b11_1110+-- >>> reduceAnd (-2 :: Signed 6)+-- 0+-- >>> pack (-1 :: Signed 6)+-- 0b11_1111+-- >>> reduceAnd (-1 :: Signed 6)+-- 1+--+-- Zero width types will evaluate to '1':+--+-- >>> reduceAnd (0 :: Unsigned 0)+-- 1+reduceAnd :: BitPack a => a -> Bit+reduceAnd v = reduceAnd# (pack v)++{-# INLINE reduceOr #-}+-- | Is there at least one bit set to '1'?+--+-- >>> pack (5 :: Signed 6)+-- 0b00_0101+-- >>> reduceOr (5 :: Signed 6)+-- 1+-- >>> pack (0 :: Signed 6)+-- 0b00_0000+-- >>> reduceOr (0 :: Signed 6)+-- 0+--+-- Zero width types will evaluate to '0':+--+-- >>> reduceOr (0 :: Unsigned 0)+-- 0+reduceOr :: BitPack a => a -> Bit+reduceOr v = reduceOr# (pack v)++{-# INLINE reduceXor #-}+-- | Is the number of bits set to '1' uneven?+--+-- >>> pack (5 :: Signed 6)+-- 0b00_0101+-- >>> reduceXor (5 :: Signed 6)+-- 0+-- >>> pack (28 :: Signed 6)+-- 0b01_1100+-- >>> reduceXor (28 :: Signed 6)+-- 1+-- >>> pack (-5 :: Signed 6)+-- 0b11_1011+-- >>> reduceXor (-5 :: Signed 6)+-- 1+--+-- Zero width types will evaluate to '0':+--+-- >>> reduceXor (0 :: Unsigned 0)+-- 0+reduceXor :: BitPack a => a -> Bit+reduceXor v = reduceXor# (pack v)
src/Clash/Class/BitPack/Internal.hs view
@@ -1,102 +1,619 @@ {-|-Copyright  :  (C) 2019, QBayLogic B.V.+Copyright  :  (C) 2013-2016, University of Twente,+                  2016-2017, Myrtle Software Ltd,+                  2021-2026, QBayLogic B.V.,+                  2022,      Google Inc.+                  2023,      LumiGuide Fietsdetectie B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -}-{-# LANGUAGE CPP             #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -module Clash.Class.BitPack.Internal (deriveBitPackTuples) where+{-# LANGUAGE Trustworthy #-} -import           Clash.CPP             (maxTupleSize)-import           Language.Haskell.TH.Compat (mkTySynInstD)-import           Control.Monad         (replicateM)-import           Data.List             (foldl')-import           GHC.TypeLits          (KnownNat)-import           Language.Haskell.TH+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_HADDOCK show-extensions #-} --- | Contruct all the tuple (starting at size 3) instances for BitPack.-deriveBitPackTuples-  :: Name-  -- ^ BitPack-  -> Name-  -- ^ BitSize-  -> Name-  -- ^ pack-  -> Name-  -- ^ unpack-  -> DecsQ-deriveBitPackTuples bitPackName bitSizeName packName unpackName = do-  let bitPack  = ConT bitPackName-      bitSize  = ConT bitSizeName-      knownNat = ConT ''KnownNat-      plus     = ConT $ mkName "+"+#include "MachDeps.h" -  allNames <- replicateM maxTupleSize (newName "a")-  retupName <- newName "retup"-  x <- newName "x"-  y <- newName "y"-  tup <- newName "tup"+module Clash.Class.BitPack.Internal where -  pure $ flip map [3..maxTupleSize] $ \tupleNum ->-    let names  = take tupleNum allNames-        (v:vs) = fmap VarT names-        tuple xs = foldl' AppT (TupleT $ length xs) xs+import Prelude                        hiding (map) -        -- Instance declaration-        context =-          [ bitPack `AppT` v-          , knownNat `AppT` (bitSize `AppT` v)-          , bitPack `AppT` tuple vs-          , knownNat `AppT` (bitSize `AppT` tuple vs)-          ]-        instTy = AppT bitPack $ tuple (v:vs)+import Data.Binary.IEEE754            (doubleToWord, floatToWord, wordToDouble,+                                       wordToFloat) -        -- Associated type BitSize-        bitSizeType =-          mkTySynInstD bitSizeName [tuple (v:vs)]-            $ plus `AppT` (bitSize `AppT` v) `AppT`-              (bitSize `AppT` foldl AppT (TupleT $ tupleNum - 1) vs)+import Data.Char                      (chr, ord)+import Data.Complex                   (Complex)+import Data.Functor.Compose           (Compose)+import Data.Functor.Const             (Const)+import Data.Functor.Identity          (Identity)+import Data.Functor.Product           (Product)+import Data.Functor.Sum               (Sum)+import Data.Int+import Data.Ord                       (Down)+import Data.Proxy                     (Proxy)+import Data.Word+import Foreign.C.Types                (CUShort)+import GHC.Generics+import GHC.TypeLits                   (KnownNat, Nat, type (+), type (-))+import GHC.TypeLits.Extra             (CLog, Max)+import Numeric.Half                   (Half (..)) -        pack =-          FunD-            packName-            [ Clause-                [VarP tup]-                (NormalB (AppE (VarE packName) (AppE (VarE retupName) (VarE tup))))-                [FunD-                    retupName-                    [ Clause-                        [ TupP $ map VarP names ]-                        ( let (e:es) = map VarE names-                          in NormalB (TupE [e,TupE es])-                        )-                        []-                    ]-                ]-            ]+import Clash.Annotations.Primitive    (hasBlackBox)+import Clash.Class.BitPack.Internal.TH (deriveBitPackTuples)+import Clash.Class.Resize             (zeroExtend, resize)+import Clash.Promoted.Nat             (SNat(..), snatToNum)+import Clash.Sized.Internal.BitVector+  (pack#, split#, checkUnpackUndef, undefined#, unpack#, unsafeToNatural, isLike#,+   BitVector, Bit, (++#), xToBV) -        unpack =-          FunD-            unpackName-            [ Clause-                [ VarP x ]-                ( NormalB $-                    let (p:ps) = map VarP names-                    in-                    LetE-                      [ ValD-                          ( TupP [ p, VarP y ] )-                          ( NormalB $ VarE unpackName `AppE` VarE x )-                          []-                      , ValD-                          ( TupP ps )-                          ( NormalB $ VarE unpackName `AppE` VarE y )-                          []-                      ]-                      ( TupE $ map VarE names )-                )-                []-            ]+{- $setup+>>> :m -Prelude+>>> :set -XDataKinds+>>> import Clash.Prelude+>>> import Data.Proxy+-} -    in InstanceD Nothing context instTy [bitSizeType, pack, unpack]+-- | Convert data to/from a 'BitVector'. This allows functions to be defined+-- on the underlying representation of data, while exposing a nicer API using+-- 'pack' / 'unpack' at the boundaries. For example:+--+-- @+--     f :: forall a b. (BitPack a, BitPack b) => a -> b+--     f = unpack . go . pack+--      where+--       go :: BitVector (BitSize a) -> BitVector (BitSize b)+--       go = _ -- A function on the underlying bit vector+-- @+--+-- A type should only implement this class if it has a statically known size,+-- as otherwise it is not possible to determine how many bits are needed to+-- represent values. This means that types such as @[a]@ cannot have @BitPack@+-- instances, as even if @a@ has a statically known size, the length of the+-- list cannot be known in advance.+--+-- It is not possible to give data a custom bit representation by providing a+-- @BitPack@ instance. A @BitPack@ instance allows no creativity and should+-- always accurately reflect the bit representation of the data in HDL. You+-- should always @derive ('Generic', BitPack)@ unless you use a custom data+-- representation, in which case you should use+-- 'Clash.Annotations.BitRepresentation.Deriving.deriveBitPack'. Custom+-- encodings can be created with "Clash.Annotations.BitRepresentation" and+-- "Clash.Annotations.BitRepresentation.Deriving".+--+-- If the @BitPack@ instance does not accurately match the bit representation of+-- the data in HDL, Clash designs will exhibit incorrect behavior in various+-- places.+--+-- Clash provides some generic functions on packable types in the prelude, such+-- as indexing into packable structures (see "Clash.Class.BitPack.BitIndex") and+-- bitwise reduction of packable data (see "Clash.Class.BitPack.BitReduction").+--+class KnownNat (BitSize a) => BitPack a where+  -- | Number of 'Clash.Sized.BitVector.Bit's needed to represents elements+  -- of type @a@+  --+  -- Can be derived using `GHC.Generics`:+  --+  -- > import Clash.Prelude+  -- > import GHC.Generics+  -- >+  -- > data MyProductType = MyProductType { a :: Int, b :: Bool }+  -- >   deriving (Generic, BitPack)+  type BitSize a :: Nat+  type BitSize a = (CLog 2 (GConstructorCount (Rep a))) + (GFieldSize (Rep a))+  -- | Convert element of type @a@ to a 'BitVector'+  --+  -- @pack@ will never raise @XException@; as @BitVector@ is three-valued,+  -- @pack@ applied to an @XException@ will return a @BitVector@ filled with+  -- undefined bits.+  --+  -- >>> pack (-5 :: Signed 6)+  -- 0b11_1011+  pack   :: a -> BitVector (BitSize a)+  default pack+    :: ( Generic a+       , GBitPack (Rep a)+       , KnownNat (BitSize a)+       , KnownNat constrSize+       , KnownNat fieldSize+       , constrSize ~ CLog 2 (GConstructorCount (Rep a))+       , fieldSize ~ GFieldSize (Rep a)+       , (constrSize + fieldSize) ~ BitSize a+       )+    => a -> BitVector (BitSize a)+  pack = packXWith go+   where+    go a = resize (pack sc) ++# packedFields+     where+      (sc, packedFields) = gPackFields 0 (from a)++  -- | Convert a 'BitVector' to an element of type @a@+  --+  -- >>> pack (-5 :: Signed 6)+  -- 0b11_1011+  -- >>> let x = pack (-5 :: Signed 6)+  -- >>> unpack x :: Unsigned 6+  -- 59+  -- >>> pack (59 :: Unsigned 6)+  -- 0b11_1011+  unpack :: BitVector (BitSize a) -> a+  default unpack+    :: ( Generic a+       , GBitPack (Rep a)+       , KnownNat constrSize+       , KnownNat fieldSize+       , constrSize ~ CLog 2 (GConstructorCount (Rep a))+       , fieldSize ~ GFieldSize (Rep a)+       , (constrSize + fieldSize) ~ BitSize a+       )+    => BitVector (BitSize a) -> a+  unpack b =+    to (gUnpack sc 0 bFields)+   where+    (checkUnpackUndef unpack . resize -> sc, bFields) = split# b++packXWith+  :: KnownNat n+  => (a -> BitVector n)+  -> a+  -> BitVector n+packXWith f = xToBV . f+{-# INLINE packXWith #-}++-- | Pack both arguments to a 'BitVector' and use+-- 'Clash.Sized.Internal.BitVector.isLike#' to compare them. This is a more+-- lenient comparison than '(==)', behaving more like (but not necessarily+-- exactly the same as) @std_match@ in VHDL or @casez@ in Verilog.+--+-- Unlike '(==)', isLike is not symmetric. The reason for this is that a+-- defined bit is said to be like an undefined bit, but not vice-versa:+--+-- >>> isLike (12 :: Signed 8) undefined+-- True+-- >>> isLike undefined (12 :: Signed 8)+-- False+--+-- However, it is still trivially reflexive and transitive:+--+-- >>> :set -XTemplateHaskell+-- >>> let x1 = $(bLit "0010")+-- >>> let x2 = $(bLit "0.10")+-- >>> let x3 = $(bLit "0.1.")+-- >>> isLike x1 x1+-- True+-- >>> isLike x1 x2+-- True+-- >>> isLike x2 x3+-- True+-- >>> isLike x1 x3+-- True+--+-- __NB__: Not synthesizable+--+isLike+  :: (BitPack a)+  => a+  -> a+  -> Bool+isLike x y =+  isLike# (pack x) (pack y)++{-# INLINE[1] bitCoerce #-}+-- | Coerce a value from one type to another through its bit representation.+--+-- >>> pack (-5 :: Signed 6)+-- 0b11_1011+-- >>> bitCoerce (-5 :: Signed 6) :: Unsigned 6+-- 59+-- >>> pack (59 :: Unsigned 6)+-- 0b11_1011+bitCoerce+  :: (BitPack a, BitPack b, BitSize a ~ BitSize b)+  => a+  -> b+bitCoerce = unpack . pack++-- | Map a value by first coercing to another type through its bit representation.+--+-- >>> pack (-5 :: Signed 32)+-- 0b1111_1111_1111_1111_1111_1111_1111_1011+-- >>> bitCoerceMap @(Vec 4 (BitVector 8)) (replace 1 0) (-5 :: Signed 32)+-- -16711685+-- >>> pack (-16711685 :: Signed 32)+-- 0b1111_1111_0000_0000_1111_1111_1111_1011+bitCoerceMap+  :: forall a b . (BitPack a, BitPack b, BitSize a ~ BitSize b)+  => (a -> a)+  -> b+  -> b+bitCoerceMap f = bitCoerce . f . bitCoerce++instance BitPack Bool where+  type BitSize Bool = 1+  pack   = let go b = if b then 1 else 0 in packXWith go+  unpack = checkUnpackUndef $ \bv -> if bv == 1 then True else False++instance KnownNat n => BitPack (BitVector n) where+  type BitSize (BitVector n) = n+  pack     = packXWith id+  unpack v = v++instance BitPack Bit where+  type BitSize Bit = 1+  pack   = packXWith pack#+  unpack = unpack#++instance BitPack Int where+  type BitSize Int = WORD_SIZE_IN_BITS+  pack   = packXWith toEnum+  unpack = checkUnpackUndef fromEnum++instance BitPack Int8 where+  type BitSize Int8 = 8+  pack   = packXWith packInt8#+  unpack = checkUnpackUndef unpackInt8#++packInt8# :: Int8 -> BitVector 8+packInt8# = fromIntegral+{-# OPAQUE packInt8# #-}+{-# ANN packInt8# hasBlackBox #-}++unpackInt8# :: BitVector 8 -> Int8+unpackInt8# = fromIntegral+{-# OPAQUE unpackInt8# #-}+{-# ANN unpackInt8# hasBlackBox #-}++instance BitPack Int16 where+  type BitSize Int16 = 16+  pack   = packXWith packInt16#+  unpack = checkUnpackUndef unpackInt16#++packInt16# :: Int16 -> BitVector 16+packInt16# = fromIntegral+{-# OPAQUE packInt16# #-}+{-# ANN packInt16# hasBlackBox #-}++unpackInt16# :: BitVector 16 -> Int16+unpackInt16# = fromIntegral+{-# OPAQUE unpackInt16# #-}+{-# ANN unpackInt16# hasBlackBox #-}++instance BitPack Int32 where+  type BitSize Int32 = 32+  pack   = packXWith packInt32#+  unpack = checkUnpackUndef unpackInt32#++packInt32# :: Int32 -> BitVector 32+packInt32# = fromIntegral+{-# OPAQUE packInt32# #-}+{-# ANN packInt32# hasBlackBox #-}++unpackInt32# :: BitVector 32 -> Int32+unpackInt32# = fromIntegral+{-# OPAQUE unpackInt32# #-}+{-# ANN unpackInt32# hasBlackBox #-}++instance BitPack Int64 where+  type BitSize Int64 = 64+  pack   = packXWith packInt64#+  unpack = checkUnpackUndef unpackInt64#++packInt64# :: Int64 -> BitVector 64+packInt64# = fromIntegral+{-# OPAQUE packInt64# #-}+{-# ANN packInt64# hasBlackBox #-}++unpackInt64# :: BitVector 64 -> Int64+unpackInt64# = fromIntegral+{-# OPAQUE unpackInt64# #-}+{-# ANN unpackInt64# hasBlackBox #-}++instance BitPack Word where+  type BitSize Word = WORD_SIZE_IN_BITS+  pack   = packXWith packWord#+  unpack = checkUnpackUndef unpackWord#++packWord# :: Word -> BitVector WORD_SIZE_IN_BITS+packWord# = fromIntegral+{-# OPAQUE packWord# #-}+{-# ANN packWord# hasBlackBox #-}++unpackWord# :: BitVector WORD_SIZE_IN_BITS -> Word+unpackWord# = fromIntegral+{-# OPAQUE unpackWord# #-}+{-# ANN unpackWord# hasBlackBox #-}++instance BitPack Word8 where+  type BitSize Word8 = 8+  pack   = packXWith packWord8#+  unpack = checkUnpackUndef unpackWord8#++packWord8# :: Word8 -> BitVector 8+packWord8# = fromIntegral+{-# OPAQUE packWord8# #-}+{-# ANN packWord8# hasBlackBox #-}++unpackWord8# :: BitVector 8 -> Word8+unpackWord8# = fromIntegral+{-# OPAQUE unpackWord8# #-}+{-# ANN unpackWord8# hasBlackBox #-}++instance BitPack Word16 where+  type BitSize Word16 = 16+  pack   = packXWith packWord16#+  unpack = checkUnpackUndef unpackWord16#++packWord16# :: Word16 -> BitVector 16+packWord16# = fromIntegral+{-# OPAQUE packWord16# #-}+{-# ANN packWord16# hasBlackBox #-}++unpackWord16# :: BitVector 16 -> Word16+unpackWord16# = fromIntegral+{-# OPAQUE unpackWord16# #-}+{-# ANN unpackWord16# hasBlackBox #-}++instance BitPack Word32 where+  type BitSize Word32 = 32+  pack   = packXWith packWord32#+  unpack = checkUnpackUndef unpackWord32#++packWord32# :: Word32 -> BitVector 32+packWord32# = fromIntegral+{-# OPAQUE packWord32# #-}+{-# ANN packWord32# hasBlackBox #-}++unpackWord32# :: BitVector 32 -> Word32+unpackWord32# = fromIntegral+{-# OPAQUE unpackWord32# #-}+{-# ANN unpackWord32# hasBlackBox #-}++instance BitPack Word64 where+  type BitSize Word64 = 64+  pack   = packXWith packWord64#+  unpack = checkUnpackUndef unpackWord64#++packWord64# :: Word64 -> BitVector 64+packWord64# = fromIntegral+{-# OPAQUE packWord64# #-}+{-# ANN packWord64# hasBlackBox #-}++unpackWord64# :: BitVector 64 -> Word64+unpackWord64# = fromIntegral+{-# OPAQUE unpackWord64# #-}+{-# ANN unpackWord64# hasBlackBox #-}++instance BitPack Float where+  type BitSize Float = 32+  pack   = packXWith packFloat#+  unpack = checkUnpackUndef unpackFloat#++packFloat# :: Float -> BitVector 32+packFloat# = fromIntegral . floatToWord+{-# OPAQUE packFloat# #-}+{-# ANN packFloat# hasBlackBox #-}++unpackFloat# :: BitVector 32 -> Float+unpackFloat# (unsafeToNatural -> w) = wordToFloat (fromIntegral w)+{-# OPAQUE unpackFloat# #-}+{-# ANN unpackFloat# hasBlackBox #-}++instance BitPack Double where+  type BitSize Double = 64+  pack   = packXWith packDouble#+  unpack = checkUnpackUndef unpackDouble#++packDouble# :: Double -> BitVector 64+packDouble# = fromIntegral . doubleToWord+{-# OPAQUE packDouble# #-}+{-# ANN packDouble# hasBlackBox #-}++unpackDouble# :: BitVector 64 -> Double+unpackDouble# (unsafeToNatural -> w) = wordToDouble (fromIntegral w)+{-# OPAQUE unpackDouble# #-}+{-# ANN unpackDouble# hasBlackBox #-}++instance BitPack CUShort where+  type BitSize CUShort = 16+  pack   = packXWith packCUShort#+  unpack = checkUnpackUndef unpackCUShort#++packCUShort# :: CUShort -> BitVector 16+packCUShort# = fromIntegral+{-# OPAQUE packCUShort# #-}+{-# ANN packCUShort# hasBlackBox #-}++unpackCUShort# :: BitVector 16 -> CUShort+unpackCUShort# = fromIntegral+{-# OPAQUE unpackCUShort# #-}+{-# ANN unpackCUShort# hasBlackBox #-}++instance BitPack Half where+  type BitSize Half = 16+  pack (Half x) = pack x+  unpack        = checkUnpackUndef $ \x -> Half (unpack x)++instance BitPack () where+  type BitSize () = 0+  pack   _ = minBound+  unpack _ = ()++instance BitPack Char where+  type BitSize Char = 21+  pack   = packXWith packChar#+  unpack = checkUnpackUndef unpackChar#++packChar# :: Char -> BitVector 21+packChar# = fromIntegral . ord+{-# OPAQUE packChar# #-}+{-# ANN packChar# hasBlackBox #-}++unpackChar# :: BitVector 21 -> Char+unpackChar# = chr . fromIntegral+{-# OPAQUE unpackChar# #-}+{-# ANN unpackChar# hasBlackBox #-}++-- | __NB__: The documentation only shows instances up to /3/-tuples. By+-- default, instances up to and including /12/-tuples will exist. If the flag+-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The+-- GHC imposed limit is either 62 or 64 depending on the GHC version.+instance (BitPack a, BitPack b) => BitPack (a,b) where+  type BitSize (a,b) = BitSize a + BitSize b+  pack = let go (a,b) = pack a ++# pack b in packXWith go+  unpack ab  = let (a,b) = split# ab in (unpack a, unpack b)++class GBitPack f where+  -- | Size of fields. If multiple constructors exist, this is the maximum of+  -- the sum of each of the constructors fields.+  type GFieldSize f :: Nat++  -- | Number of constructors this type has. Indirectly indicates how many bits+  -- are needed to represent the constructor.+  type GConstructorCount f :: Nat++  -- | Pack fields of a type. Caller should pack and prepend the constructor bits.+  gPackFields+    :: Int+    -- ^ Current constructor+    -> f a+    -- ^ Data to pack+    -> (Int, BitVector (GFieldSize f))+    -- ^ (Constructor number, Packed fields)++  -- | Unpack whole type.+  gUnpack+    :: Int+    -- ^ Construct with constructor /n/+    -> Int+    -- ^ Current constructor+    -> BitVector (GFieldSize f)+    -- ^ BitVector containing fields+    -> f a+    -- ^ Unpacked result++instance GBitPack a => GBitPack (M1 m d a) where+  type GFieldSize (M1 m d a) = GFieldSize a+  type GConstructorCount (M1 m d a) = GConstructorCount a++  gPackFields cc (M1 m1) = gPackFields cc m1+  gUnpack c cc b = M1 (gUnpack c cc b)++instance ( KnownNat (GFieldSize g)+         , KnownNat (GFieldSize f)+         , KnownNat (GConstructorCount f)+         , GBitPack f+         , GBitPack g+         ) => GBitPack (f :+: g) where+  type GFieldSize (f :+: g) = Max (GFieldSize f) (GFieldSize g)+  type GConstructorCount (f :+: g) = GConstructorCount f + GConstructorCount g++  gPackFields cc (L1 l) =+    let (sc, packed) = gPackFields cc l in+    let padding = undefined# :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize f) in+    (sc, packed ++# padding)+  gPackFields cc (R1 r) =+    let cLeft = snatToNum (SNat @(GConstructorCount f)) in+    let (sc, packed) = gPackFields (cc + cLeft) r in+    let padding = undefined# :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize g) in+    (sc, packed ++# padding)++  gUnpack c cc b =+    let cLeft = snatToNum (SNat @(GConstructorCount f)) in+    if c < cc + cLeft then+      L1 (gUnpack c cc f)+    else+      R1 (gUnpack c (cc + cLeft) g)++   where+    -- It's a thing of beauty, if I may say so myself!+    (f, _ :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize f)) = split# b+    (g, _ :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize g)) = split# b+++instance (KnownNat (GFieldSize g), KnownNat (GFieldSize f), GBitPack f, GBitPack g) => GBitPack (f :*: g) where+  type GFieldSize (f :*: g) = GFieldSize f + GFieldSize g+  type GConstructorCount (f :*: g) = 1++  gPackFields cc fg =+    (cc, packXWith go fg)+   where+    go (l0 :*: r0) =+      let (_, l1) = gPackFields cc l0 in+      let (_, r1) = gPackFields cc r0 in+      l1 ++# r1++  gUnpack c cc b =+    gUnpack c cc front :*: gUnpack c cc back+   where+    (front, back) = split# b++instance BitPack c => GBitPack (K1 i c) where+  type GFieldSize (K1 i c) = BitSize c+  type GConstructorCount (K1 i c)  = 1++  gPackFields cc (K1 i) = (cc, pack i)+  gUnpack _c _cc b      = K1 (unpack b)++instance GBitPack U1 where+  type GFieldSize U1 = 0+  type GConstructorCount U1 = 1++  gPackFields cc U1 = (cc, 0)+  gUnpack _c _cc _b = U1++-- Instances derived using Generic+instance BitPack Ordering++instance ( BitPack a+         , BitPack b+         ) => BitPack (Either a b)++instance BitPack a => BitPack (Maybe a)++-- | Any 'Proxy' has a bit size of 0 and hence packs to @0 :: BitVector 0@.+--+-- >>> pack (Proxy @())+-- 0+-- >>> pack (Proxy @5)+-- 0+-- >>> pack (Proxy @Bool)+-- 0+instance BitPack (Proxy a)++instance BitPack a => BitPack (Complex a)+instance BitPack a => BitPack (Down a)++instance BitPack a => BitPack (Identity a)+instance BitPack a => BitPack (Const a b)+instance (BitPack (f a), BitPack (g a)) => BitPack (Product f g a)+instance (BitPack (f a), BitPack (g a)) => BitPack (Sum f g a)+instance BitPack (f (g a)) => BitPack (Compose f g a)++-- | Zero-extend a 'Bool'ean value to a 'BitVector' of the appropriate size.+--+-- >>> boolToBV True :: BitVector 6+-- 0b00_0001+-- >>> boolToBV False :: BitVector 6+-- 0b00_0000+boolToBV :: KnownNat n => Bool -> BitVector (n + 1)+boolToBV = zeroExtend . pack++-- | Convert a Bool to a Bit+boolToBit :: Bool -> Bit+boolToBit = bitCoerce++-- | Convert a Bit to a Bool+bitToBool :: Bit -> Bool+bitToBool = bitCoerce++-- Derive the BitPack instance for tuples of size 3 to maxTupleSize+deriveBitPackTuples ''BitPack ''BitSize 'pack 'unpack
+ src/Clash/Class/BitPack/Internal/TH.hs view
@@ -0,0 +1,110 @@+{-|+Copyright  :  (C) 2019-2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Class.BitPack.Internal.TH where++import           Clash.CPP             (maxTupleSize)+import           Language.Haskell.TH.Compat (mkTySynInstD,mkTupE)+import           Control.Monad         (replicateM)+#if !MIN_VERSION_base(4,20,0)+import           Data.List             (foldl')+#endif+import           GHC.TypeLits          (KnownNat)+import           Language.Haskell.TH++-- | Contruct all the tuple (starting at size 3) instances for BitPack.+deriveBitPackTuples+  :: Name+  -- ^ BitPack+  -> Name+  -- ^ BitSize+  -> Name+  -- ^ pack+  -> Name+  -- ^ unpack+  -> DecsQ+deriveBitPackTuples bitPackName bitSizeName packName unpackName = do+  let bitPack  = ConT bitPackName+      bitSize  = ConT bitSizeName+      knownNat = ConT ''KnownNat+      plus     = ConT $ mkName "+"++  allNames <- replicateM maxTupleSize (newName "a")+  retupName <- newName "retup"+  x <- newName "x"+  y <- newName "y"+  tup <- newName "tup"++  pure $ flip map [3..maxTupleSize] $ \tupleNum ->+    let names  = take tupleNum allNames+        (v,vs) = case map VarT names of+                    (z:zs) -> (z,zs)+                    _ -> error "maxTupleSize <= 3"+        tuple xs = foldl' AppT (TupleT $ length xs) xs++        -- Instance declaration+        context =+          [ bitPack `AppT` v+          , knownNat `AppT` (bitSize `AppT` v)+          , bitPack `AppT` tuple vs+          , knownNat `AppT` (bitSize `AppT` tuple vs)+          ]+        instTy = AppT bitPack $ tuple (v:vs)++        -- Associated type BitSize+        bitSizeType =+          mkTySynInstD bitSizeName [tuple (v:vs)]+            $ plus `AppT` (bitSize `AppT` v) `AppT`+              (bitSize `AppT` foldl AppT (TupleT $ tupleNum - 1) vs)++        pack =+          FunD+            packName+            [ Clause+                [VarP tup]+                (NormalB (AppE (VarE packName) (AppE (VarE retupName) (VarE tup))))+                [FunD+                    retupName+                    [ Clause+                        [ TupP $ map VarP names ]+                        ( let (e,es) = case map VarE names of+                                          (z:zs) -> (z,zs)+                                          _ -> error "maxTupleSize <= 3"+                          in NormalB (mkTupE [e,mkTupE es])+                        )+                        []+                    ]+                ]+            ]++        unpack =+          FunD+            unpackName+            [ Clause+                [ VarP x ]+                ( NormalB $+                    let (p,ps) = case map VarP names of+                                   (z:zs) -> (z,zs)+                                   _ -> error "maxTupleSize <= 3"+                    in+                    LetE+                      [ ValD+                          ( TupP [ p, VarP y ] )+                          ( NormalB $ VarE unpackName `AppE` VarE x )+                          []+                      , ValD+                          ( TupP ps )+                          ( NormalB $ VarE unpackName `AppE` VarE y )+                          []+                      ]+                      ( mkTupE $ map VarE names )+                )+                []+            ]++    in InstanceD Nothing context instTy [bitSizeType, pack, unpack]
+ src/Clash/Class/Counter.hs view
@@ -0,0 +1,62 @@+{-|+  Copyright   :  (C) 2021     , QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Utilities for wrapping counters consisting of multiple individual counters+-}++module Clash.Class.Counter+  ( Counter(countMin, countMax, countSuccOverflow, countPredOverflow)+  , countSucc+  , countPred+  ) where++import Clash.Class.Counter.Internal++-- $setup+-- >>> import Clash.Class.Counter+-- >>> import Clash.Sized.BitVector (BitVector)+-- >>> import Clash.Sized.Index (Index)+-- >>> import Clash.Sized.Signed (Signed)+-- >>> import Clash.Sized.Unsigned (Unsigned)++-- | Successor of a counter.+--+-- Examples:+--+-- >>> type T = (Unsigned 2, Unsigned 2)+-- >>> countSucc @T (1, 1)+-- (1,2)+-- >>> countSucc @T (1, 2)+-- (1,3)+-- >>> countSucc @T (1, 3)+-- (2,0)+-- >>> countSucc @T (3, 3)+-- (0,0)+-- >>> countSucc @(Index 9, Index 2) (0, 1)+-- (1,0)+-- >>> countSucc @(Either (Index 9) (Index 9)) (Left 8)+-- Right 0+countSucc :: Counter a => a -> a+countSucc = snd . countSuccOverflow++-- | Predecessor of a counter+--+-- Examples:+--+-- >>> type T = (Unsigned 2, Unsigned 2)+-- >>> countPred @T (1, 2)+-- (1,1)+-- >>> countPred @T (1, 3)+-- (1,2)+-- >>> countPred @T (2, 0)+-- (1,3)+-- >>> countPred @T (0, 0)+-- (3,3)+-- >>> countPred @(Index 9, Index 2) (1, 0)+-- (0,1)+-- >>> countPred @(Either (Index 9) (Index 9)) (Right 0)+-- Left 8+countPred :: Counter a => a -> a+countPred = snd . countPredOverflow
+ src/Clash/Class/Counter/Internal.hs view
@@ -0,0 +1,228 @@+{- |+Copyright  :  (C) 2021-2026, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Clash.Class.Counter.Internal where++import Clash.CPP (maxTupleSize)++import Clash.Class.Counter.TH (genTupleInstances)+import Clash.Sized.BitVector (BitVector, Bit)+import Clash.Sized.Index (Index)+import Clash.Sized.Signed (Signed)+import Clash.Sized.Unsigned (Unsigned)+import Clash.Sized.Vector as Vec (Vec, repeat, mapAccumR)++import Data.Bifunctor (bimap)+import Data.Functor.Identity (Identity(..))+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)+import GHC.TypeLits (KnownNat, type (<=))++-- $setup+-- >>> :m -Prelude+-- >>> import Clash.Prelude+-- >>> import Clash.Class.Counter+-- >>> import Clash.Sized.BitVector (BitVector)+-- >>> import Clash.Sized.Index (Index)+-- >>> import Clash.Sized.Signed (Signed)+-- >>> import Clash.Sized.Unsigned (Unsigned)+-- >>> import Clash.Sized.Vector (Vec(..), iterate)++-- | t'Clash.Class.Counter.Counter' is a class that composes multiple counters+-- into a single one. It is similar to odometers found in olds cars,+-- once all counters reach their maximum they reset to zero - i.e. odometer+-- rollover. See 'Clash.Class.Counter.countSucc' and 'Clash.Class.Counter.countPred'+-- for API usage examples.+--+-- Example use case: when driving a monitor through VGA you would like to keep+-- track at least two counters: one counting a horizontal position, and one+-- vertical. Perhaps a fancy VGA driver would also like to keep track of the+-- number of drawn frames. To do so, the three counters are setup with different+-- types. On each /round/ of the horizontal counter the vertical counter should+-- be increased. On each /round/ of the vertical counter the frame counter should+-- be increased. With this class you could simply use the type:+--+-- @+-- (FrameCount, VerticalCount, HorizontalCount)+-- @+--+-- and have 'Clash.Class.Counter.countSucc' work as described.+--+class Counter a where+  -- | Value counter wraps around to on a 'countSuccOverflow' overflow+  countMin :: a+  default countMin :: Bounded a => a+  countMin = minBound++  -- | Value counter wraps around to on a 'countPredOverflow' overflow+  countMax :: a+  default countMax :: Bounded a => a+  countMax = maxBound++  -- | Gets the successor of @a@. If it overflows, the first part of the tuple+  -- will be set to True and the second part wraps around to `countMin`.+  countSuccOverflow :: a -> (Bool, a)+  default countSuccOverflow :: (Eq a, Enum a, Bounded a) => a -> (Bool, a)+  countSuccOverflow a+    | a == maxBound = (True, countMin)+    | otherwise = (False, succ a)++  -- | Gets the predecessor of @a@. If it underflows, the first part of the tuple+  -- will be set to True and the second part wraps around to `countMax`.+  countPredOverflow :: a -> (Bool, a)+  default countPredOverflow :: (Eq a, Enum a, Bounded a) => a -> (Bool, a)+  countPredOverflow a+    | a == minBound = (True, countMax)+    | otherwise = (False, pred a)++instance (1 <= n, KnownNat n) => Counter (Index n)+instance KnownNat n => Counter (Unsigned n)+instance KnownNat n => Counter (Signed n)+instance KnownNat n => Counter (BitVector n)++-- | @since 1.8.2+instance Counter Bool+-- | @since 1.8.2+instance Counter Bit+-- | @since 1.8.2+instance Counter Int+-- | @since 1.8.2+instance Counter Int8+-- | @since 1.8.2+instance Counter Int16+-- | @since 1.8.2+instance Counter Int32+-- | @since 1.8.2+instance Counter Int64+-- | @since 1.8.2+instance Counter Word+-- | @since 1.8.2+instance Counter Word8+-- | @since 1.8.2+instance Counter Word16+-- | @since 1.8.2+instance Counter Word32+-- | @since 1.8.2+instance Counter Word64++-- | @since 1.8.2+deriving newtype instance Counter a => Counter (Identity a)++-- | 'Nothing' is considered the minimum value, while @'Just' 'countMax'@ is+-- considered the maximum value.+--+-- @since 1.8.2+instance Counter a => Counter (Maybe a) where+  countMin = Nothing+  countMax = Just countMax++  countSuccOverflow = \case+    Nothing -> (False, Just countMin)+    Just a0 ->+      case countSuccOverflow a0 of+        (True, _) -> (True, Nothing)+        (False, a1) -> (False, Just a1)++  countPredOverflow = \case+    Nothing -> (True, Just countMax)+    Just a0 ->+      case countPredOverflow a0 of+        (True, _) -> (False, Nothing)+        (False, a1) -> (False, Just a1)++-- | Counter instance that flip-flops between 'Left' and 'Right'. Examples:+--+-- >>> type T = Either (Index 2) (Unsigned 2)+-- >>> countSucc @T (Left 0)+-- Left 1+-- >>> countSucc @T (Left 1)+-- Right 0+-- >>> countSucc @T (Right 0)+-- Right 1+instance (Counter a, Counter b) => Counter (Either a b) where+  countMin = Left countMin+  countMax = Right countMax++  countSuccOverflow e =+    case bimap countSuccOverflow countSuccOverflow e of+      Left (overflow, a)  -> (False, if overflow then Right countMin else Left a)+      Right (overflow, b) -> (overflow, if overflow then Left countMin else Right b)++  countPredOverflow e =+    case bimap countPredOverflow countPredOverflow e of+      Left (overflow, a)  -> (overflow, if overflow then Right countMax else Left a)+      Right (overflow, b) -> (False, if overflow then Left countMax else Right b)++-- | Counters on tuples increment from right-to-left. This makes sense from the+-- perspective of LSB/MSB; MSB is on the left-hand-side and LSB is on the+-- right-hand-side in other Clash types.+--+-- >>> type T = (Unsigned 2, Index 2, Index 2)+-- >>> countSucc @T (0, 0, 0)+-- (0,0,1)+-- >>> countSucc @T (0, 0, 1)+-- (0,1,0)+-- >>> countSucc @T (0, 1, 0)+-- (0,1,1)+-- >>> countSucc @T (0, 1, 1)+-- (1,0,0)+--+-- __NB__: The documentation only shows the instances up to /3/-tuples. By+-- default, instances up to and including /12/-tuples will exist. If the flag+-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The+-- GHC imposed limit is either 62 or 64 depending on the GHC version.+instance (Counter a0, Counter a1) => Counter (a0, a1) where+  -- a0/a1 instead of a/b to be consistent with TH generated instances+  countMin = (countMin, countMin)+  countMax = (countMax, countMax)++  countSuccOverflow (a0, b0) =+    if overflowB+    then (overflowA, (a1, b1))+    else (overflowB, (a0, b1))+   where+    (overflowB, b1) = countSuccOverflow b0+    (overflowA, a1) = countSuccOverflow a0++  countPredOverflow (a0, b0) =+    if overflowB+    then (overflowA, (a1, b1))+    else (overflowB, (a0, b1))+   where+    (overflowB, b1) = countPredOverflow b0+    (overflowA, a1) = countPredOverflow a0++genTupleInstances maxTupleSize++rippleR :: (a -> (Bool, a)) -> Vec n a -> (Bool, Vec n a)+rippleR f = mapAccumR step True+  where+    step carry x = if carry then f x else (False, x)++-- | Counters on vectors increment from right to left.+--+-- >>> type T = Vec 2 (Index 10)+-- >>> countSucc @T (0 :> 0 :> Nil)+-- 0 :> 1 :> Nil+-- >>> countSucc @T (0 :> 1 :> Nil)+-- 0 :> 2 :> Nil+-- >>> countSucc @T (0 :> 9 :> Nil)+-- 1 :> 0 :> Nil+-- >>> iterate (SNat @5) (countSucc @T) (9 :> 8 :> Nil)+-- (9 :> 8 :> Nil) :> (9 :> 9 :> Nil) :> (0 :> 0 :> Nil) :> (0 :> 1 :> Nil) :> (0 :> 2 :> Nil) :> Nil+instance (Counter a, KnownNat n) => Counter (Vec n a) where+    countMin = Vec.repeat countMin+    countMax = Vec.repeat countMax++    countSuccOverflow = rippleR countSuccOverflow+    countPredOverflow = rippleR countPredOverflow
+ src/Clash/Class/Counter/TH.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE CPP #-}++module Clash.Class.Counter.TH where++import Language.Haskell.TH++counterName, countMinName, countMaxName, countSuccName, countPredName :: Name+counterName = mkName "Counter"+countMinName = mkName "countMin"+countMaxName = mkName "countMax"+countSuccName = mkName "countSuccOverflow"+countPredName = mkName "countPredOverflow"++mkTupTy :: [Type] -> Type+mkTupTy names@(length -> n) = foldl AppT (TupleT n) names++mkTup :: [Exp] -> Exp+mkTup = TupE . map Just++genTupleInstances :: Int -> Q [Dec]+genTupleInstances maxTupleSize = mapM genTupleInstance [3..maxTupleSize]++genTupleInstance :: Int -> Q Dec+genTupleInstance tupSize = do+  typeVars <- mapM (\n -> VarT <$> newName ("a" <> show n)) [0..tupSize-1]++  succOverflowBody <- genCountOverflow countSuccName tupSize+  predOverflowBody <- genCountOverflow countPredName tupSize++  let+    minBody = genCount countMinName tupSize+    maxBody = genCount countMaxName tupSize+    ctx = map (ConT counterName `AppT`) typeVars+    typ = ConT counterName `AppT` mkTupTy typeVars+    decls =+      [ FunD countMinName [minBody]+      , FunD countMaxName [maxBody]+      , FunD (mkName "countSuccOverflow") [succOverflowBody]+      , FunD (mkName "countPredOverflow") [predOverflowBody]+      ]++  pure (InstanceD Nothing ctx typ decls)++genCount :: Name -> Int -> Clause+genCount nm n = Clause [] (NormalB (mkTup (replicate n (VarE nm)))) []++genCountOverflow :: Name -> Int -> Q Clause+genCountOverflow nm tupSize = do+  varNms <- mapM (\n -> newName ("a" <> show n)) [0..tupSize-1]+  let vars = map VarE varNms++  overflowLastNm <- newName "overflowLast"+  lastNm <- newName "last"++  overflowInitNm <- newName "overflowInit"+  initNms <- mapM (\n -> newName ("a" <> show n)) [0..tupSize-2]++  let+    body =+      CondE+        (VarE overflowLastNm)+        (mkTup [VarE overflowInitNm, mkTup (map VarE (initNms <> [lastNm]))])+        (mkTup [VarE overflowLastNm, mkTup (init vars <> [VarE lastNm])])++    decs =+      [ ValD+          (TupP [VarP overflowLastNm, VarP lastNm])+          (NormalB (VarE nm `AppE` last vars))+          []++      , ValD+          (TupP [VarP overflowInitNm, TupP (map VarP initNms)])+          (NormalB (VarE nm `AppE` mkTup (init vars)))+          []+      ]++  pure (Clause [TupP (map VarP varNms)] (NormalB body) decs)
src/Clash/Class/Exp.hs view
@@ -1,23 +1,27 @@ {-| Copyright  :  (C) 2019, Myrtle Software Ltd+                  2024, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qaylogic.com> -} -{-# LANGUAGE CPP           #-}-{-# LANGUAGE DataKinds     #-}-{-# LANGUAGE MagicHash     #-}-{-# LANGUAGE TypeFamilies  #-}-{-# LANGUAGE TypeOperators #-}--#if __GLASGOW_HASKELL__ >= 806-{-# LANGUAGE NoStarIsType  #-}-#endif+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} -module Clash.Class.Exp (Exp, ExpResult, (^)) where+module Clash.Class.Exp+  ( Exp+  , ExpResult+  , (^) +  -- | * Internal+  , expIndex#+  , expSigned#+  , expUnsigned#+  ) where+ import qualified Prelude                       as P import           Prelude                       hiding ((^)) @@ -29,6 +33,7 @@  import           GHC.TypeLits   (KnownNat, Nat, type (^), type (*))+import           GHC.TypeLits.Extra            (Max)  -- | Type class implementing exponentiation with explicitly resizing results. class Exp a where@@ -43,20 +48,22 @@     -> ExpResult a n     -- ^ Resized result, guaranteed to not have overflown +infixr 8 ^+ instance KnownNat m => Exp (Index m) where-  type ExpResult (Index m) n = Index (m ^ n)+  type ExpResult (Index m) n = Index (Max 2 (m ^ n))    (^) = expIndex#   {-# INLINE (^) #-}  instance KnownNat m => Exp (Signed m) where-  type ExpResult (Signed m) n = Signed (m * n)+  type ExpResult (Signed m) n = Signed (Max 2 (m * n))    (^) = expSigned#   {-# INLINE (^) #-}  instance KnownNat m => Exp (Unsigned m) where-  type ExpResult (Unsigned m) n = Unsigned (m * n)+  type ExpResult (Unsigned m) n = Unsigned (Max 1 (m * n))    (^) = expUnsigned#   {-# INLINE (^) #-}@@ -65,28 +72,28 @@   :: KnownNat m   => Index m   -> SNat n-  -> Index (m ^ n)+  -> Index (Max 2 (m ^ n)) expIndex# b e@SNat =   fromInteger (toInteger b P.^ snatToInteger e)-{-# NOINLINE expIndex# #-}+{-# OPAQUE expIndex# #-} {-# ANN expIndex# hasBlackBox #-}  expSigned#   :: KnownNat m   => Signed m   -> SNat n-  -> Signed (m * n)+  -> Signed (Max 2 (m * n)) expSigned# b e@SNat =   fromInteger (toInteger b P.^ snatToInteger e)-{-# NOINLINE expSigned# #-}+{-# OPAQUE expSigned# #-} {-# ANN expSigned# hasBlackBox #-}  expUnsigned#   :: KnownNat m   => Unsigned m   -> SNat n-  -> Unsigned (m * n)+  -> Unsigned (Max 1 (m * n)) expUnsigned# b e@SNat =   fromInteger (toInteger b P.^ snatToInteger e)-{-# NOINLINE expUnsigned# #-}+{-# OPAQUE expUnsigned# #-} {-# ANN expUnsigned# hasBlackBox #-}
src/Clash/Class/HasDomain.hs view
@@ -1,6 +1,13 @@-module Clash.Class.HasDomain+{-# OPTIONS_GHC -Wno-deprecations #-}++module Clash.Class.HasDomain {-# DEPRECATED "Experimental feature multiple hidden has been removed. This module will therefore be removed in Clash 1.12." #-}   ( WithSpecificDomain   , WithSingleDomain++  , HasDomain+  , TryDomain+  , TryDomainResult(..)+  , DomEq   ) where  -- Compilation is split across modules to maximize GHC parallelism
src/Clash/Class/HasDomain/CodeGen.hs view
@@ -4,8 +4,6 @@ Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE ViewPatterns #-}- module Clash.Class.HasDomain.CodeGen   ( mkTryDomainTuples   , mkHasDomainTuples
src/Clash/Class/HasDomain/Common.hs view
@@ -4,16 +4,16 @@ Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DataKinds          #-}-{-# LANGUAGE PolyKinds          #-}-{-# LANGUAGE TypeFamilies       #-}-{-# LANGUAGE TypeOperators      #-}+{-# LANGUAGE TypeFamilies #-} -module Clash.Class.HasDomain.Common+module Clash.Class.HasDomain.Common {-# DEPRECATED "Experimental feature multiple hidden has been removed. This module will therefore be removed in Clash 1.12." #-}   ( Unlines   , (:<<>>:)   , (:$$$:)   , (:++:)++  -- * Internal+  , ToEM   ) where  import           GHC.TypeLits               (Symbol)
src/Clash/Class/HasDomain/HasSingleDomain.hs view
@@ -1,37 +1,44 @@ {-| Copyright  :  (C) 2019, Myrtle Software Ltd+                  2022-2025, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Internals for "Clash.Class.HasDomain" -} -{-# LANGUAGE CPP                  #-}-{-# LANGUAGE ConstraintKinds      #-}-{-# LANGUAGE PolyKinds            #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ < 806-{-# LANGUAGE TypeInType #-}-#endif -{-# OPTIONS_GHC -Wno-missing-methods #-}+{-# OPTIONS_GHC -Wno-missing-methods -Wno-deprecations #-}+{-# OPTIONS_HADDOCK not-home #-} -module Clash.Class.HasDomain.HasSingleDomain where+module Clash.Class.HasDomain.HasSingleDomain {-# DEPRECATED "Experimental feature multiple hidden has been removed. This module will therefore be removed in Clash 1.12." #-} where  import           Clash.Class.HasDomain.Common import           Clash.Class.HasDomain.CodeGen    (mkTryDomainTuples)  import           Clash.Sized.Vector               (Vec) import           Clash.Sized.RTree                (RTree)+import           Clash.Sized.Index                (Index)+import           Clash.Sized.Unsigned             (Unsigned)+import           Clash.Sized.Signed               (Signed)+import           Clash.Sized.BitVector            (BitVector, Bit)+import           Clash.Sized.Fixed                (Fixed)+ import           Clash.Signal.Internal   (Signal, Domain, Clock, Reset, Enable) import           Clash.Signal.Delayed.Internal    (DSignal) +import           Numeric.Natural                  (Natural)+ import           Data.Kind                        (Type) import           Data.Proxy                       (Proxy)+import           GHC.TypeLits                     (type (+)) import           Type.Errors   (DelayError, TypeError, IfStuck, Pure) @@ -146,25 +153,24 @@ type instance TryDomain t (Proxy dom)           = 'Found dom type instance TryDomain t (Vec n a)             = TryDomain t a type instance TryDomain t (RTree d a)           = TryDomain t a+type instance TryDomain t (Index n)             = 'NotFound+type instance TryDomain t (Unsigned n)          = 'NotFound+type instance TryDomain t (Signed n)            = 'NotFound+type instance TryDomain t (BitVector n)         = 'NotFound+type instance TryDomain t Bit                   = 'NotFound+type instance TryDomain t (Fixed a n m)         = TryDomain t (a (n + m)) type instance TryDomain t (a -> b)              = Merge t a b type instance TryDomain t (a, b)                = Merge t a b  type instance TryDomain t ()                    = 'NotFound type instance TryDomain t Bool                  = 'NotFound type instance TryDomain t Integer               = 'NotFound+type instance TryDomain t Natural               = 'NotFound type instance TryDomain t Int                   = 'NotFound type instance TryDomain t Float                 = 'NotFound type instance TryDomain t Double                = 'NotFound type instance TryDomain t (Maybe a)             = TryDomain t a type instance TryDomain t (Either a b)          = Merge t a b---- TODO: Add more instances, including:---type instance TryDomain t Bit                   = 'NotFound---type instance TryDomain t (BitVector n)         = 'NotFound---type instance TryDomain t (Index n)             = 'NotFound---type instance TryDomain t (Fixed rep int frac)  = 'NotFound---type instance TryDomain t (Signed n)            = 'NotFound---type instance TryDomain t (Unsigned n)          = 'NotFound  -- | Type family that searches a type and checks whether all subtypes that can -- contain a domain (for example, Signal) contain the /same/ domain. Its
src/Clash/Class/HasDomain/HasSpecificDomain.hs view
@@ -1,26 +1,24 @@ {-| Copyright  :  (C) 2019, Myrtle Software Ltd+                  2022-2025, QBayLogic B.V. License    :  BSD2 (see the file LICENSE) Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++Internals for "Clash.Class.HasDomain" -} -{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}-#if __GLASGOW_HASKELL__ < 806-{-# LANGUAGE TypeInType #-}-#endif+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-missing-methods #-}+{-# OPTIONS_GHC -Wno-missing-methods -Wno-deprecations #-}+{-# OPTIONS_HADDOCK not-home #-} -module Clash.Class.HasDomain.HasSpecificDomain where+module Clash.Class.HasDomain.HasSpecificDomain {-# DEPRECATED "Experimental feature multiple hidden has been removed. This module will therefore be removed in Clash 1.12." #-} where  import           Clash.Class.HasDomain.CodeGen  (mkHasDomainTuples) import           Clash.Class.HasDomain.Common@@ -86,7 +84,7 @@   DomEqWorker n n = 'Found   DomEqWorker n m = 'NotFound --- | Check domain for equality. Return 'Found if so, return 'NotFound if not.+-- | Check domain for equality. Return @'Found@ if so, return @'NotFound@ if not. -- The reason d'etre for this type family is that _open_ type families don't -- allow overlapping types. We therefore defer equality checking to a closed -- type family.@@ -112,7 +110,7 @@   ErrOnNotFound dom  'NotFound t = DelayError (NotFoundError dom t)   ErrOnNotFound dom  'Found    t = dom --- | Wrapper that checks for stuckness and returns "NotFound" if so+-- | Wrapper that checks for stuckness and returns @'NotFound@ if so type family HasDomainWrapper (dom :: Domain) (n :: Type) :: HasDomainWrapperResult where   HasDomainWrapper dom n =     IfStuck@@ -133,7 +131,7 @@ -- | Type class that specifies that a certain domain, /dom/, needs to be present -- in some other type, /r/. This is used to disambiguate what hidden clock, -- reset, and enable lines should be exposed in functions such as--- 'withSpecificReset'.+-- 'Clash.Signal.withSpecificReset'. -- -- Functions in need of this class should use 'WithSpecificDomain' though, to -- force Clash to display an error instead of letting it silently pass.
src/Clash/Class/Num.hs view
@@ -1,12 +1,13 @@ {-| Copyright  :  (C) 2013-2016, University of Twente+                  2024,      Google LLC License    :  BSD2 (see the file LICENSE) Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DataKinds             #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}  {-# LANGUAGE Safe #-} @@ -21,8 +22,6 @@   , boundedAdd   , boundedSub   , boundedMul-  , satSucc-  , satPred   ) where @@ -44,6 +43,9 @@   -- that is potentially different from either argument.   mul :: a -> b -> MResult a b +infixl 7  `mul`+infixl 6  `add`, `sub`+ -- * Saturating arithmetic functions  -- | Determine how overflow and underflow are handled by the functions in@@ -55,7 +57,8 @@   | SatSymmetric -- ^ Become 'maxBound' on overflow, and (@'minBound' + 1@) on                  -- underflow for signed numbers, and 'minBound' for unsigned                  -- numbers.-  deriving Eq+  | SatError -- ^ Become an XException on overflow and underflow+  deriving (Show, Eq, Enum, Bounded)  -- | 'Num' operators in which overflow and underflow behavior can be specified -- using 'SaturationMode'.@@ -66,30 +69,36 @@   satSub  :: SaturationMode -> a -> a -> a   -- | Multiplication with parameterizable over- and underflow behavior   satMul :: SaturationMode -> a -> a -> a---- | Get successor of (or in other words, add 1 to) given number-satSucc :: SaturatingNum a => SaturationMode -> a -> a-satSucc s n = satAdd s n 1-{-# INLINE satSucc #-}+  -- | Get successor of (or in other words, add 1 to) given number+  satSucc :: SaturationMode -> a -> a+  -- Default method suitable for types that can represent the number 1+  satSucc s n = satAdd s n 1+  {-# INLINE satSucc #-}+  -- | Get predecessor of (or in other words, subtract 1 from) given number+  satPred :: SaturationMode -> a -> a+  -- Default method suitable for types that can represent the number 1+  satPred s n = satSub s n 1+  {-# INLINE satPred #-} --- | Get predecessor of (or in other words, subtract 1 from) given number-satPred :: SaturatingNum a => SaturationMode -> a -> a-satPred s n = satSub s n 1-{-# INLINE satPred #-}+infixl 7  `satMul`+infixl 6  `satAdd`, `satSub`  -- | Addition that clips to 'maxBound' on overflow, and 'minBound' on underflow boundedAdd :: SaturatingNum a => a -> a -> a boundedAdd = satAdd SatBound {-# INLINE boundedAdd #-}+infixl 6  `boundedAdd`  -- | Subtraction that clips to 'maxBound' on overflow, and 'minBound' on -- underflow boundedSub  :: SaturatingNum a => a -> a -> a boundedSub = satSub SatBound {-# INLINE boundedSub #-}+infixl 6 `boundedSub`  -- | Multiplication that clips to 'maxBound' on overflow, and 'minBound' on -- underflow boundedMul :: SaturatingNum a => a -> a -> a boundedMul = satMul SatBound {-# INLINE boundedMul #-}+infixl 7  `boundedMul`
+ src/Clash/Class/NumConvert.hs view
@@ -0,0 +1,44 @@+{- |+Copyright  :  (C) 2025     , Martijn Bastiaan+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Utilities for converting between Clash number types in a non-erroring way. Its+existence is motivated by the observation that Clash users often need to convert+between different number types (e.g., @Unsigned@ to @Signed@) and that it is not+always clear how to do so properly. Two classes are exported:++* 'NumConvert': for conversions that, based on types, are guaranteed to succeed.+* 'MaybeNumConvert': for conversions that may fail for some values.++As opposed to 'Prelude.fromIntegral', all conversions are translatable to+synthesizable HDL.++== __Relation to @convertible@__+Type classes exported here are similar to the @convertible@ package in that it+aims to facilitate conversions between different types. It is different in three+ways:++ 1. It offers no partial functions+ 2. All its conversions are translatable to synthesizable HDL+ 3. It is focused on (Clash's) number types++== __Implementing 'NumConvert' for your own type__+If you want to implement 'NumConvert' and 'MaybeNumConvert' for your own type,+see 'NumConvertCanonical'.+-}+module Clash.Class.NumConvert (+  NumConvert,+  numConvert,+  MaybeNumConvert,+  maybeNumConvert,++  -- * For implementers only+  NumConvertCanonical(..),+  MaybeNumConvertCanonical(..),+  Canonical,+) where++import Clash.Class.NumConvert.Internal.MaybeNumConvert+import Clash.Class.NumConvert.Internal.NumConvert+import Clash.Class.NumConvert.Internal.Canonical
+ src/Clash/Class/NumConvert/Internal/Canonical.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_HADDOCK hide #-}++#include "MachDeps.h"++{- |+Copyright  :  (C) 2026     , Martijn Bastiaan+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}+module Clash.Class.NumConvert.Internal.Canonical where++import Clash.Sized.BitVector+import Clash.Sized.Index+import Clash.Sized.Signed+import Clash.Sized.Unsigned++import Data.Int (Int16, Int32, Int64, Int8)+import Data.Word (Word16, Word32, Word64, Word8)++-- | Type family mapping types to their canonical \"unwrapped\" Clash form.+-- This is used by 'Clash.Class.NumConvert.numConvert' and+-- 'Clash.Class.NumConvert.maybeNumConvert' to determine the intermediate type.+type family Canonical a++-- Instances for Data.Word types+type instance Canonical Word = Unsigned WORD_SIZE_IN_BITS+type instance Canonical Word64 = Unsigned 64+type instance Canonical Word32 = Unsigned 32+type instance Canonical Word16 = Unsigned 16+type instance Canonical Word8 = Unsigned 8++-- Instances for Data.Int types+type instance Canonical Int = Signed WORD_SIZE_IN_BITS+type instance Canonical Int64 = Signed 64+type instance Canonical Int32 = Signed 32+type instance Canonical Int16 = Signed 16+type instance Canonical Int8 = Signed 8++-- Bit+type instance Canonical Bit = BitVector 1++-- Clash types are already in canonical form+type instance Canonical (Unsigned n) = Unsigned n+type instance Canonical (Signed n) = Signed n+type instance Canonical (BitVector n) = BitVector n+type instance Canonical (Index n) = Index n
+ src/Clash/Class/NumConvert/Internal/MaybeNumConvert.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_HADDOCK hide #-}++{- |+Copyright  :  (C) 2025     , Martijn Bastiaan+                  2025-2026, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}+module Clash.Class.NumConvert.Internal.MaybeNumConvert where++import Clash.Class.BitPack+import Clash.Class.NumConvert.Internal.NumConvert (NumConvertCanonical (..))+import Clash.Class.NumConvert.Internal.Canonical (Canonical)+import Clash.Class.Resize+import Clash.Promoted.Nat+import Clash.Sized.BitVector+import Clash.Sized.Index+import Clash.Sized.Signed+import Clash.Sized.Unsigned++import GHC.TypeLits (KnownNat, type (+), type (^))+import GHC.TypeLits.Extra (CLogWZ)++{- $setup+>>> import Clash.Prelude+>>> import Clash.Class.NumConvert+>>> import Data.Word+>>> import Data.Int+-}++{- | Internal class for concrete conversions that may fail. This class is used+internally by 'MaybeNumConvert' and should not be used directly. Use+'MaybeNumConvert' instead.+-}+class MaybeNumConvertCanonical a b where+  maybeNumConvertCanonical :: a -> Maybe b++{- | Conversions that may fail for some values. A successful conversion retains+the numerical value interpretation of the source type in the target type. A+failure is expressed by returning 'Nothing', never by an 'Clash.XException.XException'.++== __Laws__+A conversion is either successful or it fails gracefully. I.e., it does not+produce errors (also see "Clash.XException"). I.e.,++> x == fromMaybe x (maybeNumConvert @a @b x >>= maybeNumConvert @b @a)++for all values @x@ of type @a@. It should also preserve the numerical value+interpretation of the bits. For types that have an @Integral@ instance, this+intuition is captured by:++> toInteger x == fromMaybe (toInteger x) (toInteger <$> maybeNumConvert @a @b x)++If a conversion succeeds one way, it should also succeed the other way. I.e.,++> isJust (maybeNumConvert @a @b x) `implies` isJust (maybeNumConvert @a @b x >>= maybeNumConvert @b @a)++A conversion should succeed if and only if the value is representable in the+target type. For types that have a @Bounded@ and @Integral@ instance, this+intuition is captured by:++> isJust (maybeNumConvert @a @b x) == (i x >= i (minBound @b) && i x <= i (maxBound @b))++where @i = toInteger@.++All implementations should be total, i.e., they should not produce \"bottoms\".++Additionally, any implementation should be translatable to synthesizable HDL.+-}+type MaybeNumConvert a b =+  ( NumConvertCanonical a (Canonical a)+  , MaybeNumConvertCanonical (Canonical a) (Canonical b)+  , NumConvertCanonical (Canonical b) b+  )++{- | Convert a supplied value of type @a@ to a value of type @b@. If the value+cannot be represented in the target type, 'Nothing' is returned.++>>> maybeNumConvert (1 :: Index 8) :: Maybe (Unsigned 2)+Just 1+>>> maybeNumConvert (7 :: Index 8) :: Maybe (Unsigned 2)+Nothing++For the time being, if the input is an 'Clash.XException.XException', then+the output is too. This property might be relaxed in the future.+-}+maybeNumConvert :: forall a b. MaybeNumConvert a b => a -> Maybe b+maybeNumConvert a =+    fmap (numConvertCanonical @(Canonical b) @b)+  $ maybeNumConvertCanonical @(Canonical a) @(Canonical b)+  $ numConvertCanonical @a @(Canonical a) a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (Index n) (Index m) where+  maybeNumConvertCanonical !a = case natToInteger @m of+    0 -> Nothing+    _ -> maybeResize a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (Index n) (Unsigned m) where+  maybeNumConvertCanonical !a = maybeResize $ bitCoerce @_ @(Unsigned (CLogWZ 2 n 0)) a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (Index n) (Signed m) where+  maybeNumConvertCanonical !a = maybeNumConvertCanonical $ bitCoerce @_ @(Unsigned (CLogWZ 2 n 0)) a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (Index n) (BitVector m) where+  maybeNumConvertCanonical !a = maybeResize $ pack a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (Unsigned n) (Index m) where+  maybeNumConvertCanonical !a = case natToInteger @m of+    0 -> Nothing+    _ -> maybeResize $ bitCoerce @_ @(Index (2 ^ n)) a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (Unsigned n) (Unsigned m) where+  maybeNumConvertCanonical !a = maybeResize a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (Unsigned n) (Signed m) where+  maybeNumConvertCanonical !a = maybeResize $ bitCoerce @(Unsigned (n + 1)) $ extend a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (Unsigned n) (BitVector m) where+  maybeNumConvertCanonical !a = maybeResize $ pack a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (Signed n) (Index m) where+  maybeNumConvertCanonical n = case natToInteger @m of+    0 -> Nothing+    _ | n < 0 -> Nothing+      | otherwise -> maybeResize (bitCoerce @_ @(Index (2 ^ n)) (resize n))++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (Signed n) (Unsigned m) where+  maybeNumConvertCanonical n+    | n < 0 = Nothing+    | otherwise = maybeResize (bitCoerce @(Signed (n + 1)) (extend n))++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (Signed n) (Signed m) where+  maybeNumConvertCanonical !a = maybeResize a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (Signed n) (BitVector m) where+  maybeNumConvertCanonical n+    | n < 0 = Nothing+    | otherwise = maybeResize (pack @(Signed (n + 1)) (extend n))++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (BitVector n) (Index m) where+  maybeNumConvertCanonical !a = case natToInteger @m of+    0 -> Nothing+    _ -> maybeResize $ unpack @(Index (2 ^ n)) a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (BitVector n) (Unsigned m) where+  maybeNumConvertCanonical !a = maybeResize $ unpack @(Unsigned n) a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (BitVector n) (Signed m) where+  maybeNumConvertCanonical !a = maybeResize $ unpack @(Signed (n + 1)) $ extend a++instance (KnownNat n, KnownNat m) => MaybeNumConvertCanonical (BitVector n) (BitVector m) where+  maybeNumConvertCanonical !a = maybeResize a
+ src/Clash/Class/NumConvert/Internal/NumConvert.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_HADDOCK hide #-}++#include "MachDeps.h"++{- |+Copyright  :  (C) 2025     , Martijn Bastiaan+                  2025-2026, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}+module Clash.Class.NumConvert.Internal.NumConvert where++import Prelude++import Clash.Class.BitPack+import Clash.Class.NumConvert.Internal.Canonical+import Clash.Class.Resize+import Clash.Sized.BitVector+import Clash.Sized.Index+import Clash.Sized.Signed+import Clash.Sized.Unsigned++import GHC.TypeLits (KnownNat, type (+), type (<=), type (^))+import GHC.TypeLits.Extra (CLogWZ)++import Data.Int (Int16, Int32, Int64, Int8)+import Data.Word (Word16, Word32, Word64, Word8)++{- $setup+>>> import Clash.Prelude+>>> import Clash.Class.NumConvert+>>> import Data.Word+>>> import Data.Int+-}++{- | Internal class for concrete conversions. This class is used internally by+'NumConvert' and should not be used directly. Use 'NumConvert' instead.++If you want to provide an instance for your own type, please only make an+instance for a direct mapping from and to Clash types and tell the instance+what Clash type it corresponds to. For example, implementing 'Int16' looks like:++> instance NumConvertCanonical Int16 (Signed 16) where+>   numConvertCanonical = bitCoerce+>+> instance NumConvertCanonical (Signed 16) Int16 where+>   numConvertCanonical = bitCoerce+>+> type instance Canonical Int16 = Signed 16++By doing this, your type will be convertable from and to any other type. For+example:++>>> numConvert (10 :: Int16) :: Int32+10+>>> numConvert (15 :: Signed 8) :: Int16+15+-}+class NumConvertCanonical a b where+  numConvertCanonical :: a -> b++{- | Conversions that are, based on their types, guaranteed to succeed. A+successful conversion retains the numerical value interpretation of the source+type in the target type and does not produce errors.++== __Laws__+A conversion is successful if a round trip conversion is lossless. I.e.,++> Just x == maybeNumConvert (numConvert @a @b x)++for all values @x@ of type @a@. It should also preserve the numerical value+interpretation of the bits. For types that have an @Integral@ instance, this+intuition is captured by:++> toInteger x == toInteger (numConvert @a @b x)++Instances should make sure their constraints are as \"tight\" as possible. I.e.,+if an instance's constraints cannot be satisfied, then for the same types+'Clash.Class.NumConvert.maybeNumConvert' should return 'Nothing' for one or more+values in the domain of the source type @a@:++> L.any isNothing (L.map (maybeNumConvert @a @b) [minBound ..])++All implementations should be total, i.e., they should not produce \"bottoms\".++Additionally, any implementation should be translatable to synthesizable HDL.+-}+type NumConvert a b =+  ( NumConvertCanonical a (Canonical a)+  , NumConvertCanonical (Canonical a) (Canonical b)+  , NumConvertCanonical (Canonical b) b+  )++{- | Convert a supplied value of type @a@ to a value of type @b@. The conversion+is guaranteed to succeed.++>>> numConvert (3 :: Index 8) :: Unsigned 8+3++The following will fail with a type error, as we cannot prove that all values+of @Index 8@ can be represented by an @Unsigned 2@:++>>> numConvert (3 :: Index 8) :: Unsigned 2+...++For the time being, if the input is an 'Clash.XException.XException', then+the output is too. This property might be relaxed in the future.+-}+numConvert :: forall a b. NumConvert a b => a -> b+numConvert =+    numConvertCanonical @(Canonical b) @b+  . numConvertCanonical @(Canonical a) @(Canonical b)+  . numConvertCanonical @a @(Canonical a)++instance (KnownNat n, KnownNat m, n <= m) => NumConvertCanonical (Index n) (Index m) where+  numConvertCanonical = resize++instance (KnownNat n, KnownNat m, n <= 2 ^ m) => NumConvertCanonical (Index n) (Unsigned m) where+  numConvertCanonical !a = resize $ bitCoerce a++{- | Note: Conversion from @Index 1@ to @Signed 0@ is lossless, but not within the+constraints of the instance.+-}+instance (KnownNat n, KnownNat m, CLogWZ 2 n 0 + 1 <= m) => NumConvertCanonical (Index n) (Signed m) where+  numConvertCanonical !a = numConvertCanonical $ bitCoerce @_ @(Unsigned (CLogWZ 2 n 0)) a++instance (KnownNat n, KnownNat m, n <= 2 ^ m) => NumConvertCanonical (Index n) (BitVector m) where+  numConvertCanonical !a = resize $ pack a++instance (KnownNat n, KnownNat m, 2 ^ n <= m) => NumConvertCanonical (Unsigned n) (Index m) where+  numConvertCanonical !a = bitCoerce $ resize a++instance (KnownNat n, KnownNat m, n <= m) => NumConvertCanonical (Unsigned n) (Unsigned m) where+  numConvertCanonical = resize++{- | Note: Conversion from @Unsigned 0@ to @Signed 0@ is lossless, but not within the+constraints of the instance.+-}+instance (KnownNat n, KnownNat m, n + 1 <= m) => NumConvertCanonical (Unsigned n) (Signed m) where+  numConvertCanonical !a = bitCoerce $ resize a++instance (KnownNat n, KnownNat m, n <= m) => NumConvertCanonical (Unsigned n) (BitVector m) where+  numConvertCanonical !a = resize $ pack a++instance (KnownNat n, KnownNat m, n <= m) => NumConvertCanonical (Signed n) (Signed m) where+  numConvertCanonical !a = resize a++instance (KnownNat n, KnownNat m, 2 ^ n <= m) => NumConvertCanonical (BitVector n) (Index m) where+  numConvertCanonical = unpack . resize++instance (KnownNat n, KnownNat m, n <= m) => NumConvertCanonical (BitVector n) (Unsigned m) where+  numConvertCanonical = unpack . resize++{- | Note: Conversion from @BitVector 0@ to @Signed 0@ is lossless, but not within the+constraints of the instance.+-}+instance (KnownNat n, KnownNat m, n + 1 <= m) => NumConvertCanonical (BitVector n) (Signed m) where+  numConvertCanonical = unpack . resize++instance (KnownNat n, KnownNat m, n <= m) => NumConvertCanonical (BitVector n) (BitVector m) where+  numConvertCanonical = resize++-- Concrete bidirectional instances for Word types+instance NumConvertCanonical Word (Unsigned WORD_SIZE_IN_BITS) where+  numConvertCanonical = bitCoerce+instance NumConvertCanonical (Unsigned WORD_SIZE_IN_BITS) Word where+  numConvertCanonical = bitCoerce++instance NumConvertCanonical Word64 (Unsigned 64) where+  numConvertCanonical = bitCoerce+instance NumConvertCanonical (Unsigned 64) Word64 where+  numConvertCanonical = bitCoerce++instance NumConvertCanonical Word32 (Unsigned 32) where+  numConvertCanonical = bitCoerce+instance NumConvertCanonical (Unsigned 32) Word32 where+  numConvertCanonical = bitCoerce++instance NumConvertCanonical Word16 (Unsigned 16) where+  numConvertCanonical = bitCoerce+instance NumConvertCanonical (Unsigned 16) Word16 where+  numConvertCanonical = bitCoerce++instance NumConvertCanonical Word8 (Unsigned 8) where+  numConvertCanonical = bitCoerce+instance NumConvertCanonical (Unsigned 8) Word8 where+  numConvertCanonical = bitCoerce++-- Concrete bidirectional instances for Int types+instance NumConvertCanonical Int (Signed WORD_SIZE_IN_BITS) where+  numConvertCanonical = bitCoerce+instance NumConvertCanonical (Signed WORD_SIZE_IN_BITS) Int where+  numConvertCanonical = bitCoerce++instance NumConvertCanonical Int64 (Signed 64) where+  numConvertCanonical = bitCoerce+instance NumConvertCanonical (Signed 64) Int64 where+  numConvertCanonical = bitCoerce++instance NumConvertCanonical Int32 (Signed 32) where+  numConvertCanonical = bitCoerce+instance NumConvertCanonical (Signed 32) Int32 where+  numConvertCanonical = bitCoerce++instance NumConvertCanonical Int16 (Signed 16) where+  numConvertCanonical = bitCoerce+instance NumConvertCanonical (Signed 16) Int16 where+  numConvertCanonical = bitCoerce++instance NumConvertCanonical Int8 (Signed 8) where+  numConvertCanonical = bitCoerce+instance NumConvertCanonical (Signed 8) Int8 where+  numConvertCanonical = bitCoerce++-- Concrete bidirectional instances for Bit+instance NumConvertCanonical Bit (BitVector 1) where+  numConvertCanonical = pack+instance NumConvertCanonical (BitVector 1) Bit where+  numConvertCanonical = unpack
+ src/Clash/Class/Parity.hs view
@@ -0,0 +1,116 @@+{-|+Copyright  :  (C) 2019, QBayLogic+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_HADDOCK show-extensions #-}++#include "MachDeps.h"++module Clash.Class.Parity+  ( Parity (..) )+where++import Prelude hiding                 (even, odd)++import Data.Int+import Data.Word+import Foreign.C.Types                (CUShort)+import GHC.TypeLits                   (KnownNat)++import Clash.Class.BitPack            (pack)+import Clash.Sized.Internal.BitVector (BitVector, high, low, lsb#)+import Clash.Promoted.Nat             (SNat(..), snatToNum)++{- $setup+>>> :m -Prelude+>>> import Clash.Prelude+>>> import Clash.Class.Parity+-}++-- | Determine whether value is odd or even+class Parity a where+  -- | Check if value is even+  --+  -- >>> even (4 :: Unsigned 4)+  -- True+  even :: a -> Bool+  even = not . odd++  -- | Check if value is odd+  --+  -- >>> odd (4 :: Unsigned 4)+  -- False+  odd :: a -> Bool+  odd = not . even+  {-# MINIMAL even | odd #-}++instance Parity Integer+  where+    even a = a `mod` 2 == 0+    odd a = a `mod` 2 == 1++instance KnownNat n => Parity (BitVector n) where+  even a =+    case snatToNum @Integer (SNat @n) of+      0 -> True+      _ -> (==low) $ lsb# a+  odd a =+    case snatToNum @Integer (SNat @n) of+      0 -> False+      _ -> (==high) $ lsb# a++instance Parity Bool where+  even = even . pack+  odd = odd . pack++instance Parity CUShort where+  even = even . pack+  odd = odd . pack++instance Parity Word where+  even = even . pack+  odd = odd . pack++instance Parity Word8 where+  even = even . pack+  odd = odd . pack++instance Parity Word16 where+  even = even . pack+  odd = odd . pack++instance Parity Word32 where+  even = even . pack+  odd = odd . pack++instance Parity Word64 where+  even = even . pack+  odd = odd . pack++instance Parity Int where+  even = even . pack+  odd = odd . pack++instance Parity Int8 where+  even = even . pack+  odd = odd . pack++instance Parity Int16 where+  even = even . pack+  odd = odd . pack++instance Parity Int32 where+  even = even . pack+  odd = odd . pack++instance Parity Int64 where+  even = even . pack+  odd = odd . pack
src/Clash/Class/Resize.hs view
@@ -1,24 +1,42 @@ {-| Copyright  :  (C) 2013-2016, University of Twente+                  2020,      Myrtle Software Ltd+                  2024,      QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# LANGUAGE DataKinds      #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeOperators  #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MonoLocalBinds #-}  {-# LANGUAGE Safe #-}  {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} -module Clash.Class.Resize where+module Clash.Class.Resize+ ( Resize(..) + -- * Resize helpers+ , checkedResize+ , checkedFromIntegral+ , checkedTruncateB+ , maybeResize+ , maybeTruncateB+ ) where++import Data.Kind (Type)+import Data.Proxy (Proxy(Proxy))+import GHC.Stack (HasCallStack) import GHC.TypeLits (Nat, KnownNat, type (+)) +import Clash.Magic (clashSimulation)+import Clash.Sized.Internal (formatRange)++import GHC.TypeLits (OrderingI(EQI, GTI), cmpNat)+ -- | Coerce a value to be represented by a different number of bits-class Resize (f :: Nat -> *) where+class Resize (f :: Nat -> Type) where   -- | A sign-preserving resize operation   --   -- * For signed datatypes: Increasing the size of the number replicates the@@ -40,3 +58,94 @@   signExtend = resize   -- | Remove bits from the MSB   truncateB :: KnownNat a => f (a + b) -> f a++-- | Helper function of 'checkedFromIntegral', 'checkedResize' and 'checkedTruncateB'+checkIntegralSimOnly ::+  forall a b.+  HasCallStack =>+  (Integral a, Integral b, Bounded b) =>+  Proxy b ->+  a -> a+checkIntegralSimOnly Proxy v =+  if clashSimulation+  && (toInteger v > toInteger (maxBound @b)+  || toInteger v < toInteger (minBound @b)) then+    error $ "Given integral " <> show (toInteger v) <> " is out of bounds for" <>+            " target type. Bounds of target type are: " <>+            formatRange (toInteger (minBound @b)) (toInteger (maxBound @b)) <> "."+  else+    v++-- | Like 'fromIntegral', but errors if /a/ is out of bounds for /b/. Useful when+-- you "know" /a/ can't be out of bounds, but would like to have your assumptions+-- checked.+--+-- * __NB__: Check only affects simulation. I.e., no checks will be inserted+-- into the generated HDL+-- * __NB__: 'fromIntegral' is not well suited for Clash as it will go through+-- 'Integer' which is arbitrarily bounded in HDL. Instead use+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class.+checkedFromIntegral ::+  forall a b.+  HasCallStack =>+  (Integral a, Integral b, Bounded b) =>+  a -> b+checkedFromIntegral v = fromIntegral (checkIntegralSimOnly (Proxy @b) v)++-- | Like 'resize', but errors if /f a/ is out of bounds for /f b/. Useful when+-- you "know" /f a/ can't be out of bounds, but would like to have your+-- assumptions checked.+--+-- __NB__: Check only affects simulation. I.e., no checks will be inserted+-- into the generated HDL+checkedResize ::+  forall a b f.+  ( HasCallStack+  , Resize f+  , KnownNat a, Integral (f a)+  , KnownNat b, Integral (f b), Bounded (f b) ) =>+  f a -> f b+checkedResize v = resize (checkIntegralSimOnly (Proxy @(f b)) v)++-- | Like 'truncateB', but errors if /f (a + b)/ is out of bounds for /f a/. Useful+-- when you "know" /f (a + b)/ can't be out of bounds, but would like to have your+-- assumptions checked.+--+-- __NB__: Check only affects simulation. I.e., no checks will be inserted+-- into the generated HDL+checkedTruncateB ::+  forall a b f.+  ( HasCallStack+  , Resize f+  , KnownNat b, Integral (f (a + b))+  , KnownNat a, Integral (f a), Bounded (f a) ) =>+  f (a + b) -> f a+checkedTruncateB v = truncateB (checkIntegralSimOnly (Proxy @(f a)) v)++-- | Like 'resize', but returns 'Nothing' if the argument is out of bounds for+-- the result type.+maybeResize ::+  forall a b f.+  ( Resize f+  , KnownNat a, Integral (f a)+  , KnownNat b, Integral (f b), Bounded (f b) ) =>+  f a -> Maybe (f b)+maybeResize v =+  case Proxy @a `cmpNat` Proxy @b of+    GTI | v > resize (maxBound @(f b)) -> Nothing+    GTI | v < resize (minBound @(f b)) -> Nothing+    EQI -> Just v+    _ -> Just (resize v)++-- | Like 'truncateB', but returns 'Nothing' if the argument is out of bounds for+-- the result type.+maybeTruncateB ::+  forall a b f.+  ( Resize f+  , KnownNat b, Integral (f (a + b))+  , KnownNat a, Integral (f a), Bounded (f a) ) =>+  f (a + b) -> Maybe (f a)+maybeTruncateB v+  | v > resize (maxBound @(f a)) = Nothing+  | v < resize (minBound @(f a)) = Nothing+  | otherwise = Just (truncateB v)
src/Clash/Clocks.hs view
@@ -1,29 +1,43 @@ {-| Copyright  :  (C) 2018, Google Inc                   2019, Myrtle Software Ltd+                  2023,      QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  Generic clock related utilities. -} -{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE InstanceSigs        #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} -module Clash.Clocks (Clocks, clocks) where+{-# OPTIONS_GHC "-Wno-orphans" #-} -import Clash.Signal.Internal-import Clash.Clocks.Deriving (deriveClocksInstances)+module Clash.Clocks+  ( Clocks(..)+  , ClocksSync(..)+  , ClocksSyncCxt+  , NumOutClocksSync+  ) where -class Clocks t where-  clocks-    :: Clock domIn-    -> Reset domIn-    -> t+import Clash.Clocks.Internal+  (Clocks(..), ClocksSync(..), deriveClocksInstances, deriveClocksSyncInstances)+import Clash.Signal.Internal (Domain, KnownDomain) -deriveClocksInstances 16+deriveClocksInstances++type ClocksSyncCxt t (domIn :: Domain) =+  ( KnownDomain domIn+  , ClocksSync t+  , ClocksResetSynchronizerCxt t+  , Clocks (ClocksSyncClocksInst t domIn)+  , ClocksCxt (ClocksSyncClocksInst t domIn)+  )++type NumOutClocksSync t (domIn :: Domain) =+  NumOutClocks (ClocksSyncClocksInst t domIn)++deriveClocksSyncInstances
− src/Clash/Clocks/Deriving.hs 
@@ -1,55 +0,0 @@-{-|-Copyright  :  (C) 2018, Google Inc-                  2019, Myrtle Software Ltd-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE ViewPatterns      #-}--module Clash.Clocks.Deriving (deriveClocksInstances) where--import Control.Monad               (foldM)-import Clash.Signal.Internal-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Lib-import Unsafe.Coerce               (unsafeCoerce)---- Derive instance for /n/ clocks-derive' :: Int -> Q Dec-derive' n = do-  -- (Clock d0, Clock d1, )-  instType  <- foldM (\a n' -> AppT a <$> clkType n') (TupleT $ n + 1) [1..n]-  instType' <- (AppT (ConT $ mkName "Clocks") . AppT instType) <$> lockType--  -- Function definition of 'clocks'-  let clk = mkName "clk"-  let rst = mkName "rst"--  -- Implementation of 'clocks'-  let noInline  = PragmaD $ InlineP (mkName "clocks") NoInline FunLike AllPhases-  let clkImpls  = replicate n (clkImpl clk)-  let instTuple = TupE $ clkImpls ++ [AppE (VarE 'unsafeCoerce) (VarE rst)]-  let funcBody  = NormalB instTuple-  let instFunc  = FunD (mkName "clocks") [Clause [VarP clk, VarP rst] funcBody []]--  return $ InstanceD Nothing [] instType' [instFunc, noInline]--  where-    -- | Generate type @Clock dom@ with fresh @dom@ variable-    clkType n' =-      let c = varT $ mkName ("c" ++ show n') in-      [t| Clock $c |]--    -- | Generate type @Signal dom 'Bool@ with fresh @dom@ variable-    lockType =-      let c = varT $ mkName "pllLock" in-      [t| Signal $c Bool |]--    clkImpl clk = AppE (VarE 'unsafeCoerce) (VarE clk)---- Derive instances for up to and including to /n/ clocks-deriveClocksInstances :: Int -> Q [Dec]-deriveClocksInstances n = mapM derive' [1..n]
+ src/Clash/Clocks/Internal.hs view
@@ -0,0 +1,159 @@+{-|+Copyright  :  (C) 2018-2022, Google Inc+                  2019,      Myrtle Software Ltd+                  2023,      QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Clash.Clocks.Internal+  ( Clocks(..)+  , deriveClocksInstances+  , ClocksSync(..)+  , deriveClocksSyncInstances+  ) where++import Control.Monad.Extra (concatMapM)+import Data.Kind (Constraint, Type)+import GHC.TypeLits (Nat)+import Language.Haskell.TH hiding (Type)++import Clash.CPP (haddockOnly)+import Clash.Explicit.Reset (resetSynchronizer)+import Clash.Explicit.Signal (unsafeSynchronizer)+import Clash.Magic (setName)+import Clash.Promoted.Symbol (SSymbol(..))+import Clash.Signal.Internal+  (clockGen, Clock(..), Domain, KnownDomain, Reset, Signal, unsafeFromActiveLow,+   unsafeToActiveLow)++-- | __NB__: The documentation only shows instances up to /3/ output clocks. By+-- default, instances up to and including /18/ clocks will exist.+class Clocks t where+  type ClocksCxt t :: Constraint+  type NumOutClocks t :: Nat++  clocks ::+    (KnownDomain domIn, ClocksCxt t) =>+    Clock domIn ->+    Reset domIn ->+    t++-- Derive instance for /n/ clocks+deriveClocksInstance :: Int -> DecsQ+deriveClocksInstance n =+  [d| instance Clocks $instType where+        type ClocksCxt $instType = $cxtType+        type NumOutClocks $instType = $numOutClocks++        clocks (Clock _ Nothing) $(varP rst) = $funcImpl+        clocks _ _ = error "clocks: dynamic clocks unsupported"+        {-# OPAQUE clocks #-}+    |]+ where+  clkTyVar m = varT $ mkName $ "c" <> show m+  clkTypes = map (\m -> [t| Clock $(clkTyVar m) |]) [1..n]+  lockTyVar = varT $ mkName "pllLock"+  -- (Clock c1, Clock c2, ..., Signal pllLock Bool)+  instType = foldl appT (tupleT $ n + 1) $+               clkTypes <> [ [t| Signal $lockTyVar Bool |] ]+  clkKnownDoms = map (\m -> [t| KnownDomain $(clkTyVar m) |]) [1..n]+  -- (KnownDomain c1, KnownDomain c2, ..., KnownDomain pllLock)+  cxtType = foldl appT (tupleT $ n + 1) $+              clkKnownDoms <> [ [t| KnownDomain $lockTyVar |] ]+  numOutClocks = litT . numTyLit $ toInteger n++  -- 'clocks' function+  rst = mkName "rst"+  lockImpl = [|+    unsafeSynchronizer clockGen clockGen (unsafeToActiveLow $(varE rst))+    |]+  clkImpls = replicate n [| Clock SSymbol Nothing |]+  funcImpl = tupE $ clkImpls <> [lockImpl]++-- Derive instances for up to and including 18 clocks, except when we are+-- generating Haddock+deriveClocksInstances :: DecsQ+deriveClocksInstances = concatMapM deriveClocksInstance [1..n]+ where+  n | haddockOnly = 3+    | otherwise   = 18++-- | __NB__: The documentation only shows instances up to /3/ output clocks. By+-- default, instances up to and including /18/ clocks will exist.+class ClocksSync t where+  type ClocksSyncClocksInst t (domIn :: Domain) :: Type+  type ClocksResetSynchronizerCxt t :: Constraint++  clocksResetSynchronizer ::+    ( KnownDomain domIn+    , ClocksResetSynchronizerCxt t+    ) =>+    ClocksSyncClocksInst t domIn ->+    Clock domIn ->+    t++-- Derive instance for /n/ clocks+deriveClocksSyncInstance :: Int -> DecsQ+deriveClocksSyncInstance n =+  [d|+    instance ClocksSync $instType where+      type ClocksSyncClocksInst $instType $domInTyVar = $clocksInstType+      type ClocksResetSynchronizerCxt $instType = $cxtType++      clocksResetSynchronizer pllOut $(varP clkIn) =+        let $pllPat = pllOut+        in $funcImpl+  |]+ where+  clkVarName m = mkName $ "c" <> show m+  clkTyVar :: Int -> TypeQ+  clkTyVar = varT . clkVarName+  clkAndRstTy m = [ [t| Clock $(clkTyVar m) |]+                  , [t| Reset $(clkTyVar m) |]+                  ]+  -- (Clock c1, Reset c1, Clock c2, Reset c2, ...)+  instType = foldl appT (tupleT $ n * 2) $ concatMap clkAndRstTy [1..n]+  domInTyVar = varT $ mkName "domIn"+  clkTypes = map (\m -> [t| Clock $(clkTyVar m) |]) [1..n]+  -- (Clock c1, Clock c2, ..., Signal domIn Bool)+  clocksInstType = foldl appT (tupleT $ n + 1) $+                     clkTypes <> [ [t| Signal $domInTyVar Bool |] ]+  -- (KnownDomain c1, KnownDomain c2, ...)+  cxtType+    | n == 1+    = [t| KnownDomain $(clkTyVar 1) |]+    | otherwise+    = foldl appT (tupleT n) $+        map (\m -> [t| KnownDomain $(clkTyVar m) |]) [1..n]++  -- 'clocksResetSynchronizer' function+  clkIn = mkName "clkIn"+  pllLock = mkName "pllLock"+  -- (c1, c2, ..., pllLock)+  pllPat = tupP $ map (varP . clkVarName) [1..n] <> [varP pllLock]+  syncImpl m =+    [|+      setName @"resetSynchronizer" (resetSynchronizer $(varE $ clkVarName m)+        (unsafeFromActiveLow+          (unsafeSynchronizer $(varE clkIn) $(varE $ clkVarName m)+                              $(varE pllLock))))+    |]+  clkAndRstExp m = [ varE $ clkVarName m+                   , syncImpl m+                   ]+  -- (c1, r1, c2, r2, ...) where rN is the synchronized reset for clock N+  funcImpl = tupE $ concatMap clkAndRstExp [1..n]++-- Derive instances for up to and including 18 clocks, except when we are+-- generating Haddock+deriveClocksSyncInstances :: DecsQ+deriveClocksSyncInstances = concatMapM deriveClocksSyncInstance [1..n]+ where+  n | haddockOnly = 3+    | otherwise   = 18
src/Clash/Examples.hs view
@@ -2,18 +2,13 @@ Copyright : © 2015-2016, Christiaan Baaij,               2017     , Google Inc.               2019     , Myrtle Software Ltd-Licence   : Creative Commons 4.0 (CC BY 4.0) (http://creativecommons.org/licenses/by/4.0/)+Licence   : Creative Commons 4.0 (CC BY 4.0) (https://creativecommons.org/licenses/by/4.0/) -} -{-# LANGUAGE NoImplicitPrelude, CPP, TemplateHaskell, DataKinds, BinaryLiterals,-             FlexibleContexts, GADTs, TypeOperators, TypeApplications,-             RecordWildCards, DeriveGeneric, DeriveAnyClass #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-unused-imports #-}+ module Clash.Examples (   -- * Decoders and Encoders   -- $decoders_and_encoders@@ -29,281 +24,16 @@   ) where -import Clash.Prelude hiding (feedback)+import Clash.Prelude import Control.Lens import Control.Monad import Control.Monad.Trans.State -decoderCase :: Bool -> BitVector 4 -> BitVector 16-decoderCase enable binaryIn | enable =-  case binaryIn of-    0x0 -> 0x0001-    0x1 -> 0x0002-    0x2 -> 0x0004-    0x3 -> 0x0008-    0x4 -> 0x0010-    0x5 -> 0x0020-    0x6 -> 0x0040-    0x7 -> 0x0080-    0x8 -> 0x0100-    0x9 -> 0x0200-    0xA -> 0x0400-    0xB -> 0x0800-    0xC -> 0x1000-    0xD -> 0x2000-    0xE -> 0x4000-    0xF -> 0x8000-decoderCase _ _ = 0--decoderShift :: Bool -> BitVector 4 -> BitVector 16-decoderShift enable binaryIn =-  if enable-     then 1 `shiftL` (fromIntegral binaryIn)-     else 0--encoderCase :: Bool -> BitVector 16 -> BitVector 4-encoderCase enable binaryIn | enable =-  case binaryIn of-    0x0001 -> 0x0-    0x0002 -> 0x1-    0x0004 -> 0x2-    0x0008 -> 0x3-    0x0010 -> 0x4-    0x0020 -> 0x5-    0x0040 -> 0x6-    0x0080 -> 0x7-    0x0100 -> 0x8-    0x0200 -> 0x9-    0x0400 -> 0xA-    0x0800 -> 0xB-    0x1000 -> 0xC-    0x2000 -> 0xD-    0x4000 -> 0xE-    0x8000 -> 0xF-encoderCase _ _ = 0--upCounter-  :: HiddenClockResetEnable dom-  => Signal dom Bool-  -> Signal dom (Unsigned 8)-upCounter enable = s-  where-    s = register 0 (mux enable (s + 1) s)--upCounterLdT-  :: Num a => a -> (Bool, Bool, a) -> (a,a)-upCounterLdT s (ld,en,dIn) = (s',s)-  where-    s' | ld        = dIn-       | en        = s + 1-       | otherwise = s--upCounterLd-  :: HiddenClockResetEnable dom-  => Signal dom (Bool, Bool, Unsigned 8)-  -> Signal dom (Unsigned 8)-upCounterLd = mealy upCounterLdT 0--upDownCounter-  :: HiddenClockResetEnable dom-  => Signal dom Bool-  -> Signal dom (Unsigned 8)-upDownCounter upDown = s-  where-    s = register 0 (mux upDown (s + 1) (s - 1))--lfsrF' :: BitVector 16 -> BitVector 16-lfsrF' s = pack feedback ++# slice d15 d1 s-  where-    feedback = s!5 `xor` s!3 `xor` s!2 `xor` s!0--lfsrF-  :: HiddenClockResetEnable dom-  => BitVector 16 -> Signal dom Bit-lfsrF seed = msb <$> r-  where r = register seed (lfsrF' <$> r)--lfsrGP-  :: (KnownNat (n + 1), Bits a)-  => Vec (n + 1) Bool-  -> Vec (n + 1) a-  -> Vec (n + 1) a-lfsrGP taps regs = zipWith xorM taps (fb +>> regs)-  where-    fb = last regs-    xorM i x | i         =  x `xor` fb-             | otherwise = x--lfsrG-  :: HiddenClockResetEnable dom-  => BitVector 16-  -> Signal dom Bit-lfsrG seed = last (unbundle r)-  where r = register (unpack seed) (lfsrGP (unpack 0b0011010000000000) <$> r)--grayCounter-  :: HiddenClockResetEnable dom-  => Signal dom Bool-  -> Signal dom (BitVector 8)-grayCounter en = gray <$> upCounter en-  where gray xs = pack (msb xs) ++# xor (slice d7 d1 xs) (slice d6 d0 xs)--oneHotCounter-  :: HiddenClockResetEnable dom-  => Signal dom Bool-  -> Signal dom (BitVector 8)-oneHotCounter enable = s-  where-    s = register 1 (mux enable (rotateL <$> s <*> 1) s)--crcT-  :: ( Bits a-     , KnownNat (BitSize a)-     , BitPack a-     )-  => a-  -> Bit-  -> a-crcT bv dIn = replaceBit 0  dInXor-            $ replaceBit 5  (bv!4  `xor` dInXor)-            $ replaceBit 12 (bv!11 `xor` dInXor)-              rotated-  where-    dInXor  = dIn `xor` fb-    rotated = rotateL bv 1-    fb      = msb bv--crc-  :: HiddenClockResetEnable dom-  => Signal dom Bool-  -> Signal dom Bool-  -> Signal dom Bit-  -> Signal dom (BitVector 16)-crc enable ld dIn = s-  where-    s = register 0xFFFF (mux enable (mux ld 0xFFFF (crcT <$> s <*> dIn)) s)--data RxReg-  = RxReg-  { _rx_reg        :: BitVector 8-  , _rx_data       :: BitVector 8-  , _rx_sample_cnt :: Unsigned 4-  , _rx_cnt        :: Unsigned 4-  , _rx_frame_err  :: Bool-  , _rx_over_run   :: Bool-  , _rx_empty      :: Bool-  , _rx_d1         :: Bit-  , _rx_d2         :: Bit-  , _rx_busy       :: Bool-  } deriving (Generic, NFDataX)--makeLenses ''RxReg--data TxReg-  = TxReg-  { _tx_reg      :: BitVector 8-  , _tx_empty    :: Bool-  , _tx_over_run :: Bool-  , _tx_out      :: Bit-  , _tx_cnt      :: Unsigned 4-  }-  deriving (Generic, NFDataX)--makeLenses ''TxReg--uartTX t@(TxReg {..}) ld_tx_data tx_data tx_enable = flip execState t $ do-  when ld_tx_data $ do-    if not _tx_empty then-      tx_over_run .= False-    else do-      tx_reg   .= tx_data-      tx_empty .= False-  when (tx_enable && not _tx_empty) $ do-    tx_cnt += 1-    when (_tx_cnt == 0) $-      tx_out .= 0-    when (_tx_cnt > 0 && _tx_cnt < 9) $-      tx_out .= _tx_reg ! (_tx_cnt - 1)-    when (_tx_cnt == 9) $ do-      tx_out   .= 1-      tx_cnt   .= 0-      tx_empty .= True-  unless tx_enable $-    tx_cnt .= 0--uartRX r@(RxReg {..}) rx_in uld_rx_data rx_enable = flip execState r $ do-  -- Synchronize the async signal-  rx_d1 .= rx_in-  rx_d2 .= _rx_d1-  -- Uload the rx data-  when uld_rx_data $ do-    rx_data  .= _rx_reg-    rx_empty .= True-  -- Receive data only when rx is enabled-  if rx_enable then do-    -- Check if just received start of frame-    when (not _rx_busy && _rx_d2 == 0) $ do-      rx_busy       .= True-      rx_sample_cnt .= 1-      rx_cnt        .= 0-    -- Star of frame detected, Proceed with rest of data-    when _rx_busy $ do-      rx_sample_cnt += 1-      -- Logic to sample at middle of data-      when (_rx_sample_cnt == 7) $ do-        if _rx_d1 == 1 && _rx_cnt == 0 then-          rx_busy .= False-        else do-          rx_cnt += 1-          -- start storing the rx data-          when (_rx_cnt > 0 && _rx_cnt < 9) $ do-            rx_reg %= replaceBit (_rx_cnt - 1) _rx_d2-          when (_rx_cnt == 9) $ do-            rx_busy .= False-            -- Check if End of frame received correctly-            if _rx_d2 == 0 then-              rx_frame_err .= True-            else do-              rx_empty     .= False-              rx_frame_err .= False-              -- Check if last rx data was not unloaded-              rx_over_run  .= not _rx_empty-  else do-    rx_busy .= False--uart ld_tx_data tx_data tx_enable rx_in uld_rx_data rx_enable =-    ( _tx_out   <$> txReg-    , _tx_empty <$> txReg-    , _rx_data  <$> rxReg-    , _rx_empty <$> rxReg-    )-  where-    rxReg     = register rxRegInit (uartRX <$> rxReg <*> rx_in <*> uld_rx_data-                                           <*> rx_enable)-    rxRegInit = RxReg { _rx_reg        = 0-                      , _rx_data       = 0-                      , _rx_sample_cnt = 0-                      , _rx_cnt        = 0-                      , _rx_frame_err  = False-                      , _rx_over_run   = False-                      , _rx_empty      = True-                      , _rx_d1         = 1-                      , _rx_d2         = 1-                      , _rx_busy       = False-                      }-    txReg     = register txRegInit (uartTX <$> txReg <*> ld_tx_data <*> tx_data-                                           <*> tx_enable)-    txRegInit = TxReg { _tx_reg      = 0-                      , _tx_empty    = True-                      , _tx_over_run = False-                      , _tx_out      = 1-                      , _tx_cnt      = 0-                      }- {- $setup >>> :set -XDataKinds >>> import Clash.Prelude->>> import Test.QuickCheck+>>> import Test.QuickCheck ((===))+>>> import Clash.Examples.Internal -}  {- $decoders_and_encoders@@ -347,9 +77,9 @@ Examples:  >>> decoderCase True 3-0000_0000_0000_1000+0b0000_0000_0000_1000 >>> decoderShift True 7-0000_0000_1000_0000+0b0000_0000_1000_0000  The following property holds: @@ -551,6 +281,7 @@ {- $uart @ {\-\# LANGUAGE RecordWildCards \#-\}+ module UART (uart) where  import Clash.Prelude@@ -571,7 +302,7 @@   , _rx_d1         :: Bit   , _rx_d2         :: Bit   , _rx_busy       :: Bool-  }+  } deriving (Generic, NFDataX)  makeLenses ''RxReg @@ -590,7 +321,7 @@       rx_busy       '.=' True       rx_sample_cnt '.=' 1       rx_cnt        '.=' 0-    -- Star of frame detected, Proceed with rest of data+    -- Start of frame detected, proceed with rest of data     'when' _rx_busy $ do       rx_sample_cnt '+=' 1       -- Logic to sample at middle of data@@ -623,7 +354,7 @@   , _tx_over_run :: Bool   , _tx_out      :: Bit   , _tx_cnt      :: Unsigned 4-  }+  } deriving (Generic, NFDataX)  makeLenses ''TxReg
+ src/Clash/Examples/Internal.hs view
@@ -0,0 +1,290 @@+{-|+Copyright : © 2015-2016, Christiaan Baaij,+              2017     , Google Inc.+              2019     , Myrtle Software Ltd+Licence   : Creative Commons 4.0 (CC BY 4.0) (https://creativecommons.org/licenses/by/4.0/)+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}++module Clash.Examples.Internal where++import Clash.Prelude hiding (feedback)+import Control.Lens+import Control.Monad+import Control.Monad.Trans.State++decoderCase :: Bool -> BitVector 4 -> BitVector 16+decoderCase enable binaryIn | enable =+  case binaryIn of+    0x0 -> 0x0001+    0x1 -> 0x0002+    0x2 -> 0x0004+    0x3 -> 0x0008+    0x4 -> 0x0010+    0x5 -> 0x0020+    0x6 -> 0x0040+    0x7 -> 0x0080+    0x8 -> 0x0100+    0x9 -> 0x0200+    0xA -> 0x0400+    0xB -> 0x0800+    0xC -> 0x1000+    0xD -> 0x2000+    0xE -> 0x4000+    0xF -> 0x8000+decoderCase _ _ = 0++decoderShift :: Bool -> BitVector 4 -> BitVector 16+decoderShift enable binaryIn =+  if enable+     then 1 `shiftL` (fromIntegral binaryIn)+     else 0++encoderCase :: Bool -> BitVector 16 -> BitVector 4+encoderCase enable binaryIn | enable =+  case binaryIn of+    0x0001 -> 0x0+    0x0002 -> 0x1+    0x0004 -> 0x2+    0x0008 -> 0x3+    0x0010 -> 0x4+    0x0020 -> 0x5+    0x0040 -> 0x6+    0x0080 -> 0x7+    0x0100 -> 0x8+    0x0200 -> 0x9+    0x0400 -> 0xA+    0x0800 -> 0xB+    0x1000 -> 0xC+    0x2000 -> 0xD+    0x4000 -> 0xE+    0x8000 -> 0xF+encoderCase _ _ = 0++upCounter+  :: HiddenClockResetEnable dom+  => Signal dom Bool+  -> Signal dom (Unsigned 8)+upCounter enable = s+  where+    s = register 0 (mux enable (s + 1) s)++upCounterLdT+  :: Num a => a -> (Bool, Bool, a) -> (a,a)+upCounterLdT s (ld,en,dIn) = (s',s)+  where+    s' | ld        = dIn+       | en        = s + 1+       | otherwise = s++upCounterLd+  :: HiddenClockResetEnable dom+  => Signal dom (Bool, Bool, Unsigned 8)+  -> Signal dom (Unsigned 8)+upCounterLd = mealy upCounterLdT 0++upDownCounter+  :: HiddenClockResetEnable dom+  => Signal dom Bool+  -> Signal dom (Unsigned 8)+upDownCounter upDown = s+  where+    s = register 0 (mux upDown (s + 1) (s - 1))++lfsrF' :: BitVector 16 -> BitVector 16+lfsrF' s = pack feedback ++# slice (SNat @15) d1 s+  where+    feedback = s!5 `xor` s!3 `xor` s!2 `xor` s!0++lfsrF+  :: HiddenClockResetEnable dom+  => BitVector 16 -> Signal dom Bit+lfsrF seed = msb <$> r+  where r = register seed (lfsrF' <$> r)++lfsrGP+  :: (KnownNat (n + 1), Bits a)+  => Vec (n + 1) Bool+  -> Vec (n + 1) a+  -> Vec (n + 1) a+lfsrGP taps regs = zipWith xorM taps (fb +>> regs)+  where+    fb = last regs+    xorM i x | i         =  x `xor` fb+             | otherwise = x++lfsrG+  :: HiddenClockResetEnable dom+  => BitVector 16+  -> Signal dom Bit+lfsrG seed = last (unbundle r)+  where r = register (unpack seed) (lfsrGP (unpack 0b0011010000000000) <$> r)++grayCounter+  :: HiddenClockResetEnable dom+  => Signal dom Bool+  -> Signal dom (BitVector 8)+grayCounter en = gray <$> upCounter en+  where gray xs = pack (msb xs) ++# xor (slice d7 d1 xs) (slice d6 d0 xs)++oneHotCounter+  :: HiddenClockResetEnable dom+  => Signal dom Bool+  -> Signal dom (BitVector 8)+oneHotCounter enable = s+  where+    s = register 1 (mux enable (rotateL <$> s <*> 1) s)++crcT+  :: (Bits a, BitPack a)+  => a+  -> Bit+  -> a+crcT bv dIn = replaceBit 0  dInXor+            $ replaceBit 5  (bv!4  `xor` dInXor)+            $ replaceBit 12 (bv!11 `xor` dInXor)+              rotated+  where+    dInXor  = dIn `xor` fb+    rotated = rotateL bv 1+    fb      = msb bv++crc+  :: HiddenClockResetEnable dom+  => Signal dom Bool+  -> Signal dom Bool+  -> Signal dom Bit+  -> Signal dom (BitVector 16)+crc enable ld dIn = s+  where+    s = register 0xFFFF (mux enable (mux ld 0xFFFF (crcT <$> s <*> dIn)) s)++data RxReg+  = RxReg+  { _rx_reg        :: BitVector 8+  , _rx_data       :: BitVector 8+  , _rx_sample_cnt :: Unsigned 4+  , _rx_cnt        :: Unsigned 4+  , _rx_frame_err  :: Bool+  , _rx_over_run   :: Bool+  , _rx_empty      :: Bool+  , _rx_d1         :: Bit+  , _rx_d2         :: Bit+  , _rx_busy       :: Bool+  } deriving (Generic, NFDataX)++makeLenses ''RxReg++data TxReg+  = TxReg+  { _tx_reg      :: BitVector 8+  , _tx_empty    :: Bool+  , _tx_over_run :: Bool+  , _tx_out      :: Bit+  , _tx_cnt      :: Unsigned 4+  }+  deriving (Generic, NFDataX)++makeLenses ''TxReg++uartTX t@(TxReg {..}) ld_tx_data tx_data tx_enable = flip execState t $ do+  when ld_tx_data $ do+    if not _tx_empty then+      tx_over_run .= False+    else do+      tx_reg   .= tx_data+      tx_empty .= False+  when (tx_enable && not _tx_empty) $ do+    tx_cnt += 1+    when (_tx_cnt == 0) $+      tx_out .= 0+    when (_tx_cnt > 0 && _tx_cnt < 9) $+      tx_out .= _tx_reg ! (_tx_cnt - 1)+    when (_tx_cnt == 9) $ do+      tx_out   .= 1+      tx_cnt   .= 0+      tx_empty .= True+  unless tx_enable $+    tx_cnt .= 0++uartRX r@(RxReg {..}) rx_in uld_rx_data rx_enable = flip execState r $ do+  -- Synchronize the async signal+  rx_d1 .= rx_in+  rx_d2 .= _rx_d1+  -- Uload the rx data+  when uld_rx_data $ do+    rx_data  .= _rx_reg+    rx_empty .= True+  -- Receive data only when rx is enabled+  if rx_enable then do+    -- Check if just received start of frame+    when (not _rx_busy && _rx_d2 == 0) $ do+      rx_busy       .= True+      rx_sample_cnt .= 1+      rx_cnt        .= 0+    -- Star of frame detected, Proceed with rest of data+    when _rx_busy $ do+      rx_sample_cnt += 1+      -- Logic to sample at middle of data+      when (_rx_sample_cnt == 7) $ do+        if _rx_d1 == 1 && _rx_cnt == 0 then+          rx_busy .= False+        else do+          rx_cnt += 1+          -- start storing the rx data+          when (_rx_cnt > 0 && _rx_cnt < 9) $ do+            rx_reg %= replaceBit (_rx_cnt - 1) _rx_d2+          when (_rx_cnt == 9) $ do+            rx_busy .= False+            -- Check if End of frame received correctly+            if _rx_d2 == 0 then+              rx_frame_err .= True+            else do+              rx_empty     .= False+              rx_frame_err .= False+              -- Check if last rx data was not unloaded+              rx_over_run  .= not _rx_empty+  else do+    rx_busy .= False++uart ld_tx_data tx_data tx_enable rx_in uld_rx_data rx_enable =+    ( _tx_out   <$> txReg+    , _tx_empty <$> txReg+    , _rx_data  <$> rxReg+    , _rx_empty <$> rxReg+    )+  where+    rxReg     = register rxRegInit (uartRX <$> rxReg <*> rx_in <*> uld_rx_data+                                           <*> rx_enable)+    rxRegInit = RxReg { _rx_reg        = 0+                      , _rx_data       = 0+                      , _rx_sample_cnt = 0+                      , _rx_cnt        = 0+                      , _rx_frame_err  = False+                      , _rx_over_run   = False+                      , _rx_empty      = True+                      , _rx_d1         = 1+                      , _rx_d2         = 1+                      , _rx_busy       = False+                      }+    txReg     = register txRegInit (uartTX <$> txReg <*> ld_tx_data <*> tx_data+                                           <*> tx_enable)+    txRegInit = TxReg { _tx_reg      = 0+                      , _tx_empty    = True+                      , _tx_over_run = False+                      , _tx_out      = 1+                      , _tx_cnt      = 0+                      }
src/Clash/Explicit/BlockRam.hs view
@@ -1,1044 +1,1535 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2016-2017, Myrtle Software Ltd,-                  2017     , Google Inc.-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--BlockRAM primitives--= Using RAMs #usingrams#--We will show a rather elaborate example on how you can, and why you might want-to use 'blockRam's. We will build a \"small\" CPU+Memory+Program ROM where we-will slowly evolve to using blockRams. Note that the code is /not/ meant as a-de-facto standard on how to do CPU design in Clash.--We start with the definition of the Instructions, Register names and machine-codes:--@-{\-\# LANGUAGE RecordWildCards, TupleSections, DeriveAnyClass \#-\}-module CPU where--import Clash.Explicit.Prelude--type InstrAddr = Unsigned 8-type MemAddr   = Unsigned 5-type Value     = Signed 8--data Instruction-  = Compute Operator Reg Reg Reg-  | Branch Reg Value-  | Jump Value-  | Load MemAddr Reg-  | Store Reg MemAddr-  | Nop-  deriving (Eq,Show)--data Reg-  = Zero-  | PC-  | RegA-  | RegB-  | RegC-  | RegD-  | RegE-  deriving (Eq,Show,Enum)--data Operator = Add | Sub | Incr | Imm | CmpGt-  deriving (Eq,Show)--data MachCode-  = MachCode-  { inputX  :: Reg-  , inputY  :: Reg-  , result  :: Reg-  , aluCode :: Operator-  , ldReg   :: Reg-  , rdAddr  :: MemAddr-  , wrAddrM :: Maybe MemAddr-  , jmpM    :: Maybe Value-  }--nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm-                    , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing-                    , jmpM = Nothing-                    }-@--Next we define the CPU and its ALU:--@-cpu-  :: Vec 7 Value-  -- ^ Register bank-  -> (Value,Instruction)-  -- ^ (Memory output, Current instruction)-  -> ( Vec 7 Value-     , (MemAddr, Maybe (MemAddr,Value), InstrAddr)-     )-cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) '<$>' wrAddrM,fromIntegral ipntr))-  where-    -- Current instruction pointer-    ipntr = regbank '!!' PC--    -- Decoder-    (MachCode {..}) = case instr of-      Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}-      Branch cr a          -> nullCode {inputX=cr,jmpM=Just a}-      Jump a               -> nullCode {aluCode=Incr,jmpM=Just a}-      Load a r             -> nullCode {ldReg=r,rdAddr=a}-      Store r a            -> nullCode {inputX=r,wrAddrM=Just a}-      Nop                  -> nullCode--    -- ALU-    regX   = regbank '!!' inputX-    regY   = regbank '!!' inputY-    aluOut = alu aluCode regX regY--    -- next instruction-    nextPC = case jmpM of-               Just a | aluOut /= 0 -> ipntr + a-               _                    -> ipntr + 1--    -- update registers-    regbank' = 'replace' Zero   0-             $ 'replace' PC     nextPC-             $ 'replace' result aluOut-             $ 'replace' ldReg  memOut-             $ regbank--alu Add   x y = x + y-alu Sub   x y = x - y-alu Incr  x _ = x + 1-alu Imm   x _ = x-alu CmpGt x y = if x > y then 1 else 0-@--We initially create a memory out of simple registers:--@-dataMem-  :: KnownDomain dom-  => Clock dom-  -> Reset dom-  -> Enable dom-  -> Signal dom MemAddr-  -- ^ Read address-  -> Signal dom (Maybe (MemAddr,Value))-  -- ^ (write address, data in)-  -> Signal dom Value-  -- ^ data out-dataMem clk rst en rd wrM = 'Clash.Explicit.Mealy.mealy' clk rst en dataMemT ('Clash.Sized.Vector.replicate' d32 0) (bundle (rd,wrM))-  where-    dataMemT mem (rd,wrM) = (mem',dout)-      where-        dout = mem '!!' rd-        mem' = case wrM of-                 Just (wr,din) -> 'replace' wr din mem-                 _ -> mem-@--And then connect everything:--@-system-  :: ( KnownDomain dom-     , KnownNat n )-  => Vec n Instruction-  -> Clock dom-  -> Reset dom-  -> Enable dom-  -> Signal dom Value-system instrs clk rst en = memOut-  where-    memOut = dataMem clk rst en rdAddr dout-    (rdAddr,dout,ipntr) = 'Clash.Explicit.Mealy.mealyB' clk rst en cpu ('Clash.Sized.Vector.replicate' d7 0) (memOut,instr)-    instr  = 'Clash.Explicit.Prelude.asyncRom' instrs '<$>' ipntr-@--Create a simple program that calculates the GCD of 4 and 6:--@--- Compute GCD of 4 and 6-prog = -- 0 := 4-       Compute Incr Zero RegA RegA :>-       replicate d3 (Compute Incr RegA Zero RegA) ++-       Store RegA 0 :>-       -- 1 := 6-       Compute Incr Zero RegA RegA :>-       replicate d5 (Compute Incr RegA Zero RegA) ++-       Store RegA 1 :>-       -- A := 4-       Load 0 RegA :>-       -- B := 6-       Load 1 RegB :>-       -- start-       Compute CmpGt RegA RegB RegC :>-       Branch RegC 4 :>-       Compute CmpGt RegB RegA RegC :>-       Branch RegC 4 :>-       Jump 5 :>-       -- (a > b)-       Compute Sub RegA RegB RegA :>-       Jump (-6) :>-       -- (b > a)-       Compute Sub RegB RegA RegB :>-       Jump (-8) :>-       -- end-       Store RegA 2 :>-       Load 2 RegC :>-       Nil-@--And test our system:--@->>> sampleN 32 $ system prog systemClockGen resetGen enableGen-[0,0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]--@--to see that our system indeed calculates that the GCD of 6 and 4 is 2.--=== Improvement 1: using @asyncRam@--As you can see, it's fairly straightforward to build a memory using registers-and read ('!!') and write ('replace') logic. This might however not result in-the most efficient hardware structure, especially when building an ASIC.--Instead it is preferable to use the 'Clash.Prelude.RAM.asyncRam' function which-has the potential to be translated to a more efficient structure:--@-system2-  :: ( KnownDomain dom-     , KnownNat n )-  => Vec n Instruction-  -> Clock dom-  -> Reset dom-  -> Enable dom-  -> Signal dom Value-system2 instrs clk rst en = memOut-  where-    memOut = 'Clash.Explicit.RAM.asyncRam' clk clk en d32 rdAddr dout-    (rdAddr,dout,ipntr) = 'mealyB' clk rst en cpu ('Clash.Sized.Vector.replicate' d7 0) (memOut,instr)-    instr  = 'Clash.Prelude.ROM.asyncRom' instrs '<$>' ipntr-@--Again, we can simulate our system and see that it works. This time however,-we need to disregard the first few output samples, because the initial content of an-'Clash.Prelude.RAM.asyncRam' is 'undefined', and consequently, the first few-output samples are also 'undefined'. We use the utility function 'printX' to conveniently-filter out the undefinedness and replace it with the string "X" in the few leading outputs.--@->>> printX $ sampleN 32 $ system2 prog systemClockGen resetGen enableGen-[X,X,X,X,X,X,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]--@--=== Improvement 2: using @blockRam@--Finally we get to using 'blockRam'. On FPGAs, 'Clash.Prelude.RAM.asyncRam' will-be implemented in terms of LUTs, and therefore take up logic resources. FPGAs-also have large(r) memory structures called /Block RAMs/, which are preferred,-especially as the memories we need for our application get bigger. The-'blockRam' function will be translated to such a /Block RAM/.--One important aspect of Block RAMs have a /synchronous/ read port, meaning that,-unlike the behavior of 'Clash.Prelude.RAM.asyncRam', given a read address @r@-at time @t@, the value @v@ in the RAM at address @r@ is only available at time-@t+1@.--For us that means we need to change the design of our CPU. Right now, upon a-load instruction we generate a read address for the memory, and the value at-that read address is immediately available to be put in the register bank.-Because we will be using a BlockRAM, the value is delayed until the next cycle.-We hence need to also delay the register address to which the memory address-is loaded:--@-cpu2-  :: (Vec 7 Value,Reg)-  -- ^ (Register bank, Load reg addr)-  -> (Value,Instruction)-  -- ^ (Memory output, Current instruction)-  -> ( (Vec 7 Value,Reg)-     , (MemAddr, Maybe (MemAddr,Value), InstrAddr)-     )-cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) '<$>' wrAddrM,fromIntegral ipntr))-  where-    -- Current instruction pointer-    ipntr = regbank '!!' PC--    -- Decoder-    (MachCode {..}) = case instr of-      Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}-      Branch cr a          -> nullCode {inputX=cr,jmpM=Just a}-      Jump a               -> nullCode {aluCode=Incr,jmpM=Just a}-      Load a r             -> nullCode {ldReg=r,rdAddr=a}-      Store r a            -> nullCode {inputX=r,wrAddrM=Just a}-      Nop                  -> nullCode--    -- ALU-    regX   = regbank '!!' inputX-    regY   = regbank '!!' inputY-    aluOut = alu aluCode regX regY--    -- next instruction-    nextPC = case jmpM of-               Just a | aluOut /= 0 -> ipntr + a-               _                    -> ipntr + 1--    -- update registers-    ldRegD'  = ldReg -- Delay the ldReg by 1 cycle-    regbank' = 'replace' Zero   0-             $ 'replace' PC     nextPC-             $ 'replace' result aluOut-             $ 'replace' ldRegD memOut-             $ regbank-@--We can now finally instantiate our system with a 'blockRam':--@-system3-  :: ( KnownDomain dom-     , KnownNat n )-  => Vec n Instruction-  -> Clock dom-  -> Reset dom-  -> Enable dom-  -> Signal dom Value-system3 instrs clk rst en = memOut-  where-    memOut = 'blockRam' clk en (replicate d32 0) rdAddr dout-    (rdAddr,dout,ipntr) = 'mealyB' clk rst en cpu2 (('Clash.Sized.Vector.replicate' d7 0),Zero) (memOut,instr)-    instr  = 'Clash.Explicit.Prelude.asyncRom' instrs '<$>' ipntr-@--We are, however, not done. We will also need to update our program. The reason-being that values that we try to load in our registers won't be loaded into the-register until the next cycle. This is a problem when the next instruction-immediately depended on this memory value. In our case, this was only the case-when the loaded the value @6@, which was stored at address @1@, into @RegB@.-Our updated program is thus:--@-prog2 = -- 0 := 4-       Compute Incr Zero RegA RegA :>-       replicate d3 (Compute Incr RegA Zero RegA) ++-       Store RegA 0 :>-       -- 1 := 6-       Compute Incr Zero RegA RegA :>-       replicate d5 (Compute Incr RegA Zero RegA) ++-       Store RegA 1 :>-       -- A := 4-       Load 0 RegA :>-       -- B := 6-       Load 1 RegB :>-       Nop :> -- Extra NOP-       -- start-       Compute CmpGt RegA RegB RegC :>-       Branch RegC 4 :>-       Compute CmpGt RegB RegA RegC :>-       Branch RegC 4 :>-       Jump 5 :>-       -- (a > b)-       Compute Sub RegA RegB RegA :>-       Jump (-6) :>-       -- (b > a)-       Compute Sub RegB RegA RegB :>-       Jump (-8) :>-       -- end-       Store RegA 2 :>-       Load 2 RegC :>-       Nil-@--When we simulate our system we see that it works. This time again,-we need to disregard the first sample, because the initial output of a-'blockRam' is 'undefined'. We use the utility function 'printX' to conveniently-filter out the undefinedness and replace it with the string "X".--@->>> printX $ sampleN 34 $ system3 prog2 systemClockGen resetGen enableGen-[X,0,0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]--@--This concludes the short introduction to using 'blockRam'.---}--{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE KindSignatures      #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeOperators       #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}---- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c--- as to why we need this.-{-# OPTIONS_GHC -fno-cpr-anal #-}--module Clash.Explicit.BlockRam-  ( -- * BlockRAM synchronized to the system clock-    blockRam-  , blockRamPow2-  , blockRamU-  , blockRam1-  , ResetStrategy(..)-    -- * Read/Write conflict resolution-  , readNew-    -- * Internal-  , blockRam#-  )-where--import           Data.Maybe             (isJust)-import qualified Data.Vector  as V-import           GHC.Stack              (HasCallStack, withFrozenCallStack)-import           GHC.TypeLits           (KnownNat, type (^), type (<=))-import           Prelude                hiding (length, replicate)--import           Clash.Annotations.Primitive-  (hasBlackBox)-import           Clash.Class.Num        (SaturationMode(SatBound), satSucc)-import           Clash.Explicit.Signal  (KnownDomain, Enable, register, fromEnable)-import           Clash.Signal.Internal-  (Clock(..), Reset, Signal (..), invertReset, (.&&.), mux)-import           Clash.Promoted.Nat     (SNat(..))-import           Clash.Signal.Bundle    (unbundle)-import           Clash.Sized.Unsigned   (Unsigned)-import           Clash.Sized.Index      (Index)-import           Clash.Sized.Vector     (Vec, replicate, toList, iterateI)-import qualified Clash.Sized.Vector     as CV-import           Clash.XException-  (maybeIsX, seqX, NFDataX, deepErrorX, defaultSeqX, errorX)--{- $setup->>> import Clash.Explicit.Prelude as C->>> import qualified Data.List as L->>> :set -XDataKinds -XRecordWildCards -XTupleSections -XDeriveAnyClass -XDeriveGeneric->>> type InstrAddr = Unsigned 8->>> type MemAddr = Unsigned 5->>> type Value = Signed 8->>> :{-data Reg-  = Zero-  | PC-  | RegA-  | RegB-  | RegC-  | RegD-  | RegE-  deriving (Eq,Show,Enum,C.Generic,NFDataX)-:}-->>> :{-data Operator = Add | Sub | Incr | Imm | CmpGt-  deriving (Eq,Show)-:}-->>> :{-data Instruction-  = Compute Operator Reg Reg Reg-  | Branch Reg Value-  | Jump Value-  | Load MemAddr Reg-  | Store Reg MemAddr-  | Nop-  deriving (Eq,Show)-:}-->>> :{-data MachCode-  = MachCode-  { inputX  :: Reg-  , inputY  :: Reg-  , result  :: Reg-  , aluCode :: Operator-  , ldReg   :: Reg-  , rdAddr  :: MemAddr-  , wrAddrM :: Maybe MemAddr-  , jmpM    :: Maybe Value-  }-:}-->>> :{-nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm-                    , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing-                    , jmpM = Nothing-                    }-:}-->>> :{-alu Add   x y = x + y-alu Sub   x y = x - y-alu Incr  x _ = x + 1-alu Imm   x _ = x-alu CmpGt x y = if x > y then 1 else 0-:}-->>> :{-cpu :: Vec 7 Value          -- ^ Register bank-    -> (Value,Instruction)  -- ^ (Memory output, Current instruction)-    -> ( Vec 7 Value-       , (MemAddr,Maybe (MemAddr,Value),InstrAddr)-       )-cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr))-  where-    -- Current instruction pointer-    ipntr = regbank C.!! PC-    -- Decoder-    (MachCode {..}) = case instr of-      Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}-      Branch cr a          -> nullCode {inputX=cr,jmpM=Just a}-      Jump a               -> nullCode {aluCode=Incr,jmpM=Just a}-      Load a r             -> nullCode {ldReg=r,rdAddr=a}-      Store r a            -> nullCode {inputX=r,wrAddrM=Just a}-      Nop                  -> nullCode-    -- ALU-    regX   = regbank C.!! inputX-    regY   = regbank C.!! inputY-    aluOut = alu aluCode regX regY-    -- next instruction-    nextPC = case jmpM of-               Just a | aluOut /= 0 -> ipntr + a-               _                    -> ipntr + 1-    -- update registers-    regbank' = replace Zero   0-             $ replace PC     nextPC-             $ replace result aluOut-             $ replace ldReg  memOut-             $ regbank-:}-->>> :{-dataMem-  :: KnownDomain dom-  => Clock  dom-  -> Reset  dom-  -> Enable dom-  -> Signal dom MemAddr-  -> Signal dom (Maybe (MemAddr,Value))-  -> Signal dom Value-dataMem clk rst en rd wrM = mealy clk rst en dataMemT (C.replicate d32 0) (bundle (rd,wrM))-  where-    dataMemT mem (rd,wrM) = (mem',dout)-      where-        dout = mem C.!! rd-        mem' = case wrM of-                 Just (wr,din) -> replace wr din mem-                 Nothing       -> mem-:}-->>> :{-system-  :: ( KnownDomain dom-     , KnownNat n )-  => Vec n Instruction-  -> Clock dom-  -> Reset dom-  -> Enable dom-  -> Signal dom Value-system instrs clk rst en = memOut-  where-    memOut = dataMem clk rst en rdAddr dout-    (rdAddr,dout,ipntr) = mealyB clk rst en cpu (C.replicate d7 0) (memOut,instr)-    instr  = asyncRom instrs <$> ipntr-:}-->>> :{--- Compute GCD of 4 and 6-prog = -- 0 := 4-       Compute Incr Zero RegA RegA :>-       C.replicate d3 (Compute Incr RegA Zero RegA) C.++-       Store RegA 0 :>-       -- 1 := 6-       Compute Incr Zero RegA RegA :>-       C.replicate d5 (Compute Incr RegA Zero RegA) C.++-       Store RegA 1 :>-       -- A := 4-       Load 0 RegA :>-       -- B := 6-       Load 1 RegB :>-       -- start-       Compute CmpGt RegA RegB RegC :>-       Branch RegC 4 :>-       Compute CmpGt RegB RegA RegC :>-       Branch RegC 4 :>-       Jump 5 :>-       -- (a > b)-       Compute Sub RegA RegB RegA :>-       Jump (-6) :>-       -- (b > a)-       Compute Sub RegB RegA RegB :>-       Jump (-8) :>-       -- end-       Store RegA 2 :>-       Load 2 RegC :>-       Nil-:}-->>> :{-system2-  :: ( KnownDomain dom-     , KnownNat n )-  => Vec n Instruction-  -> Clock dom-  -> Reset dom-  -> Enable dom-  -> Signal dom Value-system2 instrs clk rst en = memOut-  where-    memOut = asyncRam clk clk en d32 rdAddr dout-    (rdAddr,dout,ipntr) = mealyB clk rst en cpu (C.replicate d7 0) (memOut,instr)-    instr  = asyncRom instrs <$> ipntr-:}-->>> :{-cpu2 :: (Vec 7 Value,Reg)    -- ^ (Register bank, Load reg addr)-     -> (Value,Instruction)  -- ^ (Memory output, Current instruction)-     -> ( (Vec 7 Value,Reg)-        , (MemAddr,Maybe (MemAddr,Value),InstrAddr)-        )-cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr))-  where-    -- Current instruction pointer-    ipntr = regbank C.!! PC-    -- Decoder-    (MachCode {..}) = case instr of-      Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}-      Branch cr a          -> nullCode {inputX=cr,jmpM=Just a}-      Jump a               -> nullCode {aluCode=Incr,jmpM=Just a}-      Load a r             -> nullCode {ldReg=r,rdAddr=a}-      Store r a            -> nullCode {inputX=r,wrAddrM=Just a}-      Nop                  -> nullCode-    -- ALU-    regX   = regbank C.!! inputX-    regY   = regbank C.!! inputY-    aluOut = alu aluCode regX regY-    -- next instruction-    nextPC = case jmpM of-               Just a | aluOut /= 0 -> ipntr + a-               _                    -> ipntr + 1-    -- update registers-    ldRegD'  = ldReg -- Delay the ldReg by 1 cycle-    regbank' = replace Zero   0-             $ replace PC     nextPC-             $ replace result aluOut-             $ replace ldRegD memOut-             $ regbank-:}-->>> :{-system3-  :: ( KnownDomain dom-     , KnownNat n )-  => Vec n Instruction-  -> Clock dom-  -> Reset dom-  -> Enable dom-  -> Signal dom Value-system3 instrs clk rst en = memOut-  where-    memOut = blockRam clk en (C.replicate d32 0) rdAddr dout-    (rdAddr,dout,ipntr) = mealyB clk rst en cpu2 ((C.replicate d7 0),Zero) (memOut,instr)-    instr  = asyncRom instrs <$> ipntr-:}-->>> :{-prog2 = -- 0 := 4-       Compute Incr Zero RegA RegA :>-       C.replicate d3 (Compute Incr RegA Zero RegA) C.++-       Store RegA 0 :>-       -- 1 := 6-       Compute Incr Zero RegA RegA :>-       C.replicate d5 (Compute Incr RegA Zero RegA) C.++-       Store RegA 1 :>-       -- A := 4-       Load 0 RegA :>-       -- B := 6-       Load 1 RegB :>-       Nop :> -- Extra NOP-       -- start-       Compute CmpGt RegA RegB RegC :>-       Branch RegC 4 :>-       Compute CmpGt RegB RegA RegC :>-       Branch RegC 4 :>-       Jump 5 :>-       -- (a > b)-       Compute Sub RegA RegB RegA :>-       Jump (-6) :>-       -- (b > a)-       Compute Sub RegB RegA RegB :>-       Jump (-8) :>-       -- end-       Store RegA 2 :>-       Load 2 RegC :>-       Nil-:}---}--fromJustX :: HasCallStack => Maybe a -> a-fromJustX Nothing  = errorX "fromJustX: Nothing"-fromJustX (Just x) = x---- | Create a blockRAM with space for @n@ elements------ * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'------ @--- bram40---   :: 'Clock'  dom---   -> 'Enable'  dom---   -> 'Signal' dom ('Unsigned' 6)---   -> 'Signal' dom (Maybe ('Unsigned' 6, 'Clash.Sized.BitVector.Bit'))---   -> 'Signal' dom 'Clash.Sized.BitVector.Bit'--- bram40 clk en = 'blockRam' clk en ('Clash.Sized.Vector.replicate' d40 1)--- @------ Additional helpful information:------ * See "Clash.Explicit.BlockRam#usingrams" for more information on how to use a--- Block RAM.--- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @'readNew' clk rst ('blockRam' clk inits) rd wrM@.-blockRam-  :: ( KnownDomain dom-     , HasCallStack-     , NFDataX a-     , Enum addr )-  => Clock dom-  -- ^ 'Clock' to synchronize to-  -> Enable dom-  -- ^ Global enable-  -> Vec n a-  -- ^ Initial content of the BRAM, also determines the size, @n@, of the BRAM.-   ---   -- __NB__: __MUST__ be a constant.-  -> Signal dom addr-  -- ^ Read address @r@-  -> Signal dom (Maybe (addr, a))-  -- ^ (write address @w@, value to write)-  -> Signal dom a-  -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle-blockRam = \clk gen content rd wrM ->-  let en       = isJust <$> wrM-      (wr,din) = unbundle (fromJustX <$> wrM)-  in  withFrozenCallStack-      (blockRam# clk gen content (fromEnum <$> rd) en (fromEnum <$> wr) din)-{-# INLINE blockRam #-}---- | Create a blockRAM with space for 2^@n@ elements------ * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'------ @--- bram32---   :: 'Clock' dom---   -> 'Enable' dom---   -> 'Signal' dom ('Unsigned' 5)---   -> 'Signal' dom (Maybe ('Unsigned' 5, 'Clash.Sized.BitVector.Bit'))---   -> 'Signal' dom 'Clash.Sized.BitVector.Bit'--- bram32 clk en = 'blockRamPow2' clk en ('Clash.Sized.Vector.replicate' d32 1)--- @------ Additional helpful information:------ * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a--- Block RAM.--- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @'readNew' clk rst ('blockRamPow2' clk inits) rd wrM@.-blockRamPow2-  :: ( KnownDomain dom-     , HasCallStack-     , NFDataX a-     , KnownNat n )-  => Clock dom-  -- ^ 'Clock' to synchronize to-  -> Enable dom-  -- ^ Global enable-  -> Vec (2^n) a-  -- ^ Initial content of the BRAM, also-  -- determines the size, @2^n@, of-  -- the BRAM.-  ---  -- __NB__: __MUST__ be a constant.-  -> Signal dom (Unsigned n)-  -- ^ Read address @r@-  -> Signal dom (Maybe (Unsigned n, a))-  -- ^ (Write address @w@, value to write)-  -> Signal dom a-  -- ^ Value of the @blockRAM@ at address @r@ from the previous-  -- clock cycle-blockRamPow2 = \clk en cnt rd wrM -> withFrozenCallStack-  (blockRam clk en cnt rd wrM)-{-# INLINE blockRamPow2 #-}--data ResetStrategy (r :: Bool) where-  ClearOnReset :: ResetStrategy 'True-  NoClearOnReset :: ResetStrategy 'False---- | Version of blockram that has no default values set. May be cleared to a--- arbitrary state using a reset function.-blockRamU-   :: forall n dom a r addr-   . ( KnownDomain dom-     , HasCallStack-     , NFDataX a-     , Enum addr-     , 1 <= n )-  => Clock dom-  -- ^ 'Clock' to synchronize to-  -> Reset dom-  -- ^ 'Reset' line to listen to. Needs to be held at least /n/ cycles in order-  -- for the BRAM to be reset to its initial state.-  -> Enable dom-  -- ^ Global enable-  -> ResetStrategy r-  -- ^ Whether to clear BRAM on asserted reset ('ClearOnReset') or-  -- not ('NoClearOnReset'). Reset needs to be asserted at least /n/ cycles to-  -- clear the BRAM.-  -> SNat n-  -- ^ Number of elements in BRAM-  -> (Index n -> a)-  -- ^ If applicable (see first argument), reset BRAM using this function.-  -> Signal dom addr-  -- ^ Read address @r@-  -> Signal dom (Maybe (addr, a))-  -- ^ (write address @w@, value to write)-  -> Signal dom a-  -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle-blockRamU clk rst0 en rstStrategy n@SNat initF rd0 mw0 =-  case rstStrategy of-    ClearOnReset ->-      -- Use reset infrastructure-      blockRamU# clk en n rd1 we1 wa1 w1-    NoClearOnReset ->-      -- Ignore reset infrastructure, pass values unchanged-      blockRamU# clk en n-        (fromEnum <$> rd0)-        we0-        (fromEnum <$> wa0)-        w0- where-  rstBool = register clk rst0 en True (pure False)-  rstInv = invertReset rst0--  waCounter :: Signal dom (Index n)-  waCounter = register clk rstInv en 0 (satSucc SatBound <$> waCounter)--  wa0 = fst . fromJustX <$> mw0-  w0  = snd . fromJustX <$> mw0-  we0 = isJust <$> mw0--  rd1 = mux rstBool 0 (fromEnum <$> rd0)-  we1 = mux rstBool (pure True) we0-  wa1 = mux rstBool (fromInteger . toInteger <$> waCounter) (fromEnum <$> wa0)-  w1  = mux rstBool (initF <$> waCounter) w0---- | blockRAM1 primitive-blockRamU#-  :: forall n dom a-   . ( KnownDomain dom-     , HasCallStack-     , NFDataX a )-  => Clock dom-  -- ^ 'Clock' to synchronize to-  -> Enable dom-  -- ^ Global Enable-  -> SNat n-  -- ^ Number of elements in BRAM-  -> Signal dom Int-  -- ^ Read address @r@-  -> Signal dom Bool-  -- ^ Write enable-  -> Signal dom Int-  -- ^ Write address @w@-  -> Signal dom a-  -- ^ Value to write (at address @w@)-  -> Signal dom a-  -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle-blockRamU# clk en SNat =-  -- TODO: Generalize to single BRAM primitive taking an initialization function-  blockRam#-    clk-    en-    (CV.map-      (\i -> deepErrorX $ "Initial value at index " ++ show i ++ " undefined.")-      (iterateI @n succ (0 :: Int)))-{-# NOINLINE blockRamU# #-}-{-# ANN blockRamU# hasBlackBox #-}---- | Version of blockram that is initialized with the same value on all--- memory positions.-blockRam1-   :: forall n dom a r addr-   . ( KnownDomain dom-     , HasCallStack-     , NFDataX a-     , Enum addr-     , 1 <= n )-  => Clock dom-  -- ^ 'Clock' to synchronize to-  -> Reset dom-  -- ^ 'Reset' line to listen to. Needs to be held at least /n/ cycles in order-  -- for the BRAM to be reset to its initial state.-  -> Enable dom-  -- ^ Global enable-  -> ResetStrategy r-  -- ^ Whether to clear BRAM on asserted reset ('ClearOnReset') or-  -- not ('NoClearOnReset'). Reset needs to be asserted at least /n/ cycles to-  -- clear the BRAM.-  -> SNat n-  -- ^ Number of elements in BRAM-  -> a-  -- ^ Initial content of the BRAM (replicated /n/ times)-  -> Signal dom addr-  -- ^ Read address @r@-  -> Signal dom (Maybe (addr, a))-  -- ^ (write address @w@, value to write)-  -> Signal dom a-  -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle-blockRam1 clk rst0 en rstStrategy n@SNat a rd0 mw0 =-  case rstStrategy of-    ClearOnReset ->-      -- Use reset infrastructure-      blockRam1# clk en n a rd1 we1 wa1 w1-    NoClearOnReset ->-      -- Ignore reset infrastructure, pass values unchanged-      blockRam1# clk en n a-        (fromEnum <$> rd0)-        we0-        (fromEnum <$> wa0)-        w0- where-  rstBool = register clk rst0 en True (pure False)-  rstInv = invertReset rst0--  waCounter :: Signal dom (Index n)-  waCounter = register clk rstInv en 0 (satSucc SatBound <$> waCounter)--  wa0 = fst . fromJustX <$> mw0-  w0  = snd . fromJustX <$> mw0-  we0 = isJust <$> mw0--  rd1 = mux rstBool 0 (fromEnum <$> rd0)-  we1 = mux rstBool (pure True) we0-  wa1 = mux rstBool (fromInteger . toInteger <$> waCounter) (fromEnum <$> wa0)-  w1  = mux rstBool (pure a) w0---- | blockRAM1 primitive-blockRam1#-  :: forall n dom a-   . ( KnownDomain dom-     , HasCallStack-     , NFDataX a )-  => Clock dom-  -- ^ 'Clock' to synchronize to-  -> Enable dom-  -- ^ Global Enable-  -> SNat n-  -- ^ Number of elements in BRAM-  -> a-  -- ^ Initial content of the BRAM (replicated /n/ times)-  -> Signal dom Int-  -- ^ Read address @r@-  -> Signal dom Bool-  -- ^ Write enable-  -> Signal dom Int-  -- ^ Write address @w@-  -> Signal dom a-  -- ^ Value to write (at address @w@)-  -> Signal dom a-  -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle-blockRam1# clk en n a =-  -- TODO: Generalize to single BRAM primitive taking an initialization function-  blockRam# clk en (replicate n a)-{-# NOINLINE blockRam1# #-}-{-# ANN blockRam1# hasBlackBox #-}---- | blockRAM primitive-blockRam#-  :: ( KnownDomain dom-     , HasCallStack-     , NFDataX a )-  => Clock dom-  -- ^ 'Clock' to synchronize to-  -> Enable dom-  -- ^ Global enable-  -> Vec n a-  -- ^ Initial content of the BRAM, also-  -- determines the size, @n@, of the BRAM.-  ---  -- __NB__: __MUST__ be a constant.-  -> Signal dom Int-  -- ^ Read address @r@-  -> Signal dom Bool-  -- ^ Write enable-  -> Signal dom Int-  -- ^ Write address @w@-  -> Signal dom a-  -- ^ Value to write (at address @w@)-  -> Signal dom a-  -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle-blockRam# (Clock _) gen content rd wen =-  go-    (V.fromList (toList content))-    (withFrozenCallStack (deepErrorX "blockRam: intial value undefined"))-    (fromEnable gen)-    rd-    (fromEnable gen .&&. wen)- where-  go !ram o ret@(~(re :- res)) rt@(~(r :- rs)) et@(~(e :- en)) wt@(~(w :- wr)) dt@(~(d :- din)) =-    let ram' = d `defaultSeqX` upd ram e (fromEnum w) d-        o'   = if re then ram V.! r else o-    in  o `seqX` o :- (ret `seq` rt `seq` et `seq` wt `seq` dt `seq` go ram' o' res rs en wr din)--  upd ram we waddr d = case maybeIsX we of-    Nothing -> case maybeIsX waddr of-      Nothing -> V.map (const (seq waddr d)) ram-      Just wa -> ram V.// [(wa,d)]-    Just True -> case maybeIsX waddr of-      Nothing -> V.map (const (seq waddr d)) ram-      Just wa -> ram V.// [(wa,d)]-    _ -> ram-{-# ANN blockRam# hasBlackBox #-}-{-# NOINLINE blockRam# #-}---- | Create read-after-write blockRAM from a read-before-write one-readNew-  :: ( KnownDomain dom-     , NFDataX a-     , Eq addr )-  => Clock dom-  -> Reset dom-  -> Enable dom-  -> (Signal dom addr -> Signal dom (Maybe (addr, a)) -> Signal dom a)-  -- ^ The @ram@ component-  -> Signal dom addr-  -- ^ Read address @r@-  -> Signal dom (Maybe (addr, a))-  -- ^ (Write address @w@, value to write)-  -> Signal dom a-  -- ^ Value of the @ram@ at address @r@ from the previous clock cycle-readNew clk rst en ram rdAddr wrM = mux wasSame wasWritten $ ram rdAddr wrM-  where readNewT rd (Just (wr, wrdata)) = (wr == rd, wrdata)-        readNewT _  Nothing             = (False   , undefined)--        (wasSame,wasWritten) =-          unbundle (register clk rst en (False, undefined)-                             (readNewT <$> rdAddr <*> wrM))+                  2017     , Google Inc.,+                  2021-2026, QBayLogic B.V.,+                  2022     , Google Inc.,+                  2024     , Alex Mason,+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Block RAM primitives++= Using RAMs #usingrams#++We will show a rather elaborate example on how you can, and why you might want+to use block RAMs. We will build a \"small\" CPU + Memory + Program ROM where we+will slowly evolve to using block RAMs. Note that the code is /not/ meant as a+de-facto standard on how to do CPU design in Clash.++We start with the definition of the Instructions, Register names and machine+codes:++@+{\-\# LANGUAGE RecordWildCards, TupleSections, DeriveAnyClass \#-\}++module CPU where++import Clash.Explicit.Prelude++type InstrAddr = Unsigned 8+type MemAddr   = Unsigned 5+type Value     = Signed 8++data Instruction+  = Compute Operator Reg Reg Reg+  | Branch Reg Value+  | Jump Value+  | Load MemAddr Reg+  | Store Reg MemAddr+  | Nop+  deriving (Eq, Show, Generic, NFDataX)++data Reg+  = Zero+  | PC+  | RegA+  | RegB+  | RegC+  | RegD+  | RegE+  deriving (Eq, Show, Enum, Generic, NFDataX)++data Operator = Add | Sub | Incr | Imm | CmpGt+  deriving (Eq, Show, Generic, NFDataX)++data MachCode+  = MachCode+  { inputX  :: Reg+  , inputY  :: Reg+  , result  :: Reg+  , aluCode :: Operator+  , ldReg   :: Reg+  , rdAddr  :: MemAddr+  , wrAddrM :: Maybe MemAddr+  , jmpM    :: Maybe Value+  }++nullCode =+  MachCode+    { inputX = Zero+    , inputY = Zero+    , result = Zero+    , aluCode = Imm+    , ldReg = Zero+    , rdAddr = 0+    , wrAddrM = Nothing+    , jmpM = Nothing+    }+@++Next we define the CPU and its ALU:++@+cpu+  :: Vec 7 Value          -- ^ Register bank+  -> (Value,Instruction)  -- ^ (Memory output, Current instruction)+  -> ( Vec 7 Value+     , (MemAddr, Maybe (MemAddr,Value), InstrAddr)+     )+cpu regbank (memOut, instr) =+  (regbank', (rdAddr, (,aluOut) '<$>' wrAddrM, bitCoerce ipntr))+ where+  -- Current instruction pointer+  ipntr = regbank 'Clash.Sized.Vector.!!' PC++  -- Decoder+  (MachCode {..}) = case instr of+    Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}+    Branch cr a          -> nullCode {inputX=cr,jmpM=Just a}+    Jump a               -> nullCode {aluCode=Incr,jmpM=Just a}+    Load a r             -> nullCode {ldReg=r,rdAddr=a}+    Store r a            -> nullCode {inputX=r,wrAddrM=Just a}+    Nop                  -> nullCode++  -- ALU+  regX   = regbank 'Clash.Sized.Vector.!!' inputX+  regY   = regbank 'Clash.Sized.Vector.!!' inputY+  aluOut = alu aluCode regX regY++  -- next instruction+  nextPC =+    case jmpM of+      Just a | aluOut /= 0 -> ipntr + a+      _                    -> ipntr + 1++  -- update registers+  regbank' = 'Clash.Sized.Vector.replace' Zero   0+           $ 'Clash.Sized.Vector.replace' PC     nextPC+           $ 'Clash.Sized.Vector.replace' result aluOut+           $ 'Clash.Sized.Vector.replace' ldReg  memOut+           $ regbank++alu Add   x y = x + y+alu Sub   x y = x - y+alu Incr  x _ = x + 1+alu Imm   x _ = x+alu CmpGt x y = if x > y then 1 else 0+@++We initially create a memory out of simple registers:++@+dataMem+  :: KnownDomain dom+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> Signal dom MemAddr+  -- ^ Read address+  -> Signal dom (Maybe (MemAddr,Value))+  -- ^ (write address, data in)+  -> Signal dom Value+  -- ^ data out+dataMem clk rst en rd wrM =+  'Clash.Explicit.Mealy.mealy' clk rst en dataMemT ('Clash.Sized.Vector.replicate' d32 0) (bundle (rd,wrM))+ where+  dataMemT mem (rd,wrM) = (mem',dout)+    where+      dout = mem 'Clash.Sized.Vector.!!' rd+      mem' =+        case wrM of+          Just (wr,din) -> 'Clash.Sized.Vector.replace' wr din mem+          _             -> mem+@++And then connect everything:++@+system+  :: ( KnownDomain dom+     , KnownNat n )+  => Vec n Instruction+  -> Clock dom+  -> Reset dom+  -> Enable dom+  -> Signal dom Value+system instrs clk rst en = memOut+ where+  memOut = dataMem clk rst en rdAddr dout+  (rdAddr,dout,ipntr) = 'Clash.Explicit.Mealy.mealyB' clk rst en cpu ('Clash.Sized.Vector.replicate' d7 0) (memOut,instr)+  instr  = 'Clash.Explicit.Prelude.asyncRom' instrs '<$>' ipntr+@++Create a simple program that calculates the GCD of 4 and 6:++@+-- Compute GCD of 4 and 6+prog = -- 0 := 4+       Compute Incr Zero RegA RegA :>+       replicate d3 (Compute Incr RegA Zero RegA) +++       Store RegA 0 :>+       -- 1 := 6+       Compute Incr Zero RegA RegA :>+       replicate d5 (Compute Incr RegA Zero RegA) +++       Store RegA 1 :>+       -- A := 4+       Load 0 RegA :>+       -- B := 6+       Load 1 RegB :>+       -- start+       Compute CmpGt RegA RegB RegC :>+       Branch RegC 4 :>+       Compute CmpGt RegB RegA RegC :>+       Branch RegC 4 :>+       Jump 5 :>+       -- (a > b)+       Compute Sub RegA RegB RegA :>+       Jump (-6) :>+       -- (b > a)+       Compute Sub RegB RegA RegB :>+       Jump (-8) :>+       -- end+       Store RegA 2 :>+       Load 2 RegC :>+       Nil+@++And test our system:++@+>>> sampleN 32 $ system prog systemClockGen resetGen enableGen+[0,0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]++@++to see that our system indeed calculates that the GCD of 6 and 4 is 2.++=== Improvement 1: using @asyncRam@++As you can see, it's fairly straightforward to build a memory using registers+and read ('Clash.Sized.Vector.!!') and write ('Clash.Sized.Vector.replace')+logic. This might however not result in the most efficient hardware structure,+especially when building an ASIC.++Instead it is preferable to use the 'Clash.Prelude.RAM.asyncRam' function which+has the potential to be translated to a more efficient structure:++@+system2+  :: ( KnownDomain dom+     , KnownNat n )+  => Vec n Instruction+  -> Clock dom+  -> Reset dom+  -> Enable dom+  -> Signal dom Value+system2 instrs clk rst en = memOut+ where+  memOut = 'Clash.Explicit.RAM.asyncRam' clk clk en d32 rdAddr dout+  (rdAddr,dout,ipntr) = 'Clash.Explicit.Prelude.mealyB' clk rst en cpu ('Clash.Sized.Vector.replicate' d7 0) (memOut,instr)+  instr  = 'Clash.Prelude.ROM.asyncRom' instrs '<$>' ipntr+@++Again, we can simulate our system and see that it works. This time however,+we need to disregard the first few output samples, because the initial content of an+'Clash.Prelude.RAM.asyncRam' is /undefined/, and consequently, the first few+output samples are also /undefined/. We use the utility function+'Clash.XException.printX' to conveniently filter out the undefinedness and+replace it with the string @\"undefined\"@ in the first few leading outputs.++@+>>> printX $ sampleN 32 $ system2 prog systemClockGen resetGen enableGen+[undefined,undefined,undefined,undefined,undefined,undefined,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]++@++=== Improvement 2: using @blockRam@++Finally we get to using 'blockRam'. On FPGAs, 'Clash.Prelude.RAM.asyncRam' will+be implemented in terms of LUTs, and therefore take up logic resources. FPGAs+also have large(r) memory structures called /block RAMs/, which are preferred,+especially as the memories we need for our application get bigger. The+'blockRam' function will be translated to such a /block RAM/.++One important aspect of block RAMs is that they have a /synchronous/ read port,+meaning unlike an 'Clash.Prelude.RAM.asyncRam', the result of a read command+given at time @t@ is output at time @t + 1@.++For us that means we need to change the design of our CPU. Right now, upon a+load instruction we generate a read address for the memory, and the value at+that read address is immediately available to be put in the register bank. We+will be using a block RAM, so the value is delayed until the next cycle. Thus,+we will also need to delay the register address to which the memory address is+loaded:++@+cpu2+  :: (Vec 7 Value,Reg)    -- ^ (Register bank, Load reg addr)+  -> (Value,Instruction)  -- ^ (Memory output, Current instruction)+  -> ( (Vec 7 Value, Reg)+     , (MemAddr, Maybe (MemAddr,Value), InstrAddr)+     )+cpu2 (regbank, ldRegD) (memOut, instr) =+  ((regbank', ldRegD'), (rdAddr, (,aluOut) '<$>' wrAddrM, bitCoerce ipntr))+ where+  -- Current instruction pointer+  ipntr = regbank 'Clash.Sized.Vector.!!' PC++  -- Decoder+  (MachCode {..}) = case instr of+    Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}+    Branch cr a          -> nullCode {inputX=cr,jmpM=Just a}+    Jump a               -> nullCode {aluCode=Incr,jmpM=Just a}+    Load a r             -> nullCode {ldReg=r,rdAddr=a}+    Store r a            -> nullCode {inputX=r,wrAddrM=Just a}+    Nop                  -> nullCode++  -- ALU+  regX   = regbank 'Clash.Sized.Vector.!!' inputX+  regY   = regbank 'Clash.Sized.Vector.!!' inputY+  aluOut = alu aluCode regX regY++  -- next instruction+  nextPC =+    case jmpM of+      Just a | aluOut /= 0 -> ipntr + a+      _                    -> ipntr + 1++  -- update registers+  ldRegD'  = ldReg  -- Delay the ldReg by 1 cycle+  regbank' = 'Clash.Sized.Vector.replace' Zero   0+           $ 'Clash.Sized.Vector.replace' PC     nextPC+           $ 'Clash.Sized.Vector.replace' result aluOut+           $ 'Clash.Sized.Vector.replace' ldRegD memOut+           $ regbank+@++We can now finally instantiate our system with a 'blockRam':++@+system3+  :: ( KnownDomain dom+     , KnownNat n )+  => Vec n Instruction+  -> Clock dom+  -> Reset dom+  -> Enable dom+  -> Signal dom Value+system3 instrs clk rst en = memOut+ where+  memOut = 'blockRam' clk en (replicate d32 0) rdAddr dout+  (rdAddr,dout,ipntr) = 'Clash.Explicit.Prelude.mealyB' clk rst en cpu2 (('Clash.Sized.Vector.replicate' d7 0),Zero) (memOut,instr)+  instr  = 'Clash.Explicit.Prelude.asyncRom' instrs '<$>' ipntr+@++We are, however, not done. We will also need to update our program. The reason+being that values that we try to load in our registers won't be loaded into the+register until the next cycle. This is a problem when the next instruction+immediately depends on this memory value. In our example, this was only the case+when we loaded the value @6@, which was stored at address @1@, into @RegB@.+Our updated program is thus:++@+prog2 = -- 0 := 4+       Compute Incr Zero RegA RegA :>+       replicate d3 (Compute Incr RegA Zero RegA) +++       Store RegA 0 :>+       -- 1 := 6+       Compute Incr Zero RegA RegA :>+       replicate d5 (Compute Incr RegA Zero RegA) +++       Store RegA 1 :>+       -- A := 4+       Load 0 RegA :>+       -- B := 6+       Load 1 RegB :>+       Nop :> -- Extra NOP+       -- start+       Compute CmpGt RegA RegB RegC :>+       Branch RegC 4 :>+       Compute CmpGt RegB RegA RegC :>+       Branch RegC 4 :>+       Jump 5 :>+       -- (a > b)+       Compute Sub RegA RegB RegA :>+       Jump (-6) :>+       -- (b > a)+       Compute Sub RegB RegA RegB :>+       Jump (-8) :>+       -- end+       Store RegA 2 :>+       Load 2 RegC :>+       Nil+@++When we simulate our system we see that it works. This time again,+we need to disregard the first sample, because the initial output of a+'blockRam' is /undefined/. We use the utility function 'Clash.XException.printX'+to conveniently filter out the undefinedness and replace it with the string @\"undefined\"@.++@+>>> printX $ sampleN 34 $ system3 prog2 systemClockGen resetGen enableGen+[undefined,0,0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]++@++This concludes the short introduction to using 'blockRam'.++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_HADDOCK show-extensions #-}++-- See [Note: eta port names for trueDualPortBlockRam]+{-# OPTIONS_GHC -fno-do-lambda-eta-expansion #-}++-- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c+-- as to why we need this.+{-# OPTIONS_GHC -fno-cpr-anal #-}++{-# OPTIONS_GHC -fconstraint-solver-iterations=12 #-}++module Clash.Explicit.BlockRam+  ( -- * Block RAM synchronized to an arbitrary clock+    blockRam+  , blockRamPow2+  , blockRamU+  , blockRam1+  , ResetStrategy(..)+    -- ** Read/write conflict resolution+  , readNew+    -- * True dual-port block RAM+    -- $tdpbram+  , trueDualPortBlockRam+  , RamOp(..)+    -- * Internal+  , blockRam#+  , blockRamU#+  , blockRam1#+  , trueDualPortBlockRam#+  )+where++import Clash.HaskellPrelude++import Control.DeepSeq (NFData)+import Control.Exception (catch, throw)+import Control.Monad (forM_)+import Control.Monad.ST (ST, runST)+import Control.Monad.ST.Unsafe (unsafeInterleaveST, unsafeIOToST, unsafeSTToIO)+import Data.Array.MArray (newListArray)+import Data.List.Infinite (Infinite(..), (...))+import Data.Maybe (isJust)+import Data.Sequence (Seq)+import Data.String.Interpolate (__i)+import GHC.Arr (STArray, unsafeReadSTArray, unsafeWriteSTArray)+import GHC.Generics (Generic)+import GHC.Stack (HasCallStack, withFrozenCallStack)+import GHC.TypeLits (KnownNat, type (^))+import Unsafe.Coerce (unsafeCoerce)++import Clash.Annotations.Primitive+  (Primitive(InlineYamlPrimitive), HDL(..), hasBlackBox)+import Clash.Class.AutoReg (AutoReg(autoReg))+import Clash.Class.BitPack (BitPack, bitToBool, msb)+import Clash.Class.Num (SaturationMode(SatBound), satSucc)+import Clash.Explicit.BlockRam.Model (TdpbramModelConfig(..), tdpbramModel)+import Clash.Explicit.Signal (KnownDomain, Enable, register, fromEnable, andEnable)+import Clash.Promoted.Nat (SNat(..), UNat(..), toUNat)+import Clash.Signal.Bundle (unbundle)+import Clash.Signal.Internal+  (Clock(..), Reset, Signal (..), invertReset, (.&&.), mux)+import Clash.Sized.BitVector (BitVector)+import Clash.Sized.Index (Index)+import Clash.Sized.Unsigned (Unsigned)+import Clash.Sized.Vector (Vec, replicate, iterateI)+import Clash.XException+ (ShowX, maybeIsX, NFDataX(deepErrorX), defaultSeqX, fromJustX, undefined,+ XException (..), seqX, errorX)+import Clash.XException.MaybeX (MaybeX(..), andX)++import qualified Data.Sequence as Seq+import qualified Data.List as L++import qualified Clash.Sized.Vector as CV++{- $tdpbram+A true dual-port block RAM has two fully independent, fully functional access+ports: port A and port B. Either port can do both RAM reads and writes. These+two ports can even be on distinct clock domains, but the memory itself is shared+between the ports. This also makes a true dual-port block RAM suitable as a+component in a domain crossing circuit (but it needs additional logic for it to+be safe, see e.g. 'Clash.Explicit.Synchronizer.asyncFIFOSynchronizer').++A version with implicit clocks can be found in "Clash.Prelude.BlockRam".+-}++-- start benchmark only+-- import GHC.Arr (listArray, unsafeThawSTArray)+-- end benchmark only++{- $setup+>>> import Clash.Explicit.Prelude as C+>>> import qualified Data.List as L+>>> :set -XDataKinds -XRecordWildCards -XTupleSections -XDeriveAnyClass -XDeriveGeneric+>>> type InstrAddr = Unsigned 8+>>> type MemAddr = Unsigned 5+>>> type Value = Signed 8+>>> :{+data Reg+  = Zero+  | PC+  | RegA+  | RegB+  | RegC+  | RegD+  | RegE+  deriving (Eq,Show,Enum,C.Generic,NFDataX)+:}++>>> :{+data Operator = Add | Sub | Incr | Imm | CmpGt+  deriving (Eq, Show, Generic, NFDataX)+:}++>>> :{+data Instruction+  = Compute Operator Reg Reg Reg+  | Branch Reg Value+  | Jump Value+  | Load MemAddr Reg+  | Store Reg MemAddr+  | Nop+  deriving (Eq, Show, Generic, NFDataX)+:}++>>> :{+data MachCode+  = MachCode+  { inputX  :: Reg+  , inputY  :: Reg+  , result  :: Reg+  , aluCode :: Operator+  , ldReg   :: Reg+  , rdAddr  :: MemAddr+  , wrAddrM :: Maybe MemAddr+  , jmpM    :: Maybe Value+  }+:}++>>> :{+nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm+                    , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing+                    , jmpM = Nothing+                    }+:}++>>> :{+alu Add   x y = x + y+alu Sub   x y = x - y+alu Incr  x _ = x + 1+alu Imm   x _ = x+alu CmpGt x y = if x > y then 1 else 0+:}++>>> :{+let cpu :: Vec 7 Value          -- ^ Register bank+        -> (Value,Instruction)  -- ^ (Memory output, Current instruction)+        -> ( Vec 7 Value+           , (MemAddr,Maybe (MemAddr,Value),InstrAddr)+           )+    cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) <$> wrAddrM,bitCoerce ipntr))+      where+        -- Current instruction pointer+        ipntr = regbank C.!! PC+        -- Decoder+        (MachCode {..}) = case instr of+          Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}+          Branch cr a          -> nullCode {inputX=cr,jmpM=Just a}+          Jump a               -> nullCode {aluCode=Incr,jmpM=Just a}+          Load a r             -> nullCode {ldReg=r,rdAddr=a}+          Store r a            -> nullCode {inputX=r,wrAddrM=Just a}+          Nop                  -> nullCode+        -- ALU+        regX   = regbank C.!! inputX+        regY   = regbank C.!! inputY+        aluOut = alu aluCode regX regY+        -- next instruction+        nextPC = case jmpM of+                   Just a | aluOut /= 0 -> ipntr + a+                   _                    -> ipntr + 1+        -- update registers+        regbank' = replace Zero   0+                 $ replace PC     nextPC+                 $ replace result aluOut+                 $ replace ldReg  memOut+                 $ regbank+:}++>>> :{+let dataMem+      :: KnownDomain dom+      => Clock  dom+      -> Reset  dom+      -> Enable dom+      -> Signal dom MemAddr+      -> Signal dom (Maybe (MemAddr,Value))+      -> Signal dom Value+    dataMem clk rst en rd wrM = mealy clk rst en dataMemT (C.replicate d32 0) (bundle (rd,wrM))+      where+        dataMemT mem (rd,wrM) = (mem',dout)+          where+            dout = mem C.!! rd+            mem' = case wrM of+                     Just (wr,din) -> replace wr din mem+                     Nothing       -> mem+:}++>>> :{+let system+      :: ( KnownDomain dom+         , KnownNat n )+      => Vec n Instruction+      -> Clock dom+      -> Reset dom+      -> Enable dom+      -> Signal dom Value+    system instrs clk rst en = memOut+      where+        memOut = dataMem clk rst en rdAddr dout+        (rdAddr,dout,ipntr) = mealyB clk rst en cpu (C.replicate d7 0) (memOut,instr)+        instr  = asyncRom instrs <$> ipntr+:}++>>> :{+-- Compute GCD of 4 and 6+prog = -- 0 := 4+       Compute Incr Zero RegA RegA :>+       C.replicate d3 (Compute Incr RegA Zero RegA) C.+++       Store RegA 0 :>+       -- 1 := 6+       Compute Incr Zero RegA RegA :>+       C.replicate d5 (Compute Incr RegA Zero RegA) C.+++       Store RegA 1 :>+       -- A := 4+       Load 0 RegA :>+       -- B := 6+       Load 1 RegB :>+       -- start+       Compute CmpGt RegA RegB RegC :>+       Branch RegC 4 :>+       Compute CmpGt RegB RegA RegC :>+       Branch RegC 4 :>+       Jump 5 :>+       -- (a > b)+       Compute Sub RegA RegB RegA :>+       Jump (-6) :>+       -- (b > a)+       Compute Sub RegB RegA RegB :>+       Jump (-8) :>+       -- end+       Store RegA 2 :>+       Load 2 RegC :>+       Nil+:}++>>> :{+let system2+      :: ( KnownDomain dom+         , KnownNat n )+      => Vec n Instruction+      -> Clock dom+      -> Reset dom+      -> Enable dom+      -> Signal dom Value+    system2 instrs clk rst en = memOut+      where+        memOut = asyncRam clk clk en d32 rdAddr dout+        (rdAddr,dout,ipntr) = mealyB clk rst en cpu (C.replicate d7 0) (memOut,instr)+        instr  = asyncRom instrs <$> ipntr+:}++>>> :{+let cpu2 :: (Vec 7 Value,Reg)    -- ^ (Register bank, Load reg addr)+         -> (Value,Instruction)  -- ^ (Memory output, Current instruction)+         -> ( (Vec 7 Value,Reg)+            , (MemAddr,Maybe (MemAddr,Value),InstrAddr)+            )+    cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) <$> wrAddrM,bitCoerce ipntr))+      where+        -- Current instruction pointer+        ipntr = regbank C.!! PC+        -- Decoder+        (MachCode {..}) = case instr of+          Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}+          Branch cr a          -> nullCode {inputX=cr,jmpM=Just a}+          Jump a               -> nullCode {aluCode=Incr,jmpM=Just a}+          Load a r             -> nullCode {ldReg=r,rdAddr=a}+          Store r a            -> nullCode {inputX=r,wrAddrM=Just a}+          Nop                  -> nullCode+        -- ALU+        regX   = regbank C.!! inputX+        regY   = regbank C.!! inputY+        aluOut = alu aluCode regX regY+        -- next instruction+        nextPC = case jmpM of+                   Just a | aluOut /= 0 -> ipntr + a+                   _                    -> ipntr + 1+        -- update registers+        ldRegD'  = ldReg -- Delay the ldReg by 1 cycle+        regbank' = replace Zero   0+                 $ replace PC     nextPC+                 $ replace result aluOut+                 $ replace ldRegD memOut+                 $ regbank+:}++>>> :{+let system3+      :: ( KnownDomain dom+         , KnownNat n )+      => Vec n Instruction+      -> Clock dom+      -> Reset dom+      -> Enable dom+      -> Signal dom Value+    system3 instrs clk rst en = memOut+      where+        memOut = blockRam clk en (C.replicate d32 0) rdAddr dout+        (rdAddr,dout,ipntr) = mealyB clk rst en cpu2 ((C.replicate d7 0),Zero) (memOut,instr)+        instr  = asyncRom instrs <$> ipntr+:}++>>> :{+prog2 = -- 0 := 4+       Compute Incr Zero RegA RegA :>+       C.replicate d3 (Compute Incr RegA Zero RegA) C.+++       Store RegA 0 :>+       -- 1 := 6+       Compute Incr Zero RegA RegA :>+       C.replicate d5 (Compute Incr RegA Zero RegA) C.+++       Store RegA 1 :>+       -- A := 4+       Load 0 RegA :>+       -- B := 6+       Load 1 RegB :>+       Nop :> -- Extra NOP+       -- start+       Compute CmpGt RegA RegB RegC :>+       Branch RegC 4 :>+       Compute CmpGt RegB RegA RegC :>+       Branch RegC 4 :>+       Jump 5 :>+       -- (a > b)+       Compute Sub RegA RegB RegA :>+       Jump (-6) :>+       -- (b > a)+       Compute Sub RegB RegA RegB :>+       Jump (-8) :>+       -- end+       Store RegA 2 :>+       Load 2 RegC :>+       Nil+:}++-}++-- | Create a block RAM with space for @n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'XException'+--+-- === See also:+--+-- * See "Clash.Explicit.BlockRam#usingrams" for more information on how to use a+-- block RAM.+-- * Use the adapter 'readNew' for obtaining write-before-read semantics like+-- this: @'readNew' clk rst en ('blockRam' clk inits) rd wrM@.+-- * A large 'Vec' for the initial content may be too inefficient, depending+-- on how it is constructed. See 'Clash.Explicit.BlockRam.File.blockRamFile' and+-- 'Clash.Explicit.BlockRam.Blob.blockRamBlob' for different approaches that+-- scale well.+--+-- === __Example__+-- @+-- bram40+--   :: 'Clock'  dom+--   -> 'Enable'  dom+--   -> 'Signal' dom ('Unsigned' 6)+--   -> 'Signal' dom (Maybe ('Unsigned' 6, 'Clash.Sized.BitVector.Bit'))+--   -> 'Signal' dom 'Clash.Sized.BitVector.Bit'+-- bram40 clk en = 'blockRam' clk en ('Clash.Sized.Vector.replicate' d40 1)+-- @+blockRam+  :: ( KnownDomain dom+     , HasCallStack+     , NFDataX a+     , Enum addr+     , NFDataX addr )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> Vec n a+  -- ^ Initial content of the BRAM, also determines the size, @n@, of the BRAM+   --+   -- __NB__: __MUST__ be a constant+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom (Maybe (addr, a))+  -- ^ (write address @w@, value to write)+  -> Signal dom a+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRam = \clk gen content rd wrM ->+  let en       = isJust <$> wrM+      (wr,din) = unbundle (fromJustX <$> wrM)+  in  withFrozenCallStack+      (blockRam# clk gen content (fromEnum <$> rd) en (fromEnum <$> wr) din)+{-# INLINE blockRam #-}++-- | Create a block RAM with space for 2^@n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'XException'+--+-- === See also:+--+-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a+-- block RAM.+-- * Use the adapter 'readNew' for obtaining write-before-read semantics like+-- this: @'readNew' clk rst en ('blockRamPow2' clk inits) rd wrM@.+-- * A large 'Vec' for the initial content may be too inefficient, depending+-- on how it is constructed. See 'Clash.Explicit.BlockRam.File.blockRamFilePow2'+-- and 'Clash.Explicit.BlockRam.Blob.blockRamBlobPow2' for different approaches+-- that scale well.+--+-- === __Example__+-- @+-- bram32+--   :: 'Clock' dom+--   -> 'Enable' dom+--   -> 'Signal' dom ('Unsigned' 5)+--   -> 'Signal' dom (Maybe ('Unsigned' 5, 'Clash.Sized.BitVector.Bit'))+--   -> 'Signal' dom 'Clash.Sized.BitVector.Bit'+-- bram32 clk en = 'blockRamPow2' clk en ('Clash.Sized.Vector.replicate' d32 1)+-- @+blockRamPow2+  :: ( KnownDomain dom+     , HasCallStack+     , NFDataX a+     , KnownNat n )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> Vec (2^n) a+  -- ^ Initial content of the BRAM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom (Unsigned n)+  -- ^ Read address @r@+  -> Signal dom (Maybe (Unsigned n, a))+  -- ^ (Write address @w@, value to write)+  -> Signal dom a+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRamPow2 = \clk en cnt rd wrM -> withFrozenCallStack+  (blockRam clk en cnt rd wrM)+{-# INLINE blockRamPow2 #-}++data ResetStrategy (r :: Bool) a where+  ClearOnReset :: a -> ResetStrategy 'True a+  NoClearOnReset :: ResetStrategy 'False a++-- | A version of 'blockRam' that has no default values set. May be cleared to+-- an arbitrary state using a reset function.+blockRamU+   :: forall n dom a r addr+   . ( KnownDomain dom+     , HasCallStack+     , NFDataX a+     , Enum addr+     , NFDataX addr+     )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Reset dom+  -- ^ 'Reset' line. This needs to be asserted for at least /n/ cycles in order+  -- for the BRAM to be reset to its initial state.+  -> Enable dom+  -- ^ 'Enable' line+  -> ResetStrategy r (Index n -> a)+  -- ^ Whether to clear BRAM on asserted reset ('ClearOnReset') or+  -- not ('NoClearOnReset'). The reset needs to be asserted for at least /n/+  -- cycles to clear the BRAM.+  -> SNat n+  -- ^ Number of elements in BRAM+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom (Maybe (addr, a))+  -- ^ (write address @w@, value to write)+  -> Signal dom a+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRamU clk rst0 en rstStrategy n@SNat rd0 mw0 = case toUNat n of+  UZero -> case rstStrategy of+    ClearOnReset f -> pure $ f undefined+    NoClearOnReset -> pure undefined+  USucc _ -> case rstStrategy of+    ClearOnReset initF ->+      -- Use reset infrastructure+      blockRamU# clk en n rd1 we1 wa1 w1+      where+        rd1 = mux rstBool 0 (fromEnum <$> rd0)+        we1 = mux rstBool (pure True) we0+        wa1 = mux rstBool (fromInteger . toInteger <$> waCounter) (fromEnum <$> wa0)+        w1  = mux rstBool (initF <$> waCounter) w0+    NoClearOnReset ->+      -- Ignore reset infrastructure, pass values unchanged+      blockRamU# clk en n+        (fromEnum <$> rd0)+        we0+        (fromEnum <$> wa0)+        w0+ where+  rstBool = register clk rst0 en True (pure False)+  rstInv = invertReset rst0++  waCounter :: Signal dom (Index n)+  waCounter = register clk rstInv en 0 (satSucc SatBound <$> waCounter)++  wa0 = fst . fromJustX <$> mw0+  w0  = snd . fromJustX <$> mw0+  we0 = isJust <$> mw0++-- | blockRAMU primitive+blockRamU#+  :: forall n dom a+   . ( KnownDomain dom+     , HasCallStack+     , NFDataX a )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> SNat n+  -- ^ Number of elements in BRAM+  -> Signal dom Int+  -- ^ Read address @r@+  -> Signal dom Bool+  -- ^ Write enable+  -> Signal dom Int+  -- ^ Write address @w@+  -> Signal dom a+  -- ^ Value to write (at address @w@)+  -> Signal dom a+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRamU# clk en SNat =+  -- TODO: Generalize to single BRAM primitive taking an initialization function+  blockRam#+    clk+    en+    (CV.map+      (\i -> deepErrorX $ "Initial value at index " <> show i <> " undefined.")+      (iterateI @n succ (0 :: Int)))+{-# OPAQUE blockRamU# #-}+{-# ANN blockRamU# hasBlackBox #-}++-- | A version of 'blockRam' that is initialized with the same value on all+-- memory positions+blockRam1+   :: forall n dom a r addr+   . ( KnownDomain dom+     , HasCallStack+     , NFDataX a+     , Enum addr+     , NFDataX addr+     )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Reset dom+  -- ^ 'Reset' line. This needs to be asserted for at least /n/ cycles in order+  -- for the BRAM to be reset to its initial state.+  -> Enable dom+  -- ^ 'Enable' line+  -> ResetStrategy r ()+  -- ^ Whether to clear BRAM on asserted reset ('ClearOnReset') or+  -- not ('NoClearOnReset'). The reset needs to be asserted for at least /n/+  -- cycles to clear the BRAM.+  -> SNat n+  -- ^ Number of elements in BRAM+  -> a+  -- ^ Initial content of the BRAM (replicated /n/ times)+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom (Maybe (addr, a))+  -- ^ (write address @w@, value to write)+  -> Signal dom a+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRam1 clk rst0 en rstStrategy n@SNat a rd0 mw0 = case toUNat n of+  UZero -> pure a+  USucc _ -> case rstStrategy of+    ClearOnReset () ->+      -- Use reset infrastructure+      blockRam1# clk en n a rd1 we1 wa1 w1+    NoClearOnReset ->+      -- Ignore reset infrastructure, pass values unchanged+      blockRam1# clk en n a+        (fromEnum <$> rd0)+        we0+        (fromEnum <$> wa0)+        w0+ where+  rstBool = register clk rst0 en True (pure False)+  rstInv = invertReset rst0++  waCounter :: Signal dom (Index n)+  waCounter = register clk rstInv en 0 (satSucc SatBound <$> waCounter)++  wa0 = fst . fromJustX <$> mw0+  w0  = snd . fromJustX <$> mw0+  we0 = isJust <$> mw0++  rd1 = mux rstBool 0 (fromEnum <$> rd0)+  we1 = mux rstBool (pure True) we0+  wa1 = mux rstBool (fromInteger . toInteger <$> waCounter) (fromEnum <$> wa0)+  w1  = mux rstBool (pure a) w0++-- | blockRAM1 primitive+blockRam1#+  :: forall n dom a+   . ( KnownDomain dom+     , HasCallStack+     , NFDataX a )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> SNat n+  -- ^ Number of elements in BRAM+  -> a+  -- ^ Initial content of the BRAM (replicated /n/ times)+  -> Signal dom Int+  -- ^ Read address @r@+  -> Signal dom Bool+  -- ^ Write enable+  -> Signal dom Int+  -- ^ Write address @w@+  -> Signal dom a+  -- ^ Value to write (at address @w@)+  -> Signal dom a+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRam1# clk en n a =+  -- TODO: Generalize to single BRAM primitive taking an initialization function+  blockRam# clk en (replicate n a)+{-# OPAQUE blockRam1# #-}+{-# ANN blockRam1# hasBlackBox #-}++-- | blockRAM primitive+blockRam#+  :: forall dom a n+   . ( KnownDomain dom+     , HasCallStack+     , NFDataX a )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> Vec n a+  -- ^ Initial content of the BRAM, also determines the size, @n@, of the BRAM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom Int+  -- ^ Read address @r@+  -> Signal dom Bool+  -- ^ Write enable+  -> Signal dom Int+  -- ^ Write address @w@+  -> Signal dom a+  -- ^ Value to write (at address @w@)+  -> Signal dom a+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRam# (Clock _ Nothing) gen content = \rd wen waS wd -> runST $ do+  ramStart <- newListArray (0,szI-1) contentL+  -- start benchmark only+  -- ramStart <- unsafeThawSTArray ramArr+  -- end benchmark only+  go+    ramStart+    (withFrozenCallStack (deepErrorX "blockRam: intial value undefined"))+    (fromEnable gen)+    rd+    (fromEnable gen .&&. wen)+    waS+    wd+ where+  contentL = unsafeCoerce content :: [a]+  szI = L.length contentL+  -- start benchmark only+  -- ramArr = listArray (0,szI-1) contentL+  -- end benchmark only++  go :: STArray s Int a -> a -> Signal dom Bool -> Signal dom Int+     -> Signal dom Bool -> Signal dom Int -> Signal dom a+     -> ST s (Signal dom a)+  go !ram o ret@(~(re :- res)) rt@(~(r :- rs)) et@(~(e :- en)) wt@(~(w :- wr)) dt@(~(d :- din)) = do+    o `seqX` (o :-) <$> (ret `seq` rt `seq` et `seq` wt `seq` dt `seq`+      unsafeInterleaveST+        (do o' <- unsafeIOToST+                    (catch (if re then unsafeSTToIO (ram `safeAt` r) else pure o)+                    (\err@XException {} -> pure (throw err)))+            d `defaultSeqX` upd ram e (fromEnum w) d+            go ram o' res rs en wr din))++  upd :: STArray s Int a -> Bool -> Int -> a -> ST s ()+  upd ram we waddr d = case maybeIsX we of+    Nothing -> case maybeIsX waddr of+      Nothing -> -- Put the XException from `waddr` as the value in all+                 -- locations of `ram`.+                 forM_ [0..(szI-1)] (\i -> unsafeWriteSTArray ram i (seq waddr d))+      Just wa -> -- Put the XException from `we` as the value at address+                 -- `waddr`.+                 safeUpdate wa (seq we d) ram+    Just True -> case maybeIsX waddr of+      Nothing -> -- Put the XException from `waddr` as the value in all+                 -- locations of `ram`.+                 forM_ [0..(szI-1)] (\i -> unsafeWriteSTArray ram i (seq waddr d))+      Just wa -> safeUpdate wa d ram+    _ -> return ()++  safeAt :: HasCallStack => STArray s Int a -> Int -> ST s a+  safeAt s i =+    if (0 <= i) && (i < szI) then+      unsafeReadSTArray s i+    else pure $+      withFrozenCallStack+        (deepErrorX ("blockRam: read address " <> show i <>+                     " not in range [0.." <> show szI <> ")"))+  {-# INLINE safeAt #-}++  safeUpdate :: HasCallStack => Int -> a -> STArray s Int a -> ST s ()+  safeUpdate i a s =+    if (0 <= i) && (i < szI) then+      unsafeWriteSTArray s i a+    else+      let d = withFrozenCallStack+                (deepErrorX ("blockRam: write address " <> show i <>+                             " not in range [0.." <> show szI <> ")"))+       in forM_ [0..(szI-1)] (\j -> unsafeWriteSTArray s j d)+  {-# INLINE safeUpdate #-}+blockRam# _ _ _ = error "blockRam#: dynamic clocks not supported"+{-# ANN blockRam# hasBlackBox #-}+{-# OPAQUE blockRam# #-}++-- | Create a read-after-write block RAM from a read-before-write one+readNew+  :: ( KnownDomain dom+     , NFDataX a+     , Eq addr )+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> (Signal dom addr -> Signal dom (Maybe (addr, a)) -> Signal dom a)+  -- ^ The BRAM component+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom (Maybe (addr, a))+  -- ^ (Write address @w@, value to write)+  -> Signal dom a+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+readNew clk rst en ram rdAddr wrM = mux wasSame wasWritten $ ram rdAddr wrM+  where readNewT rd (Just (wr, wrdata)) = (wr == rd, wrdata)+        readNewT _  Nothing             = (False   , undefined)++        (wasSame,wasWritten) =+          unbundle (register clk rst en (False, undefined)+                             (readNewT <$> rdAddr <*> wrM))++-- | Port operation+data RamOp n a+  = RamRead (Index n)+  -- ^ Read from address+  | RamWrite (Index n) a+  -- ^ Write data to address+  | RamNoOp+  -- ^ No operation+  deriving (Eq, Generic, NFData, NFDataX, Show, ShowX, BitPack)++instance (AutoReg a, KnownNat n) => AutoReg (RamOp n a) where+  autoReg clk rst en initVal input =+    createRamOp <$> tagR <*> valAddr <*> valValue+    where+      tag = toTag <$> input++      toTag op = case op of+        RamNoOp    -> 0b00 :: BitVector 2+        RamRead{}  -> 0b01+        RamWrite{} -> 0b10++      tagInit = toTag initVal+      tagR = register clk rst en tagInit tag++      toAddr op = case op of+        RamNoOp         -> deepErrorX "autoReg'.ramOpAddr"+        RamRead addr    -> addr+        RamWrite addr _ -> addr++      toValue op = case op of+        RamWrite _ a -> a+        _ -> deepErrorX "autoReg'.ramOpValue"+++      opAddr  = toAddr  <$> input+      opValue = toValue <$> input++      addrInit = toAddr  initVal+      valInit  = toValue initVal++      valAddr  = autoReg clk rst (andEnable en           ((/=0) <$> tag)) addrInit opAddr+      valValue = autoReg clk rst (andEnable en (bitToBool . msb <$> tag)) valInit opValue++      createRamOp t addr val = case t of+        0b00 -> RamNoOp+        0b01 -> RamRead addr+        0b10 -> RamWrite addr val+        _ -> deepErrorX  "autoReg'.createRamOp: impossible"++  {-# INLINE autoReg #-}++ramOpAddr :: RamOp n a -> Index n+ramOpAddr (RamRead addr)    = addr+ramOpAddr (RamWrite addr _) = addr+ramOpAddr RamNoOp           = errorX "Address for No operation undefined"++isRamWrite :: RamOp n a -> Bool+isRamWrite (RamWrite {}) = True+isRamWrite _             = False++ramOpWriteVal :: RamOp n a -> Maybe a+ramOpWriteVal (RamWrite _ val) = Just val+ramOpWriteVal _                = Nothing++isOp :: RamOp n a -> Bool+isOp RamNoOp = False+isOp _       = True++-- | Produces vendor-agnostic HDL that will be inferred as a true dual-port+-- block RAM+--+-- Any value that is being written on a particular port is also the+-- value that will be read on that port, i.e. the same-port read/write behavior+-- is: WriteFirst. For mixed-port read/write, when port A writes to the address+-- port B reads from, the output of port B is undefined, and vice versa.+trueDualPortBlockRam ::+  forall nAddrs domA domB a .+  ( HasCallStack+  , KnownNat nAddrs+  , KnownDomain domA+  , KnownDomain domB+  , NFDataX a+  )+  => Clock domA+  -- ^ Clock for port A+  -> Clock domB+  -- ^ Clock for port B+  -> Signal domA (RamOp nAddrs a)+  -- ^ RAM operation for port A+  -> Signal domB (RamOp nAddrs a)+  -- ^ RAM operation for port B+  -> (Signal domA a, Signal domB a)+  -- ^ Outputs data on /next/ cycle. When writing, the data written+  -- will be echoed. When reading, the read data is returned.++{-# INLINE trueDualPortBlockRam #-}+trueDualPortBlockRam = \clkA clkB opA opB ->+  trueDualPortBlockRamWrapper+    clkA (isOp <$> opA) (isRamWrite <$> opA) (ramOpAddr <$> opA) (fromJustX . ramOpWriteVal <$> opA)+    clkB (isOp <$> opB) (isRamWrite <$> opB) (ramOpAddr <$> opB) (fromJustX . ramOpWriteVal <$> opB)++-- [Note: eta port names for trueDualPortBlockRam]+--+-- By naming all the arguments and setting the -fno-do-lambda-eta-expansion GHC+-- option for this module, the generated HDL also contains names based on the+-- argument names used here. This greatly improves readability of the HDL.++-- [Note: true dual-port blockRAM separate architecture]+--+-- A multi-clock true dual-port block RAM is only inferred from the generated HDL+-- when it lives in its own Verilog module / VHDL architecture. Add any other+-- logic to the module / architecture, and synthesis will no longer infer a+-- multi-clock true dual-port block RAM. This wrapper pushes the primitive out+-- into its own module / architecture.+trueDualPortBlockRamWrapper clkA enA weA addrA datA clkB enB weB addrB datB =+  trueDualPortBlockRam# clkA enA weA addrA datA clkB enB weB addrB datB+{-# OPAQUE trueDualPortBlockRamWrapper #-}++{-# OPAQUE trueDualPortBlockRam# #-}+{-# ANN trueDualPortBlockRam# hasBlackBox #-}+{-# ANN trueDualPortBlockRam# (+  let+    bbName = show 'trueDualPortBlockRam#+    _hasCallStack+     :< knownNatAddrs+     :< _knownDomainA+     :< _knownDomainB+     :< _nfdataX++     :< clockA+     :< enaA+     :< wenaA+     :< addrA+     :< datA++     :< clockB+     :< enaB+     :< wenaB+     :< addrB+     :< datB++     :< _ = ((0 :: Int)...)++    symBlockName+     :< symDoutA+     :< symDoutB+     :< _ = ((0 :: Int)...)+  in InlineYamlPrimitive [VHDL] [__i|+    BlackBox:+      name: "#{bbName}"+      kind: Declaration+      template: |-+        -- trueDualPortBlockRam begin+        ~GENSYM[~RESULT_trueDualPortBlockRam][#{symBlockName}] : block+          -- Shared memory+          type mem_type is array ( ~LIT[#{knownNatAddrs}]-1 downto 0 ) of ~TYP[#{datA}];+          shared variable mem : mem_type;+          signal ~GENSYM[a_dout][#{symDoutA}] : ~TYP[#{datA}];+          signal ~GENSYM[b_dout][#{symDoutB}] : ~TYP[#{datB}];+        begin++          -- Port A+          process(~ARG[#{clockA}])+          begin+              if(rising_edge(~ARG[#{clockA}])) then+                    if(~ARG[#{enaA}]) then+                      if(~ARG[#{wenaA}]) then+                          mem(~IF~SIZE[~TYP[#{addrA}]]~THENto_integer(~ARG[#{addrA}])~ELSE0~FI) := ~ARG[#{datA}];+                      end if;+                      ~SYM[#{symDoutA}] <= mem(~IF~SIZE[~TYP[#{addrA}]]~THENto_integer(~ARG[#{addrA}])~ELSE0~FI);+                  end if;+              end if;+          end process;++          -- Port B+          process(~ARG[#{clockB}])+          begin+              if(rising_edge(~ARG[#{clockB}])) then+                  if(~ARG[#{enaB}]) then+                      if(~ARG[#{wenaB}]) then+                          mem(~IF~SIZE[~TYP[#{addrB}]]~THENto_integer(~ARG[#{addrB}])~ELSE0~FI) := ~ARG[#{datB}];+                      end if;+                      ~SYM[#{symDoutB}] <= mem(~IF~SIZE[~TYP[#{addrB}]]~THENto_integer(~ARG[#{addrB}])~ELSE0~FI);+                  end if;+              end if;+          end process;++          ~RESULT <= (~SYM[#{symDoutA}], ~SYM[#{symDoutB}]);+        end block;+        -- end trueDualPortBlockRam+|]) #-}+{-# ANN trueDualPortBlockRam# (+  let+    bbName = show 'trueDualPortBlockRam#+    _hasCallStack+     :< knownNatAddrs+     :< knownDomainA+     :< knownDomainB+     :< _nfdataX++     :< clockA+     :< enaA+     :< wenaA+     :< addrA+     :< datA++     :< clockB+     :< enaB+     :< wenaB+     :< addrB+     :< datB++     :< _ = ((0 :: Int)...)+    symMem+     :< symDoutA+     :< symDoutB+     :< _ = ((0 :: Int)...)+  in InlineYamlPrimitive [SystemVerilog] [__i|+    BlackBox:+      name: "#{bbName}"+      kind: Declaration+      template: |-+        // trueDualPortBlockRam begin+        // Shared memory+        logic [~SIZE[~TYP[#{datA}]]-1:0] ~GENSYM[mem][#{symMem}] [~LIT[#{knownNatAddrs}]-1:0];++        ~SIGD[~GENSYM[a_dout][#{symDoutA}]][#{datA}];+        ~SIGD[~GENSYM[b_dout][#{symDoutB}]][#{datB}];++        // Port A+        always @(~IF~ACTIVEEDGE[Rising][#{knownDomainA}]~THENposedge~ELSEnegedge~FI ~ARG[#{clockA}]) begin+            if(~ARG[#{enaA}]) begin+                ~SYM[#{symDoutA}] <= ~SYM[#{symMem}][~IF~SIZE[~TYP[#{addrA}]]~THEN~ARG[#{addrA}]~ELSE0~FI];+                if(~ARG[#{wenaA}]) begin+                    ~SYM[#{symDoutA}] <= ~ARG[#{datA}];+                    ~SYM[#{symMem}][~IF~SIZE[~TYP[#{addrA}]]~THEN~ARG[#{addrA}]~ELSE0~FI] <= ~ARG[#{datA}];+                end+            end+        end++        // Port B+        always @(~IF~ACTIVEEDGE[Rising][#{knownDomainB}]~THENposedge~ELSEnegedge~FI ~ARG[#{clockB}]) begin+            if(~ARG[#{enaB}]) begin+                ~SYM[#{symDoutB}] <= ~SYM[#{symMem}][~IF~SIZE[~TYP[#{addrB}]]~THEN~ARG[#{addrB}]~ELSE0~FI];+                if(~ARG[#{wenaB}]) begin+                    ~SYM[#{symDoutB}] <= ~ARG[#{datB}];+                    ~SYM[#{symMem}][~IF~SIZE[~TYP[#{addrB}]]~THEN~ARG[#{addrB}]~ELSE0~FI] <= ~ARG[#{datB}];+                end+            end+        end++        assign ~RESULT = {~SYM[#{symDoutA}], ~SYM[#{symDoutB}]};+        // end trueDualPortBlockRam+|]) #-}+{-# ANN trueDualPortBlockRam# (+  let+    bbName = show 'trueDualPortBlockRam#+    _hasCallStack+     :< knownNatAddrs+     :< knownDomainA+     :< knownDomainB+     :< _nfdataX++     :< clockA+     :< enaA+     :< wenaA+     :< addrA+     :< datA++     :< clockB+     :< enaB+     :< wenaB+     :< addrB+     :< datB++     :< _ = ((0 :: Int)...)++    symMem+     :< symDoutA+     :< symDoutB+     :< _ = ((0 :: Int)...)+  in InlineYamlPrimitive [Verilog] [__i|+    BlackBox:+      name: "#{bbName}"+      kind: Declaration+      template: |-+        // trueDualPortBlockRam begin+        // Shared memory+        reg [~SIZE[~TYP[#{datA}]]-1:0] ~GENSYM[mem][#{symMem}] [~LIT[#{knownNatAddrs}]-1:0];++        reg ~SIGD[~GENSYM[a_dout][#{symDoutA}]][#{datA}];+        reg ~SIGD[~GENSYM[b_dout][#{symDoutB}]][#{datB}];++        // Port A+        always @(~IF~ACTIVEEDGE[Rising][#{knownDomainA}]~THENposedge~ELSEnegedge~FI ~ARG[#{clockA}]) begin+            if(~ARG[#{enaA}]) begin+                ~SYM[#{symDoutA}] <= ~SYM[#{symMem}][~IF~SIZE[~TYP[#{addrA}]]~THEN~ARG[#{addrA}]~ELSE0~FI];+                if(~ARG[#{wenaA}]) begin+                    ~SYM[#{symDoutA}] <= ~ARG[#{datA}];+                    ~SYM[#{symMem}][~IF~SIZE[~TYP[#{addrA}]]~THEN~ARG[#{addrA}]~ELSE0~FI] <= ~ARG[#{datA}];+                end+            end+        end++        // Port B+        always @(~IF~ACTIVEEDGE[Rising][#{knownDomainB}]~THENposedge~ELSEnegedge~FI ~ARG[#{clockB}]) begin+            if(~ARG[#{enaB}]) begin+                ~SYM[#{symDoutB}] <= ~SYM[#{symMem}][~IF~SIZE[~TYP[#{addrB}]]~THEN~ARG[#{addrB}]~ELSE0~FI];+                if(~ARG[#{wenaB}]) begin+                    ~SYM[#{symDoutB}] <= ~ARG[#{datB}];+                    ~SYM[#{symMem}][~IF~SIZE[~TYP[#{addrB}]]~THEN~ARG[#{addrB}]~ELSE0~FI] <= ~ARG[#{datB}];+                end+            end+        end++        assign ~RESULT = {~SYM[#{symDoutA}], ~SYM[#{symDoutB}]};++        // end trueDualPortBlockRam+|]) #-}++-- | Primitive for 'trueDualPortBlockRam'+--+trueDualPortBlockRam#, trueDualPortBlockRamWrapper ::+  forall nAddrs domA domB a .+  ( HasCallStack+  , KnownNat nAddrs+  , KnownDomain domA+  , KnownDomain domB+  , NFDataX a+  ) =>++  Clock domA ->+  -- | Enable+  Signal domA Bool ->+  -- | Write enable+  Signal domA Bool ->+  -- | Address+  Signal domA (Index nAddrs) ->+  -- | Write data+  Signal domA a ->++  Clock domB ->+  -- | Enable+  Signal domB Bool ->+  -- | Write enable+  Signal domB Bool ->+  -- | Address+  Signal domB (Index nAddrs) ->+  -- | Write data+  Signal domB a ->++  (Signal domA a, Signal domB a)+trueDualPortBlockRam# clkA enA weA addrA datA clkB enB weB addrB datB =+  tdpbramModel+    TdpbramModelConfig+      { tdpIsActiveWriteEnable = id+      , tdpMergeWriteEnable = andX+      , tdpUpdateRam = updateRam }+    clkA enA addrA weA datA+    clkB enB addrB weB datB+ where+  updateRam :: Int -> MaybeX Bool -> a -> Seq a -> Seq a+  updateRam addr writeEnable dat mem =+    case writeEnable of+      IsDefined False -> mem+      IsDefined True -> Seq.update addr dat mem+      IsX msg -> Seq.update addr dat $ deepErrorX $+          "Write enable unknown; position" <> show addr <>+        "\nWrite enable error message: " <> msg
+ src/Clash/Explicit/BlockRam/Blob.hs view
@@ -0,0 +1,412 @@+{-|+Copyright  :  (C) 2021-2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++= Efficient bundling of initial RAM content with the compiled code++Leveraging Template Haskell, the initial content for the block RAM components in+this module is stored alongside the compiled Haskell code. It covers use cases+where passing the initial content as a 'Clash.Sized.Vector.Vec' turns out to be+problematically slow.++The data is stored efficiently, with very little overhead (worst-case 7%, often+no overhead at all).++Unlike "Clash.Explicit.BlockRam.File", "Clash.Explicit.BlockRam.Blob"+generates practically the same HDL as "Clash.Explicit.BlockRam" and is+compatible with all tools consuming the generated HDL.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Explicit.BlockRam.Blob+  ( -- * Block RAMs initialized with a 'MemBlob'+    blockRamBlob+  , blockRamBlobPow2+    -- * Creating and inspecting 'MemBlob'+  , MemBlob+  , createMemBlob+  , memBlobTH+  , unpackMemBlob+    -- * Internal+  , blockRamBlob#+  ) where++import Control.Exception (catch, throw)+import Control.Monad (forM_)+import Control.Monad.ST (ST, runST)+import Control.Monad.ST.Unsafe (unsafeInterleaveST, unsafeIOToST, unsafeSTToIO)+import Data.Array.MArray (newListArray)+import qualified Data.ByteString.Lazy as L+import Data.Maybe (isJust)+import GHC.Arr (STArray, unsafeReadSTArray, unsafeWriteSTArray)+import GHC.Stack (withFrozenCallStack)+import GHC.TypeLits (KnownNat, type (^))+import Language.Haskell.TH+  (DecsQ, ExpQ, integerL, litE, litT, mkName, normalB, numTyLit, sigD,+   stringPrimL, valD, varP)++import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Class.BitPack.Internal (BitPack, BitSize)+import Clash.Explicit.BlockRam.Internal+  (MemBlob(..), packBVs, unpackMemBlob, unpackMemBlob0)+import Clash.Explicit.Signal (KnownDomain, Enable, fromEnable)+import Clash.Promoted.Nat (natToInteger, natToNum)+import Clash.Signal.Bundle (unbundle)+import Clash.Signal.Internal (Clock, Signal(..), (.&&.))+import Clash.Sized.Internal.BitVector (Bit(..), BitVector(..))+import Clash.Sized.Internal.Unsigned (Unsigned)+import Clash.XException+  (maybeIsX, deepErrorX, defaultSeqX, fromJustX, NFDataX, XException (..), seqX)++-- $setup+-- >>> :set -XTemplateHaskell+-- >>> :set -fplugin GHC.TypeLits.Normalise+-- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver+-- >>> :m -Prelude+-- >>> import Clash.Explicit.Prelude++-- | Create a block RAM with space for @n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException'+--+--+-- === See also:+--+-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a+-- block RAM.+-- * Use the adapter 'Clash.Explicit.BlockRam.readNew' for obtaining+-- write-before-read semantics like this: @'Clash.Explicit.BlockRam.readNew'+-- clk rst en ('blockRamBlob' clk en content) rd wrM@.+blockRamBlob+  :: forall dom addr m n+   . ( KnownDomain dom+     , Enum addr+     , NFDataX addr+     )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> MemBlob n m+  -- ^ Initial content of the BRAM, also determines the size, @n@, of the BRAM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom (Maybe (addr, BitVector m))+  -- ^ (write address @w@, value to write)+  -> Signal dom (BitVector m)+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRamBlob = \clk gen content@MemBlob{} rd wrM ->+  let en       = isJust <$> wrM+      (wr,din) = unbundle (fromJustX <$> wrM)+  in blockRamBlob# clk gen content (fromEnum <$> rd) en (fromEnum <$> wr) din+{-# INLINE blockRamBlob #-}++-- | Create a block RAM with space for 2^@n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'XException'+--+-- === See also:+--+-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a+-- block RAM.+-- * Use the adapter 'Clash.Explicit.BlockRam.readNew' for obtaining+-- write-before-read semantics like this: @'Clash.Explicit.BlockRam.readNew'+-- clk rst en ('blockRamBlobPow2' clk en content) rd wrM@.+blockRamBlobPow2+  :: forall dom m n+   . ( KnownDomain dom+     , KnownNat n+     )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> MemBlob (2^n) m+  -- ^ Initial content of the BRAM, also determines the size, 2^@n@, of the BRAM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom (Unsigned n)+  -- ^ Read address @r@+  -> Signal dom (Maybe (Unsigned n, BitVector m))+  -- ^ (write address @w@, value to write)+  -> Signal dom (BitVector m)+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRamBlobPow2 = blockRamBlob+{-# INLINE blockRamBlobPow2 #-}++-- | blockRAMBlob primitive+blockRamBlob#+  :: forall dom m n+   . KnownDomain dom+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> MemBlob n m+  -- ^ Initial content of the BRAM, also determines the size, @n@, of the BRAM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom Int+  -- ^ Read address @r@+  -> Signal dom Bool+  -- ^ Write enable+  -> Signal dom Int+  -- ^ Write address @w@+  -> Signal dom (BitVector m)+  -- ^ Value to write (at address @w@)+  -> Signal dom (BitVector m)+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRamBlob# !_ gen content@MemBlob{} = \rd wen waS wd -> runST $ do+  bvList <- unsafeIOToST (unpackMemBlob0 content)+  ramStart <- newListArray (0,szI-1) bvList+  go+    ramStart+    (withFrozenCallStack (deepErrorX "blockRamBlob: intial value undefined"))+    (fromEnable gen)+    rd+    (fromEnable gen .&&. wen)+    waS+    wd+ where+  szI = natToNum @n @Int++  go :: STArray s Int (BitVector m) -> BitVector m -> Signal dom Bool+     -> Signal dom Int -> Signal dom Bool -> Signal dom Int+     -> Signal dom (BitVector m) -> ST s (Signal dom (BitVector m))+  go !ram o ret@(~(re :- res)) rt@(~(r :- rs)) et@(~(e :- en)) wt@(~(w :- wr))+     dt@(~(d :- din)) = do+    o `seqX` (o :-) <$> (ret `seq` rt `seq` et `seq` wt `seq` dt `seq`+      unsafeInterleaveST+        (do o' <- unsafeIOToST+                    (catch (if re then unsafeSTToIO (ram `safeAt` r) else pure o)+                    (\err@XException {} -> pure (throw err)))+            d `defaultSeqX` upd ram e w d+            go ram o' res rs en wr din))++  upd :: STArray s Int (BitVector m) -> Bool -> Int -> BitVector m -> ST s ()+  upd ram we waddr d = case maybeIsX we of+    Nothing -> case maybeIsX waddr of+      Nothing -> -- Put the XException from `waddr` as the value in all+                 -- locations of `ram`.+                 forM_ [0..(szI-1)] (\i -> unsafeWriteSTArray ram i (seq waddr d))+      Just wa -> -- Put the XException from `we` as the value at address+                 -- `waddr`.+                 safeUpdate wa (seq we d) ram+    Just True -> case maybeIsX waddr of+      Nothing -> -- Put the XException from `waddr` as the value in all+                 -- locations of `ram`.+                 forM_ [0..(szI-1)] (\i -> unsafeWriteSTArray ram i (seq waddr d))+      Just wa -> safeUpdate wa d ram+    _ -> return ()++  safeAt :: STArray s Int (BitVector m) -> Int -> ST s (BitVector m)+  safeAt s i =+    if (0 <= i) && (i < szI) then+      unsafeReadSTArray s i+    else pure $+      withFrozenCallStack+        (deepErrorX ("blockRamBlob: read address " <> show i <>+                     " not in range [0.." <> show szI <> ")"))+  {-# INLINE safeAt #-}++  safeUpdate :: Int -> BitVector m -> STArray s Int (BitVector m) -> ST s ()+  safeUpdate i a s =+    if (0 <= i) && (i < szI) then+      unsafeWriteSTArray s i a+    else+      let d = withFrozenCallStack+                (deepErrorX ("blockRam: write address " <> show i <>+                             " not in range [0.." <> show szI <> ")"))+       in forM_ [0..(szI-1)] (\j -> unsafeWriteSTArray s j d)+  {-# INLINE safeUpdate #-}+{-# ANN blockRamBlob# hasBlackBox #-}+{-# OPAQUE blockRamBlob# #-}++{- | Create a 'MemBlob' binding from a list of values++Since this uses Template Haskell, nothing in the arguments given to+'createMemBlob' can refer to something defined in the same module.++=== __Example__++@+'createMemBlob' "content" 'Nothing' [15 :: Unsigned 8 .. 17]++ram clk en = 'blockRamBlob' clk en content+@++The 'Data.Maybe.Maybe' datatype has don't care bits, where the actual value+does not matter. But the bits need a defined value in the memory. Either 0 or+1 can be used, and both are valid representations of the data.++>>> import qualified Prelude as P+>>> let es = [ Nothing, Just (7 :: Unsigned 8), Just 8 ]+>>> :{+createMemBlob "content0" (Just 0) es+createMemBlob "content1" (Just 1) es+x = 1+:}++>>> let pr = mapM_ (putStrLn . show)+>>> pr $ P.map pack es+0b0_...._....+0b1_0000_0111+0b1_0000_1000+>>> pr $ unpackMemBlob content0+0b0_0000_0000+0b1_0000_0111+0b1_0000_1000+>>> pr $ unpackMemBlob content1+0b0_1111_1111+0b1_0000_0111+0b1_0000_1000++#if __GLASGOW_HASKELL__ >= 910+>>> :{+createMemBlob "contentN" Nothing es+x = 1+:}+<interactive>:...: error:...+    packBVs: cannot convert don't care values. Please specify a mapping to a definite value.+<BLANKLINE>++#else+>>> :{+createMemBlob "contentN" Nothing es+x = 1+:}+<BLANKLINE>+<interactive>:...: error:...+    packBVs: cannot convert don't care values. Please specify a mapping to a definite value.++#endif+Note how we hinted to @clashi@ that our multi-line command was a list of+declarations by including a dummy declaration @x = 1@. Without this trick,+@clashi@ would expect an expression and the Template Haskell would not work.+-}+createMemBlob+  :: forall a f+   . ( Foldable f+     , BitPack a+     )+  => String+  -- ^ Name of the binding to generate+  -> Maybe Bit+  -- ^ Value to map don't care bits to. 'Nothing' means throwing an error on+  -- don't care bits.+  -> f a+  -- ^ The content for the 'MemBlob'+  -> DecsQ+createMemBlob name care es =+  case packed of+    Left err -> fail err+    Right _ -> sequence+      [ sigD name0 [t| MemBlob $(n) $(m) |]+      , valD (varP name0) (normalB [| MemBlob { memBlobRunsLen = $(runsLen)+                                              , memBlobRuns = $(runs)+                                              , memBlobEndsLen = $(endsLen)+                                              , memBlobEnds = $(ends)+                                              } |]) []+      ]+ where+  name0 = mkName name+  n = litT . numTyLit . toInteger $ len+  m = litT . numTyLit $ natToInteger @(BitSize a)+  runsLen = litE . integerL . toInteger $ L.length runsB+  runs = litE . stringPrimL $ L.unpack runsB+  endsLen = litE . integerL . toInteger $ L.length endsB+  ends = litE . stringPrimL $ L.unpack endsB+  (len, runsB, endsB) = either error id packed+  packed = packBVs care es++{- | Create a 'MemBlob' from a list of values++Since this uses Template Haskell, nothing in the arguments given to+'memBlobTH' can refer to something defined in the same module.++=== __Example__++@+ram clk en = 'blockRamBlob' clk en $(memBlobTH Nothing [15 :: Unsigned 8 .. 17])+@++The 'Data.Maybe.Maybe' datatype has don't care bits, where the actual value+does not matter. But the bits need a defined value in the memory. Either 0 or+1 can be used, and both are valid representations of the data.++>>> import qualified Prelude as P+>>> let es = [ Nothing, Just (7 :: Unsigned 8), Just 8 ]+>>> content0 = $(memBlobTH (Just 0) es)+>>> content1 = $(memBlobTH (Just 1) es)+>>> let pr = mapM_ (putStrLn . show)+>>> pr $ P.map pack es+0b0_...._....+0b1_0000_0111+0b1_0000_1000+>>> pr $ unpackMemBlob content0+0b0_0000_0000+0b1_0000_0111+0b1_0000_1000+>>> pr $ unpackMemBlob content1+0b0_1111_1111+0b1_0000_0111+0b1_0000_1000++#if __GLASGOW_HASKELL__ >= 910+>>> $(memBlobTH Nothing es)+<interactive>:...: error:...+    • packBVs: cannot convert don't care values. Please specify a mapping to a definite value.+    • In the untyped splice: $(memBlobTH Nothing es)+<BLANKLINE>++#else+>>> $(memBlobTH Nothing es)+<BLANKLINE>+<interactive>:...: error:...+    • packBVs: cannot convert don't care values. Please specify a mapping to a definite value.+    • In the untyped splice: $(memBlobTH Nothing es)++#endif+-}+memBlobTH+  :: forall a f+   . ( Foldable f+     , BitPack a+     )+  => Maybe Bit+  -- ^ Value to map don't care bits to. 'Nothing' means throwing an error on+  -- don't care bits.+  -> f a+  -- ^ The content for the 'MemBlob'+  -> ExpQ+memBlobTH care es =+  case packed of+    Left err -> fail err+    Right _ -> [| MemBlob { memBlobRunsLen = $(runsLen)+                          , memBlobRuns = $(runs)+                          , memBlobEndsLen = $(endsLen)+                          , memBlobEnds = $(ends)+                          }+                    :: MemBlob $(n) $(m) |]+ where+  n = litT . numTyLit . toInteger $ len+  m = litT . numTyLit $ natToInteger @(BitSize a)+  runsLen = litE . integerL . toInteger $ L.length runsB+  runs = litE . stringPrimL $ L.unpack runsB+  endsLen = litE . integerL . toInteger $ L.length endsB+  ends = litE . stringPrimL $ L.unpack endsB+  (len, runsB, endsB) = either error id packed+  packed = packBVs care es
src/Clash/Explicit/BlockRam/File.hs view
@@ -1,52 +1,56 @@ {-| Copyright  :  (C) 2015-2016, University of Twente,-                  2017     , Google Inc.-                  2019     , Myrtle Software Ltd+                  2017     , Google Inc.,+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -= Initializing a BlockRAM with a data file #usingramfiles#+= Initializing a block RAM with a data file #usingramfiles# -BlockRAM primitives that can be initialized with a data file. The BNF grammar+Block RAM primitives that can be initialized with a data file. The BNF grammar for this data file is simple: -@-FILE = LINE+-LINE = BIT+-BIT  = '0'-     | '1'-@+> FILE = LINE++> LINE = BIT++> BIT  = '0'+>      | '1'  Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@.-For example, a data file @memory.bin@ containing the 9-bit unsigned number+For example, a data file @memory.bin@ containing the 9-bit unsigned numbers @7@ to @13@ looks like: +> 000000111+> 000001000+> 000001001+> 000001010+> 000001011+> 000001100+> 000001101++Such a file can be produced with 'memFile':+ @-000000111-000001000-000001001-000001010-000001011-000001100-000001101+writeFile "memory.bin" (memFile Nothing [7 :: Unsigned 9 .. 13]) @ -We can instantiate a BlockRAM using the content of the above file like so:+We can instantiate a block RAM using the contents of the file above like so:  @-f-  :: Clock  dom+f :: KnownDomain dom+  => Clock  dom+  -> Enable dom   -> Signal dom (Unsigned 3)   -> Signal dom (Unsigned 9)-f clk rd = 'Clash.Class.BitPack.unpack' '<$>' 'blockRamFile' clk d7 \"memory.bin\" rd (signal Nothing)+f clk en rd = 'Clash.Class.BitPack.unpack' '<$>' 'blockRamFile' clk en d7 \"memory.bin\" rd (signal Nothing) @ -In the example above, we basically treat the BlockRAM as an synchronous ROM.+In the example above, we basically treat the block RAM as a synchronous ROM. We can see that it works as expected:  @ __>>> import qualified Data.List as L__-__>>> L.tail $ sampleN 4 $ f systemClockGen (fromList [3..5])__+__>>> L.tail $ sampleN 4 $ f systemClockGen enableGen (fromList [3..5])__ [10,11,12] @ @@ -54,30 +58,27 @@ number, and a 3-bit signed number:  @-g-  :: Clock  dom+g :: KnownDomain dom+  => Clock  dom+  -> Enable dom   -> Signal dom (Unsigned 3)   -> Signal dom (Unsigned 6,Signed 3)-g clk rd = 'Clash.Class.BitPack.unpack' '<$>' 'blockRamFile' clk d7 \"memory.bin\" rd (signal Nothing)+g clk en rd = 'Clash.Class.BitPack.unpack' '<$>' 'blockRamFile' clk en d7 \"memory.bin\" rd (signal Nothing) @  And then we would see:  @ __>>> import qualified Data.List as L__-__>>> L.tail $ sampleN 4 $ g systemClockGen (fromList [3..5])__+__>>> L.tail $ sampleN 4 $ g systemClockGen enableGen (fromList [3..5])__ [(1,2),(1,3)(1,-4)] @  -} -{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}  {-# LANGUAGE Unsafe #-} @@ -89,127 +90,227 @@ {-# OPTIONS_GHC -fno-cpr-anal #-}  module Clash.Explicit.BlockRam.File-  ( -- * BlockRAM synchronized to an arbitrary clock+  ( -- * Block RAM synchronized to an arbitrary clock     blockRamFile   , blockRamFilePow2+    -- * Producing files+  , memFile     -- * Internal   , blockRamFile#   , initMem   ) where +import Control.Exception     (catch, throw)+import Control.Monad         (forM_)+import Control.Monad.ST      (ST, runST)+import Control.Monad.ST.Unsafe (unsafeInterleaveST, unsafeIOToST, unsafeSTToIO)+import Data.Array.MArray     (newArray_)+import Data.Bits             ((.&.), (.|.), shiftL, xor) import Data.Char             (digitToInt)-import Data.Maybe            (fromJust, isJust, listToMaybe)-import qualified Data.Vector as V+import Data.Maybe            (isJust, listToMaybe)+import GHC.Arr               (STArray, unsafeReadSTArray, unsafeWriteSTArray) import GHC.Stack             (HasCallStack, withFrozenCallStack) import GHC.TypeLits          (KnownNat) import Numeric               (readInt)-import System.IO.Unsafe      (unsafePerformIO)+import System.IO -import Clash.Promoted.Nat    (SNat (..), pow2SNat)-import Clash.Sized.BitVector (BitVector)+import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Class.BitPack   (BitPack, BitSize, pack)+import Clash.Promoted.Nat    (SNat (..), pow2SNat, natToNum, snatToNum)+import Clash.Sized.Internal.BitVector (Bit(..), BitVector(..), undefined#) import Clash.Signal.Internal   (Clock(..), Signal (..), Enable, KnownDomain, fromEnable, (.&&.)) import Clash.Signal.Bundle   (unbundle) import Clash.Sized.Unsigned  (Unsigned)-import Clash.XException      (errorX, maybeIsX, seqX)+import Clash.XException      (maybeIsX, seqX, fromJustX, NFDataX(..), XException (..)) +-- start benchmark only+-- import GHC.Arr (unsafeFreezeSTArray, unsafeThawSTArray)+-- end benchmark only --- | Create a blockRAM with space for 2^@n@ elements+-- $setup+-- >>> :m -Prelude+-- >>> :set -fplugin GHC.TypeLits.Normalise+-- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver+-- >>> import Clash.Prelude+-- >>> import Clash.Prelude.BlockRam.File+++-- | Create a block RAM with space for 2^@n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'XException' -- * __NB__: This function might not work for specific combinations of -- code-generation backends and hardware targets. Please check the support table -- below: -----     @---                    | VHDL     | Verilog  | SystemVerilog |---     ===============+==========+==========+===============+---     Altera/Quartus | Broken   | Works    | Works         |---     Xilinx/ISE     | Works    | Works    | Works         |---     ASIC           | Untested | Untested | Untested      |---     ===============+==========+==========+===============+---     @+-- +----------------+----------+----------+---------------++-- |                | VHDL     | Verilog  | SystemVerilog |+-- +================+==========+==========+===============++-- | Altera/Quartus | Broken   | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | Xilinx/ISE     | Works    | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | ASIC           | Untested | Untested | Untested      |+-- +----------------+----------+----------+---------------+ ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a--- Block RAM.+-- block RAM. -- * Use the adapter 'Clash.Explicit.BlockRam.readNew' for obtaining write-before-read semantics like this: @'Clash.Explicit.BlockRam.readNew' clk rst en (blockRamFilePow2' clk en file) rd wrM@. -- * See "Clash.Explicit.BlockRam.File#usingramfiles" for more information on how--- to instantiate a Block RAM with the contents of a data file.--- * See "Clash.Explicit.Fixed#creatingdatafiles" for ideas on how to create your--- own data files.+-- to instantiate a block RAM with the contents of a data file.+-- * See 'memFile' for creating a data file with Clash.+-- * See "Clash.Explicit.Fixed#creatingdatafiles" for more ideas on how to+-- create your own data files. blockRamFilePow2   :: forall dom n m    . (KnownDomain dom, KnownNat m, KnownNat n, HasCallStack)   => Clock dom   -- ^ 'Clock' to synchronize to   -> Enable dom-  -- ^ Global enable+  -- ^ 'Enable' line   -> FilePath-  -- ^ File describing the initial content of the blockRAM+  -- ^ File describing the initial content of the BRAM   -> Signal dom (Unsigned n)   -- ^ Read address @r@   -> Signal dom (Maybe (Unsigned n, BitVector m))   -- ^ (write address @w@, value to write)   -> Signal dom (BitVector m)-  -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle blockRamFilePow2 = \clk en file rd wrM -> withFrozenCallStack-  (blockRamFile clk en (pow2SNat (SNat @ n)) file rd wrM)+  (blockRamFile clk en (pow2SNat (SNat @n)) file rd wrM) {-# INLINE blockRamFilePow2 #-} --- | Create a blockRAM with space for @n@ elements+-- | Create a block RAM with space for @n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'XException' -- * __NB__: This function might not work for specific combinations of -- code-generation backends and hardware targets. Please check the support table -- below: -----     @---                    | VHDL     | Verilog  | SystemVerilog |---     ===============+==========+==========+===============+---     Altera/Quartus | Broken   | Works    | Works         |---     Xilinx/ISE     | Works    | Works    | Works         |---     ASIC           | Untested | Untested | Untested      |---     ===============+==========+==========+===============+---     @+-- +----------------+----------+----------+---------------++-- |                | VHDL     | Verilog  | SystemVerilog |+-- +================+==========+==========+===============++-- | Altera/Quartus | Broken   | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | Xilinx/ISE     | Works    | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | ASIC           | Untested | Untested | Untested      |+-- +----------------+----------+----------+---------------+ ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Explicit.BlockRam#usingrams" for more information on how to use a--- Block RAM.+-- block RAM. -- * Use the adapter 'Clash.Explicit.BlockRam.readNew' for obtaining write-before-read semantics like this: @'Clash.Explicit.BlockRam.readNew' clk rst en ('blockRamFile' clk en size file) rd wrM@. -- * See "Clash.Explicit.BlockRam.File#usingramfiles" for more information on how--- to instantiate a Block RAM with the contents of a data file.--- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your--- own data files.+-- to instantiate a block RAM with the contents of a data file.+-- * See 'memFile' for creating a data file with Clash.+-- * See "Clash.Sized.Fixed#creatingdatafiles" for more ideas on how to create+-- your own data files. blockRamFile-  :: (KnownDomain dom, KnownNat m, Enum addr, HasCallStack)+  :: (KnownDomain dom, KnownNat m, Enum addr, NFDataX addr, HasCallStack)   => Clock dom   -- ^ 'Clock' to synchronize to   -> Enable dom-  -- ^ Global enable+  -- ^ 'Enable' line   -> SNat n-  -- ^ Size of the blockRAM+  -- ^ Size of the BRAM   -> FilePath-  -- ^ File describing the initial content of the blockRAM+  -- ^ File describing the initial content of the BRAM   -> Signal dom addr   -- ^ Read address @r@   -> Signal dom (Maybe (addr, BitVector m))   -- ^ (write address @w@, value to write)   -> Signal dom (BitVector m)-  -- ^ Value of the @blockRAM@ at address @r@ from the previous-  -- clock cycle+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle blockRamFile = \clk gen sz file rd wrM ->   let en       = isJust <$> wrM-      (wr,din) = unbundle (fromJust <$> wrM)+      (wr,din) = unbundle (fromJustX <$> wrM)   in  withFrozenCallStack       (blockRamFile# clk gen sz file (fromEnum <$> rd) en (fromEnum <$> wr) din) {-# INLINE blockRamFile #-} +-- | Convert data to the 'String' contents of a memory file.+--+-- * __NB__: Not synthesizable+-- * The following document the several ways to instantiate components with+-- files:+--+--     * "Clash.Prelude.BlockRam.File#usingramfiles"+--     * "Clash.Prelude.ROM.File#usingromfiles"+--     * "Clash.Explicit.BlockRam.File#usingramfiles"+--     * "Clash.Explicit.ROM.File#usingromfiles"+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" for more ideas on how to create+-- your own data files.+--+-- = Example+--+-- The @Maybe@ datatype has don't care bits, where the actual value does not+-- matter. But the bits need a defined value in the memory. Either 0 or 1 can be+-- used, and both are valid representations of the data.+--+-- >>> let es = [ Nothing, Just (7 :: Unsigned 8), Just 8]+-- >>> mapM_ (putStrLn . show . pack) es+-- 0b0_...._....+-- 0b1_0000_0111+-- 0b1_0000_1000+-- >>> putStr (memFile (Just 0) es)+-- 000000000+-- 100000111+-- 100001000+-- >>> putStr (memFile (Just 1) es)+-- 011111111+-- 100000111+-- 100001000+--+memFile+  :: forall a f+   . ( BitPack a+     , Foldable f+     , HasCallStack)+  => Maybe Bit+  -- ^ Value to map don't care bits to. 'Nothing' means throwing an error on+  -- don't care bits.+  -> f a+  -- ^ Values to convert+  -> String+  -- ^ Contents of the memory file+memFile care = foldr (\e -> showsBV $ pack e) ""+ where+  showsBV :: BitVector (BitSize a) -> String -> String+  showsBV (BV mask val) s =+    if n == 0 then+      '0' : '\n' : s+    else+      case care of+        Just (Bit 0 0) -> go n (val .&. (mask `xor` fullMask)) ('\n' : s)+        Just (Bit 0 1)  -> go n (val .|. mask) ('\n' : s)+        _ -> if mask /= 0 then+               err+             else+               go n val ('\n' : s)+   where+    n = natToNum @(BitSize a) @Int+    fullMask = (1 `shiftL` n) - 1+    err = withFrozenCallStack $ error $+            "memFile: cannot convert don't-care values. "+            ++ "Please specify mapping to definite value."+    go 0  _ s0 = s0+    go n0 v s0 =+      let (!v0, !vBit) = quotRem v 2+      in if vBit == 0 then+           go (n0 - 1) v0 $ '0' : s0+         else+           go (n0 - 1) v0 $ '1' : s0+ -- | blockRamFile primitive blockRamFile#   :: forall m dom n@@ -217,11 +318,11 @@   => Clock dom   -- ^ 'Clock' to synchronize to   -> Enable dom-  -- ^ Global enable+  -- ^ 'Enable' line   -> SNat n-  -- ^ Size of the blockRAM+  -- ^ Size of the BRAM   -> FilePath-  -- ^ File describing the initial content of the blockRAM+  -- ^ File describing the initial content of the BRAM   -> Signal dom Int   -- ^ Read address @r@   -> Signal dom Bool@@ -231,46 +332,101 @@   -> Signal dom (BitVector m)   -- ^ Value to write (at address @w@)   -> Signal dom (BitVector m)-  -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle-blockRamFile# (Clock _) ena _sz file rd wen =+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRamFile# (Clock _ Nothing) ena sz file = \rd wen waS wd -> runST $ do+  ramStart <- newArray_ (0,szI)+  unsafeIOToST (withFile file ReadMode (\h ->+    forM_ [0..(szI-1)] (\i -> do+      l <- hGetLine h+      let bv = parseBV l+      bv `seq` unsafeSTToIO (unsafeWriteSTArray ramStart i bv)+      )))+  -- start benchmark only+  -- ramStart <- unsafeThawSTArray ramArr+  -- end benchmark only   go-    ramI-    (withFrozenCallStack (errorX "blockRamFile#: intial value undefined"))+    ramStart+    (withFrozenCallStack (deepErrorX "blockRamFile: intial value undefined"))     (fromEnable ena)     rd     (fromEnable ena .&&. wen)-  where-    -- clock enable-    go-      :: V.Vector (BitVector m)-      -> BitVector m-      -> Signal dom Bool-      -> Signal dom Int-      -> Signal dom Bool-      -> Signal dom Int-      -> Signal dom (BitVector m)-      -> Signal dom (BitVector m)-    go !ram o (re :- res) (r :- rs) (e :- en) (w :- wr) (d :- din) =-      let ram' = upd ram e (fromEnum w) d-          o'   = if re then ram V.! r else o-      in  o `seqX` o :- go ram' o' res rs en wr din+    waS+    wd+ where+  szI = snatToNum sz :: Int+  -- start benchmark only+  -- ramArr = runST $ do+  --             ram <- newArray_ (0,szI-1) -- 0 -- (error "QQ")+  --             unsafeIOToST (withFile file ReadMode (\h ->+  --               forM_ [0..(szI-1)] (\i -> do+  --                 l <- hGetLine h+  --                 let bv = parseBV l+  --                 bv `seq` unsafeSTToIO (unsafeWriteSTArray ram i bv))+  --               ))+  --             unsafeFreezeSTArray ram+  -- end benchmark only -    upd ram we waddr d = case maybeIsX we of-      Nothing -> case maybeIsX waddr of-        Nothing -> V.map (const (seq waddr d)) ram-        Just wa -> ram V.// [(wa,d)]-      Just True -> case maybeIsX waddr of-        Nothing -> V.map (const (seq waddr d)) ram-        Just wa -> ram V.// [(wa,d)]-      _ -> ram+  go :: STArray s Int (BitVector m) -> (BitVector m) -> Signal dom Bool -> Signal dom Int+    -> Signal dom Bool -> Signal dom Int -> Signal dom (BitVector m)+    -> ST s (Signal dom (BitVector m))+  go !ram o ret@(~(re :- res)) rt@(~(r :- rs)) et@(~(e :- en)) wt@(~(w :- wr)) dt@(~(d :- din)) = do+    o `seqX` (o :-) <$> (ret `seq` rt `seq` et `seq` wt `seq` dt `seq`+      unsafeInterleaveST+        (do o' <- unsafeIOToST+                    (catch (if re then unsafeSTToIO (ram `safeAt` r) else pure o)+                    (\err@XException {} -> pure (throw err)))+            d `seqX` upd ram e (fromEnum w) d+            go ram o' res rs en wr din)) -    content = unsafePerformIO (initMem file)+  upd :: STArray s Int (BitVector m) -> Bool -> Int -> (BitVector m) -> ST s ()+  upd ram we waddr d = case maybeIsX we of+    Nothing -> case maybeIsX waddr of+      Nothing -> -- Put the XException from `waddr` as the value in all+                 -- locations of `ram`.+                 forM_ [0..(szI-1)] (\i -> unsafeWriteSTArray ram i (seq waddr d))+      Just wa -> -- Put the XException from `we` as the value at address+                 -- `waddr`.+                 safeUpdate wa (seq we d) ram+    Just True -> case maybeIsX waddr of+      Nothing -> -- Put the XException from `waddr` as the value in all+                 -- locations of `ram`.+                 forM_ [0..(szI-1)] (\i -> unsafeWriteSTArray ram i (seq waddr d))+      Just wa -> safeUpdate wa d ram+    _ -> return () -    ramI :: V.Vector (BitVector m)-    ramI = V.fromList content-{-# NOINLINE blockRamFile# #-}+  safeAt :: HasCallStack => STArray s Int (BitVector m) -> Int -> ST s (BitVector m)+  safeAt s i =+    if (0 <= i) && (i < szI) then+      unsafeReadSTArray s i+    else pure $+      withFrozenCallStack+        (deepErrorX ("blockRamFile: read address " <> show i <>+                " not in range [0.." <> show szI <> ")"))+  {-# INLINE safeAt #-} --- | __NB:__ Not synthesizable+  safeUpdate :: HasCallStack => Int -> BitVector m+             -> STArray s Int (BitVector m) -> ST s ()+  safeUpdate i a s =+    if (0 <= i) && (i < szI) then+      unsafeWriteSTArray s i a+    else+      let d = withFrozenCallStack+                (deepErrorX ("blockRamFile: write address " <> show i <>+                             " not in range [0.." <> show szI <> ")"))+      in forM_ [0..(szI-1)] (\j -> unsafeWriteSTArray s j d)+  {-# INLINE safeUpdate #-}++  parseBV :: String -> BitVector m+  parseBV s = case parseBV' s of+                Just i  -> fromInteger i+                Nothing -> undefined#+  parseBV' = fmap fst . listToMaybe . readInt 2 (`elem` "01") digitToInt+blockRamFile# _ _ _ _ = error "blockRamFile#: dynamic clocks not supported"++{-# OPAQUE blockRamFile# #-}+{-# ANN blockRamFile# hasBlackBox #-}++-- | __NB__: Not synthesizable initMem :: KnownNat n => FilePath -> IO [BitVector n] initMem = fmap (map parseBV . lines) . readFile   where@@ -278,4 +434,4 @@                   Just i  -> fromInteger i                   Nothing -> error ("Failed to parse: " ++ s)     parseBV' = fmap fst . listToMaybe . readInt 2 (`elem` "01") digitToInt-{-# NOINLINE initMem #-}+{-# OPAQUE initMem #-}
+ src/Clash/Explicit/BlockRam/Internal.hs view
@@ -0,0 +1,207 @@+{-|+Copyright  :  (C) 2021-2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++module Clash.Explicit.BlockRam.Internal where++import Data.Bits ((.&.), (.|.), shiftL, xor)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Builder (Builder, toLazyByteString, word8, word64BE)+import qualified Data.ByteString.Unsafe as B+#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif+import Data.Word (Word64)+import GHC.Exts (Addr#)+import GHC.TypeLits (KnownNat, Nat)+import Numeric.Natural (Natural)+import System.IO.Unsafe (unsafePerformIO)++import Clash.Class.BitPack.Internal (BitPack, BitSize, pack)+import Clash.Promoted.Nat (natToNum)+import Clash.Sized.Internal.BitVector (Bit(..), BitVector(..))++-- | Efficient storage of memory content+--+-- It holds @n@ words of @'BitVector' m@.+data MemBlob (n :: Nat) (m :: Nat) where+  MemBlob+    :: ( KnownNat n+       , KnownNat m+       )+    => { memBlobRunsLen :: !Int+       , memBlobRuns :: Addr#+       , memBlobEndsLen :: !Int+       , memBlobEnds :: Addr#+       }+    -> MemBlob n m++instance Show (MemBlob n m) where+  showsPrec _ x@MemBlob{} =+    ("$(memBlobTH @(BitVector " ++) . shows (natToNum @m @Int) .+      (") Nothing " ++) . shows (unpackMemBlob x) . (')':)++-- | Convert a 'MemBlob' back to a list+--+-- __NB__: Not synthesizable+unpackMemBlob+  :: forall n m+   . MemBlob n m+  -> [BitVector m]+unpackMemBlob = unsafePerformIO . unpackMemBlob0++unpackMemBlob0+  :: forall n m+   . MemBlob n m+  -> IO [BitVector m]+unpackMemBlob0 MemBlob{..} = do+  runsB <- B.unsafePackAddressLen memBlobRunsLen memBlobRuns+  endsB <- B.unsafePackAddressLen memBlobEndsLen memBlobEnds+  return $ map (BV 0) $+    unpackNats (natToNum @n) (natToNum @m) runsB endsB++packBVs+  :: forall a f+   . ( Foldable f+     , BitPack a+     )+  => Maybe Bit+  -> f a+  -> Either String (Int, L.ByteString, L.ByteString)+packBVs care es =+  case lenOrErr of+    Nothing  -> Left err+    Just len -> let (runs, ends) = packAsNats mI (knownBVVal . pack) es+                in Right (len, runs, ends)+ where+  lenOrErr = case care of+               Just (Bit 0 _) -> Just $ length es+               _              -> foldl' lenOrErr0 (Just 0) es+  lenOrErr0 (Just len) (pack -> BV 0 _) = Just $ len + 1+  lenOrErr0 _          _                = Nothing++  knownBVVal bv@(BV _ val) = case care of+    Just (Bit 0 bm) -> maskBVVal bm bv+    _               -> val++  maskBVVal _ (BV 0    val) = val+  maskBVVal 0 (BV mask val) = val .&. (mask `xor` fullMask)+  maskBVVal _ (BV mask val) = val .|. mask++  mI = natToNum @(BitSize a) @Int+  fullMask = (1 `shiftL` mI) - 1+  err = "packBVs: cannot convert don't care values. " +++        "Please specify a mapping to a definite value."++packAsNats+  :: forall a f+   . Foldable f+  => Int+  -> (a -> Natural)+  -> f a+  -> (L.ByteString, L.ByteString)+packAsNats width trans es = (toLazyByteString runs0, toLazyByteString ends)+ where+  (runL, endL) = width `divMod` 8+  ends | endC0 > 0 = word64BE endA0 <> ends0+       | otherwise = ends0+  (runs0, ends0, endC0, endA0) = foldr pack0 (mempty, mempty, 0, 0) es++  pack0 :: a -> (Builder, Builder, Int, Word64) ->+           (Builder, Builder, Int, Word64)+  pack0 val (runs1, ends1, endC1, endA1) =+    let (ends2, endC2, endA2) = packEnd val2 ends1 endC1 endA1+        (val2, runs2) = packRun runL (trans val) runs1+    in (runs2, ends2, endC2, endA2)++  packRun :: Int -> Natural -> Builder -> (Natural, Builder)+  packRun 0    val1 runs1 = (val1, runs1)+  packRun runC val1 runs1 = let (val2, runB) = val1 `divMod` 256+                                runs2 = word8 (fromIntegral runB) <> runs1+                            in packRun (runC - 1) val2 runs2++  packEnd :: Natural -> Builder -> Int -> Word64 -> (Builder, Int, Word64)+  packEnd val2 ends1 endC1 endA1+    | endL == 0   = (ends1, endC1, endA1)+    | endC2 <= 64 = let endA2 = endA1 * (2 ^ endL) + valEnd+                    in (ends1, endC2, endA2)+    | otherwise   = let ends2 = word64BE endA1 <> ends1+                    in (ends2, endL, valEnd)+   where+    endC2 = endC1 + endL+    valEnd = fromIntegral val2++unpackNats+  :: Int+  -> Int+  -> B.ByteString+  -> B.ByteString+  -> [Natural]+unpackNats 0 _ _ _ = []+unpackNats len width runBs endBs+  | width < 8 = ends+  | otherwise = case ends of+                  (e0:es) -> go e0 runL runBs es+                  _ -> error ("unpackNats failed for:" <> show (len,width,runBs,endBs))+ where+  (runL, endL) = width `divMod` 8+  ends = if endL == 0 then+           repeat 0+         else+           unpackEnds endL len $ unpackW64s endBs++  go :: Natural -> Int -> B.ByteString -> [Natural] -> [Natural]+  go val 0    runBs0 ends0+    = let (end0,end0rest) = case ends0 of+            [] -> error "unpackNats: unexpected end of bytestring"+            (x:xs) -> (x,xs)+       in val : go end0 runL runBs0 end0rest+  go _   _    runBs0 _             | B.null runBs0 = []+  go val runC runBs0 ends0+    = let (runB, runBs1) = case B.uncons runBs0 of+             Nothing -> error "unpackNats: unexpected end of bytestring"+             Just xs -> xs+          val0 = val * 256 + fromIntegral runB+      in go val0 (runC - 1) runBs1 ends0++unpackW64s+  :: B.ByteString+  -> [Word64]+unpackW64s = go 8 0+ where+  go :: Int -> Word64 -> B.ByteString -> [Word64]+  go 8 _   endBs | B.null endBs = []+  go 0 val endBs = val : go 8 0 endBs+  go n val endBs = let (endB, endBs0) = case B.uncons endBs of+                          Nothing -> error "unpackW64s: unexpeded end of bytestring"+                          Just xs -> xs+                       val0 = val * 256 + fromIntegral endB+                   in go (n - 1) val0 endBs0++unpackEnds+  :: Int+  -> Int+  -> [Word64]+  -> [Natural]+unpackEnds _    _   []     = []+unpackEnds endL len (w:ws) = go endCInit w ws+ where+  endPerWord = 64 `div` endL+  leader = len `mod` endPerWord+  endCInit | leader == 0 = endPerWord+           | otherwise   = leader++  go 0 _    []       = []+  go 0 _    (w0:ws0) = go endPerWord w0 ws0+  go n endA ws0      = let (endA0, valEnd) = endA `divMod` (2 ^ endL)+                       in fromIntegral valEnd : go (n - 1) endA0 ws0
+ src/Clash/Explicit/BlockRam/Model.hs view
@@ -0,0 +1,313 @@+{-|+Copyright  :  (C) 2023, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Configurable model for true dual-port block RAM+-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}++module Clash.Explicit.BlockRam.Model where++import Control.Exception (throw)+import Data.Sequence (Seq)+import GHC.Stack (HasCallStack)+import GHC.TypeNats (KnownNat)++import Clash.Promoted.Nat (SNat(..), natToNum)+import Clash.Signal.Bundle (Bundle(bundle))+import Clash.Signal.Internal+  (KnownDomain(..), Clock (..), Signal (..), ClockAB (..), clockTicks)+import Clash.Sized.Index (Index)+import Clash.XException (XException(..), NFDataX(..), seqX)+import Clash.XException.MaybeX (MaybeX(..), toMaybeX, andX)++import qualified Clash.XException.MaybeX as MaybeX++import qualified Data.Sequence as Seq++-- | Helper used in 'getConflict'+data Conflict = Conflict+  { cfRWA :: !(MaybeX Bool) -- ^ Read/Write conflict for output A+  , cfRWB :: !(MaybeX Bool) -- ^ Read/Write conflict for output B+  , cfWW  :: !(MaybeX Bool) -- ^ Write/Write conflict+  } deriving (Show)++-- | Determines whether there was a write-write or read-write conflict. A conflict+-- occurs when two ports tried to (potentially, in case of undefined values)+-- access the same address and one or both tried to write to it. See documentation+-- of 'Conflict' for more information.+getConflict ::+  -- | Port A: enable, write enable, address+  (MaybeX Bool, MaybeX Bool, MaybeX Int) ->+  -- | Port B: enable, write enable, address+  (MaybeX Bool, MaybeX Bool, MaybeX Int) ->+  -- | 'Just' if there is a (potential) write conflict, otherwise 'Nothing'+  Maybe Conflict+getConflict (enA, wenA, addrA) (enB, wenB, addrB)+  | IsDefined False <- sameAddrX = Nothing+  | otherwise                    = Just conflict+ where+  sameAddrX = liftA2 (==) addrA addrB++  conflict = Conflict+    { cfRWA = enA `andX` (enB `andX` wenB)+    , cfRWB = enB `andX` (enA `andX` wenA)+    , cfWW  = (enA `andX` enB) `andX` (wenA `andX` wenB)+    }++-- | Step through a cycle of a TDP block RAM where only one clock is active. Like+-- 'accessRam', it accounts for 'Clash.XException.XException' in all values+-- supplied by the user of the block RAM.+cycleOne ::+  forall nAddrs a writeEnable .+  ( HasCallStack+  , NFDataX a+  ) =>+  SNat nAddrs ->+  TdpbramModelConfig writeEnable a ->+  -- | Previous value+  a ->+  -- | Memory+  Seq a ->+  -- | Port: enable, address, write enable, write data+  (MaybeX Bool, MaybeX Int, MaybeX writeEnable, a) ->+  -- | Updated memory, output value+  (Seq a, a)+cycleOne SNat TdpbramModelConfig{..} prev ram0 = \case+  -- RAM is disabled, so we do nothing+  (IsDefined False, _, _, _) ->+    (ram0, prev)++  -- RAM is (potentially) enabled, so we run write RAM logic+  (ena, addr, byteEna0, dat) ->+    let+      byteEna1 = tdpMergeWriteEnable ena byteEna0+      (out0, !ram1) =+        accessRam (SNat @nAddrs) tdpIsActiveWriteEnable tdpUpdateRam addr byteEna1 dat ram0++      out1 = MaybeX.maybeX (throw . XException) (const out0) ena+    in+      (ram1, out1)++-- | Step through a cycle of a TDP block RAM where the clock edges of port A and+-- port B coincided. Like 'accessRam', it accounts for 'Clash.XException.XException'+-- in all values supplied by the user of the block RAM.+cycleBoth ::+  forall nAddrs a writeEnable.+  ( NFDataX a+  , HasCallStack+  ) =>+  SNat nAddrs ->+  TdpbramModelConfig writeEnable a ->+  -- | Previous value for port A+  a ->+  -- | Previous value for port B+  a ->+  -- | Memory+  Seq a ->+  -- | Port A: enable, address, write enable, write data+  (MaybeX Bool, MaybeX Int, MaybeX writeEnable, a) ->+  -- | Port B: enable, address, write enable, write data+  (MaybeX Bool, MaybeX Int, MaybeX writeEnable, a) ->+  -- | Updated memory, output value A, output value B+  (Seq a, a, a)+cycleBoth+  SNat TdpbramModelConfig{..} prevA prevB ram0+  (enAx, addrAx, byteEnaAx0, datA)+  (enBx, addrBx, byteEnaBx0, datB) = (ram2, outA2, outB2)+ where+  conflict =+    getConflict+      (enAx, tdpIsActiveWriteEnable byteEnaAx1, addrAx)+      (enBx, tdpIsActiveWriteEnable byteEnaBx1, addrBx)++  writeWriteError = deepErrorX "conflicting write/write queries"+  readWriteError = deepErrorX "conflicting read/write queries"++  byteEnaAx1 = tdpMergeWriteEnable enAx byteEnaAx0+  byteEnaBx1 = tdpMergeWriteEnable enBx byteEnaBx0++  (datA1, datB1) = case conflict of+    Just Conflict{cfWW=IsDefined True} -> (writeWriteError, writeWriteError)+    Just Conflict{cfWW=IsX _} -> (writeWriteError, writeWriteError)+    _ -> (datA, datB)++  (outA0, ram1) =+    accessRam (SNat @nAddrs) tdpIsActiveWriteEnable tdpUpdateRam addrAx byteEnaAx1 datA1 ram0+  (outB0, ram2) =+    accessRam (SNat @nAddrs) tdpIsActiveWriteEnable tdpUpdateRam addrBx byteEnaBx1 datB1 ram1++  outA1 = case conflict of+    Just Conflict{cfRWA=IsDefined True} -> readWriteError+    Just Conflict{cfRWA=IsX _} -> readWriteError+    _ -> outA0++  outB1 = case conflict of+    Just Conflict{cfRWB=IsDefined True} -> readWriteError+    Just Conflict{cfRWB=IsX _} -> readWriteError+    _ -> outB0++  outA2 = if MaybeX.fromMaybeX enAx then outA1 else prevA+  outB2 = if MaybeX.fromMaybeX enBx then outB1 else prevB++-- | Access a RAM and account for undefined values in the address, write enable,+-- and data to write. Return read after write value.+accessRam ::+  forall nAddrs a writeEnable .+  ( NFDataX a+  , HasCallStack ) =>+  SNat nAddrs ->+  -- | Determine whether a write enable is active+  (MaybeX writeEnable -> MaybeX Bool) ->+  -- | Update memory with a defined address+  (Int -> MaybeX writeEnable -> a -> Seq a -> Seq a) ->+  -- | Address+  MaybeX Int ->+  -- | Byte enable+  MaybeX writeEnable ->+  -- | Data to write+  a ->+  -- | Memory to write to+  Seq a ->+  -- | (Read after write value, new memory)+  (a, Seq a)+accessRam SNat tdpIsActiveWriteEnable updateMem addrX byteEnableX dat mem0+  -- Read (do nothing)+  | IsDefined False <- tdpIsActiveWriteEnable byteEnableX+  = (mem0 `Seq.index` MaybeX.fromMaybeX addrX, mem0)++  -- Undefined address and write enable or (partially) unknown+  | IsX addrMsg <- addrX+  = ( deepErrorX $ "Unknown address" <> "\nAddress error message: " <> addrMsg+    , Seq.fromFunction (natToNum @nAddrs) (unknownAddr addrMsg) )++  -- Write with defined address+  | IsDefined addr <- addrX+  , mem1 <- updateMem addr byteEnableX dat mem0+  = (mem1 `Seq.index` addr, mem1)+ where+  unknownAddr :: String -> Int -> a+  unknownAddr msg n =+    deepErrorX ("Write enabled or undefined, but address unknown; position " <> show n <>+                "\nAddress error message: " <> msg)++data TdpbramModelConfig writeEnable a = TdpbramModelConfig+  { tdpIsActiveWriteEnable :: MaybeX writeEnable -> MaybeX Bool+  -- ^ Determine whether a write enable is active++  , tdpMergeWriteEnable :: MaybeX Bool -> MaybeX writeEnable -> MaybeX writeEnable+  -- ^ Merge global enable with write enable++  , tdpUpdateRam :: Int -> MaybeX writeEnable -> a -> Seq a -> Seq a+  -- ^ Update memory with a defined address+  }++-- | Haskell model for a true dual-port block RAM which is polymorphic in its+-- write enables+--+tdpbramModel ::+  forall nAddrs domA domB a writeEnable .+  ( HasCallStack+  , KnownNat nAddrs+  , KnownDomain domA+  , KnownDomain domB+  , NFDataX a+  ) =>+  TdpbramModelConfig writeEnable a ->++  Clock domA ->+  -- | Enable+  Signal domA Bool ->+  -- | Address+  Signal domA (Index nAddrs) ->+  -- | Write enable+  Signal domA writeEnable ->+  -- | Write data+  Signal domA a ->++  Clock domB ->+  -- | Enable+  Signal domB Bool ->+  -- | Address+  Signal domB (Index nAddrs) ->+  -- | Write byte enable+  Signal domB writeEnable ->+  -- | Write data+  Signal domB a ->++  (Signal domA a, Signal domB a)+tdpbramModel+  config+  clkA enA addrA byteEnaA datA+  clkB enB addrB byteEnaB datB =+  ( startA :- outA+  , startB :- outB )+ where+  (outA, outB) =+    go+      (Seq.fromFunction (natToNum @nAddrs) initElement)+      (clockTicks clkA clkB)+      (bundle (enA, byteEnaA, fromIntegral <$> addrA, datA))+      (bundle (enB, byteEnaB, fromIntegral <$> addrB, datB))+      startA startB++  startA = deepErrorX $ "Port A: First value undefined"+  startB = deepErrorX $ "Port B: First value undefined"++  initElement :: Int -> a+  initElement n =+    deepErrorX ("Unknown initial element; position " <> show n)++  go ::+    Seq a ->+    [ClockAB] ->+    Signal domA (Bool, writeEnable, Int, a) ->+    Signal domB (Bool, writeEnable, Int, a) ->+    a -> a ->+    (Signal domA a, Signal domB a)+  go _ [] _ _ =+    error "tdpbramModel#.go: `ticks` should have been an infinite list"+  go ram0 (tick:ticks) as0 bs0 =+    case tick of+      ClockA -> goA+      ClockB -> goB+      ClockAB -> goBoth+   where+    (  toMaybeX -> enAx+     , toMaybeX -> byteEnaAx+     , toMaybeX -> addrAx+     , datA0+     ) :- as1 = as0++    (  toMaybeX -> enBx+     , toMaybeX -> byteEnaBx+     , toMaybeX -> addrBx+     , datB0+     ) :- bs1 = bs0++    portA = (enAx, addrAx, byteEnaAx, datA0)+    portB = (enBx, addrBx, byteEnaBx, datB0)++    goBoth prevA prevB = outA1 `seqX` outB1 `seqX` (outA1 :- as2, outB1 :- bs2)+     where+      (ram1, outA1, outB1) =+        cycleBoth+          (SNat @nAddrs) config+          prevA prevB ram0 portA portB+      (as2, bs2) = go ram1 ticks as1 bs1 outA1 outB1++    goA prevA prevB = out `seqX` (out :- as2, bs2)+     where+      (ram1, out) = cycleOne (SNat @nAddrs) config prevA ram0 portA+      (as2, bs2) = go ram1 ticks as1 bs0 out prevB++    goB prevA prevB = out `seqX` (as2, out :- bs2)+     where+      (ram1, out) = cycleOne (SNat @nAddrs) config prevB ram0 portB+      (as2, bs2) = go ram1 ticks as0 bs1 prevA out
src/Clash/Explicit/DDR.hs view
@@ -1,13 +1,14 @@ {-| Copyright  :  (C) 2017, Google Inc                   2019, Myrtle Software Ltd+                  2025, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  We simulate DDR signal by using 'Signal's which have exactly half the period (or double the speed) of our normal 'Signal's. -The primitives in this module can be used to produce of consume DDR signals.+The primitives in this module can be used to produce or consume DDR signals.  DDR signals are not meant to be used internally in a design, but only to communicate with the outside world.@@ -18,58 +19,81 @@ or "Clash.Xilinx.DDR". -} -{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE ViewPatterns        #-}-#if __GLASGOW_HASKELL__ >= 806-{-# LANGUAGE NoStarIsType #-}-#endif+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TypeFamilies #-}  module Clash.Explicit.DDR   ( ddrIn   , ddrOut+  , ddrForwardClock     -- * Internal   , ddrIn#   , ddrOut#+  , ddrForwardClock#   ) where +import Data.List.Infinite (Infinite(..), (...))+import Data.String.Interpolate (__i) import GHC.Stack (HasCallStack, withFrozenCallStack)+import Unsafe.Coerce (unsafeCoerce) -import Clash.Annotations.Primitive    (hasBlackBox)-import Clash.Explicit.Prelude+import Clash.Annotations.Primitive (hasBlackBox, Primitive(..), HDL(..))+import Clash.Explicit.Prelude hiding ((:<)) import Clash.Signal.Internal +{- $setup+>>> :set -XNoImplicitPrelude -XTypeFamilies -XFlexibleInstances+>>> import Clash.Explicit.Prelude+>>> import Clash.Explicit.DDR+>>> :{+type DDR = "DDR" :: Domain+instance KnownDomain "DDR" where+  type KnownConf "DDR" = 'DomainConfiguration "DDR" 5000 'Rising 'Asynchronous 'Defined 'ActiveHigh+  knownDomain = SDomainConfiguration SSymbol SNat SRising SAsynchronous SDefined SActiveHigh+:} +-}+ -- | DDR input primitive -- -- Consumes a DDR input signal and produces a regular signal containing a pair -- of values. ----- >>> printX $ sampleN 5 $ ddrIn systemClockGen resetGen enableGen (-1,-2,-3) (fromList [0..10])--- [(X,X),((-1),(-2)),((-3),2),(3,4),(5,6)]+-- Data is clocked in on both edges of the clock signal. We can discern the+-- /active edge/ of the clock and the /other edge/. When the domain has the+-- rising edge as the active edge (which is the most common), this means that+-- the /rising/ edge is the /active/ edge and the /falling/ edge is the /other/+-- edge.+--+-- Of the output pair @(o0, o1)@, @o0@ is the data clocked in on the /other/+-- edge and @o1@ is the data clocked in on the /active/ edge, and @o0@ comes+-- before @o1@ in time. With a domain where the rising edge is the active edge,+-- this means @o0@ is clocked in on the falling clock edge and @o1@ is clocked+-- in on the rising clock edge. For a domain with the falling edge as the active+-- edge, this is the other way around, but @o0@ still comes before @o1@ in time.+--+-- >>> sampleN 5 $ ddrIn @Int @System @DDR clockGen resetGen enableGen (-1,-2,-3) (fromList [0..10])+-- [(-1,-2),(-1,-2),(-3,2),(3,4),(5,6)] ddrIn-  :: ( HasCallStack-     , NFDataX a-     , KnownConfiguration fast ('DomainConfiguration fast fPeriod edge reset init polarity)-     , KnownConfiguration slow ('DomainConfiguration slow (2*fPeriod) edge reset init polarity) )-  => Clock slow-  -- ^ clock-  -> Reset slow-  -- ^ reset-  -> Enable slow+  :: forall a dom domDDR+   . HasCallStack+  => NFDataX a+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => Clock dom+  -> Reset dom+  -> Enable dom   -> (a, a, a)-  -- ^ reset values-  -> Signal fast a+  -- ^ Reset values+  -> Signal domDDR a   -- ^ DDR input signal-  -> Signal slow (a, a)-  -- ^ normal speed output pairs+  -> Signal dom (a, a)+  -- ^ Normal speed output pair @(o0, o1)@ ddrIn clk rst en (i0,i1,i2) =   withFrozenCallStack $ ddrIn# clk rst en i0 i1 i2 @@ -77,21 +101,22 @@ -- For details about all the seq's en seqX's -- see the [Note: register strictness annotations] in Clash.Signal.Internal ddrIn#-  :: forall a slow fast fPeriod polarity edge reset init-   . ( HasCallStack-     , NFDataX a-     , KnownConfiguration fast ('DomainConfiguration fast fPeriod edge reset init polarity)-     , KnownConfiguration slow ('DomainConfiguration slow (2*fPeriod) edge reset init polarity) )-  => Clock slow-  -> Reset slow-  -> Enable slow+  :: forall a dom domDDR+   . HasCallStack+  => NFDataX a+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => Clock dom+  -> Reset dom+  -> Enable dom   -> a   -> a   -> a-  -> Signal fast a-  -> Signal slow (a,a)-ddrIn# (Clock _) (unsafeToHighPolarity -> hRst) (fromEnable -> ena) i0 i1 i2 =-  case resetKind @fast of+  -> Signal domDDR a+  -> Signal dom (a,a)+ddrIn# (Clock _ Nothing) (unsafeToActiveHigh -> hRst) (fromEnable -> ena) i0 i1 i2 =+  case resetKind @domDDR of     SAsynchronous ->       goAsync         ( deepErrorX "ddrIn: initial value 0 undefined"@@ -109,10 +134,10 @@   where     goSync       :: (a, a, a)-      -> Signal slow Bool-      -> Signal slow Bool-      -> Signal fast a-      -> Signal slow (a,a)+      -> Signal dom Bool+      -> Signal dom Bool+      -> Signal domDDR a+      -> Signal dom (a,a)     goSync (o0,o1,o2) rt@(~(r :- rs)) ~(e :- es) as@(~(x0 :- x1 :- xs)) =       let (o0',o1',o2') = if r then (i0,i1,i2) else (o2,x0,x1)       in o0 `seqX` o1 `seqX` (o0,o1)@@ -121,55 +146,75 @@      goAsync       :: (a, a, a)-      -> Signal slow Bool-      -> Signal slow Bool-      -> Signal fast a-      -> Signal slow (a, a)+      -> Signal dom Bool+      -> Signal dom Bool+      -> Signal domDDR a+      -> Signal dom (a, a)     goAsync (o0,o1,o2) ~(r :- rs) ~(e :- es) as@(~(x0 :- x1 :- xs)) =       let (o0',o1',o2',o3',o4') = if r then (i0,i1,i0,i1,i2) else (o0,o1,o2,x0,x1)       in o0' `seqX` o1' `seqX` (o0',o1')            :- (as `seq` if e then goAsync (o2',o3',o4') rs es xs                              else goAsync (o0',o1',o2') rs es xs) -{-# NOINLINE ddrIn# #-}+ddrIn# _ _ _ _ _ _ =+  error "ddrIn#: dynamic clocks not supported"+{-# OPAQUE ddrIn# #-} {-# ANN ddrIn# hasBlackBox #-}  -- | DDR output primitive -- -- Produces a DDR output signal from a normal signal of pairs of input. ----- >>> sampleN 7 $ ddrOut systemClockGen asyncResetGen (-1) (fromList [(0,1),(2,3),(4,5)])+-- Data is clocked out on both edges of the clock signal. We can discern the+-- /active edge/ of the clock and the /other edge/. When the domain has the+-- rising edge as the active edge (which is the most common), this means that+-- the /rising/ edge is the /active/ edge and the /falling/ edge is the /other/+-- edge.+--+-- Of the input pair @(i0, i1)@, @i0@ is the data clocked out on the /active/+-- edge and @i1@ is the data clocked out on the /other/ edge, and @i0@ comes+-- before @i1@ in time. With a domain where the rising edge is the active edge,+-- this means @i0@ is clocked out on the rising clock edge and @i1@ is clocked+-- out on the falling clock edge. For a domain with the falling edge as the+-- active edge, this is the other way around, but @i0@ still comes before @i1@+-- in time.+--+-- >>> sampleN 7 (ddrOut @Int @System @DDR clockGen resetGen enableGen (-1) (fromList [(0,1),(2,3),(4,5)])) -- [-1,-1,-1,2,3,4,5] ddrOut-  :: ( HasCallStack-     , NFDataX a-     , KnownConfiguration fast ('DomainConfiguration fast fPeriod edge reset init polarity)-     , KnownConfiguration slow ('DomainConfiguration slow (2*fPeriod) edge reset init polarity) )-  => Clock slow-  -> Reset slow-  -> Enable slow+  :: forall a dom domDDR+   . HasCallStack+  => NFDataX a+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => Clock dom+  -> Reset dom+  -> Enable dom   -> a-  -- ^ reset value-  -> Signal slow (a, a)-  -- ^ Normal speed input pairs-  -> Signal fast a+  -- ^ Reset value+  -> Signal dom (a, a)+  -- ^ Normal speed input pair @(i0, i1)@+  -> Signal domDDR a   -- ^ DDR output signal ddrOut clk rst en i0 =   uncurry (withFrozenCallStack $ ddrOut# clk rst en i0) . unbundle   ddrOut#-  :: ( HasCallStack-     , NFDataX a-     , KnownConfiguration fast ('DomainConfiguration fast fPeriod edge reset init polarity)-     , KnownConfiguration slow ('DomainConfiguration slow (2*fPeriod) edge reset init polarity) )-  => Clock slow-  -> Reset slow-  -> Enable slow+  :: forall a dom domDDR+   . HasCallStack+  => NFDataX a+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => Clock dom+  -> Reset dom+  -> Enable dom   -> a-  -> Signal slow a-  -> Signal slow a-  -> Signal fast a+  -> Signal dom a+  -> Signal dom a+  -> Signal domDDR a ddrOut# clk rst en i0 xs ys =     -- We only observe one reset value, because when the mux switches on the     -- next clock level, the second register will already be outputting its@@ -178,8 +223,120 @@     -- That is why we drop the first value of the stream.     let (_ :- out) = zipSig xs' ys' in out   where-    xs' = register# clk rst en (error "ddrOut: unreachable error") i0 xs+    xs' = register# clk rst en (errorX "ddrOut: unreachable error") i0 xs     ys' = register# clk rst en (deepErrorX "ddrOut: initial value undefined") i0 ys     zipSig (a :- as) (b :- bs) = a :- b :- zipSig as bs-{-# NOINLINE ddrOut# #-}+{-# OPAQUE ddrOut# #-} {-# ANN ddrOut# hasBlackBox #-}++-- | Use a DDR output primitive to forward a clock to an output pin+--+-- This function allows outputting a clock signal on a DDR-capable output pin.+-- As with the DDR output primitive itself, the created clock cannot be used+-- internally in the design.+--+-- The @ddrOut@ primitive passed in will always have its enable asserted. If the+-- @Enable@ input of @ddrForwardClock@ is deasserted, the data inputs of the+-- @ddrOut@ primitive will switch to achieve the desired output signal. This is+-- because the behavior of the enable input of the DDR primitive differs between+-- vendor-specific primitives.+--+-- The @Reset@ input of this function is passed on to the @ddrOut@ primitive and+-- not otherwise used by @ddrForwardClock@.+--+-- With the @phase@ argument, the phase relation between input and output clock+-- can be defined. With the argument @Nothing@, the clocks are in phase: the+-- active edge of the output clock is on the active edge of the input clock,+-- even if the domains differ on what the active edge is.+--+-- With the @idle@ argument, the output level when the @Enable@ input is+-- deasserted can be defined. With @Nothing@, it will be 0 for a clock with the+-- rising edge as the active edge, and 1 for a clock with the falling edge as+-- the active edge.+--+-- __NB__: The deassertion of the @Enable@ input or the assertion of the @Reset@+-- input is not faithfully simulated in Haskell simulation: Haskell simulation+-- of a Clash design has clocks that always run. The generated HDL will actually+-- output an idle state when @Enable@ is deasserted (and the reset depends on+-- the @ddrOut@ primitive used).+ddrForwardClock+  :: forall domDDR domOut domIn+   . KnownDomain domOut+  => DomainPeriod domIn ~ DomainPeriod domOut+  => DomainPeriod domIn ~ (2 * DomainPeriod domDDR)+  => Clock domIn+  -> Reset domIn+  -> Enable domIn+  -> Maybe Bit+  -- ^ @idle@: Output value when @Enable@ is deasserted+  -> Maybe Bit+  -- ^ @phase@: Value to output at active edge of incoming clock+  -> (Clock domIn -> Reset domIn -> Enable domIn -> Signal domIn (Bit, Bit)+      -> Signal domDDR Bit)+  -- ^ @ddrOut@ primitive to use+  -> Clock domOut+ddrForwardClock clk rst en idle phase oddr =+  ddrForwardClock# clk $ oddr clk rst enableGen ins+ where+  ins =+    mux+      (fromEnable en)+      (pure (activeLevel, complement activeLevel))+      (pure (idleLevel, idleLevel))+  activeLevel =+    case phase of+      Nothing ->+        case activeEdge @domOut of+          SRising -> 1+          SFalling -> 0+      Just x -> x+  idleLevel =+    case idle of+      Nothing ->+        case activeEdge @domOut of+          SRising -> 0+          SFalling -> 1+      Just x -> x++ddrForwardClock#+  :: KnownDomain domOut+  => DomainPeriod domIn ~ DomainPeriod domOut+  => DomainPeriod domIn ~ (2 * DomainPeriod domDDR)+  => Clock domIn+  -> Signal domDDR Bit+  -> Clock domOut+ddrForwardClock# (Clock SSymbol periods) ddrSignal =+  Clock (ddrSignal `seq` SSymbol) (unsafeCoerce periods)+{-# OPAQUE ddrForwardClock# #-}+{-# ANN ddrForwardClock# (+  let+    bbName = show 'ddrForwardClock#+    _knownDomOut+      :< _domInOutPeriod+      :< _domDDRPeriod+      :< _clkIn+      :< ddrSignal+      :< _ = ((0 :: Int)...)+  in InlineYamlPrimitive [VHDL] [__i|+    BlackBox:+      name: #{bbName}+      kind: Expression+      template: ~TYPMO'(~ARG[#{ddrSignal}])+      workInfo: Never+    |]) #-}+{-# ANN ddrForwardClock# (+  let+    bbName = show 'ddrForwardClock#+    _knownDomOut+      :< _domInOutPeriod+      :< _domDDRPeriod+      :< _clkIn+      :< ddrSignal+      :< _ = ((0 :: Int)...)+  in InlineYamlPrimitive [Verilog, SystemVerilog] [__i|+    BlackBox:+      name: #{bbName}+      kind: Expression+      template: ~ARG[#{ddrSignal}]+      workInfo: Never+    |]) #-}
src/Clash/Explicit/Mealy.hs view
@@ -2,6 +2,7 @@   Copyright  :  (C) 2013-2016, University of Twente,                     2017     , Google Inc.                     2019     , Myrtle Software Ltd+                    2023     , Alex Mason   License    :  BSD2 (see the file LICENSE)   Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> @@ -12,12 +13,16 @@   requirements. -} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+ {-# LANGUAGE Safe #-}  module Clash.Explicit.Mealy   ( -- * Mealy machines with explicit clock and reset ports     mealy+  , mealyS   , mealyB+  , mealySB   ) where @@ -25,17 +30,59 @@   (KnownDomain, Bundle (..), Clock, Reset, Signal, Enable, register) import           Clash.XException      (NFDataX) +import           Control.Monad.State.Strict+  (State, runState)+ {- $setup->>> :set -XDataKinds -XTypeApplications->>> import Clash.Explicit.Prelude+>>> :set -XDataKinds -XTypeApplications -XDeriveGeneric -XDeriveAnyClass+>>> import Clash.Explicit.Prelude as C+>>> import Clash.Explicit.Mealy (mealyS) >>> import qualified Data.List as L+>>> import Control.Lens (Lens', (%=), (-=), uses, use)+>>> import Control.Monad.State.Strict (State) >>> :{ let macT s (x,y) = (s',s)       where         s' = x * y + s :} ->>> let mac clk rst en = mealy clk rst en macT 0+>>> mac clk rst en = mealy clk rst en macT 0++>>> :{+data DelayState = DelayState { _history :: Vec 4 Int , _untilValid :: Index 4 } deriving (Generic,NFDataX)+:}++>>> :{+history :: Lens' DelayState (Vec 4 Int)+history f = \(DelayState d u) -> (`DelayState` u) <$> f d+:}++>>> :{+untilValid :: Lens' DelayState (Index 4)+untilValid f = \(DelayState d u) -> DelayState d <$> f u+:}++>>> :{+delayS :: Int -> State DelayState (Maybe Int)+delayS n = do+  history   %= (n +>>)+  remaining <- use untilValid+  if remaining > 0+  then do+     untilValid -= 1+     return Nothing+   else do+     out <- uses history C.last+     return (Just out)+:}++>>> let initialDelayState = DelayState (C.repeat 0) maxBound++>>> :{+delayTop :: Clock System -> Reset System -> Enable System -> Signal System Int -> Signal System (Maybe Int)+delayTop clk rst en = mealyS clk rst en delayS initialDelayState+:}+ -}  -- | Create a synchronous function from a combinational function describing@@ -80,8 +127,8 @@ --   -> 'Signal' dom Int -- dualMac clk rst en (a,b) (x,y) = s1 + s2 --   where---     s1 = 'mealy' clk rst en mac 0 ('bundle' (a,x))---     s2 = 'mealy' clk rst en mac 0 ('bundle' (b,y))+--     s1 = 'mealy' clk rst en macT 0 ('bundle' (a,x))+--     s2 = 'mealy' clk rst en macT 0 ('bundle' (b,y)) -- @ mealy   :: ( KnownDomain dom@@ -104,6 +151,64 @@         in  o {-# INLINABLE mealy #-} +-- | Create a synchronous function from a combinational function describing+-- a mealy machine using the state monad. This can be particularly useful+-- when combined with lenses or optics to replicate imperative algorithms.+--+-- @+-- data DelayState = DelayState+--   { _history    :: Vec 4 Int+--   , _untilValid :: Index 4+--   }+--   deriving (Generic, NFDataX)+-- makeLenses ''DelayState+--+-- initialDelayState = DelayState (repeat 0) maxBound+--+-- delayS :: Int -> State DelayState (Maybe Int)+-- delayS n = do+--   history   %= (n +>>)+--   remaining <- use untilValid+--   if remaining > 0+--   then do+--      untilValid -= 1+--      return Nothing+--    else do+--      out <- uses history last+--      return (Just out)+--+-- delayTop ::'KnownDomain' dom+--   => 'Clock' dom+--   -> 'Reset' dom+--   -> 'Enable' dom+--   -> ('Signal' dom Int -> 'Signal' dom (Maybe Int))+-- delayTop clk rst en = 'mealyS' clk rst en delayS initialDelayState+-- @+--+-- >>> L.take 7 $ simulate (delayTop systemClockGen systemResetGen enableGen) [-100,1,2,3,4,5,6,7,8]+-- [Nothing,Nothing,Nothing,Nothing,Just 1,Just 2,Just 3]+--+mealyS+  :: ( KnownDomain dom+     , NFDataX s )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Reset dom+  -> Enable dom+  -- ^ Global enable+  -> (i -> State s o)+  -- ^ Transfer function in mealy machine handling inputs using @Control.Monad.Strict.State s@.+  -> s+  -- ^ Initial state+  -> (Signal dom i -> Signal dom o)+  -- ^ Synchronous sequential function with input and output matching that+  -- of the mealy machine+mealyS clk rst en f iS =+  \i -> let (o,s') = unbundle $ (runState . f) <$> i <*> s+            s      = register clk rst en iS s'+        in o+{-# INLINABLE mealyS #-}+ -- | A version of 'mealy' that does automatic 'Bundle'ing -- -- Given a function @f@ of type:@@ -147,3 +252,23 @@  -- of the mealy machine mealyB clk rst en f iS i = unbundle (mealy clk rst en f iS (bundle i)) {-# INLINE mealyB #-}+++-- | A version of 'mealyS' that does automatic 'Bundle'ing, see 'mealyB' for details.+mealySB+  :: ( KnownDomain dom+     , NFDataX s+     , Bundle i+     , Bundle o )+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> (i -> State s o)+  -- ^ Transfer function in mealy machine handling inputs using @Control.Monad.Strict.State s@.+  -> s+  -- ^ Initial state+  -> (Unbundled dom i -> Unbundled dom o)+ -- ^ Synchronous sequential function with input and output matching that+ -- of the mealy machine+mealySB clk rst en f iS i = unbundle (mealyS clk rst en f iS (bundle i))+{-# INLINE mealySB #-}
src/Clash/Explicit/Moore.hs view
@@ -12,6 +12,8 @@   requirements. -} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+ {-# LANGUAGE Safe #-}  module Clash.Explicit.Moore@@ -72,8 +74,8 @@ --   -> 'Signal' dom Int -- dualMac clk rst en (a,b) (x,y) = s1 + s2 --   where---     s1 = 'moore' clk rst en mac id 0 ('bundle' (a,x))---     s2 = 'moore' clk rst en mac id 0 ('bundle' (b,y))+--     s1 = 'moore' clk rst en macT id 0 ('bundle' (a,x))+--     s2 = 'moore' clk rst en macT id 0 ('bundle' (b,y)) -- @ moore   :: ( KnownDomain dom
src/Clash/Explicit/Prelude.hs view
@@ -1,17 +1,18 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2017     , Google Inc.-                  2019     , Myrtle Software Ltd+                  2019     , Myrtle Software Ltd,+                  2021-2025, QBayLogic B.V.,+                  2022     , Myrtle.ai, License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  This module defines the explicitly clocked counterparts of the functions defined in "Clash.Prelude". -} -{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeOperators     #-}  {-# LANGUAGE Unsafe #-} @@ -21,7 +22,9 @@ module Clash.Explicit.Prelude   ( -- * Creating synchronous sequential circuits     mealy+  , mealyS   , mealyB+  , mealySB   , moore   , mooreB   , registerB@@ -33,7 +36,12 @@   , asyncRomPow2   , rom   , romPow2-    -- ** ROMs initialized with a data file+    -- ** ROMs defined by a 'MemBlob'+  , asyncRomBlob+  , asyncRomBlobPow2+  , romBlob+  , romBlobPow2+    -- ** ROMs defined by a data file   , asyncRomFile   , asyncRomFilePow2   , romFile@@ -41,22 +49,35 @@     -- * RAM primitives with a combinational read port   , asyncRam   , asyncRamPow2-    -- * BlockRAM primitives+    -- * Block RAM primitives   , blockRam   , blockRamPow2   , blockRamU   , blockRam1   , ResetStrategy(..)-    -- ** BlockRAM primitives initialized with a data file+    -- ** Block RAM primitives initialized with a 'MemBlob'+  , blockRamBlob+  , blockRamBlobPow2+    -- *** Creating and inspecting 'MemBlob'+  , MemBlob+  , createMemBlob+  , memBlobTH+  , unpackMemBlob+    -- ** Block RAM primitives initialized with a data file   , blockRamFile   , blockRamFilePow2-  -- ** BlockRAM read/write conflict resolution+  -- ** Block RAM read/write conflict resolution   , readNew+    -- ** True dual-port block RAM+  , trueDualPortBlockRam+  , RamOp(..)     -- * Utility functions   , window   , windowD   , isRising   , isFalling+  , riseEvery+  , oscillate     -- * Testbench functions   , assert   , stimuliGenerator@@ -72,15 +93,12 @@   , dumpVCD     -- * Exported modules     -- ** Synchronous signals+  , module Clash.Explicit.Reset   , module Clash.Explicit.Signal   , module Clash.Explicit.Signal.Delayed-    -- ** DataFlow interface-  , module Clash.Prelude.DataFlow     -- ** Datatypes     -- *** Bit vectors   , module Clash.Sized.BitVector-  , module Clash.Prelude.BitIndex-  , module Clash.Prelude.BitReduction     -- *** Arbitrary-width numbers   , module Clash.Sized.Signed   , module Clash.Sized.Unsigned@@ -107,7 +125,13 @@     -- ** Template Haskell   , Lift (..)     -- ** Type classes+    -- *** Number conversion+  , NumConvert+  , numConvert+  , MaybeNumConvert+  , maybeNumConvert     -- *** Clash+  , module Clash.Class.AutoReg   , module Clash.Class.BitPack   , module Clash.Class.Exp   , module Clash.Class.Num@@ -115,10 +139,9 @@     -- *** Other   , module Control.Applicative   , module Data.Bits-  , module Data.Default.Class+  , module Data.Default     -- ** Exceptions   , module Clash.XException-  , undefined     -- ** Named types   , module Clash.NamedTypes     -- ** Magic@@ -131,33 +154,36 @@  import Control.Applicative import Data.Bits-import Data.Default.Class+import Data.Default import GHC.TypeLits+  hiding (SNat, SSymbol, fromSNat) import GHC.TypeLits.Extra import Language.Haskell.TH.Syntax  (Lift(..)) import Clash.HaskellPrelude  import Clash.Annotations.TopEntity+import Clash.Class.AutoReg import Clash.Class.BitPack import Clash.Class.Exp import Clash.Class.Num+import Clash.Class.NumConvert import Clash.Class.Resize import Clash.Magic import Clash.NamedTypes import Clash.Explicit.BlockRam+import Clash.Explicit.BlockRam.Blob import Clash.Explicit.BlockRam.File import Clash.Explicit.Mealy import Clash.Explicit.Moore import Clash.Explicit.RAM import Clash.Explicit.ROM+import Clash.Explicit.ROM.Blob import Clash.Explicit.ROM.File import Clash.Explicit.Prelude.Safe+import Clash.Explicit.Reset import Clash.Explicit.Signal import Clash.Explicit.Signal.Delayed import Clash.Explicit.Testbench-import Clash.Prelude.BitIndex-import Clash.Prelude.BitReduction-import Clash.Prelude.DataFlow import Clash.Prelude.ROM.File       (asyncRomFile, asyncRomFilePow2) import Clash.Promoted.Nat import Clash.Promoted.Nat.TH@@ -170,7 +196,7 @@ import Clash.Sized.RTree import Clash.Sized.Signed import Clash.Sized.Unsigned-import Clash.Sized.Vector+import Clash.Sized.Vector hiding (fromList, unsafeFromList) import Clash.XException  {- $setup@@ -180,6 +206,15 @@ >>> let windowD3 = windowD @2 -} +{- $hiding+"Clash.Explicit.Prelude" re-exports most of the Haskell "Prelude" with the+exception of those functions that the Clash API defines to work on 'Vec' from+"Clash.Sized.Vector" instead of on lists as the Haskell Prelude does. In+addition, for the 'Clash.Class.Parity.odd' and 'Clash.Class.Parity.even'+functions a type class called 'Clash.Class.Parity.Parity' is available at+"Clash.Class.Parity".+-}+ -- | Give a window over a 'Signal' -- -- @@@ -193,7 +228,7 @@ -- @ -- -- >>> simulateB (window4 systemClockGen systemResetGen enableGen) [1::Int,2,3,4,5] :: [Vec 4 Int]--- [<1,0,0,0>,<2,1,0,0>,<3,2,1,0>,<4,3,2,1>,<5,4,3,2>...+-- [1 :> 0 :> 0 :> 0 :> Nil,2 :> 1 :> 0 :> 0 :> Nil,3 :> 2 :> 1 :> 0 :> Nil,4 :> 3 :> 2 :> 1 :> Nil,5 :> 4 :> 3 :> 2 :> Nil,... -- ... window   :: ( KnownNat n@@ -232,7 +267,7 @@ -- @ -- -- >>> simulateB (windowD3 systemClockGen resetGen enableGen) [1::Int,1,2,3,4] :: [Vec 3 Int]--- [<0,0,0>,<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>...+-- [0 :> 0 :> 0 :> Nil,0 :> 0 :> 0 :> Nil,1 :> 0 :> 0 :> Nil,2 :> 1 :> 0 :> Nil,3 :> 2 :> 1 :> Nil,4 :> 3 :> 2 :> Nil,... -- ... windowD   :: ( KnownNat n
src/Clash/Explicit/Prelude/Safe.hs view
@@ -1,21 +1,21 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2017     , Google Inc.-                  2019     , Myrtle Software Ltd+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -__This is the <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/safe_haskell.html Safe> API only of "Clash.Explicit.Prelude"__+__This is the <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/exts/safe_haskell.html Safe> API only of "Clash.Explicit.Prelude"__  This module defines the explicitly clocked counterparts of the functions defined in "Clash.Prelude". -} -{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE NoImplicitPrelude   #-}-{-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}  {-# LANGUAGE Safe #-} @@ -36,14 +36,30 @@   , asyncRomPow2   , rom   , romPow2+    -- ** ROMs defined by a 'MemBlob'+  , asyncRomBlob+  , asyncRomBlobPow2+  , romBlob+  , romBlobPow2     -- * RAM primitives with a combinational read port   , asyncRam   , asyncRamPow2-    -- * BlockRAM primitives+    -- * Block RAM primitives   , blockRam   , blockRamPow2-    -- ** BlockRAM read/write conflict resolution+    -- ** Block RAM primitives initialized with a 'MemBlob'+  , blockRamBlob+  , blockRamBlobPow2+    -- *** Creating and inspecting 'MemBlob'+  , MemBlob+  , createMemBlob+  , memBlobTH+  , unpackMemBlob+    -- ** Block RAM read/write conflict resolution   , readNew+    -- ** True dual-port block RAM+  , trueDualPortBlockRam+  , RamOp(..)     -- * Utility functions   , isRising   , isFalling@@ -53,13 +69,9 @@     -- ** Synchronous signals   , module Clash.Explicit.Signal   , module Clash.Explicit.Signal.Delayed-    -- ** DataFlow interface-  , module Clash.Prelude.DataFlow     -- ** Datatypes     -- *** Bit vectors   , module Clash.Sized.BitVector-  , module Clash.Prelude.BitIndex-  , module Clash.Prelude.BitReduction     -- *** Arbitrary-width numbers   , module Clash.Sized.Signed   , module Clash.Sized.Unsigned@@ -93,7 +105,6 @@   , module Data.Bits       -- ** Exceptions   , module Clash.XException-  , undefined     -- ** Named types   , module Clash.NamedTypes     -- ** Haskell Prelude@@ -105,8 +116,8 @@ import Control.Applicative import Data.Bits import GHC.Generics (Generic, Generic1)-import GHC.Stack import GHC.TypeLits+  hiding (SNat, SSymbol, fromSNat) import GHC.TypeLits.Extra import Clash.HaskellPrelude import qualified Prelude@@ -118,17 +129,17 @@ import Clash.NamedTypes  import Clash.Explicit.BlockRam+import Clash.Explicit.BlockRam.Blob import Clash.Explicit.Mealy import Clash.Explicit.Moore import Clash.Explicit.RAM import Clash.Explicit.ROM+import Clash.Explicit.ROM.Blob import Clash.Explicit.Signal import Clash.Explicit.Signal.Delayed import Clash.Explicit.Synchronizer   (dualFlipFlopSynchronizer, asyncFIFOSynchronizer)-import Clash.Prelude.BitIndex-import Clash.Prelude.BitReduction-import Clash.Prelude.DataFlow+import Clash.Prelude.ROM.Blob (asyncRomBlob, asyncRomBlobPow2) import Clash.Prelude.ROM             (asyncRom, asyncRomPow2) import Clash.Promoted.Nat import Clash.Promoted.Nat.TH@@ -140,15 +151,24 @@ import Clash.Sized.RTree import Clash.Sized.Signed import Clash.Sized.Unsigned-import Clash.Sized.Vector+import Clash.Sized.Vector hiding (fromList, unsafeFromList) import Clash.XException  {- $setup >>> :set -XDataKinds->>> import Clash.Explicit.Prelude+>>> :m -Prelude+>>> import Clash.Explicit.Prelude.Safe >>> let rP clk rst en = registerB clk rst en (8::Int,8::Int) -} +{- $hiding+"Clash.Explicit.Prelude.Safe" re-exports most of the Haskell "Prelude" with the+exception of those functions that the Clash API defines to work on 'Vec' from+"Clash.Sized.Vector" instead of on lists as the Haskell Prelude does. In+addition, for the 'Clash.Class.Parity.odd' and 'Clash.Class.Parity.even'+functions a type class called 'Clash.Class.Parity.Parity' is available at+"Clash.Class.Parity".+-}  -- | Create a 'register' function for product-type like signals (e.g. -- @('Signal' a, 'Signal' b)@)@@ -252,6 +272,3 @@       then (0,   not i) -- reset state and oscillate output       else (s+1, i)     -- hold current output {-# INLINEABLE oscillate #-}--undefined :: HasCallStack => a-undefined = errorX "undefined"
src/Clash/Explicit/RAM.hs view
@@ -1,22 +1,17 @@ {-| Copyright  :  (C) 2015-2016, University of Twente,                   2017     , Google Inc.-                  2019     , Myrtle Software Ltd+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  RAM primitives with a combinational read port. -} -{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}  {-# LANGUAGE Trustworthy #-} @@ -35,23 +30,27 @@   ) where -import Data.Maybe            (fromJust, isJust)+import Data.Maybe            (isJust) import GHC.Stack             (HasCallStack, withFrozenCallStack) import GHC.TypeLits          (KnownNat)-import qualified Data.Vector as V+import qualified Data.Sequence as Seq -import Clash.Explicit.Signal-  (unbundle, unsafeSynchronizer, KnownDomain, enable)+import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Explicit.Signal (unbundle, KnownDomain, andEnable) import Clash.Promoted.Nat    (SNat (..), snatToNum, pow2SNat)-import Clash.Signal.Internal (Clock (..), Signal (..), Enable, fromEnable)+import Clash.Signal.Internal+  (Clock (..), ClockAB (..), Signal (..), Enable, fromEnable, clockTicks)+import Clash.Signal.Internal.Ambiguous (clockPeriod) import Clash.Sized.Unsigned  (Unsigned)-import Clash.XException      (errorX, maybeIsX)+import Clash.XException+  (defaultSeqX, deepErrorX, fromJustX, maybeIsX, NFDataX)  -- | Create a RAM with space for 2^@n@ elements ----- * __NB__: Initial content of the RAM is 'undefined'+-- * __NB__: Initial content of the RAM is /undefined/, reading it will throw an+-- 'Clash.XException.XException' ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a -- RAM.@@ -61,19 +60,20 @@      , HasCallStack      , KnownDomain wdom      , KnownDomain rdom+     , NFDataX a      )   => Clock wdom-  -- ^ 'Clock' to which to synchronize the write port of the RAM+   -- ^ 'Clock' to which the write port of the RAM is synchronized   -> Clock rdom-  -- ^ 'Clock' to which the read address signal, @r@, is synchronized+   -- ^ 'Clock' to which the read address signal, @r@, is synchronized   -> Enable wdom-  -- ^ Global enable+  -- ^ 'Enable' line for the write port   -> Signal rdom (Unsigned n)   -- ^ Read address @r@   -> Signal wdom (Maybe (Unsigned n, a))   -- ^ (write address @w@, value to write)   -> Signal rdom a-  -- ^ Value of the @RAM@ at address @r@+  -- ^ Value of the RAM at address @r@ asyncRamPow2 = \wclk rclk en rd wrM -> withFrozenCallStack   (asyncRam wclk rclk en (pow2SNat (SNat @n)) rd wrM) {-# INLINE asyncRamPow2 #-}@@ -81,24 +81,27 @@  -- | Create a RAM with space for @n@ elements ----- * __NB__: Initial content of the RAM is 'undefined'+-- * __NB__: Initial content of the RAM is /undefined/, reading it will throw an+-- 'Clash.XException.XException' ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Explicit.BlockRam#usingrams" for more information on how to use a -- RAM. asyncRam   :: ( Enum addr+     , NFDataX addr      , HasCallStack      , KnownDomain wdom      , KnownDomain rdom+     , NFDataX a      )   => Clock wdom-   -- ^ 'Clock' to which to synchronize the write port of the RAM+   -- ^ 'Clock' to which the write port of the RAM is synchronized   -> Clock rdom-   -- ^ 'Clock' to which the read address signal, @r@, is synchronized to+   -- ^ 'Clock' to which the read address signal, @r@, is synchronized   -> Enable wdom-  -- ^ Global enable+  -- ^ 'Enable' line for the write port   -> SNat n   -- ^ Size @n@ of the RAM   -> Signal rdom addr@@ -106,25 +109,28 @@   -> Signal wdom (Maybe (addr, a))   -- ^ (write address @w@, value to write)   -> Signal rdom a-   -- ^ Value of the @RAM@ at address @r@+   -- ^ Value of the RAM at address @r@ asyncRam = \wclk rclk gen sz rd wrM ->   let en       = isJust <$> wrM-      (wr,din) = unbundle (fromJust <$> wrM)+      (wr,din) = unbundle (fromJustX <$> wrM)   in  withFrozenCallStack       (asyncRam# wclk rclk gen sz (fromEnum <$> rd) en (fromEnum <$> wr) din) {-# INLINE asyncRam #-}  -- | RAM primitive asyncRam#-  :: ( HasCallStack+  :: forall wdom rdom n a+   . ( HasCallStack      , KnownDomain wdom-     , KnownDomain rdom )+     , KnownDomain rdom+     , NFDataX a+     )   => Clock wdom-  -- ^ 'Clock' to which to synchronize the write port of the RAM+   -- ^ 'Clock' to which the write port of the RAM is synchronized   -> Clock rdom-  -- ^ 'Clock' to which the read address signal, @r@, is synchronized+   -- ^ 'Clock' to which the read address signal, @r@, is synchronized   -> Enable wdom-  -- ^ Global enable+  -- ^ 'Enable' line for the write port   -> SNat n   -- ^ Size @n@ of the RAM   -> Signal rdom Int@@ -136,30 +142,75 @@   -> Signal wdom a   -- ^ Value to write (at address @w@)   -> Signal rdom a-  -- ^ Value of the @RAM@ at address @r@-asyncRam# wclk rclk en sz rd we wr din =-    unsafeSynchronizer wclk rclk dout+  -- ^ Value of the RAM at address @r@+asyncRam# wClk rClk en sz rd we wr din = dout   where-    rd'  = unsafeSynchronizer rclk wclk rd-    ramI = V.replicate-              (snatToNum sz)-              (withFrozenCallStack (errorX "asyncRam#: initial value undefined"))-    en' = fromEnable (enable en we)-    dout = go ramI rd' en' wr din+    ramI = Seq.replicate+              szI+              (withFrozenCallStack (deepErrorX "asyncRam: initial value undefined"))+    en0 = fromEnable (andEnable en we)+    dout = if rPeriod == wPeriod+           then goSingle ramI rd en0 wr din+           else go (clockTicks wClk rClk) ramI rd en0 wr din+    rPeriod = snatToNum (clockPeriod @rdom) :: Int+    wPeriod = snatToNum (clockPeriod @wdom) :: Int+    szI = snatToNum sz :: Int -    go :: V.Vector a -> Signal wdom Int -> Signal wdom Bool-       -> Signal wdom Int -> Signal wdom a -> Signal wdom a-    go !ram (r :- rs) (e :- es) (w :- ws) (d :- ds) =-      let ram' = upd ram e (fromEnum w) d-          o    = ram V.! r-      in  o :- go ram' rs es ws ds+    goSingle :: Seq.Seq a -> Signal rdom Int -> Signal wdom Bool+       -> Signal wdom Int -> Signal wdom a -> Signal rdom a+    goSingle !ram (r :- rs) ~(e :- es) wt@(~(w :- ws)) dt@(~(d :- ds)) =+      let ram0 = upd ram e w d+          o    = ram `safeAt` r+      in  o :- (o `defaultSeqX` wt `seq` dt `seq` goSingle ram0 rs es ws ds) -    upd ram we' waddr d = case maybeIsX we' of+    go :: [ClockAB] -> Seq.Seq a -> Signal rdom Int -> Signal wdom Bool+       -> Signal wdom Int -> Signal wdom a -> Signal rdom a+    go [] _ _ _ _ _ = error "asyncRam#.go: `ticks` should have been an infinite list"+    go (tick:ticks) !ram rt@(~(r :- rs)) et@(~(e :- es)) wt@(~(w :- ws)) dt@(~(d :- ds)) =+      case tick of+        ClockA  ->+          let ram0 = upd ram e w d+          in  wt `seq` dt `seq` go ticks ram0 rt es ws ds+        ClockB  ->+          let o = ram `safeAt` r+          in  o :- (o `defaultSeqX` go ticks ram rs et wt dt)+        ClockAB ->+          go (ClockB:ClockA:ticks) ram rt et wt dt++    upd ram we0 waddr d = case maybeIsX we0 of       Nothing -> case maybeIsX waddr of-        Nothing -> V.map (const (seq waddr d)) ram-        Just wa -> ram V.// [(wa,d)]+        Nothing -> -- Put the XException from `waddr` as the value in all+                   -- locations of `ram`.+                   seq waddr d <$ ram+        Just wa -> -- Put the XException from `we` as the value at address+                   -- `waddr`.+                   safeUpdate wa (seq we0 d) ram       Just True -> case maybeIsX waddr of-        Nothing -> V.map (const (seq waddr d)) ram-        Just wa -> ram V.// [(wa,d)]+        Nothing -> -- Put the XException from `waddr` as the value in all+                   -- locations of `ram`.+                   seq waddr d <$ ram+        Just wa -> d `defaultSeqX` safeUpdate wa d ram       _ -> ram-{-# NOINLINE asyncRam# #-}++    safeAt :: HasCallStack => Seq.Seq a -> Int -> a+    safeAt s i =+      if (0 <= i) && (i < szI) then+        Seq.index s i+      else+        withFrozenCallStack+          (deepErrorX ("asyncRam: read address " ++ show i +++                   " not in range [0.." ++ show szI ++ ")"))+    {-# INLINE safeAt #-}++    safeUpdate :: HasCallStack => Int -> a -> Seq.Seq a ->  Seq.Seq a+    safeUpdate i a s =+      if (0 <= i) && (i < szI) then+        Seq.update i a s+      else+        let d = withFrozenCallStack+                  (deepErrorX ("asyncRam: write address " ++ show i +++                           " not in range [0.." ++ show szI ++ ")"))+        in d <$ s+    {-# INLINE safeUpdate #-}+{-# OPAQUE asyncRam# #-}+{-# ANN asyncRam# hasBlackBox #-}
src/Clash/Explicit/ROM.hs view
@@ -1,19 +1,18 @@ {-| Copyright  :  (C) 2015-2016, University of Twente,                   2017     , Google Inc.-                  2019     , Myrtle Software Ltd+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  ROMs -} -{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}  {-# LANGUAGE Trustworthy #-} @@ -29,11 +28,13 @@   ) where -import Data.Array             ((!),listArray)+import Data.Array             (listArray)+import Data.Array.Base        (unsafeAt) import GHC.Stack              (withFrozenCallStack) import GHC.TypeLits           (KnownNat, type (^)) import Prelude hiding         (length) +import Clash.Annotations.Primitive (hasBlackBox) import Clash.Signal.Internal   (Clock (..), KnownDomain, Signal (..), Enable, fromEnable) import Clash.Sized.Unsigned   (Unsigned)@@ -43,52 +44,61 @@ -- | A ROM with a synchronous read port, with space for 2^@n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException' ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Explicit.BlockRam#usingrams"--- for ideas on how to use ROMs and RAMs+-- for ideas on how to use ROMs and RAMs.+-- * A large 'Vec' for the content may be too inefficient, depending on how it+-- is constructed. See 'Clash.Explicit.ROM.File.romFilePow2' and+-- 'Clash.Explicit.ROM.Blob.romBlobPow2' for different approaches that scale+-- well. romPow2   :: (KnownDomain dom, KnownNat n, NFDataX a)   => Clock dom   -- ^ 'Clock' to synchronize to   -> Enable dom-  -- ^ Global enable+  -- ^ 'Enable' line   -> Vec (2^n) a   -- ^ ROM content   ---  -- __NB:__ must be a constant+  -- __NB__: __MUST__ be a constant   -> Signal dom (Unsigned n)-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> Signal dom a-  -- ^ The value of the ROM at address @rd@+  -- ^ The value of the ROM at address @r@ from the previous clock cycle romPow2 = rom {-# INLINE romPow2 #-}  -- | A ROM with a synchronous read port, with space for @n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException' ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Explicit.BlockRam#usingrams"--- for ideas on how to use ROMs and RAMs+-- for ideas on how to use ROMs and RAMs.+-- * A large 'Vec' for the content may be too inefficient, depending on how it+-- is constructed. See 'Clash.Explicit.ROM.File.romFile' and+-- 'Clash.Explicit.ROM.Blob.romBlob' for different approaches that scale well. rom   :: (KnownDomain dom, KnownNat n, NFDataX a, Enum addr)   => Clock dom   -- ^ 'Clock' to synchronize to   -> Enable dom-  -- ^ Global enable+  -- ^ 'Enable' line   -> Vec n a-  -- ^ ROM content+  -- ^ ROM content, also determines the size, @n@, of the ROM   ---  -- __NB:__ must be a constant+  -- __NB__: __MUST__ be a constant   -> Signal dom addr-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> Signal dom a-  -- ^ The value of the ROM at address @rd@ from the previous clock cycle+  -- ^ The value of the ROM at address @r@ from the previous clock cycle rom = \clk en content rd -> rom# clk en content (fromEnum <$> rd) {-# INLINE rom #-} @@ -99,25 +109,36 @@   => Clock dom   -- ^ 'Clock' to synchronize to   -> Enable dom-  -- ^ Global enable+  -- ^ 'Enable' line   -> Vec n a-  -- ^ ROM content+  -- ^ ROM content, also determines the size, @n@, of the ROM   ---  -- __NB:__ must be a constant+  -- __NB__: __MUST__ be a constant   -> Signal dom Int   -- ^ Read address @rd@   -> Signal dom a   -- ^ The value of the ROM at address @rd@ from the previous clock cycle-rom# _ en content rd =+rom# !_ en content =   go     (withFrozenCallStack (deepErrorX "rom: initial value undefined"))     (fromEnable en)-    ((arr !) <$> rd)  where   szI = length content   arr = listArray (0,szI-1) (toList content) -  go o (e :- es) as@(~(x :- xs)) =+  go o (e :- es) rd@(~(r :- rs)) =+    let o1 = if e then safeAt r else o     -- See [Note: register strictness annotations]-    o `seqX` o :- (as `seq` if e then go x es xs else go o es xs)-{-# NOINLINE rom# #-}+    in  o `seqX` o :- (rd `seq` go o1 es rs)++  safeAt :: Int -> a+  safeAt i =+    if (0 <= i) && (i < szI) then+      unsafeAt arr i+    else+      withFrozenCallStack+        (deepErrorX ("rom: address " ++ show i +++                     " not in range [0.." ++ show szI ++ ")"))+  {-# INLINE safeAt #-}+{-# OPAQUE rom# #-}+{-# ANN rom# hasBlackBox #-}
+ src/Clash/Explicit/ROM/Blob.hs view
@@ -0,0 +1,154 @@+{-|+Copyright  :  (C) 2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++= Efficient bundling of ROM content with the compiled code++Leveraging Template Haskell, the content for the ROM components in this module+is stored alongside the compiled Haskell code. It covers use cases where passing+the initial content as a 'Clash.Sized.Vector.Vec' turns out to be+problematically slow.++The data is stored efficiently, with very little overhead (worst-case 7%, often+no overhead at all).++Unlike "Clash.Explicit.ROM.File", "Clash.Explicit.ROM.Blob" generates+practically the same HDL as "Clash.Explicit.ROM" and is compatible with all+tools consuming the generated HDL.+-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Explicit.ROM.Blob+  ( -- * ROMs defined by a 'MemBlob'+    romBlob+  , romBlobPow2+    -- * Creating and inspecting 'MemBlob'+  , MemBlob+  , createMemBlob+  , memBlobTH+  , unpackMemBlob+    -- * Internal+  , romBlob#+  ) where++import Data.Array (listArray)+import Data.Array.Base (unsafeAt)+import GHC.Stack (withFrozenCallStack)+import GHC.TypeLits (KnownNat, type (^))++import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Explicit.BlockRam.Blob (createMemBlob, memBlobTH)+import Clash.Explicit.BlockRam.Internal (MemBlob(..), unpackMemBlob)+import Clash.Promoted.Nat (natToNum)+import Clash.Signal.Internal+  (Clock (..), KnownDomain, Signal (..), Enable, fromEnable)+import Clash.Sized.Internal.BitVector (BitVector)+import Clash.Sized.Internal.Unsigned (Unsigned)+import Clash.XException (deepErrorX, seqX)++-- | A ROM with a synchronous read port, with space for @n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException'+--+-- === See also:+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" and+-- "Clash.Explicit.BlockRam#usingrams" for ideas on how to use ROMs and RAMs.+romBlob+  :: forall dom addr m n+   . ( KnownDomain dom+     , Enum addr+     )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> MemBlob n m+  -- ^ ROM content, also determines the size, @n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ The value of the ROM at address @r@ from the previous clock cycle+romBlob = \clk en content rd -> romBlob# clk en content (fromEnum <$> rd)+{-# INLINE romBlob #-}++-- | A ROM with a synchronous read port, with space for 2^@n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException'+--+-- === See also:+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" and+-- "Clash.Explicit.BlockRam#usingrams" for ideas on how to use ROMs and RAMs.+romBlobPow2+  :: forall dom m n+   . ( KnownDomain dom+     , KnownNat n+     )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> MemBlob (2^n) m+  -- ^ ROM content, also determines the size, 2^@n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom (Unsigned n)+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ The value of the ROM at address @r@ from the previous clock cycle+romBlobPow2 = romBlob+{-# INLINE romBlobPow2 #-}++-- | ROM primitive+romBlob#+  :: forall dom m n+   . KnownDomain dom+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> MemBlob n m+  -- ^ ROM content, also determines the size, @n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom Int+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ The value of the ROM at address @r@ from the previous clock cycle+romBlob# !_ en content@MemBlob{} =+  go+    (withFrozenCallStack (deepErrorX "romBlob: initial value undefined"))+    (fromEnable en)+ where+  szI = natToNum @n @Int+  arr = listArray (0,szI-1) $ unpackMemBlob content++  go o (e :- es) rd@(~(r :- rs)) =+    let o1 = if e then safeAt r else o+    -- See [Note: register strictness annotations]+    in  o `seqX` o :- (rd `seq` go o1 es rs)++  safeAt :: Int -> BitVector m+  safeAt i =+    if (0 <= i) && (i < szI) then+      unsafeAt arr i+    else+      withFrozenCallStack+        (deepErrorX ("romBlob: address " ++ show i +++                     " not in range [0.." ++ show szI ++ ")"))+  {-# INLINE safeAt #-}+{-# OPAQUE romBlob# #-}+{-# ANN romBlob# hasBlackBox #-}
src/Clash/Explicit/ROM/File.hs view
@@ -1,44 +1,48 @@ {-| Copyright  :  (C) 2015-2016, University of Twente,-                  2017     , Google Inc.-                  2019     , Myrtle Software Ltd.+                  2017     , Google Inc.,+                  2019     , Myrtle Software Ltd.,+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  = Initializing a ROM with a data file #usingromfiles#  ROMs initialized with a data file. The BNF grammar for this data file is simple: -@-FILE = LINE+-LINE = BIT+-BIT  = '0'-     | '1'-@+> FILE = LINE++> LINE = BIT++> BIT  = '0'+>      | '1'  Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@.-For example, a data file @memory.bin@ containing the 9-bit unsigned number+For example, a data file @memory.bin@ containing the 9-bit unsigned numbers @7@ to @13@ looks like: +> 000000111+> 000001000+> 000001001+> 000001010+> 000001011+> 000001100+> 000001101++Such a file can be produced with 'memFile':+ @-000000111-000001000-000001001-000001010-000001011-000001100-000001101+writeFile "memory.bin" (memFile Nothing [7 :: Unsigned 9 .. 13]) @ -We can instantiate a synchronous ROM using the content of the above file like+We can instantiate a synchronous ROM using the contents of the file above like so:  @-f-  :: Clock  dom+f :: KnownDomain dom+  => Clock  dom+  -> Enable dom   -> Signal dom (Unsigned 3)   -> Signal dom (Unsigned 9)-f clk rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' clk d7 \"memory.bin\" rd+f clk en rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' clk en d7 \"memory.bin\" rd @  And see that it works as expected:@@ -53,11 +57,11 @@ number, and a 3-bit signed number:  @-g-  :: Clock  dom Regular+g :: KnownDomain dom+  => Clock  dom   -> Signal dom (Unsigned 3)   -> Signal dom (Unsigned 6,Signed 3)-g clk rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' clk d7 \"memory.bin\" rd+g clk en rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' clk en d7 \"memory.bin\" rd @  And then we would see:@@ -69,12 +73,8 @@ @ -} -{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}  {-# LANGUAGE Unsafe #-} @@ -84,16 +84,20 @@   ( -- * Synchronous ROM synchronized to an arbitrary clock     romFile   , romFilePow2+    -- * Producing files+  , memFile     -- * Internal   , romFile#   ) where -import Data.Array                   (listArray,(!))+import Data.Array                   (listArray)+import Data.Array.Base              (unsafeAt) import GHC.TypeLits                 (KnownNat) import System.IO.Unsafe             (unsafePerformIO)----import Clash.Explicit.BlockRam.File (initMem)++import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Explicit.BlockRam.File (initMem, memFile) import Clash.Promoted.Nat           (SNat (..), pow2SNat, snatToNum) import Clash.Sized.BitVector        (BitVector) import Clash.Explicit.Signal        (Clock, Enable, Signal, KnownDomain, delay)@@ -104,64 +108,69 @@ -- | A ROM with a synchronous read port, with space for 2^@n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException' -- * __NB__: This function might not work for specific combinations of -- code-generation backends and hardware targets. Please check the support table -- below: -----     @---                    | VHDL     | Verilog  | SystemVerilog |---     ===============+==========+==========+===============+---     Altera/Quartus | Broken   | Works    | Works         |---     Xilinx/ISE     | Works    | Works    | Works         |---     ASIC           | Untested | Untested | Untested      |---     ===============+==========+==========+===============+---     @+-- +----------------+----------+----------+---------------++-- |                | VHDL     | Verilog  | SystemVerilog |+-- +================+==========+==========+===============++-- | Altera/Quartus | Broken   | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | Xilinx/ISE     | Works    | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | ASIC           | Untested | Untested | Untested      |+-- +----------------+----------+----------+---------------+ ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Explicit.ROM.File#usingromfiles" for more information on how -- to instantiate a ROM with the contents of a data file.--- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your--- own data files.+-- * See 'memFile' for creating a data file with Clash.+-- * See "Clash.Sized.Fixed#creatingdatafiles" for more ideas on how to create+-- your own data files. romFilePow2   :: forall dom  n m    . (KnownNat m, KnownNat n, KnownDomain dom)   => Clock dom   -- ^ 'Clock' to synchronize to   -> Enable dom-  -- ^ Global enable+  -- ^ 'Enable' line   -> FilePath-  -- ^ File describing the content of-  -- the ROM+  -- ^ File describing the content of the ROM   -> Signal dom (Unsigned n)-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> Signal dom (BitVector m)-  -- ^ The value of the ROM at address @rd@ from the previous clock cycle-romFilePow2 = \clk en -> romFile clk en (pow2SNat (SNat @ n))+  -- ^ The value of the ROM at address @r@ from the previous clock cycle+romFilePow2 = \clk en -> romFile clk en (pow2SNat (SNat @n)) {-# INLINE romFilePow2 #-}  -- | A ROM with a synchronous read port, with space for @n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException' -- * __NB__: This function might not work for specific combinations of -- code-generation backends and hardware targets. Please check the support table -- below: -----     @---                    | VHDL     | Verilog  | SystemVerilog |---     ===============+==========+==========+===============+---     Altera/Quartus | Broken   | Works    | Works         |---     Xilinx/ISE     | Works    | Works    | Works         |---     ASIC           | Untested | Untested | Untested      |---     ===============+==========+==========+===============+---     @+-- +----------------+----------+----------+---------------++-- |                | VHDL     | Verilog  | SystemVerilog |+-- +================+==========+==========+===============++-- | Altera/Quartus | Broken   | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | Xilinx/ISE     | Works    | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | ASIC           | Untested | Untested | Untested      |+-- +----------------+----------+----------+---------------+ ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Explicit.ROM.File#usingromfiles" for more information on how -- to instantiate a ROM with the contents of a data file.+-- * See 'memFile' for creating a data file with Clash. -- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your -- own data files. romFile@@ -169,37 +178,49 @@   => Clock dom   -- ^ 'Clock' to synchronize to   -> Enable dom-  -- ^ Global enable+  -- ^ 'Enable' line   -> SNat n   -- ^ Size of the ROM   -> FilePath   -- ^ File describing the content of the ROM   -> Signal dom addr-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> Signal dom (BitVector m)-  -- ^ The value of the ROM at address @rd@ from the previous clock cycle+  -- ^ The value of the ROM at address @r@ from the previous clock cycle romFile = \clk en sz file rd -> romFile# clk en sz file (fromEnum <$> rd) {-# INLINE romFile #-}  -- | romFile primitive romFile#-  :: (KnownNat m, KnownDomain dom)+  :: forall m dom n+   . (KnownNat m, KnownDomain dom)   => Clock dom   -- ^ 'Clock' to synchronize to   -> Enable dom-  -- ^ Global enable+  -- ^ 'Enable' line   -> SNat n   -- ^ Size of the ROM   -> FilePath   -- ^ File describing the content of the ROM   -> Signal dom Int-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> Signal dom (BitVector m)-  -- ^ The value of the ROM at address @rd@ from the previous clock cycle+  -- ^ The value of the ROM at address @r@ from the previous clock cycle romFile# clk en sz file rd =-  delay clk en (deepErrorX "First value of romFile is undefined") ((content !) <$> rd)+  delay clk en (deepErrorX "First value of romFile is undefined")+        (safeAt <$> rd)  where   mem     = unsafePerformIO (initMem file)   content = listArray (0,szI-1) mem   szI     = snatToNum sz-{-# NOINLINE romFile# #-}++  safeAt :: Int -> BitVector m+  safeAt i =+    if (0 <= i) && (i < szI) then+      unsafeAt content i+    else+      deepErrorX ("romFile: address " ++ show i +++                  " not in range [0.." ++ show szI ++ ")")+  {-# INLINE safeAt #-}+{-# OPAQUE romFile# #-}+{-# ANN romFile# hasBlackBox #-}
+ src/Clash/Explicit/Reset.hs view
@@ -0,0 +1,570 @@+{-|+Copyright  :  (C) 2020-2026, QBayLogic B.V.,+                  2022-2023, Google LLC+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Utilities to deal with resets.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}++module Clash.Explicit.Reset+  ( -- Defined in this module+    resetSynchronizer+  , resetGlitchFilter+  , resetGlitchFilterWithReset+  , unsafeResetGlitchFilter+  , registerSyncReset+  , holdReset+  , convertReset+  , noReset+  , andReset, unsafeAndReset+  , orReset, unsafeOrReset++    -- Re-exports+  , Reset+  , resetGen+  , resetGenN+  , resetKind+  , systemResetGen+  , unsafeToReset+  , unsafeFromReset+  , unsafeToActiveHigh+  , unsafeToActiveLow+  , unsafeFromActiveHigh+  , unsafeFromActiveLow++  -- * Deprecated+  , unsafeFromHighPolarity+  , unsafeFromLowPolarity+  , unsafeToHighPolarity+  , unsafeToLowPolarity+  ) where++import           Data.Type.Equality ((:~:)(Refl))++import           Clash.Class.Num (satSucc, SaturationMode(SatBound))+import           Clash.Explicit.Signal+import           Clash.Explicit.Synchronizer (dualFlipFlopSynchronizer)+import           Clash.Promoted.Nat+import           Clash.Signal.Internal+import           Clash.Sized.Index (Index)++import           GHC.Stack (HasCallStack)+import           GHC.TypeLits (type (+), type (<=))++{- $setup+>>> import Clash.Explicit.Prelude+-}++-- | A reset that is never asserted+noReset :: KnownDomain dom => Reset dom+noReset = unsafeFromActiveHigh (pure False)++-- | Output reset will be asserted when either one of the input resets is+-- asserted+orReset ::+  forall dom .+  HasSynchronousReset dom =>+  Reset dom ->+  Reset dom ->+  Reset dom+orReset = unsafeOrReset++-- | Output reset will be asserted when either one of the input resets is+-- asserted. This function is considered unsafe because it can be used on+-- domains with components with asynchronous resets, where use of this function+-- can introduce glitches triggering a reset.+unsafeOrReset :: forall dom. KnownDomain dom => Reset dom -> Reset dom -> Reset dom+unsafeOrReset (unsafeFromReset -> rst0) (unsafeFromReset -> rst1) =+  unsafeToReset $+    case resetPolarity @dom of+      SActiveHigh -> rst0 .||. rst1+      SActiveLow  -> rst0 .&&. rst1++-- | Output reset will be asserted when both input resets are asserted+andReset ::+  forall dom .+  HasSynchronousReset dom =>+  Reset dom ->+  Reset dom ->+  Reset dom+andReset = unsafeAndReset++-- | Output reset will be asserted when both input resets are asserted. This+-- function is considered unsafe because it can be used on domains with+-- components with asynchronous resets, where use of this function can introduce+-- glitches triggering a reset.+unsafeAndReset :: forall dom. KnownDomain dom => Reset dom -> Reset dom -> Reset dom+unsafeAndReset (unsafeFromReset -> rst0) (unsafeFromReset -> rst1) =+  unsafeToReset $+    case resetPolarity @dom of+      SActiveHigh -> rst0 .&&. rst1+      SActiveLow  -> rst0 .||. rst1++-- | The resetSynchronizer will synchronize an incoming reset according to+-- whether the domain is synchronous or asynchronous.+--+-- For asynchronous resets this synchronizer ensures the reset will only+-- be de-asserted synchronously but it can still be asserted asynchronously.+-- The reset assert is immediate, but reset de-assertion is delayed by two+-- cycles.+--+-- Normally, asynchronous resets can be both asynchronously asserted and+-- de-asserted. Asynchronous de-assertion can induce meta-stability in the+-- component which is being reset. To ensure this doesn't happen,+-- 'resetSynchronizer' ensures that de-assertion of a reset happens+-- synchronously. Assertion of the reset remains asynchronous.+--+-- Note that asynchronous assertion does not induce meta-stability in the+-- component whose reset is asserted. However, when a component \"A\" in another+-- clock or reset domain depends on the value of a component \"B\" being+-- reset, then asynchronous assertion of the reset of component \"B"\ can induce+-- meta-stability in component \"A\". To prevent this from happening you need+-- to use a proper synchronizer, for example one of the synchronizers in+-- "Clash.Explicit.Synchronizer".+--+-- For synchronous resets this function ensures that the reset is asserted and+-- de-asserted synchronously. Both the assertion and de-assertion of the reset+-- are delayed by two cycles.+--+-- === __Example 1__+-- The circuit below detects a rising bit (i.e., a transition from 0 to 1) in a+-- given argument. It takes a reset that is not synchronized to any of the other+-- incoming signals and synchronizes it using 'resetSynchronizer'.+--+-- @+-- topEntity+--   :: Clock  System+--   -> Reset  System+--   -> Signal System Bit+--   -> Signal System (BitVector 8)+-- topEntity clk asyncRst key1 =+--   withClockResetEnable clk rst enableGen leds+--  where+--   rst   = 'resetSynchronizer' clk asyncRst+--   key1R = isRising 1 key1+--   leds  = mealy blinkerT (1, False, 0) key1R+-- @+--+-- === __Example 2__+-- Similar to /Example 1/ this circuit detects a rising bit (i.e., a transition+-- from 0 to 1) in a given argument. It takes a clock that is not stable yet and+-- a reset signal that is not synchronized to any other signals. It stabilizes+-- the clock and then synchronizes the reset signal.+--+--+-- Note that the function 'Clash.Intel.ClockGen.altpllSync' provides this+-- functionality in a convenient form, obviating the need for+-- @resetSynchronizer@ for this use case.+--+-- @+-- topEntity+--   :: Clock  System+--   -> Reset  System+--   -> Signal System Bit+--   -> Signal System (BitVector 8)+-- topEntity clk rst key1 =+--     let  (pllOut,pllStable) = unsafeAltpll clk rst+--          rstSync            = 'resetSynchronizer' pllOut (unsafeFromActiveLow pllStable)+--     in   exposeClockResetEnable leds pllOut rstSync enableGen+--   where+--     key1R  = isRising 1 key1+--     leds   = mealy blinkerT (1, False, 0) key1R+-- @+--+-- === __Implementation details__+-- 'resetSynchronizer' implements the following circuit for asynchronous domains:+--+-- >                                   rst+-- >   --------------------------------------++-- >                       |                 |+-- >                  +----v----+       +----v----++-- >     deasserted   |         |       |         |+-- >   --------------->         +------->         +-------->+-- >                  |         |       |         |+-- >              +---|>        |   +---|>        |+-- >              |   |         |   |   |         |+-- >              |   +---------+   |   +---------++-- >      clk     |                 |+-- >   -----------------------------++--+-- This corresponds to figure 3d at <https://www.embedded.com/asynchronous-reset-synchronization-and-distribution-challenges-and-solutions/>+--+-- For synchronous domains two sequential dflipflops are used:+--+-- >                  +---------+       +---------++-- >     rst          |         |       |         |+-- >   --------------->         +------->         +-------->+-- >                  |         |       |         |+-- >              +---|>        |   +---|>        |+-- >              |   |         |   |   |         |+-- >              |   +---------+   |   +---------++-- >      clk     |                 |+-- >   -----------------------------++--+resetSynchronizer+  :: forall dom+   . KnownDomain dom+  => Clock dom+  -> Reset dom+  -> Reset dom+resetSynchronizer clk rst = rstOut+ where+  isActiveHigh = case resetPolarity @dom of { SActiveHigh -> True; _ -> False }+  rstOut =+    case (resetKind @dom) of+      SAsynchronous -> unsafeToReset+                         $ register clk rst enableGen isActiveHigh+                         $ register clk rst enableGen isActiveHigh+                         $ pure (not isActiveHigh)+      SSynchronous  -> unsafeToReset+                         $ delay clk enableGen isActiveHigh+                         $ delay clk enableGen isActiveHigh+                         $ unsafeFromReset rst++-- | Filter glitches from reset signals by only triggering a reset after it has+-- been asserted for /glitchlessPeriod/ cycles. Similarly, it will stay+-- asserted until a /glitchlessPeriod/ number of deasserted cycles have been+-- observed.+--+-- This circuit can only be used on platforms supporting initial values. This+-- restriction can be worked around by using 'unsafeResetGlitchFilter' but this+-- is not recommended.+--+-- On platforms without initial values, you should instead use+-- 'resetGlitchFilterWithReset' with an additional power-on reset, or+-- 'holdReset' if filtering is only needed on deassertion.+--+-- At power-on, the reset will be asserted. If the filtered reset input remains+-- unasserted, the output reset will deassert after /glitchlessPeriod/ clock+-- cycles.+--+-- If @resetGlitchFilter@ is used in a domain with asynchronous resets+-- ('Asynchronous'), @resetGlitchFilter@ will first synchronize the reset input+-- with 'dualFlipFlopSynchronizer'.+--+-- === __Example 1__+-- >>> let sampleResetN n = sampleN n . unsafeToActiveHigh+-- >>> let resetFromList = unsafeFromActiveHigh . fromList+-- >>> let rst = resetFromList [True, True, False, False, True, False, False, True, True, False, True, True]+-- >>> sampleResetN 12 (resetGlitchFilter d2 (clockGen @XilinxSystem) rst)+-- [True,True,True,True,False,False,False,False,False,True,True,True]+resetGlitchFilter+  :: forall dom glitchlessPeriod+   . ( HasCallStack+     , HasDefinedInitialValues dom+     , 1 <= glitchlessPeriod+     )+  => SNat glitchlessPeriod+  -- ^ Consider a reset signal to be properly asserted after having seen the+  -- reset asserted for /glitchlessPeriod/ cycles straight.+  -> Clock dom+  -> Reset dom+  -> Reset dom+resetGlitchFilter = unsafeResetGlitchFilter+{-# INLINE resetGlitchFilter #-}++-- | Filter glitches from reset signals by only triggering a reset after it has+-- been asserted for /glitchlessPeriod/ cycles. Similarly, it will stay+-- asserted until a /glitchlessPeriod/ number of deasserted cycles have been+-- observed.+--+-- On platforms without initial values ('Unknown'), 'resetGlitchFilter' cannot+-- be used and you should use 'resetGlitchFilterWithReset' with an additional+-- power-on reset, or 'holdReset' if filtering is only needed on deassertion.+--+-- @unsafeResetGlitchFilter@ allows breaking the requirement of initial values,+-- but by doing so it is possible that the design starts up with a period of up+-- to /2 * glitchlessPeriod/ clock cycles where the reset output is unasserted+-- (or longer in the case of glitches on the filtered reset input). This can+-- cause a number of problems. The outputs\/tri-states of the design might+-- output random things, including coherent but incorrect streams of data. This+-- might have grave repercussions in the design's environment (sending network+-- packets, overwriting non-volatile memory, in extreme cases destroying+-- controlled equipment or causing harm to living beings, ...).+--+-- Without initial values, the synthesized result of @unsafeResetGlitchFilter@+-- eventually correctly outputs a filtered version of the reset input. However,+-- in simulation, it will indefinitely output an undefined value. This happens+-- both in Clash simulation and in HDL simulation. Therefore, simulation should+-- not include the @unsafeResetGlitchFilter@.+--+-- If @unsafeResetGlitchFilter@ is used in a domain with asynchronous resets+-- ('Asynchronous'), @unsafeResetGlitchFilter@ will first synchronize the reset+-- input with 'dualFlipFlopSynchronizer'.+unsafeResetGlitchFilter+  :: forall dom glitchlessPeriod+   . ( HasCallStack+     , KnownDomain dom+     , 1 <= glitchlessPeriod+     )+  => SNat glitchlessPeriod+  -- ^ Consider a reset signal to be properly asserted after having seen the+  -- reset asserted for /glitchlessPeriod/ cycles straight.+  -> Clock dom+  -> Reset dom+  -> Reset dom+unsafeResetGlitchFilter glitchlessPeriod clk =+  resetGlitchFilter# glitchlessPeriod reg dffSync+ where+  reg = delay clk enableGen+  dffSync = dualFlipFlopSynchronizer clk clk noReset enableGen+{-# INLINE unsafeResetGlitchFilter #-}++-- | Filter glitches from reset signals by only triggering a reset after it has+-- been asserted for /glitchlessPeriod/ cycles. Similarly, it will stay+-- asserted until a /glitchlessPeriod/ number of deasserted cycles have been+-- observed.+--+-- Compared to 'resetGlitchFilter', this function adds an additional power-on+-- reset input. As soon as the power-on reset asserts, the reset output will+-- assert, and after the power-on reset deasserts, the reset output will stay+-- asserted for another /glitchlessPeriod/ clock cycles. This is identical+-- behavior to 'holdReset' where it concerns the power-on reset, and differs+-- from the filtered reset, which will only cause an assertion after+-- /glitchlessPeriod/ cycles.+--+-- If @resetGlitchFilterWithReset@ is used in a domain with asynchronous resets+-- ('Asynchronous'), @resetGlitchFilterWithReset@ will first synchronize the+-- reset input with 'dualFlipFlopSynchronizer'.+resetGlitchFilterWithReset+  :: forall dom glitchlessPeriod+   . ( HasCallStack+     , KnownDomain dom+     , 1 <= glitchlessPeriod+     )+  => SNat glitchlessPeriod+  -- ^ Consider a reset signal to be properly asserted after having seen the+  -- reset asserted for /glitchlessPeriod/ cycles straight.+  -> Clock dom+  -> Reset dom+  -- ^ The power-on reset for the glitch filter itself+  -> Reset dom+  -- ^ The reset that will be filtered+  -> Reset dom+resetGlitchFilterWithReset glitchlessPeriod clk ownRst =+  resetGlitchFilter# glitchlessPeriod reg dffSync+ where+  reg = register clk ownRst enableGen+  dffSync = dualFlipFlopSynchronizer clk clk ownRst enableGen+{-# INLINE resetGlitchFilterWithReset #-}++resetGlitchFilter#+  :: forall dom glitchlessPeriod state+   . ( HasCallStack+     , KnownDomain dom+     , 1 <= glitchlessPeriod+     , state ~ (Bool, Index glitchlessPeriod)+     )+  => SNat glitchlessPeriod+  -> (   state+      -> Signal dom state+      -> Signal dom state+     )+  -> (   Bool+      -> Signal dom Bool+      -> Signal dom Bool+     )+  -> Reset dom+  -> Reset dom+resetGlitchFilter# SNat reg dffSync rstIn0 =+  let s' = go <$> s <*> rstIn2+      s  = reg (asserted, 0) s'+  in unsafeToReset $ fst <$> s+ where+  rstIn1 = unsafeFromReset rstIn0+  rstIn2 =+    case resetKind @dom of+      SAsynchronous -> dffSync asserted rstIn1+      SSynchronous -> rstIn1++  go :: state -> Bool -> state+  go (state, count) reset+    | reset == state    = (state,     0)+    | count == maxBound = (not state, 0)+    | otherwise         = (state,     count + 1)++  asserted :: Bool+  asserted =+    case resetPolarity @dom of+      SActiveHigh -> True+      SActiveLow -> False++-- | Register a synchronous reset signal.+--+--   `registerSyncReset` delays an incoming reset by one clock cycle using a+--   register. This can be useful to break combinational paths involving reset+--   logic.+--+--   __NB__: This is not a synchronizer. Use `resetSynchronizer` to synchronize+--   a reset.+--+--   Example:+--+-- >>> let sampleReset = sampleN 7 . unsafeToActiveHigh+-- >>> let rst = unsafeFromActiveHigh (fromList [False, True, False, False, True, False])+-- >>> sampleReset (registerSyncReset @XilinxSystem clockGen rst enableGen True)+-- [True,False,True,False,False,True,False]+--+registerSyncReset+  :: forall dom+   . KnownDomain dom+  => HasSynchronousReset dom+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> Bool+  -- ^ Initial assert value of the register if supported by the domain.+  --   If True the initial reset value is asserted.+  --   If False the initial reset value is de-asserted.+  -> Reset dom+registerSyncReset clk (unsafeFromReset -> rst) en initialValue = unsafeToReset outRst+  where+    intialRst :: Bool+    intialRst =+      case resetPolarity @dom of+        SActiveHigh -> initialValue+        SActiveLow -> not initialValue+    outRst = delay clk en intialRst rst++-- | Hold reset for a number of cycles relative to an incoming reset+-- signal.+--+-- __NB__: The output of this function is combinational for @n > 0@ on domains+-- with a synchronous reset. Use `registerSyncReset` to add an output register if+-- desired.+--+-- Example:+--+-- >>> let sampleReset = sampleN 8 . unsafeToActiveHigh+-- >>> sampleReset (holdReset @System clockGen enableGen (SNat @2) (resetGenN (SNat @3)))+-- [True,True,True,True,True,False,False,False]+--+-- 'holdReset' holds the reset for an additional 2 clock cycles for a total+-- of 5 clock cycles where the reset is asserted. 'holdReset' also works on+-- intermediate assertions of the reset signal:+--+-- >>> let rst = fromList [True, False, False, False, True, False, False, False]+-- >>> sampleReset (holdReset @System clockGen enableGen (SNat @2) (unsafeFromActiveHigh rst))+-- [True,True,True,False,True,True,True,False]+--+holdReset+  :: forall dom n+   . KnownDomain dom+  => Clock dom+  -> Enable dom+  -- ^ Global enable+  -> SNat n+  -- ^ Hold for /n/ cycles, counting from the moment the incoming reset+  -- signal becomes deasserted.+  -> Reset dom+  -- ^ Reset to extend+  -> Reset dom+holdReset clk en n rst = case resetKind @dom of+  SSynchronous -> holdResetSync clk en n rst+  SAsynchronous -> holdResetAsync clk en n rst++holdResetSync+  :: forall dom n+   . KnownDomain dom+  => DomainResetKind dom ~ 'Synchronous+  => Clock dom+  -> Enable dom+  -- ^ Global enable+  -> SNat n+  -- ^ Hold for /n/ cycles+  -> Reset dom+  -- ^ Reset to extend+  -> Reset dom+holdResetSync clk en sn@SNat rst = rstOut+ where+  rstOut = case snatToInteger sn of+    0 -> rst+    1 -> orReset rst (unsafeToReset regReset)+      where+        isActiveHigh = case resetPolarity @dom of { SActiveHigh -> True; _ -> False }+        regReset = register clk rst en isActiveHigh (pure (not isActiveHigh))+    _ -> orReset rst (unsafeToReset rawRst)+      where+        counter :: Signal dom (Index (n + 1))+        counter = register clk rst en 0 (satSucc SatBound <$> counter)+        rawRst :: Signal dom Bool+        rawRst = case resetPolarity @dom of+          SActiveHigh -> (/=maxBound) <$> counter+          SActiveLow -> (==maxBound) <$> counter++holdResetAsync+  :: forall dom n+   . KnownDomain dom+  => DomainResetKind dom ~ 'Asynchronous+  => Clock dom+  -> Enable dom+  -- ^ Global enable+  -> SNat n+  -- ^ Hold for /n/ cycles+  -> Reset dom+  -- ^ Reset to extend+  -> Reset dom+holdResetAsync clk en sn@SNat rst = rstOut+ where+  isActiveHigh = case resetPolarity @dom of { SActiveHigh -> True; _ -> False }+  rstOut = case toUNat sn of+    UZero -> rst+    USucc UZero -> unsafeToReset (register clk rst en isActiveHigh (pure (not isActiveHigh)))+    USucc (USucc _) -> unsafeToReset (register clk rst en isActiveHigh rawRst)+      where+        counter :: Signal dom (Index n)+        counter = register clk rst en 0 (satSucc SatBound <$> counter)+        rawRst :: Signal dom Bool+        rawRst = case resetPolarity @dom of+          SActiveHigh -> (/=maxBound) <$> counter+          SActiveLow -> (==maxBound) <$> counter+++-- | Convert between different types of reset, adding a synchronizer when+-- the domains are not the same. See 'resetSynchronizer' for further details+-- about reset synchronization.+--+-- If @domA@ has 'Synchronous' resets, a flip-flop is inserted in @domA@ to+-- filter glitches. This adds one @domA@ clock cycle delay.+convertReset+  :: forall domA domB+   . ( KnownDomain domA+     , KnownDomain domB+     )+  => Clock domA+  -> Clock domB+  -> Reset domA+  -> Reset domB+convertReset clkA clkB rstA0 = rstB1+ where+  rstA1 = unsafeFromReset rstA0+  rstA2 =+    case (resetPolarity @domA, resetPolarity @domB) of+      (SActiveLow, SActiveLow)   -> rstA1+      (SActiveHigh, SActiveHigh) -> rstA1+      _                          -> not <$> rstA1+  rstA3 =+    case resetKind @domA of+      SSynchronous -> delay clkA enableGen assertedA rstA2+      _            -> rstA2+  rstB0 = unsafeToReset $ unsafeSynchronizer clkA clkB rstA3+  rstB1 =+    case (sameDomain @domA @domB) of+      Just Refl -> rstA0+      Nothing   -> resetSynchronizer clkB rstB0+  assertedA :: Bool+  assertedA =+    case resetPolarity @domA of+      SActiveHigh -> True+      SActiveLow  -> False
src/Clash/Explicit/Signal.hs view
@@ -1,9 +1,11 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2016-2019, Myrtle Software,-                  2017     , Google Inc.+                  2017-2022, Google Inc.+                  2020     , Ben Gamari,+                  2021-2025, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  Clash has synchronous 'Signal's in the form of: @@ -25,7 +27,7 @@   { _name:: 'GHC.TypeLits.Symbol'   -- ^ Domain name   , _period :: 'GHC.TypeLits.Nat'-  -- ^ Clock period in /ps/+  -- ^ Clock period in \/ps\/   , _edge :: 'ActiveEdge'   -- ^ Active edge of the clock   , _reset :: 'ResetKind'@@ -44,8 +46,8 @@ configured as follows:  @-instance KnownDomain "System" where-  type KnownConf "System" = 'DomainConfiguration "System" 10000 'Rising 'Asynchronous 'Defined 'ActiveHigh+instance KnownDomain 'System' where+  type KnownConf 'System' = 'DomainConfiguration 'System' 10000 'Rising 'Asynchronous 'Defined 'ActiveHigh   knownDomain = 'SDomainConfiguration' SSymbol SNat 'SRising' 'SAsynchronous' 'SDefined' 'SActiveHigh' @ @@ -129,28 +131,27 @@  -} -{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE ExplicitNamespaces    #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MagicHash             #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE ViewPatterns          #-}+{-# LANGUAGE RankNTypes #-}  {-# LANGUAGE Trustworthy #-}  {-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-} {-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -Wno-orphans #-}  {-# OPTIONS_HADDOCK show-extensions #-}  module Clash.Explicit.Signal   ( -- * Synchronous signal     Signal+  , BiSignalIn+  , BiSignalOut+  , BiSignalDefault(..)     -- * Domain   , Domain   , KnownDomain(..)@@ -171,6 +172,24 @@   , DomainResetKind   , DomainInitBehavior   , DomainResetPolarity+    -- *** Convenience types #conveniencetypes#+    -- $conveniencetypes++  , HasSynchronousReset+  , HasAsynchronousReset+  , HasDefinedInitialValues+  -- **** Time representations+  , Seconds+  , Milliseconds+  , Microseconds+  , Nanoseconds+  , Picoseconds+  -- **** Time conversions+  , DomainToHz+  , HzToPeriod+  , PeriodToHz+  , PeriodToCycles+  , ClockDivider     -- ** Default domains   , System   , XilinxSystem@@ -189,31 +208,28 @@   , initBehavior   , resetPolarity     -- ** Enabling-  , Enable(..)+  , Enable   , toEnable   , fromEnable   , enableGen     -- * Clock   , Clock-  , freqCalc  -- DEPRECATED+  , DiffClock   , periodToHz   , hzToPeriod     -- ** Synchronization primitive   , unsafeSynchronizer   , veryUnsafeSynchronizer     -- * Reset-  , Reset(..)+  , Reset   , unsafeToReset   , unsafeFromReset-  , unsafeToHighPolarity-  , unsafeToLowPolarity-  , unsafeFromHighPolarity-  , unsafeFromLowPolarity-  , convertReset-  , resetSynchronizer-  , holdReset+  , unsafeToActiveHigh+  , unsafeToActiveLow+  , unsafeFromActiveHigh+  , unsafeFromActiveLow     -- * Basic circuit functions-  , enable+  , andEnable   , dflipflop   , delay   , delayMaybe@@ -221,6 +237,9 @@   , register   , regMaybe   , regEn+  , regEnN+  , mux+  , apEn     -- * Simulation and testbench functions   , clockGen   , resetGen@@ -231,17 +250,24 @@   , (.&&.), (.||.)     -- * Product/Signal isomorphism   , Bundle(..)+  , EmptyTuple(..)+  , TaggedEmptyTuple(..)     -- * Simulation functions (not synthesizable)   , simulate   , simulateB   , simulateWithReset   , simulateWithResetN+  , runUntil     -- ** lazy versions   , simulate_lazy   , simulateB_lazy+    -- ** Automaton+  , signalAutomaton     -- * List \<-\> Signal conversion (not synthesizable)   , sample   , sampleN+  , sampleWithReset+  , sampleWithResetN   , fromList   , fromListWithReset     -- ** lazy versions@@ -252,28 +278,46 @@   , testFor     -- * Type classes     -- ** 'Eq'-like-  , (.==.), (./=.)+  , (.==.), (.==), (==.), (./=.), (./=), (/=.)     -- ** 'Ord'-like-  , (.<.), (.<=.), (.>=.), (.>.)+  , (.<.), (.<), (<.), (.<=.), (.<=), (<=.), (.>=.), (.>=), (>=.), (.>.), (.>), (>.)+    -- * Bisignal functions+  , veryUnsafeToBiSignalIn+  , readFromBiSignal+  , writeToBiSignal+  , mergeBiSignalOuts++  -- * Deprecated+  , unsafeFromHighPolarity+  , unsafeFromLowPolarity+  , unsafeToHighPolarity+  , unsafeToLowPolarity   ) where -import           Data.Maybe                     (isJust, fromJust)-import           GHC.TypeLits                   (type (+), type (<=))+import           Data.Bifunctor                 (bimap)+import           Data.Int                       (Int64)+import           Data.List                      (uncons)+import           Data.Maybe                     (isJust)+import           GHC.TypeLits                   (type (<=))  import           Clash.Annotations.Primitive    (hasBlackBox)-import           Clash.Class.Num                (satSucc, SaturationMode(SatBound))-import           Clash.Promoted.Nat             (SNat(..), snatToNum)-import           Clash.Signal.Bundle            (Bundle (..))+import           Clash.Promoted.Nat+  (SNat(..), SNatLE(..), compareSNat, leToPlus, snatToNum)+import           Clash.Signal.Bundle+  (Bundle (..), EmptyTuple(..), TaggedEmptyTuple(..), vecBundle#)+import           Clash.Signal.BiSignal import           Clash.Signal.Internal import           Clash.Signal.Internal.Ambiguous   (knownVDomain, clockPeriod, activeEdge, resetKind, initBehavior, resetPolarity)-import           Clash.Sized.Index              (Index)-import           Clash.XException               (NFDataX, deepErrorX)+import qualified Clash.Sized.Vector+import           Clash.XException+  (NFDataX, deepErrorX, fromJustX, seqX, ShowX(..))  {- $setup >>> :set -XDataKinds -XTypeApplications -XFlexibleInstances -XMultiParamTypeClasses -XTypeFamilies >>> :set -fno-warn-deprecations+>>> :m -Prelude >>> import Clash.Explicit.Prelude >>> import Clash.Promoted.Nat (SNat(..)) >>> import qualified Data.List as L@@ -314,18 +358,50 @@  -} +{- $conveniencetypes++==== Simplifying++If you want to write part of your Clash design as domain-polymorphic functions,+it can be practical to define a design-wide constraint synonym that captures the+characteristics of the clock domains of the design. Such a constraint synonym+can be used as a constraint on all domain-polymorphic functions in the design,+regardless of whether they actually need the constraints from this section.++@+type DesignDomain dom =+  ( 'HasSynchronousReset' dom+  , 'HasDefinedInitialValues' dom+  )++type DesignDomainHidden dom =+  ( DesignDomain dom+  , t'Clash.Signal.HiddenClockResetEnable' dom+  )++myFunc ::+  DesignDomainHidden dom =>+  'Signal' dom [...]+@++This way, you don't have to think about which constraints the function you're+writing has exactly, and the constraint is succinct.+-}+ -- **Clock -- | Clock generator for the 'System' clock domain. ----- __NB__: should only be used for simulation, and __not__ for the /testBench/--- function. For the /testBench/ function, used 'tbSystemClockGen'+-- __NB__: Should only be used for simulation, and __not__ for the /testBench/+-- function. For the /testBench/ function, used 'Clash.Explicit.Testbench.tbSystemClockGen' systemClockGen   :: Clock System systemClockGen = clockGen --- | Reset generator for the 'System' clock domain.+-- | Reset generator for use in simulation, for the 'System' clock domain.+-- Asserts the reset for a single cycle. ----- __NB__: should only be used for simulation or the \testBench\ function.+-- __NB__: While this can be used in the @testBench@ function, it cannot be+-- synthesized to hardware. -- -- === __Example__ --@@ -338,73 +414,13 @@ --   where --     testInput      = pure ((1 :> 2 :> 3 :> Nil) :> (4 :> 5 :> 6 :> Nil) :> Nil) --     expectedOutput = outputVerifier' ((1:>2:>3:>4:>5:>6:>Nil):>Nil)---     done           = exposeClockResetEnable (expectedOutput (topEntity <$> testInput)) clk rst+--     done           = exposeClockResetEnable (expectedOutput (topEntity \<$\> testInput)) clk rst --     clk            = tbSystemClockGen (not <\$\> done) --     rst            = 'systemResetGen' -- @ systemResetGen ::Reset System systemResetGen = resetGen --- | Normally, asynchronous resets can be both asynchronously asserted and--- de-asserted. Asynchronous de-assertion can induce meta-stability in the--- component which is being reset. To ensure this doesn't happen,--- 'resetSynchronizer' ensures that de-assertion of a reset happens--- synchronously. Assertion of the reset remains asynchronous.------ Note that asynchronous assertion does not induce meta-stability in the--- component whose reset is asserted. However, when a component \"A\" in another--- clock or reset domain depends on the value of a component \"B\" being--- reset, then asynchronous assertion of the reset of component \"B"\ can induce--- meta-stability in component \"A\". To prevent this from happening you need--- to use a proper synchronizer, for example one of the synchronizers in--- "Clash.Explicit.Synchronizer"------ === __Example__------ @--- topEntity---   :: Clock  System---   -> Reset  System---   -> Signal System Bit---   -> Signal System (BitVector 8)--- topEntity clk rst key1 =---     let  (pllOut,pllStable) = altpll (SSymbol @"altpll50") clk rst---          rstSync            = 'resetSynchronizer' pllOut (unsafeToHighPolarity pllStable)---     in   exposeClockResetEnable leds pllOut rstSync---   where---     key1R  = isRising 1 key1---     leds   = mealy blinkerT (1, False, 0) key1R--- @-resetSynchronizer-  :: forall dom-   . KnownDomain dom-  => Clock dom-  -> Reset dom-  -> Enable dom-  -> Reset dom-resetSynchronizer clk rst en =-  case resetKind @dom of-    SAsynchronous ->-      let isActiveHigh = case resetPolarity @dom of { SActiveHigh -> True; _ -> False }-          r1 = register clk rst en isActiveHigh (pure (not isActiveHigh))-          r2 = register clk rst en isActiveHigh r1-       in unsafeToReset r2-    SSynchronous ->-      -- Reset is already synchronous, nothing to do!-      rst---- | Calculate the period, in __ps__, given a frequency in __Hz__------ i.e. to calculate the clock period for a circuit to run at 240 MHz we get------ >>> freqCalc 240e6--- 4167------ __NB__: This function is /not/ synthesizable-freqCalc :: Double -> Integer-freqCalc = toInteger . hzToPeriod-{-# DEPRECATED freqCalc "Use 'hzToPeriod' instead." #-}- -- ** Synchronization primitive -- | The 'unsafeSynchronizer' function is a primitive that must be used to -- connect one clock domain to the other, and will be synthesized to a (bundle@@ -493,60 +509,80 @@   -- ^ 'Clock' of the outgoing signal   -> Signal dom1 a   -> Signal dom2 a-unsafeSynchronizer _clk1 _clk2 =-  veryUnsafeSynchronizer-    (snatToNum (clockPeriod @dom1))-    (snatToNum (clockPeriod @dom2))-{-# INLINE unsafeSynchronizer #-}+unsafeSynchronizer clk1 clk2 =+  go (clockTicks clk1 clk2)+ where+  go :: [ClockAB] -> Signal dom1 a -> Signal dom2 a+  go [] _ = error "unsafeSynchronizer.go: `ticks` should have been an infinite list"+  go (tick:ticks) ass@(~(a :- as)) =+    case tick of+      ClockA  -> go ticks as+      ClockB  -> a :- go ticks ass+      ClockAB -> go (ClockB:ClockA:ticks) ass+{-# OPAQUE unsafeSynchronizer #-}+{-# ANN unsafeSynchronizer hasBlackBox #-}  -- | Same as 'unsafeSynchronizer', but with manually supplied clock periods. -- -- Note: this unsafeSynchronizer is defined to be consistent with the vhdl and verilog -- implementations however as only synchronous signals are represented in Clash this--- cannot be done precisely and can lead to odd behaviour. For example,+-- cannot be done precisely and can lead to odd behavior. For example,+-- -- @--- sample $ unsafeSynchronizer @Dom2 @Dom7 . unsafeSynchronizer @Dom7 @Dom2 $ fromList [0..10]+-- sample $ unsafeSynchronizer \@Dom2 \@Dom7 . unsafeSynchronizer \@Dom7 \@Dom2 $ fromList [0..10] -- > [0,4,4,4,7,7,7,7,11,11,11.. -- @+-- -- is quite different from the identity,+-- -- @ -- sample $ fromList [0..10] -- > [0,1,2,3,4,5,6,7,8,9,10.. -- @+-- -- with values appearing from the "future". veryUnsafeSynchronizer-  :: Int-  -- ^ Period of clock belonging to 'dom1'-  -> Int-  -- ^ Period of clock belonging to 'dom2'+  :: Either Int (Signal dom1 Int)+  -- ^ Period of clock belonging to @dom1@. 'Left' if clock has a static period,+  -- 'Right' if periods are dynamic.+  -> Either Int (Signal dom2 Int)+  -- ^ Period of clock belonging to @dom2@. 'Left' if clock has a static period,+  -- 'Right' if periods are dynamic.   -> Signal dom1 a   -> Signal dom2 a-veryUnsafeSynchronizer t1 t2-  -- this case is just an optimisation for when the periods are the same-  | t1 == t2 = same--  | otherwise = go 0--  where-  same :: Signal dom1 a -> Signal dom2 a-  same (s :- ss) = s :- same ss+veryUnsafeSynchronizer t1e t2e =+  go (clockTicksEither (toInt64 t1e) (toInt64 t2e))+ where+  -- TODO: deprecate 'veryUnsafeSynchronizer' or change its type signature to use+  --       'Int64' to prevent issues down the road if/when we switch to represent+  --       clock periods using femtoseconds.+  toInt64 ::+    forall dom .+    Either Int (Signal dom Int) ->+    Either Int64 (Signal dom Int64)+  toInt64 = bimap fromIntegral (fmap fromIntegral) -  go :: Int -> Signal dom1 a -> Signal dom2 a-  go relativeTime (a :- s)-    | relativeTime <= 0 = a :- go (relativeTime + t2) (a :- s)-    | otherwise = go (relativeTime - t1) s-{-# NOINLINE veryUnsafeSynchronizer #-}+  go :: [ClockAB] -> Signal dom1 a -> Signal dom2 a+  go [] _ = error "veryUnsafeSynchronizer.go: `ticks` should have been an infinite list"+  go (tick:ticks) ass@(~(a :- as)) =+    case tick of+      ClockA  -> go ticks as+      ClockB  -> a :- go ticks ass+      ClockAB -> go (ClockB:ClockA:ticks) ass+{-# OPAQUE veryUnsafeSynchronizer #-} {-# ANN veryUnsafeSynchronizer hasBlackBox #-}  -- * Basic circuit functions --- | Merge enable signal with signal of bools-enable+-- | Merge enable signal with signal of bools by applying the boolean AND+-- operation.+andEnable   :: Enable dom   -> Signal dom Bool   -> Enable dom-enable e0 e1 =+andEnable e0 e1 =   toEnable (fromEnable e0 .&&. e1)+{-# INLINE andEnable #-}  -- | Special version of 'delay' that doesn't take enable signals of any kind. -- Initial value will be undefined.@@ -556,8 +592,8 @@   => Clock dom   -> Signal dom a   -> Signal dom a-dflipflop clk i =-  delay+dflipflop = \clk i ->+  delay#     clk     (toEnable (pure True))     (deepErrorX "First value of dflipflop undefined")@@ -600,8 +636,8 @@   -- ^ Initial value   -> Signal dom (Maybe a)   -> Signal dom a-delayMaybe clk gen dflt i =-  delayEn clk gen dflt (isJust <$> i) (fromJust <$> i)+delayMaybe = \clk gen dflt i ->+  delay# clk (andEnable gen (isJust <$> i)) dflt (fromJustX <$> i) {-# INLINE delayMaybe #-}  -- | Version of 'delay' that only updates when its third argument is asserted.@@ -623,11 +659,11 @@   -- ^ Enable   -> Signal dom a   -> Signal dom a-delayEn clk gen dflt en i =-  delay clk (enable gen en) dflt i+delayEn = \clk gen dflt en i ->+  delay# clk (andEnable gen en) dflt i {-# INLINE delayEn #-} --- | \"@'register' clk rst i s@\" delays the values in 'Signal' /s/ for one+-- | \"@'register' clk rst en i s@\" delays the values in 'Signal' /s/ for one -- cycle, and sets the value to @i@ the moment the reset becomes 'False'. -- -- >>> sampleN 5 (register systemClockGen resetGen enableGen 8 (fromList [1,1,2,3,4]))@@ -646,7 +682,7 @@   -- will also be the initial value.   -> Signal dom a   -> Signal dom a-register clk rst gen initial i =+register = \clk rst gen initial i ->   register# clk rst gen initial initial i {-# INLINE register #-} @@ -685,8 +721,8 @@   -- will also be the initial value.   -> Signal dom (Maybe a)   -> Signal dom a-regMaybe clk rst en initial iM =-  register clk rst (enable en (fmap isJust iM)) initial (fmap fromJust iM)+regMaybe = \clk rst en initial iM ->+  register# clk rst (andEnable en (fmap isJust iM)) initial initial (fmap fromJustX iM) {-# INLINE regMaybe #-}  -- | Version of 'register' that only updates its content when its fourth@@ -720,10 +756,35 @@   -- ^ Enable signal   -> Signal dom a   -> Signal dom a-regEn clk rst gen initial en i =-  register clk rst (enable gen en) initial i+regEn = \clk rst gen initial en i ->+  register# clk rst (andEnable gen en) initial initial i {-# INLINE regEn #-} +-- | A chain of 'regEn's.+regEnN ::+  forall dom a n.+  (KnownDomain dom, NFDataX a) =>+  -- | Clock+  Clock dom ->+  -- | Reset, 'regEnN' outputs the reset value when the reset value is active+  Reset dom ->+  -- | Global enable+  Enable dom ->+  -- | The number of stored elements+  SNat n ->+  -- | Initial content of all elements in the chain.+  a ->+  -- | The "push next input" indicator+  Signal dom Bool ->+  Signal dom a ->+  Signal dom a+regEnN clk rst gen n@SNat initial en = case compareSNat n (SNat @0) of+  SNatLE -> id+  SNatGT -> leToPlus @1 @n+          $ Clash.Sized.Vector.last+          . Clash.Sized.Vector.generate n (regEn clk rst gen initial en)+{-# INLINE regEnN #-}+ -- * Simulation functions  -- | Same as 'simulate', but with the reset line asserted for /n/ cycles. Similar@@ -757,7 +818,7 @@   clk = clockGen   en  = enableGen   out = simulate (f clk rst en) inp-{-# NOINLINE simulateWithReset #-}+{-# OPAQUE simulateWithReset #-}  -- | Same as 'simulateWithReset', but only sample the first /Int/ output values. simulateWithResetN@@ -819,43 +880,9 @@ simulateB_lazy f = simulate_lazy (bundle . f . unbundle)  --- | Hold reset for a number of cycles relative to an incoming reset signal.------ Example:------ >>> let sampleWithReset = sampleN 8 . unsafeToHighPolarity--- >>> sampleWithReset (holdReset @System clockGen enableGen (SNat @2) (resetGenN (SNat @3)))--- [True,True,True,True,True,False,False,False]------ 'holdReset' holds the reset for an additional 2 clock cycles for a total--- of 5 clock cycles where the reset is asserted. 'holdReset' also works on--- intermediate assertions of the reset signal:------ >>> let rst = fromList [True, False, False, False, True, False, False, False]--- >>> sampleWithReset (holdReset @System clockGen enableGen (SNat @2) (unsafeFromHighPolarity rst))--- [True,True,True,False,True,True,True,False]----holdReset-  :: forall dom n-   . KnownDomain dom-  => Clock dom-  -> Enable dom-  -- ^ Global enable-  -> SNat n-  -- ^ Hold for /n/ cycles, counting from the moment the incoming reset-  -- signal becomes deasserted.-  -> Reset dom-  -- ^ Reset to extend-  -> Reset dom-holdReset clk en SNat rst =-  unsafeFromHighPolarity ((/=maxBound) <$> counter)- where-  counter :: Signal dom (Index (n+1))-  counter = register clk rst en 0 (satSucc SatBound <$> counter)- -- | Like 'fromList', but resets on reset and has a defined reset value. ----- >>> let rst = unsafeFromHighPolarity (fromList [True, True, False, False, True, False])+-- >>> let rst = unsafeFromActiveHigh (fromList [True, True, False, False, True, False]) -- >>> let res = fromListWithReset @System rst Nothing [Just 'a', Just 'b', Just 'c'] -- >>> sampleN 6 res -- [Nothing,Nothing,Just 'a',Just 'b',Nothing,Just 'a']@@ -869,32 +896,140 @@   -> [a]   -> Signal dom a fromListWithReset rst resetValue vals =-  go (unsafeToHighPolarity rst) vals+  go (unsafeToActiveHigh rst) vals  where   go (r :- rs) _ | r = resetValue :- go rs vals   go (_ :- rs) [] = deepErrorX "fromListWithReset: input ran out" :- go rs []   go (_ :- rs) (a : as) = a :- go rs as --- | Convert between different types of reset, adding a synchronizer in case--- it needs to convert from an asynchronous to a synchronous reset.-convertReset-  :: forall domA domB-   . ( KnownDomain domA-     , KnownDomain domB-     )-  => Clock domA-  -> Clock domB-  -> Reset domA-  -> Reset domB-convertReset clkA clkB (unsafeToHighPolarity -> rstA0) =-  unsafeFromHighPolarity rstA2+-- | Get a list of samples from a 'Signal', while asserting the reset line+-- for /n/ clock cycles. 'sampleWithReset' does not return the first /n/ cycles,+-- i.e., when the reset is asserted.+--+-- __NB__: This function is not synthesizable+sampleWithReset+  :: forall dom a m+   . ( KnownDomain dom+     , NFDataX a+     , 1 <= m )+  => SNat m+  -- ^ Number of cycles to assert the reset+  -> (KnownDomain dom+      => Clock dom+      -> Reset dom+      -> Enable dom+      -> Signal dom a)+  -- ^ 'Signal' to sample+  -> [a]+sampleWithReset nReset f0 =+  let f1 = f0 clockGen (resetGenN @dom nReset) enableGen in+  drop (snatToNum nReset) (sample f1)+{-# OPAQUE sampleWithReset #-}++-- | Get a fine list of /m/ samples from a 'Signal', while asserting the reset line+-- for /n/ clock cycles. 'sampleWithReset' does not return the first /n/ cycles,+-- i.e., while the reset is asserted.+--+-- __NB__: This function is not synthesizable+sampleWithResetN+  :: forall dom a m+   . ( KnownDomain dom+     , NFDataX a+     , 1 <= m )+  => SNat m+  -- ^ Number of cycles to assert the reset+  -> Int+  -- ^ Number of samples to produce+  -> (KnownDomain dom+      => Clock dom+      -> Reset dom+      -> Enable dom+      -> Signal dom a)+  -- ^ 'Signal' to sample+  -> [a]+sampleWithResetN nReset nSamples f =+  take nSamples (sampleWithReset nReset f)++-- | Simulate a component until it matches a condition+--+-- It prints a message of the form+--+-- > Signal sampled for N cycles until value X+--+-- __NB__: This function is not synthesizable+--+-- === __Example with test bench__+--+-- A common usage is with a test bench using+-- 'Clash.Explicit.Testbench.outputVerifier'.+--+-- __NB__: Since this uses 'Clash.Explicit.Testbench.assert', when using+-- @clashi@, read the note at "Clash.Explicit.Testbench#assert-clashi".+--+-- @+-- import Clash.Prelude+-- import Clash.Explicit.Testbench+--+-- topEntity+--   :: 'Signal' 'System' Int+--   -> 'Signal' 'System' Int+-- topEntity = id+--+-- testBench+--   :: 'Signal' 'System' Bool+-- testBench = done+--  where+--   testInput = 'Clash.Explicit.Testbench.stimuliGenerator' clk rst $('Clash.Sized.Vector.listToVecTH' [1 :: Int .. 10])+--   expectedOutput =+--     'Clash.Explicit.Testbench.outputVerifier'' clk rst $('Clash.Sized.Vector.listToVecTH' $ [1 :: Int .. 9] '<>' [42])+--   done = expectedOutput $ topEntity testInput+--   clk = 'Clash.Explicit.Testbench.tbSystemClockGen' (not \<$\> done)+--   rst = 'systemResetGen'+-- @+--+-- @+-- > runUntil id testBench+--+--+-- cycle(\<Clock: System\>): 10, outputVerifier+-- expected value: 42, not equal to actual value: 10+-- Signal sampled for 11 cycles until value True+-- @+--+-- When you need to verify multiple test benches, the following invocations come+-- in handy:+--+-- @+-- > 'mapM_' (runUntil id) [ testBenchA, testBenchB ]+-- @+--+-- or when the test benches are in different clock domains:+--+-- @+-- testBenchA :: Signal DomA Bool+-- testBenchB :: Signal DomB Bool+-- @+--+-- @+-- > 'sequence_' [ runUntil id testBenchA, runUntil id testBenchB ]+-- @+runUntil+  :: forall dom a+   . (KnownDomain dom, NFDataX a, ShowX a)+  => (a -> Bool)+  -- ^ Condition checking function, should return @True@ to finish run+  -> Signal dom a+  -- ^ 'Signal' we want to sample for the condition+  -> IO ()+runUntil check s =+  -- Ensure invocations of 'trace' are printed before the result message+  value `seqX`+  putStrLn msg  where-  rstA1 = unsafeSynchronizer clkA clkB rstA0-  rstA2 =-    case (resetKind @domA, resetKind @domB) of-      (SSynchronous,  SSynchronous)  -> rstA1-      (SAsynchronous, SAsynchronous) -> rstA1-      (SSynchronous,  SAsynchronous) -> rstA1-      (SAsynchronous, SSynchronous) ->-        delay clkB enableGen True $-          delay clkB enableGen True rstA1+  msg =   ("Signal sampled for " ++) . shows nSamples+        . (" cycles until value " ++) $ showX value+  (before, after) = break check $ sample s+  nSamples = length before+  value = maybe (error "impossible") fst (uncons after)++{-# RULES "sequenceAVecSignal" Clash.Sized.Vector.traverse# (\x -> x) = vecBundle# #-}
src/Clash/Explicit/Signal/Delayed.hs view
@@ -2,17 +2,17 @@ Copyright  :  (C) 2013-2016, University of Twente,                   2017     , Google Inc.                   2019     , Myrtle Software Ltd+                  2021     , LUMI GUIDE FIETSDETECTIE B.V. License    :  BSD2 (see the file LICENSE) Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  {-# LANGUAGE Trustworthy #-} @@ -24,6 +24,9 @@     -- * Delay-annotated synchronous signals   , delayed   , delayedI+  , delayN+  , delayI+  , delayedFold   , feedback     -- * Signal \<-\> DSignal conversion   , fromSignal@@ -35,22 +38,26 @@     -- * Experimental   , unsafeFromSignal   , antiDelay+  , forward   ) where +import Prelude                    ((.), (<$>), (<*>), id, Num(..))+ import Data.Coerce                (coerce)-import GHC.TypeLits               (KnownNat, type (+))-import Prelude                    hiding (head, length, repeat)+import Data.Kind                  (Type)+import Data.Proxy                 (Proxy (..))+import Data.Singletons            (Apply, TyFun, type (@@))+import GHC.TypeLits               (KnownNat, Nat, type (+), type (^), type (*))  import Clash.Sized.Vector-  (Vec, head, length, repeat, shiftInAt0, singleton) import Clash.Signal.Delayed.Internal   (DSignal(..), dfromList, dfromList_lazy, fromSignal, toSignal,-   unsafeFromSignal, antiDelay, feedback)+   unsafeFromSignal, antiDelay, feedback, forward)  import Clash.Explicit.Signal-  (KnownDomain, Clock, Reset, Signal, Enable, register,  bundle, unbundle)-+  (KnownDomain, Clock, Domain, Reset, Signal, Enable, register, delay, bundle, unbundle)+import Clash.Promoted.Nat         (SNat (..), snatToInteger) import Clash.XException           (NFDataX)  {- $setup@@ -59,6 +66,9 @@ >>> import Clash.Explicit.Prelude >>> let delay3 clk rst en = delayed clk rst en (-1 :> -1 :> -1 :> Nil) >>> let delay2 clk rst en = (delayedI clk rst en :: Int -> DSignal System n Int -> DSignal System (n + 2) Int)+>>> let delayN2 = delayN d2+>>> let delayI2 = delayI :: KnownDomain dom => Int -> Enable dom -> Clock dom -> DSignal dom n Int -> DSignal dom (n + 2) Int+>>> let countingSignals = Clash.Prelude.repeat (dfromList [0..]) :: Vec 4 (DSignal dom 0 Int) >>> :{ let mac :: Clock System         -> Reset System@@ -81,7 +91,8 @@ -- -- @ -- delay3---   :: Clock dom+--   :: KnownDomain dom+--   => Clock dom --   -> Reset dom --   -> Enable dom --   -> 'DSignal' dom n Int@@ -117,7 +128,8 @@ -- -- @ -- delay2---   :: Clock dom+--   :: KnownDomain dom+--   => Clock dom --   -> Reset dom --   -> Enable dom --   -> Int@@ -152,3 +164,111 @@   -> DSignal dom n a   -> DSignal dom (n + d) a delayedI clk rst en dflt = delayed clk rst en (repeat dflt)++-- | Delay a 'DSignal' for @d@ cycles, the value at time 0..d-1 is /a/.+--+-- @+-- delayN2+--   :: 'KnownDomain' dom+--   => Int+--   -> 'Enable' dom+--   -> 'Clock' dom+--   -> 'DSignal' dom n Int+--   -> 'DSignal' dom (n + 2) Int+-- delayN2 = 'delayN' d2+-- @+--+-- >>> printX $ sampleN 6 (delayN2 (-1) enableGen systemClockGen (dfromList [1..]))+-- [-1,-1,1,2,3,4]+delayN+  :: forall dom a d n+   . ( KnownDomain dom+     , NFDataX a )+  => SNat d+  -> a+  -- ^ Initial value+  -> Enable dom+  -> Clock dom+  -> DSignal dom n a+  -> DSignal dom (n+d) a+delayN d dflt ena clk = coerce . go (snatToInteger d) . coerce @_ @(Signal dom a)+  where+    go 0 = id+    go i = delay clk ena dflt . go (i-1)++-- | Delay a 'DSignal' for @d@ cycles, where @d@ is derived from the context.+-- The value at time 0..d-1 is a default value.+--+-- @+-- delayI2+--   :: 'KnownDomain' dom+--   => Int+--   -> 'Enable' dom+--   -> 'Clock' dom+--   -> 'DSignal' dom n Int+--   -> 'DSignal' dom (n + 2) Int+-- delayI2 = 'delayI'+-- @+--+-- >>> sampleN 6 (delayI2 (-1) enableGen systemClockGen (dfromList [1..]))+-- [-1,-1,1,2,3,4]+--+-- You can also use type application to do the same:+--+-- >>> sampleN 6 (delayI @2 (-1) enableGen systemClockGen (dfromList [1..]))+-- [-1,-1,1,2,3,4]+delayI+  :: forall d n a dom+   . ( NFDataX a+     , KnownDomain dom+     , KnownNat d )+  => a+  -- ^ Initial value+  -> Enable dom+  -> Clock dom+  -> DSignal dom n a+  -> DSignal dom (n+d) a+delayI dflt = delayN (SNat :: SNat d) dflt++data DelayedFold (dom :: Domain) (n :: Nat) (delay :: Nat) (a :: Type) (f :: TyFun Nat Type) :: Type+type instance Apply (DelayedFold dom n delay a) k = DSignal dom (n + (delay*k)) a++-- | Tree fold over a 'Vec' of 'DSignal's with a combinational function,+-- and delaying @delay@ cycles after each application.+-- Values at times 0..(delay*k)-1 are set to a default.+--+-- @+-- countingSignals :: Vec 4 (DSignal dom 0 Int)+-- countingSignals = repeat (dfromList [0..])+-- @+--+-- >>> printX $ sampleN 6 (delayedFold  d1 (-1) (+) enableGen systemClockGen countingSignals)+-- [-1,-2,0,4,8,12]+--+-- >>> printX $ sampleN 8 (delayedFold d2 (-1) (*) enableGen systemClockGen countingSignals)+-- [-1,-1,1,1,0,1,16,81]+delayedFold+  :: forall dom  n delay k a+   . ( NFDataX a+     , KnownDomain dom+     , KnownNat delay+     , KnownNat k )+  => SNat delay+  -- ^ Delay applied after each step+  -> a+  -- ^ Initial value+  -> (a -> a -> a)+  -- ^ Fold operation to apply+  -> Enable dom+  -> Clock dom+  -> Vec (2^k) (DSignal dom n a)+  -- ^ Vector input of size 2^k+  -> DSignal dom (n + (delay * k)) a+  -- ^ Output Signal delayed by (delay * k)+delayedFold _ dflt op ena clk = dtfold (Proxy :: Proxy (DelayedFold dom n delay a)) id go+  where+    go :: SNat l+       -> DelayedFold dom n delay a @@ l+       -> DelayedFold dom n delay a @@ l+       -> DelayedFold dom n delay a @@ (l+1)+    go SNat x y = delayI dflt ena clk (op <$> x <*> y)
+ src/Clash/Explicit/SimIO.hs view
@@ -0,0 +1,339 @@+{-|+  Copyright   :  (C) 2019, Google Inc.,+                     2022, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  I\/O actions that are translatable to HDL+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns, MagicHash, TypeOperators, ScopedTypeVariables, FlexibleContexts #-}+{-# LANGUAGE DataKinds, GADTs, TypeApplications #-}++module Clash.Explicit.SimIO+  ( -- * I\/O environment for simulation+    mealyIO+  , SimIO+  -- * Display on stdout+  , display+  -- * End of simulation+  , finish+  -- * Mutable values+  , Reg+  , reg+  , readReg+  , writeReg+  -- * File I\/O+  , File+  , openFile+  , closeFile+  -- ** Reading and writing characters+  , getChar+  , putChar+  -- ** Reading strings+  , getLine+  -- ** Detecting the end of input+  , isEOF+    -- ** Buffering operations+  , flush+    -- ** Repositioning handles+  , seek+  , rewind+  , tell+  )+where++import Control.Monad (when)+import Data.IORef+import GHC.TypeLits+  hiding (SNat)+import Prelude hiding (getChar, putChar, getLine)+import qualified System.IO as IO+import System.IO.Unsafe++import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Promoted.Nat+import Clash.Signal.Internal+import Clash.Sized.Unsigned+import Clash.Sized.Vector (Vec (..))+import Clash.XException (seqX)++-- | Simulation-level I\/O environment; synthesizable to HDL I\/O, which in+-- itself is unlikely to be synthesisable to a digital circuit.+--+-- See 'mealyIO' as to its use.+data SimIO a = SimIO {unSimIO :: !(IO a)}+{-# ANN unSimIO hasBlackBox #-}++instance Functor SimIO where+  fmap = fmapSimIO#++fmapSimIO# :: (a -> b) -> SimIO a -> SimIO b+fmapSimIO# f (SimIO m) = SimIO (fmap f m)+{-# OPAQUE fmapSimIO# #-}+{-# ANN fmapSimIO# hasBlackBox #-}++instance Applicative SimIO where+  pure  = pureSimIO#+  (<*>) = apSimIO#++pureSimIO# :: a -> SimIO a+pureSimIO# a = SimIO (pure a)+{-# OPAQUE pureSimIO# #-}+{-# ANN pureSimIO# hasBlackBox #-}++apSimIO# :: SimIO (a -> b) -> SimIO a -> SimIO b+apSimIO# (SimIO f) (SimIO m) = SimIO (f <*> m)+{-# OPAQUE apSimIO# #-}+{-# ANN apSimIO# hasBlackBox #-}++instance Monad SimIO where+  (>>=)  = bindSimIO#++bindSimIO# :: SimIO a -> (a -> SimIO b) -> SimIO b+bindSimIO# (SimIO m) k = SimIO (m >>= (\x -> x `seqX` unSimIO (k x)))+{-# OPAQUE bindSimIO# #-}+{-# ANN bindSimIO# hasBlackBox #-}++-- | Display a string on /stdout/+display+  :: String+  -- ^ String you want to display+  -> SimIO ()+display s = SimIO (putStrLn s)+{-# OPAQUE display #-}+{-# ANN display hasBlackBox #-}++-- | Finish the simulation with an exit code+finish+  :: Integer+  -- ^ The exit code you want to return at the end of the simulation+  -> SimIO a+finish i = return (error (show i))+{-# OPAQUE finish #-}+{-# ANN finish hasBlackBox #-}++-- | Mutable reference+data Reg a = Reg !(IORef a)++-- | Create a new mutable reference with the given starting value+reg+  :: a+  -- ^ The starting value+  -> SimIO (Reg a)+reg a = SimIO (Reg <$> newIORef a)+{-# OPAQUE reg #-}+{-# ANN reg hasBlackBox #-}++-- | Read value from a mutable reference+readReg :: Reg a -> SimIO a+readReg (Reg a) = SimIO (readIORef a)+{-# OPAQUE readReg #-}+{-# ANN readReg hasBlackBox #-}++-- | Write new value to the mutable reference+writeReg+  :: Reg a+  -- ^ The mutable reference+  -> a+  -- ^ The new value+  -> SimIO ()+writeReg (Reg r) a = SimIO (writeIORef r a)+{-# OPAQUE writeReg #-}+{-# ANN writeReg hasBlackBox #-}++-- | File handle+data File = File !IO.Handle++-- | Open a file+openFile+  :: FilePath+  -- ^ File to open+  -> String+  -- ^ File mode:+  --+  -- * "r": Open for reading+  -- * "w": Create for writing+  -- * "a": Append+  -- * "r+": Open for update (reading and writing)+  -- * "w+": Create for update+  -- * "a+": Append, open or create for update at end-of-file+  -> SimIO File+openFile fp "r"   = SimIO $ fmap File (IO.openFile fp IO.ReadMode)+openFile fp "w"   = SimIO $ fmap File (IO.openFile fp IO.WriteMode)+openFile fp "a"   = SimIO $ fmap File (IO.openFile fp IO.AppendMode)+openFile fp "rb"  = SimIO $ fmap File (IO.openBinaryFile fp IO.ReadMode)+openFile fp "wb"  = SimIO $ fmap File (IO.openBinaryFile fp IO.WriteMode)+openFile fp "ab"  = SimIO $ fmap File (IO.openBinaryFile fp IO.AppendMode)+openFile fp "r+"  = SimIO $ fmap File (IO.openFile fp IO.ReadWriteMode)+openFile fp "w+"  = SimIO $ fmap File (IO.openFile fp IO.WriteMode)+openFile fp "a+"  = SimIO $ fmap File (IO.openFile fp IO.AppendMode)+openFile fp "r+b" = SimIO $ fmap File (IO.openBinaryFile fp IO.ReadWriteMode)+openFile fp "w+b" = SimIO $ fmap File (IO.openBinaryFile fp IO.WriteMode)+openFile fp "a+b" = SimIO $ fmap File (IO.openBinaryFile fp IO.AppendMode)+openFile fp "rb+" = SimIO $ fmap File (IO.openBinaryFile fp IO.ReadWriteMode)+openFile fp "wb+" = SimIO $ fmap File (IO.openBinaryFile fp IO.WriteMode)+openFile fp "ab+" = SimIO $ fmap File (IO.openBinaryFile fp IO.AppendMode)+openFile _  m     = error ("openFile unknown mode: " ++ show m)+{-# OPAQUE openFile #-}+{-# ANN openFile hasBlackBox #-}++-- | Close a file+closeFile+  :: File+  -> SimIO ()+closeFile (File fp) = SimIO (IO.hClose fp)+{-# OPAQUE closeFile #-}+{-# ANN closeFile hasBlackBox #-}++-- | Read one character from a file+getChar+  :: File+  -- ^ File to read from+  -> SimIO Char+getChar (File fp) = SimIO (IO.hGetChar fp)+{-# OPAQUE getChar #-}+{-# ANN getChar hasBlackBox #-}++-- | Insert a character into a buffer specified by the file+putChar+  :: Char+  -- ^ Character to insert+  -> File+  -- ^ Buffer to insert to+  -> SimIO ()+putChar c (File fp) = SimIO (IO.hPutChar fp c)+{-# OPAQUE putChar #-}+{-# ANN putChar hasBlackBox #-}++-- | Read one line from a file+getLine+  :: forall n+   . KnownNat n+  => File+  -- ^ File to read from+  -> Reg (Vec n (Unsigned 8))+  -- ^ Vector to store the content+  -> SimIO Int+getLine (File fp) (Reg r) = SimIO $ do+  s <- IO.hGetLine fp+  let d = snatToNum (SNat @n) - length s+  when (d < 0) (IO.hSeek fp IO.RelativeSeek (toInteger d))+  modifyIORef r (rep s)+  return 0+ where+   rep :: String -> Vec m (Unsigned 8) -> Vec m (Unsigned 8)+   rep []     vs          = vs+   rep (x:xs) (Cons _ vs) = Cons (toEnum (fromEnum x)) (rep xs vs)+   rep _      Nil         = Nil+{-# OPAQUE getLine #-}+{-# ANN getLine hasBlackBox #-}++-- | Determine whether we've reached the end of the file+isEOF+  :: File+  -- ^ File we want to inspect+  -> SimIO Bool+isEOF (File fp) = SimIO (IO.hIsEOF fp)+{-# OPAQUE isEOF #-}+{-# ANN isEOF hasBlackBox #-}++-- | Set the position of the next operation on the file+seek+  :: File+  -- ^ File to set the position for+  -> Integer+  -- ^ Position+  -> Int+  -- ^ Mode:+  --+  -- * 0: From the beginning of the file+  -- * 1: From the current position+  -- * 2: From the end of the file+  -> SimIO Int+seek (File fp) pos mode = SimIO (IO.hSeek fp (toEnum mode) pos >> return 0)+{-# OPAQUE seek #-}+{-# ANN seek hasBlackBox #-}++-- | Set the position of the next operation to the beginning of the file+rewind+  :: File+  -> SimIO Int+rewind (File fp) = SimIO (IO.hSeek fp IO.AbsoluteSeek 0 >> return 0)+{-# OPAQUE rewind #-}+{-# ANN rewind hasBlackBox #-}++-- | Returns the offset from the beginning of the file (in bytes).+tell+  :: File+  -- ^ File we want to inspect+  -> SimIO Integer+tell (File fp) = SimIO (IO.hTell fp)+{-# OPAQUE tell #-}+{-# ANN tell hasBlackBox #-}++-- | Write any buffered output to file+flush+  :: File+  -> SimIO ()+flush (File fp) = SimIO (IO.hFlush fp)+{-# OPAQUE flush #-}+{-# ANN flush hasBlackBox #-}++-- | Simulation-level I/O environment that can be synthesized to HDL-level I\/O.+-- Note that it is unlikely that the HDL-level I\/O can subsequently be+-- synthesized to a circuit.+--+-- = Example+--+-- @+-- tbMachine :: (File,File) -> Int -> SimIO Int+-- tbMachine (fileIn,fileOut) regOut = do+--   eofFileOut <- 'isEOF' fileOut+--   eofFileIn  <- 'isEOF' fileIn+--   when (eofFileIn || eofFileOut) $ do+--     'display' "success"+--     'finish' 0+--+--   goldenIn  <- 'getChar' fileIn+--   goldenOut <- 'getChar' fileOut+--   res <- if regOut == fromEnum goldenOut then do+--            return (fromEnum goldenIn)+--          else do+--            'display' "Output doesn't match golden output"+--            'finish' 1+--   display ("Output matches golden output")+--   return res+--+-- tbInit :: (File,File)+-- tbInit = do+--   fileIn  <- 'openFile' "./goldenInput00.txt" "r"+--   fileOut <- 'openFile' "./goldenOutput00.txt" "r"+--   return (fileIn,fileOut)+--+-- topEntity :: Signal System Int+-- topEntity = regOut+--   where+--     clk = systemClockGen+--     rst = resetGen+--     ena = enableGen+--+--     regOut = register clk rst ena (fromEnum \'a\') regIn+--     regIn  = 'mealyIO' clk tbMachine tbInit regOut+-- @+mealyIO+  :: KnownDomain dom+  => Clock dom+  -- ^ Clock at which rate the I\/O environment progresses+  -> (s -> i -> SimIO o)+  -- ^ Transition function inside an I\/O environment+  -> SimIO s+  -- ^ I/O action to create the initial state+  -> Signal dom i+  -> Signal dom o+mealyIO !_ f (SimIO i) inp = unsafePerformIO (i >>= go inp)+ where+  go q@(~(k :- ks)) s =+    (:-) <$> unSimIO (f s k) <*> unsafeInterleaveIO ((q `seq` go ks s))+{-# OPAQUE mealyIO #-}
src/Clash/Explicit/Synchronizer.hs view
@@ -1,23 +1,23 @@ {-| Copyright   :  (C) 2015-2016, University of Twente,                    2016-2019, Myrtle Software Ltd,-                   2017     , Google Inc.+                   2017     , Google Inc.,+                   2021-2022, QBayLogic B.V. License     :  BSD2 (see the file LICENSE)-Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>  Synchronizer circuits for safe clock domain crossings -} -{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE Safe                  #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Safe #-}+ {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver    #-}  {-# OPTIONS_HADDOCK show-extensions #-} @@ -29,25 +29,24 @@   ) where -import Control.Applicative         (liftA2) import Data.Bits                   (complement, shiftR, xor)-import Data.Constraint             ((:-)(..), Dict (..))+import Data.Constraint             ((:-)(Sub), Dict (..)) import Data.Constraint.Nat         (leTrans) import Data.Maybe                  (isJust)-import GHC.TypeLits                (type (+), type (-), type (<=))+import GHC.TypeLits                (type (+), type (-), type (<=), type (^), KnownNat) -import Clash.Class.BitPack         (boolToBV)+import Clash.Class.BitPack         (boolToBV, unpack) import Clash.Class.Resize          (truncateB)-import Clash.Prelude.BitIndex      (slice)+import Clash.Class.BitPack.BitIndex (slice) import Clash.Explicit.Mealy        (mealyB)-import Clash.Explicit.RAM          (asyncRam)+import Clash.Explicit.BlockRam     (RamOp (..), trueDualPortBlockRam) import Clash.Explicit.Signal-  (Clock, Reset, Signal, Enable, register, unsafeSynchronizer)-import Clash.Promoted.Nat          (SNat (..), pow2SNat)+  (Clock, Reset, Signal, Enable, register, unsafeSynchronizer, fromEnable,+  (.&&.), mux, KnownDomain)+import Clash.Promoted.Nat          (SNat (..)) import Clash.Promoted.Nat.Literals (d0)-import Clash.Signal                (mux, KnownDomain) import Clash.Sized.BitVector       (BitVector, (++#))-import Clash.XException            (NFDataX)+import Clash.XException            (NFDataX, fromJustX)  -- * Dual flip-flop synchronizer @@ -99,27 +98,63 @@ -- * Asynchronous FIFO synchronizer  fifoMem-  :: ( KnownDomain wdom-     , KnownDomain rdom )+  :: forall wdom rdom a addrSize+   . ( KnownDomain wdom+     , KnownDomain rdom+     , NFDataX a+     , KnownNat addrSize+     , 1 <= addrSize )   => Clock wdom   -> Clock rdom   -> Enable wdom-  -> SNat addrSize+  -> Enable rdom   -> Signal wdom Bool   -> Signal rdom (BitVector addrSize)-  -> Signal wdom (Maybe (BitVector addrSize, a))+  -> Signal wdom (BitVector addrSize)+  -> Signal wdom (Maybe a)   -> Signal rdom a-fifoMem wclk rclk en addrSize@SNat full raddr writeM =-  asyncRam-    wclk rclk en-    (pow2SNat addrSize)-    raddr-    (mux full (pure Nothing) writeM)+fifoMem wclk rclk wen ren full raddr waddr wdataM =+  fst $ trueDualPortBlockRam+    rclk wclk portA portB+ where+   portA :: Signal rdom (RamOp (2 ^ addrSize) a)+   portA = mux (fromEnable ren)+               (RamRead . unpack <$> raddr)+               (pure RamNoOp)+   portB :: Signal wdom (RamOp (2 ^ addrSize) a)+   portB = mux (fromEnable wen .&&. fmap not full .&&. fmap isJust wdataM)+               (RamWrite <$> fmap unpack waddr <*> fmap fromJustX wdataM)+               (pure RamNoOp) -ptrCompareT-  :: SNat addrSize-  -> (BitVector (addrSize + 1) -> BitVector (addrSize + 1) -> Bool)+readPtrCompareT+  :: KnownNat addrSize+  => ( BitVector (addrSize + 1)+     , BitVector (addrSize + 1)+     , Bool )   -> ( BitVector (addrSize + 1)+     , Bool )+  -> ( ( BitVector (addrSize + 1)+       , BitVector (addrSize + 1)+       , Bool )+     , ( Bool+       , BitVector addrSize+       , BitVector (addrSize + 1)+       )+     )+readPtrCompareT (bin, ptr, flag) (s_ptr, inc) =+  ((bin', ptr', flag'), (flag, addr, ptr))+ where+  -- GRAYSTYLE2 pointer+  bin' = bin + boolToBV (inc && not flag)+  ptr' = (bin' `shiftR` 1) `xor` bin'+  addr = truncateB bin'++  flag' = ptr' == s_ptr++writePtrCompareT+  :: (2 <= addrSize)+  => SNat addrSize+  -> ( BitVector (addrSize + 1)      , BitVector (addrSize + 1)      , Bool )   -> ( BitVector (addrSize + 1)@@ -132,7 +167,7 @@        , BitVector (addrSize + 1)        )      )-ptrCompareT SNat flagGen (bin, ptr, flag) (s_ptr, inc) =+writePtrCompareT addrSize@SNat (bin, ptr, flag) (s_ptr, inc) =   ((bin', ptr', flag'), (flag, addr, ptr))  where   -- GRAYSTYLE2 pointer@@ -140,9 +175,9 @@   ptr' = (bin' `shiftR` 1) `xor` bin'   addr = truncateB bin -  flag' = flagGen ptr' s_ptr+  flag' = isFull addrSize ptr' s_ptr --- FIFO full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1:0]}+-- FIFO full: when next pntr == synchronized {~wptr[addrSize:addrSize-1],wptr[addrSize-2:0]} isFull   :: forall addrSize    . (2 <= addrSize)@@ -157,15 +192,21 @@           a2 = SNat @(addrSize - 2)       in  ptr == (complement (slice addrSize a1 s_ptr) ++# slice a2 d0 s_ptr) --- | Synchronizer implemented as a FIFO around an asynchronous RAM. Based on the--- design described in "Clash.Tutorial#multiclock", which is itself based on the+-- | Synchronizer implemented as a FIFO around a synchronous RAM. Based on the -- design described in <http://www.sunburst-design.com/papers/CummingsSNUG2002SJ_FIFO1.pdf>.+-- However, this FIFO uses a synchronous dual-ported RAM which, unlike those+-- designs using RAM with an asynchronous read port, is nearly guaranteed to+-- actually synthesize into one of the dual-ported RAMs found on most FPGAs. -- -- __NB__: This synchronizer can be used for __word__-synchronization.+-- __NB__: This synchronizer will only work safely when you set up the proper+-- bus skew and maximum delay constraints inside your synthesis tool for the+-- clock domain crossings of the gray pointers. asyncFIFOSynchronizer   :: ( KnownDomain wdom      , KnownDomain rdom-     , 2 <= addrSize )+     , 2 <= addrSize+     , NFDataX a )   => SNat addrSize   -- ^ Size of the internally used addresses, the  FIFO contains @2^addrSize@   -- elements.@@ -191,20 +232,20 @@    rdata =     fifoMem-      wclk rclk wen-      addrSize wfull raddr-      (liftA2 (,) <$> (pure <$> waddr) <*> wdataM)+      wclk rclk wen ren+      wfull raddr+      waddr wdataM    (rempty, raddr, rptr) =     mealyB       rclk rrst ren-      (ptrCompareT addrSize (==))+      readPtrCompareT       (0, 0, True)       (s_wptr, rinc)    (wfull, waddr, wptr) =     mealyB       wclk wrst wen-      (ptrCompareT addrSize (isFull addrSize))+      (writePtrCompareT addrSize)       (0, 0, False)       (s_rptr, isJust <$> wdataM)
src/Clash/Explicit/Testbench.hs view
@@ -1,17 +1,14 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,-                  2017     , Google Inc.-                  2019     , Myrtle Software Ltd+                  2017-2022, Google Inc.+                  2019     , Myrtle Software Ltd,+                  2021-2023, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}  {-# LANGUAGE Unsafe #-} @@ -23,41 +20,44 @@ module Clash.Explicit.Testbench   ( -- * Testbench functions for circuits     assert+  , assertBitVector   , ignoreFor   , stimuliGenerator    , tbClockGen   , tbEnableGen   , tbSystemClockGen+  , clockToDiffClock    , outputVerifier   , outputVerifier'   , outputVerifierBitVector   , outputVerifierBitVector'   , biTbClockGen+  , unsafeSimSynchronizer+  , outputVerifierWith   ) where  import Control.Exception     (catch, evaluate) import Debug.Trace           (trace)-import GHC.TypeLits          (KnownNat, type (+))+import GHC.TypeLits          (KnownNat, type (+), type (<=)) import Prelude               hiding ((!!), length) import System.IO.Unsafe      (unsafeDupablePerformIO)  import Clash.Annotations.Primitive (hasBlackBox) import Clash.Class.Num       (satSucc, SaturationMode(SatBound))-import Clash.Promoted.Nat    (SNat(..), snatToNum)-import Clash.Promoted.Symbol (SSymbol (..))+import Clash.Promoted.Nat    (SNat(..))+import Clash.Promoted.Symbol (SSymbol(..)) import Clash.Explicit.Signal-  (Clock, Reset, System, Signal, clockPeriod, toEnable, fromList, register,-  unbundle, unsafeSynchronizer, veryUnsafeSynchronizer)-import Clash.Signal.Internal (Clock (..))-import Clash.Signal-  (mux, DomainResetKind, ResetKind(Asynchronous), KnownDomain, Reset(..),-  Enable)+  (Clock, Reset, System, Signal, toEnable, fromList, register,+  unbundle, unsafeSynchronizer)+import Clash.Signal.Internal+  (ClockN (..), DiffClock (..), Reset (..), tbClockGen)+import Clash.Signal          (mux, KnownDomain, Enable) import Clash.Sized.Index     (Index) import Clash.Sized.Internal.BitVector-  (BitVector, isLike)+  (BitVector, isLike#) import Clash.Sized.Vector    (Vec, (!!), length) import Clash.XException      (ShowX (..), XException) @@ -77,7 +77,13 @@ -- function simply returns the third 'Signal' unaltered as its result. This -- function is used by 'outputVerifier'. --+-- === Usage in @clashi@ #assert-clashi# --+-- __NB__: When simulating a component that uses 'assert' in @clashi@, usually,+-- the warnings are only logged the first time the component is simulated.+-- Issuing @:reload@ in @clashi@ will discard the cached result of the+-- computation, and warnings will once again be emitted.+-- -- __NB__: This function /can/ be used in synthesizable designs. assert   :: (KnownDomain dom, Eq a, ShowX a)@@ -109,10 +115,10 @@   where     eqX a b = unsafeDupablePerformIO (catch (evaluate (a == b))                                             (\(_ :: XException) -> return False))-{-# NOINLINE assert #-}+{-# OPAQUE assert #-} {-# ANN assert hasBlackBox #-} --- | The same as 'assert', but can handle don't care bits in it's expected value.+-- | The same as 'assert', but can handle don't care bits in its expected value. assertBitVector   :: (KnownDomain dom, KnownNat n)   => Clock dom@@ -141,9 +147,9 @@                             ]) r)   <$> checked <*> expected <*> fromList [(0::Integer)..] <*> returned   where-    eqX a b = unsafeDupablePerformIO (catch (evaluate (a `isLike` b))+    eqX a b = unsafeDupablePerformIO (catch (evaluate (a `isLike#` b))                                             (\(_ :: XException) -> return False))-{-# NOINLINE assertBitVector #-}+{-# OPAQUE assertBitVector #-} {-# ANN assertBitVector hasBlackBox #-}  @@ -188,34 +194,40 @@                 else s {-# INLINABLE stimuliGenerator #-} --- | Same as 'outputVerifier' but used in cases where the testbench domain and+-- | Same as 'outputVerifier' but used in cases where the test bench domain and -- the domain of the circuit under test are the same. outputVerifier'   :: forall l a dom    . ( KnownNat l      , KnownDomain dom-     , DomainResetKind dom ~ 'Asynchronous      , Eq a-     , ShowX a )+     , ShowX a+     , 1 <= l+     )   => Clock dom-  -- ^ Clock to which the testbench is synchronized to+  -- ^ Clock to which the test bench is synchronized   -> Reset dom-  -- ^ Reset line of testbench+  -- ^ Reset line of test bench   -> Vec l a   -- ^ Samples to compare with   -> Signal dom a   -- ^ Signal to verify   -> Signal dom Bool   -- ^ Indicator that all samples are verified-outputVerifier' =-  outputVerifier @l @a @dom @dom-{-# INLINABLE outputVerifier' #-}+outputVerifier' clk =+  outputVerifier @l @a clk clk+{-# INLINE outputVerifier' #-}  -- | Compare a signal (coming from a circuit) to a vector of samples. If a -- sample from the signal is not equal to the corresponding sample in the -- vector, print to stderr and continue testing. This function is--- synthesizable in the sense that HDL simulators will run it.+-- synthesizable in the sense that HDL simulators will run it. If @testDom@ and+-- @circuitDom@ refer to the same domain, it can also be synthesized into+-- hardware. --+-- __NB__: This function uses 'assert'. When simulating this function in+-- @clashi@, read the [note](#assert-clashi).+-- -- Example: -- -- @@@ -250,61 +262,45 @@ -- expected value: 10, not equal to actual value: 9 -- ,False,True] ----- If your working with 'BitVector's containing don't care bits you should+-- If you're working with 'BitVector's containing don't care bits you should -- use 'outputVerifierBitVector'. outputVerifier   :: forall l a testDom circuitDom    . ( KnownNat l      , KnownDomain testDom      , KnownDomain circuitDom-     , DomainResetKind testDom ~ 'Asynchronous      , Eq a-     , ShowX a )+     , ShowX a+     , 1 <= l+     )   => Clock testDom-  -- ^ Clock to which the testbench is synchronized to (but not necessarily+  -- ^ Clock to which the test bench is synchronized (but not necessarily   -- the circuit under test)+  -> Clock circuitDom+  -- ^ Clock to which the circuit under test is synchronized   -> Reset testDom-  -- ^ Reset line of testbench+  -- ^ Reset line of test bench   -> Vec l a   -- ^ Samples to compare with   -> Signal circuitDom a   -- ^ Signal to verify   -> Signal testDom Bool   -- ^ True if all samples are verified-outputVerifier clk rst samples i0 =-    let t1    = snatToNum (clockPeriod @circuitDom)-        t2    = snatToNum (clockPeriod @testDom)-        i1    = veryUnsafeSynchronizer t1 t2 i0-        en    = toEnable (pure True)-        (s,o) = unbundle (genT <$> register clk rst en 0 s)-        (e,f) = unbundle o-        f'    = register clk rst en False f-        -- Only assert while not finished-    in  mux f' f' $ assert clk rst "outputVerifier" i1 e f'-  where-    genT :: Index l -> (Index l,(a,Bool))-    genT s = (s',(samples !! s,finished))-      where-        maxI = toEnum (length samples - 1)--        s' = if s < maxI-                then s + 1-                else s--        finished = s == maxI-{-# INLINABLE outputVerifier #-}+outputVerifier =+  outputVerifierWith (\clk rst -> assert clk rst "outputVerifier")+{-# INLINE outputVerifier #-} --- | Same as 'outputVerifier'', but can handle don't care bits in it's expected+-- | Same as 'outputVerifier'', but can handle don't care bits in its expected -- values. outputVerifierBitVector'   :: forall l n dom    . ( KnownNat l      , KnownNat n      , KnownDomain dom-     , DomainResetKind dom ~ 'Asynchronous+     , 1 <= l      )   => Clock dom-  -- ^ Clock to which the input signal is synchronized to+  -- ^ Clock to which the input signal is synchronized   -> Reset dom   -> Vec l (BitVector n)   -- ^ Samples to compare with@@ -312,11 +308,11 @@   -- ^ Signal to verify   -> Signal dom Bool   -- ^ Indicator that all samples are verified-outputVerifierBitVector' =-  outputVerifierBitVector @l @n @dom @dom-{-# INLINABLE outputVerifierBitVector' #-}+outputVerifierBitVector' clk =+  outputVerifierBitVector @l @n clk clk+{-# INLINE outputVerifierBitVector' #-} --- | Same as 'outputVerifier', but can handle don't care bits in it's+-- | Same as 'outputVerifier', but can handle don't care bits in its -- expected values. outputVerifierBitVector   :: forall l n testDom circuitDom@@ -324,39 +320,71 @@      , KnownNat n      , KnownDomain testDom      , KnownDomain circuitDom-     , DomainResetKind testDom ~ 'Asynchronous+     , 1 <= l      )   => Clock testDom-  -- ^ Clock to which the input signal is synchronized to+  -- ^ Clock to which the test bench is synchronized (but not necessarily+  -- the circuit under test)+  -> Clock circuitDom+  -- ^ Clock to which the circuit under test is synchronized   -> Reset testDom+  -- ^ Reset line of test bench   -> Vec l (BitVector n)   -- ^ Samples to compare with   -> Signal circuitDom (BitVector n)   -- ^ Signal to verify   -> Signal testDom Bool   -- ^ Indicator that all samples are verified-outputVerifierBitVector clk rst samples i0 =-    let t1    = snatToNum (clockPeriod @circuitDom)-        t2    = snatToNum (clockPeriod @testDom)-        i1    = veryUnsafeSynchronizer t1 t2 i0+outputVerifierBitVector =+  outputVerifierWith+    (\clk rst -> assertBitVector clk rst "outputVerifierBitVector")+{-# INLINE outputVerifierBitVector #-}++outputVerifierWith+  :: forall l a testDom circuitDom+   . ( KnownNat l+     , KnownDomain testDom+     , KnownDomain circuitDom+     , Eq a+     , ShowX a+     , 1 <= l+     )+  => (    Clock testDom+       -> Reset testDom+       -> Signal testDom a+       -> Signal testDom a+       -> Signal testDom Bool+       -> Signal testDom Bool+      )+  -- ^ The @assert@ function to use+  -> Clock testDom+  -- ^ Clock to which the test bench is synchronized (but not necessarily+  -- the circuit under test)+  -> Clock circuitDom+  -- ^ Clock to which the circuit under test is synchronized+  -> Reset testDom+  -- ^ Reset line of test bench+  -> Vec l a+  -- ^ Samples to compare with+  -> Signal circuitDom a+  -- ^ Signal to verify+  -> Signal testDom Bool+  -- ^ True if all samples are verified+outputVerifierWith assertF clkTest clkCircuit rst samples i0 =+    let i1    = unsafeSimSynchronizer clkCircuit clkTest i0         en    = toEnable (pure True)-        (s,o) = unbundle (genT <$> register clk rst en 0 s)+        (s,o) = unbundle (genT <$> register clkTest rst en 0 s)         (e,f) = unbundle o-        f'    = register clk rst en False f+        f'    = register clkTest rst en False f         -- Only assert while not finished-    in  mux f' f' $ assertBitVector clk rst "outputVerifierBitVector'" i1 e f'+    in  mux f' f' $ assertF clkTest rst i1 e f'   where-    genT :: Index l -> (Index l,(BitVector n,Bool))+    genT :: Index l -> (Index l,(a,Bool))     genT s = (s',(samples !! s,finished))       where-        maxI = toEnum (length samples - 1)--        s' = if s < maxI-                then s + 1-                else s--        finished = s == maxI-{-# INLINABLE outputVerifierBitVector #-}+        s' = satSucc SatBound s+        finished = s == maxBound+{-# INLINABLE outputVerifierWith #-}  -- | Ignore signal for a number of cycles, while outputting a static value. ignoreFor@@ -381,14 +409,12 @@   counter = register clk rst en 0 (satSucc SatBound <$> counter)  -- | Same as 'tbClockGen', but returns two clocks on potentially different--- domains. To be used in situations where the circuit under test runs--- in a different domain than the circuit testing it. Most commonly used--- to test synchronous circuits (with an asynchronous test circuit).+-- domains. To be used in situations where the test circuit potentially operates+-- on a different clock than the device under test. biTbClockGen   :: forall testDom circuitDom    . ( KnownDomain testDom      , KnownDomain circuitDom-     , DomainResetKind testDom ~ 'Asynchronous      )   => Signal testDom Bool   -> (Clock testDom, Clock circuitDom)@@ -397,72 +423,17 @@   testClk = tbClockGen done   circuitClk = tbClockGen (unsafeSynchronizer testClk circuitClk done) --- | Clock generator to be used in the /testBench/ function.------ To be used like:------ @--- clkSystem en = tbClockGen @System en--- @------ === __Example__------ @--- module Example where------ import "Clash.Explicit.Prelude"--- import "Clash.Explicit.Testbench"------ -- Fast domain: twice as fast as \"Slow\"--- 'createDomain' 'vSystem'{vName=\"Fast\", vPeriod=10}------ -- Slow domain: twice as slow as "Fast"--- 'createDomain' 'vSystem'{vName=\"Slow\", vPeriod=20}------ topEntity---   :: 'Clock' \"Fast\"---   -> 'Reset' \"Fast\"---   -> 'Enable' \"Fast\"---   -> 'Clock' \"Slow\"---   -> 'Signal' \"Fast\" (Unsigned 8)---   -> 'Signal' \"Slow\" (Unsigned 8, Unsigned 8)--- topEntity clk1 rst1 en1 clk2 i =---   let h = register clk1 rst1 en1 0 (register clk1 rst1 en1 0 i)---       l = register clk1 rst1 en1 0 i---   in  unsafeSynchronizer clk1 clk2 (bundle (h, l))------ testBench---   :: 'Signal' \"Slow\" Bool--- testBench = done---   where---     testInput      = 'Clash.Explicit.Testbench.stimuliGenerator' clkA1 rstA1 $('listToVecTH' [1::Unsigned 8,2,3,4,5,6,7,8])---     expectedOutput = 'Clash.Explicit.Testbench.outputVerifier'   clkB2 rstB2 $('listToVecTH' [(0,0) :: (Unsigned 8, Unsigned 8),(1,2),(3,4),(5,6),(7,8)])---     done           = expectedOutput (topEntity clkA1 rstA1 enableGen clkB2 testInput)---     done'          = not \<$\> done---     clkA1          = 'tbClockGen' \@\"Fast\" (unsafeSynchronizer clkB2 clkA1 done')---     clkB2          = 'tbClockGen' \@\"Slow\" done'---     rstA1          = 'resetGen' \@\"Fast\"---     rstB2          = 'resetGen' \@\"Slow\"--- @-tbClockGen-  :: KnownDomain testDom-  => Signal testDom Bool-  -> Clock testDom-tbClockGen done = Clock (done `seq` SSymbol)-{-# NOINLINE tbClockGen #-}-{-# ANN tbClockGen hasBlackBox #-}- -- | Enable signal that's always enabled. Because it has a blackbox definition -- this enable signal is opaque to other blackboxes. It will therefore never -- be optimized away. tbEnableGen :: Enable tag tbEnableGen = toEnable (pure True)-{-# NOINLINE tbEnableGen #-}+{-# OPAQUE tbEnableGen #-} {-# ANN tbEnableGen hasBlackBox #-}  -- | Clock generator for the 'System' clock domain. ----- __NB__: can be used in the /testBench/ function+-- __NB__: Can be used in the /testBench/ function -- -- === __Example__ --@@ -474,12 +445,57 @@ -- testBench = done --   where --     testInput      = pure ((1 :> 2 :> 3 :> Nil) :> (4 :> 5 :> 6 :> Nil) :> Nil)---     expectedOutput = outputVerifier ((1:>2:>3:>4:>5:>6:>Nil):>Nil)---     done           = exposeClockResetEnable (expectedOutput (topEntity <$> testInput)) clk rst---     clk            = 'tbSystemClockGen' (not <\$\> done)+--     expectedOutput = outputVerifier' ((1:>2:>3:>4:>5:>6:>Nil):>Nil)+--     done           = exposeClockResetEnable (expectedOutput (topEntity \<\$> testInput)) clk rst+--     clk            = 'tbSystemClockGen' (not \<\$> done) --     rst            = systemResetGen -- @ tbSystemClockGen   :: Signal System Bool   -> Clock System tbSystemClockGen = tbClockGen++-- | Convert a single-ended clock to a differential clock+--+-- The 'tbClockGen' function generates a single-ended clock. This function will+-- output the two phases of a differential clock corresponding to that+-- single-ended clock.+--+-- This function is only meant to be used in the /testBench/ function, not to+-- create a differential output in hardware.+--+-- Example:+--+-- @+-- clk = clockToDiffClock $ tbClockGen (not \<\$\> done)+-- @+clockToDiffClock ::+  KnownDomain dom =>+  -- | Single-ended input+  Clock dom ->+  -- | Differential output+  DiffClock dom+clockToDiffClock clk = DiffClock clk (ClockN SSymbol)+{-# OPAQUE clockToDiffClock #-}+{-# ANN clockToDiffClock hasBlackBox #-}++-- | Cross clock domains in a way that is unsuitable for hardware but good+-- enough for simulation.+--+-- It's equal to 'unsafeSynchronizer' but will warn when used outside of a test+-- bench. 'outputVerifier' uses this function when it needs to cross between+-- clock domains, which will render it unsuitable for synthesis, but good enough+-- for simulating the generated HDL.+unsafeSimSynchronizer+  :: forall dom1 dom2 a+   . ( KnownDomain dom1+     , KnownDomain dom2 )+  => Clock dom1+  -- ^ 'Clock' of the incoming signal+  -> Clock dom2+  -- ^ 'Clock' of the outgoing signal+  -> Signal dom1 a+  -> Signal dom2 a+unsafeSimSynchronizer = unsafeSynchronizer+{-# OPAQUE unsafeSimSynchronizer #-}+{-# ANN unsafeSimSynchronizer hasBlackBox #-}
+ src/Clash/Explicit/Verification.hs view
@@ -0,0 +1,276 @@+{-|+Copyright  :  (C) 2019, Myrtle Software Ltd+                  2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Verification primitives for Clash. Currently implements PSL (Property+Specification Language) and SVA (SystemVerilog Assertions). For a good overview+of PSL and an introduction to the concepts of property checking, read+<https://standards.ieee.org/standard/62531-2012.html>.++The verification API is currently experimental and subject to change.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE QuasiQuotes #-}++module Clash.Explicit.Verification+  ( -- * Types+    Assertion+  , Property+  , AssertionValue+  , RenderAs(..)++    -- * Bootstrapping functions+  , name+  , lit++    -- * Functions to build a PSL/SVA expressions+  , not+  , and+  , or+  , implies+  , next+  , nextN+  , before+  , timplies+  , timpliesOverlapping+  , always+  , never+  , eventually++  -- * Asserts+  , assert+  , cover+  , assume++  -- * Assertion checking+  , check+  , checkI++  -- * Functions to deal with assertion results+  , hideAssertion+  )+ where++import           Prelude+  (Bool, Word, (.), pure, max, concat)++import           Data.Text  (Text)+import           Data.Maybe (Maybe(Just))+import           Data.String.Interpolate (__i)++import           Clash.Annotations.Primitive+  (Primitive(InlineYamlPrimitive), HDL(..))+import           Clash.Signal.Internal (KnownDomain, Signal, Clock, Reset)+import           Clash.XException      (errorX, hwSeqX)++import           Clash.Verification.Internal++-- | Convert a signal to a cv expression with a name hint. Clash will try its+-- best to use this name in the rendered assertion, but might run into+-- collisions. You can skip using 'name' altogether. Clash will then try its+-- best to get a readable name from context.+name :: Text -> Signal dom Bool -> Assertion dom+name nm signal = Assertion IsNotTemporal (CvPure (Just nm, signal))+{-# INLINE name #-}++-- | For using a literal (either True or False) in assertions+lit :: Bool -> Assertion dom+lit = Assertion IsNotTemporal . CvLit+{-# INLINE lit #-}++-- | Truth table for 'not':+--+-- > a     | not a+-- > ------------+-- > True  | False+-- > False | True+not :: AssertionValue dom a => a -> Assertion dom+not (toAssertionValue -> a) = Assertion (isTemporal a) (CvNot (assertion a))+{-# INLINE not #-}++-- | Truth table for 'and':+--+-- > a     | b     | a `and` b+-- > --------------|----------+-- > False | False | False+-- > False | True  | False+-- > True  | False | False+-- > True  | True  | True+and :: (AssertionValue dom a, AssertionValue dom b) => a -> b -> Assertion dom+and (toAssertionValue -> a) (toAssertionValue -> b) =+  Assertion+    (max (isTemporal a) (isTemporal b))+    (CvAnd (assertion a) (assertion b))+{-# INLINE and #-}++-- | Truth table for 'or':+--+-- > a     | b     | a `or` b+-- > --------------|---------+-- > False | False | False+-- > False | True  | True+-- > True  | False | True+-- > True  | True  | True+or :: (AssertionValue dom a, AssertionValue dom b) => a -> b -> Assertion dom+or (toAssertionValue -> a) (toAssertionValue -> b) =+  Assertion+    (max (isTemporal a) (isTemporal b))+    (CvOr (assertion a) (assertion b))+{-# INLINE or #-}++-- |+-- Truth table for 'implies':+--+-- > a     | b     | a `implies` b+-- > --------------|--------------+-- > False | False | True+-- > False | True  | True+-- > True  | False | False+-- > True  | True  | True+implies :: (AssertionValue dom a, AssertionValue dom b) => a -> b -> Assertion dom+implies (toAssertionValue -> Assertion aTmp a) (toAssertionValue -> Assertion bTmp b) =+  Assertion (max aTmp bTmp) (CvImplies a b)+{-# INLINE implies #-}++-- | Truth table for 'next':+--+-- > a[n]  | a[n+1] | a `implies` next a+-- > ---------------|-------------------+-- > False | False  | True+-- > False | True   | True+-- > True  | False  | False+-- > True  | True   | True+--+-- where a[n] represents the value of @a@ at cycle @n@ and @a[n+1]@ represents+-- the value of @a@ at cycle @n+1@. Cycle n is an arbitrary cycle.+next :: AssertionValue dom a => a -> Assertion dom+next = nextN 1+{-# INLINE next #-}++-- | Truth table for 'nextN':+--+-- > a[n]  | a[n+m] | a `implies` next m a+-- > ---------------|---------------------+-- > False | False  | True+-- > False | True   | True+-- > True  | False  | False+-- > True  | True   | True+--+-- where a[n] represents the value of @a@ at cycle @n@ and a[n+m] represents+-- the value of @a@ at cycle @n+m@. Cycle n is an arbitrary cycle.+nextN :: AssertionValue dom a => Word -> a -> Assertion dom+nextN n = Assertion IsTemporal . CvNext n . assertion . toAssertionValue+{-# INLINE nextN #-}++-- | Same as @a && next b@ but with a nice syntax. E.g., @a && next b@ could+-- be written as @a \`before\` b@. Might be read as "a happens one cycle before b".+before :: (AssertionValue dom a, AssertionValue dom b) => a -> b -> Assertion dom+before a0 b0 = Assertion IsTemporal (CvBefore a1 b1)+ where+  a1 = assertion (toAssertionValue a0)+  b1 = assertion (toAssertionValue b0)+{-# INLINE before #-}++-- | Same as @a \`implies\` next b@ but with a nice syntax. E.g.,+-- @a \`implies\` next b@ could be written as @a \`timplies\` b@. Might be read+-- as "a at cycle n implies b at cycle n+1".+timplies :: (AssertionValue dom a, AssertionValue dom b) => a -> b -> Assertion dom+timplies a0 b0 = Assertion IsTemporal (CvTemporalImplies 1 a1 b1)+ where+  a1 = toTemporal (toAssertionValue a0)+  b1 = toTemporal (toAssertionValue b0)+{-# INLINE timplies #-}++-- | Same as 'implies' but strictly temporal.+timpliesOverlapping+  :: (AssertionValue dom a, AssertionValue dom b)+  => a+  -> b+  -> Assertion dom+timpliesOverlapping a0 b0 =+  Assertion IsTemporal (CvTemporalImplies 0 a1 b1)+ where+  a1 = toTemporal (toAssertionValue a0)+  b1 = toTemporal (toAssertionValue b0)+{-# INLINE timpliesOverlapping #-}++-- | Specify assertion should _always_ hold+always :: AssertionValue dom a => a -> Assertion dom+always = Assertion IsTemporal . CvAlways . assertion . toAssertionValue+{-# INLINE always #-}++-- | Specify assertion should _never_ hold (not supported by SVA)+never :: AssertionValue dom a => a -> Assertion dom+never = Assertion IsTemporal . CvNever . assertion . toAssertionValue+{-# INLINE never #-}++-- | Specify assertion should _eventually_ hold+eventually :: AssertionValue dom a => a -> Assertion dom+eventually = Assertion IsTemporal . CvEventually . assertion . toAssertionValue+{-# INLINE eventually #-}++-- | Check whether given assertion always holds. Results can be collected with+-- 'check'.+assert :: AssertionValue dom a => a -> Property dom+assert = Property . CvAssert . assertion . toAssertionValue+{-# INLINE assert #-}++-- | Check whether given assertion holds for at least a single cycle. Results+-- can be collected with 'check'.+cover :: AssertionValue dom a => a -> Property dom+cover = Property . CvCover . assertion . toAssertionValue+{-# INLINE cover #-}++-- | Inform the prover that this property is true. This is the same as 'assert'+-- for simulations.+assume :: AssertionValue dom a => a -> Property dom+assume = Property . CvAssume . assertion . toAssertionValue+{-# INLINE assume #-}+++-- | Print property as PSL/SVA in HDL. Clash simulation support not yet+-- implemented.+check+  :: KnownDomain dom+  => Clock dom+  -> Reset dom+  -> Text+  -- ^ Property name (used in reports and error messages)+  -> RenderAs+  -- ^ Assertion language to use in HDL+  -> Property dom+  -> Signal dom AssertionResult+check !_clk !_rst !_propName !_renderAs !_prop =+  pure (errorX (concat [+      "Simulation for Clash.Verification not yet implemented. If you need this,"+    , " create an issue at https://github.com/clash-compiler/clash-lang/issues." ]))+{-# OPAQUE check #-}+{-# ANN check (InlineYamlPrimitive [Verilog, SystemVerilog, VHDL] [__i|+  BlackBoxHaskell:+    name: Clash.Explicit.Verification.check+    templateFunction: Clash.Primitives.Verification.checkBBF+  |]) #-}++-- | Same as 'check', but doesn't require a design to explicitly carried to+-- top-level.+checkI+  :: KnownDomain dom+  => Clock dom+  -> Reset dom+  -> Text+  -- ^ Property name (used in reports and error messages)+  -> RenderAs+  -- ^ Assertion language to use in HDL+  -> Property dom+  -> Signal dom a+  -> Signal dom a+checkI clk rst propName renderAs prop =+  hideAssertion (check clk rst propName renderAs prop)++-- | Print assertions in HDL+hideAssertion :: Signal dom AssertionResult -> Signal dom a -> Signal dom a+hideAssertion = hwSeqX
src/Clash/HaskellPrelude.hs view
@@ -1,23 +1,72 @@ {-|   Copyright   :  (C) 2019, QBayLogic B.V.+                 (C) 2021, QBayLogic B.V.   License     :  BSD2 (see the file LICENSE)   Maintainer  :  QBayLogic B.V <devops@qbaylogic.com> -"Clash.HaskellPrelude" re-exports most of the Haskell "Prelude" with the exception of-the following: (++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head,-init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr,-splitAt, tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3.+"Clash.HaskellPrelude" re-exports most of the Haskell "Prelude" with the+exception of those functions that the Clash API defines to work on+'Clash.Sized.Vector.Vec' from "Clash.Sized.Vector" instead of on lists as the+Haskell Prelude does. In addition, for the 'Clash.Class.Parity.odd' and+'Clash.Class.Parity.even' functions a type class called+'Clash.Class.Parity.Parity' is available at "Clash.Class.Parity". -} +{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+ {-# LANGUAGE Safe #-}  {-# OPTIONS_HADDOCK show-extensions, not-home #-}  module Clash.HaskellPrelude-  (module Prelude)+  (module Prelude, (&&), (||), not) where  import Prelude hiding-  ((++), (!!), concat, concatMap, drop, foldl, foldl1, foldr, foldr1, head, init,-   iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, splitAt,-   tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3, undefined, (^))+  ((++), (!!), concat, concatMap, drop, even, foldl, foldl1, foldr, foldr1, head, init,+   iterate, last, length, map, odd, repeat, replicate, reverse, scanl, scanl1,+   scanr, scanr1, splitAt, tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3, undefined,+   (^), getChar, putChar, getLine, (&&), (||), not, maximum, minimum)++import qualified Prelude+import GHC.Magic (noinline)++{-+Note [use of noinline]+~~~~~~~~~~~~~~~~~~~~~~+The magic noinline function is used here to prevent GHC inlining these+functions in the simplifier. They are removed (by GHC) post-simplifier, so+they have no negative impact on Clash's normalization.++Why prevent this inlining? When GHC sees a function like++    topEntity :: Bool -> Bool -> Bool+    topEntity a b = a && b++it inlines the definition of && to become++    topEntity a b =+      case a of+        True -> case b of+                  True -> True+                  False -> False+        False -> False++which Clash will render as multiplexer(s) instead of using the and operator+available in the targeted HDL backend. While this has no impact on the quality+of the final result (EDA tools will optimize this with ease in P&R), it makes+the generated HDL (and RTL view of circuits) more obfuscated to read.+-}++infixr 3 &&++(&&) :: Bool -> Bool -> Bool+(&&) = noinline (Prelude.&&)++infixr 2 ||++(||) :: Bool -> Bool -> Bool+(||) = noinline (Prelude.||)++not :: Bool -> Bool+not = noinline Prelude.not
src/Clash/Hidden.hs view
@@ -6,15 +6,11 @@ Hidden arguments -} -{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE KindSignatures         #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE Rank2Types             #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}  {-# LANGUAGE Trustworthy #-}
src/Clash/Intel/ClockGen.hs view
@@ -1,100 +1,389 @@ {-| Copyright  :  (C) 2017-2018, Google Inc                   2019     , Myrtle Software+                  2022-2026, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -PLL and other clock-related components for Intel (Altera) FPGAs+This module contains functions for instantiating clock generators on Intel+FPGA's.++We suggest you use a clock generator even if your oscillator runs at the+frequency you want to run your circuit at.++A clock generator generates a stable clock signal for your design at a+configurable frequency. A clock generator in an FPGA is frequently referred to+as a PLL (Phase-Locked Loop). Intel also refers to them as PLL's in general but+because this is not consistently the case among FPGA vendors, we choose the+more generic term /clock generator/.++For most use cases, you would create two or more synthesis domains describing+the oscillator input and the domains you wish to use in your design, and use+the [regular functions](#g:regular) below to generate the clocks and resets of+the design from the oscillator input. There are use cases not covered by this+simpler approach, and the [unsafe functions](#g:unsafe) are provided as a means+to build advanced reset managers for the output domains. -} -{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE ExplicitForAll    #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}  module Clash.Intel.ClockGen-  ( altpll-  , alteraPll+  ( -- * Choosing domains+    -- $domains++    -- ** Caution: actual output frequency+    -- $caution++    -- * Using+    -- $using++    -- ** Example+    -- $example++    -- ** Type checking errors+    -- $error++    -- * Regular functions #regular#+    altpllSync+  , alteraPllSync+    -- * Unsafe functions #unsafe#+    -- $unsafe++    -- ** Example+    -- $unsafe_example+  , unsafeAltpll+  , unsafeAlteraPll   ) where -import Clash.Clocks           (clocks, Clocks)-import Clash.Promoted.Symbol  (SSymbol)+import GHC.TypeLits (type (<=))++import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Clocks+  (Clocks(..), ClocksSync(..), ClocksSyncCxt, NumOutClocksSync) import Clash.Signal.Internal-  (Signal, Clock, Reset)+  (Clock, Reset, KnownDomain, HasAsynchronousReset) +{- $domains+Synthesis domains are denoted by the type-parameter+@dom :: t'Clash.Signal.Domain'@ as occurring in for instance+@t'Clash.Signal.Signal' dom a@; see "Clash.Signal" for more information. For+each domain, there is only a single clock signal which clocks that domain;+mixing clock signals is a design error. Conversely, it is possible to clock+multiple domains using the same clock signal, in complex designs. --- | A clock source that corresponds to the Intel/Quartus \"ALTPLL\" component--- with settings to provide a stable 'Clock' from a single free-running input------ Only works when configured with:------ * 1 reference clock--- * 1 output clock--- * a reset port--- * a locked port+For the clock generator inputs, create a domain with the correct clock frequency+and reset polarity. For instance, if the clock input is a free-running clock at+a frequency of 50 MHz (a period of 20 ns or 20,000 ps), and the reset input+connected to the clock generator is /active-low/, the following will instantiate+the required input domain:++@+'Clash.Signal.createDomain' 'Clash.Signal.vSystem'{vName=\"DomInput\", vPeriod=20000, vResetPolarity='Clash.Signal.ActiveLow'}+@++If you haven't determined the frequency you want the design to run at, the+predefined 100 MHz domain t'Clash.Signal.System' can be a good starting point.+The datasheet for your FPGA specifies lower and upper limits, but the true+maximum frequency is determined by your design.++Supposing you need a clock running at 150 MHz for your design, the following+will instantiate a suitable domain:++@+'Clash.Signal.createDomain' 'Clash.Signal.vSystem'{vName=\"Dom150\", vPeriod='Clash.Signal.hzToPeriod' 150e6}+@++As the clock generator always reacts asynchronously to its reset input, it will+require that the @DomInput@ domain has asynchronous resets. The /unsafe/+functions below do not enforce this requirement on the domain (but they still+react asynchronously).+-}++{- $caution+The clock generator in the FPGA is limited in which clock frequencies it can+generate, especially when one clock generator has multiple outputs. The clock+generator will pick the attainable frequency closest to the requested frequency+(or possibly fail to synthesize). You can check the frequency that the IP core+chose by loading your design into the Quartus GUI. In the /Project Navigator/,+choose the /Hierarchy/ view and find your clock generator instance.+Double-click the instance to open Platform Designer and choose /Edit/+/Parameters.../. In the /Output Clocks/ page, the relevant column is /Actual/+/Settings/. If the actual value differs, copy the actual value back to the+Clash design.+-}++{- $using+The functions in this module will instantiate an Intel IP core for a clock+generator with 1 reference clock input and a reset input, and one or more output+clocks and a @locked@ output.++The [regular functions](#g:regular) incorporate 'Clash.Signal.resetSynchronizer'+to convert the @locked@ output port into a proper 'Reset' signal for the domains+which will keep the circuit in reset while the clock is still stabilizing.++The clock generator will react asynchronously to the incoming reset input. When+the reset input is asserted, the clock generator's @locked@ output will+deassert, in turn causing the 'Reset' output(s) of these functions to assert.++You can use 'Clash.Magic.setName' to give the IP instance a specific name, which+can be useful if you need to refer to the instance in Synopsys Design+Constraints files.++The output of the function for /n/ output clocks is a /2n/-tuple with clock and+reset outputs. The compiler needs to be able to fully determine the types of the+individual tuple elements from the context; the clock generator function itself+will not constrain them. If the types of the tuple elements cannot be inferred,+you can use pattern type signatures to specify the types. Supposing the+referenced domains have been created with 'Clash.Signal.createDomain', an+instance with a single output clock can be instantiated using:++@+(clk150 :: 'Clock' Dom150, rst150 :: 'Reset' Dom150) = 'alteraPllSync' clkIn rstIn+@++An instance with two clocks can be instantiated using++@+( clk100 :: 'Clock' Dom100+  , rst100 :: 'Reset' Dom100+  , clk150 :: 'Clock' Dom150+  , rst150 :: 'Reset' Dom150) = 'alteraPllSync' clkIn rstIn+@++and so on up to 18 clocks, following the general pattern @('Clock' dom1, 'Reset'+dom1, 'Clock' dom2, 'Reset' dom2, ..., 'Clock' dom/n/, 'Reset' dom/n/)@.++These examples show 'alteraPllSync' but it is the same for 'altpllSync' except+that it supports up to 5 clocks.++If you need access to the @locked@ output to build a more advanced reset+manager, you should use the [unsafe functions](#g:unsafe) instead.+-}++{- $example++When the oscillator connected to the FPGA runs at 50 MHz and the external reset+signal is /active-low/, this will generate a 150 MHz clock for use by the+circuit:++@+'Clash.Signal.createDomain' 'Clash.Signal.vSystem'{vName=\"DomInput\", vPeriod=20000, vResetPolarity='Clash.Signal.ActiveLow'}+'Clash.Signal.createDomain' 'Clash.Signal.vSystem'{vName=\"Dom150\", vPeriod='Clash.Signal.hzToPeriod' 150e6}++topEntity+  :: 'Clock' DomInput+  -> 'Reset' DomInput+  -> t'Clash.Signal.Signal' Dom150 Int+  -> t'Clash.Signal.Signal' Dom150 Int+topEntity clkIn rstIn = 'Clash.Signal.exposeClockResetEnable' (register 0) clk rst 'Clash.Signal.enableGen'+ where+  (clk, rst) = 'alteraPllSync' clkIn rstIn+@+-}++{- $error+When type checking cannot infer the types of the tuple elements, or they have+the wrong type, the GHC compiler will complain about satisfying @NumOutClocks@.+The error message on GHC 9.4 and up is:++>     • Cannot satisfy: clash-prelude-[...]:Clash.Clocks.Internal.NumOutClocks+>                         (clash-prelude-[...]:Clash.Clocks.Internal.ClocksSyncClocksInst+>                            ([...])+>                            DomInput) <= 18+>     • In the expression: alteraPllSync clkIn rstIn++On older GHC versions, the error message is:++>     • Couldn't match type ‘clash-prelude-[...]:Clash.Clocks.Internal.NumOutClocks+>                              (clash-prelude-[...]:Clash.Clocks.Internal.ClocksSyncClocksInst+>                                 ([...])+>                                 DomInput)+>                            <=? 18’+>                      with ‘'True’+>         arising from a use of ‘alteraPllSync’+>     • In the expression: alteraPllSync clkIn rstIn++The above error message is also emitted when trying to instantiate more than 18+output clocks, as it will fail to find an instance. As 'altpllSync' supports no+more than 5 clocks, trying to instantiate between 6 and 18 output clocks will+also cause a type checking error. On GHC 9.4 and up, the error for attempting to+instantiate 6 clocks is:++>     • Cannot satisfy: 6 <= 5+>     • In the expression: altpllSync clkIn rstIn++On older GHC versions, the error message is less clear:++>     • Couldn't match type ‘'False’ with ‘'True’+>         arising from a use of ‘altpllSync’+>     • In the expression: altpllSync clkIn rstIn+-}++{- $unsafe+These functions are provided for the cases where the [regular+functions](#g:regular) cannot provide the desired behavior, like when+implementing certain advanced reset managers. These functions directly expose+the /asynchronous/ @locked@ output of the clock generator, which will assert+when the output clocks are stable. @locked@ is usually connected to reset+circuitry to keep the circuit in reset while the clock is still stabilizing.++The output of the function for /n/ output clocks is an /n+1/-tuple with /n/+clock outputs and a @locked@ signal. The compiler needs to be able to fully+determine the types of the individual tuple elements from the context; the clock+generator function itself will not constrain them. If the types of the tuple+elements cannot be inferred, you can use pattern type signatures to specify the+types. Supposing the referenced domains have been created with+'Clash.Signal.createDomain', an instance with a single output clock can be+instantiated using:++@+(clk150 :: 'Clock' Dom150, locked :: t'Clash.Signal.Signal' Dom150 'Bool') = 'unsafeAlteraPll' clkIn rstIn+@++An instance with two clocks can be instantiated using++@+(clk100 :: 'Clock' Dom100+  , clk150 :: 'Clock' Dom150+  , locked :: t'Clash.Signal.Signal' Dom100 'Bool') = 'unsafeAlteraPll' clkIn rstIn+@++and so on up to 18 clocks, following the general pattern @('Clock' dom1, 'Clock'+dom2, ..., 'Clock' dom/n/, t'Clash.Signal.Signal' pllLock Bool)@.++These examples show 'unsafeAlteraPll' but it is the same for 'unsafeAltpll'+except that it supports up to 5 clocks.++Though the @locked@ output is specified as a @t'Clash.Signal.Signal' pllLock+'Bool'@, it is an asynchronous signal and will need to be synchronized before it+can be used as a (reset) signal. While in the examples above the+@locked@ output has been assigned the domain of one of the output clocks, the+domain @pllLock@ is left unrestricted. If the lock signal is to be used in+multiple domains, the @pllLock@ domain should probably be set to @domIn@ (the+domain of the input clock and reset). While in HDL+'Clash.Explicit.Signal.unsafeSynchronizer' is just a wire, in Haskell simulation+it does actually resample the signal, and by setting @pllLock@ to @domIn@, there+is no resampling of the simulated lock signal. The simulated lock signal is+simply the inverse of the reset input: @locked@ is asserted whenever the reset+input is deasserted and vice versa.+-}++{- $unsafe_example+@+'Clash.Signal.createDomain' 'Clash.Signal.vSystem'{vName=\"DomInput\", vPeriod=20000, vResetPolarity='Clash.Signal.ActiveLow'}+'Clash.Signal.createDomain' 'Clash.Signal.vSystem'{vName=\"Dom150\", vPeriod='Clash.Signal.hzToPeriod' 150e6}++topEntity+  :: 'Clock' DomInput+  -> 'Reset' DomInput+  -> t'Clash.Signal.Signal' Dom150 Int+  -> t'Clash.Signal.Signal' Dom150 Int+topEntity clkIn rstIn = 'Clash.Signal.exposeClockResetEnable' (register 0) clk rst 'Clash.Signal.enableGen'+ where+  (clk, locked) = 'unsafeAlteraPll' clkIn rstIn+  rst = 'Clash.Signal.resetSynchronizer' clk ('Clash.Signal.unsafeFromActiveLow' locked)+@++'Clash.Signal.resetSynchronizer' will keep the reset asserted when @locked@ is+'False', hence the use of @'Clash.Signal.unsafeFromActiveLow' locked@.+-}++-- | Instantiate an Intel clock generator corresponding to the Intel/Quartus+-- \"ALTPLL\" IP core (Arria GX, Arria II, Stratix IV, Stratix III, Stratix II,+-- Stratix, Cyclone 10 LP, Cyclone IV, Cyclone III, Cyclone II, Cyclone) with 1+-- reference clock input and a reset input and 1 to 5 output clocks and a+-- @locked@ output. ----- You must use type applications to specify the output clock domain, e.g.:+-- This function incorporates 'Clash.Signal.resetSynchronizer's to convert the+-- @locked@ output port into proper 'Reset' signals for the output domains which+-- will keep the circuit in reset while the clock is still stabilizing. ----- @--- -- outputs a clock running at 100 MHz--- altpll @@"50MHzDom" @@"100MHzDom" (SSymbol @@"altpll50to100") clk50 rst--- @-altpll-  :: forall domOut domIn name-   . SSymbol name-  -- ^ Name of the component, must correspond to the name entered in the QSys-  -- dialog.-  ---  -- For example, when you entered \"altPLL50\", instantiate as follows:-  ---  -- > SSymbol @"altPLL50"-  -> Clock domIn-  -- ^ Free running clock (i.e. a clock pin connected to a crystal)-  -> Reset domIn-  -- ^ Reset for the PLL-  -> (Clock domOut, Signal domOut Bool)-  -- ^ (Stable PLL clock, PLL lock)-altpll !_ = clocks-{-# NOINLINE altpll #-}+-- See also the [ALTPLL (Phase-Locked Loop) IP Core User Guide](https://www.intel.com/content/dam/www/programmable/us/en/pdfs/literature/ug/ug_altpll.pdf)+altpllSync ::+  forall t domIn .+  ( HasAsynchronousReset domIn+  , ClocksSyncCxt t domIn+  , NumOutClocksSync t domIn <= 5+  ) =>+  -- | Free running clock (e.g. a clock pin connected to a crystal oscillator)+  Clock domIn ->+  -- | Reset for the clock generator+  Reset domIn ->+  t+altpllSync clkIn rstIn =+  clocksResetSynchronizer (unsafeAltpll clkIn rstIn) clkIn --- | A clock source that corresponds to the Intel/Quartus \"Altera PLL\"--- component with settings to provide a stable 'Clock' from a single--- free-running input------ Only works when configured with:+-- | Instantiate an Intel clock generator corresponding to the Intel/Quartus+-- \"ALTPLL\" IP core (Arria GX, Arria II, Stratix IV, Stratix III, Stratix II,+-- Stratix, Cyclone 10 LP, Cyclone IV, Cyclone III, Cyclone II, Cyclone) with 1+-- reference clock input and a reset input and 1 to 5 output clocks and a+-- @locked@ output. ----- * 1 reference clock--- * 1-16 output clocks--- * a reset input port--- * a locked output port+-- __NB__: Because the clock generator reacts asynchronously to the incoming+-- reset input, the signal __must__ be glitch-free. ----- The number of output clocks depend this function's inferred result type. An--- instance with a single and double output clock can be instantiated using:+-- See also the [ALTPLL (Phase-Locked Loop) IP Core User Guide](https://www.intel.com/content/dam/www/programmable/us/en/pdfs/literature/ug/ug_altpll.pdf)+unsafeAltpll ::+  forall t domIn .+  ( KnownDomain domIn+  , Clocks t+  , ClocksCxt t+  , NumOutClocks t <= 5+  ) =>+  -- | Free running clock (e.g. a clock pin connected to a crystal oscillator)+  Clock domIn ->+  -- | Reset for the clock generator+  Reset domIn ->+  t+unsafeAltpll = clocks+{-# OPAQUE unsafeAltpll #-}+{-# ANN unsafeAltpll hasBlackBox #-}++-- | Instantiate an Intel clock generator corresponding to the Intel/Quartus+-- \"Altera PLL\" IP core (Arria V, Stratix V, Cyclone V) with 1 reference clock+-- input and a reset input and 1 to 18 output clocks and a @locked@ output. ----- @--- (outClk, pllLocked) = alteraPll clk rst--- @+-- This function incorporates 'Clash.Signal.resetSynchronizer's to convert the+-- @locked@ output port into proper 'Reset' signals for the output domains which+-- will keep the circuit in reset while the clock is still stabilizing. ----- and+-- See also the [Altera Phase-Locked Loop (Altera PLL) IP Core User Guide](https://www.intel.com/content/dam/www/programmable/us/en/pdfs/literature/ug/altera_pll.pdf)+alteraPllSync ::+  forall t domIn .+  ( HasAsynchronousReset domIn+  , ClocksSyncCxt t domIn+  , NumOutClocksSync t domIn <= 18+  ) =>+  -- | Free running clock (e.g. a clock pin connected to a crystal oscillator)+  Clock domIn ->+  -- | Reset for the clock generator+  Reset domIn ->+  t+alteraPllSync clkIn rstIn =+  clocksResetSynchronizer (unsafeAlteraPll clkIn rstIn) clkIn++-- | Instantiate an Intel clock generator corresponding to the Intel/Quartus+-- \"Altera PLL\" IP core (Arria V, Stratix V, Cyclone V) with 1 reference clock+-- input and a reset input and 1 to 18 output clocks and a @locked@ output. ----- @--- (outClk1, outClk2, pllLocked) = alteraPll clk rst--- @+-- __NB__: Because the clock generator reacts asynchronously to the incoming+-- reset input, the signal __must__ be glitch-free. ----- respectively.-alteraPll-  :: Clocks t-  => SSymbol name-  -- ^ Name of the component, must correspond to the name entered in the QSys-  -- dialog.-  ---  -- For example, when you entered \"alteraPLL50\", instantiate as follows:-  ---  -- > SSymbol @"alteraPLL50"-  -> Clock domIn-  -- ^ Free running clock (i.e. a clock pin connected to a crystal)-  -> Reset domIn-  -- ^ Reset for the PLL-  -> t-alteraPll !_ = clocks-{-# NOINLINE alteraPll #-}+-- See also the [Altera Phase-Locked Loop (Altera PLL) IP Core User Guide](https://www.intel.com/content/dam/www/programmable/us/en/pdfs/literature/ug/altera_pll.pdf)+unsafeAlteraPll ::+  forall t domIn .+  ( KnownDomain domIn+  , Clocks t+  , ClocksCxt t+  , NumOutClocks t <= 18+  ) =>+  -- | Free running clock (e.g. a clock pin connected to a crystal oscillator)+  Clock domIn ->+  -- | Reset for the clock generator+  Reset domIn ->+  t+unsafeAlteraPll = clocks+{-# OPAQUE unsafeAlteraPll #-}+{-# ANN unsafeAlteraPll hasBlackBox #-}
src/Clash/Intel/DDR.hs view
@@ -9,26 +9,24 @@ For general information about DDR primitives see "Clash.Explicit.DDR".  Note that a reset is only available on certain devices,-see ALTDDIO userguide for the specifics:+see the ALTDDIO user guide for the specifics: <https://www.altera.com/content/dam/altera-www/global/en_US/pdfs/literature/ug/ug_altddio.pdf> -} -{-# LANGUAGE CPP              #-}-{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash        #-}-{-# LANGUAGE TypeFamilies     #-}-{-# LANGUAGE TypeOperators    #-}-#if __GLASGOW_HASKELL__ >= 806-{-# LANGUAGE NoStarIsType #-}-#endif+{-# LANGUAGE TypeFamilies #-}  module Clash.Intel.DDR   ( altddioIn   , altddioOut+    -- * Internal+  , altddioIn#+  , altddioOut#   ) where +import Data.Bifunctor import GHC.Stack (HasCallStack, withFrozenCallStack)  import Clash.Annotations.Primitive (hasBlackBox)@@ -38,70 +36,104 @@ -- | Intel specific variant of 'ddrIn' implemented using the ALTDDIO_IN IP core. -- -- Reset values are @0@+--+-- Of the output pair @(o0, o1)@, @o0@ is the data clocked in on the /falling/+-- edge and @o1@ is the data clocked in on the /rising/ edge, and @o0@ comes+-- before @o1@ in time.+--+-- __NB__: This primitive only supports rising edges as the active edge. altddioIn-  :: ( HasCallStack-     , KnownConfiguration fast ('DomainConfiguration fast fPeriod edge reset init polarity)-     , KnownConfiguration slow ('DomainConfiguration slow (2*fPeriod) edge reset init polarity)-     , KnownNat m )+  :: forall deviceFamily a dom domDDR+   . HasCallStack+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => DomainActiveEdge dom ~ 'Rising+  => BitPack a   => SSymbol deviceFamily   -- ^ The FPGA family   --   -- For example this can be instantiated as follows:   --   -- > SSymbol @"Cyclone IV GX"-  -> Clock slow-  -- ^ clock-  -> Reset slow-  -- ^ reset-  -> Enable slow-  -- ^ Global enable-  -> Signal fast (BitVector m)+  -> Clock dom+  -> Reset dom+  -> Enable dom+  -> Signal domDDR a   -- ^ DDR input signal-  -> Signal slow (BitVector m,BitVector m)-  -- ^ normal speed output pairs-altddioIn _devFam clk rst en = withFrozenCallStack ddrIn# clk rst en 0 0 0-{-# NOINLINE altddioIn #-}-{-# ANN altddioIn hasBlackBox #-}+  -> Signal dom (a, a)+  -- ^ Normal speed output pair @(o0, o1)@+altddioIn devFam clk rst en =+  fmap (bimap unpack unpack) .+    withFrozenCallStack (altddioIn# devFam clk rst en) . fmap pack +altddioIn#+  :: forall deviceFamily n dom domDDR+   . HasCallStack+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => DomainActiveEdge dom ~ 'Rising+  => KnownNat n+  => SSymbol deviceFamily+  -> Clock dom+  -> Reset dom+  -> Enable dom+  -> Signal domDDR (BitVector n)+  -> Signal dom (BitVector n, BitVector n)+altddioIn# SSymbol clk rst en = withFrozenCallStack ddrIn# clk rst en 0 0 0+{-# OPAQUE altddioIn# #-}+{-# ANN altddioIn# hasBlackBox #-}+ -- | Intel specific variant of 'ddrOut' implemented using the ALTDDIO_OUT IP core. -- -- Reset value is @0@+--+-- Of the input pair @(i0, i1)@, @i0@ is the data clocked out on the /rising/+-- edge and @i1@ is the data clocked out on the /falling/ edge, and @i0@ comes+-- before @i1@ in time.+--+-- __NB__: This primitive only supports rising edges as the active edge. altddioOut-  :: ( HasCallStack-     , KnownConfiguration fast ('DomainConfiguration fast fPeriod edge reset init polarity)-     , KnownConfiguration slow ('DomainConfiguration slow (2*fPeriod) edge reset init polarity)-     , KnownNat m )+  :: forall deviceFamily a dom domDDR+   . HasCallStack+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => DomainActiveEdge dom ~ 'Rising+  => BitPack a   => SSymbol deviceFamily   -- ^ The FPGA family   --   -- For example this can be instantiated as follows:   --   -- > SSymbol @"Cyclone IV E"-  -> Clock slow-  -- ^ clock-  -> Reset slow-  -- ^ reset-  -> Enable slow-  -- ^ Global enable-  -> Signal slow (BitVector m,BitVector m)-  -- ^ normal speed input pair-  -> Signal fast (BitVector m)+  -> Clock dom+  -> Reset dom+  -> Enable dom+  -> Signal dom (a, a)+  -- ^ Normal speed input pair @(i0, i1)@+  -> Signal domDDR a   -- ^ DDR output signal altddioOut devFam clk rst en =-  uncurry (withFrozenCallStack altddioOut# devFam clk rst en) . unbundle+  fmap unpack . uncurry (withFrozenCallStack altddioOut# devFam clk rst en) .+    unbundle . fmap (bimap pack pack)  altddioOut#-  :: ( HasCallStack-     , KnownConfiguration fast ('DomainConfiguration fast fPeriod edge reset init polarity)-     , KnownConfiguration slow ('DomainConfiguration slow (2*fPeriod) edge reset init polarity)-     , KnownNat m )+  :: forall deviceFamily n dom domDDR+   . HasCallStack+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => DomainActiveEdge dom ~ 'Rising+  => KnownNat n   => SSymbol deviceFamily-  -> Clock slow-  -> Reset slow-  -> Enable slow-  -> Signal slow (BitVector m)-  -> Signal slow (BitVector m)-  -> Signal fast (BitVector m)-altddioOut# _ clk rst en = ddrOut# clk rst en 0-{-# NOINLINE altddioOut# #-}+  -> Clock dom+  -> Reset dom+  -> Enable dom+  -> Signal dom (BitVector n)+  -> Signal dom (BitVector n)+  -> Signal domDDR (BitVector n)+altddioOut# SSymbol clk rst en = ddrOut# clk rst en 0+{-# OPAQUE altddioOut# #-} {-# ANN altddioOut# hasBlackBox #-}
src/Clash/Magic.hs view
@@ -1,33 +1,124 @@ {-|-  Copyright   :  (C) 2019, Myrtle Software Ltd+  Copyright   :  (C) 2019-2023, Myrtle Software Ltd   License     :  BSD2 (see the file LICENSE)-  Maintainer  :  QBayLogic B.V. <clash@qbaylogic.com>+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com> -Control module instance, and register, names in generated HDL code.+Control naming and deduplication in the generated HDL code. Explicitly nameable+things include:++* Component (VHDL) / module ((System)Verilog) instances++* Registers++* Terms++Refer to "Clash.Annotations.TopEntity" for controlling naming of entities+(VHDL) / modules ((System)Verilog) and their ports. -} -{-# LANGUAGE DataKinds      #-}-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeOperators  #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE Trustworthy #-} -module Clash.Magic where+module Clash.Magic+  (+  -- ** Functions to control names of identifiers in HDL+    prefixName+  , suffixName+  , suffixNameP+  , suffixNameFromNat+  , suffixNameFromNatP+  , setName+  , nameHint -import Clash.NamedTypes ((:::))-import GHC.TypeLits     (Symbol)+  -- ** Functions to control Clash's (de)duplication mechanisms+  , deDup+  , noDeDup +  -- ** Utilities to differentiate between simulation and generating HDL+  , clashSimulation+  , SimOnly (..)++  -- * Static assertions+  , clashCompileError+  ) where++import Clash.Annotations.Primitive (Primitive(..), hasBlackBox)+import Clash.NamedTypes            ((:::))+import Clash.Promoted.Symbol       (SSymbol)+import Clash.XException            (NFDataX)+import Data.String.Interpolate     (__i)+import GHC.Generics                (Generic)+import GHC.Magic                   (noinline)+import GHC.Stack                   (HasCallStack, withFrozenCallStack)+import GHC.TypeLits                (Nat,Symbol)+ -- | Prefix instance and register names with the given 'Symbol' prefixName   :: forall (name :: Symbol) a . a -> name ::: a prefixName = id-{-# NOINLINE prefixName #-}+{-# OPAQUE prefixName #-}  -- | Suffix instance and register names with the given 'Symbol' suffixName   :: forall (name :: Symbol) a . a -> name ::: a suffixName = id-{-# NOINLINE suffixName #-}+{-# OPAQUE suffixName #-} +-- | Suffix instance and register names with the given 'Nat'+suffixNameFromNat+  :: forall (name :: Nat) a . a -> name ::: a+suffixNameFromNat = id+{-# OPAQUE suffixNameFromNat #-}++-- | Suffix instance and register names with the given 'Symbol', but add it+-- in front of other suffixes.+--+-- When you write+--+-- @+-- suffixName \@\"A\" (suffixName \@\"B\" f))+-- @+--+-- you get register and instance names inside /f/ with the suffix: "_B_A"+--+-- However, if you want them in the other order you can write:+--+-- @+-- suffixNameP \@\"A\" (suffixName \@\"B\" f))+-- @+--+-- so that names inside /f/ will have the suffix "_A_B"+suffixNameP+  :: forall (name :: Symbol) a . a -> name ::: a+suffixNameP = id+{-# OPAQUE suffixNameP #-}++-- | Suffix instance and register names with the given 'Nat', but add it in+-- front of other suffixes.+--+-- When you write+--+-- @+-- suffixNameNat \@1 (suffixName \@\"B\" f))+-- @+--+-- you get register and instance names inside /f/ with the suffix: "_B_1"+--+-- However, if you want them in the other order you can write:+--+-- @+-- suffixNameNatP \@1 (suffixName \@\"B\" f))+-- @+--+-- so that names inside /f/ will have the suffix "_1_B"+suffixNameFromNatP+  :: forall (name :: Nat) a . a -> name ::: a+suffixNameFromNatP = id+{-# OPAQUE suffixNameFromNatP #-}+ -- | Name the instance or register with the given 'Symbol', instead of using -- an auto-generated name. Pre- and suffixes annotated with 'prefixName' and -- 'suffixName' will be added to both instances and registers named with@@ -35,4 +126,180 @@ setName   :: forall (name :: Symbol) a . a -> name ::: a setName = id-{-# NOINLINE setName #-}+{-# OPAQUE setName #-}++-- | Name a given term, such as one of type 'Clash.Signal.Signal', using the+-- given 'SSymbol'. Results in a declaration with the name used as the+-- identifier in the generated HDL code.+--+-- Example usage:+--+-- @+-- nameHint (SSymbol @"identifier") term+-- @+--+-- __NB__: The given name should be considered a hint as it may be expanded,+-- e.g. if it collides with existing identifiers.+nameHint+  :: SSymbol sym+  -- ^ A hint for a name+  -> a -> a+nameHint = seq+{-# OPAQUE nameHint #-}+{-# ANN nameHint hasBlackBox #-}++-- | Force deduplication, i.e. share a function or operator between multiple+-- branches.+--+-- By default Clash converts+--+-- @+-- case x of+--   A -> 3 * y+--   B -> x * x+-- @+--+-- to+--+-- @+-- let f_arg0 = case x of {A -> 3; _ -> x}+--     f_arg1 = case x of {A -> y; _ -> x}+--     f_out  = f_arg0 * f_arg1+-- in  case x of+--       A -> f_out+--       B -> f_out+-- @+--+-- However, it won't do this for:+--+-- @+-- case x of+--   A -> 3 + y+--   B -> x + x+-- @+--+-- Because according to the internal heuristics the multiplexer introduced for+-- the deduplication are more expensive than the addition. This might not be+-- the case for your particular platform.+--+-- In these cases you can force Clash to deduplicate by:+--+-- @+-- case x of+--   A -> 'deDup' (3 + y)+--   B -> 'deDup' (x + x)+-- @+deDup+  :: forall a . a -> a+deDup = id+{-# OPAQUE deDup #-}++-- | Do not deduplicate, i.e. /keep/, an applied function inside a+-- case-alternative; do not try to share the function between multiple+-- branches.+--+-- By default Clash converts+--+-- @+-- case x of+--   A -> f 3 y+--   B -> f x x+--   C -> h x+-- @+--+-- to+--+-- @+-- let f_arg0 = case x of {A -> 3; _ -> x}+--     f_arg1 = case x of {A -> y; _ -> x}+--     f_out  = f f_arg0 f_arg1+-- in  case x of+--       A -> f_out+--       B -> f_out+--       C -> h x+-- @+--+-- i.e. it deduplicates functions (and operators such as multiplication) between+-- case-alternatives to save on area. This comes at the cost of multiplexing the+-- arguments for the deduplicated function.+--+-- There are two reasons you would want to stop Clash from doing this:+--+-- 1. The deduplicated function is in the critical path, and the addition of the+--    multiplexers further increased the propagation delay.+--+-- 2. Clash's heuristics were off, and the addition of the multiplexers actually+--    made the final circuit larger instead of smaller.+--+-- In these cases you want to tell Clash not to deduplicate:+--+-- @+-- case x of+--   A -> 'noDeDup' f 3 y+--   B -> f x x+--   C -> h x+-- @+--+-- Where the application of /f/ in the /A/-alternative is now explicitly not+-- deduplicated, and given that the /f/ in the B-alternative is the only+-- remaining application of /f/ in the case-expression it is also not+-- deduplicated.+--+-- Note that if the /C/-alternative also had an application of /f/, then the+-- applications of /f/ in the /B/- and /C/-alternatives would have been+-- deduplicated; i.e. the final circuit would have had two application of /f/.+noDeDup+  :: forall a . a -> a+noDeDup = id+{-# OPAQUE noDeDup #-}++-- | 'True' in Haskell/Clash simulation. Replaced by 'False' when generating HDL.+clashSimulation :: Bool+clashSimulation = noinline True+-- The 'noinline' is here to prevent SpecConstr from poking through the OPAQUE, see #2736+{-# OPAQUE clashSimulation #-}++-- | 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.+data SimOnly a = SimOnly a+  deriving (Generic, Eq, Ord, Foldable, Traversable, NFDataX)+{-# ANN SimOnly hasBlackBox #-}++instance Functor SimOnly where+  fmap f (SimOnly a) = SimOnly (f a)++instance Applicative SimOnly where+  pure = SimOnly+  (SimOnly f) <*> (SimOnly a) = SimOnly (f a)++instance Monad SimOnly where+  (SimOnly a) >>= f = f a++instance Semigroup a => Semigroup (SimOnly a) where+  (SimOnly a) <> (SimOnly b) = SimOnly (a <> b)++instance Monoid a => Monoid (SimOnly a) where+  mempty = SimOnly mempty++-- | Same as 'error' but will make HDL generation fail if included in the+-- final circuit.+--+-- This is useful for the error case of static assertions.+--+-- Note that the error message needs to be a literal, and during HDL generation+-- the error message does not include a stack trace, so it had better be+-- descriptive.+clashCompileError :: forall a . HasCallStack => String -> a+clashCompileError msg = withFrozenCallStack $ error msg+{-# OPAQUE clashCompileError #-}+{-# ANN clashCompileError (+  let primName = 'clashCompileError+  in InlineYamlPrimitive [minBound..] [__i|+    BlackBoxHaskell:+      name: #{primName}+      templateFunction: Clash.Primitives.Magic.clashCompileErrorBBF+    |]) #-}
src/Clash/NamedTypes.hs view
@@ -33,8 +33,7 @@  -} -{-# LANGUAGE PolyKinds     #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}  {-# LANGUAGE Safe #-}
+ src/Clash/Num/Erroring.hs view
@@ -0,0 +1,159 @@+{-+Copyright   : (C) 2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Clash.Num.Erroring+  ( Erroring+  , fromErroring  -- exported here because haddock https://github.com/haskell/haddock/issues/456+  , toErroring+  ) where++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Bits (Bits, FiniteBits)+import Data.Coerce (coerce)+import Data.Functor.Compose (Compose(..))+import Data.Hashable (Hashable)+import GHC.TypeLits (KnownNat, type (+))+import Test.QuickCheck (Arbitrary)++import Clash.Class.BitPack (BitPack)+import Clash.Class.Num (SaturationMode(SatError), SaturatingNum(..))+import Clash.Class.Parity (Parity)+import Clash.Class.Resize (Resize(..))+import Clash.XException (NFDataX, ShowX, errorX)++-- | An erroring number type is one where all operations return a+-- 'Clash.XException.XExecption' if they would go out of bounds for the+-- underlying type.+--+-- Numbers can be converted to error by default using 'toErroring'.+--+newtype Erroring a =+  Erroring { fromErroring :: a }+  deriving newtype+    ( Arbitrary+    , Binary+    , Bits+    , BitPack+    , Bounded+    , Eq+    , FiniteBits+    , Hashable+    , NFData+    , NFDataX+    , Ord+    , Parity+    , Show+    , ShowX+    )++{-# INLINE toErroring #-}+toErroring :: (SaturatingNum a) => a -> Erroring a+toErroring = Erroring++instance (Resize f) => Resize (Compose Erroring f) where+  {-# INLINE resize #-}+  resize+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Erroring f a+    -> Compose Erroring f b+  resize = coerce (resize @f @a @b)++  {-# INLINE zeroExtend #-}+  zeroExtend+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Erroring f a+    -> Compose Erroring f (b + a)+  zeroExtend = coerce (zeroExtend @f @a @b)++  {-# INLINE truncateB #-}+  truncateB+    :: forall a b+     . (KnownNat a)+    => Compose Erroring f (a + b)+    -> Compose Erroring f a+  truncateB = coerce (truncateB @f @a @b)++instance (Bounded a, Ord a, SaturatingNum a) => Num (Erroring a) where+  {-# INLINE (+) #-}+  (+) = coerce (satAdd @a SatError)++  {-# INLINE (-) #-}+  (-) = coerce (satSub @a SatError)++  {-# INLINE (*) #-}+  (*) = coerce (satMul @a SatError)++  negate x+    | 0 == x = x+    | 0 <= minBound @a = errorX "Erroring.negate: result exceeds minBound"+    | x == minBound = errorX "Erroring.negate: result exceeds maxBound"+    | otherwise = coerce (negate @a) x++  abs x+    | x == minBound && x < 0 = errorX "Erroring.abs: result exceeds maxBound"+    | otherwise = coerce (abs @a) x++  {-# INLINE signum #-}+  signum = coerce (signum @a)++  {-# INLINE fromInteger #-}+  -- TODO This does what the underlying representation does if the Integer+  -- is not in range (typically wrapping). It would be better if this also+  -- threw an XException, but in a way which remained synthesizable.+  fromInteger = coerce (fromInteger @a)++instance (Enum a, SaturatingNum a) => Enum (Erroring a) where+  {-# INLINE succ #-}+  succ = coerce (satSucc @a SatError)++  {-# INLINE pred #-}+  pred = coerce (satPred @a SatError)++  {-# INLINE toEnum #-}+  toEnum = coerce (toEnum @a)++  {-# INLINE fromEnum #-}+  fromEnum = coerce (fromEnum @a)++instance (Real a, SaturatingNum a) => Real (Erroring a) where+  {-# INLINE toRational #-}+  toRational = coerce (toRational @a)++instance (Integral a, SaturatingNum a) => Integral (Erroring a) where+  -- NOTE the seemingly duplicate "y < 0 && y == -1" guards against unsigned types+  quotRem x y+    | x == minBound && y < 0 && y == -1 =+        (errorX "Erroring.quotRem: result exceeds maxBound", 0)+    | otherwise = coerce (quotRem @a) x y++  divMod x y+    | x == minBound && y < 0 && y == -1 =+        (errorX "Erroring.divMod: result exceeds maxBound", 0)+    | otherwise = coerce (divMod @a) x y++  {-# INLINE toInteger #-}+  toInteger = coerce (toInteger @a)++instance (Fractional a, Ord a, SaturatingNum a) => Fractional (Erroring a) where+  {-# INLINE recip #-}+  recip = coerce (recip @a)++  {-# INLINE fromRational #-}+  -- TODO This does what the underlying representation does if the Rational+  -- is not in range (typically wrapping). It would be better if this also+  -- threw an XException, but in a way which remained synthesizable.+  fromRational = coerce (fromRational @a)++instance (RealFrac a, SaturatingNum a) => RealFrac (Erroring a) where+  {-# INLINE properFraction #-}+  properFraction :: forall b. (Integral b) => Erroring a -> (b, Erroring a)+  properFraction = coerce (properFraction @a @b)
+ src/Clash/Num/Overflowing.hs view
@@ -0,0 +1,200 @@+{-|+Copyright  :  (C) 2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Clash.Num.Overflowing+  ( Overflowing+  , fromOverflowing+  , hasOverflowed+  , toOverflowing+  , clearOverflow+  ) where++import Prelude hiding (even, odd)++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Function (on)+import Data.Hashable (Hashable)+import GHC.Generics (Generic)+import GHC.TypeLits (KnownNat, type (+))++import Clash.Class.BitPack (BitPack(..))+import Clash.Class.Num (SaturationMode(SatWrap, SatZero), SaturatingNum(..))+import Clash.Class.Parity (Parity(..))+import Clash.XException (NFDataX, ShowX)++-- | An overflowing number behaves similarly to a 'Clash.Num.Wrapping.Wrapping'+-- number, but also includes an overflow status flag which can be used to more+-- easily check if an overflow has occurred.+--+-- Numbers can be converted to be 'Overflowing' using 'toOverflowing'.+--+data Overflowing a = Overflowing+  { fromOverflowing :: a+    -- ^ Retrieve the value+  , hasOverflowed :: Bool+    -- ^ 'True' when a computation has overflowed+  }+  deriving stock (Generic, Show)+  deriving anyclass (Binary, Hashable, NFData, NFDataX, ShowX)++{-# INLINE toOverflowing #-}+toOverflowing :: a -> Overflowing a+toOverflowing x = Overflowing x False++{-# INLINE clearOverflow #-}+-- | Reset the overflow status flag to False.+clearOverflow :: Overflowing a -> Overflowing a+clearOverflow x = x { hasOverflowed = False }++instance (Eq a) => Eq (Overflowing a) where+  {-# INLINE (==) #-}+  (==) = (==) `on` fromOverflowing++instance (Ord a) => Ord (Overflowing a) where+  {-# INLINE compare #-}+  compare = compare `on` fromOverflowing++instance (BitPack a, KnownNat (BitSize a + 1)) => BitPack (Overflowing a) where+  type BitSize (Overflowing a) = BitSize a + 1+  -- Default instance, no explicit implementations.++instance (Parity a) => Parity (Overflowing a) where+  {-# INLINE even #-}+  even = even . fromOverflowing++  {-# INLINE odd #-}+  odd = odd . fromOverflowing++instance (Bounded a, Ord a, SaturatingNum a) => Num (Overflowing a) where+  Overflowing x a + Overflowing y b+    | y > 0+    , x > satSub SatWrap maxBound y+    = withOverflow True++    | y < 0+    , x < satSub SatWrap minBound y+    = withOverflow True++    | otherwise+    = withOverflow (a || b)+   where+    withOverflow = Overflowing (satAdd SatWrap x y)++  Overflowing x a - Overflowing y b+    | y < 0+    , x > satAdd SatWrap maxBound y+    = withOverflow True++    | y > 0+    , x < satAdd SatWrap minBound y+    = withOverflow True++    | otherwise+    = withOverflow (a || b)+   where+    withOverflow = Overflowing (satSub SatWrap x y)++  Overflowing x a * Overflowing y b+    | x /= 0+    , y /= 0+    , satMul SatZero x y == 0+    = withOverflow True++    | otherwise+    = withOverflow (a || b)+   where+    withOverflow = Overflowing (satMul SatWrap x y)++  negate n@(Overflowing x a)+    | 0 == x = n+    | 0 <= minBound @a = withOverflow True+    | x == minBound = withOverflow True+    | otherwise = withOverflow a+   where+    withOverflow = Overflowing (negate x)++  abs (Overflowing x a)+    | x == minBound && x < 0 = Overflowing x True+    | otherwise = Overflowing (abs x) a++  signum (Overflowing x a) =+    Overflowing (signum x) a++  -- TODO This does what the underlying representation does if the Integer+  -- is not in range (typically wrapping). It would be better if this also+  -- definitely wrapped, but in a way which remained synthesizable.+  fromInteger i =+    Overflowing (fromInteger i) False++instance (Bounded a) => Bounded (Overflowing a) where+  minBound = Overflowing minBound False+  maxBound = Overflowing maxBound False++instance (Enum a, Eq a, SaturatingNum a) => Enum (Overflowing a) where+  succ (Overflowing x a)+    | x == maxBound = withOverflow True+    | otherwise = withOverflow a+   where+    withOverflow = Overflowing (satSucc SatWrap x)++  pred (Overflowing x a)+    | x == minBound = withOverflow True+    | otherwise = withOverflow a+   where+    withOverflow = Overflowing (satPred SatWrap x)++  toEnum i = Overflowing (toEnum i) False+  fromEnum = fromEnum . fromOverflowing++instance (Real a, SaturatingNum a) => Real (Overflowing a) where+  toRational = toRational . fromOverflowing++instance (Integral a, SaturatingNum a) => Integral (Overflowing a) where+  -- NOTE the seemingly duplicate "y < 0 && y == -1" guards against unsigned types+  quotRem (Overflowing x a) (Overflowing y b)+    | x == minBound && y < 0 && y == -1 =+        withOverflow True++    | otherwise =+        withOverflow (a || b)+   where+    withOverflow o =+      let (q, r) = quotRem x y+       in (Overflowing q o, Overflowing r False)++  divMod (Overflowing x a) (Overflowing y b)+    | x == minBound && y < 0 && y == -1 =+        withOverflow True++    | otherwise =+        withOverflow (a || b)+   where+    withOverflow o =+      let (d, m) = divMod x y+       in (Overflowing d o, Overflowing m False)++  toInteger = toInteger . fromOverflowing++instance (Fractional a, Ord a, SaturatingNum a) => Fractional (Overflowing a) where+  recip x =+    x { fromOverflowing = recip (fromOverflowing x) }++  -- TODO This does what the underlying representation does if the Rational+  -- is not in range (typically wrapping). It would be better if this also+  -- definitely wrapped, but in a way which remained synthesizable.+  fromRational i =+    Overflowing (fromRational i) False++instance (RealFrac a, SaturatingNum a) => RealFrac (Overflowing a) where+  properFraction (Overflowing x _) =+    let (n, f) = properFraction x+     in (n, Overflowing f False)
+ src/Clash/Num/Saturating.hs view
@@ -0,0 +1,158 @@+{-+Copyright   : (C) 2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Clash.Num.Saturating+  ( Saturating+  , fromSaturating  -- exported here because haddock https://github.com/haskell/haddock/issues/456+  , toSaturating+  ) where++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Bits (Bits, FiniteBits)+import Data.Coerce (coerce)+import Data.Functor.Compose (Compose(..))+import Data.Hashable (Hashable)+import GHC.TypeLits (KnownNat, type (+))+import Test.QuickCheck (Arbitrary)++import Clash.Class.BitPack (BitPack)+import Clash.Class.Num (SaturationMode(SatBound), SaturatingNum(..))+import Clash.Class.Parity (Parity)+import Clash.Class.Resize (Resize(..))+import Clash.XException (NFDataX, ShowX)++-- | A saturating number type is one where all operations saturate at the+-- bounds of the underlying type, i.e. operations which overflow return+-- 'maxBound' and operations that underflow return 'minBound'.+--+-- Numbers can be converted to saturate by default using 'toSaturating'.+--+newtype Saturating a =+  Saturating { fromSaturating :: a }+  deriving newtype+    ( Arbitrary+    , Binary+    , Bits+    , BitPack+    , Bounded+    , Eq+    , FiniteBits+    , Hashable+    , NFData+    , NFDataX+    , Ord+    , Parity+    , Show+    , ShowX+    )++{-# INLINE toSaturating #-}+toSaturating :: (SaturatingNum a) => a -> Saturating a+toSaturating = Saturating++instance (Resize f) => Resize (Compose Saturating f) where+  {-# INLINE resize #-}+  resize+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Saturating f a+    -> Compose Saturating f b+  resize = coerce (resize @f @a @b)++  {-# INLINE zeroExtend #-}+  zeroExtend+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Saturating f a+    -> Compose Saturating f (b + a)+  zeroExtend = coerce (zeroExtend @f @a @b)++  {-# INLINE truncateB #-}+  truncateB+    :: forall a b+     . (KnownNat a)+    => Compose Saturating f (a + b)+    -> Compose Saturating f a+  truncateB = coerce (truncateB @f @a @b)++instance (Ord a, SaturatingNum a) => Num (Saturating a) where+  {-# INLINE (+) #-}+  (+) = coerce (satAdd @a SatBound)++  {-# INLINE (-) #-}+  (-) = coerce (satSub @a SatBound)++  {-# INLINE (*) #-}+  (*) = coerce (satMul @a SatBound)++  negate x+    | 0 <= minBound @a = 0+    | x == minBound = maxBound+    | otherwise = coerce (negate @a) x++  abs x+    | x == minBound && x < 0 = maxBound+    | otherwise = coerce (abs @a) x++  {-# INLINE signum #-}+  signum = coerce (signum @a)++  {-# INLINE fromInteger #-}+  -- TODO This does what the underlying representation does if the Integer+  -- is not in range (typically wrapping). It would be better if this also+  -- saturated, but in a way which remained synthesizable.+  fromInteger = coerce (fromInteger @a)++instance (Enum a, SaturatingNum a) => Enum (Saturating a) where+  {-# INLINE succ #-}+  -- Deliberately breaks the Enum law that succ maxBound ~> error+  succ = coerce (satSucc @a SatBound)++  {-# INLINE pred #-}+  -- Deliberately breaks the Enum law that pred minBound ~> error+  pred = coerce (satPred @a SatBound)++  {-# INLINE toEnum #-}+  toEnum = coerce (toEnum @a)++  {-# INLINE fromEnum #-}+  fromEnum = coerce (fromEnum @a)++instance (Real a, SaturatingNum a) => Real (Saturating a) where+  {-# INLINE toRational #-}+  toRational = coerce (toRational @a)++instance (Integral a, SaturatingNum a) => Integral (Saturating a) where+  -- NOTE the seemingly duplicate "y < 0 && y == -1" guards against unsigned types+  quotRem x y+    | x == minBound && y < 0 && y == -1 = (maxBound, 0)+    | otherwise = coerce (quotRem @a) x y++  divMod x y+    | x == minBound && y < 0 && y == -1 = (maxBound, 0)+    | otherwise = coerce (divMod @a) x y++  {-# INLINE toInteger #-}+  toInteger = coerce (toInteger @a)++instance (Fractional a, Ord a, SaturatingNum a) => Fractional (Saturating a) where+  {-# INLINE recip #-}+  recip = coerce (recip @a)++  {-# INLINE fromRational #-}+  -- TODO This does what the underlying representation does if the Rational+  -- is not in range (typically wrapping). It would be better if this also+  -- saturated, but in a way which remained synthesizable.+  fromRational = coerce (fromRational @a)++instance (Ord a, RealFrac a, SaturatingNum a) => RealFrac (Saturating a) where+  {-# INLINE properFraction #-}+  properFraction :: forall b. (Integral b) => Saturating a -> (b, Saturating a)+  properFraction = coerce (properFraction @a @b)
+ src/Clash/Num/Wrapping.hs view
@@ -0,0 +1,153 @@+{-+Copyright   : (C) 2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Clash.Num.Wrapping+  ( Wrapping(..)+  , toWrapping+  ) where++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Bits (Bits, FiniteBits)+import Data.Coerce (coerce)+import Data.Functor.Compose (Compose(..))+import Data.Hashable (Hashable)+import GHC.TypeLits (KnownNat, type (+))+import Test.QuickCheck (Arbitrary)++import Clash.Class.BitPack (BitPack)+import Clash.Class.Num (SaturationMode(SatWrap), SaturatingNum(..))+import Clash.Class.Parity (Parity)+import Clash.Class.Resize (Resize(..))+import Clash.XException (NFDataX, ShowX)++-- | A wrapping number type is one where all operations wrap between minBound+-- and maxBound (and vice-versa) if the result goes out of bounds for the+-- underlying type.+--+-- Numbers can be converted to wrap by default using 'toWrapping'.+--+newtype Wrapping a =+  Wrapping { fromWrapping :: a }+  deriving newtype+    ( Arbitrary+    , Binary+    , Bits+    , BitPack+    , Bounded+    , Eq+    , FiniteBits+    , Hashable+    , NFData+    , NFDataX+    , Ord+    , Parity+    , Show+    , ShowX+    )++{-# INLINE toWrapping #-}+toWrapping :: (SaturatingNum a) => a -> Wrapping a+toWrapping = Wrapping++instance (Resize f) => Resize (Compose Wrapping f) where+  {-# INLINE resize #-}+  resize+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Wrapping f a+    -> Compose Wrapping f b+  resize = coerce (resize @f @a @b)++  {-# INLINE zeroExtend #-}+  zeroExtend+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Wrapping f a+    -> Compose Wrapping f (b + a)+  zeroExtend = coerce (zeroExtend @f @a @b)++  {-# INLINE truncateB #-}+  truncateB+    :: forall a b+     . (KnownNat a)+    => Compose Wrapping f (a + b)+    -> Compose Wrapping f a+  truncateB = coerce (truncateB @f @a @b)++instance (SaturatingNum a) => Num (Wrapping a) where+  {-# INLINE (+) #-}+  (+) = coerce (satAdd @a SatWrap)++  {-# INLINE (-) #-}+  (-) = coerce (satSub @a SatWrap)++  {-# INLINE (*) #-}+  (*) = coerce (satMul @a SatWrap)++  -- Assume the default behaviour is to wrap anyway.++  {-# INLINE negate #-}+  negate = coerce (negate @a)++  {-# INLINE abs #-}+  abs = coerce (abs @a)++  {-# INLINE signum #-}+  signum = coerce (signum @a)++  {-# INLINE fromInteger #-}+  -- TODO This does what the underlying representation does if the Integer+  -- is not in range (typically wrapping). It would be better if this also+  -- definitely wrapped, but in a way which remained synthesizable.+  fromInteger = coerce (fromInteger @a)++instance (Enum a, SaturatingNum a) => Enum (Wrapping a) where+  {-# INLINE succ #-}+  -- Deliberately breaks the Enum law that succ maxBound ~> error+  succ = coerce (satSucc @a SatWrap)++  {-# INLINE pred #-}+  -- Deliberately breaks the Enum law that pred minBound ~> error+  pred = coerce (satPred @a SatWrap)++  {-# INLINE toEnum #-}+  toEnum = coerce (toEnum @a)++  {-# INLINE fromEnum #-}+  fromEnum = coerce (fromEnum @a)++instance (Real a, SaturatingNum a) => Real (Wrapping a) where+  {-# INLINE toRational #-}+  toRational = coerce (toRational @a)++instance (Integral a, SaturatingNum a) => Integral (Wrapping a) where+  {-# INLINE quotRem #-}+  quotRem = coerce (quotRem @a)++  {-# INLINE divMod #-}+  divMod = coerce (divMod @a)++  {-# INLINE toInteger #-}+  toInteger = coerce (toInteger @a)++instance (Fractional a, SaturatingNum a) => Fractional (Wrapping a) where+  {-# INLINE recip #-}+  recip = coerce (recip @a)++  {-# INLINE fromRational #-}+  -- TODO This does what the underlying representation does if the Rational+  -- is not in range (typically wrapping). It would be better if this also+  -- definitely wrapped, but in a way which remained synthesizable.+  fromRational = coerce (fromRational @a)++instance (RealFrac a, SaturatingNum a) => RealFrac (Wrapping a) where+  {-# INLINE properFraction #-}+  properFraction :: forall b. (Integral b) => Wrapping a -> (b, Wrapping a)+  properFraction = coerce (properFraction @a @b)
+ src/Clash/Num/Zeroing.hs view
@@ -0,0 +1,157 @@+{-+Copyright   : (C) 2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Clash.Num.Zeroing+  ( Zeroing+  , fromZeroing  -- exported here because haddock https://github.com/haskell/haddock/issues/456+  , toZeroing+  ) where++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Bits (Bits, FiniteBits)+import Data.Coerce (coerce)+import Data.Functor.Compose (Compose(..))+import Data.Hashable (Hashable)+import GHC.TypeLits (KnownNat, type (+))+import Test.QuickCheck (Arbitrary)++import Clash.Class.BitPack (BitPack)+import Clash.Class.Num (SaturationMode(SatZero), SaturatingNum(..))+import Clash.Class.Parity (Parity)+import Clash.Class.Resize (Resize(..))+import Clash.XException (NFDataX, ShowX)++-- | A zeroing number type is one where all operations return zero if they go+-- out of bounds for the underlying type.+--+-- Numbers can be converted to zero by default using `toZeroing`.+--+newtype Zeroing a =+  Zeroing { fromZeroing :: a }+  deriving newtype+    ( Arbitrary+    , Binary+    , Bits+    , BitPack+    , Bounded+    , Eq+    , FiniteBits+    , Hashable+    , NFData+    , NFDataX+    , Ord+    , Parity+    , Show+    , ShowX+    )++{-# INLINE toZeroing #-}+toZeroing :: (SaturatingNum a) => a -> Zeroing a+toZeroing = Zeroing++instance (Resize f) => Resize (Compose Zeroing f) where+  {-# INLINE resize #-}+  resize+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Zeroing f a+    -> Compose Zeroing f b+  resize = coerce (resize @f @a @b)++  {-# INLINE zeroExtend #-}+  zeroExtend+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Zeroing f a+    -> Compose Zeroing f (b + a)+  zeroExtend = coerce (zeroExtend @f @a @b)++  {-# INLINE truncateB #-}+  truncateB+    :: forall a b+     . (KnownNat a)+    => Compose Zeroing f (a + b)+    -> Compose Zeroing f a+  truncateB = coerce (truncateB @f @a @b)++instance (Bounded a, Ord a, SaturatingNum a) => Num (Zeroing a) where+  {-# INLINE (+) #-}+  (+) = coerce (satAdd @a SatZero)++  {-# INLINE (-) #-}+  (-) = coerce (satSub @a SatZero)++  {-# INLINE (*) #-}+  (*) = coerce (satMul @a SatZero)++  negate x+    | 0 <= minBound @a = 0+    | x == minBound = 0+    | otherwise = coerce (negate @a) x++  abs x+    | x == minBound && x < 0 = 0+    | otherwise = coerce (abs @a) x++  {-# INLINE signum #-}+  signum = coerce (signum @a)++  {-# INLINE fromInteger #-}+  -- TODO This does what the underlying representation does if the Integer+  -- is not in range (typically wrapping). It would be better if this also+  -- returned zero, but in a way which remained synthesizable.+  fromInteger = coerce (fromInteger @a)++instance (Enum a, SaturatingNum a) => Enum (Zeroing a) where+  {-# INLINE succ #-}+  -- Deliberately breaks the Enum law that succ maxBound ~> error+  succ = coerce (satSucc @a SatZero)++  {-# INLINE pred #-}+  -- Deliberately breaks the Enum law that pred minBound ~> error+  pred = coerce (satPred @a SatZero)++  {-# INLINE toEnum #-}+  toEnum = coerce (toEnum @a)++  {-# INLINE fromEnum #-}+  fromEnum = coerce (fromEnum @a)++instance (Real a, SaturatingNum a) => Real (Zeroing a) where+  {-# INLINE toRational #-}+  toRational = coerce (toRational @a)++instance (Integral a, SaturatingNum a) => Integral (Zeroing a) where+  -- NOTE the seemingly duplicate "y < 0 && y == -1" guards against unsigned types+  quotRem x y+    | x == minBound && y < 0 && y == -1 = (0, 0)+    | otherwise = coerce (quotRem @a) x y++  divMod x y+    | x == minBound && y < 0 && y == -1 = (0, 0)+    | otherwise = coerce (divMod @a) x y++  {-# INLINE toInteger #-}+  toInteger = coerce (toInteger @a)++instance (Fractional a, Ord a, SaturatingNum a) => Fractional (Zeroing a) where+  {-# INLINE recip #-}+  recip = coerce (recip @a)++  {-# INLINE fromRational #-}+  -- TODO This does what the underlying representation does if the Rational+  -- is not in range (typically wrapping). It would be better if this also+  -- returned zero, but in a way which remained synthesizable.+  fromRational = coerce (fromRational @a)++instance (RealFrac a, SaturatingNum a) => RealFrac (Zeroing a) where+  {-# INLINE properFraction #-}+  properFraction :: forall b. (Integral b) => Zeroing a -> (b, Zeroing a)+  properFraction = coerce (properFraction @a @b)
src/Clash/Prelude.hs view
@@ -1,9 +1,10 @@ {-|   Copyright   :  (C) 2013-2016, University of Twente,                      2017-2019, Myrtle Software Ltd-                     2017     , Google Inc.+                     2017     , Google Inc.,+                     2021-2025, QBayLogic B.V.   License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>    Clash is a functional hardware description language that borrows both its   syntax and semantics from the functional programming language Haskell. The@@ -28,15 +29,15 @@     have overlapping definitions.    For now, "Clash.Prelude" is also the best starting point for exploring the-  library. A preliminary version of a tutorial can be found in "Clash.Tutorial".-  Some circuit examples can be found in "Clash.Examples".+  library. A preliminary version of a tutorial can be found at+  https://docs.clash-lang.org/tutorial. Some circuit examples can be found in+  "Clash.Examples". -} -{-# LANGUAGE CPP               #-}-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeOperators     #-}  {-# LANGUAGE Unsafe #-} @@ -45,22 +46,24 @@ module Clash.Prelude   ( -- * Creating synchronous sequential circuits     mealy+  , mealyS   , mealyB+  , mealySB   , (<^>)   , moore   , mooreB   , registerB-#ifdef CLASH_MULTIPLE_HIDDEN-    -- * Synchronizer circuits for safe clock domain crossings-  , dualFlipFlopSynchronizer-  , asyncFIFOSynchronizer-#endif     -- * ROMs   , asyncRom   , asyncRomPow2   , rom   , romPow2-    -- ** ROMs initialized with a data file+    -- ** ROMs defined by a 'MemBlob'+  , asyncRomBlob+  , asyncRomBlobPow2+  , romBlob+  , romBlobPow2+    -- ** ROMs defined by a data file   , asyncRomFile   , asyncRomFilePow2   , romFile@@ -68,17 +71,28 @@     -- * RAM primitives with a combinational read port   , asyncRam   , asyncRamPow2-    -- * BlockRAM primitives+    -- * Block RAM primitives   , blockRam   , blockRamPow2   , blockRamU   , blockRam1   , E.ResetStrategy(..)-    -- ** BlockRAM primitives initialized with a data file+    -- ** Block RAM primitives initialized with a 'MemBlob'+  , blockRamBlob+  , blockRamBlobPow2+    -- *** Creating and inspecting 'MemBlob'+  , MemBlob+  , createMemBlob+  , memBlobTH+  , unpackMemBlob+    -- ** Block RAM primitives initialized with a data file   , blockRamFile   , blockRamFilePow2-    -- ** BlockRAM read/write conflict resolution+    -- ** Block RAM read/write conflict resolution   , readNew+    -- ** True dual-port block RAM+  , trueDualPortBlockRam+  , RamOp(..)     -- * Utility functions   , window   , windowD@@ -99,13 +113,9 @@     -- ** Synchronous signals   , module Clash.Signal   , module Clash.Signal.Delayed-    -- ** DataFlow interface-  , module Clash.Prelude.DataFlow     -- ** Datatypes     -- *** Bit vectors   , module Clash.Sized.BitVector-  , module Clash.Prelude.BitIndex-  , module Clash.Prelude.BitReduction     -- *** Arbitrary-width numbers   , module Clash.Sized.Signed   , module Clash.Sized.Unsigned@@ -132,18 +142,25 @@     -- ** Template Haskell   , Lift (..)     -- ** Type classes+    -- *** Number conversion+  , NumConvert+  , numConvert+  , MaybeNumConvert+  , maybeNumConvert     -- *** Clash+  , AutoReg, autoReg, deriveAutoReg   , module Clash.Class.BitPack   , module Clash.Class.Exp   , module Clash.Class.Num+  , module Clash.Class.Parity   , module Clash.Class.Resize     -- *** Other   , module Control.Applicative   , module Data.Bits-  , module Data.Default.Class+  , module Data.Default+  , module Data.Kind     -- ** Exceptions   , module Clash.XException-  , undefined     -- ** Named types   , module Clash.NamedTypes     -- ** Hidden arguments@@ -158,31 +175,33 @@  import           Control.Applicative import           Data.Bits-import           Data.Default.Class+import           Data.Default+import           Data.Kind (Type, Constraint)+import           GHC.Stack                   (HasCallStack) import           GHC.TypeLits+  hiding (SNat, SSymbol, fromSNat) import           GHC.TypeLits.Extra import           Language.Haskell.TH.Syntax  (Lift(..)) import           Clash.HaskellPrelude  import           Clash.Annotations.TopEntity+import           Clash.Class.AutoReg         (AutoReg, deriveAutoReg) import           Clash.Class.BitPack import           Clash.Class.Exp import           Clash.Class.Num+import           Clash.Class.NumConvert+import           Clash.Class.Parity import           Clash.Class.Resize import qualified Clash.Explicit.Prelude      as E import           Clash.Hidden import           Clash.Magic import           Clash.NamedTypes-import           Clash.Prelude.BitIndex-import           Clash.Prelude.BitReduction import           Clash.Prelude.BlockRam+import           Clash.Prelude.BlockRam.Blob import           Clash.Prelude.BlockRam.File-import           Clash.Prelude.DataFlow+import           Clash.Prelude.ROM.Blob import           Clash.Prelude.ROM.File import           Clash.Prelude.Safe-#ifdef CLASH_MULTIPLE_HIDDEN-import           Clash.Prelude.Synchronizer-#endif import           Clash.Promoted.Nat import           Clash.Promoted.Nat.TH import           Clash.Promoted.Nat.Literals@@ -193,8 +212,9 @@ import           Clash.Sized.RTree import           Clash.Sized.Signed import           Clash.Sized.Unsigned-import           Clash.Sized.Vector-import           Clash.Signal+import           Clash.Sized.Vector hiding (fromList, unsafeFromList)+import           Clash.Signal hiding+  (HiddenClockName, HiddenResetName, HiddenEnableName) import           Clash.Signal.Delayed import           Clash.Signal.Trace import           Clash.XException@@ -207,15 +227,13 @@  {- $hiding "Clash.Prelude" re-exports most of the Haskell "Prelude" with the exception of-the following: (++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head,-init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr,-splitAt, tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3.--It instead exports the identically named functions defined in terms of-'Clash.Sized.Vector.Vec' at "Clash.Sized.Vector".+those functions that the Clash API defines to work on 'Vec' from+"Clash.Sized.Vector" instead of on lists as the Haskell Prelude does.+In addition, for the 'Clash.Class.Parity.odd' and 'Clash.Class.Parity.even'+functions a type class called 'Clash.Class.Parity.Parity' is available at+"Clash.Class.Parity". -} - -- | Give a window over a 'Signal' -- -- > window4 :: HiddenClockResetEnable dom@@ -223,7 +241,7 @@ -- > window4 = window -- -- >>> simulateB @System window4 [1::Int,2,3,4,5] :: [Vec 4 Int]--- [<1,0,0,0>,<2,1,0,0>,<3,2,1,0>,<4,3,2,1>,<5,4,3,2>...+-- [1 :> 0 :> 0 :> 0 :> Nil,2 :> 1 :> 0 :> 0 :> Nil,3 :> 2 :> 1 :> 0 :> Nil,4 :> 3 :> 2 :> 1 :> Nil,5 :> 4 :> 3 :> 2 :> Nil,... -- ... window   :: ( HiddenClockResetEnable dom@@ -246,7 +264,7 @@ -- > windowD3 = windowD -- -- >>> simulateB @System windowD3 [1::Int,2,3,4] :: [Vec 3 Int]--- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>...+-- [0 :> 0 :> 0 :> Nil,1 :> 0 :> 0 :> Nil,2 :> 1 :> 0 :> Nil,3 :> 2 :> 1 :> Nil,4 :> 3 :> 2 :> Nil,... -- ... windowD   :: ( HiddenClockResetEnable dom@@ -259,3 +277,11 @@   -- ^ Window of at least size 1 windowD = hideClockResetEnable E.windowD {-# INLINE windowD #-}++-- | Implicit version of 'Clash.Class.AutoReg.autoReg'+autoReg+  :: (HasCallStack, HiddenClockResetEnable dom, AutoReg a)+  => a+  -> Signal dom a+  -> Signal dom a+autoReg = hideClockResetEnable E.autoReg
− src/Clash/Prelude/BitIndex.hs 
@@ -1,152 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash        #-}-{-# LANGUAGE TypeOperators    #-}-{-# LANGUAGE TypeFamilies     #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module Clash.Prelude.BitIndex where--import GHC.TypeLits                   (KnownNat, type (+), type (-))--import Clash.Class.BitPack            (BitPack (..))-import Clash.Promoted.Nat             (SNat)-import Clash.Sized.Internal.BitVector (BitVector, Bit, index#, lsb#, msb#,-                                       replaceBit#, setSlice#, slice#, split#)--{- $setup->>> :set -XDataKinds->>> import Clash.Prelude--}--{-# INLINE (!) #-}--- | Get the bit at the specified bit index.------ __NB:__ Bit indices are __DESCENDING__.------ >>> pack (7 :: Unsigned 6)--- 00_0111--- >>> (7 :: Unsigned 6) ! 1--- 1--- >>> (7 :: Unsigned 6) ! 5--- 0--- >>> (7 :: Unsigned 6) ! 6--- *** Exception: (!): 6 is out of range [5..0]--- ...-(!) :: (BitPack a, KnownNat (BitSize a), Enum i) => a -> i -> Bit-(!) v i = index# (pack v) (fromEnum i)--{-# INLINE slice #-}--- | Get a slice between bit index @m@ and and bit index @n@.------ __NB:__ Bit indices are __DESCENDING__.------ >>> pack (7 :: Unsigned 6)--- 00_0111--- >>> slice d4 d2 (7 :: Unsigned 6)--- 001--- >>> slice d6 d4 (7 :: Unsigned 6)--- <BLANKLINE>--- <interactive>:...---     • Couldn't match type ‘7 + i0’ with ‘6’---         arising from a use of ‘slice’---       The type variable ‘i0’ is ambiguous---     • In the expression: slice d6 d4 (7 :: Unsigned 6)---       In an equation for ‘it’: it = slice d6 d4 (7 :: Unsigned 6)-slice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => SNat m -> SNat n -> a-      -> BitVector (m + 1 - n)-slice m n v = slice# (pack v) m n--{-# INLINE split #-}--- | Split a value of a bit size @m + n@ into a tuple of values with size @m@--- and size @n@.------ >>> pack (7 :: Unsigned 6)--- 00_0111--- >>> split (7 :: Unsigned 6) :: (BitVector 2, BitVector 4)--- (00,0111)-split :: (BitPack a, BitSize a ~ (m + n), KnownNat n) => a-      -> (BitVector m, BitVector n)-split v = split# (pack v)--{-# INLINE replaceBit #-}--- | Set the bit at the specified index------ __NB:__ Bit indices are __DESCENDING__.------ >>> pack (-5 :: Signed 6)--- 11_1011--- >>> replaceBit 4 0 (-5 :: Signed 6)--- -21--- >>> pack (-21 :: Signed 6)--- 10_1011--- >>> replaceBit 5 0 (-5 :: Signed 6)--- 27--- >>> pack (27 :: Signed 6)--- 01_1011--- >>> replaceBit 6 0 (-5 :: Signed 6)--- *** Exception: replaceBit: 6 is out of range [5..0]--- ...-replaceBit :: (BitPack a, KnownNat (BitSize a), Enum i) => i -> Bit -> a-           -> a-replaceBit i b v = unpack (replaceBit# (pack v) (fromEnum i) b)--{-# INLINE setSlice #-}--- | Set the bits between bit index @m@ and bit index @n@.------ __NB:__ Bit indices are __DESCENDING__.------ >>> pack (-5 :: Signed 6)--- 11_1011--- >>> setSlice d4 d3 0 (-5 :: Signed 6)--- -29--- >>> pack (-29 :: Signed 6)--- 10_0011--- >>> setSlice d6 d5 0 (-5 :: Signed 6)--- <BLANKLINE>--- <interactive>:...---     • Couldn't match type ‘7 + i0’ with ‘6’---         arising from a use of ‘setSlice’---       The type variable ‘i0’ is ambiguous---     • In the expression: setSlice d6 d5 0 (- 5 :: Signed 6)---       In an equation for ‘it’: it = setSlice d6 d5 0 (- 5 :: Signed 6)-setSlice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => SNat m -> SNat n-         -> BitVector (m + 1 - n) -> a -> a-setSlice m n w v = unpack (setSlice# (pack v) m n w)--{-# INLINE msb #-}--- | Get the most significant bit.------ >>> pack (-4 :: Signed 6)--- 11_1100--- >>> msb (-4 :: Signed 6)--- 1--- >>> pack (4 :: Signed 6)--- 00_0100--- >>> msb (4 :: Signed 6)--- 0-msb :: (BitPack a, KnownNat (BitSize a)) => a -> Bit-msb v = msb# (pack v)--{-# INLINE lsb #-}--- | Get the least significant bit.------ >>> pack (-9 :: Signed 6)--- 11_0111--- >>> lsb (-9 :: Signed 6)--- 1--- >>> pack (-8 :: Signed 6)--- 11_1000--- >>> lsb (-8 :: Signed 6)--- 0-lsb :: BitPack a => a -> Bit-lsb v = lsb# (pack v)
− src/Clash/Prelude/BitReduction.hs 
@@ -1,85 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash        #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module Clash.Prelude.BitReduction where--import GHC.TypeLits                   (KnownNat)--import Clash.Class.BitPack            (BitPack (..))-import Clash.Sized.Internal.BitVector (Bit, reduceAnd#, reduceOr#, reduceXor#)--{- $setup->>> :set -XDataKinds->>> import Clash.Prelude--}--{-# INLINE reduceAnd #-}--- | Are all bits set to '1'?------ >>> pack (-2 :: Signed 6)--- 11_1110--- >>> reduceAnd (-2 :: Signed 6)--- 0--- >>> pack (-1 :: Signed 6)--- 11_1111--- >>> reduceAnd (-1 :: Signed 6)--- 1------ Zero width types will evaluate to '1':------ >>> reduceAnd (0 :: Unsigned 0)--- 1-reduceAnd :: (BitPack a, KnownNat (BitSize a)) => a -> Bit-reduceAnd v = reduceAnd# (pack v)--{-# INLINE reduceOr #-}--- | Is there at least one bit set to '1'?------ >>> pack (5 :: Signed 6)--- 00_0101--- >>> reduceOr (5 :: Signed 6)--- 1--- >>> pack (0 :: Signed 6)--- 00_0000--- >>> reduceOr (0 :: Signed 6)--- 0------ Zero width types will evaluate to '0':------ >>> reduceOr (0 :: Unsigned 0)--- 0-reduceOr :: (BitPack a, KnownNat (BitSize a)) => a -> Bit-reduceOr v = reduceOr# (pack v)--{-# INLINE reduceXor #-}--- | Is the number of bits set to '1' uneven?------ >>> pack (5 :: Signed 6)--- 00_0101--- >>> reduceXor (5 :: Signed 6)--- 0--- >>> pack (28 :: Signed 6)--- 01_1100--- >>> reduceXor (28 :: Signed 6)--- 1--- >>> pack (-5 :: Signed 6)--- 11_1011--- >>> reduceXor (-5 :: Signed 6)--- 1------ Zero width types will evaluate to '0':------ >>> reduceXor (0 :: Unsigned 0)--- 0-reduceXor :: (BitPack a, KnownNat (BitSize a)) => a -> Bit-reduceXor v = reduceXor# (pack v)
src/Clash/Prelude/BlockRam.hs view
@@ -1,24 +1,26 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2016-2019, Myrtle Software Ltd,-                  2017     , Google Inc.+                  2017     , Google Inc.,+                  2021-2026, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -BlockRAM primitives+Block RAM primitives  = Using RAMs #usingrams#  We will show a rather elaborate example on how you can, and why you might want-to use 'blockRam's. We will build a \"small\" CPU+Memory+Program ROM where we-will slowly evolve to using blockRams. Note that the code is /not/ meant as a-de-facto standard on how to do CPU design in Clash.+to use 'blockRam's. We will build a \"small\" CPU + Memory + Program ROM where+we will slowly evolve to using 'blockRam's. Note that the code is /not/ meant as+a de-facto standard on how to do CPU design in Clash.  We start with the definition of the Instructions, Register names and machine codes:  @-{\-\# LANGUAGE RecordWildCards, TupleSections, DeriveAnyClass, TypeApplications \#-\}+{\-\# LANGUAGE RecordWildCards, TupleSections, DeriveAnyClass \#-\}+ module CPU where  import Clash.Prelude@@ -34,7 +36,7 @@   | Load MemAddr Reg   | Store Reg MemAddr   | Nop-  deriving (Eq, Show)+  deriving (Eq, Show, Generic, NFDataX)  data Reg   = Zero@@ -47,7 +49,7 @@   deriving (Eq, Show, Enum, Generic, NFDataX)  data Operator = Add | Sub | Incr | Imm | CmpGt-  deriving (Eq, Show)+  deriving (Eq, Show, Generic, NFDataX)  data MachCode   = MachCode@@ -77,16 +79,17 @@ Next we define the CPU and its ALU:  @-cpu :: Vec 7 Value          -- ^ Register bank-    -> (Value,Instruction)  -- ^ (Memory output, Current instruction)-    -> ( Vec 7 Value-       , (MemAddr, Maybe (MemAddr,Value), InstrAddr)-       )+cpu+  :: Vec 7 Value          -- ^ Register bank+  -> (Value,Instruction)  -- ^ (Memory output, Current instruction)+  -> ( Vec 7 Value+     , (MemAddr, Maybe (MemAddr,Value), InstrAddr)+     ) cpu regbank (memOut, instr) =-  (regbank', (rdAddr, (,aluOut) '<$>' wrAddrM, fromIntegral ipntr))+  (regbank', (rdAddr, (,aluOut) 'Prelude.<$>' wrAddrM, bitCoerce ipntr))  where   -- Current instruction pointer-  ipntr = regbank '!!' PC+  ipntr = regbank 'Clash.Sized.Vector.!!' PC    -- Decoder   (MachCode {..}) = case instr of@@ -98,8 +101,8 @@     Nop                  -> nullCode    -- ALU-  regX   = regbank '!!' inputX-  regY   = regbank '!!' inputY+  regX   = regbank 'Clash.Sized.Vector.!!' inputX+  regY   = regbank 'Clash.Sized.Vector.!!' inputY   aluOut = alu aluCode regX regY    -- next instruction@@ -109,10 +112,10 @@       _                    -> ipntr + 1    -- update registers-  regbank' = 'replace' Zero   0-           $ 'replace' PC     nextPC-           $ 'replace' result aluOut-           $ 'replace' ldReg  memOut+  regbank' = 'Clash.Sized.Vector.replace' Zero   0+           $ 'Clash.Sized.Vector.replace' PC     nextPC+           $ 'Clash.Sized.Vector.replace' result aluOut+           $ 'Clash.Sized.Vector.replace' ldReg  memOut            $ regbank  alu Add   x y = x + y@@ -134,14 +137,14 @@   -> Signal dom Value   -- ^ data out dataMem rd wrM =-  'Clash.Prelude.Mealy.mealy' dataMemT ('replicate' d32 0) (bundle (rd,wrM))+  'Clash.Prelude.Mealy.mealy' dataMemT ('Clash.Sized.Vector.replicate' d32 0) (bundle (rd,wrM))  where   dataMemT mem (rd,wrM) = (mem',dout)     where-      dout = mem '!!' rd+      dout = mem 'Clash.Sized.Vector.!!' rd       mem' =         case wrM of-          Just (wr,din) -> 'replace' wr din mem+          Just (wr,din) -> 'Clash.Sized.Vector.replace' wr din mem           _             -> mem @ @@ -155,10 +158,10 @@   => Vec n Instruction   -> Signal dom Value system instrs = memOut-  where-    memOut = dataMem rdAddr dout-    (rdAddr, dout, ipntr) = 'Clash.Prelude.Mealy.mealyB' cpu ('replicate' d7 0) (memOut,instr)-    instr  = 'Clash.Prelude.ROM.asyncRom' instrs '<$>' ipntr+ where+  memOut = dataMem rdAddr dout+  (rdAddr, dout, ipntr) = 'Clash.Prelude.Mealy.mealyB' cpu ('Clash.Sized.Vector.replicate' d7 0) (memOut,instr)+  instr  = 'Clash.Prelude.ROM.asyncRom' instrs 'Prelude.<$>' ipntr @  Create a simple program that calculates the GCD of 4 and 6:@@ -208,8 +211,9 @@ === Improvement 1: using @asyncRam@  As you can see, it's fairly straightforward to build a memory using registers-and read ('!!') and write ('replace') logic. This might however not result in-the most efficient hardware structure, especially when building an ASIC.+and read ('Clash.Sized.Vector.!!') and write ('Clash.Sized.Vector.replace')+logic. This might however not result in the most efficient hardware structure,+especially when building an ASIC.  Instead it is preferable to use the 'Clash.Prelude.RAM.asyncRam' function which has the potential to be translated to a more efficient structure:@@ -221,21 +225,22 @@   => Vec n Instruction   -> Signal dom Value system2 instrs = memOut-  where-    memOut = 'Clash.Prelude.RAM.asyncRam' d32 rdAddr dout-    (rdAddr,dout,ipntr) = 'mealyB' cpu ('replicate' d7 0) (memOut,instr)-    instr  = 'Clash.Prelude.ROM.asyncRom' instrs '<$>' ipntr+ where+  memOut = 'Clash.Prelude.RAM.asyncRam' d32 rdAddr dout+  (rdAddr,dout,ipntr) = 'Clash.Prelude.mealyB' cpu ('Clash.Sized.Vector.replicate' d7 0) (memOut,instr)+  instr  = 'Clash.Prelude.ROM.asyncRom' instrs 'Prelude.<$>' ipntr @  Again, we can simulate our system and see that it works. This time however, we need to disregard the first few output samples, because the initial content of an-'Clash.Prelude.RAM.asyncRam' is 'undefined', and consequently, the first few-output samples are also 'undefined'. We use the utility function 'printX' to conveniently-filter out the undefinedness and replace it with the string "X" in the few leading outputs.+'Clash.Prelude.RAM.asyncRam' is /undefined/, and consequently, the first few+output samples are also /undefined/. We use the utility function+'Clash.XException.printX' to conveniently filter out the undefinedness and+replace it with the string @\"undefined\"@ in the first few leading outputs.  @ >>> printX $ sampleN @System 32 (system2 prog)-[X,X,X,X,X,X,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]+[undefined,undefined,undefined,undefined,undefined,undefined,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]  @ @@ -243,36 +248,34 @@  Finally we get to using 'blockRam'. On FPGAs, 'Clash.Prelude.RAM.asyncRam' will be implemented in terms of LUTs, and therefore take up logic resources. FPGAs-also have large(r) memory structures called /Block RAMs/, which are preferred,+also have large(r) memory structures called /block RAMs/, which are preferred, especially as the memories we need for our application get bigger. The-'blockRam' function will be translated to such a /Block RAM/.+'blockRam' function will be translated to such a /block RAM/. -One important aspect of Block RAMs have a /synchronous/ read port, meaning that,-unlike the behavior of 'Clash.Prelude.RAM.asyncRam', given a read address @r@-at time @t@, the value @v@ in the RAM at address @r@ is only available at time-@t+1@.+One important aspect of block RAMs is that they have a /synchronous/ read port,+meaning that, unlike the behavior of 'Clash.Prelude.RAM.asyncRam', given a read+address @r@ at time @t@, the value @v@ in the RAM at address @r@ is only+available at time @t+1@.  For us that means we need to change the design of our CPU. Right now, upon a load instruction we generate a read address for the memory, and the value at that read address is immediately available to be put in the register bank.-Because we will be using a BlockRAM, the value is delayed until the next cycle.-We hence need to also delay the register address to which the memory address-is loaded:+Because we will be using a block RAM, the value is delayed until the next cycle.+Thus, we will need to also delay the register address to which the memory+address is loaded:  @ cpu2-  :: (Vec 7 Value,Reg)-  -- ^ (Register bank, Load reg addr)-  -> (Value, Instruction)-  -- ^ (Memory output, Current instruction)-  -> ( (Vec 7 Value,Reg)-     , (MemAddr, Maybe (MemAddr, Value), InstrAddr)+  :: (Vec 7 Value,Reg)    -- ^ (Register bank, Load reg addr)+  -> (Value,Instruction)  -- ^ (Memory output, Current instruction)+  -> ( (Vec 7 Value, Reg)+     , (MemAddr, Maybe (MemAddr,Value), InstrAddr)      ) cpu2 (regbank,ldRegD) (memOut,instr) =-  ((regbank', ldRegD'), (rdAddr, (,aluOut) '<$>' wrAddrM, fromIntegral ipntr))+  ((regbank', ldRegD'), (rdAddr, (,aluOut) 'Prelude.<$>' wrAddrM, bitCoerce ipntr))  where   -- Current instruction pointer-  ipntr = regbank '!!' PC+  ipntr = regbank 'Clash.Sized.Vector.!!' PC    -- Decoder   (MachCode {..}) = case instr of@@ -284,8 +287,8 @@     Nop                  -> nullCode    -- ALU-  regX   = regbank '!!' inputX-  regY   = regbank '!!' inputY+  regX   = regbank 'Clash.Sized.Vector.!!' inputX+  regY   = regbank 'Clash.Sized.Vector.!!' inputY   aluOut = alu aluCode regX regY    -- next instruction@@ -296,10 +299,10 @@    -- update registers   ldRegD'  = ldReg  -- Delay the ldReg by 1 cycle-  regbank' = 'replace' Zero   0-           $ 'replace' PC     nextPC-           $ 'replace' result aluOut-           $ 'replace' ldRegD memOut+  regbank' = 'Clash.Sized.Vector.replace' Zero   0+           $ 'Clash.Sized.Vector.replace' PC     nextPC+           $ 'Clash.Sized.Vector.replace' result aluOut+           $ 'Clash.Sized.Vector.replace' ldRegD memOut            $ regbank @ @@ -312,17 +315,17 @@   => Vec n Instruction   -> Signal dom Value system3 instrs = memOut-  where-    memOut = 'blockRam' (replicate d32 0) rdAddr dout-    (rdAddr,dout,ipntr) = 'mealyB' cpu2 (('replicate' d7 0),Zero) (memOut,instr)-    instr  = 'Clash.Prelude.ROM.asyncRom' instrs '<$>' ipntr+ where+  memOut = 'blockRam' (replicate d32 0) rdAddr dout+  (rdAddr,dout,ipntr) = 'Clash.Prelude.mealyB' cpu2 (('Clash.Sized.Vector.replicate' d7 0),Zero) (memOut,instr)+  instr  = 'Clash.Prelude.ROM.asyncRom' instrs 'Prelude.<$>' ipntr @  We are, however, not done. We will also need to update our program. The reason being that values that we try to load in our registers won't be loaded into the register until the next cycle. This is a problem when the next instruction-immediately depended on this memory value. In our case, this was only the case-when the loaded the value @6@, which was stored at address @1@, into @RegB@.+immediately depends on this memory value. In our case, this was only the case+when we loaded the value @6@, which was stored at address @1@, into @RegB@. Our updated program is thus:  @@@ -359,12 +362,12 @@  When we simulate our system we see that it works. This time again, we need to disregard the first sample, because the initial output of a-'blockRam' is 'undefined'. We use the utility function 'printX' to conveniently-filter out the undefinedness and replace it with the string "X".+'blockRam' is /undefined/. We use the utility function 'Clash.XException.printX'+to conveniently filter out the undefinedness and replace it with the string @\"undefined\"@.  @ >>> printX $ sampleN @System 34 (system3 prog2)-[X,0,0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]+[undefined,0,0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]  @ @@ -372,11 +375,12 @@  -} -{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE GADTs               #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators       #-}  {-# LANGUAGE Safe #-} @@ -389,12 +393,18 @@   , blockRamU   , blockRam1   , E.ResetStrategy(..)-    -- * Read/Write conflict resolution+    -- ** Read/Write conflict resolution   , readNew+    -- * True dual-port block RAM+    -- $tdpbram+  , trueDualPortBlockRam+  , E.RamOp(..)   ) where -import           GHC.TypeLits            (KnownNat, type (^), type (<=))+import           Prelude                 (Enum, Maybe, Eq)++import           GHC.TypeLits            (KnownNat, type (^)) import           GHC.Stack               (HasCallStack, withFrozenCallStack)  import qualified Clash.Explicit.BlockRam as E@@ -405,6 +415,17 @@ import           Clash.Sized.Vector      (Vec) import           Clash.XException        (NFDataX) +{- $tdpbram+A true dual-port block RAM has two fully independent, fully functional access+ports: port A and port B. Either port can do both RAM reads and writes. These+two ports can even be on distinct clock domains, but the memory itself is shared+between the ports. This also makes a true dual-port block RAM suitable as a+component in a domain crossing circuit (but it needs additional logic for it to+be safe, see e.g. 'Clash.Explicit.Synchronizer.asyncFIFOSynchronizer').++A version with explicit clocks can be found in "Clash.Explicit.BlockRam".+-}+ {- $setup >>> import Clash.Prelude as C >>> import qualified Data.List as L@@ -427,7 +448,7 @@  >>> :{ data Operator = Add | Sub | Incr | Imm | CmpGt-  deriving (Eq,Show)+  deriving (Eq, Show, Generic, NFDataX) :}  >>> :{@@ -438,7 +459,7 @@   | Load MemAddr Reg   | Store Reg MemAddr   | Nop-  deriving (Eq,Show)+  deriving (Eq, Show, Generic, NFDataX) :}  >>> :{@@ -471,65 +492,65 @@ :}  >>> :{-cpu :: Vec 7 Value          -- ^ Register bank-    -> (Value,Instruction)  -- ^ (Memory output, Current instruction)-    -> ( Vec 7 Value-       , (MemAddr,Maybe (MemAddr,Value),InstrAddr)-       )-cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr))-  where-    -- Current instruction pointer-    ipntr = regbank C.!! PC-    -- Decoder-    (MachCode {..}) = case instr of-      Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}-      Branch cr a          -> nullCode {inputX=cr,jmpM=Just a}-      Jump a               -> nullCode {aluCode=Incr,jmpM=Just a}-      Load a r             -> nullCode {ldReg=r,rdAddr=a}-      Store r a            -> nullCode {inputX=r,wrAddrM=Just a}-      Nop                  -> nullCode-    -- ALU-    regX   = regbank C.!! inputX-    regY   = regbank C.!! inputY-    aluOut = alu aluCode regX regY-    -- next instruction-    nextPC = case jmpM of-               Just a | aluOut /= 0 -> ipntr + a-               _                    -> ipntr + 1-    -- update registers-    regbank' = replace Zero   0-             $ replace PC     nextPC-             $ replace result aluOut-             $ replace ldReg  memOut-             $ regbank+let cpu :: Vec 7 Value          -- ^ Register bank+        -> (Value,Instruction)  -- ^ (Memory output, Current instruction)+        -> ( Vec 7 Value+           , (MemAddr,Maybe (MemAddr,Value),InstrAddr)+           )+    cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) <$> wrAddrM,bitCoerce ipntr))+      where+        -- Current instruction pointer+        ipntr = regbank C.!! PC+        -- Decoder+        (MachCode {..}) = case instr of+          Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}+          Branch cr a          -> nullCode {inputX=cr,jmpM=Just a}+          Jump a               -> nullCode {aluCode=Incr,jmpM=Just a}+          Load a r             -> nullCode {ldReg=r,rdAddr=a}+          Store r a            -> nullCode {inputX=r,wrAddrM=Just a}+          Nop                  -> nullCode+        -- ALU+        regX   = regbank C.!! inputX+        regY   = regbank C.!! inputY+        aluOut = alu aluCode regX regY+        -- next instruction+        nextPC = case jmpM of+                   Just a | aluOut /= 0 -> ipntr + a+                   _                    -> ipntr + 1+        -- update registers+        regbank' = replace Zero   0+                 $ replace PC     nextPC+                 $ replace result aluOut+                 $ replace ldReg  memOut+                 $ regbank :}  >>> :{-dataMem-  :: HiddenClockResetEnable dom-  => Signal dom MemAddr-  -> Signal dom (Maybe (MemAddr,Value))-  -> Signal dom Value-dataMem rd wrM = mealy dataMemT (C.replicate d32 0) (bundle (rd,wrM))-  where-    dataMemT mem (rd,wrM) = (mem',dout)+let dataMem+      :: HiddenClockResetEnable dom+      => Signal dom MemAddr+      -> Signal dom (Maybe (MemAddr,Value))+      -> Signal dom Value+    dataMem rd wrM = mealy dataMemT (C.replicate d32 0) (bundle (rd,wrM))       where-        dout = mem C.!! rd-        mem' = case wrM of-                 Just (wr,din) -> replace wr din mem-                 Nothing       -> mem+        dataMemT mem (rd,wrM) = (mem',dout)+          where+            dout = mem C.!! rd+            mem' = case wrM of+                     Just (wr,din) -> replace wr din mem+                     Nothing       -> mem :}  >>> :{-system-  :: (KnownNat n, HiddenClockResetEnable dom )-  => Vec n Instruction-  -> Signal dom Value-system instrs = memOut-  where-    memOut = dataMem rdAddr dout-    (rdAddr,dout,ipntr) = mealyB cpu (C.replicate d7 0) (memOut,instr)-    instr  = asyncRom instrs <$> ipntr+let system+      :: (KnownNat n, HiddenClockResetEnable dom )+      => Vec n Instruction+      -> Signal dom Value+    system instrs = memOut+      where+        memOut = dataMem rdAddr dout+        (rdAddr,dout,ipntr) = mealyB cpu (C.replicate d7 0) (memOut,instr)+        instr  = asyncRom instrs <$> ipntr :}  >>> :{@@ -565,69 +586,69 @@ :}  >>> :{-system2-  :: ( KnownNat n-     , HiddenClockResetEnable dom  )-  => Vec n Instruction-  -> Signal dom Value-system2 instrs = memOut-  where-    memOut = asyncRam d32 rdAddr dout-    (rdAddr,dout,ipntr) = mealyB cpu (C.replicate d7 0) (memOut,instr)-    instr  = asyncRom instrs <$> ipntr+let system2+      :: ( KnownNat n+         , HiddenClockResetEnable dom  )+      => Vec n Instruction+      -> Signal dom Value+    system2 instrs = memOut+      where+        memOut = asyncRam d32 rdAddr dout+        (rdAddr,dout,ipntr) = mealyB cpu (C.replicate d7 0) (memOut,instr)+        instr  = asyncRom instrs <$> ipntr :}  >>> :{-cpu2-  :: (Vec 7 Value,Reg)-  -- ^ (Register bank, Load reg addr)-  -> (Value,Instruction)-  -- ^ (Memory output, Current instruction)-  -> ( (Vec 7 Value,Reg)-     , (MemAddr, Maybe (MemAddr, Value), InstrAddr)-     )-cpu2 (regbank,ldRegD) (memOut,instr) =-  ((regbank', ldRegD'), (rdAddr, (,aluOut) <$> wrAddrM, fromIntegral ipntr))- where-  -- Current instruction pointer-  ipntr = regbank C.!! PC-  -- Decoder-  (MachCode {..}) = case instr of-    Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}-    Branch cr a          -> nullCode {inputX=cr,jmpM=Just a}-    Jump a               -> nullCode {aluCode=Incr,jmpM=Just a}-    Load a r             -> nullCode {ldReg=r,rdAddr=a}-    Store r a            -> nullCode {inputX=r,wrAddrM=Just a}-    Nop                  -> nullCode-  -- ALU-  regX   = regbank C.!! inputX-  regY   = regbank C.!! inputY-  aluOut = alu aluCode regX regY-  -- next instruction-  nextPC =-    case jmpM of-      Just a | aluOut /= 0 -> ipntr + a-      _                    -> ipntr + 1-  -- update registers-  ldRegD'  = ldReg -- Delay the ldReg by 1 cycle-  regbank' = replace Zero   0-           $ replace PC     nextPC-           $ replace result aluOut-           $ replace ldRegD memOut-           $ regbank+let cpu2+      :: (Vec 7 Value,Reg)+      -- ^ (Register bank, Load reg addr)+      -> (Value,Instruction)+      -- ^ (Memory output, Current instruction)+      -> ( (Vec 7 Value,Reg)+         , (MemAddr, Maybe (MemAddr, Value), InstrAddr)+         )+    cpu2 (regbank,ldRegD) (memOut,instr) =+      ((regbank', ldRegD'), (rdAddr, (,aluOut) <$> wrAddrM, bitCoerce ipntr))+     where+      -- Current instruction pointer+      ipntr = regbank C.!! PC+      -- Decoder+      (MachCode {..}) = case instr of+        Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}+        Branch cr a          -> nullCode {inputX=cr,jmpM=Just a}+        Jump a               -> nullCode {aluCode=Incr,jmpM=Just a}+        Load a r             -> nullCode {ldReg=r,rdAddr=a}+        Store r a            -> nullCode {inputX=r,wrAddrM=Just a}+        Nop                  -> nullCode+      -- ALU+      regX   = regbank C.!! inputX+      regY   = regbank C.!! inputY+      aluOut = alu aluCode regX regY+      -- next instruction+      nextPC =+        case jmpM of+          Just a | aluOut /= 0 -> ipntr + a+          _                    -> ipntr + 1+      -- update registers+      ldRegD'  = ldReg -- Delay the ldReg by 1 cycle+      regbank' = replace Zero   0+               $ replace PC     nextPC+               $ replace result aluOut+               $ replace ldRegD memOut+               $ regbank :}  >>> :{-system3-  :: ( KnownNat n-     , HiddenClockResetEnable dom  )-  => Vec n Instruction-  -> Signal dom Value-system3 instrs = memOut-  where-    memOut = blockRam (C.replicate d32 0) rdAddr dout-    (rdAddr,dout,ipntr) = mealyB cpu2 ((C.replicate d7 0),Zero) (memOut,instr)-    instr  = asyncRom instrs <$> ipntr+let system3+      :: ( KnownNat n+         , HiddenClockResetEnable dom  )+      => Vec n Instruction+      -> Signal dom Value+    system3 instrs = memOut+      where+        memOut = blockRam (C.replicate d32 0) rdAddr dout+        (rdAddr,dout,ipntr) = mealyB cpu2 ((C.replicate d7 0),Zero) (memOut,instr)+        instr  = asyncRom instrs <$> ipntr :}  >>> :{@@ -664,11 +685,23 @@  -} --- | Create a blockRAM with space for @n@ elements.+-- | Create a block RAM with space for @n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException' --+-- === See also:+--+-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a+-- Block RAM.+-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @'readNew' ('blockRam' inits) rd wrM@.+-- * A large 'Vec' for the initial content may be too inefficient, depending+-- on how it is constructed. See 'Clash.Prelude.BlockRam.File.blockRamFile' and+-- 'Clash.Prelude.BlockRam.Blob.blockRamBlob' for different approaches that+-- scale well.+--+-- === __Example__ -- @ -- bram40 --   :: 'HiddenClock' dom@@ -677,75 +710,68 @@ --   -> 'Signal' dom 'Clash.Sized.BitVector.Bit' -- bram40 = 'blockRam' ('Clash.Sized.Vector.replicate' d40 1) -- @------ Additional helpful information:------ * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a--- Block RAM.--- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRam inits) rd wrM@. blockRam   :: ( HasCallStack      , HiddenClock dom      , HiddenEnable dom      , NFDataX a      , Enum addr-     )+     , NFDataX addr )   => Vec n a-  -- ^ Initial content of the BRAM, also determines the size, @n@, of the BRAM.+  -- ^ Initial content of the BRAM, also determines the size, @n@, of the BRAM   ---  -- __NB__: __MUST__ be a constant.+  -- __NB__: __MUST__ be a constant   -> Signal dom addr   -- ^ Read address @r@   -> Signal dom (Maybe (addr, a))    -- ^ (write address @w@, value to write)   -> Signal dom a-  -- ^ Value of the @blockRAM@ at address @r@ from the previous clock-  -- cycle+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle blockRam = \cnt rd wrM -> withFrozenCallStack   (hideEnable (hideClock E.blockRam) cnt rd wrM) {-# INLINE blockRam #-} --- | Version of blockram that has no default values set. May be cleared to a--- arbitrary state using a reset function.+-- | A version of 'blockRam' that has no default values set. May be cleared to+-- an arbitrary state using a reset function. blockRamU    :: forall n dom a r addr    . ( HasCallStack      , HiddenClockResetEnable dom      , NFDataX a      , Enum addr-     , 1 <= n )-  => E.ResetStrategy r-  -- ^ Whether to clear BRAM on asserted reset ('ClearOnReset') or-  -- not ('NoClearOnReset'). Reset needs to be asserted at least /n/ cycles to-  -- clear the BRAM.+     , NFDataX addr+     )+  => E.ResetStrategy r (Index n -> a)+  -- ^ Whether to clear BRAM on asserted reset ('Clash.Explicit.BlockRam.ClearOnReset')+  -- or not ('Clash.Explicit.BlockRam.NoClearOnReset'). The reset needs to be+  -- asserted for at least /n/ cycles to clear the BRAM.   -> SNat n   -- ^ Number of elements in BRAM-  -> (Index n -> a)-  -- ^ If applicable (see first argument), reset BRAM using this function.   -> Signal dom addr   -- ^ Read address @r@   -> Signal dom (Maybe (addr, a))   -- ^ (write address @w@, value to write)   -> Signal dom a-  -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle blockRamU =-  \rstStrategy cnt initF rd wrM -> withFrozenCallStack-    (hideClockResetEnable E.blockRamU) rstStrategy cnt initF rd wrM+  \rstStrategy cnt rd wrM -> withFrozenCallStack+    (hideClockResetEnable E.blockRamU) rstStrategy cnt rd wrM {-# INLINE blockRamU #-} --- | Version of blockram that is initialized with the same value on all--- memory positions.+-- | A version of 'blockRam' that is initialized with the same value on all+-- memory positions blockRam1    :: forall n dom a r addr    . ( HasCallStack      , HiddenClockResetEnable dom      , NFDataX a      , Enum addr-     , 1 <= n )-  => E.ResetStrategy r-  -- ^ Whether to clear BRAM on asserted reset ('ClearOnReset') or-  -- not ('NoClearOnReset'). Reset needs to be asserted at least /n/ cycles to-  -- clear the BRAM.+     , NFDataX addr+     )+  => E.ResetStrategy r ()+  -- ^ Whether to clear BRAM on asserted reset ('Clash.Explicit.BlockRam.ClearOnReset')+  -- or not ('Clash.Explicit.BlockRam.NoClearOnReset'). The reset needs to be+  -- asserted for at least /n/ cycles to clear the BRAM.   -> SNat n   -- ^ Number of elements in BRAM   -> a@@ -755,17 +781,29 @@   -> Signal dom (Maybe (addr, a))   -- ^ (write address @w@, value to write)   -> Signal dom a-  -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle blockRam1 =   \rstStrategy cnt initValue rd wrM -> withFrozenCallStack     (hideClockResetEnable E.blockRam1) rstStrategy cnt initValue rd wrM {-# INLINE blockRam1 #-} --- | Create a blockRAM with space for 2^@n@ elements+-- | Create a block RAM with space for 2^@n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException' --+-- === See also:+--+-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a+-- block RAM.+-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @'readNew' ('blockRamPow2' inits) rd wrM@.+-- * A large 'Vec' for the initial content may be too inefficient, depending+-- on how it is constructed. See 'Clash.Prelude.BlockRam.File.blockRamFilePow2'+-- and 'Clash.Prelude.BlockRam.Blob.blockRamBlobPow2' for different approaches+-- that scale well.+--+-- === __Example__ -- @ -- bram32 --   :: 'HiddenClock' dom@@ -774,12 +812,6 @@ --   -> 'Signal' dom 'Clash.Sized.BitVector.Bit' -- bram32 = 'blockRamPow2' ('Clash.Sized.Vector.replicate' d32 1) -- @------ Additional helpful information:------ * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a--- Block RAM.--- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRamPow2 inits) rd wrM@. blockRamPow2   :: ( HasCallStack      , HiddenClock dom@@ -788,7 +820,7 @@      , KnownNat n      )   => Vec (2^n) a-  -- ^ Initial content of the BRAM, also determines the size, @2^n@, of the BRAM.+  -- ^ Initial content of the BRAM   --   -- __NB__: __MUST__ be a constant.   -> Signal dom (Unsigned n)@@ -802,28 +834,59 @@   (hideEnable (hideClock E.blockRamPow2) cnt rd wrM) {-# INLINE blockRamPow2 #-} --- | Create read-after-write blockRAM from a read-before-write one (synchronized to system clock)------ >>> import Clash.Prelude--- >>> :t readNew (blockRam (0 :> 1 :> Nil))--- readNew (blockRam (0 :> 1 :> Nil))---   :: ...---      ...---      ...---      ...---      ... =>---      Signal dom addr -> Signal dom (Maybe (addr, a)) -> Signal dom a+{- | Create a read-after-write block RAM from a read-before-write one++#if __GLASGOW_HASKELL__ >= 908+>>> :t readNew (blockRam (0 :> 1 :> Nil))+readNew (blockRam (0 :> 1 :> Nil))+  :: ...+     ...+     ... =>+     Signal dom addr -> Signal dom (Maybe (addr, a)) -> Signal dom a++#else+>>> :t readNew (blockRam (0 :> 1 :> Nil))+readNew (blockRam (0 :> 1 :> Nil))+  :: ...+     ... =>+     Signal dom addr -> Signal dom (Maybe (addr, a)) -> Signal dom a++#endif+-} readNew   :: ( HiddenClockResetEnable dom      , NFDataX a      , Eq addr )   => (Signal dom addr -> Signal dom (Maybe (addr, a)) -> Signal dom a)-  -- ^ The @ram@ component+  -- ^ The BRAM component   -> Signal dom addr   -- ^ Read address @r@   -> Signal dom (Maybe (addr, a))   -- ^ (Write address @w@, value to write)   -> Signal dom a-  -- ^ Value of the @ram@ at address @r@ from the previous clock cycle+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle readNew = hideClockResetEnable E.readNew {-# INLINE readNew #-}++-- | Produces vendor-agnostic HDL that will be inferred as a true dual-port+-- block RAM+--+-- Any value that is being written on a particular port is also the+-- value that will be read on that port, i.e. the same-port read/write behavior+-- is: WriteFirst. For mixed-port read/write, when port A writes to the address+-- port B reads from, the output of port B is undefined, and vice versa.+trueDualPortBlockRam ::+  forall nAddrs dom a .+  ( HasCallStack+  , KnownNat nAddrs+  , HiddenClock dom+  , NFDataX a+  )+  => Signal dom (E.RamOp nAddrs a)+  -- ^ RAM operation for port A+  -> Signal dom (E.RamOp nAddrs a)+  -- ^ RAM operation for port B+  -> (Signal dom a, Signal dom a)+  -- ^ Outputs data on /next/ cycle. When writing, the data written+  -- will be echoed. When reading, the read data is returned.+trueDualPortBlockRam inA inB = E.trueDualPortBlockRam hasClock hasClock inA inB
+ src/Clash/Prelude/BlockRam/Blob.hs view
@@ -0,0 +1,111 @@+{-|+Copyright  :  (C) 2022     , QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++= Efficient bundling of initial RAM content with the compiled code++Leveraging Template Haskell, the initial content for the block RAM components in+this module is stored alongside the compiled Haskell code. It covers use cases+where passing the initial content as a 'Clash.Sized.Vector.Vec' turns out to be+problematically slow.++The data is stored efficiently, with very little overhead (worst-case 7%, often+no overhead at all).++Unlike "Clash.Prelude.BlockRam.File", "Clash.Prelude.BlockRam.Blob" generates+practically the same HDL as "Clash.Prelude.BlockRam" and is compatible with all+tools consuming the generated HDL.+-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++{-# LANGUAGE Safe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Prelude.BlockRam.Blob+  ( -- * BlockRAMs initialized with a 'E.MemBlob'+    blockRamBlob+  , blockRamBlobPow2+    -- * Creating and inspecting 'E.MemBlob'+  , E.MemBlob+  , E.createMemBlob+  , E.memBlobTH+  , E.unpackMemBlob+  )+where++import GHC.TypeLits (KnownNat, type (^))++import qualified Clash.Explicit.BlockRam.Blob as E+import Clash.Signal (hideClock, hideEnable, HiddenClock, HiddenEnable, Signal)+import Clash.Sized.BitVector (BitVector)+import Clash.Sized.Unsigned (Unsigned)+import Clash.XException (NFDataX)++-- | Create a block RAM with space for @n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException'+--+--+-- === See also:+--+-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a+-- block RAM.+-- * Use the adapter 'Clash.Prelude.BlockRam.readNew' for obtaining+-- write-before-read semantics like this: @'Clash.Prelude.BlockRam.readNew'+-- ('blockRamBlob' content) rd wrM@.+blockRamBlob+  :: forall dom addr m n+   . ( HiddenClock dom+     , HiddenEnable dom+     , Enum addr+     , NFDataX addr+     )+  => E.MemBlob n m+  -- ^ Initial content of the BRAM, also determines the size, @n@, of the BRAM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom (Maybe (addr, BitVector m))+  -- ^ (write address @w@, value to write)+  -> Signal dom (BitVector m)+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRamBlob = hideEnable (hideClock E.blockRamBlob)+{-# INLINE blockRamBlob #-}++-- | Create a block RAM with space for 2^@n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException'+--+-- === See also:+--+-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a+-- block RAM.+-- * Use the adapter 'Clash.Prelude.BlockRam.readNew' for obtaining+-- write-before-read semantics like this: @'Clash.Prelude.BlockRam.readNew'+-- ('blockRamBlobPow2' content) rd wrM@.+blockRamBlobPow2+  :: forall dom m n+   . ( HiddenClock dom+     , HiddenEnable dom+     , KnownNat n+     )+  => E.MemBlob (2^n) m+  -- ^ Initial content of the BRAM, also determines the size, 2^@n@, of the BRAM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom (Unsigned n)+  -- ^ Read address @r@+  -> Signal dom (Maybe (Unsigned n, BitVector m))+  -- ^ (write address @w@, value to write)+  -> Signal dom (BitVector m)+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle+blockRamBlobPow2 = hideEnable (hideClock E.blockRamBlobPow2)+{-# INLINE blockRamBlobPow2 #-}
src/Clash/Prelude/BlockRam/File.hs view
@@ -1,44 +1,49 @@ {-| Copyright  :  (C) 2015-2016, University of Twente,-                  2019     , Myrtle Software Ltd-                  2017     , Google Inc.+                  2019     , Myrtle Software Ltd,+                  2017     , Google Inc.,+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -= Initializing a BlockRAM with a data file #usingramfiles#+= Initializing a block RAM with a data file #usingramfiles# -BlockRAM primitives that can be initialized with a data file. The BNF grammar+Block RAM primitives that can be initialized with a data file. The BNF grammar for this data file is simple: -@-FILE = LINE+-LINE = BIT+-BIT  = '0'-     | '1'-@+> FILE = LINE++> LINE = BIT++> BIT  = '0'+>      | '1'  Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@.-For example, a data file @memory.bin@ containing the 9-bit unsigned number+For example, a data file @memory.bin@ containing the 9-bit unsigned numbers @7@ to @13@ looks like: +> 000000111+> 000001000+> 000001001+> 000001010+> 000001011+> 000001100+> 000001101++Such a file can be produced with 'E.memFile':+ @-000000111-000001000-000001001-000001010-000001011-000001100-000001101+writeFile "memory.bin" (memFile Nothing [7 :: Unsigned 9 .. 13]) @ -We can instantiate a BlockRAM using the content of the above file like so:+We can instantiate a block RAM using the contents of the file above like so:  @-f :: HiddenClock dom  -> Signal dom (Unsigned 3) -> Signal dom (Unsigned 9)-f rd = 'Clash.Class.BitPack.unpack' '<$>' exposeClock 'blockRamFile' clk d7 \"memory.bin\" rd (pure Nothing)+f :: (HiddenClock dom, HiddenEnable dom)+  => Signal dom (Unsigned 3)+  -> Signal dom (Unsigned 9)+f rd = 'Clash.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" rd (pure Nothing) @ -In the example above, we basically treat the BlockRAM as an synchronous ROM.+In the example above, we basically treat the block RAM as a synchronous ROM. We can see that it works as expected:  @@@ -51,8 +56,10 @@ number, and a 3-bit signed number:  @-g :: HiddenClock dom  -> Signal dom (Unsigned 3) -> Signal dom (Unsigned 6,Signed 3)-g clk rd = 'Clash.Class.BitPack.unpack' '<$>' exposeClock 'blockRamFile' clk d7 \"memory.bin\" rd (pure Nothing)+g :: (HiddenClock dom, HiddenEnable dom)+   => Signal dom (Unsigned 3)+   -> Signal dom (Unsigned 6,Signed 3)+g clk rd = 'Clash.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" rd (pure Nothing) @  And then we would see:@@ -65,23 +72,19 @@  -} -{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}  {-# LANGUAGE Unsafe #-}  {-# OPTIONS_HADDOCK show-extensions #-}  module Clash.Prelude.BlockRam.File-  ( -- * BlockRAM synchronized to an arbitrary clock+  ( -- * Block RAM synchronized to an arbitrary clock     blockRamFile   , blockRamFilePow2+    -- * Producing files+  , E.memFile   ) where @@ -95,31 +98,34 @@   (HiddenClock, HiddenEnable, Signal, hideClock, hideEnable) import           Clash.Sized.BitVector        (BitVector) import           Clash.Sized.Unsigned         (Unsigned)+import           Clash.XException             (NFDataX) --- | Create a blockRAM with space for 2^@n@ elements+-- | Create a block RAM with space for 2^@n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException' -- * __NB__: This function might not work for specific combinations of -- code-generation backends and hardware targets. Please check the support table -- below: -----     @---                    | VHDL     | Verilog  | SystemVerilog |---     ===============+==========+==========+===============+---     Altera/Quartus | Broken   | Works    | Works         |---     Xilinx/ISE     | Works    | Works    | Works         |---     ASIC           | Untested | Untested | Untested      |---     ===============+==========+==========+===============+---     @+-- +----------------+----------+----------+---------------++-- |                | VHDL     | Verilog  | SystemVerilog |+-- +================+==========+==========+===============++-- | Altera/Quartus | Broken   | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | Xilinx/ISE     | Works    | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | ASIC           | Untested | Untested | Untested      |+-- +----------------+----------+----------+---------------+ ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a--- Block RAM.--- * Use the adapter 'Clash.Prelude.BlockRam.readNew' for obtaining write-before-read semantics like this: @'Clash.Prelude.BlockRam.readNew' clk ('blockRamFilePow2' clk file) rd wrM@.+-- block RAM.+-- * Use the adapter 'Clash.Prelude.BlockRam.readNew' for obtaining write-before-read semantics like this: @'Clash.Prelude.BlockRam.readNew' ('blockRamFilePow2' file) rd wrM@. -- * See "Clash.Prelude.BlockRam.File#usingramfiles" for more information on how--- to instantiate a Block RAM with the contents of a data file.+-- to instantiate a block RAM with the contents of a data file. -- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your -- own data files. blockRamFilePow2@@ -130,61 +136,62 @@      , HiddenEnable dom      , HasCallStack )   => FilePath-  -- ^ File describing the initial content of the blockRAM+  -- ^ File describing the initial content of the BRAM   -> Signal dom (Unsigned n)   -- ^ Read address @r@   -> Signal dom (Maybe (Unsigned n, BitVector m))   -- ^ (write address @w@, value to write)   -> Signal dom (BitVector m)-  -- ^ Value of the @blockRAM@ at address @r@ from the previous-  -- clock cycle+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle blockRamFilePow2 = \fp rd wrM -> withFrozenCallStack   (hideEnable (hideClock E.blockRamFilePow2) fp rd wrM) {-# INLINE blockRamFilePow2 #-} --- | Create a blockRAM with space for @n@ elements+-- | Create a block RAM with space for @n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException' -- * __NB__: This function might not work for specific combinations of -- code-generation backends and hardware targets. Please check the support table -- below: -----     @---                    | VHDL     | Verilog  | SystemVerilog |---     ===============+==========+==========+===============+---     Altera/Quartus | Broken   | Works    | Works         |---     Xilinx/ISE     | Works    | Works    | Works         |---     ASIC           | Untested | Untested | Untested      |---     ===============+==========+==========+===============+---     @+-- +----------------+----------+----------+---------------++-- |                | VHDL     | Verilog  | SystemVerilog |+-- +================+==========+==========+===============++-- | Altera/Quartus | Broken   | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | Xilinx/ISE     | Works    | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | ASIC           | Untested | Untested | Untested      |+-- +----------------+----------+----------+---------------+ ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a--- Block RAM.--- * Use the adapter 'Clash.Prelude.BlockRam.readNew' for obtaining write-before-read semantics like this: @'Clash.Prelude.BlockRam.readNew' clk ('blockRamFile' clk size file) rd wrM@.+-- block RAM.+-- * Use the adapter 'Clash.Prelude.BlockRam.readNew' for obtaining write-before-read semantics like this: @'Clash.Prelude.BlockRam.readNew' ('blockRamFile' size file) rd wrM@. -- * See "Clash.Prelude.BlockRam.File#usingramfiles" for more information on how--- to instantiate a Block RAM with the contents of a data file.+-- to instantiate a block RAM with the contents of a data file. -- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your -- own data files. blockRamFile   :: ( KnownNat m      , Enum addr+     , NFDataX addr      , HiddenClock dom      , HiddenEnable dom      , HasCallStack )   => SNat n-  -- ^ Size of the blockRAM+  -- ^ Size of the BRAM   -> FilePath-  -- ^ File describing the initial content of the blockRAM+  -- ^ File describing the initial content of the BRAM   -> Signal dom addr   -- ^ Read address @r@   -> Signal dom (Maybe (addr, BitVector m))   -- ^ (write address @w@, value to write)   -> Signal dom (BitVector m)-  -- ^ Value of the @blockRAM@ at address @r@ from the previous-  -- clock cycle+  -- ^ Value of the BRAM at address @r@ from the previous clock cycle blockRamFile = \sz fp rd wrM -> withFrozenCallStack   (hideEnable (hideClock E.blockRamFile) sz fp rd wrM) {-# INLINE blockRamFile #-}
− src/Clash/Prelude/DataFlow.hs 
@@ -1,576 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente,-                  2017     , Google Inc.-                  2019     , Myrtle Software Ltd-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--Self-synchronizing circuits based on data-flow principles.--}--{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MagicHash             #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}--{-# LANGUAGE Safe #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module Clash.Prelude.DataFlow-  ( -- * Data types-    DataFlow (..)-    -- * Creating DataFlow circuits-  , liftDF-  , pureDF-  , mealyDF-  , mooreDF-  , fifoDF-    -- * Composition combinators-  , idDF-  , seqDF-  , firstDF-  , swapDF-  , secondDF-  , parDF-  , parNDF-  , loopDF-  , loopDF_nobuf-    -- * Lock-Step operation-  , LockStep (..)-  )-where--import GHC.TypeLits           (KnownNat, type (+), type (^))-import Prelude-  hiding ((++), (!!), length, map, repeat, tail, unzip3, zip3, zipWith)--import Clash.Class.BitPack    (boolToBV)-import Clash.Class.Resize     (truncateB)-import Clash.Prelude.BitIndex (msb)-import Clash.Explicit.Mealy   (mealyB)-import Clash.Promoted.Nat     (SNat)-import Clash.Signal           (KnownDomain, (.&&.))-import Clash.Signal.Bundle    (Bundle (..))-import Clash.Explicit.Signal  (Clock, Reset, Signal, Enable, enable, register)-import Clash.Sized.BitVector  (BitVector)-import Clash.Sized.Vector-import Clash.XException       (errorX, NFDataX)--{- | Dataflow circuit with bidirectional synchronization channels.--In the /forward/ direction we assert /validity/ of the data. In the /backward/-direction we assert that the circuit is /ready/ to receive new data. A circuit-adhering to the 'DataFlow' type should:-- * Not consume data when validity is deasserted.- * Only update its output when readiness is asserted.--The 'DataFlow' type is defined as:--@-newtype DataFlow' dom iEn oEn i o-  = DF-  { df :: 'Signal' dom i     -- Incoming data-       -> 'Signal' dom iEn   -- Flagged with /valid/ bits @iEn@.-       -> 'Signal' dom oEn   -- Incoming back-pressure, /ready/ edge.-       -> ( 'Signal' dom o   -- Outgoing data.-          , 'Signal' dom oEn -- Flagged with /valid/ bits @oEn@.-          , 'Signal' dom iEn -- Outgoing back-pressure, /ready/ edge.-          )-  }-@--where:-- * @dom@ is the domain to which the circuit is synchronized.- * @iEn@ is the type of the bidirectional incoming synchronization channel.- * @oEn@ is the type of the bidirectional outgoing synchronization channel.- * @i@ is the incoming data type.- * @o@ is the outgoing data type.--We define several composition operators for our 'DataFlow' circuits:-- * 'seqDF' sequential composition.- * 'parDF' parallel composition.- * 'loopDF' add a feedback arc.- * 'lockStep' proceed in lock-step.--When you look at the types of the above operators it becomes clear why we-parametrize in the types of the synchronization channels.--}-newtype DataFlow dom iEn oEn i o-  = DF-  { -- | Create an ordinary circuit from a 'DataFlow' circuit-    df :: Signal dom i     -- Incoming data-       -> Signal dom iEn   -- Flagged with /valid/ bits @iEn@.-       -> Signal dom oEn   -- Incoming back-pressure, /ready/ edge.-       -> ( Signal dom o   -- Outgoing data.-          , Signal dom oEn -- Flagged with /valid/ bits @oEn@.-          , Signal dom iEn -- Outgoing back-pressure, /ready/ edge.-          )-  }---- | Dataflow circuit synchronized to the 'systemClockGen'.--- type DataFlow iEn oEn i o = DataFlow' systemClockGen iEn oEn i o---- | Create a 'DataFlow' circuit from a circuit description with the appropriate--- type:------ @--- 'Signal' dom i        -- Incoming data.--- -> 'Signal' dom Bool  -- Flagged with a single /valid/ bit.--- -> 'Signal' dom Bool  -- Incoming back-pressure, /ready/ bit.--- -> ( 'Signal' dom o   -- Outgoing data.---    , 'Signal' dom oEn -- Flagged with a single /valid/ bit.---    , 'Signal' dom iEn -- Outgoing back-pressure, /ready/ bit.---    )--- @------ A circuit adhering to the 'DataFlow' type should:------  * Not consume data when validity is deasserted.---  * Only update its output when readiness is asserted.-liftDF-  :: ( Signal dom i-    -> Signal dom Bool-    -> Signal dom Bool-    -> (Signal dom o, Signal dom Bool, Signal dom Bool))-  -> DataFlow dom Bool Bool i o-liftDF = DF---- | Create a 'DataFlow' circuit where the given function @f@ operates on the--- data, and the synchronization channels are passed unaltered.-pureDF-  :: (i -> o)-  -> DataFlow dom Bool Bool i o-pureDF f = DF (\i iV oR -> (fmap f i,iV,oR))---- | Create a 'DataFlow' circuit from a Mealy machine description as those of--- "Clash.Prelude.Mealy"-mealyDF-  :: ( KnownDomain dom-     , NFDataX s )-  => Clock dom-  -> Reset dom-  -> Enable dom-  -> (s -> i -> (s,o))-  -> s-  -> DataFlow dom Bool Bool i o-mealyDF clk rst gen f iS =-  DF (\i iV oR -> let en     = iV .&&. oR-                      (s',o) = unbundle (f <$> s <*> i)-                      s      = register clk rst (enable gen en) iS s'-                  in  (o,iV,oR))---- | Create a 'DataFlow' circuit from a Moore machine description as those of--- "Clash.Prelude.Moore"-mooreDF-  :: ( KnownDomain dom-     , NFDataX s )-  => Clock dom-  -> Reset dom-  -> Enable dom-  -> (s -> i -> s)-  -> (s -> o)-  -> s-  -> DataFlow dom Bool Bool i o-mooreDF clk rst gen ft fo iS =-  DF (\i iV oR -> let en  = iV .&&. oR-                      s'  = ft <$> s <*> i-                      s   = register clk rst (enable gen en) iS s'-                      o   = fo <$> s-                  in  (o,iV,oR))--fifoDF_mealy-  :: forall addrSize a-   . KnownNat addrSize-  => (Vec (2^addrSize) a, BitVector (addrSize + 1), BitVector (addrSize + 1))-  -> (a, Bool, Bool)-  -> ((Vec (2^addrSize) a, BitVector (addrSize + 1), BitVector (addrSize + 1))-     ,(a, Bool, Bool))-fifoDF_mealy (mem,rptr,wptr) (wdata,winc,rinc) =-  let raddr = truncateB rptr :: BitVector addrSize-      waddr = truncateB wptr :: BitVector addrSize--      mem' | winc && not full = replace waddr wdata mem-           | otherwise        = mem--      rdata = mem !! raddr--      rptr' = rptr + boolToBV (rinc && not empty)-      wptr' = wptr + boolToBV (winc && not full)-      empty = rptr == wptr-      full  = msb rptr /= msb wptr && raddr == waddr-  in  ((mem',rptr',wptr'), (rdata,empty,full))---- | Create a FIFO buffer adhering to the 'DataFlow' protocol. Can be filled--- with initial content.------ To create a FIFO of size 4, with two initial values 2 and 3 you would write:------ @--- fifo4 = 'fifoDF' d4 (2 :> 3 :> Nil)--- @-fifoDF-  :: forall addrSize m n a dom-   . ( KnownDomain dom-     , NFDataX a-     , KnownNat addrSize-     , KnownNat n-     , KnownNat m-     , (m + n) ~ (2 ^ addrSize) )-  => Clock dom-  -> Reset dom-  -> Enable dom-  -> SNat (m + n) -- ^ Depth of the FIFO buffer. Must be a power of two.-  -> Vec m a      -- ^ Initial content. Can be smaller than the size of the-                  -- FIFO. Empty spaces are initialized with 'undefined'.-  -> DataFlow dom Bool Bool a a-fifoDF clk rst en _ iS = DF $ \i iV oR ->-  let initRdPtr      = 0-      initWrPtr      = fromIntegral (length iS)-      initMem        = iS ++ repeat  (errorX "fifoDF: undefined") :: Vec (m + n) a-      initS          = (initMem,initRdPtr,initWrPtr)-      (o,empty,full) = mealyB clk rst en fifoDF_mealy initS (i,iV,oR)-  in  (o,not <$> empty, not <$> full)---- | Identity circuit------ <<doc/idDF.svg>>-idDF :: DataFlow dom en en a a-idDF = DF (\a val rdy -> (a,val,rdy))---- | Sequential composition of two 'DataFlow' circuits.------ <<doc/seqDF.svg>>-seqDF-  :: DataFlow dom aEn bEn a b-  -> DataFlow dom bEn cEn b c-  -> DataFlow dom aEn cEn a c-(DF f) `seqDF` (DF g) = DF (\a aVal cRdy -> let (b,bVal,aRdy) = f a aVal bRdy-                                                (c,cVal,bRdy) = g b bVal cRdy-                                            in  (c,cVal,aRdy))---- | Apply the circuit to the first halve of the communication channels, leave--- the second halve unchanged.------ <<doc/firstDF.svg>>-firstDF-  :: DataFlow dom aEn bEn a b-  -> DataFlow dom (aEn, cEn) (bEn, cEn) (a, c) (b, c)-firstDF (DF f) = DF (\ac acV bcR -> let (a,c)     = unbundle ac-                                        (aV,cV)   = unbundle acV-                                        (bR,cR)   = unbundle bcR-                                        (b,bV,aR) = f a aV bR-                                        bc        = bundle (b,c)-                                        bcV       = bundle (bV,cV)-                                        acR       = bundle (aR,cR)-                                    in  (bc,bcV,acR)-                    )---- | Swap the two communication channels.------ <<doc/swapDF.svg>>-swapDF :: DataFlow dom (aEn, bEn) (bEn, aEn) (a, b) (b, a)-swapDF = DF (\ab abV baR -> (swap <$> ab, swap <$> abV, swap <$> baR))-  where-    swap ~(a,b) = (b,a)---- | Apply the circuit to the second halve of the communication channels, leave--- the first halve unchanged.------ <<doc/secondDF.svg>>-secondDF-  :: DataFlow dom aEn bEn a b-  -> DataFlow dom (cEn, aEn) (cEn, bEn) (c, a) (c, b)-secondDF f = swapDF `seqDF` firstDF f `seqDF` swapDF---- | Compose two 'DataFlow' circuits in parallel.------ <<doc/parDF.svg>>-parDF-  :: DataFlow dom aEn bEn a b-  -> DataFlow dom cEn dEn c d-  -> DataFlow dom (aEn, cEn) (bEn, dEn) (a, c) (b, d)-f `parDF` g = firstDF f `seqDF` secondDF g---- | Compose /n/ 'DataFlow' circuits in parallel.-parNDF-  :: KnownNat n-  => Vec n (DataFlow dom aEn bEn a b)-  -> DataFlow dom (Vec n aEn) (Vec n bEn) (Vec n a) (Vec n b)-parNDF fs =-  DF (\as aVs bRs ->-        let as'  = unbundle as-            aVs' = unbundle aVs-            bRs' = unbundle bRs-            (bs,bVs,aRs) = unzip3 (zipWith (\k (a,b,r) -> df k a b r) fs-                                  (zip3 (lazyV as') (lazyV aVs') bRs'))-        in  (bundle bs,bundle bVs, bundle aRs)-     )---- | Feed back the second halve of the communication channel. The feedback loop--- is buffered by a 'fifoDF' circuit.------ So given a circuit /h/ with two synchronization channels:------ @--- __h__ :: 'DataFlow' (Bool,Bool) (Bool,Bool) (a,d) (b,d)--- @------ Feeding back the /d/ part (including its synchronization channels) results--- in:------ @--- 'loopDF' d4 Nil h--- @------ <<doc/loopDF.svg>>------ When you have a circuit @h'@, with only a single synchronization channel:------ @--- __h'__ :: 'DataFlow' Bool Bool (a,d) (b,d)--- @------ and you want to compose /h'/ in a feedback loop, the following will not work:------ @--- f \`@'seqDF'@\` ('loopDF' d4 Nil h') \`@'seqDF'@\` g--- @------ The circuits @f@, @h@, and @g@, must operate in /lock-step/ because the /h'/--- circuit only has a single synchronization channel. Consequently, there--- should only be progress when all three circuits are producing /valid/ data--- and all three circuits are /ready/ to receive new data. We need to compose--- /h'/ with the 'lockStep' and 'stepLock' functions to achieve the /lock-step/--- operation.------ @--- f \`@'seqDF'@\` ('lockStep' \`@'seqDF'@\` 'loopDF' d4 Nil h' \`@'seqDF'@\` 'stepLock') \`@'seqDF'@\` g--- @------ <<doc/loopDF_sync.svg>>-loopDF-  :: ( KnownDomain dom-     , NFDataX d-     , KnownNat m-     , KnownNat n-     , KnownNat addrSize-     , (m+n) ~ (2^addrSize) )-  => Clock dom-  -> Reset dom-  -> Enable dom-  -> SNat (m + n)-  -- ^ Depth of the FIFO buffer. Must be a power of two-  -> Vec m d-  -- ^ Initial content of the FIFO buffer. Can be smaller than the size of the-  -- FIFO. Empty spaces are initialized with 'undefined'.-  -> DataFlow dom (Bool,Bool) (Bool,Bool) (a,d) (b,d)-  -> DataFlow dom Bool Bool   a           b-loopDF clk rst en sz is (DF f) =-  DF (\a aV bR -> let (bd,bdV,adR) = f ad adV bdR-                      (b,d)        = unbundle bd-                      (bV,dV)      = unbundle bdV-                      (aR,dR)      = unbundle adR-                      (d_buf,dV_buf,dR_buf) = df (fifoDF clk rst en sz is) d dV dR--                      ad  = bundle (a,d_buf)-                      adV = bundle (aV,dV_buf)-                      bdR = bundle (bR,dR_buf)-                  in  (b,bV,aR)-     )---- | Feed back the second halve of the communication channel. Unlike 'loopDF',--- the feedback loop is /not/ buffered.-loopDF_nobuf :: DataFlow dom (Bool,Bool) (Bool,Bool) (a,d) (b,d)-             -> DataFlow dom Bool Bool   a           b-loopDF_nobuf (DF f) = DF (\a aV bR -> let (bd,bdV,adR) = f ad adV bdR-                                          (b,d)        = unbundle bd-                                          (bV,dV)      = unbundle bdV-                                          (aR,dR)      = unbundle adR-                                          ad           = bundle (a,d)-                                          adV          = bundle (aV,dV)-                                          bdR          = bundle (bR,dR)-                                      in  (b,bV,aR)-                         )---- | Reduce or extend the synchronization granularity of parallel compositions.-class LockStep a b where-  -- | Reduce the synchronization granularity to a single 'Bool'ean value.-  ---  -- Given:-  ---  -- @-  -- __f__ :: 'DataFlow' Bool Bool a b-  -- __g__ :: 'DataFlow' Bool Bool c d-  -- __h__ :: 'DataFlow' Bool Bool (b,d) (p,q)-  -- @-  ---  -- We /cannot/ simply write:-  ---  -- @-  -- (f \`@'parDF'@\` g) \`@'seqDF'@\` h-  -- @-  ---  -- because, @f \`parDF\` g@, has type, @'DataFlow' (Bool,Bool) (Bool,Bool) (a,c) (b,d)@,-  -- which does not match the expected synchronization granularity of @h@. We-  -- need a circuit in between that has the type:-  ---  -- @-  -- 'DataFlow' (Bool,Bool) Bool (b,d) (b,d)-  -- @-  ---  -- Simply '&&'-ing the /valid/ signals in the forward direction, and-  -- duplicating the /ready/ signal in the backward direction is however not-  -- enough. We also need to make sure that @f@ does not update its output when-  -- @g@'s output is invalid and visa versa, as @h@ can only consume its input-  -- when both @f@ and @g@ are producing valid data. @g@'s /ready/ port is hence-  -- only asserted when @h@ is ready and @f@ is producing /valid/ data. And @f@'s-  -- ready port is only asserted when @h@ is ready and @g@ is producing valid-  -- data. @f@ and @g@ will hence be proceeding in /lock-step/.-  ---  -- The 'lockStep' function ensures that all synchronization signals are-  -- properly connected:-  ---  -- @-  -- (f \`@'parDF'@\` g) \`@'seqDF'@\` 'lockStep' \`@'seqDF'@\` h-  -- @-  ---  -- <<doc/lockStep.svg>>-  ---  -- __Note 1__: ensure that the components that you are synchronizing have-  -- buffered/delayed @ready@ and @valid@ signals, or 'lockStep' has the-  -- potential to introduce combinational loops. You can do this by placing-  -- 'fifoDF's on the parallel channels. Extending the above example, you would-  -- write:-  ---  -- @-  -- ((f \`@'seqDF'@\` 'fifoDF' d4 Nil) \`@'parDF'@\` (g \`@'seqDF'@\` 'fifoDF' d4 Nil)) \`@'seqDF'@\` 'lockStep' \`@'seqDF'@\` h-  -- @-  ---  -- __Note 2__: 'lockStep' works for arbitrarily nested tuples. That is:-  ---  -- @-  -- p :: 'DataFlow' Bool Bool ((b,d),d) z-  ---  -- q :: 'DataFlow' ((Bool,Bool),Bool) ((Bool,Bool),Bool) ((a,c),c) ((b,d),d)-  -- q = f \`@'parDF'@\` g \`@'parDF'@\` g-  ---  -- r = q \`@'seqDF'@\` 'lockStep' \`@'seqDF'@\` p-  -- @-  ---  -- Does the right thing.-  lockStep :: DataFlow dom a Bool b b--  -- | Extend the synchronization granularity from a single 'Bool'ean value.-  ---  -- Given:-  ---  -- @-  -- __f__ :: 'DataFlow' Bool Bool a b-  -- __g__ :: 'DataFlow' Bool Bool c d-  -- __h__ :: 'DataFlow' Bool Bool (p,q) (a,c)-  -- @-  ---  -- We /cannot/ simply write:-  ---  -- @-  -- h \`@'seqDF'@\` (f \`@'parDF'@\` g)-  -- @-  ---  -- because, @f \`parDF\` g@, has type, @'DataFlow' (Bool,Bool) (Bool,Bool) (a,c) (b,d)@,-  -- which does not match the expected synchronization granularity of @h@. We-  -- need a circuit in between that has the type:-  ---  -- @-  -- 'DataFlow' Bool (Bool,Bool) (a,c) (a,c)-  -- @-  ---  -- Simply '&&'-ing the /ready/ signals in the backward direction, and-  -- duplicating the /valid/ signal in the forward direction is however not-  -- enough. We need to make sure that @f@ does not consume values when @g@ is-  -- not /ready/ and visa versa, because @h@ cannot update the values of its-  -- output tuple independently. @f@'s /valid/ port is hence only asserted when-  -- @h@ is valid and @g@ is ready to receive new values. @g@'s /valid/ port is-  -- only asserted when @h@ is valid and @f@ is ready to receive new values.-  -- @f@ and @g@ will hence be proceeding in /lock-step/.-  ---  -- The 'stepLock' function ensures that all synchronization signals are-  -- properly connected:-  ---  -- @-  -- h \`@'seqDF'@\` 'stepLock' \`@'seqDF'@\` (f \`@'parDF'@\` g)-  -- @-  ---  -- <<doc/stepLock.svg>>-  ---  -- __Note 1__: ensure that the components that you are synchronizing have-  -- buffered/delayed @ready@ and @valid@ signals, or 'stepLock' has the-  -- potential to introduce combinational loops. You can do this by placing-  -- 'fifoDF's on the parallel channels. Extending the above example, you would-  -- write:-  ---  -- @-  -- h \`@'seqDF'@\` 'stepLock' \`@'seqDF'@\` ((`fifoDF` d4 Nil \`@'seqDF'@\` f) \`@'parDF'@\` (`fifoDF` d4 Nil \`@'seqDF'@\` g))-  -- @-  ---  -- __Note 2__: 'stepLock' works for arbitrarily nested tuples. That is:-  ---  -- @-  -- p :: 'DataFlow' Bool Bool z ((a,c),c)-  ---  -- q :: 'DataFlow' ((Bool,Bool),Bool) ((Bool,Bool),Bool) ((a,c),c) ((b,d),d)-  -- q = f \`@'parDF'@\` g \`@'parDF'@\` g-  ---  -- r = p \`@'seqDF'@\` 'stepLock' \`@'seqDF'@\` q-  -- @-  ---  -- Does the right thing.-  stepLock :: DataFlow dom Bool a b b--instance LockStep Bool c where-  lockStep = idDF-  stepLock = idDF--instance (LockStep a x, LockStep b y) => LockStep (a,b) (x,y) where-  lockStep = (lockStep `parDF` lockStep) `seqDF`-                (DF (\xy xyV rdy -> let (xV,yV)   = unbundle xyV-                                        val       = xV .&&. yV-                                        xR        = yV .&&. rdy-                                        yR        = xV .&&. rdy-                                        xyR       = bundle (xR,yR)-                                    in  (xy,val,xyR)))--  stepLock = (DF (\xy val xyR -> let (xR,yR) = unbundle xyR-                                     rdy     = xR  .&&. yR-                                     xV      = val .&&. yR-                                     yV      = val .&&. xR-                                     xyV     = bundle (xV,yV)-                                 in  (xy,xyV,rdy))) `seqDF` (stepLock `parDF` stepLock)--instance (LockStep en a, KnownNat n) => LockStep (Vec n en) (Vec n a) where-  lockStep = parNDF (repeat lockStep) `seqDF`-    DF (\xs vals rdy ->-          let val  = (and . (True :>)) <$> vals-              rdys = allReady <$> rdy <*> (repeat . (:< True) <$> vals)-          in  (xs,val,rdys)-       )-  stepLock =-    DF (\xs val rdys ->-          let rdy  = (and . (True :>)) <$> rdys-              vals = allReady <$> val <*> (repeat . (:< True) <$> rdys)-          in  (xs,vals,rdy)-       ) `seqDF` parNDF (repeat stepLock)--allReady :: KnownNat n-         => Bool-         -> Vec n (Vec (n+1) Bool)-         -> Vec n Bool-allReady b vs = map (and . (b :>) . tail) (smap (flip rotateLeftS) vs)
src/Clash/Prelude/Mealy.hs view
@@ -2,6 +2,7 @@   Copyright  :  (C) 2013-2016, University of Twente,                     2017     , Google Inc.                     2019     , Myrtle Software Ltd+                    2023     , Alex Mason   License    :  BSD2 (see the file LICENSE)   Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> @@ -13,13 +14,16 @@ -}  {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}  {-# LANGUAGE Safe #-}  module Clash.Prelude.Mealy   ( -- * Mealy machine synchronized to the system clock     mealy+  , mealyS   , mealyB+  , mealySB   , (<^>)   ) where@@ -28,9 +32,15 @@ import           Clash.Signal import           Clash.XException           (NFDataX) +import           Control.Monad.State.Strict (State)+ {- $setup->>> :set -XDataKinds -XTypeApplications->>> import Clash.Prelude+>>> :set -XDataKinds -XTypeApplications -XDeriveGeneric -XDeriveAnyClass+>>> import Clash.Prelude as C+>>> import Clash.Prelude.Mealy (mealyS)+>>> import qualified Data.List as L+>>> import Control.Lens (Lens', (%=), (-=), uses, use)+>>> import Control.Monad.State.Strict (State) >>> :{ let macT s (x,y) = (s',s)       where@@ -38,6 +48,41 @@     mac = mealy macT 0 :} +>>> :{+data DelayState = DelayState { _history :: Vec 4 Int , _untilValid :: Index 4 } deriving (Generic,NFDataX)+:}++>>> :{+history :: Lens' DelayState (Vec 4 Int)+history f = \(DelayState d u) -> (`DelayState` u) <$> f d+:}++>>> :{+untilValid :: Lens' DelayState (Index 4)+untilValid f = \(DelayState d u) -> DelayState d <$> f u+:}++>>> :{+delayS :: Int -> State DelayState (Maybe Int)+delayS n = do+  history   %= (n +>>)+  remaining <- use untilValid+  if remaining > 0+  then do+     untilValid -= 1+     return Nothing+   else do+     out <- uses history C.last+     return (Just out)+:}++>>> let initialDelayState = DelayState (C.repeat 0) maxBound++>>> :{+delayTop :: HiddenClockResetEnable dom => Signal dom Int -> Signal dom (Maybe Int)+delayTop = mealyS delayS initialDelayState+:}+ -}  -- | Create a synchronous function from a combinational function describing@@ -71,8 +116,8 @@ --   -> 'Signal' dom Int -- dualMac (a,b) (x,y) = s1 + s2 --   where---     s1 = 'mealy' mac 0 ('Clash.Signal.bundle' (a,x))---     s2 = 'mealy' mac 0 ('Clash.Signal.bundle' (b,y))+--     s1 = 'mealy' macT 0 ('Clash.Signal.bundle' (a,x))+--     s2 = 'mealy' macT 0 ('Clash.Signal.bundle' (b,y)) -- @ mealy   :: ( HiddenClockResetEnable dom@@ -127,6 +172,70 @@   -- of the mealy machine mealyB = hideClockResetEnable E.mealyB {-# INLINE mealyB #-}+++-- | Create a synchronous function from a combinational function describing+-- a mealy machine using the state monad. This can be particularly useful+-- when combined with lenses or optics to replicate imperative algorithms.+--+-- @+-- data DelayState = DelayState+--   { _history    :: Vec 4 Int+--   , _untilValid :: Index 4+--   }+--   deriving (Generic, NFDataX)+-- makeLenses ''DelayState+--+-- initialDelayState = DelayState (repeat 0) maxBound+--+-- delayS :: Int -> State DelayState (Maybe Int)+-- delayS n = do+--   history   %= (n +>>)+--   remaining <- use untilValid+--   if remaining > 0+--   then do+--      untilValid -= 1+--      return Nothing+--    else do+--      out <- uses history last+--      return (Just out)+--+-- delayTop :: HiddenClockResetEnable dom  => 'Signal' dom Int -> 'Signal' dom (Maybe Int)+-- delayTop = 'mealyS' delayS initialDelayState+-- @+--+-- >>> L.take 7 $ simulate @System delayTop [1,2,3,4,5,6,7,8]+-- [Nothing,Nothing,Nothing,Just 1,Just 2,Just 3,Just 4]+-- ...+--+mealyS+  :: ( HiddenClockResetEnable dom+     , NFDataX s )+  => (i -> State s o)+  --  ^ Transfer function in mealy machine handling inputs using @Control.Monad.Strict.State s@.+  -> s+  -- ^ Initial state+  -> (Signal dom i -> Signal dom o)+  -- ^ Synchronous sequential function with input and output matching that+  -- of the mealy machine+mealyS = hideClockResetEnable E.mealyS+{-# INLINE mealyS #-}++-- | A version of 'mealyS' that does automatic 'Bundle'ing, see 'mealyB' for details.+mealySB+  :: ( HiddenClockResetEnable dom+     , NFDataX s+     , Bundle i+     , Bundle o  )+  => (i -> State s o)+  --  ^ Transfer function in mealy machine handling inputs using @Control.Monad.Strict.State s@.+  -> s+  -- ^ Initial state+  -> (Unbundled dom i -> Unbundled dom o)+  -- ^ Synchronous sequential function with input and output matching that+  -- of the mealy machine+mealySB = hideClockResetEnable E.mealySB+{-# INLINE mealySB #-}  -- | Infix version of 'mealyB' (<^>)
src/Clash/Prelude/Moore.hs view
@@ -13,6 +13,7 @@ -}  {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}  {-# LANGUAGE Safe #-} @@ -31,6 +32,8 @@  {- $setup >>> :set -XDataKinds -XTypeApplications+>>> :m -Clash.Explicit.Prelude+>>> :m -Clash.Explicit.Prelude.Safe >>> import Clash.Prelude >>> :{ let macT s (x,y) = x * y + s@@ -72,8 +75,8 @@ --   -> 'Signal' dom Int -- dualMac (a,b) (x,y) = s1 + s2 --   where---     s1 = 'moore' mac id 0 ('Clash.Signal.bundle' (a,x))---     s2 = 'moore' mac id 0 ('Clash.Signal.bundle' (b,y))+--     s1 = 'moore' macT id 0 ('Clash.Signal.bundle' (a,x))+--     s2 = 'moore' macT id 0 ('Clash.Signal.bundle' (b,y)) -- @ moore   :: ( HiddenClockResetEnable dom
src/Clash/Prelude/RAM.hs view
@@ -1,22 +1,18 @@ {-| Copyright  :  (C) 2015-2016, University of Twente,                   2017-2019, Myrtle Software Ltd-                  2017     , Google Inc.+                  2017     , Google Inc.,+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -RAM primitives with a combinational read port.+RAM primitives with a combinational read port -} -{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}  {-# LANGUAGE Safe #-} @@ -36,21 +32,25 @@ import           Clash.Promoted.Nat   (SNat) import           Clash.Signal import           Clash.Sized.Unsigned (Unsigned)+import           Clash.XException     (NFDataX)  --- | Create a RAM with space for @n@ elements.+-- | Create a RAM with space for @n@ elements ----- * __NB__: Initial content of the RAM is 'undefined'+-- * __NB__: Initial content of the RAM is /undefined/, reading it will throw an+-- 'Clash.XException.XException' ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a -- RAM. asyncRam   :: ( Enum addr+     , NFDataX addr      , HiddenClock dom      , HiddenEnable dom      , HasCallStack+     , NFDataX a      )   => SNat n   -- ^ Size @n@ of the RAM@@ -59,16 +59,17 @@   -> Signal dom (Maybe (addr, a))    -- ^ (write address @w@, value to write)   -> Signal dom a-   -- ^ Value of the @RAM@ at address @r@+   -- ^ Value of the RAM at address @r@ asyncRam = \sz rd wrM -> withFrozenCallStack   (hideEnable (\en -> hideClock (\clk -> E.asyncRam clk clk en sz rd wrM))) {-# INLINE asyncRam #-}  -- | Create a RAM with space for 2^@n@ elements ----- * __NB__: Initial content of the RAM is 'undefined'+-- * __NB__: Initial content of the RAM is /undefined/, reading it will throw an+-- 'Clash.XException.XException' ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a -- RAM.@@ -76,13 +77,15 @@   :: ( KnownNat n      , HiddenClock dom      , HiddenEnable dom-     , HasCallStack )+     , HasCallStack+     , NFDataX a+     )   => Signal dom (Unsigned n)   -- ^ Read address @r@   -> Signal dom (Maybe (Unsigned n, a))   -- ^ (write address @w@, value to write)   -> Signal dom a-  -- ^ Value of the @RAM@ at address @r@+  -- ^ Value of the RAM at address @r@ asyncRamPow2 = \rd wrM -> withFrozenCallStack   (hideEnable (\en -> (hideClock (\clk -> E.asyncRamPow2 clk clk en rd wrM)))) {-# INLINE asyncRamPow2 #-}
src/Clash/Prelude/ROM.hs view
@@ -1,20 +1,19 @@ {-| Copyright  :  (C) 2015-2016, University of Twente,                   2017     , Google Inc.-                  2019     , Myrtle Software Ltd+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  ROMs -} -{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash        #-}-{-# LANGUAGE RankNTypes       #-}-{-# LANGUAGE TypeOperators    #-}+{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-}  {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-}@@ -31,81 +30,114 @@   ) where -import           Data.Array           ((!),listArray)+import           Data.Array           (listArray)+import           Data.Array.Base      (unsafeAt)+import           GHC.Stack            (withFrozenCallStack) import           GHC.TypeLits         (KnownNat, type (^)) import           Prelude              hiding (length) +import           Clash.Annotations.Primitive (hasBlackBox) import qualified Clash.Explicit.ROM   as E import           Clash.Signal import           Clash.Sized.Unsigned (Unsigned) import           Clash.Sized.Vector   (Vec, length, toList) -import           Clash.XException     (NFDataX)+import           Clash.XException     (NFDataX, deepErrorX)  -- | An asynchronous/combinational ROM with space for @n@ elements ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Prelude.BlockRam#usingrams"--- for ideas on how to use ROMs and RAMs+-- for ideas on how to use ROMs and RAMs.+-- * A large 'Vec' for the content may be too inefficient, depending on how it+-- is constructed. See 'Clash.Prelude.ROM.File.asyncRomFile' and+-- 'Clash.Prelude.ROM.Blob.asyncRomBlob' for different approaches that scale+-- well. asyncRom-  :: (KnownNat n, Enum addr)+  :: ( KnownNat n+     , Enum addr+     , NFDataX a+     )   => Vec n a-  -- ^ ROM content+  -- ^ ROM content, also determines the size, @n@, of the ROM   ---  -- __NB:__ must be a constant+  -- __NB__: __MUST__ be a constant   -> addr-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> a-  -- ^ The value of the ROM at address @rd@+  -- ^ The value of the ROM at address @r@ asyncRom = \content rd -> asyncRom# content (fromEnum rd) {-# INLINE asyncRom #-}  -- | An asynchronous/combinational ROM with space for 2^@n@ elements ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Prelude.BlockRam#usingrams"--- for ideas on how to use ROMs and RAMs+-- for ideas on how to use ROMs and RAMs.+-- * A large 'Vec' for the content may be too inefficient, depending on how it+-- is constructed. See 'Clash.Prelude.ROM.File.asyncRomFilePow2' and+-- 'Clash.Prelude.ROM.Blob.asyncRomBlobPow2' for different approaches that scale+-- well. asyncRomPow2-  :: KnownNat n+  :: ( KnownNat n+     , NFDataX a+     )   => Vec (2^n) a   -- ^ ROM content   ---  -- __NB:__ must be a constant+  -- __NB__: __MUST__ be a constant   -> Unsigned n-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> a-  -- ^ The value of the ROM at address @rd@+  -- ^ The value of the ROM at address @r@ asyncRomPow2 = asyncRom {-# INLINE asyncRomPow2 #-} --- | asyncROM primitive+-- | asyncRom primitive asyncRom#-  :: KnownNat n+  :: forall n a+   . ( KnownNat n+     , NFDataX a+     )   => Vec n a-  -- ^ ROM content+  -- ^ ROM content, also determines the size, @n@, of the ROM   ---  -- __NB:__ must be a constant+  -- __NB__: __MUST__ be a constant   -> Int-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> a-  -- ^ The value of the ROM at address @rd@-asyncRom# content rd = arr ! rd+  -- ^ The value of the ROM at address @r@+asyncRom# content = safeAt   where     szI = length content     arr = listArray (0,szI-1) (toList content)-{-# NOINLINE asyncRom# #-} +    safeAt :: Int -> a+    safeAt i =+      if (0 <= i) && (i < szI) then+        unsafeAt arr i+      else+        withFrozenCallStack+          (deepErrorX ("asyncRom: address " ++ show i +++                       " not in range [0.." ++ show szI ++ ")"))+{-# OPAQUE asyncRom# #-}+{-# ANN asyncRom# hasBlackBox #-}+ -- | A ROM with a synchronous read port, with space for @n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException' ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Prelude.BlockRam#usingrams"--- for ideas on how to use ROMs and RAMs+-- for ideas on how to use ROMs and RAMs.+-- * A large 'Vec' for the content may be too inefficient, depending on how it+-- is constructed. See 'Clash.Prelude.ROM.File.romFile' and+-- 'Clash.Prelude.ROM.Blob.romBlob' for different approaches that scale well. rom   :: forall dom n m a    . ( NFDataX a@@ -114,25 +146,30 @@      , HiddenClock dom      , HiddenEnable dom  )   => Vec n a-  -- ^ ROM content+  -- ^ ROM content, also determines the size, @n@, of the ROM   ---  -- __NB:__ must be a constant+  -- __NB__: __MUST__ be a constant   -> Signal dom (Unsigned m)-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> Signal dom a-  -- ^ The value of the ROM at address @rd@+  -- ^ The value of the ROM at address @r@ from the previous clock cycle rom = hideEnable (hideClock E.rom) {-# INLINE rom #-}  -- | A ROM with a synchronous read port, with space for 2^@n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException' ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Prelude.BlockRam#usingrams"--- for ideas on how to use ROMs and RAMs+-- for ideas on how to use ROMs and RAMs.+-- * A large 'Vec' for the content may be too inefficient, depending on how it+-- is constructed. See 'Clash.Prelude.ROM.File.romFilePow2' and+-- 'Clash.Prelude.ROM.Blob.romBlobPow2' for different approaches that scale+-- well. romPow2   :: forall dom n a    . ( KnownNat n@@ -142,10 +179,10 @@   => Vec (2^n) a   -- ^ ROM content   ---  -- __NB:__ must be a constant+  -- __NB__: __MUST__ be a constant   -> Signal dom (Unsigned n)-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> Signal dom a-  -- ^ The value of the ROM at address @rd@+  -- ^ The value of the ROM at address @r@ from the previous clock cycle romPow2 = hideEnable (hideClock E.romPow2) {-# INLINE romPow2 #-}
+ src/Clash/Prelude/ROM/Blob.hs view
@@ -0,0 +1,176 @@+{-|+Copyright  :  (C) 2022     , QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++= Efficient bundling of ROM content with the compiled code++Leveraging Template Haskell, the content for the ROM components in this module+is stored alongside the compiled Haskell code. It covers use cases where passing+the initial content as a 'Clash.Sized.Vector.Vec' turns out to be+problematically slow.++The data is stored efficiently, with very little overhead (worst-case 7%, often+no overhead at all).++Unlike "Clash.Prelude.ROM.File", "Clash.Prelude.ROM.Blob" generates practically+the same HDL as "Clash.Prelude.ROM" and is compatible with all tools consuming+the generated HDL.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Prelude.ROM.Blob+  ( -- * Asynchronous ROM defined by a 'MemBlob'+    asyncRomBlob+  , asyncRomBlobPow2+    -- * Synchronous 'MemBlob' ROM synchronized to an arbitrary clock+  , romBlob+  , romBlobPow2+    -- * Creating and inspecting 'MemBlob'+  , MemBlob+  , createMemBlob+  , memBlobTH+  , unpackMemBlob+    -- * Internal+  , asyncRomBlob#+  )+where++import Data.Array (listArray)+import Data.Array.Base (unsafeAt)+import GHC.Stack (withFrozenCallStack)+import GHC.TypeLits (KnownNat, type (^))++import Clash.Annotations.Primitive (hasBlackBox)+import qualified Clash.Explicit.ROM.Blob as E+import Clash.Explicit.BlockRam.Blob (createMemBlob, memBlobTH)+import Clash.Explicit.BlockRam.Internal (MemBlob(..), unpackMemBlob)+import Clash.Promoted.Nat (natToNum)+import Clash.Signal (hideClock, hideEnable, HiddenClock, HiddenEnable)+import Clash.Signal.Internal (Signal)+import Clash.Sized.Internal.BitVector (BitVector)+import Clash.Sized.Internal.Unsigned (Unsigned)+import Clash.XException (deepErrorX)++-- | An asynchronous/combinational ROM with space for @n@ elements+--+-- === See also:+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" and+-- "Clash.Prelude.BlockRam#usingrams" for ideas on how to use ROMs and RAMs.+asyncRomBlob+  :: Enum addr+  => MemBlob n m+  -- ^ ROM content, also determines the size, @n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> addr+  -- ^ Read address @r@+  -> BitVector m+  -- ^ The value of the ROM at address @r@+asyncRomBlob = \content rd -> asyncRomBlob# content (fromEnum rd)+{-# INLINE asyncRomBlob #-}++-- | An asynchronous/combinational ROM with space for 2^@n@ elements+--+-- === See also:+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" and+-- "Clash.Prelude.BlockRam#usingrams" for ideas on how to use ROMs and RAMs.+asyncRomBlobPow2+  :: KnownNat n+  => MemBlob (2^n) m+  -- ^ ROM content, also determines the size, 2^@n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Unsigned n+  -- ^ Read address @r@+  -> BitVector m+  -- ^ The value of the ROM at address @r@+asyncRomBlobPow2 = asyncRomBlob+{-# INLINE asyncRomBlobPow2 #-}++-- | asyncRomBlob primitive+asyncRomBlob#+  :: forall m n+   . MemBlob n m+  -- ^ ROM content, also determines the size, @n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Int+  -- ^ Read address @r@+  -> BitVector m+  -- ^ The value of the ROM at address @r@+asyncRomBlob# content@MemBlob{} = safeAt+  where+    szI = natToNum @n @Int+    arr = listArray (0,szI-1) $ unpackMemBlob content++    safeAt :: Int -> BitVector m+    safeAt i =+      if (0 <= i) && (i < szI) then+        unsafeAt arr i+      else+        withFrozenCallStack+          (deepErrorX ("asyncRom: address " ++ show i +++                       " not in range [0.." ++ show szI ++ ")"))+{-# ANN asyncRomBlob# hasBlackBox #-}+{-# OPAQUE asyncRomBlob# #-}++-- | A ROM with a synchronous read port, with space for @n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException'+--+-- === See also:+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" and+-- "Clash.Explicit.BlockRam#usingrams" for ideas on how to use ROMs and RAMs.+romBlob+  :: forall dom addr m n+   . ( HiddenClock dom+     , HiddenEnable dom+     , Enum addr+     )+  => MemBlob n m+  -- ^ ROM content, also determines the size, @n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ The value of the ROM at address @r@ from the previous clock cycle+romBlob = hideEnable (hideClock E.romBlob)+{-# INLINE romBlob #-}++-- | A ROM with a synchronous read port, with space for 2^@n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException'+--+-- === See also:+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" and+-- "Clash.Explicit.BlockRam#usingrams" for ideas on how to use ROMs and RAMs.+romBlobPow2+  :: forall dom m n+   . ( HiddenClock dom+     , HiddenEnable dom+     , KnownNat n+     )+  => MemBlob (2^n) m+  -- ^ ROM content, also determines the size, 2^@n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom (Unsigned n)+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ The value of the ROM at address @r@ from the previous clock cycle+romBlobPow2 = hideEnable (hideClock E.romBlobPow2)+{-# INLINE romBlobPow2 #-}
src/Clash/Prelude/ROM/File.hs view
@@ -1,40 +1,45 @@ {-| Copyright  :  (C) 2015-2016, University of Twente,-                  2017     , Google Inc.-                  2019     , Myrtle Software Ltd+                  2017     , Google Inc.,+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  = Initializing a ROM with a data file #usingromfiles#  ROMs initialized with a data file. The BNF grammar for this data file is simple: -@-FILE = LINE+-LINE = BIT+-BIT  = '0'-     | '1'-@+> FILE = LINE++> LINE = BIT++> BIT  = '0'+>      | '1'  Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@.-For example, a data file @memory.bin@ containing the 9-bit unsigned number+For example, a data file @memory.bin@ containing the 9-bit unsigned numbers @7@ to @13@ looks like: +> 000000111+> 000001000+> 000001001+> 000001010+> 000001011+> 000001100+> 000001101++Such a file can be produced with 'memFile':+ @-000000111-000001000-000001001-000001010-000001011-000001100-000001101+writeFile "memory.bin" (memFile Nothing [7 :: Unsigned 9 .. 13]) @ -We can instantiate a synchronous ROM using the content of the above file like+We can instantiate a synchronous ROM using the contents of the file above like so:  @-f :: HiddenClock dom  => Signal dom (Unsigned 3) -> Signal dom (Unsigned 9)+f :: (HiddenClock dom, HiddenEnable dom)+   => Signal dom (Unsigned 3)+   -> Signal dom (Unsigned 9) f rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' d7 \"memory.bin\" rd @ @@ -50,7 +55,9 @@ number, and a 3-bit signed number:  @-g :: HiddenClock dom  => Signal dom (Unsigned 3) -> Signal dom (Unsigned 6,Signed 3)+g :: (HiddenClock dom, HiddenEnable dom)+  => Signal dom (Unsigned 3)+  -> Signal dom (Unsigned 6,Signed 3) g rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' d7 \"memory.bin\" rd @ @@ -63,12 +70,8 @@ @ -} -{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}  {-# LANGUAGE Unsafe #-} @@ -81,6 +84,8 @@     -- * Synchronous ROM synchronized to an arbitrary clock   , romFile   , romFilePow2+    -- * Producing files+  , memFile     -- * Internal   , asyncRomFile#   )@@ -90,7 +95,8 @@ import           GHC.TypeLits                 (KnownNat) import           System.IO.Unsafe             (unsafePerformIO) -import           Clash.Explicit.BlockRam.File (initMem)+import           Clash.Annotations.Primitive (hasBlackBox)+import           Clash.Explicit.BlockRam.File (initMem, memFile) import qualified Clash.Explicit.ROM.File      as E import           Clash.Promoted.Nat           (SNat (..), pow2SNat, snatToNum) import           Clash.Signal@@ -103,16 +109,17 @@ -- code-generation backends and hardware targets. Please check the support table -- below: -----     @---                    | VHDL     | Verilog  | SystemVerilog |---     ===============+==========+==========+===============+---     Altera/Quartus | Broken   | Works    | Works         |---     Xilinx/ISE     | Works    | Works    | Works         |---     ASIC           | Untested | Untested | Untested      |---     ===============+==========+==========+===============+---     @+-- +----------------+----------+----------+---------------++-- |                | VHDL     | Verilog  | SystemVerilog |+-- +================+==========+==========+===============++-- | Altera/Quartus | Broken   | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | Xilinx/ISE     | Works    | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | ASIC           | Untested | Untested | Untested      |+-- +----------------+----------+----------+---------------+ ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Prelude.ROM.File#usingromfiles" for more information on how -- to instantiate a ROM with the contents of a data file.@@ -146,11 +153,11 @@   -> FilePath   -- ^ File describing the content of the ROM   -> addr-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> BitVector m-  -- ^ The value of the ROM at address @rd@+  -- ^ The value of the ROM at address @r@ asyncRomFile sz file = asyncRomFile# sz file . fromEnum--- Leave 'asyncRom' eta-reduced, see Note [Eta-reduction and unsafePerformIO initMem]+-- Leave 'asyncRomFile#' eta-reduced, see Note [Eta-reduction and unsafePerformIO initMem] {-# INLINE asyncRomFile #-}  -- Note [Eta-reduction and unsafePerformIO initMem]@@ -187,16 +194,17 @@ -- code-generation backends and hardware targets. Please check the support table -- below: -----     @---                    | VHDL     | Verilog  | SystemVerilog |---     ===============+==========+==========+===============+---     Altera/Quartus | Broken   | Works    | Works         |---     Xilinx/ISE     | Works    | Works    | Works         |---     ASIC           | Untested | Untested | Untested      |---     ===============+==========+==========+===============+---     @+-- +----------------+----------+----------+---------------++-- |                | VHDL     | Verilog  | SystemVerilog |+-- +================+==========+==========+===============++-- | Altera/Quartus | Broken   | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | Xilinx/ISE     | Works    | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | ASIC           | Untested | Untested | Untested      |+-- +----------------+----------+----------+---------------+ ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Prelude.ROM.File#usingromfiles" for more information on how -- to instantiate a ROM with the contents of a data file.@@ -222,13 +230,13 @@   => FilePath   -- ^ File describing the content of the ROM   -> Unsigned n-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> BitVector m-  -- ^ The value of the ROM at address @rd@-asyncRomFilePow2 = asyncRomFile (pow2SNat (SNat @ n))+  -- ^ The value of the ROM at address @r@+asyncRomFilePow2 = asyncRomFile (pow2SNat (SNat @n)) {-# INLINE asyncRomFilePow2 #-} --- | asyncROMFile primitive+-- | asyncRomFile primitive asyncRomFile#   :: KnownNat m   => SNat n@@ -236,34 +244,37 @@   -> FilePath   -- ^ File describing the content of the ROM   -> Int-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> BitVector m-  -- ^ The value of the ROM at address @rd@+  -- ^ The value of the ROM at address @r@ asyncRomFile# sz file = (content !) -- Leave "(content !)" eta-reduced, see   where                             -- Note [Eta-reduction and unsafePerformIO initMem]     mem     = unsafePerformIO (initMem file)     content = listArray (0,szI-1) mem     szI     = snatToNum sz-{-# NOINLINE asyncRomFile# #-}+{-# OPAQUE asyncRomFile# #-}+{-# ANN asyncRomFile# hasBlackBox #-}  -- | A ROM with a synchronous read port, with space for @n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException' -- * __NB__: This function might not work for specific combinations of -- code-generation backends and hardware targets. Please check the support table -- below: -----     @---                    | VHDL     | Verilog  | SystemVerilog |---     ===============+==========+==========+===============+---     Altera/Quartus | Broken   | Works    | Works         |---     Xilinx/ISE     | Works    | Works    | Works         |---     ASIC           | Untested | Untested | Untested      |---     ===============+==========+==========+===============+---     @+-- +----------------+----------+----------+---------------++-- |                | VHDL     | Verilog  | SystemVerilog |+-- +================+==========+==========+===============++-- | Altera/Quartus | Broken   | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | Xilinx/ISE     | Works    | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | ASIC           | Untested | Untested | Untested      |+-- +----------------+----------+----------+---------------+ ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Prelude.ROM.File#usingromfiles" for more information on how -- to instantiate a ROM with the contents of a data file.@@ -274,36 +285,39 @@      , KnownNat n      , HiddenClock dom      , HiddenEnable dom+     , Enum addr      )   => SNat n   -- ^ Size of the ROM   -> FilePath   -- ^ File describing the content of the ROM-  -> Signal dom (Unsigned n)-  -- ^ Read address @rd@+  -> Signal dom addr+  -- ^ Read address @r@   -> Signal dom (BitVector m)-  -- ^ The value of the ROM at address @rd@ from the previous clock cycle+  -- ^ The value of the ROM at address @r@ from the previous clock cycle romFile = hideEnable (hideClock E.romFile) {-# INLINE romFile #-}  -- | A ROM with a synchronous read port, with space for 2^@n@ elements -- -- * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException' -- * __NB__: This function might not work for specific combinations of -- code-generation backends and hardware targets. Please check the support table -- below: -----     @---                    | VHDL     | Verilog  | SystemVerilog |---     ===============+==========+==========+===============+---     Altera/Quartus | Broken   | Works    | Works         |---     Xilinx/ISE     | Works    | Works    | Works         |---     ASIC           | Untested | Untested | Untested      |---     ===============+==========+==========+===============+---     @+-- +----------------+----------+----------+---------------++-- |                | VHDL     | Verilog  | SystemVerilog |+-- +================+==========+==========+===============++-- | Altera/Quartus | Broken   | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | Xilinx/ISE     | Works    | Works    | Works         |+-- +----------------+----------+----------+---------------++-- | ASIC           | Untested | Untested | Untested      |+-- +----------------+----------+----------+---------------+ ----- Additional helpful information:+-- === See also: -- -- * See "Clash.Prelude.ROM.File#usingromfiles" for more information on how -- to instantiate a ROM with the contents of a data file.@@ -319,8 +333,8 @@   => FilePath   -- ^ File describing the content of the ROM   -> Signal dom (Unsigned n)-  -- ^ Read address @rd@+  -- ^ Read address @r@   -> Signal dom (BitVector m)-  -- ^ The value of the ROM at address @rd@ from the previous clock cycle+  -- ^ The value of the ROM at address @r@ from the previous clock cycle romFilePow2 = hideEnable (hideClock E.romFilePow2) {-# INLINE romFilePow2 #-}
src/Clash/Prelude/Safe.hs view
@@ -1,11 +1,12 @@ {-|   Copyright   :  (C) 2013-2016, University of Twente,                      2017-2019, Myrtle Software Ltd-                     2017     , Google Inc.+                     2017     , Google Inc.,+                     2021-2022, QBayLogic B.V.   License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com> -  __This is the <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/safe_haskell.html Safe> API only of "Clash.Prelude"__+  __This is the <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/exts/safe_haskell.html Safe> API only of "Clash.Prelude"__    Clash is a functional hardware description language that borrows both its   syntax and semantics from the functional programming language Haskell. The@@ -25,14 +26,15 @@     explicitly clocked circuits in a multi-clock setting    For now, "Clash.Prelude" is also the best starting point for exploring the-  library. A preliminary version of a tutorial can be found in "Clash.Tutorial".-  Some circuit examples can be found in "Clash.Examples".+  library. A preliminary version of a tutorial can be found at+  https://docs.clash-lang.org/tutorial. Some circuit examples can be found in+  "Clash.Examples". -} -{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE NoImplicitPrelude   #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}  {-# LANGUAGE Safe #-} @@ -41,7 +43,9 @@ module Clash.Prelude.Safe   ( -- * Creating synchronous sequential circuits     mealy+  , mealyS   , mealyB+  , mealySB   , (<^>)   , moore   , mooreB@@ -51,14 +55,30 @@   , asyncRomPow2   , rom   , romPow2+    -- ** ROMs defined by a 'MemBlob'+  , asyncRomBlob+  , asyncRomBlobPow2+  , romBlob+  , romBlobPow2     -- * RAM primitives with a combinational read port   , asyncRam   , asyncRamPow2     -- * BlockRAM primitives   , blockRam   , blockRamPow2+    -- ** BlockRAM primitives initialized with a 'MemBlob'+  , blockRamBlob+  , blockRamBlobPow2+    -- *** Creating and inspecting 'MemBlob'+  , MemBlob+  , createMemBlob+  , memBlobTH+  , unpackMemBlob     -- ** BlockRAM read/write conflict resolution   , readNew+    -- ** True dual-port block RAM+  , trueDualPortBlockRam+  , RamOp(..)     -- * Utility functions   , isRising   , isFalling@@ -68,13 +88,9 @@     -- ** Synchronous signals   , module Clash.Signal   , module Clash.Signal.Delayed-    -- ** DataFlow interface-  , module Clash.Prelude.DataFlow     -- ** Datatypes     -- *** Bit vectors   , module Clash.Sized.BitVector-  , module Clash.Prelude.BitIndex-  , module Clash.Prelude.BitReduction     -- *** Arbitrary-width numbers   , module Clash.Sized.Signed   , module Clash.Sized.Unsigned@@ -108,7 +124,6 @@   , module Data.Bits       -- ** Exceptions   , module Clash.XException-  , E.undefined     -- ** Named types   , module Clash.NamedTypes     -- ** Hidden arguments@@ -124,6 +139,7 @@ import           GHC.Generics (Generic, Generic1)  import           GHC.TypeLits+  hiding (SNat, SSymbol, fromSNat) import           GHC.TypeLits.Extra import           Clash.HaskellPrelude @@ -133,15 +149,14 @@ import           Clash.Class.Resize import           Clash.Hidden import           Clash.NamedTypes-import           Clash.Prelude.BitIndex-import           Clash.Prelude.BitReduction import           Clash.Prelude.BlockRam+import           Clash.Prelude.BlockRam.Blob import qualified Clash.Explicit.Prelude.Safe as E-import           Clash.Prelude.Mealy         (mealy, mealyB, (<^>))+import           Clash.Prelude.Mealy         (mealy, mealyB, mealyS, mealySB, (<^>)) import           Clash.Prelude.Moore         (moore, mooreB) import           Clash.Prelude.RAM           (asyncRam,asyncRamPow2) import           Clash.Prelude.ROM           (asyncRom,asyncRomPow2,rom,romPow2)-import           Clash.Prelude.DataFlow+import           Clash.Prelude.ROM.Blob import           Clash.Promoted.Nat import           Clash.Promoted.Nat.TH import           Clash.Promoted.Nat.Literals@@ -152,24 +167,26 @@ import           Clash.Sized.RTree import           Clash.Sized.Signed import           Clash.Sized.Unsigned-import           Clash.Sized.Vector+import           Clash.Sized.Vector hiding (fromList, unsafeFromList) import           Clash.Signal import           Clash.Signal.Delayed import           Clash.XException  {- $setup >>> :set -XFlexibleContexts -XTypeApplications+>>> :m -Prelude+>>> :m -Clash.Explicit.Prelude+>>> import Clash.Prelude.Safe >>> let rP = registerB (8,8) -}  {- $hiding-"Clash.Prelude" re-exports most of the Haskell "Prelude" with the exception of-the following: (++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head,-init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr,-splitAt, tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3.--It instead exports the identically named functions defined in terms of-'Clash.Sized.Vector.Vec' at "Clash.Sized.Vector".+"Clash.Prelude.Safe" re-exports most of the Haskell "Prelude" with the exception+of those functions that the Clash API defines to work on 'Vec' from+"Clash.Sized.Vector" instead of on lists as the Haskell Prelude does. In+addition, for the 'Clash.Class.Parity.odd' and 'Clash.Class.Parity.even'+functions a type class called 'Clash.Class.Parity.Parity' is available at+"Clash.Class.Parity". -}  -- | Create a 'register' function for product-type like signals (e.g. '(Signal a, Signal b)')
− src/Clash/Prelude/Synchronizer.hs 
@@ -1,89 +0,0 @@-{-|-Copyright   :  (C) 2019, Myrtle Software Ltd,-License     :  BSD2 (see the file LICENSE)-Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--Synchronizer circuits for safe clock domain crossings--}--{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE TypeFamilies          #-}--module Clash.Prelude.Synchronizer-  ( -- * Bit-synchronizers-    dualFlipFlopSynchronizer-    -- * Word-synchronizers-  , asyncFIFOSynchronizer-  ) where--import qualified Clash.Explicit.Synchronizer as E-import           Clash.Promoted.Nat          (SNat)-import           Clash.Signal-  (HiddenClockResetEnable, HiddenClock, Signal, hasClock, hasReset, hasEnable)-import           Clash.XException            (NFDataX)-import           GHC.TypeLits                (type (<=))---- | Synchronizer based on two sequentially connected flip-flops.------  * __NB__: This synchronizer can be used for __bit__-synchronization.------  * __NB__: Although this synchronizer does reduce metastability, it does---  not guarantee the proper synchronization of a whole __word__. For---  example, given that the output is sampled twice as fast as the input is---  running, and we have two samples in the input stream that look like:------      @[0111,1000]@------      But the circuit driving the input stream has a longer propagation delay---      on __msb__ compared to the __lsb__s. What can happen is an output stream---      that looks like this:------      @[0111,0111,0000,1000]@------      Where the level-change of the __msb__ was not captured, but the level---      change of the __lsb__s were.------      If you want to have /safe/ __word__-synchronization use---      'asyncFIFOSynchronizer'.-dualFlipFlopSynchronizer-  :: ( NFDataX a-     , HiddenClock dom1-     , HiddenClockResetEnable dom2-     )-  => a-  -- ^ Initial value of the two synchronization registers-  -> Signal dom1 a-  -- ^ Incoming data-  -> Signal dom2 a-  -- ^ Outgoing, synchronized, data-dualFlipFlopSynchronizer =-  E.dualFlipFlopSynchronizer hasClock hasClock hasReset hasEnable---- | Synchronizer implemented as a FIFO around an asynchronous RAM. Based on the--- design described in "Clash.Tutorial#multiclock", which is itself based on the--- design described in <http://www.sunburst-design.com/papers/CummingsSNUG2002SJ_FIFO1.pdf>.------ __NB__: This synchronizer can be used for __word__-synchronization.-asyncFIFOSynchronizer-  :: ( HiddenClockResetEnable rdom-     , HiddenClockResetEnable wdom-     , 2 <= addrSize )-  => SNat addrSize-  -- ^ Size of the internally used addresses, the  FIFO contains @2^addrSize@-  -- elements.-  -> Signal rdom Bool-  -- ^ Read request-  -> Signal wdom (Maybe a)-  -- ^ Element to insert-  -> (Signal rdom a, Signal rdom Bool, Signal wdom Bool)-  -- ^ (Oldest element in the FIFO, @empty@ flag, @full@ flag)-asyncFIFOSynchronizer addrSize =-  E.asyncFIFOSynchronizer-    addrSize-    hasClock  -- wdom-    hasClock  -- rdom-    hasReset  -- wdom-    hasReset  -- rdom-    hasEnable  -- wdom-    hasEnable  -- rdom
src/Clash/Prelude/Testbench.hs view
@@ -1,15 +1,14 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2017     , Google Inc.-                  2019     , Myrtle Software Ltd+                  2019     , Myrtle Software Ltd,+                  2021-2023, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}  {-# LANGUAGE Unsafe #-} @@ -18,6 +17,7 @@ module Clash.Prelude.Testbench   ( -- * Testbench functions for circuits     assert+  , assertBitVector   , ignoreFor   , outputVerifier'   , outputVerifierBitVector'@@ -26,15 +26,16 @@   , E.tbClockGen   , E.tbEnableGen   , E.tbSystemClockGen+  , E.clockToDiffClock   ) where -import GHC.TypeLits                       (KnownNat)+import GHC.TypeLits                       (KnownNat, type (<=))  import qualified Clash.Explicit.Testbench as E import           Clash.Signal   (HiddenClock, HiddenReset, HiddenClockResetEnable, Signal,-  DomainResetKind, ResetKind(Asynchronous), hideClock, hideReset, hideClockResetEnable)+  hideClock, hideReset, hideClockResetEnable) import Clash.Promoted.Nat                 (SNat) import Clash.Sized.BitVector              (BitVector) import Clash.Sized.Vector                 (Vec)@@ -42,7 +43,11 @@  {- $setup >>> :set -XTemplateHaskell -XDataKinds -XTypeApplications+>>> :m -Clash.Explicit.Prelude+>>> :m -Clash.Explicit.Prelude.Safe+>>> :m -Clash.Explicit.Testbench >>> import Clash.Prelude+>>> import Clash.Prelude.Testbench >>> let testInput = stimuliGenerator $(listToVecTH [(1::Int),3..21]) >>> let expectedOutput = outputVerifier' $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int])) -}@@ -52,7 +57,13 @@ -- function simply returns the third 'Signal' unaltered as its result. This -- function is used by 'outputVerifier''. --+-- === Usage in @clashi@ #assert-clashi# --+-- __NB__: When simulating a component that uses 'assert' in @clashi@, usually,+-- the warnings are only logged the first time the component is simulated.+-- Issuing @:reload@ in @clashi@ will discard the cached result of the+-- computation, and warnings will once again be emitted.+-- -- __NB__: This function /can/ be used in synthesizable designs. assert   :: (Eq a, ShowX a, HiddenClock dom , HiddenReset dom )@@ -69,6 +80,22 @@   hideReset (hideClock E.assert) msg actual expected ret {-# INLINE assert #-} +-- | The same as 'assert', but can handle don't care bits in its expected value.+assertBitVector+  :: (KnownNat n, HiddenClock dom , HiddenReset dom )+  => String+  -- ^ Additional message+  -> Signal dom (BitVector n)+  -- ^ Checked value+  -> Signal dom (BitVector n)+  -- ^ Expected value+  -> Signal dom b+  -- ^ Return value+  -> Signal dom b+assertBitVector msg actual expected ret =+  hideReset (hideClock E.assertBitVector) msg actual expected ret+{-# INLINE assertBitVector #-}+ -- | -- -- Example:@@ -80,8 +107,8 @@ -- testInput = 'stimuliGenerator' $('Clash.Sized.Vector.listToVecTH' [(1::Int),3..21]) -- @ ----- >>> sampleN 13 testInput--- [1,3,5,7,9,11,13,15,17,19,21,21,21]+-- >>> sampleN @System 13 testInput+-- [1,1,3,5,7,9,11,13,15,17,19,21,21] stimuliGenerator   :: ( KnownNat l      , HiddenClock dom@@ -93,8 +120,14 @@ stimuliGenerator = hideReset (hideClock E.stimuliGenerator) {-# INLINE stimuliGenerator #-} --- |+-- | Compare a signal (coming from a circuit) to a vector of samples. If a+-- sample from the signal is not equal to the corresponding sample in the+-- vector, print to stderr and continue testing. This function is+-- synthesizable in the sense that HDL simulators will run it. --+-- __NB__: This function uses 'assert'. When simulating this function in+-- @clashi@, read the [note](#assert-clashi).+-- -- Example: -- -- @@@ -105,35 +138,39 @@ -- @ -- -- >>> import qualified Data.List as List--- >>> sampleN 12 (expectedOutput (fromList ([0..10] List.++ [10,10,10])))+-- >>> sampleN @System 12 (expectedOutput (fromList (0:[0..10] List.++ [10,10,10]))) -- <BLANKLINE>--- cycle(system10000): 0, outputVerifier'+-- cycle(<Clock: System>): 0, outputVerifier -- expected value: 70, not equal to actual value: 0 -- [False--- cycle(system10000): 1, outputVerifier'+-- cycle(<Clock: System>): 1, outputVerifier+-- expected value: 70, not equal to actual value: 0+-- ,False+-- cycle(<Clock: System>): 2, outputVerifier -- expected value: 99, not equal to actual value: 1 -- ,False,False,False,False,False--- cycle(system10000): 6, outputVerifier'+-- cycle(<Clock: System>): 7, outputVerifier -- expected value: 7, not equal to actual value: 6 -- ,False--- cycle(system10000): 7, outputVerifier'+-- cycle(<Clock: System>): 8, outputVerifier -- expected value: 8, not equal to actual value: 7 -- ,False--- cycle(system10000): 8, outputVerifier'+-- cycle(<Clock: System>): 9, outputVerifier -- expected value: 9, not equal to actual value: 8 -- ,False--- cycle(system10000): 9, outputVerifier'+-- cycle(<Clock: System>): 10, outputVerifier -- expected value: 10, not equal to actual value: 9--- ,False,True,True]+-- ,False,True] ----- If your working with 'BitVector's containing don't care bits you should use 'outputVerifierBitVector''.+-- If you're working with 'BitVector's containing don't care bits you should use 'outputVerifierBitVector''. outputVerifier'   :: ( KnownNat l      , Eq a      , ShowX a-     , DomainResetKind dom ~ 'Asynchronous      , HiddenClock dom-     , HiddenReset dom  )+     , HiddenReset dom+     , 1 <= l+     )   => Vec l a   -- ^ Samples to compare with   -> Signal dom a@@ -145,13 +182,14 @@   -- | Same as 'outputVerifier'',--- but can handle don't care bits in it's expected values.+-- but can handle don't care bits in its expected values. outputVerifierBitVector'   :: ( KnownNat l      , KnownNat n-     , DomainResetKind dom ~ 'Asynchronous      , HiddenClock dom-     , HiddenReset dom  )+     , HiddenReset dom+     , 1 <= l+     )   => Vec l (BitVector n)   -- ^ Samples to compare with   -> Signal dom (BitVector n)
src/Clash/Promoted/Nat.hs view
@@ -1,24 +1,16 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2016     , Myrtle Software Ltd+                  2022-2025, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -}  {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE GADTs               #-}-{-# LANGUAGE KindSignatures      #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE RankNTypes          #-}-#if __GLASGOW_HASKELL__ >= 806-{-# LANGUAGE NoStarIsType #-}-#endif+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}  {-# LANGUAGE Trustworthy #-} @@ -36,6 +28,8 @@   , withSNat     -- ** Conversion   , snatToInteger, snatToNatural, snatToNum+    -- ** Conversion (ambiguous types)+  , natToInteger, natToNatural, natToNum     -- ** Arithmetic   , addSNat, mulSNat, powSNat, minSNat, maxSNat, succSNat     -- *** Partial@@ -76,15 +70,24 @@   ) where +import Data.Constraint    (Dict(..), (:-)(Sub))+import Data.Constraint.Nat (euclideanNat) import Data.Kind          (Type)+import Data.Type.Equality ((:~:)(..))+import Data.Type.Ord      (OrderingI(..))+import GHC.Show           (appPrec) import GHC.TypeLits       (KnownNat, Nat, type (+), type (-), type (*),-                           type (^), type (<=), natVal)+                           type (^), type (<=),+                           cmpNat, sameNat,+                           natVal) import GHC.TypeLits.Extra (CLog, FLog, Div, Log, Mod, Min, Max) import GHC.Natural        (naturalFromInteger) import Language.Haskell.TH (appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift (..))+import Language.Haskell.TH.Compat import Numeric.Natural    (Natural)-import Unsafe.Coerce      (unsafeCoerce)++import Clash.Annotations.Primitive (hasBlackBox) import Clash.XException   (ShowX (..), showsPrecXWith)  {- $setup@@ -92,7 +95,7 @@ >>> import Clash.Promoted.Nat.Literals (d789) -} --- | Singleton value for a type-level natural number 'n'+-- | Singleton value for a type-level natural number @n@ -- -- * "Clash.Promoted.Nat.Literals" contains a list of predefined 'SNat' literals -- * "Clash.Promoted.Nat.TH" has functions to easily create large ranges of new@@ -103,31 +106,62 @@ instance Lift (SNat n) where   lift s = sigE [| SNat |]                 (appT (conT ''SNat) (litT $ numTyLit (snatToInteger s)))+  liftTyped = liftTypedFromUntyped  -- | Create an @`SNat` n@ from a proxy for /n/ snatProxy :: KnownNat n => proxy n -> SNat n snatProxy _ = SNat  instance Show (SNat n) where-  show p@SNat = 'd' : show (snatToInteger p)+  showsPrec d p@SNat | n <= 1024 = showChar 'd' . shows n+                     | otherwise = showParen (d > appPrec) $+                                     showString "SNat @" . shows n+   where+    n = snatToInteger p  instance ShowX (SNat n) where   showsPrecX = showsPrecXWith showsPrec  {-# INLINE withSNat #-}--- | Supply a function with a singleton natural 'n' according to the context+-- | Supply a function with a singleton natural @n@ according to the context withSNat :: KnownNat n => (SNat n -> a) -> a withSNat f = f SNat +-- | Same as 'snatToInteger' and 'GHC.TypeLits.natVal', but doesn't take term+-- arguments. Example usage:+--+-- >>> natToInteger @5+-- 5+natToInteger :: forall n . KnownNat n => Integer+natToInteger = snatToInteger (SNat @n)+{-# INLINE natToInteger #-}+ -- | Reify the type-level 'Nat' @n@ to it's term-level 'Integer' representation. snatToInteger :: SNat n -> Integer snatToInteger p@SNat = natVal p {-# INLINE snatToInteger #-} +-- | Same as 'snatToNatural' and 'GHC.TypeNats.natVal', but doesn't take term+-- arguments. Example usage:+--+-- >>> natToNatural @5+-- 5+natToNatural :: forall n . KnownNat n => Natural+natToNatural = snatToNatural (SNat @n)+{-# INLINE natToNatural #-}++-- | Reify the type-level 'Nat' @n@ to it's term-level 'Natural'. snatToNatural :: SNat n -> Natural snatToNatural = naturalFromInteger . snatToInteger {-# INLINE snatToNatural #-} +-- | Same as 'snatToNum', but doesn't take term arguments. Example usage:+--+-- >>> natToNum @5 @Int+-- 5+natToNum :: forall n a . (Num a, KnownNat n) => a+natToNum = snatToNum (SNat @n)+{-# INLINE natToNum #-}  -- | Reify the type-level 'Nat' @n@ to it's term-level 'Num'ber. snatToNum :: forall a n . Num a => SNat n -> a@@ -151,11 +185,12 @@ -- -- __NB__: Not synthesizable toUNat :: forall n . SNat n -> UNat n-toUNat p@SNat = fromI @n (snatToInteger p)-  where-    fromI :: forall m . Integer -> UNat m-    fromI 0 = unsafeCoerce @(UNat 0) @(UNat m) UZero-    fromI n = unsafeCoerce @(UNat ((m-1)+1)) @(UNat m) (USucc (fromI @(m-1) (n - 1)))+toUNat p@SNat = case cmpNat (SNat @1) p of+  LTI -> USucc (toUNat @(n - 1) (predSNat p))+  EQI -> USucc UZero+  GTI -> case sameNat p (SNat @0) of+    Just Refl -> UZero+    _ -> error "toUNat: impossible: 1 > n and n /= 0 for (n :: Nat)"  -- | Convert a unary-encoded natural number to its singleton representation --@@ -192,8 +227,10 @@ -- __NB__: Not synthesizable predUNat :: UNat (n+1) -> UNat n predUNat (USucc x) = x+#if __GLASGOW_HASKELL__ < 912 predUNat UZero     =   error "predUNat: impossible: 0 minus 1, -1 is not a natural number"+#endif  -- | Subtract two unary-encoded natural numbers --@@ -201,7 +238,9 @@ subUNat :: UNat (m+n) -> UNat n -> UNat m subUNat x         UZero     = x subUNat (USucc x) (USucc y) = subUNat x y+#if __GLASGOW_HASKELL__ < 912 subUNat UZero     _         = error "subUNat: impossible: 0 + (n + 1) ~ 0"+#endif  -- | Predecessor of a singleton natural number predSNat :: SNat (a+1) -> SNat (a)@@ -234,7 +273,8 @@ -- | Power of two singleton natural numbers powSNat :: SNat a -> SNat b -> SNat (a^b) powSNat SNat SNat = SNat-{-# NOINLINE powSNat #-}+{-# OPAQUE powSNat #-}+{-# ANN powSNat hasBlackBox #-} infixr 8 `powSNat`  -- | Division of two singleton natural numbers@@ -261,7 +301,8 @@              -> SNat x              -> SNat (FLog base x) flogBaseSNat SNat SNat = SNat-{-# NOINLINE flogBaseSNat #-}+{-# OPAQUE flogBaseSNat #-}+{-# ANN flogBaseSNat hasBlackBox #-}  -- | Ceiling of the logarithm of a natural number clogBaseSNat :: (2 <= base, 1 <= x)@@ -269,7 +310,8 @@              -> SNat x              -> SNat (CLog base x) clogBaseSNat SNat SNat = SNat-{-# NOINLINE clogBaseSNat #-}+{-# OPAQUE clogBaseSNat #-}+{-# ANN clogBaseSNat hasBlackBox #-}  -- | Exact integer logarithm of a natural number --@@ -279,7 +321,8 @@             -> SNat x             -> SNat (Log base x) logBaseSNat SNat SNat = SNat-{-# NOINLINE logBaseSNat #-}+{-# OPAQUE logBaseSNat #-}+{-# ANN logBaseSNat hasBlackBox #-}  -- | Power of two of a singleton natural number pow2SNat :: SNat a -> SNat (2^a)@@ -291,12 +334,17 @@   SNatLE :: forall a b . a <= b => SNatLE a b   SNatGT :: forall a b . (b+1) <= a => SNatLE a b +deriving instance Show (SNatLE a b)+ -- | Get an ordering relation between two SNats compareSNat :: forall a b . SNat a -> SNat b -> SNatLE a b-compareSNat a b =-  if snatToInteger a <= snatToInteger b-     then unsafeCoerce (SNatLE @0 @0)-     else unsafeCoerce (SNatGT @1 @0)+compareSNat a@SNat b@SNat = case cmpNat a b of+  LTI -> SNatLE+  EQI -> SNatLE+  GTI -> case cmpNat (succSNat b) a of+    LTI -> SNatGT+    EQI -> SNatGT+    GTI -> error "compareSNat: impossible: a > b and b + 1 > a"  -- | Base-2 encoded natural number --@@ -317,13 +365,13 @@ -- * Append a zero (/0/): -- --      @---      __B0__ :: 'BNat' n -> 'BNat' (2 '*' n)+--      __B0__ :: 'BNat' n -> 'BNat' (2 'GHC.TypeNats.*' n) --      @ -- -- * Append a one (/1/): -- --      @---      __B1__ :: 'BNat' n -> 'BNat' ((2 '*' n) '+' 1)+--      __B1__ :: 'BNat' n -> 'BNat' ((2 'GHC.TypeNats.*' n) 'GHC.TypeNats.+' 1) --      @ data BNat :: Nat -> Type where   BT :: BNat 0@@ -359,14 +407,18 @@ -- | Convert a singleton natural number to its base-2 representation -- -- __NB__: Not synthesizable-toBNat :: SNat n -> BNat n-toBNat s@SNat = toBNat' (snatToInteger s)-  where-    toBNat' :: Integer -> BNat m-    toBNat' 0 = unsafeCoerce BT-    toBNat' n = case n `divMod` 2 of-      (n',1) -> unsafeCoerce (B1 (toBNat' n'))-      (n',_) -> unsafeCoerce (B0 (toBNat' n'))+toBNat :: forall n. SNat n -> BNat n+toBNat s@SNat = case cmpNat (SNat @1) s of+  LTI -> case euclideanNat @2 @n of+    Sub Dict -> case sameNat (SNat @(n `Mod` 2)) (SNat @0) of+      Just Refl -> B0 (toBNat (SNat @(n `Div` 2)))+      Nothing -> case sameNat (SNat @(n `Mod` 2)) (SNat @1) of+        Just Refl -> B1 (toBNat (SNat @(n `Div` 2)))+        Nothing -> error "toBNat: impossible: n mod 2 is either 0 or 1"+  EQI -> B1 BT+  GTI -> case sameNat s (SNat @0) of+    Just Refl -> BT+    _ -> error "toBNat: impossible: 1 > n and n /= 0 for (n :: Nat)"  -- | Convert a base-2 encoded natural number to its singleton representation --@@ -443,7 +495,9 @@ -- -- __NB__: Not synthesizable log2BNat :: BNat (2^n) -> BNat n+#if __GLASGOW_HASKELL__ < 912 log2BNat BT = error "log2BNat: log2(0) not defined"+#endif log2BNat (B1 x) = case stripZeros x of   BT -> BT   _  -> error "log2BNat: impossible: 2^n ~ 2x+1"@@ -479,7 +533,7 @@ -- @ -- f :: Index (n+1) -> Index (n + 1) -> Bool ----- g :: forall n. (1 '<=' n) => Index n -> Index n -> Bool+-- g :: forall n. (1 'GHC.TypeNats.<=' n) => Index n -> Index n -> Bool -- g a b = 'leToPlus' \@1 \@n (f a b) -- @ --@@ -488,8 +542,8 @@ -- @ -- head :: Vec (n + 1) a -> a ----- head' :: forall n a. (1 '<=' n) => Vec n a -> a--- head' = 'leToPlus' @1 @n head+-- head' :: forall n a. (1 'GHC.TypeNats.<=' n) => Vec n a -> a+-- head' = 'leToPlus' \@1 \@n head -- @ leToPlus   :: forall (k :: Nat) (n :: Nat) r
src/Clash/Promoted/Nat/Literals.hs view
@@ -3,7 +3,7 @@ License    :  BSD2 (see the file LICENSE) Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -Predefined 'SNat' singleton literals in the range [0 .. 1024]+Predefined 'Clash.Promoted.Nat.SNat' singleton literals in the range [0 .. 1024]  Defines: @@ -15,12 +15,12 @@ d1024 = SNat :: SNat 1024 @ -You can generate more 'SNat' literals using 'decLiteralsD' from "Clash.Promoted.Nat.TH"+You can generate more 'Clash.Promoted.Nat.SNat' literals using 'decLiteralsD'+from "Clash.Promoted.Nat.TH" -} -{-# LANGUAGE CPP             #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DataKinds       #-}  {-# LANGUAGE Trustworthy #-}
src/Clash/Promoted/Nat/TH.hs view
@@ -23,6 +23,8 @@  {- $setup >>> :set -XDataKinds+>>> :m -Prelude+>>> import Clash.Prelude >>> let d1111 = SNat :: SNat 1111 >>> let d1200 = SNat :: SNat 1200 >>> let d1201 = SNat :: SNat 1201
src/Clash/Promoted/Nat/Unsafe.hs view
@@ -1,9 +1,11 @@ {-| Copyright  :  (C) 2015-2016, University of Twente+                  2022     , QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} +{-# LANGUAGE CPP #-} {-# LANGUAGE Unsafe #-}  module Clash.Promoted.Nat.Unsafe@@ -13,9 +15,11 @@ import Data.Reflection    (reifyNat) import Unsafe.Coerce      (unsafeCoerce) +import Clash.Annotations.Primitive (hasBlackBox) import Clash.Promoted.Nat (SNat, snatProxy)  -- | I hope you know what you're doing unsafeSNat :: Integer -> SNat k unsafeSNat i = reifyNat i $ (\p -> unsafeCoerce (snatProxy p))-{-# NOINLINE unsafeSNat #-}+{-# OPAQUE unsafeSNat #-}+{-# ANN unsafeSNat hasBlackBox #-}
src/Clash/Promoted/Symbol.hs view
@@ -1,15 +1,16 @@ {-| Copyright  :  (C) 2013-2016, University of Twente+                  2022     , QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE Safe #-}+-- Annotations are not allowed in safe Haskell+-- {-# LANGUAGE Safe #-}  {-# OPTIONS_HADDOCK show-extensions #-} @@ -18,21 +19,28 @@ where  import Language.Haskell.TH.Syntax+import GHC.Show     (appPrec) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Clash.Annotations.Primitive (hasBlackBox)+ -- | Singleton value for a type-level string @s@ data SSymbol (s :: Symbol) where   SSymbol :: KnownSymbol s => SSymbol s +{-# ANN SSymbol hasBlackBox #-}+ instance KnownSymbol s => Lift (SSymbol (s :: Symbol)) where --  lift :: t -> Q Exp   lift t = pure (AppTypeE (ConE 'SSymbol) tt)     where       tt = LitT (StrTyLit (ssymbolToString t)) +  liftTyped = unsafeCodeCoerce . lift  instance Show (SSymbol s) where-  show s@SSymbol = symbolVal s+  showsPrec d s@SSymbol = showParen (d > appPrec) $+    showString "SSymbol @" . shows (ssymbolToString s)  {-# INLINE ssymbolProxy #-} -- | Create a singleton symbol literal @'SSymbol' s@ from a proxy for
src/Clash/Signal.hs view
@@ -1,1876 +1,1753 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2016-2019, Myrtle Software Ltd,-                  2017     , Google Inc.-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--Clash has synchronous 'Signal's in the form of:--@-'Signal' (dom :: 'Domain') a-@--Where /a/ is the type of the value of the 'Signal', for example /Int/ or /Bool/,-and /dom/ is the /clock-/ (and /reset-/) domain to which the memory elements-manipulating these 'Signal's belong.--The type-parameter, /dom/, is of the kind 'Domain' - a simple string. That-string refers to a single /synthesis domain/. A synthesis domain describes the-behavior of certain aspects of memory elements in it. More specifically, a-domain looks like:--@-'DomainConfiguration'-  { _name :: 'Domain'-  -- ^ Domain name-  , _period :: 'Nat'-  -- ^ Clock period in /ps/-  , _edge :: 'ActiveEdge'-  -- ^ Active edge of the clock-  , _reset :: 'ResetKind'-  -- ^ Whether resets are synchronous (edge-sensitive) or asynchronous (level-sensitive)-  , _init :: 'InitBehavior'-  -- ^ Whether the initial (or "power up") value of memory elements is-  -- unknown/undefined, or configurable to a specific value-  , _polarity :: ResetPolarity-  -- ^ Whether resets are active high or active low-  }-@--Check the documentation of each of the types to see the various options Clash-provides. In order to specify a domain, an instance of 'KnownDomain' should be-made. Clash provides an implementation 'System' with some common options-chosen:--@-instance KnownDomain "System" where-  type KnownConf "System" = 'DomainConfiguration "System" 10000 'Rising 'Asynchronous 'Defined 'ActiveHigh-  knownDomain = SDomainConfiguration SSymbol SNat SRising SAsynchronous SDefined SActiveHigh-@--In words, "System" is a synthesis domain with a clock running with a period-of 10000 /ps/. Memory elements respond to the rising edge of the clock,-asynchronously to changes in their resets, and have defined power up values-if applicable.--In order to create a new domain, you don't have to instantiate it explicitly.-Instead, you can have 'createDomain' create a domain for you. You can also use-the same function to subclass existing domains.--* __NB__: \"Bad things\"™  happen when you actually use a clock period of @0@,-so do __not__ do that!-* __NB__: You should be judicious using a clock with period of @1@ as you can-never create a clock that goes any faster!-* __NB__: Whether 'System' has good defaults depends on your target platform.-Check out 'IntelSystem' and 'XilinxSystem' too!--}--{-# LANGUAGE CPP                   #-}-{-# LANGUAGE ConstraintKinds       #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE ExplicitNamespaces    #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE MagicHash             #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeOperators         #-}-#if __GLASGOW_HASKELL__ < 806-{-# LANGUAGE TypeInType #-}-#endif--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module Clash.Signal-  ( -- * Synchronous signals-    Signal-  , BiSignalIn-  , BiSignalOut-  , BiSignalDefault(..)-    -- * Domain-  , Domain-  , KnownDomain(..)-  , KnownConfiguration-  , ActiveEdge(..)-  , SActiveEdge(..)-  , InitBehavior(..)-  , SInitBehavior(..)-  , ResetKind(..)-  , SResetKind(..)-  , ResetPolarity(..)-  , SResetPolarity(..)-  , DomainConfiguration(..)-  , SDomainConfiguration(..)-  -- ** Configuration type families-  , DomainPeriod-  , DomainActiveEdge-  , DomainResetKind-  , DomainInitBehavior-  , DomainResetPolarity-    -- ** Default domains-  , System-  , XilinxSystem-  , IntelSystem-  , vSystem-  , vIntelSystem-  , vXilinxSystem-    -- ** Domain utilities-  , VDomainConfiguration(..)-  , vDomain-  , createDomain-  , knownVDomain-  , clockPeriod-  , activeEdge-  , resetKind-  , initBehavior-  , resetPolarity-    -- * Clock-  , Clock-  , periodToHz-  , hzToPeriod-#ifdef CLASH_MULTIPLE_HIDDEN-    -- ** Synchronization primitive-  , unsafeSynchronizer-#endif-    -- * Reset-  , Reset(..)-  , unsafeToReset-  , unsafeFromReset-  , unsafeToHighPolarity-  , unsafeToLowPolarity-  , unsafeFromHighPolarity-  , unsafeFromLowPolarity-#ifdef CLASH_MULTIPLE_HIDDEN-  , convertReset-#endif-  , E.resetSynchronizer-  , holdReset-    -- ** Enabling-  , Enable(..)-  , toEnable-  , fromEnable-  , S.enableGen-    -- * Hidden clocks and resets-    -- $hiddenclockandreset--    -- ** Hidden clock-  , HiddenClock-  , hideClock-  , exposeClock-  , exposeSpecificClock-  , withClock-  , withSpecificClock-  , hasClock-    -- ** Hidden reset-  , HiddenReset-  , hideReset-  , exposeReset-  , withReset-#ifdef CLASH_MULTIPLE_HIDDEN-  , exposeSpecificReset-  , withSpecificReset-#endif-  , hasReset-    -- ** Hidden enable-  , HiddenEnable-  , hideEnable-  , exposeEnable-  , withEnable-#ifdef CLASH_MULTIPLE_HIDDEN-  , exposeSpecificEnable-  , withSpecificEnable-#endif-  , hasEnable-    -- ** Hidden clock, reset, and enable-  , HiddenClockResetEnable-  , hideClockResetEnable-  , exposeClockResetEnable-  , withClockResetEnable-#ifdef CLASH_MULTIPLE_HIDDEN-  , exposeSpecificClockResetEnable-  , withSpecificClockResetEnable-#endif-  , SystemClockResetEnable-    -- * Basic circuit functions-  , dflipflop-  , delay-  , delayMaybe-  , delayEn-  , register-  , regMaybe-  , regEn-  , mux-    -- * Simulation and testbench functions-  , clockGen-  , resetGen-  , resetGenN-  , systemClockGen-  , systemResetGen-    -- * Boolean connectives-  , (.&&.), (.||.)-    -- * Product/Signal isomorphism-  , Bundle(..)-    -- * Simulation functions (not synthesizable)-  , simulate-  , simulateB-  , simulateN-  , simulateWithReset-  , simulateWithResetN-    -- ** lazy versions-  , simulate_lazy-  , simulateB_lazy-    -- * List \<-\> Signal conversion (not synthesizable)-  , sample-  , sampleN-  , sampleWithReset-  , sampleWithResetN-  , fromList-  , fromListWithReset-    -- ** lazy versions-  , sample_lazy-  , sampleN_lazy-  , fromList_lazy-    -- * QuickCheck combinators-  , testFor-    -- * Type classes-    -- ** 'Eq'-like-  , (.==.), (./=.)-    -- ** 'Ord'-like-  , (.<.), (.<=.), (.>=.), (.>.)-    -- * Bisignal functions-  , veryUnsafeToBiSignalIn-  , readFromBiSignal-  , writeToBiSignal-  , mergeBiSignalOuts-  )-where--import           GHC.TypeLits-  (KnownNat, KnownSymbol, AppendSymbol, Symbol, type (<=))-import           Data.Bits             (Bits) -- Haddock only-import           Data.Proxy            (Proxy(..))-import           Prelude-import           Test.QuickCheck       (Property, property)--#ifdef CLASH_MULTIPLE_HIDDEN-import           Clash.Class.HasDomain (WithSingleDomain, WithSpecificDomain)-#else-import           Clash.Class.HasDomain (WithSpecificDomain)-#endif-import qualified Clash.Explicit.Signal as E-import           Clash.Explicit.Signal-  (System, resetSynchronizer, systemClockGen, systemResetGen)-import qualified Clash.Explicit.Signal as S-import           Clash.Hidden-import           Clash.Promoted.Nat    (SNat (..), snatToNum)-import           Clash.Promoted.Symbol (SSymbol (..))-import           Clash.Signal.Bundle   (Bundle (..))-import           Clash.Signal.BiSignal --(BisignalIn, BisignalOut, )-import           Clash.Signal.Internal hiding-  (sample, sample_lazy, sampleN, sampleN_lazy, simulate, simulate_lazy, testFor)-import           Clash.Signal.Internal.Ambiguous-  (knownVDomain, clockPeriod, activeEdge, resetKind, initBehavior, resetPolarity)-import qualified Clash.Signal.Internal as S-import           Clash.XException      (NFDataX)--{- $setup->>> :set -XFlexibleContexts -XTypeApplications->>> import Clash.Promoted.Nat (SNat(..))->>> import Clash.XException (printX)->>> import Control.Applicative (liftA2)->>> let oscillate = register False (not <$> oscillate)->>> let count = regEn 0 oscillate (count + 1)->>> :{-sometimes1 = s where-  s = register Nothing (switch <$> s)-  switch Nothing = Just 1-  switch _       = Nothing-:}-->>> :{-countSometimes = s where-  s     = regMaybe 0 (plusM (pure <$> s) sometimes1)-  plusM = liftA2 (liftA2 (+))-:}---}---- * Hidden clock and reset arguments--{- $hiddenclockandreset #hiddenclockandreset#-Clocks and resets are by default implicitly routed to their components. You can-see from the type of a component whether it has hidden clock or reset-arguments:--It has a hidden clock when it has a:--@-f :: 'HiddenClock' dom => ...-@--Constraint.--Or it has a hidden reset when it has a:--@-g :: 'HiddenReset' dom polarity => ...-@--Constraint.--Or it has both a hidden clock argument and a hidden reset argument when it-has a:--@-h :: 'HiddenClockReset' dom  => ..-@--Constraint.--Given a component with an explicit clock and reset arguments, you can turn them-into hidden arguments using 'hideClock' and 'hideReset'. So given a:--@-f :: Clock dom -> Reset dom -> Signal dom a -> ...-@--You hide the clock and reset arguments by:--@--- g :: 'HiddenClockReset' dom  => Signal dom a -> ...-g = 'hideClockReset' f-@--Or, alternatively, by:--@--- h :: HiddenClockResetEnable dom  => Signal dom a -> ...-h = f 'hasClock' 'hasReset'-@--=== Assigning explicit clock and reset arguments to hidden clocks and resets--Given a component:--@-f :: HiddenClockResetEnable dom-  => Signal dom Int-  -> Signal dom Int-@--which has hidden clock and routed reset arguments, we expose those hidden-arguments so that we can explicitly apply them:--@--- g :: Clock dom -> Reset dom -> Signal dom Int -> Signal dom Int-g = 'exposeClockResetEnable' f-@--or, alternatively, by:--@--- h :: Clock dom -> Reset dom -> Signal dom Int -> Signal dom Int-h clk rst = withClock clk rst f-@--Similarly, there are 'exposeClock' and 'exposeReset' to connect just expose-the hidden clock or the hidden reset argument.--You will need to explicitly apply clocks and resets when you want to use-components such as PPLs and 'resetSynchronizer':--@-topEntity-  :: Clock System-  -> Reset System-  -> Enable System-  -> Signal System Int-  -> Signal System Int-topEntity clk rst =-  let (pllOut,pllStable) = 'Clash.Intel.ClockGen.altpll' (SSymbol \@\"altpll50\") clk rst-      rstSync            = 'resetSynchronizer' pllOut ('unsafeToAsyncReset' pllStable)-  in  'exposeClockResetEnable' f pllOut rstSync-@--or, using the alternative method:--@-topEntity2-  :: Clock System-  -> Reset System-  -> Signal System Int-  -> Signal System Int-topEntity2 clk rst =-  let (pllOut,pllStable) = 'Clash.Intel.ClockGen.altpll' (SSymbol \@\"altpll50\") clk rst-      rstSync            = 'resetSynchronizer' pllOut ('unsafeToAsyncReset' pllStable)-  in  'withClockReset' pllOut rstSync f-@---}--#ifdef CLASH_MULTIPLE_HIDDEN-type HiddenClockName dom = AppendSymbol dom "_clk"-type HiddenResetName dom = AppendSymbol dom "_rst"-type HiddenEnableName dom = AppendSymbol dom "_en"-#else-type HiddenClockName (dom :: Domain) = "clock"-type HiddenResetName (dom :: Domain) = "reset"-type HiddenEnableName (dom :: Domain) = "enable"-#endif---- | A /constraint/ that indicates the component has a hidden 'Clock'------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>-type HiddenClock dom =-  ( Hidden (HiddenClockName dom) (Clock dom)-  , KnownDomain dom )---- | A /constraint/ that indicates the component needs a 'Reset'------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>-type HiddenReset dom =-  ( Hidden (HiddenResetName dom) (Reset dom)-  , KnownDomain dom )---- | A /constraint/ that indicates the component needs a 'Enable'------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>-type HiddenEnable dom =-  ( Hidden (HiddenEnableName dom) (Enable dom)-  , KnownDomain dom )---- | A /constraint/ that indicates the component needs a 'Clock', a 'Reset',--- and an 'Enable' belonging to the same dom.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>-type HiddenClockResetEnable dom  =-  ( HiddenClock dom-  , HiddenReset dom-  , HiddenEnable dom-  )---- | A /constraint/ that indicates the component needs a 'Clock', a 'Reset',--- and an 'Enable' belonging to the 'System' dom.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>-type SystemClockResetEnable =-  ( Hidden (HiddenClockName System) (Clock System)-  , Hidden (HiddenResetName System) (Reset System)-  , Hidden (HiddenEnableName System) (Enable System)-  )---- | Expose a hidden 'Clock' argument of a component, so it can be applied--- explicitly.----#ifdef CLASH_MULTIPLE_HIDDEN--- This function can only be used on components with a single--- domain. For example, this function will refuse when:------ @--- r ~ HiddenClock dom => Signal dom1 a -> Signal dom2 a--- @------ But will work when:------ @--- r ~ HiddenClock dom => Signal dom a -> Signal dom a--- @------ If you want to expose a clock of a component working on multiple domains--- (such as the first example), use 'exposeSpecificClock'.----#endif--- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- Usage with a /polymorphic/ domain:------ >>> reg = register 5 (reg + 1)--- >>> sig = exposeClock reg clockGen--- >>> sampleN @System 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Force exposeClock to work on System (hence 'sampleN' not needing an explicit--- domain later):------ >>> reg = register 5 (reg + 1)--- >>> sig = exposeClock @System reg clockGen--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]----exposeClock-  :: forall dom  r-   .-#ifdef CLASH_MULTIPLE_HIDDEN-     WithSingleDomain dom r =>-#endif-     (HiddenClock dom => r)-  -- ^ The component with a hidden clock-  -> (KnownDomain dom => Clock dom -> r)-  -- ^ The component with its clock argument exposed-exposeClock = \f clk -> exposeSpecificClock (const f) clk (Proxy @dom)-{-# INLINE exposeClock #-}---- | Expose a hidden 'Clock' argument of a component, so it can be applied--- explicitly. This function can be used on components with multiple domains.--- As opposed to 'exposeClock', callers should explicitly state what the clock--- domain is. See the examples for more information.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- 'exposeSpecificClock' can only be used when it can find the specified domain--- in /r/:------ >>> reg = register @System 5 (reg + 1)--- >>> sig = exposeSpecificClock @System reg clockGen--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Type variables work too, if they are in scope. For example:------ @--- reg = 'register' @@dom 5 (reg + 1)--- sig = exposeSpecificClock @@dom reg 'clockGen'--- @----exposeSpecificClock-   :: forall dom  r-   . WithSpecificDomain dom r-  => (HiddenClock dom => r)-  -- ^ The component with a hidden clock-  -> (KnownDomain dom => Clock dom -> r)-  -- ^ The component with its clock argument exposed-exposeSpecificClock = \f clk -> expose @(HiddenClockName dom) f clk-{-# INLINE exposeSpecificClock #-}---- | Hide the 'Clock' argument of a component, so it can be routed implicitly.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>-hideClock-  :: forall dom r-   . HiddenClock dom-  => (Clock dom -> r)-  -- ^ Function whose clock argument you want to hide-  -> r-hideClock = \f -> f (fromLabel @(HiddenClockName dom))-{-# INLINE hideClock #-}---- | Connect an explicit 'Clock' to a function with a hidden 'Clock'.----#ifdef CLASH_MULTIPLE_HIDDEN--- This function can only be used on components with a single domain. For--- example, this function will refuse when:------ @--- r ~ HiddenClock dom => Signal dom1 a -> Signal dom2 a--- @------ But will work when:------ @--- r ~ HiddenClock dom => Signal dom a -> Signal dom a--- @------ If you want to connect a clock to a component working on multiple domains--- (such as the first example), use 'withSpecificClock'.----#endif--- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- Usage with a _polymorphic_ domain:------ >>> reg = register 5 (reg + 1)--- >>> sig = withClock clockGen reg--- >>> sampleN @System 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Force withClock to work on signal (hence 'sampleN' not needing an explicit--- domain later):------ >>> reg = register 5 (reg + 1)--- >>> sig = withClock @System clockGen reg--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]----withClock-  :: forall dom r-   .-#ifdef CLASH_MULTIPLE_HIDDEN-     WithSingleDomain dom r =>-#endif-     KnownDomain dom-  => Clock dom-  -- ^ The 'Clock' we want to connect-  -> (HiddenClock dom => r)-  -- ^ The function with a hidden 'Clock' argument-  -> r-withClock clk f = withSpecificClock clk (const f) (Proxy @dom)-{-# INLINE withClock #-}---- | Connect an explicit 'Clock' to a function with a hidden 'Clock'. This--- function can be used on components with multiple domains. As opposed to--- 'exposeClock', callers should explicitly state what the clock domain is. See--- the examples for more information.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- 'withSpecificClock' can only be used when it can find the specified domain--- in /r/:------ >>> reg = register @System 5 (reg + 1)--- >>> sig = withClock @System clockGen reg--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Type variables work too, if they are in scope. For example:------ @--- reg = 'register' @@dom 5 (reg + 1)--- sig = withClock @@dom 'clockGen' reg--- @----withSpecificClock-  :: forall dom r-   . (KnownDomain dom, WithSpecificDomain dom r)-  => Clock dom-  -- ^ The 'Clock' we want to connect-  -> (HiddenClock dom => r)-  -- ^ The function with a hidden 'Clock' argument-  -> r-withSpecificClock = \clk f -> expose @(HiddenClockName dom) f clk-{-# INLINE withSpecificClock #-}---- | Connect a hidden 'Clock' to an argument where a normal 'Clock' argument--- was expected.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>-hasClock-  :: forall dom-   . HiddenClock dom-  => Clock dom-hasClock = fromLabel @(HiddenClockName dom)-{-# INLINE hasClock #-}---- | Expose a hidden 'Reset' argument of a component, so it can be applied--- explicitly.----#ifdef CLASH_MULTIPLE_HIDDEN--- This function can only be used on components with a single domain. For--- example, this function will refuse when:------ @--- r ~ HiddenReset dom => Signal dom1 a -> Signal dom2 a--- @------ But will work when:------ @--- r ~ HiddenReset dom => Signal dom a -> Signal dom a--- @------ If you want to expose a reset of a component working on multiple domains--- (such as the first example), use 'exposeSpecificReset'.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>----#endif--- === __Example__--- Usage with a /polymorphic/ domain:------ >>> reg = register 5 (reg + 1)--- >>> sig = exposeReset reg resetGen--- >>> sampleN @System 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Force exposeReset to work on System (hence 'sampleN' not needing an explicit--- domain later):------ >>> reg = register 5 (reg + 1)--- >>> sig = exposeReset @System reg resetGen--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]----exposeReset-  :: forall dom r-   .-#ifdef CLASH_MULTIPLE_HIDDEN-     WithSingleDomain dom r =>-#endif-     (HiddenReset dom => r)-  -- ^ The component with a hidden reset-  -> (KnownDomain dom => Reset dom -> r)-  -- ^ The component with its reset argument exposed-exposeReset = \f rst -> exposeSpecificReset (const f) rst (Proxy @dom)-{-# INLINE exposeReset #-}---- | Expose a hidden 'Reset' argument of a component, so it can be applied--- explicitly. This function can be used on components with multiple domains.--- As opposed to 'exposeReset', callers should explicitly state what the reset--- domain is. See the examples for more information.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- 'exposeSpecificReset' can only be used when it can find the specified domain--- in /r/:------ >>> reg = register @System 5 (reg + 1)--- >>> sig = exposeSpecificReset @System reg resetGen--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Type variables work too, if they are in scope. For example:------ @--- reg = 'register' @@dom 5 (reg + 1)--- sig = exposeSpecificReset @@dom reg 'resetGen'--- @----exposeSpecificReset-  :: forall dom r-   . WithSpecificDomain dom r-  => (HiddenReset dom => r)-  -- ^ The component with a hidden reset-  -> (KnownDomain dom => Reset dom -> r)-  -- ^ The component with its reset argument exposed-exposeSpecificReset = \f rst -> expose @(HiddenResetName dom) f rst-{-# INLINE exposeSpecificReset #-}---- | Hide the 'Reset' argument of a component, so it can be routed implicitly.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>-hideReset-  :: forall dom r-   . HiddenReset dom-  => (Reset dom -> r)-  -- ^ Component whose reset argument you want to hide-  -> r-hideReset = \f -> f (fromLabel @(HiddenResetName dom))-{-# INLINE hideReset #-}---- | Connect an explicit 'Reset' to a function with a hidden 'Reset'.----#ifdef CLASH_MULTIPLE_HIDDEN--- This function can only be used on components with a single domain. For--- example, this function will refuse when:------ @--- r ~ HiddenReset dom => Signal dom1 a -> Signal dom2 a--- @------ But will work when:------ @--- r ~ HiddenReset dom => Signal dom a -> Signal dom a--- @------ If you want to connect a reset to a component working on multiple domains--- (such as the first example), use 'withSpecificReset'.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>----#endif--- === __Example__--- Usage with a _polymorphic_ domain:------ >>> reg = register 5 (reg + 1)--- >>> sig = withReset resetGen reg--- >>> sampleN @System 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Force withReset to work on signal (hence 'sampleN' not needing an explicit--- domain later):------ >>> reg = register 5 (reg + 1)--- >>> sig = withReset @System resetGen reg--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]----withReset-  :: forall dom r-   .-#ifdef CLASH_MULTIPLE_HIDDEN-     WithSingleDomain dom r =>-#endif-     KnownDomain dom-  => Reset dom-  -- ^ The 'Reset' we want to connect-  -> (HiddenReset dom => r)-  -- ^ The function with a hidden 'Reset' argument-  -> r-withReset = \rst f -> expose @(HiddenResetName dom) f rst-{-# INLINE withReset #-}---- | Connect an explicit 'Reset' to a function with a hidden 'Reset'. This--- function can be used on components with multiple domains. As opposed to--- 'exposeReset', callers should explicitly state what the reset domain is. See--- the examples for more information.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- 'withSpecificReset' can only be used when it can find the specified domain--- in /r/:------ >>> reg = register @System 5 (reg + 1)--- >>> sig = withReset @System resetGen reg--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Type variables work too, if they are in scope. For example:------ @--- reg = 'register' @@dom 5 (reg + 1)--- sig = withReset @@dom 'resetGen' reg--- @----withSpecificReset-  :: forall dom r-   . (KnownDomain dom, WithSpecificDomain dom r)-  => Reset dom-  -- ^ The 'Reset' we want to connect-  -> (HiddenReset dom => r)-  -- ^ The function with a hidden 'Reset' argument-  -> r-withSpecificReset = \rst f -> expose @(HiddenResetName dom) f rst-{-# INLINE withSpecificReset #-}---- | Connect a hidden 'Reset' to an argument where a normal 'Reset' argument--- was expected.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>-hasReset-  :: forall dom-   . HiddenReset dom-  => Reset dom-hasReset = fromLabel @(HiddenResetName dom)-{-# INLINE hasReset #-}---- | Expose a hidden 'Enable' argument of a component, so it can be applied--- explicitly.----#ifdef CLASH_MULTIPLE_HIDDEN--- This function can only be used on components with a single domain. For--- example, this function will refuse when:------ @--- r ~ HiddenEnable dom => Signal dom1 a -> Signal dom2 a--- @------ But will work when:------ @--- r ~ HiddenEnable dom => Signal dom a -> Signal dom a--- @------ If you want to expose a enable of a component working on multiple domains--- (such as the first example), use 'exposeSpecificEnable'.----#endif--- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- Usage with a /polymorphic/ domain:------ >>> reg = register 5 (reg + 1)--- >>> sig = exposeEnable reg enableGen--- >>> sampleN @System 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Force exposeEnable to work on System (hence 'sampleN' not needing an explicit--- domain later):------ >>> reg = register 5 (reg + 1)--- >>> sig = exposeEnable @System reg enableGen--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]----exposeEnable-  :: forall dom  r .-#ifdef CLASH_MULTIPLE_HIDDEN-     WithSingleDomain dom r =>-#endif-     (HiddenEnable dom => r)-  -- ^ The component with a hidden reset-  -> (KnownDomain dom => Enable dom -> r)-  -- ^ The component with its reset argument exposed-exposeEnable = \f gen -> exposeSpecificEnable (const f) gen (Proxy @dom)-{-# INLINE exposeEnable #-}---- | Expose a hidden 'Enable' argument of a component, so it can be applied--- explicitly. This function can be used on components with multiple domains.--- As opposed to 'exposeEnable', callers should explicitly state what the enable--- domain is. See the examples for more information.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- 'exposeSpecificEnable' can only be used when it can find the specified domain--- in /r/:------ >>> reg = register @System 5 (reg + 1)--- >>> sig = exposeSpecificEnable @System reg enableGen--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Type variables work too, if they are in scope. For example:------ @--- reg = 'register' @@dom 5 (reg + 1)--- sig = exposeSpecificEnable @@dom reg 'enableGen'--- @----exposeSpecificEnable-  :: forall dom r-   . WithSpecificDomain dom r-  => (HiddenEnable dom => r)-  -- ^ The component with a hidden reset-  -> (KnownDomain dom => Enable dom -> r)-  -- ^ The component with its reset argument exposed-exposeSpecificEnable = \f gen -> expose @(HiddenEnableName dom) f gen-{-# INLINE exposeSpecificEnable #-}---- | Hide the 'Enable' argument of a component, so it can be routed implicitly.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>-hideEnable-  :: forall dom r-   . HiddenEnable dom-  => (Enable dom -> r)-  -- ^ Component whose reset argument you want to hide-  -> r-hideEnable = \f -> f (fromLabel @(HiddenEnableName dom))-{-# INLINE hideEnable #-}---- | Connect an explicit 'Enable' to a function with a hidden 'Enable'.----#ifdef CLASH_MULTIPLE_HIDDEN--- This function can only be used on components with a single domain. For--- example, this function will refuse when:------ @--- r ~ HiddenEnable dom => Signal dom1 a -> Signal dom2 a--- @------ But will work when:------ @--- r ~ HiddenEnable dom => Signal dom a -> Signal dom a--- @------ If you want to connect a enable to a component working on multiple domains--- (such as the first example), use 'withSpecificEnable'.----#endif--- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- Usage with a _polymorphic_ domain:------ >>> reg = register 5 (reg + 1)--- >>> sig = withEnable enableGen reg--- >>> sampleN @System 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Force withEnable to work on signal (hence 'sampleN' not needing an explicit--- domain later):------ >>> reg = register 5 (reg + 1)--- >>> sig = withEnable @System enableGen reg--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]----withEnable-  :: forall dom r-   . KnownDomain dom-#ifdef CLASH_MULTIPLE_HIDDEN-  => WithSingleDomain dom r-#endif-  => Enable dom-  -- ^ The 'Enable' we want to connect-  -> (HiddenEnable dom => r)-  -- ^ The function with a hidden 'Enable' argument-  -> r-withEnable = \gen f -> expose @(HiddenEnableName dom) f gen-{-# INLINE withEnable #-}---- | Connect an explicit 'Reset' to a function with a hidden 'Enable'. This--- function can be used on components with multiple domains. As opposed to--- 'exposeEnable', callers should explicitly state what the enable domain is. See--- the examples for more information.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- 'withSpecificEnable' can only be used when it can find the specified domain--- in /r/:------ >>> reg = register @System 5 (reg + 1)--- >>> sig = withEnable @System enableGen reg--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Type variables work too, if they are in scope. For example:------ @--- reg = 'register' @@dom 5 (reg + 1)--- sig = withEnable @@dom 'enableGen' reg--- @----withSpecificEnable-  :: forall dom r-   . (KnownDomain dom, WithSpecificDomain dom r)-  => Enable dom-  -- ^ The 'Enable' we want to connect-  -> (HiddenEnable dom => r)-  -- ^ The function with a hidden 'Enable' argument-  -> r-withSpecificEnable = \gen f -> expose @(HiddenEnableName dom) f gen-{-# INLINE withSpecificEnable #-}---- | Connect a hidden 'Enable' to an argument where a normal 'Enable' argument--- was expected.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>-hasEnable-  :: forall dom-   . HiddenEnable dom-  => Enable dom-hasEnable = fromLabel @(HiddenEnableName dom)-{-# INLINE hasEnable #-}----- | Expose a hidden 'Clock', 'Reset', and 'Enable' argument of a component, so--- it can be applied explicitly.----#ifdef CLASH_MULTIPLE_HIDDEN--- This function can only be used on components with a single domain. For--- example, this function will refuse when:------ @--- r ~ HiddenClockResetEnable dom => Signal dom1 a -> Signal dom2 a--- @------ But will work when:------ @--- r ~ HiddenClockResetEnable dom => Signal dom a -> Signal dom a--- @------ If you want to expose a clock, reset, and enable of a component working on--- multiple domains (such as the first example), use 'exposeSpecificClockResetEnable'.----#endif--- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- Usage with a /polymorphic/ domain:------ >>> reg = register 5 (reg + 1)--- >>> sig = exposeClockResetEnable reg clockGen resetGen enableGen--- >>> sampleN @System 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Force exposeClockResetEnable to work on System (hence 'sampleN' not needing an--- explicit domain later):------ >>> reg = register 5 (reg + 1)--- >>> sig = exposeClockResetEnable @System reg clockGen resetGen enableGen--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Usage in a testbench context:------ @--- topEntity :: Vec 2 (Vec 3 (Unsigned 8)) -> Vec 6 (Unsigned 8)--- topEntity = concat------ testBench :: Signal System Bool--- testBench = done---   where---     testInput      = pure ((1 :> 2 :> 3 :> Nil) :> (4 :> 5 :> 6 :> Nil) :> Nil)---     expectedOutput = outputVerifier' ((1:>2:>3:>4:>5:>6:>Nil):>Nil)---     done           = exposeClockResetEnable (expectedOutput (topEntity <$> testInput)) clk rst---     clk            = tbSystemClockGen (not <\$\> done)---     rst            = systemResetGen--- @-exposeClockResetEnable-  :: forall dom r .-#ifdef CLASH_MULTIPLE_HIDDEN-     WithSingleDomain dom r =>-#endif-     (HiddenClockResetEnable dom => r)-  -- ^ The component with hidden clock, reset, and enable arguments-  -> (KnownDomain dom => Clock dom -> Reset dom -> Enable dom -> r)-  -- ^ The component with its clock, reset, and enable arguments exposed-exposeClockResetEnable =-  \f clk rst en ->-    exposeSpecificClock (exposeSpecificReset (exposeEnable f)) clk rst en-{-# INLINE exposeClockResetEnable #-}--#ifdef CLASH_MULTIPLE_HIDDEN--- | Expose a hidden 'Clock', 'Reset', and 'Enable' argument of a component, so--- it can be applied explicitly. This function can be used on components with--- multiple domains. As opposed to 'exposeClockResetEnable', callers should--- explicitly state what the enable domain is. See the examples for more--- information.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- 'exposeSpecificClockResetEnable' can only be used when it can find the--- specified domain in /r/:------ >>> reg = register @System 5 (reg + 1)--- >>> sig = exposeSpecificClockResetEnable @System reg clockGen resetGen enableGen--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Type variables work too, if they are in scope. For example:------ @--- reg = 'register' @@dom 5 (reg + 1)--- sig = exposeSpecificClockResetEnable @@dom reg 'clockGen' 'resetGen' 'enableGen'--- @----exposeSpecificClockResetEnable-  :: forall dom r-   . WithSpecificDomain dom r-  => (HiddenClockResetEnable dom => r)-  -- ^ The component with hidden clock, reset, and enable arguments-  -> (KnownDomain dom => Clock dom -> Reset dom -> Enable dom -> r)-  -- ^ The component with its clock, reset, and enable arguments exposed-exposeSpecificClockResetEnable =-  \f clk rst en ->-    exposeSpecificClock (exposeSpecificReset (exposeSpecificEnable f)) clk rst en-{-# INLINE exposeSpecificClockResetEnable #-}-#endif---- -- | Hide the 'Clock' and 'Reset' arguments of a component, so they can be--- -- routed implicitly------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>-hideClockResetEnable-  :: forall dom r-   . HiddenClockResetEnable dom-  => (KnownDomain dom => Clock dom -> Reset dom -> Enable dom -> r)-  -- ^ Component whose clock, reset, and enable argument you want to hide-  -> r-hideClockResetEnable =-  \f ->-    f-      (fromLabel @(HiddenClockName dom))-      (fromLabel @(HiddenResetName dom))-      (fromLabel @(HiddenEnableName dom))-{-# INLINE hideClockResetEnable #-}---- | Connect an explicit 'Clock', 'Reset', and 'Enable' to a function with a--- hidden 'Clock', 'Reset', and 'Enable'.----#ifdef CLASH_MULTIPLE_HIDDEN--- This function can only be used on components with a single domain. For--- example, this function will refuse when:------ @--- r ~ HiddenClockResetEnable dom => Signal dom1 a -> Signal dom2 a--- @------ But will work when:------ @--- r ~ HiddenClockResetEnable dom => Signal dom a -> Signal dom a--- @------ If you want to connect a enable to a component working on multiple domains--- (such as the first example), use 'withSpecificClockResetEnable'.----#endif--- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- Usage with a _polymorphic_ domain:------ >>> reg = register 5 (reg + 1)--- >>> sig = withClockResetEnable clockGen resetGen enableGen reg--- >>> sampleN @System 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Force withClockResetEnable to work on signal (hence 'sampleN' not needing--- an explicit domain later):------ >>> reg = register 5 (reg + 1)--- >>> sig = withClockResetEnable @System clockGen resetGen enableGen reg--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]----withClockResetEnable-  :: forall dom r-   . KnownDomain dom-#ifdef CLASH_MULTIPLE_HIDDEN-  => WithSingleDomain dom r-#endif-  => Clock dom-  -- ^ The 'Clock' we want to connect-  -> Reset dom-  -- ^ The 'Reset' we want to connect-  -> Enable dom-  -- ^ The 'Enable' we want to connect-  -> (HiddenClockResetEnable dom => r)-  -- ^ The function with a hidden 'Clock', hidden 'Reset', and hidden-  -- 'Enable' argument-  -> r-withClockResetEnable =-  \clk rst en f -> withSpecificClockResetEnable clk rst en (const f) (Proxy @dom)-{-# INLINE withClockResetEnable #-}---- | Connect an explicit 'Clock', 'Reset', and 'Enable' to a function with a--- hidden 'Clock', 'Reset', and 'Enable'. This function can be used on components--- with multiple domains. As opposed to 'exposeClockResetEnable', callers should--- explicitly state what the enable domain is. See the examples for more--- information.------ <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>------ === __Example__--- 'withSpecificClockResetEnable' can only be used when it can find the--- specified domain in /r/:------ >>> reg = register @System 5 (reg + 1)--- >>> sig = withClockResetEnable @System clockGen resetGen enableGen reg--- >>> sampleN 10 sig--- [5,5,6,7,8,9,10,11,12,13]------ Type variables work too, if they are in scope. For example:------ @--- reg = 'register' @@dom 5 (reg + 1)--- sig = withClockResetEnable @@dom 'clockGen' 'resetGen' 'enableGen' reg--- @----withSpecificClockResetEnable-  :: forall dom r-   . (KnownDomain dom, WithSpecificDomain dom r)-  => Clock dom-  -- ^ The 'Clock' we want to connect-  -> Reset dom-  -- ^ The 'Reset' we want to connect-  -> Enable dom-  -- ^ The 'Enable' we want to connect-  -> (HiddenClockResetEnable dom => r)-  -- ^ The function with a hidden 'Clock', hidden 'Reset', and hidden-  -- 'Enable' argument-  -> r-withSpecificClockResetEnable =-  \clk rst en f -> withSpecificClock clk (withSpecificReset rst (withSpecificEnable en f))-{-# INLINE withSpecificClockResetEnable #-}---- * Basic circuit functions---- | Special version of 'delay' that doesn't take enable signals of any kind.--- Initial value will be undefined.-dflipflop-  :: forall dom a-   . ( HiddenClock dom-     , NFDataX a )-  => Signal dom a-  -> Signal dom a-dflipflop =-  E.dflipflop (fromLabel @(HiddenClockName dom))-{-# INLINE dflipflop #-}---- | 'delay' @s@ delays the values in 'Signal' @s@ for once cycle, the value--- at time 0 is /dflt/.------ >>> sampleN @System 3 (delay 0 (fromList [1,2,3,4]))--- [0,1,2]-delay-  :: forall dom a-   . ( NFDataX a-     , HiddenClock dom-     , HiddenEnable dom  )-  => a-  -- ^ Initial value-  -> Signal dom a-  -- ^ Signal to delay-  -> Signal dom a-delay dflt i =-  delay#-    (fromLabel @(HiddenClockName dom))-    (fromLabel @(HiddenEnableName dom))-    dflt-    i-{-# INLINE delay #-}---- | Version of 'delay' that only updates when its second argument is a 'Just'--- value.------ >>> let input = fromList [Just 1, Just 2, Nothing, Nothing, Just 5, Just 6, Just (7::Int)]--- >>> sampleN @System 7 (delayMaybe 0 input)--- [0,1,2,2,2,5,6]-delayMaybe-  :: forall dom a-   . ( NFDataX a-     , HiddenClock dom-     , HiddenEnable dom  )-  => a-  -- ^ Initial value-  -> Signal dom (Maybe a)-  -> Signal dom a-delayMaybe dflt i =-  E.delayMaybe-    (fromLabel @(HiddenClockName dom))-    (fromLabel @(HiddenEnableName dom))-    dflt-    i-{-# INLINE delayMaybe #-}---- | Version of 'delay' that only updates when its second argument is asserted.------ >>> let input = fromList [1,2,3,4,5,6,7::Int]--- >>> let enable = fromList [True,True,False,False,True,True,True]--- >>> sampleN @System 7 (delayEn 0 enable input)--- [0,1,2,2,2,5,6]-delayEn-  :: forall dom a-   . ( NFDataX a-     , HiddenClock dom-     , HiddenEnable dom  )-  => a-  -- ^ Initial value-  -> Signal dom Bool-  -- ^ Enable-  -> Signal dom a-  -> Signal dom a-delayEn dflt en i =-  E.delayEn-    (fromLabel @(HiddenClockName dom))-    (fromLabel @(HiddenEnableName dom))-    dflt-    en-    i-{-# INLINE delayEn #-}---- | 'register' @i s@ delays the values in 'Signal' @s@ for one cycle, and sets--- the value at time 0 to @i@------ >>> sampleN @System 5 (register 8 (fromList [1,1,2,3,4]))--- [8,8,1,2,3]-register-  :: forall dom a-   . ( HiddenClockResetEnable dom-     , NFDataX a )-  => a-  -- ^ Reset value-  ---  -- 'register' outputs the reset value when the reset value is active-  -> Signal dom a-  -> Signal dom a-register i s =-  E.register-    (fromLabel @(HiddenClockName dom))-    (fromLabel @(HiddenResetName dom))-    (fromLabel @(HiddenEnableName dom))-    i-    s-{-# INLINE register #-}-infixr 3 `register`---- | Version of 'register' that only updates its content when its second--- argument is a 'Just' value. So given:------ @--- sometimes1 = s where---   s = 'register' Nothing (switch '<$>' s)------   switch Nothing = Just 1---   switch _       = Nothing------ countSometimes = s where---   s     = 'regMaybe' 0 (plusM ('pure' '<$>' s) sometimes1)---   plusM = 'liftA2' (liftA2 (+))--- @------ We get:------ >>> sampleN @System 9 sometimes1--- [Nothing,Nothing,Just 1,Nothing,Just 1,Nothing,Just 1,Nothing,Just 1]--- >>> sampleN @System 9 countSometimes--- [0,0,0,1,1,2,2,3,3]-regMaybe-  :: forall dom a-   . ( HiddenClockResetEnable dom-     , NFDataX a )-  => a-  -- ^ Reset value. 'regMaybe' outputs the reset value when the reset is active.-  -> Signal dom (Maybe a)-  -> Signal dom a-regMaybe initial iM =-  E.regMaybe-    (fromLabel @(HiddenClockName dom))-    (fromLabel @(HiddenResetName dom))-    (fromLabel @(HiddenEnableName dom))-    initial-    iM-{-# INLINE regMaybe #-}-infixr 3 `regMaybe`---- | Version of 'register' that only updates its content when its second argument--- is asserted. So given:------ @--- oscillate = 'register' False ('not' '<$>' oscillate)--- count     = 'regEn' 0 oscillate (count + 1)--- @------ We get:------ >>> sampleN @System 9 oscillate--- [False,False,True,False,True,False,True,False,True]--- >>> sampleN @System 9 count--- [0,0,0,1,1,2,2,3,3]-regEn-  :: forall dom a-   . ( HiddenClockResetEnable dom-     , NFDataX a )-  => a-  -- ^ Reset value-  ---  -- 'regEn' outputs the reset value when the reset value is active-  -> Signal dom Bool-  -> Signal dom a-  -> Signal dom a-regEn initial en i =-  E.regEn-    (fromLabel @(HiddenClockName dom))-    (fromLabel @(HiddenResetName dom))-    (fromLabel @(HiddenEnableName dom))-    initial-    en-    i-{-# INLINE regEn #-}---- * Signal -> List conversion---- | Get an infinite list of samples from a 'Clash.Signal.Signal'------ The elements in the list correspond to the values of the 'Signal'--- at consecutive clock cycles------ > sample s == [s0, s1, s2, s3, ...------ If the given component has not yet been given a clock, reset, or enable--- line, 'sample' will supply them. The reset will be asserted for a single--- cycle. 'sample' will not drop the value produced by the circuit while--- the reset was asserted. If you want this, or if you want more than a--- single cycle reset, consider using 'sampleWithReset'.------ __NB__: This function is not synthesizable-sample-  :: forall dom a-   . ( KnownDomain dom-     , NFDataX a )-  => (HiddenClockResetEnable dom  => Signal dom a)-  -- ^ 'Signal' we want to sample, whose source potentially has a hidden clock-  -- (and reset)-  -> [a]-sample s =-  S.sample (exposeClockResetEnable @dom s clockGen resetGen enableGen)-{-# NOINLINE sample #-}---- | Get a list of /n/ samples from a 'Signal'------ The elements in the list correspond to the values of the 'Signal'--- at consecutive clock cycles------ > sampleN @System 3 s == [s0, s1, s2]------ If the given component has not yet been given a clock, reset, or enable--- line, 'sampleN' will supply them. The reset will be asserted for a single--- cycle. 'sampleN' will not drop the value produced by the circuit while--- the reset was asserted. If you want this, or if you want more than a--- single cycle reset, consider using 'sampleWithResetN'.------ __NB__: This function is not synthesizable-sampleN-  :: forall dom a-   . ( KnownDomain dom-     , NFDataX a )-  => Int-  -- ^ Number of samples to produce-  -> (HiddenClockResetEnable dom => Signal dom a)-  -- ^ 'Signal' to sample, whose source potentially has a hidden clock-  -- (and reset)-  -> [a]-sampleN n s0 =-  let s1 = exposeClockResetEnable @dom s0 clockGen resetGen enableGen in-  S.sampleN n s1-{-# NOINLINE sampleN #-}---- | Get a list of samples from a 'Signal', while asserting the reset line--- for /n/ clock cycles. 'sampleWithReset' does not return the first /n/ cycles,--- i.e., when the reset is asserted.------ __NB__: This function is not synthesizable-sampleWithReset-  :: forall dom a m-   . ( KnownDomain dom-     , NFDataX a-     , 1 <= m )-  => SNat m-  -- ^ Number of cycles to assert the reset-  -> (HiddenClockResetEnable dom => Signal dom a)-  -- ^ 'Signal' to sample, whose source potentially has a hidden clock-  -- (and reset)-  -> [a]-sampleWithReset nReset f0 =-  let f1 = exposeClockResetEnable f0 clockGen (resetGenN @dom nReset) enableGen in-  drop (snatToNum nReset) (S.sample f1)-{-# NOINLINE sampleWithReset #-}---- | Get a fine list of /m/ samples from a 'Signal', while asserting the reset line--- for /n/ clock cycles. 'sampleWithReset' does not return the first /n/ cycles,--- i.e., while the reset is asserted.------ __NB__: This function is not synthesizable-sampleWithResetN-  :: forall dom a m-   . ( KnownDomain dom-     , NFDataX a-     , 1 <= m )-  => SNat m-  -- ^ Number of cycles to assert the reset-  -> Int-  -- ^ Number of samples to produce-  -> (HiddenClockResetEnable dom => Signal dom a)-  -- ^ 'Signal' to sample, whose source potentially has a hidden clock-  -- (and reset)-  -> [a]-sampleWithResetN nReset nSamples f =-  take nSamples (sampleWithReset nReset f)---- | /Lazily/ get an infinite list of samples from a 'Clash.Signal.Signal'------ The elements in the list correspond to the values of the 'Signal'--- at consecutive clock cycles------ > sample s == [s0, s1, s2, s3, ...------ If the given component has not yet been given a clock, reset, or enable--- line, 'sample_lazy' will supply them. The reset will be asserted for a--- single cycle. 'sample_lazy' will not drop the value produced by the--- circuit while the reset was asserted.------ __NB__: This function is not synthesizable-sample_lazy-  :: forall dom a-   . KnownDomain dom-  => (HiddenClockResetEnable dom  => Signal dom a)-  -- ^ 'Signal' we want to sample, whose source potentially has a hidden clock-  -- (and reset)-  -> [a]-sample_lazy s =-  S.sample_lazy (exposeClockResetEnable @dom s clockGen resetGen enableGen)-{-# NOINLINE sample_lazy #-}---- | Lazily get a list of /n/ samples from a 'Signal'------ The elements in the list correspond to the values of the 'Signal'--- at consecutive clock cycles------ > sampleN @System 3 s == [s0, s1, s2]------ If the given component has not yet been given a clock, reset, or enable--- line, 'sampleN_lazy' will supply them. The reset will be asserted for a--- single cycle. 'sampleN_lazy' will not drop the value produced by the--- circuit while the reset was asserted.------ __NB__: This function is not synthesizable-sampleN_lazy-  :: forall dom a-   . KnownDomain dom-  => Int-  -> (HiddenClockResetEnable dom  => Signal dom a)-  -- ^ 'Signal' we want to sample, whose source potentially has a hidden clock-  -- (and reset)-  -> [a]-sampleN_lazy n s =-  S.sampleN_lazy n (exposeClockResetEnable @dom s clockGen resetGen enableGen)-{-# NOINLINE sampleN_lazy #-}---- * Simulation functions---- | Simulate a (@'Signal' a -> 'Signal' b@) function given a list of samples--- of type /a/------ >>> simulate @System (register 8) [1, 2, 3]--- [8,1,2,3...--- ...------ Where 'System' denotes the /domain/ to simulate on. The reset line is--- asserted for a single cycle. The first value is therefore supplied twice to--- the circuit: once while reset is high, and once directly after. The first--- /output/ value (the value produced while the reset is asserted) is dropped.------ If you only want to simulate a finite number of samples, see 'simulateN'. If--- you need the reset line to be asserted for more than one cycle or if you--- need a custom reset value, see 'simulateWithReset' and 'simulateWithResetN'.------ __NB__: This function is not synthesizable-simulate-  :: forall dom a b-   . ( KnownDomain dom-     , NFDataX a-     , NFDataX b )-  => (HiddenClockResetEnable dom => Signal dom a -> Signal dom b)-  -- ^ Circuit to simulate, whose source potentially has a hidden clock, reset,-  -- and/or enable.-  -> [a]-  -> [b]-simulate f as = simulateWithReset (SNat @1) (head as) f as-{-# INLINE simulate #-}---- | Same as 'simulate', but only sample the first /Int/ output values.------ __NB__: This function is not synthesizable-simulateN-  :: forall dom a b-   . ( KnownDomain dom-     , NFDataX a-     , NFDataX b )-  => Int-  -- ^ Number of cycles to simulate (excluding cycle spent in reset)-  -> (HiddenClockResetEnable dom => Signal dom a -> Signal dom b)-  -- ^ 'Signal' we want to sample, whose source potentially has a hidden clock-  -- (and reset)-  -> [a]-  -> [b]-simulateN n f as = simulateWithResetN (SNat @1) (head as) n f as-{-# INLINE simulateN #-}---- | Same as 'simulate', but with the reset line asserted for /n/ cycles. Similar--- to 'simulate', 'simulateWithReset' will drop the output values produced while--- the reset is asserted. While the reset is asserted, the reset value /a/ is--- supplied to the circuit.-simulateWithReset-  :: forall dom a b m-   . ( KnownDomain dom-     , NFDataX a-     , NFDataX b-     , 1 <= m )-  => SNat m-  -- ^ Number of cycles to assert the reset-  -> a-  -- ^ Reset value-  -> (HiddenClockResetEnable dom => Signal dom a -> Signal dom b)-  -- ^ 'Signal' we want to sample, whose source potentially has a hidden clock-  -- (and reset)-  -> [a]-  -> [b]-simulateWithReset n resetVal f as =-  S.simulateWithReset n resetVal (exposeClockResetEnable f) as-{-# INLINE simulateWithReset #-}---- | Same as 'simulateWithReset', but only sample the first /Int/ output values.-simulateWithResetN-  :: forall dom a b m-   . ( KnownDomain dom-     , NFDataX a-     , NFDataX b-     , 1 <= m )-  => SNat m-  -- ^ Number of cycles to assert the reset-  -> a-  -- ^ Reset value-  -> Int-  -- ^ Number of cycles to simulate (excluding cycles spent in reset)-  -> (HiddenClockResetEnable dom => Signal dom a -> Signal dom b)-  -- ^ 'Signal' we want to sample, whose source potentially has a hidden clock-  -- (and reset)-  -> [a]-  -> [b]-simulateWithResetN nReset resetVal nSamples f as =-  S.simulateWithResetN nReset resetVal nSamples (exposeClockResetEnable f) as-{-# INLINE simulateWithResetN #-}----- | /Lazily/ simulate a (@'Signal' a -> 'Signal' b@) function given a list of--- samples of type /a/------ >>> simulate @System (register 8) [1, 2, 3]--- [8,1,2,3...--- ...------ __NB__: This function is not synthesizable-simulate_lazy-  :: forall dom a b-   . KnownDomain dom-  => (HiddenClockResetEnable dom  =>-      Signal dom a -> Signal dom b)-  -- ^ Function we want to simulate, whose components potentially have a hidden-  -- clock (and reset)-  -> [a]-  -> [b]-simulate_lazy f0 =-  let f1 = exposeClockResetEnable @dom f0 clockGen resetGen enableGen in-  tail . S.simulate_lazy f1 . dup1-{-# NOINLINE simulate_lazy #-}---- | Simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a list of--- samples of type @a@------ >>> simulateB @System (unbundle . register (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)]--- [(8,8),(1,1),(2,2),(3,3)...--- ...------ __NB__: This function is not synthesizable-simulateB-  :: forall dom a b-   . ( KnownDomain dom-     , Bundle a-     , Bundle b-     , NFDataX a-     , NFDataX b-     )-  => (HiddenClockResetEnable dom  =>-      Unbundled dom a -> Unbundled dom b)-  -- ^ Function we want to simulate, whose components potentially have a hidden-  -- clock (and reset)-  -> [a]-  -> [b]-simulateB f0 =-  tail . S.simulateB f1 . dup1- where-  f1 =-    withSpecificClockResetEnable-      @dom-      clockGen-      resetGen-      enableGen-      (const f0)-      (Proxy @dom)-{-# NOINLINE simulateB #-}---- | /Lazily/ simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a--- list of samples of type @a@------ >>> simulateB @System (unbundle . register (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)]--- [(8,8),(1,1),(2,2),(3,3)...--- ...------ __NB__: This function is not synthesizable-simulateB_lazy-  :: forall dom a b-   . ( KnownDomain dom-     , Bundle a-     , Bundle b )-  => (HiddenClockResetEnable dom  =>-      Unbundled dom a -> Unbundled dom b)-  -- ^ Function we want to simulate, whose components potentially have a hidden-  -- clock (and reset)-  -> [a]-  -> [b]-simulateB_lazy f0 =-  tail . S.simulateB_lazy f1 . dup1- where-  f1 =-    withSpecificClockResetEnable-      @dom-      clockGen-      resetGen-      enableGen-      (const f0)-      (Proxy @dom)-{-# NOINLINE simulateB_lazy #-}--dup1 :: [a] -> [a]-dup1 (x:xs) = x:x:xs-dup1 _      = error "empty list"---- * QuickCheck combinators---- |  @testFor n s@ tests the signal /s/ for /n/ cycles.------ __NB__: This function is not synthesizable-testFor-  :: KnownDomain dom-  => Int-  -- ^ The number of cycles we want to test for-  -> (HiddenClockResetEnable dom  => Signal dom Bool)-  -- ^ 'Signal' we want to evaluate, whose source potentially has a hidden clock-  -- (and reset)-  -> Property-testFor n s = property (and (Clash.Signal.sampleN n s))--#ifdef CLASH_MULTIPLE_HIDDEN--- ** Synchronization primitive--- | Implicit version of 'Clash.Explicit.Signal.unsafeSynchronizer'.-unsafeSynchronizer-  :: forall dom1 dom2 a-   . ( HiddenClock dom1-     , HiddenClock dom2 )-  => Signal dom1 a-  -> Signal dom2 a-unsafeSynchronizer =-  hideClock (hideClock S.unsafeSynchronizer)-#endif---- | Hold reset for a number of cycles relative to an implicit reset signal.------ Example:------ >>> sampleN @System 8 (unsafeToHighPolarity (holdReset (SNat @2)))--- [True,True,True,False,False,False,False,False]------ 'holdReset' holds the reset for an additional 2 clock cycles for a total--- of 3 clock cycles where the reset is asserted.----holdReset-  :: forall dom m-   . HiddenClockResetEnable dom-  => SNat m-  -- ^ Hold for /m/ cycles, counting from the moment the incoming reset-  -- signal becomes deasserted.-  -> Reset dom-holdReset m =-  hideClockResetEnable (\clk rst en -> E.holdReset clk en m rst)---- | Like 'fromList', but resets on reset and has a defined reset value.------ >>> let rst = unsafeFromHighPolarity (fromList [True, True, False, False, True, False])--- >>> let res = withReset rst (fromListWithReset Nothing [Just 'a', Just 'b', Just 'c'])--- >>> sampleN @System 6 res--- [Nothing,Nothing,Just 'a',Just 'b',Nothing,Just 'a']------ __NB__: This function is not synthesizable-fromListWithReset-  :: forall dom a-   . (HiddenReset dom, NFDataX a)-  => a-  -> [a]-  -> Signal dom a-fromListWithReset = hideReset E.fromListWithReset-{-# INLINE fromListWithReset #-}--#ifdef CLASH_MULTIPLE_HIDDEN--- | Convert between different types of reset, adding a synchronizer in case--- it needs to convert from an asynchronous to a synchronous reset.-convertReset-  :: forall domA domB-   . ( HiddenClock domA-     , HiddenClock domB-     )-  => Reset domA-  -> Reset domB-convertReset =-  E.convertReset hasClock hasClock-#endif+                  2017     , Google Inc.,+                  2021-2026, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Clash has synchronous 'Signal's in the form of:++@+'Signal' (dom :: 'Domain') a+@++Where /a/ is the type of the value of the 'Signal', for example /Int/ or /Bool/,+and /dom/ is the /clock-/ (and /reset-/) domain to which the memory elements+manipulating these 'Signal's belong.++The type-parameter, /dom/, is of the kind 'Domain' - a simple string. That+string refers to a single /synthesis domain/. A synthesis domain describes the+behavior of certain aspects of memory elements in it. More specifically, a+domain looks like:++@+'DomainConfiguration'+  { _name :: 'Domain'+  -- ^ Domain name+  , _period :: 'Clash.Promoted.Nat.Nat'+  -- ^ Clock period in \/ps\/+  , _activeEdge :: 'ActiveEdge'+  -- ^ Active edge of the clock+  , _resetKind :: 'ResetKind'+  -- ^ Whether resets are synchronous (edge-sensitive) or asynchronous (level-sensitive)+  , _initBehavior :: 'InitBehavior'+  -- ^ Whether the initial (or "power up") value of memory elements is+  -- unknown/undefined, or configurable to a specific value+  , _resetPolarity :: ResetPolarity+  -- ^ Whether resets are active high or active low+  }+@++Check the documentation of each of the types to see the various options Clash+provides. In order to specify a domain, an instance of 'KnownDomain' should be+made. Clash provides an implementation 'System' with some common options+chosen:++@+instance KnownDomain 'System' where+  type KnownConf 'System' = 'DomainConfiguration 'System' 10000 'Rising 'Asynchronous 'Defined 'ActiveHigh+  knownDomain = SDomainConfiguration SSymbol SNat SRising SAsynchronous SDefined SActiveHigh+@++In words, \"System\" is a synthesis domain with a clock running with a period+of 10000 /ps/. Memory elements respond to the rising edge of the clock,+asynchronously to changes in their resets, and have defined power up values+if applicable.++In order to create a new domain, you don't have to instantiate it explicitly.+Instead, you can have 'createDomain' create a domain for you. You can also use+the same function to subclass existing domains.++* __NB__: \"Bad things\"™  happen when you actually use a clock period of @0@,+so do __not__ do that!+* __NB__: You should be judicious using a clock with period of @1@ as you can+never create a clock that goes any faster!+* __NB__: Whether 'System' has good defaults depends on your target platform.+Check out 'IntelSystem' and 'XilinxSystem' too!+-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Signal+  ( -- * Synchronous signals+    Signal+  , BiSignalIn+  , BiSignalOut+  , BiSignalDefault(..)+    -- * Domain+  , Domain+  , sameDomain+  , KnownDomain(..)+  , KnownConfiguration+  , ActiveEdge(..)+  , SActiveEdge(..)+  , InitBehavior(..)+  , SInitBehavior(..)+  , ResetKind(..)+  , SResetKind(..)+  , ResetPolarity(..)+  , SResetPolarity(..)+  , DomainConfiguration(..)+  , SDomainConfiguration(..)+  -- ** Configuration type families+  , DomainPeriod+  , DomainActiveEdge+  , DomainResetKind+  , DomainInitBehavior+  , DomainResetPolarity+    -- *** Convenience types+    -- $conveniencetypes++  , HasSynchronousReset+  , HasAsynchronousReset+  , HasDefinedInitialValues+  -- **** Time representations+  , Seconds+  , Milliseconds+  , Microseconds+  , Nanoseconds+  , Picoseconds+  -- **** Time conversions+  , DomainToHz+  , HzToPeriod+  , PeriodToHz+  , PeriodToCycles+  , ClockDivider+    -- ** Default domains+  , System+  , XilinxSystem+  , IntelSystem+  , vSystem+  , vIntelSystem+  , vXilinxSystem+    -- ** Domain utilities+  , VDomainConfiguration(..)+  , vDomain+  , createDomain+  , knownVDomain+  , clockPeriod+  , activeEdge+  , resetKind+  , initBehavior+  , resetPolarity+    -- * Clock+  , Clock+  , DiffClock+  , periodToHz+  , hzToPeriod+    -- * Reset+  , Reset+  , unsafeToReset+  , unsafeFromReset+  , unsafeToActiveHigh+  , unsafeToActiveLow+  , unsafeFromActiveHigh+  , unsafeFromActiveLow+  , resetSynchronizer+  , resetGlitchFilter+  , registerSyncReset+  , holdReset+    -- * Enabling+  , Enable+  , toEnable+  , fromEnable+  , E.enableGen+    -- * Hidden clock, reset, and enable arguments+    -- $hiddenclockandreset++    -- ** Monomorphism restriction leads to surprising behavior+    -- $monomorphism++    -- ** Hidden clock+  , HiddenClock+  , hideClock+  , exposeClock+  , withClock+  , hasClock+    -- ** Hidden reset+  , HiddenReset+  , hideReset+  , exposeReset+  , withReset+  , hasReset+    -- ** Hidden enable+  , HiddenEnable+  , hideEnable+  , exposeEnable+  , withEnable+  , hasEnable+    -- ** Hidden clock, reset, and enable+  , HiddenClockResetEnable+  , hideClockResetEnable+  , exposeClockResetEnable+  , withClockResetEnable+  , SystemClockResetEnable+    -- * Basic circuit functions+  , andEnable+  , dflipflop+  , delay+  , delayMaybe+  , delayEn+  , register+  , regMaybe+  , regEn+  , regEnN+  , mux+  , apEn+    -- * Simulation and testbench functions+  , clockGen+  , resetGen+  , resetGenN+  , systemClockGen+  , systemResetGen+    -- * Boolean connectives+  ,(.&&.), (&&.), (.&&), (.||.), (||.), (.||)+    -- * Product/Signal isomorphism+  , Bundle(..)+  , EmptyTuple(..)+  , TaggedEmptyTuple(..)+    -- * Simulation functions (not synthesizable)+  , simulate+  , simulateB+  , simulateN+  , simulateWithReset+  , simulateWithResetN+  , runUntil+    -- ** lazy versions+  , simulate_lazy+  , simulateB_lazy+    -- ** Automaton+  , signalAutomaton+    -- * List \<-\> Signal conversion (not synthesizable)+  , sample+  , sampleN+  , sampleWithReset+  , sampleWithResetN+  , fromList+  , fromListWithReset+    -- ** lazy versions+  , sample_lazy+  , sampleN_lazy+  , fromList_lazy+    -- * QuickCheck combinators+  , testFor+    -- * Type classes+    -- ** 'Eq'-like+  , (.==.), (.==), (==.), (./=.), (./=), (/=.)+    -- ** 'Ord'-like+  , (.<.), (.<), (<.), (.<=.), (.<=), (<=.), (.>=.), (.>=), (>=.), (.>.), (.>), (>.)+    -- * Bisignal functions+  , veryUnsafeToBiSignalIn+  , readFromBiSignal+  , writeToBiSignal+  , mergeBiSignalOuts++    -- * Internals+  , HiddenClockName+  , HiddenResetName+  , HiddenEnableName++    -- * Deprecated+  , unsafeFromHighPolarity+  , unsafeFromLowPolarity+  , unsafeToHighPolarity+  , unsafeToLowPolarity+  )+where++import           Control.Arrow.Transformer.Automaton (Automaton)+import           GHC.TypeLits          (type (<=))+import           Data.List             (uncons)+import           Data.Proxy            (Proxy(..))+import           Prelude+import           Test.QuickCheck       (Property, property)++import qualified Clash.Explicit.Signal as E+import qualified Clash.Explicit.Reset  as E+import           Clash.Explicit.Reset  (resetSynchronizer, resetGlitchFilter)+import           Clash.Explicit.Signal (systemClockGen, systemResetGen)+import           Clash.Hidden+import           Clash.Promoted.Nat    (SNat (..), snatToNum)+import           Clash.Signal.Bundle+  (Bundle (..), EmptyTuple(..), TaggedEmptyTuple(..))+import           Clash.Signal.BiSignal --(BisignalIn, BisignalOut, )+import           Clash.Signal.Internal hiding+  (sample, sample_lazy, sampleN, sampleN_lazy, simulate, simulate_lazy, testFor,+   signalAutomaton)+import           Clash.Signal.Internal.Ambiguous+  (knownVDomain, clockPeriod, activeEdge, resetKind, initBehavior, resetPolarity)+import           Clash.XException      (NFDataX, ShowX)++{- $setup+>>> :set -XFlexibleContexts -XTypeApplications+>>> :m -Prelude+>>> import Clash.Prelude+>>> import Clash.Promoted.Nat (SNat(..))+>>> import Clash.XException (printX)+>>> import Control.Applicative (liftA2)+>>> let oscillate = register False (not <$> oscillate)+>>> let count = regEn 0 oscillate (count + 1)+>>> :{+let sometimes1 = s where+      s = register Nothing (switch <$> s)+      switch Nothing = Just 1+      switch _       = Nothing+:}++>>> :{+let countSometimes = s where+      s     = regMaybe 0 (plusM (pure <$> s) sometimes1)+      plusM = liftA2 (liftA2 (+))+:}++-}++{- $conveniencetypes++==== Simplifying++If you want to write part of your Clash design as domain-polymorphic functions,+it can be practical to define a design-wide constraint synonym that captures the+characteristics of the clock domains of the design. Such a constraint synonym+can be used as a constraint on all domain-polymorphic functions in the design,+regardless of whether they actually need the constraints from this section.++@+type DesignDomain dom =+  ( 'HasSynchronousReset' dom+  , 'HasDefinedInitialValues' dom+  )++type DesignDomainHidden dom =+  ( DesignDomain dom+  , 'HiddenClockResetEnable' dom+  )++myFunc ::+  DesignDomainHidden dom =>+  'Signal' dom [...]+@++This way, you don't have to think about which constraints the function you're+writing has exactly, and the constraint is succinct.+-}++{- $hiddenclockandreset #hiddenclockandreset#+Clocks, resets and enables are by default implicitly routed to their components.+You can see from the type of a component whether it has hidden clock, reset or+enable arguments:++It has a hidden clock when it has a:++@+f :: 'HiddenClock' dom => ...+@++Constraint.++Or it has a hidden reset when it has a:++@+g :: 'HiddenReset' dom => ...+@++Constraint.++Or it has a hidden enable when it has a:++@+g :: 'HiddenEnable' dom => ...+@++Constraint.++Or it has a hidden clock argument, a hidden reset argument and a hidden enable+argument when it has a:++@+h :: 'HiddenClockResetEnable' dom  => ..+@++Constraint.++Given a component with explicit clock, reset and enable arguments, you can turn+them into hidden arguments using 'hideClock', 'hideReset', and 'hideEnable'. So+given a:++@+f :: Clock dom -> Reset dom -> Enable dom -> Signal dom a -> ...+@++You hide the clock and reset arguments by:++@+-- g :: 'HiddenClockResetEnable' dom  => Signal dom a -> ...+g = 'hideClockResetEnable' f+@++Or, alternatively, by:++@+-- h :: 'HiddenClockResetEnable' dom  => Signal dom a -> ...+h = f 'hasClock' 'hasReset' 'hasEnable'+@++== Assigning explicit clock, reset and enable arguments to hidden clocks, resets and enables++Given a component:++@+f :: 'HiddenClockResetEnable' dom+  => Signal dom Int+  -> Signal dom Int+@++which has hidden clock, reset and enable arguments, we expose those hidden+arguments so that we can explicitly apply them:++@+-- g :: Clock dom -> Reset dom -> Enable dom -> Signal dom Int -> Signal dom Int+g = 'exposeClockResetEnable' f+@++or, alternatively, by:++@+-- h :: Clock dom -> Reset dom -> Enable dom -> Signal dom Int -> Signal dom Int+h clk rst en = 'withClockResetEnable' clk rst en f+@++Similarly, there are 'exposeClock', 'exposeReset' and 'exposeEnable' to just+expose the hidden clock, the hidden reset or the hidden enable argument.++You will need to explicitly apply clocks and resets when you want to use+components such as PLLs:++@+topEntity+  :: Clock  System+  -> Reset  System+  -> Signal System Bit+  -> Signal System (BitVector 8)+topEntity clk rst key1 =+    let  (pllOut,pllRst) = 'Clash.Intel.ClockGen.altpllSync' clk rst+    in   'exposeClockResetEnable' leds pllOut pllRst enableGen+  where+    key1R  = isRising 1 key1+    leds   = mealy blinkerT (1, False, 0) key1R+@++or, using the alternative method:++@+topEntity+  :: Clock  System+  -> Reset  System+  -> Signal System Bit+  -> Signal System (BitVector 8)+topEntity clk rst key1 =+    let  (pllOut,pllRst) = 'Clash.Intel.ClockGen.altpllSync' clk rst+    in   'withClockResetEnable' pllOut pllRst enableGen leds+  where+    key1R  = isRising 1 key1+    leds   = mealy blinkerT (1, False, 0) key1R+@+-}++{- $monomorphism #monomorphism#++If you don't provide a type signature for a function, Haskell will infer one for+you. Sometimes this inferred type is less general than you would expect. This+can be due to the monomorphism restriction, which is a rather intricate+technical aspect of Haskell's type system. You don't need to understand it to+avoid the problems it creates with hidden parameters, though.++The @expose...@ and @with...@ functions for hidden clocks, resets, and enables+are intended to be used to resolve a function with hidden parameters into a+function without that hidden parameter. Put differently, 'exposeClock' and+'withClock' are not themselves used in a 'HiddenClock' context, and so on for+resets and enables. If the rule that they are not themselves in a @Hidden...@+context is observed, they will function as expected. No specific consideration+is needed in these cases.++However, the function 'andEnable' is explicitly designed to be used within a+'HiddenEnable' context. In such a situation, it is important to provide a type+signature for the component that is given to `andEnable` as an argument, and not+let Haskell infer one.++The use of 'andEnable' has an unfortunate interaction with Haskells monomorphism+restriction that can lead to very surprising behavior. All of the following also+applies to using 'exposeClock' and 'withClock' inside a 'HiddenClock' context,+and so on for resets and enables.++When you write a function++@+f :: HiddenClockResetEnable dom+  => Signal dom Bool+  -> Signal dom Int+  -> Signal dom Int+f en i = andEnable en g i -- BROKEN+ where+  g = register 0+@++you would intuitively think this has the following type for the local function @g@:++@+f :: forall dom+   . HiddenClockResetEnable dom+  => Signal dom Bool+  -> Signal dom Int+  -> Signal dom Int+f en i = andEnable en g i+ where+  g :: HiddenClockResetEnable dom => Signal dom Int -> Signal dom Int+  g = register 0+@++but instead, the monomorphism restriction will cause the following type to be inferred:++@+f :: forall dom+   . HiddenClockResetEnable dom+  => Signal dom Bool+  -> Signal dom Int+  -> Signal dom Int+f en i = andEnable en g i -- BROKEN+ where+  g :: Signal dom Int -> Signal dom Int+  g = register 0+@++The monomorphism restriction essentially misqualifies the implicit parameter as+polymorphism, and tries to remove the implicit parameter from the context of the+function's type. It /can/ do that because the outer scope already has a+'HiddenEnable' context. But by getting that implicit parameter of the enclosing+function as context, it also gets the value of the parameter of the enclosing+function. So the Enable line for @g@ is the Enable line of @f@, and the Enable+line produced by 'andEnable' that was intended to be connected to @g@ is not+connected to anything!++When using 'andEnable', you should always explicitly provide the type signature+for the component given to 'andEnable' as an argument, thereby avoiding+surprising inferred types. We don't advise you to turn off the monomorphism+restriction, as this may have undesirable consequences.++Note that the inferred type is not always incorrect. The following variant works+correctly:++@+f :: HiddenClockResetEnable dom+  => Signal dom Bool+  -> Signal dom Int+  -> Signal dom Int+f en i = andEnable en g i+ where+  g i = register 0 i+@++This is an instance of the very first example on+<https://wiki.haskell.org/Monomorphism_restriction HaskellWiki>, @f1@ (as+opposed to @f4@). The monomorphism restriction works differently for function+bindings and pattern bindings. Since @g@ here has a formal parameter, it is a+function binding, and the monomorphish restriction does not kick in. The code+works as expected. If a later code change removes the formal parameter, all of a+sudden the code silently disregards the @en@ signal! Adhering to the rule that+you should always explicitly provide the type signature for the component given+to 'andEnable' as an argument would have avoided this hard to debug problem.+-}++type HiddenClockName (dom :: Domain) = "clock"+type HiddenResetName (dom :: Domain) = "reset"+type HiddenEnableName (dom :: Domain) = "enable"++-- | A /constraint/ that indicates the component has a hidden 'Clock'+--+-- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>+type HiddenClock dom =+  ( Hidden (HiddenClockName dom) (Clock dom)+  , KnownDomain dom )++-- | A /constraint/ that indicates the component needs a 'Reset'+--+-- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>+type HiddenReset dom =+  ( Hidden (HiddenResetName dom) (Reset dom)+  , KnownDomain dom )++-- | A /constraint/ that indicates the component needs an 'Enable'+--+-- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>+type HiddenEnable dom =+  ( Hidden (HiddenEnableName dom) (Enable dom)+  , KnownDomain dom )++-- | A /constraint/ that indicates the component needs a 'Clock', a 'Reset',+-- and an 'Enable' belonging to the same @dom@.+--+-- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>+type HiddenClockResetEnable dom  =+  ( HiddenClock dom+  , HiddenReset dom+  , HiddenEnable dom+  )++-- | A /constraint/ that indicates the component needs a 'Clock', a 'Reset',+-- and an 'Enable' belonging to the 'System' domain.+--+-- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>+type SystemClockResetEnable =+  ( Hidden (HiddenClockName System) (Clock System)+  , Hidden (HiddenResetName System) (Reset System)+  , Hidden (HiddenEnableName System) (Enable System)+  )+++{- | Expose a hidden 'Clock' argument of a component, so it can be applied+explicitly.++<Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>++=== __Example__+Usage with a /polymorphic/ domain:++>>> reg = register 5 (reg + 1)+>>> sig = exposeClock reg clockGen+>>> sampleN @System 10 sig+[5,5,6,7,8,9,10,11,12,13]++Force 'exposeClock' to work on 'System' (hence 'sampleN' not needing an explicit+domain later):++>>> reg = register 5 (reg + 1)+>>> sig = exposeClock @System reg clockGen+>>> sampleN 10 sig+[5,5,6,7,8,9,10,11,12,13]+-}+exposeClock+  :: forall dom  r+   . (HiddenClock dom => r)+  -- ^ The component with a hidden clock+  -> (KnownDomain dom => Clock dom -> r)+  -- ^ The component with its clock argument exposed+exposeClock = \f clk -> expose @(HiddenClockName dom) f clk+{-# INLINE exposeClock #-}++-- | Hide the 'Clock' argument of a component, so it can be routed implicitly.+--+-- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>+hideClock+  :: forall dom r+   . HiddenClock dom+  => (Clock dom -> r)+  -- ^ Function whose clock argument you want to hide+  -> r+hideClock = \f -> f (fromLabel @(HiddenClockName dom))+{-# INLINE hideClock #-}++{- | Connect an explicit 'Clock' to a function with a hidden 'Clock'.++<Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>++=== __Example__+Usage with a /polymorphic/ domain:++>>> reg = register 5 (reg + 1)+>>> sig = withClock clockGen reg+>>> sampleN @System 10 sig+[5,5,6,7,8,9,10,11,12,13]++Force 'withClock' to work on 'System' (hence 'sampleN' not needing an explicit+domain later):++>>> reg = register 5 (reg + 1)+>>> sig = withClock @System clockGen reg+>>> sampleN 10 sig+[5,5,6,7,8,9,10,11,12,13]+-}+withClock+  :: forall dom r+   . KnownDomain dom+  => Clock dom+  -- ^ The 'Clock' we want to connect+  -> (HiddenClock dom => r)+  -- ^ The function with a hidden 'Clock' argument+  -> r+withClock = \clk f -> expose @(HiddenClockName dom) f clk+{-# INLINE withClock #-}++-- | Connect a hidden 'Clock' to an argument where a normal 'Clock' argument+-- was expected.+--+-- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>+hasClock+  :: forall dom+   . HiddenClock dom+  => Clock dom+hasClock = fromLabel @(HiddenClockName dom)+{-# INLINE hasClock #-}++{- | Expose a hidden 'Reset' argument of a component, so it can be applied+explicitly.++=== __Example__+Usage with a /polymorphic/ domain:++>>> reg = register 5 (reg + 1)+>>> sig = exposeReset reg resetGen+>>> sampleN @System 10 sig+[5,5,6,7,8,9,10,11,12,13]++Force 'exposeReset' to work on 'System' (hence 'sampleN' not needing an explicit+domain later):++>>> reg = register 5 (reg + 1)+>>> sig = exposeReset @System reg resetGen+>>> sampleN 10 sig+[5,5,6,7,8,9,10,11,12,13]+-}+exposeReset+  :: forall dom r+   . (HiddenReset dom => r)+  -- ^ The component with a hidden reset+  -> (KnownDomain dom => Reset dom -> r)+  -- ^ The component with its reset argument exposed+exposeReset = \f rst -> expose @(HiddenResetName dom) f rst+{-# INLINE exposeReset #-}++-- | Hide the 'Reset' argument of a component, so it can be routed implicitly.+--+-- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>+hideReset+  :: forall dom r+   . HiddenReset dom+  => (Reset dom -> r)+  -- ^ Component whose reset argument you want to hide+  -> r+hideReset = \f -> f (fromLabel @(HiddenResetName dom))+{-# INLINE hideReset #-}++{- | Connect an explicit 'Reset' to a function with a hidden 'Reset'.+++=== __Example__+Usage with a /polymorphic/ domain:++>>> reg = register 5 (reg + 1)+>>> sig = withReset resetGen reg+>>> sampleN @System 10 sig+[5,5,6,7,8,9,10,11,12,13]++Force 'withReset' to work on 'System' (hence 'sampleN' not needing an explicit+domain later):++>>> reg = register 5 (reg + 1)+>>> sig = withReset @System resetGen reg+>>> sampleN 10 sig+[5,5,6,7,8,9,10,11,12,13]+-}+withReset+  :: forall dom r+   . KnownDomain dom+  => Reset dom+  -- ^ The 'Reset' we want to connect+  -> (HiddenReset dom => r)+  -- ^ The function with a hidden 'Reset' argument+  -> r+withReset = \rst f -> expose @(HiddenResetName dom) f rst+{-# INLINE withReset #-}++-- | Connect a hidden 'Reset' to an argument where a normal 'Reset' argument+-- was expected.+--+-- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>+hasReset+  :: forall dom+   . HiddenReset dom+  => Reset dom+hasReset = fromLabel @(HiddenResetName dom)+{-# INLINE hasReset #-}++{- | Expose a hidden 'Enable' argument of a component, so it can be applied+explicitly.++<Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>++=== __Example__+Usage with a /polymorphic/ domain:++>>> reg = register 5 (reg + 1)+>>> sig = exposeEnable reg enableGen+>>> sampleN @System 10 sig+[5,5,6,7,8,9,10,11,12,13]++Force 'exposeEnable' to work on 'System' (hence 'sampleN' not needing an+explicit domain later):++>>> reg = register 5 (reg + 1)+>>> sig = exposeEnable @System reg enableGen+>>> sampleN 10 sig+[5,5,6,7,8,9,10,11,12,13]+-}+exposeEnable+  :: forall dom  r+  .  (HiddenEnable dom => r)+  -- ^ The component with a hidden enable+  -> (KnownDomain dom => Enable dom -> r)+  -- ^ The component with its enable argument exposed+exposeEnable = \f gen -> expose @(HiddenEnableName dom) f gen+{-# INLINE exposeEnable #-}++-- | Hide the 'Enable' argument of a component, so it can be routed implicitly.+--+-- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>+hideEnable+  :: forall dom r+   . HiddenEnable dom+  => (Enable dom -> r)+  -- ^ Component whose enable argument you want to hide+  -> r+hideEnable = \f -> f (fromLabel @(HiddenEnableName dom))+{-# INLINE hideEnable #-}++{- | Connect an explicit 'Enable' to a function with a hidden 'Enable'.++<Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>++=== __Example__+Usage with a /polymorphic/ domain:++>>> reg = register 5 (reg + 1)+>>> sig = withEnable enableGen reg+>>> sampleN @System 10 sig+[5,5,6,7,8,9,10,11,12,13]++Force 'withEnable' to work on 'System' (hence 'sampleN' not needing an explicit+domain later):++>>> reg = register 5 (reg + 1)+>>> sig = withEnable @System enableGen reg+>>> sampleN 10 sig+[5,5,6,7,8,9,10,11,12,13]+-}+withEnable+  :: forall dom r+   . KnownDomain dom+  => Enable dom+  -- ^ The 'Enable' we want to connect+  -> (HiddenEnable dom => r)+  -- ^ The function with a hidden 'Enable' argument+  -> r+withEnable = \gen f -> expose @(HiddenEnableName dom) f gen+{-# INLINE withEnable #-}++-- | Connect a hidden 'Enable' to an argument where a normal 'Enable' argument+-- was expected.+--+-- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>+hasEnable+  :: forall dom+   . HiddenEnable dom+  => Enable dom+hasEnable = fromLabel @(HiddenEnableName dom)+{-# INLINE hasEnable #-}++{- | Merge enable signal with signal of bools by applying the boolean AND+operation.++__NB: The component given to 'andEnable' as an argument needs an explicit type signature.__+Please read [Monomorphism restriction leads to surprising+behavior](#monomorphism).++The component whose enable is modified will only be enabled when both the+encompassing 'HiddenEnable' and the 'Signal' @dom@ 'Bool' are asserted.++<#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>++=== __Example__+Usage with a /polymorphic/ domain:++>>> reg = register 5 (reg + 1)+>>> f en = andEnable en reg+>>> sampleN @System 10 (f (riseEvery d2))+[5,5,5,6,6,7,7,8,8,9]++Force 'andEnable' to work on 'System' (hence 'sampleN' not needing an explicit+domain later):++>>> reg = register 5 (reg + 1)+>>> f en = andEnable @System en reg+>>> sampleN 10 (f (riseEvery d2))+[5,5,5,6,6,7,7,8,8,9]+-}+andEnable+  :: forall dom r+   . HiddenEnable dom+  => Signal dom Bool+  -- ^ The signal to AND with+  -> (HiddenEnable dom => r)+  -- ^ The component whose enable is modified+  -> r+andEnable = \en f -> andEnable0 hasEnable en f+ where+  andEnable0+    :: Enable dom+    -> Signal dom Bool+    -> (HiddenEnable dom => r)+    -> r+  andEnable0 gen en f =+    let en0 = E.andEnable gen en+    in withEnable @dom en0 f+{-# INLINE andEnable #-}++{- | Expose hidden 'Clock', 'Reset', and 'Enable' arguments of a component, so+they can be applied explicitly.++<Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>++=== __Example__+Usage with a /polymorphic/ domain:++>>> reg = register 5 (reg + 1)+>>> sig = exposeClockResetEnable reg clockGen resetGen enableGen+>>> sampleN @System 10 sig+[5,5,6,7,8,9,10,11,12,13]++Force 'exposeClockResetEnable' to work on 'System' (hence 'sampleN' not needing+an explicit domain later):++>>> reg = register 5 (reg + 1)+>>> sig = exposeClockResetEnable @System reg clockGen resetGen enableGen+>>> sampleN 10 sig+[5,5,6,7,8,9,10,11,12,13]++Usage in a testbench context:++@+topEntity :: Vec 2 (Vec 3 (Unsigned 8)) -> Vec 6 (Unsigned 8)+topEntity = concat++testBench :: Signal System Bool+testBench = done+  where+    testInput      = pure ((1 :> 2 :> 3 :> Nil) :> (4 :> 5 :> 6 :> Nil) :> Nil)+    expectedOutput = outputVerifier' ((1:>2:>3:>4:>5:>6:>Nil):>Nil)+    done           = exposeClockResetEnable (expectedOutput (topEntity \<\$> testInput)) clk rst en+    clk            = tbSystemClockGen (not <\$\> done)+    rst            = systemResetGen+    en             = enableGen+@+-}+exposeClockResetEnable+  :: forall dom r .+     (HiddenClockResetEnable dom => r)+  -- ^ The component with hidden clock, reset, and enable arguments+  -> (KnownDomain dom => Clock dom -> Reset dom -> Enable dom -> r)+  -- ^ The component with its clock, reset, and enable arguments exposed+exposeClockResetEnable =+  \f clk rst en ->+    exposeClock (exposeReset (exposeEnable f)) clk rst en+{-# INLINE exposeClockResetEnable #-}++-- | Hide the 'Clock', 'Reset', and 'Enable' arguments of a component, so they+-- can be routed implicitly.+--+-- <Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>+hideClockResetEnable+  :: forall dom r+   . HiddenClockResetEnable dom+  => (KnownDomain dom => Clock dom -> Reset dom -> Enable dom -> r)+  -- ^ Component whose clock, reset, and enable argument you want to hide+  -> r+hideClockResetEnable =+  \f ->+    f+      (fromLabel @(HiddenClockName dom))+      (fromLabel @(HiddenResetName dom))+      (fromLabel @(HiddenEnableName dom))+{-# INLINE hideClockResetEnable #-}++{- | Connect an explicit 'Clock', 'Reset', and 'Enable' to a function with a+hidden 'Clock', 'Reset', and 'Enable'.++<Clash-Signal.html#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables>++=== __Example__+Usage with a /polymorphic/ domain:++>>> reg = register 5 (reg + 1)+>>> sig = withClockResetEnable clockGen resetGen enableGen reg+>>> sampleN @System 10 sig+[5,5,6,7,8,9,10,11,12,13]++Force 'withClockResetEnable' to work on 'System' (hence 'sampleN' not needing+an explicit domain later):++>>> reg = register 5 (reg + 1)+>>> sig = withClockResetEnable @System clockGen resetGen enableGen reg+>>> sampleN 10 sig+[5,5,6,7,8,9,10,11,12,13]+-}+withClockResetEnable+  :: forall dom r+   . KnownDomain dom+  => Clock dom+  -- ^ The 'Clock' we want to connect+  -> Reset dom+  -- ^ The 'Reset' we want to connect+  -> Enable dom+  -- ^ The 'Enable' we want to connect+  -> (HiddenClockResetEnable dom => r)+  -- ^ The function with a hidden 'Clock', hidden 'Reset', and hidden+  -- 'Enable' argument+  -> r+withClockResetEnable =+  \clk rst en f -> withClock clk (withReset rst (withEnable en f))+{-# INLINE withClockResetEnable #-}++-- * Basic circuit functions++-- | Special version of 'delay' that doesn't take enable signals of any kind.+-- Initial value will be undefined.+dflipflop+  :: forall dom a+   . ( HiddenClock dom+     , NFDataX a )+  => Signal dom a+  -> Signal dom a+dflipflop =+  E.dflipflop (fromLabel @(HiddenClockName dom))+{-# INLINE dflipflop #-}++-- | 'delay' @dflt@ @s@ delays the values in 'Signal' @s@ for once cycle, the+-- value at time 0 is /dflt/.+--+-- >>> sampleN @System 3 (delay 0 (fromList [1,2,3,4]))+-- [0,1,2]+delay+  :: forall dom a+   . ( NFDataX a+     , HiddenClock dom+     , HiddenEnable dom  )+  => a+  -- ^ Initial value+  -> Signal dom a+  -- ^ Signal to delay+  -> Signal dom a+delay = \dflt i ->+  delay#+    (fromLabel @(HiddenClockName dom))+    (fromLabel @(HiddenEnableName dom))+    dflt+    i+{-# INLINE delay #-}++-- | Version of 'delay' that only updates when its second argument is a 'Just'+-- value.+--+-- >>> let input = fromList [Just 1, Just 2, Nothing, Nothing, Just 5, Just 6, Just (7::Int)]+-- >>> sampleN @System 7 (delayMaybe 0 input)+-- [0,1,2,2,2,5,6]+delayMaybe+  :: forall dom a+   . ( NFDataX a+     , HiddenClock dom+     , HiddenEnable dom  )+  => a+  -- ^ Initial value+  -> Signal dom (Maybe a)+  -> Signal dom a+delayMaybe = \dflt i ->+  E.delayMaybe+    (fromLabel @(HiddenClockName dom))+    (fromLabel @(HiddenEnableName dom))+    dflt+    i+{-# INLINE delayMaybe #-}++-- | Version of 'delay' that only updates when its second argument is asserted.+--+-- >>> let input = fromList [1,2,3,4,5,6,7::Int]+-- >>> let enable = fromList [True,True,False,False,True,True,True]+-- >>> sampleN @System 7 (delayEn 0 enable input)+-- [0,1,2,2,2,5,6]+delayEn+  :: forall dom a+   . ( NFDataX a+     , HiddenClock dom+     , HiddenEnable dom  )+  => a+  -- ^ Initial value+  -> Signal dom Bool+  -- ^ Enable+  -> Signal dom a+  -> Signal dom a+delayEn = \dflt en i ->+  E.delayEn+    (fromLabel @(HiddenClockName dom))+    (fromLabel @(HiddenEnableName dom))+    dflt+    en+    i+{-# INLINE delayEn #-}++-- | 'register' @i s@ delays the values in 'Signal' @s@ for one cycle, and sets+-- the value at time 0 to @i@+--+-- >>> sampleN @System 5 (register 8 (fromList [1,1,2,3,4]))+-- [8,8,1,2,3]+register+  :: forall dom a+   . ( HiddenClockResetEnable dom+     , NFDataX a )+  => a+  -- ^ Reset value. 'register' outputs the reset value when the reset is active.+  -- If the domain has initial values enabled, the reset value will also be the+  -- initial value.+  -> Signal dom a+  -> Signal dom a+register = \i s ->+  E.register+    (fromLabel @(HiddenClockName dom))+    (fromLabel @(HiddenResetName dom))+    (fromLabel @(HiddenEnableName dom))+    i+    s+{-# INLINE register #-}+infixr 3 `register`++-- | Version of 'register' that only updates its content when its second+-- argument is a 'Just' value. So given:+--+-- @+-- sometimes1 = s where+--   s = 'register' Nothing (switch '<$>' s)+--+--   switch Nothing = Just 1+--   switch _       = Nothing+--+-- countSometimes = s where+--   s     = 'regMaybe' 0 (plusM ('pure' '<$>' s) sometimes1)+--   plusM = 'Control.Applicative.liftA2' (liftA2 (+))+-- @+--+-- We get:+--+-- >>> sampleN @System 9 sometimes1+-- [Nothing,Nothing,Just 1,Nothing,Just 1,Nothing,Just 1,Nothing,Just 1]+-- >>> sampleN @System 9 countSometimes+-- [0,0,0,1,1,2,2,3,3]+regMaybe+  :: forall dom a+   . ( HiddenClockResetEnable dom+     , NFDataX a )+  => a+  -- ^ Reset value. 'regMaybe' outputs the reset value when the reset is active.+  -- If the domain has initial values enabled, the reset value will also be the+  -- initial value.+  -> Signal dom (Maybe a)+  -> Signal dom a+regMaybe = \initial iM ->+  E.regMaybe+    (fromLabel @(HiddenClockName dom))+    (fromLabel @(HiddenResetName dom))+    (fromLabel @(HiddenEnableName dom))+    initial+    iM+{-# INLINE regMaybe #-}+infixr 3 `regMaybe`++-- | Version of 'register' that only updates its content when its second argument+-- is asserted. So given:+--+-- @+-- oscillate = 'register' False ('not' '<$>' oscillate)+-- count     = 'regEn' 0 oscillate (count + 1)+-- @+--+-- We get:+--+-- >>> sampleN @System 9 oscillate+-- [False,False,True,False,True,False,True,False,True]+-- >>> sampleN @System 9 count+-- [0,0,0,1,1,2,2,3,3]+regEn+  :: forall dom a+   . ( HiddenClockResetEnable dom+     , NFDataX a )+  => a+  -- ^ Reset value. 'regEn' outputs the reset value when the reset is active.+  -- If the domain has initial values enabled, the reset value will also be the+  -- initial value.+  -> Signal dom Bool+  -> Signal dom a+  -> Signal dom a+regEn = \initial en i ->+  E.regEn+    (fromLabel @(HiddenClockName dom))+    (fromLabel @(HiddenResetName dom))+    (fromLabel @(HiddenEnableName dom))+    initial+    en+    i+{-# INLINE regEn #-}++-- | A chain of 'regEn's.+regEnN ::+  forall dom a n.+  (HiddenClockResetEnable dom, NFDataX a) =>+  -- | The number of stored elements+  SNat n ->+  -- | Initial content of all elements in the chain.+  a ->+  -- | The "push next input" indicator+  Signal dom Bool ->+  Signal dom a ->+  Signal dom a+regEnN = \sn initial en i ->+  E.regEnN+    (fromLabel @(HiddenClockName dom))+    (fromLabel @(HiddenResetName dom))+    (fromLabel @(HiddenEnableName dom))+    sn+    initial+    en+    i+{-# INLINE regEnN #-}++-- * Signal -> List conversion++-- | Get an infinite list of samples from a 'Signal'+--+-- The elements in the list correspond to the values of the 'Signal'+-- at consecutive clock cycles+--+-- > sample s == [s0, s1, s2, s3, ...+--+-- If the given component has not yet been given a clock, reset, or enable+-- line, 'sample' will supply them. The reset will be asserted for a single+-- cycle. 'sample' will not drop the value produced by the circuit while+-- the reset was asserted. If you want this, or if you want more than a+-- single cycle reset, consider using 'sampleWithReset'.+--+-- __NB__: This function is not synthesizable+sample+  :: forall dom a+   . ( KnownDomain dom+     , NFDataX a )+  => (HiddenClockResetEnable dom  => Signal dom a)+  -- ^ 'Signal' we want to sample, whose source potentially has a hidden clock+  -- (and reset)+  -> [a]+sample s =+  E.sample (exposeClockResetEnable @dom s clockGen resetGen enableGen)+{-# OPAQUE sample #-}++-- | Get a list of /n/ samples from a 'Signal'+--+-- The elements in the list correspond to the values of the 'Signal'+-- at consecutive clock cycles+--+-- > sampleN @System 3 s == [s0, s1, s2]+--+-- If the given component has not yet been given a clock, reset, or enable+-- line, 'sampleN' will supply them. The reset will be asserted for a single+-- cycle. 'sampleN' will not drop the value produced by the circuit while+-- the reset was asserted. If you want this, or if you want more than a+-- single cycle reset, consider using 'sampleWithResetN'.+--+-- __NB__: This function is not synthesizable+sampleN+  :: forall dom a+   . ( KnownDomain dom+     , NFDataX a )+  => Int+  -- ^ Number of samples to produce+  -> (HiddenClockResetEnable dom => Signal dom a)+  -- ^ 'Signal' to sample, whose source potentially has a hidden clock+  -- (and reset)+  -> [a]+sampleN n s0 =+  let s1 = exposeClockResetEnable @dom s0 clockGen resetGen enableGen in+  E.sampleN n s1+{-# OPAQUE sampleN #-}++-- | Get an infinite list of samples from a 'Signal', while asserting the reset+-- line for /m/ clock cycles. 'sampleWithReset' does not return the first /m/+-- cycles, i.e., when the reset is asserted.+--+-- __NB__: This function is not synthesizable+sampleWithReset+  :: forall dom a m+   . ( KnownDomain dom+     , NFDataX a+     , 1 <= m )+  => SNat m+  -- ^ Number of cycles to assert the reset+  -> (HiddenClockResetEnable dom => Signal dom a)+  -- ^ 'Signal' to sample, whose source potentially has a hidden clock+  -- (and reset)+  -> [a]+sampleWithReset nReset f0 =+  let f1 = exposeClockResetEnable f0 clockGen (resetGenN @dom nReset) enableGen in+  drop (snatToNum nReset) (E.sample f1)+{-# OPAQUE sampleWithReset #-}++-- | Get a list of /n/ samples from a 'Signal', while asserting the reset line+-- for /m/ clock cycles. 'sampleWithReset' does not return the first /m/ cycles,+-- i.e., while the reset is asserted.+--+-- __NB__: This function is not synthesizable+sampleWithResetN+  :: forall dom a m+   . ( KnownDomain dom+     , NFDataX a+     , 1 <= m )+  => SNat m+  -- ^ Number of cycles to assert the reset+  -> Int+  -- ^ Number of samples to produce+  -> (HiddenClockResetEnable dom => Signal dom a)+  -- ^ 'Signal' to sample, whose source potentially has a hidden clock+  -- (and reset)+  -> [a]+sampleWithResetN nReset nSamples f =+  take nSamples (sampleWithReset nReset f)++-- | /Lazily/ get an infinite list of samples from a 'Signal'+--+-- The elements in the list correspond to the values of the 'Signal'+-- at consecutive clock cycles+--+-- > sample s == [s0, s1, s2, s3, ...+--+-- If the given component has not yet been given a clock, reset, or enable+-- line, 'sample_lazy' will supply them. The reset will be asserted for a+-- single cycle. 'sample_lazy' will not drop the value produced by the+-- circuit while the reset was asserted.+--+-- __NB__: This function is not synthesizable+sample_lazy+  :: forall dom a+   . KnownDomain dom+  => (HiddenClockResetEnable dom  => Signal dom a)+  -- ^ 'Signal' we want to sample, whose source potentially has a hidden clock+  -- (and reset)+  -> [a]+sample_lazy s =+  E.sample_lazy (exposeClockResetEnable @dom s clockGen resetGen enableGen)+{-# OPAQUE sample_lazy #-}++-- | Lazily get a list of /n/ samples from a 'Signal'+--+-- The elements in the list correspond to the values of the 'Signal'+-- at consecutive clock cycles+--+-- > sampleN @System 3 s == [s0, s1, s2]+--+-- If the given component has not yet been given a clock, reset, or enable+-- line, 'sampleN_lazy' will supply them. The reset will be asserted for a+-- single cycle. 'sampleN_lazy' will not drop the value produced by the+-- circuit while the reset was asserted.+--+-- __NB__: This function is not synthesizable+sampleN_lazy+  :: forall dom a+   . KnownDomain dom+  => Int+  -> (HiddenClockResetEnable dom  => Signal dom a)+  -- ^ 'Signal' we want to sample, whose source potentially has a hidden clock+  -- (and reset)+  -> [a]+sampleN_lazy n s =+  E.sampleN_lazy n (exposeClockResetEnable @dom s clockGen resetGen enableGen)+{-# OPAQUE sampleN_lazy #-}++-- * Simulation functions++-- | Simulate a (@'Signal' a -> 'Signal' b@) function given a list of samples+-- of type /a/+--+-- >>> simulate @System (register 8) [1, 2, 3]+-- [8,1,2,3...+-- ...+--+-- Where 'System' denotes the /domain/ to simulate on. The reset line is+-- asserted for a single cycle. The first value is therefore supplied twice to+-- the circuit: once while reset is high, and once directly after. The first+-- /output/ value (the value produced while the reset is asserted) is dropped.+--+-- If you only want to simulate a finite number of samples, see 'simulateN'. If+-- you need the reset line to be asserted for more than one cycle or if you+-- need a custom reset value, see 'simulateWithReset' and 'simulateWithResetN'.+--+-- __NB__: This function is not synthesizable+simulate+  :: forall dom a b+   . ( KnownDomain dom+     , NFDataX a+     , NFDataX b )+  => (HiddenClockResetEnable dom => Signal dom a -> Signal dom b)+  -- ^ Circuit to simulate, whose source potentially has a hidden clock, reset,+  -- and/or enable.+  -> [a]+  -> [b]+simulate f as = simulateWithReset (SNat @1) rval f as+  where+    rval = maybe (error "simulate: no stimuli") fst (uncons as)+{-# INLINE simulate #-}++-- | Same as 'simulate', but only sample the first /Int/ output values.+--+-- __NB__: This function is not synthesizable+simulateN+  :: forall dom a b+   . ( KnownDomain dom+     , NFDataX a+     , NFDataX b )+  => Int+  -- ^ Number of cycles to simulate (excluding cycle spent in reset)+  -> (HiddenClockResetEnable dom => Signal dom a -> Signal dom b)+  -- ^ 'Signal' we want to sample, whose source potentially has a hidden clock+  -- (and reset)+  -> [a]+  -> [b]+simulateN n f as = simulateWithResetN (SNat @1) rval n f as+  where+    rval = maybe (error "simulate: no stimuli") fst (uncons as)+{-# INLINE simulateN #-}++-- | Same as 'simulate', but with the reset line asserted for /n/ cycles. Similar+-- to 'simulate', 'simulateWithReset' will drop the output values produced while+-- the reset is asserted. While the reset is asserted, the reset value /a/ is+-- supplied to the circuit.+simulateWithReset+  :: forall dom a b m+   . ( KnownDomain dom+     , NFDataX a+     , NFDataX b+     , 1 <= m )+  => SNat m+  -- ^ Number of cycles to assert the reset+  -> a+  -- ^ Reset value+  -> (HiddenClockResetEnable dom => Signal dom a -> Signal dom b)+  -- ^ 'Signal' we want to sample, whose source potentially has a hidden clock+  -- (and reset)+  -> [a]+  -> [b]+simulateWithReset n resetVal f as =+  E.simulateWithReset n resetVal (exposeClockResetEnable f) as+{-# INLINE simulateWithReset #-}++-- | Same as 'simulateWithReset', but only sample the first /Int/ output values.+simulateWithResetN+  :: forall dom a b m+   . ( KnownDomain dom+     , NFDataX a+     , NFDataX b+     , 1 <= m )+  => SNat m+  -- ^ Number of cycles to assert the reset+  -> a+  -- ^ Reset value+  -> Int+  -- ^ Number of cycles to simulate (excluding cycles spent in reset)+  -> (HiddenClockResetEnable dom => Signal dom a -> Signal dom b)+  -- ^ 'Signal' we want to sample, whose source potentially has a hidden clock+  -- (and reset)+  -> [a]+  -> [b]+simulateWithResetN nReset resetVal nSamples f as =+  E.simulateWithResetN nReset resetVal nSamples (exposeClockResetEnable f) as+{-# INLINE simulateWithResetN #-}+++-- | /Lazily/ simulate a (@'Signal' a -> 'Signal' b@) function given a list of+-- samples of type /a/+--+-- >>> simulate @System (register 8) [1, 2, 3]+-- [8,1,2,3...+-- ...+--+-- __NB__: This function is not synthesizable+simulate_lazy+  :: forall dom a b+   . KnownDomain dom+  => (HiddenClockResetEnable dom  =>+      Signal dom a -> Signal dom b)+  -- ^ Function we want to simulate, whose components potentially have a hidden+  -- clock (and reset)+  -> [a]+  -> [b]+simulate_lazy f0 =+  let f1 = exposeClockResetEnable @dom f0 clockGen resetGen enableGen in+  drop 1 . E.simulate_lazy f1 . dup1+{-# OPAQUE simulate_lazy #-}++-- | Simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a list of+-- samples of type @a@+--+-- >>> simulateB @System (unbundle . register (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)]+-- [(8,8),(1,1),(2,2),(3,3)...+-- ...+--+-- __NB__: This function is not synthesizable+simulateB+  :: forall dom a b+   . ( KnownDomain dom+     , Bundle a+     , Bundle b+     , NFDataX a+     , NFDataX b+     )+  => (HiddenClockResetEnable dom  =>+      Unbundled dom a -> Unbundled dom b)+  -- ^ Function we want to simulate, whose components potentially have a hidden+  -- clock (and reset)+  -> [a]+  -> [b]+simulateB f0 =+  drop 1 . E.simulateB f1 . dup1+ where+  f1 =+    withClockResetEnable+      clockGen+      resetGen+      enableGen+      (const f0)+      (Proxy @dom)+{-# OPAQUE simulateB #-}++-- | /Lazily/ simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a+-- list of samples of type @a@+--+-- >>> simulateB @System (unbundle . register (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)]+-- [(8,8),(1,1),(2,2),(3,3)...+-- ...+--+-- __NB__: This function is not synthesizable+simulateB_lazy+  :: forall dom a b+   . ( KnownDomain dom+     , Bundle a+     , Bundle b )+  => (HiddenClockResetEnable dom  =>+      Unbundled dom a -> Unbundled dom b)+  -- ^ Function we want to simulate, whose components potentially have a hidden+  -- clock (and reset)+  -> [a]+  -> [b]+simulateB_lazy f0 =+  drop 1 . E.simulateB_lazy f1 . dup1+ where+  f1 =+    withClockResetEnable+      clockGen+      resetGen+      enableGen+      (const f0)+      (Proxy @dom)+{-# OPAQUE simulateB_lazy #-}++dup1 :: [a] -> [a]+dup1 (x:xs) = x:x:xs+dup1 _      = error "empty list"+++-- | Simulate a component until it matches a condition+--+-- If the given component has not yet been given a clock, reset, or enable+-- line, 'runUntil' will supply them. The reset will be asserted for a single+-- cycle.+--+-- It prints a message of the form+--+-- > Signal sampled for N cycles until value X+--+-- __NB__: This function is not synthesizable+--+-- === __Example with test bench__+--+-- A common usage is with a test bench using+-- 'Clash.Explicit.Testbench.outputVerifier'.+--+-- __NB__: Since this uses 'Clash.Explicit.Testbench.assert', when using+-- @clashi@, read the note at "Clash.Explicit.Testbench#assert-clashi".+--+-- @+-- import Clash.Prelude+-- import Clash.Explicit.Testbench+--+-- topEntity+--   :: 'Signal' 'System' Int+--   -> 'Signal' 'System' Int+-- topEntity = id+--+-- testBench+--   :: 'Signal' 'System' Bool+-- testBench = done+--  where+--   testInput = 'Clash.Explicit.Testbench.stimuliGenerator' clk rst $('Clash.Sized.Vector.listToVecTH' [1 :: Int .. 10])+--   expectedOutput =+--     'Clash.Explicit.Testbench.outputVerifier'' clk rst $('Clash.Sized.Vector.listToVecTH' $ [1 :: Int .. 9] '<>' [42])+--   done = expectedOutput $ topEntity testInput+--   clk = 'Clash.Explicit.Testbench.tbSystemClockGen' (not \<$\> done)+--   rst = 'systemResetGen'+-- @+--+-- @+-- > runUntil id testBench+--+--+-- cycle(\<Clock: System\>): 10, outputVerifier+-- expected value: 42, not equal to actual value: 10+-- Signal sampled for 11 cycles until value True+-- @+--+-- When you need to verify multiple test benches, the following invocations come+-- in handy:+--+-- @+-- > 'mapM_' (runUntil id) [ testBenchA, testBenchB ]+-- @+--+-- or when the test benches are in different clock domains:+--+-- @+-- testBenchA :: Signal DomA Bool+-- testBenchB :: Signal DomB Bool+-- @+--+-- @+-- > 'sequence_' [ runUntil id testBenchA, runUntil id testBenchB ]+-- @+runUntil+  :: forall dom a+   . (KnownDomain dom, NFDataX a, ShowX a)+  => (a -> Bool)+  -- ^ Condition checking function, should return @True@ to finish run+  -> (HiddenClockResetEnable dom => Signal dom a)+  -- ^ 'Signal' we want to sample for the condition, potentially having a+  -- hidden clock, reset and/or enable+  -> IO ()+runUntil check s =+  E.runUntil check $ exposeClockResetEnable @dom s clockGen resetGen enableGen++-- * QuickCheck combinators++-- |  @testFor n s@ tests the signal /s/ for /n/ cycles.+--+-- __NB__: This function is not synthesizable+testFor+  :: KnownDomain dom+  => Int+  -- ^ The number of cycles we want to test for+  -> (HiddenClockResetEnable dom  => Signal dom Bool)+  -- ^ 'Signal' we want to evaluate, whose source potentially has a hidden clock+  -- (and reset)+  -> Property+testFor n s = property (and (Clash.Signal.sampleN n s))+++-- | Register a synchronous reset signal.+--+--   `registerSyncReset` delays an incoming reset by one clock cycle using a+--   register. This can be useful to break combinational paths involving reset+--   logic.+--+--   __NB__: This is not a synchronizer. Use `resetSynchronizer` to synchronize+--   a reset.+--+--   Example:+--+-- >>> registerSyncResetBool = unsafeToActiveHigh . (registerSyncReset @XilinxSystem)+-- >>> let rst = unsafeFromActiveHigh (fromList [False, True, False, False, True, False])+-- >>> sampleN 7 (exposeReset (registerSyncResetBool True) rst)+-- [True,False,True,False,False,True,False]+--+registerSyncReset+  :: forall dom+   . HiddenClockResetEnable dom+  => KnownDomain dom+  => DomainResetKind dom ~ 'Synchronous+  => Bool+  -- ^ Initial assert value of the register if supported by the domain.+  --   If True the initial reset value is asserted.+  --   If False the initial reset value is de-asserted.+  -> Reset dom+registerSyncReset initialValue = hideClockResetEnable E.registerSyncReset initialValue++-- | Hold reset for a number of cycles relative to an incoming reset+-- signal.+--+-- __NB__: The output of this function is combinational for @n > 1@ on domains+-- with a synchronous reset. Use `registerSyncReset` to add an output register if+-- desired.+--+-- Example:+--+-- >>> holdResetBool = unsafeToActiveHigh . (holdReset @System)+-- >>> sampleN 8 (exposeReset (holdResetBool (SNat @2)) (resetGenN (SNat @3)))+-- [True,True,True,True,True,False,False,False]+--+-- 'holdReset' holds the reset for an additional 2 clock cycles for a total+-- of 5 clock cycles where the reset is asserted. 'holdReset' also works on+-- intermediate assertions of the reset signal:+--+-- >>> let rst = fromList [True, False, False, False, True, False, False, False]+-- >>> sampleN 8 (exposeReset (holdResetBool (SNat @2)) (unsafeFromActiveHigh rst))+-- [True,True,True,False,True,True,True,False]+--+holdReset+  :: forall dom m+   . HiddenClockResetEnable dom+  => SNat m+  -- ^ Hold for /m/ cycles+  -> Reset dom+holdReset m =+  hideClockResetEnable (\clk rst en -> E.holdReset clk en m rst)++-- | Like 'fromList', but resets on reset and has a defined reset value.+--+-- >>> let rst = unsafeFromActiveHigh (fromList [True, True, False, False, True, False])+-- >>> let res = withReset rst (fromListWithReset Nothing [Just 'a', Just 'b', Just 'c'])+-- >>> sampleN @System 6 res+-- [Nothing,Nothing,Just 'a',Just 'b',Nothing,Just 'a']+--+-- __NB__: This function is not synthesizable+fromListWithReset+  :: forall dom a+   . (HiddenReset dom, NFDataX a)+  => a+  -> [a]+  -> Signal dom a+fromListWithReset = hideReset E.fromListWithReset+{-# INLINE fromListWithReset #-}++-- | Build an 'Automaton' from a function over 'Signal's.+--+-- __NB__: Consumption of continuation of the 'Automaton' must be affine; that+-- is, you can only apply the continuation associated with a particular element+-- at most once.+signalAutomaton+  :: forall dom a b+   . KnownDomain dom+  => (HiddenClockResetEnable dom => Signal dom a -> Signal dom b)+  -> Automaton (->) a b+signalAutomaton f0 =+  let f1 = exposeClockResetEnable @dom f0 clockGen resetGen enableGen in+  E.signalAutomaton f1+{-# OPAQUE signalAutomaton #-}
src/Clash/Signal/BiSignal.hs view
@@ -1,15 +1,16 @@ {-| Copyright  :  (C) 2017, Google Inc.                   2019, Myrtle Software Ltd+                  2022-2024, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  Wires are fundamentally bidirectional, and in traditional HDLs we can exploit this aspect by explicitly marking the endpoint, or port, of such a wire as /inout/, thereby making this port function as both a source and a drain for the signals flowing over the wire. -Clash has support for 'inout' ports through the implementation of /BiSignal/s.+Clash has support for @inout@ ports through the implementation of /BiSignal/s. To cleanly map to functions (and thus support software simulation using Haskell), a /BiSignal/ comes in two parts; the __in__ part: @@ -32,7 +33,7 @@   * Lastly, /ds/ indicates the default behavior for the BiSignal if nothing is     being written (pull-down, pull-up, or undefined). -'BiSignalIn' is used by Clash to generate the 'inout' ports on a HDL level,+'BiSignalIn' is used by Clash to generate the @inout@ ports on a HDL level, while 'BiSignalOut' is only used for simulation purposes and generally discarded by the compiler. @@ -43,7 +44,10 @@ cycle.  @--- | Alternatively read / increment+write+import Clash.Explicit.Prelude+import Clash.Signal.BiSignal++-- | Alternatingly read / increment+write counter   :: (Bool, Int)   -- ^ Internal flip + previous read@@ -59,55 +63,56 @@ -- | Write on odd cyles f :: Clock System   -> Reset System-  -> BiSignalIn  Floating System (BitSize Int)-  -> BiSignalOut Floating System (BitSize Int)-f clk rst s = writeToBiSignal s (mealy clk rst counter (False, 0) (readFromBiSignal s))+  -> Enable System+  -> BiSignalIn  'Floating System (BitSize Int)+  -> BiSignalOut 'Floating System (BitSize Int)+f clk rst en s = writeToBiSignal s (mealy clk rst en counter (False, 0) (readFromBiSignal s))  -- | Write on even cyles g :: Clock System   -> Reset System-  -> BiSignalIn  Floating System (BitSize Int)-  -> BiSignalOut Floating System (BitSize Int)-g clk rst s = writeToBiSignal s (mealy clk rst counter (True, 0) (readFromBiSignal s))+  -> Enable System+  -> BiSignalIn  'Floating System (BitSize Int)+  -> BiSignalOut 'Floating System (BitSize Int)+g clk rst en s = writeToBiSignal s (mealy clk rst en counter (True, 0) (readFromBiSignal s))  --- | Connect the /f/ and /g/ circuits to the same bus+-- | Connect the \/f\/ and \/g\/ circuits to the same bus topEntity   :: Clock System   -> Reset System+  -> Enable System   -> Signal System Int-topEntity clk rst = readFromBiSignal bus'+topEntity clk rst en = readFromBiSignal bus'   where-    bus  = mergeBiSignalOuts $ f clk rst bus' :> g clk rst bus' :> Nil+    bus  = mergeBiSignalOuts $ f clk rst en bus' :> g clk rst en bus' :> Nil     bus' = veryUnsafeToBiSignalIn bus @ -} -{-# LANGUAGE CPP                    #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE InstanceSigs           #-}-{-# LANGUAGE KindSignatures         #-}-{-# LANGUAGE MagicHash              #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}-#if __GLASGOW_HASKELL__ < 806-{-# LANGUAGE TypeInType #-}-#endif+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  {-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-} {-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-} {-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-} +-- TryDomain / HasDomain instances+{-# OPTIONS_GHC -Wno-deprecations #-}+ module Clash.Signal.BiSignal (     BiSignalIn()   , BiSignalOut()   , BiSignalDefault(..)+  , SBiSignalDefault(..)+  , HasBiSignalDefault(..)   , mergeBiSignalOuts   , readFromBiSignal   , writeToBiSignal@@ -116,21 +121,23 @@  import           Data.Kind                  (Type) import           Data.List                  (intercalate)-import           Data.Maybe                 (fromMaybe,fromJust,isJust)+import           Data.Maybe                 (fromMaybe,isJust) +import           Clash.Annotations.Primitive (hasBlackBox)+import           Clash.Class.HasDomain import           Clash.Class.BitPack        (BitPack (..)) import           Clash.Sized.BitVector      (BitVector) import qualified Clash.Sized.Vector         as V import           Clash.Sized.Vector         (Vec) import           Clash.Signal.Internal      (Signal(..), Domain, head#, tail#)-import           Clash.XException           (errorX)+import           Clash.XException           (errorX, fromJustX, NFDataX)  import           GHC.TypeLits               (KnownNat, Nat) import           GHC.Stack                  (HasCallStack) import           Data.Reflection            (Given (..)) --- | Used to specify the /default/ behavior of a 'BiSignal', i.e. what value is--- read when no value is being written to it.+-- | Used to specify the /default/ behavior of a \"BiSignal\" in Haskell simulation, i.e.+-- what value is read when no value is being written to it. data BiSignalDefault   = PullUp   -- ^ __inout__ port behaves as if connected to a pull-up resistor@@ -138,7 +145,7 @@   -- ^ __inout__ port behaves as if connected to a pull-down resistor   | Floating   -- ^ __inout__ port behaves as if is /floating/. Reading a /floating/-  -- 'BiSignal' value in simulation will yield an errorX (undefined value).+  -- \"BiSignal\" value in simulation will yield an errorX (undefined value).   deriving (Show)  -- | Singleton versions of 'BiSignalDefault'@@ -156,30 +163,64 @@ instance Given (SBiSignalDefault 'Floating) where   given = SFloating --- | The /in/ part of an __inout__ port+-- | Type class for 'BiSignalDefault':+--   can be used as a constraint and for obtaining the pull-up mode+class HasBiSignalDefault (ds :: BiSignalDefault) where+  pullUpMode :: BiSignalIn ds dom n -> SBiSignalDefault ds++instance HasBiSignalDefault 'PullUp where+  pullUpMode _ = SPullUp++instance HasBiSignalDefault 'PullDown where+  pullUpMode _ = SPullDown++instance HasBiSignalDefault 'Floating where+  pullUpMode _ = SFloating++type role BiSignalIn nominal nominal nominal++-- | The /in/ part of an __inout__ port.+-- BiSignalIn has the <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html type role>+--+-- >>> :i BiSignalIn+-- type role BiSignalIn nominal nominal nominal+-- ...+--+-- as it is not safe to coerce the default behaviour, synthesis domain or width+-- of the data in the signal. data BiSignalIn (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat)   = BiSignalIn (SBiSignalDefault ds) (Signal dom (Maybe (BitVector n))) +type role BiSignalOut nominal nominal nominal+ -- | The /out/ part of an __inout__ port -- -- Wraps (multiple) writing signals. The semantics are such that only one of -- the signals may write at a single time step.-newtype BiSignalOut (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat)-  = BiSignalOut [Signal dom (Maybe (BitVector n))]+--+-- BiSignalOut has the <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html type role>+--+-- >>> :i BiSignalOut+-- type role BiSignalOut nominal nominal nominal+-- ...+--+-- as it is not safe to coerce the default behaviour, synthesis domain or width+-- of the data in the signal.+data BiSignalOut (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat)+  = BiSignalOut ![Signal dom (Maybe (BitVector n))] -#if MIN_VERSION_base(4,11,0)+type instance HasDomain dom1 (BiSignalOut ds dom2 n) = DomEq dom1 dom2+type instance TryDomain t (BiSignalOut ds dom n) = 'Found dom++-- | __NB__: Not synthesizable instance Semigroup (BiSignalOut defaultState dom n) where   (BiSignalOut b1) <> (BiSignalOut b2) = BiSignalOut (b1 ++ b2)-#endif  -- | Monoid instance to support concatenating ----- __NB__ Not synthesizable+-- __NB__: Not synthesizable instance Monoid (BiSignalOut defaultState dom n) where-  mempty                                    = BiSignalOut []-#if !MIN_VERSION_base(4,11,0)-  mappend (BiSignalOut b1) (BiSignalOut b2) = BiSignalOut $ b1 ++ b2-#endif+  mempty = BiSignalOut []  -- /Lazily/ prepend a value to a 'BiSignalIn'. --@@ -202,12 +243,12 @@     SFloating -> fromMaybe (errorX " undefined value on BiSignalIn") <$> s     SPullDown  -> fromMaybe minBound <$> s     SPullUp    -> fromMaybe maxBound <$> s-{-# NOINLINE readFromBiSignal# #-}+{-# OPAQUE readFromBiSignal# #-}+{-# ANN readFromBiSignal# hasBlackBox #-}  -- | Read the value from an __inout__ port readFromBiSignal   :: ( HasCallStack-     , KnownNat (BitSize a)      , BitPack a)   => BiSignalIn ds d (BitSize a)   -- ^ A 'BiSignalIn' with a number of bits needed to represent /a/@@ -222,7 +263,8 @@   => Vec n (BiSignalOut defaultState dom m)   -> BiSignalOut defaultState dom m mergeBiSignalOuts = mconcat . V.toList-{-# NOINLINE mergeBiSignalOuts #-}+{-# OPAQUE mergeBiSignalOuts #-}+{-# ANN mergeBiSignalOuts hasBlackBox #-}  writeToBiSignal#   :: HasCallStack@@ -231,13 +273,13 @@   -> Signal d Bool   -> Signal d (BitVector n)   -> BiSignalOut ds d n--- writeToBiSignal# = writeToBiSignal#-writeToBiSignal# _ maybeSignal _ _ = BiSignalOut [maybeSignal]-{-# NOINLINE writeToBiSignal# #-}+writeToBiSignal# bIn maybeSignal wEn val = BiSignalOut [bIn `seq` wEn `seq` val `seq` maybeSignal]+{-# OPAQUE writeToBiSignal# #-}+{-# ANN writeToBiSignal# hasBlackBox #-}  -- | Write to an __inout__ port writeToBiSignal-  :: (HasCallStack, BitPack a)+  :: (HasCallStack, BitPack a, NFDataX a)   => BiSignalIn ds d (BitSize a)   -> Signal d (Maybe a)   -- ^ Value to write@@ -250,10 +292,10 @@     input     (fmap pack <$> writes)     (isJust <$> writes)-    (pack . fromJust <$> writes)+    (pack . fromJustX <$> writes) {-# INLINE writeToBiSignal #-} --- | Converts the 'out' part of a BiSignal to an 'in' part. In simulation it+-- | Converts the @out@ part of a BiSignal to an @in@ part. In simulation it -- checks whether multiple components are writing and will error accordingly. -- Make sure this is only called ONCE for every BiSignal. veryUnsafeToBiSignalIn@@ -279,4 +321,5 @@      -- Recursive step     biSignalOut' = veryUnsafeToBiSignalIn $ BiSignalOut $ map tail# signals-{-# NOINLINE veryUnsafeToBiSignalIn #-}+{-# OPAQUE veryUnsafeToBiSignalIn #-}+{-# ANN veryUnsafeToBiSignalIn hasBlackBox #-}
src/Clash/Signal/Bundle.hs view
@@ -1,37 +1,38 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2017-2019, Myrtle Software Ltd, Google Inc.+                  2019,2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  The Product/Signal isomorphism -} -{-# LANGUAGE CPP                    #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE DefaultSignatures      #-}-{-# LANGUAGE KindSignatures         #-}-{-# LANGUAGE MagicHash              #-}-{-# LANGUAGE TemplateHaskell        #-}-{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE TypeOperators          #-}-#if __GLASGOW_HASKELL__ < 806-{-# LANGUAGE TypeInType #-}-#endif  {-# LANGUAGE Trustworthy #-} +--{-# OPTIONS_GHC -ddump-splices #-} {-# OPTIONS_HADDOCK show-extensions #-}  module Clash.Signal.Bundle   ( Bundle (..)+  -- ** Tools to emulate pre Clash 1.0 @Bundle ()@ instance+  , EmptyTuple(..)+  , TaggedEmptyTuple(..)+  -- ** Internal+  , vecBundle#   ) where +import Data.Functor.Compose+import GHC.Generics import GHC.TypeLits                 (KnownNat) import Prelude                      hiding (head, map, tail) +import Clash.Annotations.Primitive (hasBlackBox) import Clash.Signal.Bundle.Internal (deriveBundleTuples) import Clash.Signal.Internal        (Signal (..), Domain) import Clash.Sized.BitVector        (Bit, BitVector)@@ -43,7 +44,7 @@ import Clash.Sized.RTree            (RTree, lazyT)  -- | Isomorphism between a 'Clash.Signal.Signal' of a product type (e.g. a tuple) and a--- product type of 'Clash.Signal.Signal''s.+-- product type of 'Clash.Signal.Signal's. -- -- Instances of 'Bundle' must satisfy the following laws: --@@ -67,11 +68,26 @@ -- data D = A | B -- -- instance Bundle D where---   type 'Unbundled'' clk D = 'Signal'' clk D---   'bundle'   _ s = s---   'unbundle' _ s = s+--   type 'Unbundled' clk D = 'Signal' clk D+--   'bundle'   s = s+--   'unbundle' s = s -- @ --+-- For custom product types you'll have to write the instance manually:+--+-- @+-- data Pair a b = MkPair { getA :: a, getB :: b }+--+-- instance Bundle (Pair a b) where+--   type Unbundled dom (Pair a b) = Pair (Signal dom a) (Signal dom b)+--+--   -- bundle :: Pair (Signal dom a) (Signal dom b) -> Signal dom (Pair a b)+--   bundle   (MkPair as bs) = MkPair '<$>' as '<*>' bs+--+--   -- unbundle :: Signal dom (Pair a b) -> Pair (Signal dom a) (Signal dom b)+--   unbundle pairs = MkPair (getA '<$>' pairs) (getB '<$>' pairs)+-- @+ class Bundle a where   type Unbundled (dom :: Domain) a = res | res -> dom a   type Unbundled dom a = Signal dom a@@ -126,6 +142,10 @@ instance Bundle (Signed n) instance Bundle (Unsigned n) +-- | __NB__: The documentation only shows instances up to /3/-tuples. By+-- default, instances up to and including /12/-tuples will exist. If the flag+-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The+-- GHC imposed limit is either 62 or 64 depending on the GHC version. deriveBundleTuples ''Bundle ''Unbundled 'bundle 'unbundle  instance KnownNat n => Bundle (Vec n a) where@@ -135,7 +155,8 @@   bundle   = vecBundle#   unbundle = sequenceA . fmap lazyV -{-# NOINLINE vecBundle# #-}+{-# OPAQUE vecBundle# #-}+{-# ANN vecBundle# hasBlackBox #-} vecBundle# :: Vec n (Signal t a) -> Signal t (Vec n a) vecBundle# = traverse# id @@ -143,3 +164,53 @@   type Unbundled t (RTree d a) = RTree d (Signal t a)   bundle   = sequenceA   unbundle = sequenceA . fmap lazyT++instance Bundle ((f :*: g) a) where+  type Unbundled t ((f :*: g) a) = (Compose (Signal t) f :*: Compose (Signal t) g) a+  bundle (Compose l :*: Compose r) = (:*:) <$> l <*> r+  unbundle s = Compose (getL <$> s) :*: Compose (getR <$> s)+   where+    getL (l :*: _) = l+    getR (_ :*: r) = r++-- | See 'TaggedEmptyTuple'+data EmptyTuple = EmptyTuple++-- | Helper type to emulate the "old" behavior of Bundle's unit instance. I.e.,+-- the instance for @Bundle ()@ used to be defined as:+--+-- @+-- class Bundle () where+--   bundle   :: () -> Signal dom ()+--   unbundle :: Signal dom () -> ()+-- @+--+-- In order to have sensible type inference, the 'Bundle' class specifies that+-- the argument type of 'bundle' should uniquely identify the result type, and+-- vice versa for 'unbundle'. The type signatures in the snippet above don't+-- though, as @()@ doesn't uniquely map to a specific domain. In other words,+-- @domain@ should occur in both the argument and result of both functions.+--+-- 'TaggedEmptyTuple' tackles this by carrying the domain in its type. The+-- 'bundle' and 'unbundle' instance now looks like:+--+-- @+-- class Bundle EmptyTuple where+--   bundle   :: TaggedEmptyTuple dom -> Signal dom EmptyTuple+--   unbundle :: Signal dom EmptyTuple -> TaggedEmptyTuple dom+-- @+--+-- @dom@ is now mentioned both the argument and result for both 'bundle' and+-- 'unbundle'.+data TaggedEmptyTuple (dom :: Domain) = TaggedEmptyTuple++-- | See [commit 94b0bff5](https://github.com/clash-lang/clash-compiler/pull/539/commits/94b0bff5770aa4961e04ddce2515130df3fc7863)+-- and documentation for 'TaggedEmptyTuple'.+instance Bundle EmptyTuple where+  type Unbundled dom EmptyTuple = TaggedEmptyTuple dom++  bundle :: TaggedEmptyTuple dom -> Signal dom EmptyTuple+  bundle TaggedEmptyTuple = pure EmptyTuple++  unbundle :: Signal dom EmptyTuple -> TaggedEmptyTuple dom+  unbundle s = seq s TaggedEmptyTuple
src/Clash/Signal/Bundle/Internal.hs view
@@ -1,14 +1,39 @@-{-# LANGUAGE CPP             #-}+{-|+Copyright  :  (C) 2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -module Clash.Signal.Bundle.Internal where+module Clash.Signal.Bundle.Internal (deriveBundleTuples, idPrimitive) where -import           Clash.CPP             (maxTupleSize)-import           Clash.Signal.Internal (Signal)-import           Control.Monad         (replicateM)-import           Data.List             (foldl')+import           Control.Monad.Extra         (concatMapM)+import           Clash.Annotations.Primitive (Primitive(InlineYamlPrimitive))+import           Clash.CPP                   (maxTupleSize)+import           Clash.Signal.Internal       (Signal((:-)))+import           Clash.XException            (seqX)+#if !MIN_VERSION_base(4,20,0)+import           Data.List                   (foldl')+#endif+import           Data.List                   (uncons)+import           Data.String.Interpolate     (__i)+import qualified Language.Haskell.TH.Syntax  as TH import           Language.Haskell.TH+import           Language.Haskell.TH.Compat +idPrimitive :: TH.Name -> DecQ+idPrimitive nm =+  PragmaD . AnnP (ValueAnnotation nm) <$> TH.liftData ip+ where+  ip = InlineYamlPrimitive [minBound..] [__i|+         Primitive:+           name: #{nm}+           primType: Function+         |]+ -- | Contruct all the tuple instances for Bundle. deriveBundleTuples   :: Name@@ -24,69 +49,122 @@   let bundleTy = ConT bundleTyName       signal   = ConT ''Signal -  allNames <- replicateM maxTupleSize (newName "a")-  tempNames <- replicateM maxTupleSize (newName "b")-  t <- newName "t"-  x <- newName "x"-  tup <- newName "tup"+      aNamesAll = map (\i -> mkName ('a':show i)) [1..maxTupleSize::Int]+      aPrimeNamesAll = map (\i -> mkName ('a':show i++"'")) [1..maxTupleSize::Int]+      asNamesAll = map (\i -> mkName ("as" <> show i)) [1..maxTupleSize::Int]+      tNm = mkName "t"+      sTailNm = mkName "sTail"+      sNm = mkName "s" -  pure $ flip map [2..maxTupleSize] $ \tupleNum ->-    let names = take tupleNum allNames-        temps = take tupleNum tempNames-        vars  = fmap VarT names-        tuple = foldl' AppT (TupleT tupleNum)+  flip concatMapM [2..maxTupleSize] $ \tupleNum ->+    let aNames = take tupleNum aNamesAll+        aPrimeNames = take tupleNum aPrimeNamesAll+        asNames = take tupleNum asNamesAll+        vars  = fmap VarT aNames +        bundlePrimName = mkName ("bundle" ++ show tupleNum ++ "#")+        unbundlePrimName = mkName ("unbundle" ++ show tupleNum ++ "#")+        qualBundleNm = mkName ("Clash.Signal.Bundle.bundle" ++ show tupleNum ++ "#")+        qualUnbundlePrimName = mkName ("Clash.Signal.Bundle.unbundle" ++ show tupleNum ++ "#")++        mkTupleT = foldl' AppT (TupleT tupleNum)+         -- Instance declaration-        instTy = AppT bundleTy $ tuple vars+        instTy = AppT bundleTy $ mkTupleT vars          -- Associated type Unbundled-#if MIN_VERSION_template_haskell(2,15,0)         unbundledTypeEq =           TySynEqn Nothing             ((ConT unbundledTyName `AppT`-                VarT t ) `AppT` tuple vars )-            $ tuple $ map (AppT (signal `AppT` VarT t)) vars+                VarT tNm ) `AppT` mkTupleT vars )+            $ mkTupleT $ map (AppT (signal `AppT` VarT tNm)) vars         unbundledType = TySynInstD unbundledTypeEq-#else-        unbundledTypeEq =-          TySynEqn-            [ VarT t, tuple vars ]-            $ tuple $ map (AppT (signal `AppT` VarT t)) vars-        unbundledType = TySynInstD unbundledTyName unbundledTypeEq-#endif -        bundleLambda = LamE (map VarP temps) (TupE $ map VarE temps)-        applicatives = VarE '(<$>) : repeat (VarE '(<*>))-        bundle =+        mkFunD nm alias = FunD nm [Clause [] (NormalB (VarE alias)) []]+        bundleD = mkFunD bundleName bundlePrimName+        unbundleD = mkFunD unbundleName unbundlePrimName++        sigType t = ConT ''Signal `AppT` VarT (mkName "dom") `AppT` t++        -- unbundle3# ~s@((a, b, c) :- abcs) =+        --   let (as, bs, cs) = s `seq` unbundle3# abcs in+        --   (a :- as, b :- bs, c :- cs)+        unbundleNoInlineAnn = PragmaD (InlineP unbundlePrimName NoInline FunLike AllPhases)++        unbundleSig = SigD unbundlePrimName (+          mkFunTys+            [mkTupleT (map sigType (map VarT aNames))]+            (sigType (mkTupleT (map VarT aNames)))+          )++        seqE nm res = UInfixE (VarE nm) (VarE 'seq) res+        seqXE nm res = UInfixE (VarE nm) (VarE 'seqX) res++        unbundleFBody =+          LetE+            [ ValD+                (TupP (map VarP asNames))+                (NormalB (+                  tNm `seqXE` (sNm `seqE` (VarE unbundlePrimName `AppE` VarE sTailNm)))) []]+            (mkTupE+              (zipWith+                (\a as -> UInfixE (VarE a) (ConE '(:-)) (VarE as))+                aNames+                asNames))++        unbundleF =           FunD-            bundleName-            [ Clause-                [ TupP $ map VarP names ]-                ( NormalB-                $ foldl'-                    (\f (a, b) -> a `AppE` f `AppE` b)-                    bundleLambda-                    (zip applicatives $ map VarE names)-                )-                []-            ]+            unbundlePrimName+            [Clause+              [AsP sNm (TildeP (UInfixP+                                 (AsP tNm (TildeP (TupP (map VarP aNames))))+                                 '(:-)+                                 (VarP sTailNm)))]+              (NormalB unbundleFBody)+              [] ] -        unbundleLambda n =-          LamE-            [ TupP [ if i == n then VarP x else WildP | i <- [0..tupleNum-1] ] ]-            (VarE x)+        -- bundle2# (a1, a2) = (\ a1' a2' -> (a1', a2')) <$> a1 <*> a2+        bundleNoInlineAnn = PragmaD (InlineP bundlePrimName NoInline FunLike AllPhases) -        unbundle =+        bundleSig = SigD bundlePrimName (+          mkFunTys+            [sigType (mkTupleT (map VarT aNames))]+            (mkTupleT (map sigType (map VarT aNames)))+          )++        bundleFmap =+          UInfixE+            (LamE (map VarP aPrimeNames) (mkTupE (map VarE aPrimeNames)))+            (VarE '(<$>))+            (VarE (maybe (error "impossible") fst (uncons aNames)))++        bundleFBody =+          foldl'+            (\e n -> UInfixE e (VarE '(<*>)) (VarE n))+            bundleFmap+            (drop 1 aNames)++        bundleF =           FunD-            unbundleName-            [ Clause-                [ VarP tup ]-                ( NormalB . TupE $-                    map-                      (\n -> VarE 'fmap `AppE` unbundleLambda n `AppE` VarE tup)-                      [0..tupleNum-1]-                )-                []-            ]+            bundlePrimName+            [Clause+              [TupP (map VarP aNames)]+              (NormalB bundleFBody)+              [] ]+    in do+      unbundlePrimAnn <- idPrimitive qualUnbundlePrimName+      bundlePrimAnn <- idPrimitive qualBundleNm+      pure [ -- Instance and its methods+             InstanceD Nothing [] instTy [unbundledType, bundleD, unbundleD] -    in InstanceD Nothing [] instTy [unbundledType, bundle, unbundle]+             -- Bundle primitive+           , bundleSig, bundleF, bundlePrimAnn, bundleNoInlineAnn++             -- Unbundle primitive+           , unbundleSig, unbundleF, unbundlePrimAnn, unbundleNoInlineAnn+           ]++mkFunTys :: Foldable t => t TH.Type -> TH.Type -> TH.Type+mkFunTys args res= foldl' go res args+ where+  go l r = AppT (AppT ArrowT l) r
src/Clash/Signal/Delayed.hs view
@@ -2,29 +2,20 @@ Copyright  :  (C) 2013-2016, University of Twente,                   2017     , Google Inc.                   2019     , Myrtle Software Ltd+                  2021     , LUMI GUIDE FIETSDETECTIE B.V. License    :  BSD2 (see the file LICENSE) Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE CPP                  #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE KindSignatures       #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeApplications     #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ >= 806-{-# LANGUAGE NoStarIsType #-}-#endif-#if __GLASGOW_HASKELL__ < 806-{-# LANGUAGE TypeInType #-}-#endif -{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}  module Clash.Signal.Delayed   ( -- * Delay-annotated synchronous signals@@ -45,35 +36,34 @@     -- * Experimental   , unsafeFromSignal   , antiDelay+  , forward   ) where -import           Data.Coerce                   (coerce)-import           Data.Kind                     (Type)-import           Data.Proxy                    (Proxy(..)) import           GHC.TypeLits-  (KnownNat, type (^), type (+), type (*), Nat)-import           Data.Singletons.Prelude       (Apply, TyFun, type (@@))+  (KnownNat, type (^), type (+), type (*)) -import           Clash.Signal.Internal         (Domain) import Clash.Signal.Delayed.Internal   (DSignal(..), dfromList, dfromList_lazy, fromSignal, toSignal,-   unsafeFromSignal, antiDelay, feedback)+   unsafeFromSignal, antiDelay, feedback, forward) import qualified Clash.Explicit.Signal.Delayed as E-import           Clash.Sized.Vector            (Vec, dtfold)+import           Clash.Sized.Vector import           Clash.Signal-  (HiddenClockResetEnable , hideClockResetEnable, Signal, delay)+  (HiddenClock, HiddenClockResetEnable, HiddenEnable, hideClock,+   hideClockResetEnable, hideEnable) -import           Clash.Promoted.Nat            (SNat (..), snatToInteger)+import           Clash.Promoted.Nat            (SNat (..)) import           Clash.XException              (NFDataX)  {- $setup >>> :set -XDataKinds -XTypeOperators -XTypeApplications -XFlexibleContexts+>>> :m -Clash.Explicit.Prelude+>>> :m -Clash.Explicit.Prelude.Safe >>> import Clash.Prelude >>> let delay3 = delayed (-1 :> -1 :> -1 :> Nil) >>> let delay2 = delayedI :: HiddenClockResetEnable dom  => Int -> DSignal dom n Int -> DSignal dom (n + 2) Int >>> let delayN2 = delayN d2->>> let delayI2 = delayI :: HiddenClockResetEnable dom  => Int -> DSignal dom n Int -> DSignal dom (n + 2) Int+>>> let delayI2 = delayI :: (HiddenClock dom, HiddenEnable dom) => Int -> DSignal dom n Int -> DSignal dom (n + 2) Int >>> let countingSignals = Clash.Prelude.repeat (dfromList [0..]) :: Vec 4 (DSignal dom 0 Int) -} @@ -99,29 +89,28 @@   -> DSignal dom (n + d) a delayed = hideClockResetEnable E.delayed --- | Delay a 'DSignal' for @d@ periods, where @d@ is derived from the context.------ @--- delay2---   :: HiddenClockResetEnable dom---   => Int---   -> 'DSignal' dom n Int---   -> 'DSignal' dom (n + 2) Int--- delay2 = 'delayedI'--- @------ >>> sampleN @System 7 (toSignal (delay2 (-1) (dfromList [0..])))--- [-1,-1,-1,1,2,3,4]------ Or @d@ can be specified using type application:------ >>> :t delayedI @3--- delayedI @3---   :: (...---       ...---       ...---       ...) =>---      a -> DSignal dom n a -> DSignal dom (n + 3) a+{- | Delay a 'DSignal' for @d@ periods, where @d@ is derived from the context.++@+delay2+  :: HiddenClockResetEnable dom+  => Int+  -> 'DSignal' dom n Int+  -> 'DSignal' dom (n + 2) Int+delay2 = 'delayedI'+@++>>> sampleN @System 7 (toSignal (delay2 (-1) (dfromList [0..])))+[-1,-1,-1,1,2,3,4]++Or @d@ can be specified using type application:++>>> :t delayedI @3+delayedI @3+  :: ... =>+     a -> DSignal dom n a -> DSignal dom (n + 3) a++-} delayedI   :: ( KnownNat d      , NFDataX a@@ -135,36 +124,36 @@ -- | Delay a 'DSignal' for @d@ cycles, the value at time 0..d-1 is /a/. -- -- @--- delay2---   :: HiddenClockResetEnable dom+-- delayN2+--   :: ( HiddenClock dom+--      , HiddenEnable dom ) --   => Int --   -> 'DSignal' dom n Int --   -> 'DSignal' dom (n + 2) Int--- delay2 = 'delayN' d2+-- delayN2 = 'delayN' d2 -- @ -- -- >>> printX $ sampleN @System 6 (toSignal (delayN2 (-1) (dfromList [1..]))) -- [-1,-1,1,2,3,4] delayN   :: forall dom  a d n-   . ( HiddenClockResetEnable dom+   . ( HiddenClock dom+     , HiddenEnable dom      , NFDataX a )   => SNat d   -> a   -- ^ Initial value   -> DSignal dom n a   -> DSignal dom (n+d) a-delayN d dflt = coerce . go (snatToInteger d) . coerce @_ @(Signal dom a)-  where-    go 0 = id-    go i = delay dflt . go (i-1)+delayN d dflt = hideClock (hideEnable (E.delayN d dflt))  -- | Delay a 'DSignal' for @d@ cycles, where @d@ is derived from the context. -- The value at time 0..d-1 is a default value. -- -- @ -- delayI2---   :: HiddenClockResetEnable dom+--   :: ( HiddenClock dom+--      , HiddenEnable dom ) --   => Int --   -> 'DSignal' dom n Int --   -> 'DSignal' dom (n + 2) Int@@ -175,23 +164,22 @@ -- [-1,-1,1,2,3,4] -- -- You can also use type application to do the same:+-- -- >>> sampleN @System 6 (toSignal (delayI @2 (-1) (dfromList [1..]))) -- [-1,-1,1,2,3,4] delayI   :: forall d n a dom-   . ( HiddenClockResetEnable dom+   . ( HiddenClock dom+     , HiddenEnable dom      , NFDataX a      , KnownNat d )   => a   -- ^ Initial value   -> DSignal dom n a   -> DSignal dom (n+d) a-delayI dflt = delayN (SNat :: SNat d) dflt--data DelayedFold (dom :: Domain) (n :: Nat) (delay :: Nat) (a :: Type) (f :: TyFun Nat Type) :: Type-type instance Apply (DelayedFold dom n delay a) k = DSignal dom (n + (delay*k)) a+delayI dflt = hideClock (hideEnable (E.delayI dflt)) --- | Tree fold over a 'Vec' of 'DSignal's with a combinatorial function,+-- | Tree fold over a 'Vec' of 'DSignal's with a combinational function, -- and delaying @delay@ cycles after each application. -- Values at times 0..(delay*k)-1 are set to a default. --@@ -207,7 +195,8 @@ -- [-1,-1,1,1,0,1,16,81] delayedFold   :: forall dom  n delay k a-   . ( HiddenClockResetEnable dom+   . ( HiddenClock dom+     , HiddenEnable dom      , NFDataX a      , KnownNat delay      , KnownNat k )@@ -221,10 +210,4 @@   -- ^ Vector input of size 2^k   -> DSignal dom (n + (delay * k)) a   -- ^ Output Signal delayed by (delay * k)-delayedFold _ dflt op = dtfold (Proxy :: Proxy (DelayedFold dom n delay a)) id go-  where-    go :: SNat l-       -> DelayedFold dom n delay a @@ l-       -> DelayedFold dom n delay a @@ l-       -> DelayedFold dom n delay a @@ (l+1)-    go SNat x y = delayI dflt (op <$> x <*> y)+delayedFold d dflt f = hideClock (hideEnable (E.delayedFold d dflt f))
src/Clash/Signal/Delayed/Bundle.hs view
@@ -5,28 +5,18 @@   License     :  BSD2 (see the file LICENSE)   Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com> -}-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE DefaultSignatures      #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE KindSignatures         #-}-{-# LANGUAGE NoImplicitPrelude      #-}-{-# LANGUAGE PolyKinds              #-}-{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE TypeOperators          #-}-#if __GLASGOW_HASKELL__ < 806-{-# LANGUAGE TypeInType #-}-#endif  module Clash.Signal.Delayed.Bundle (-  Bundle,-  Unbundled,-  bundle,-  unbundle,+    Bundle(..)+  -- ** Tools to emulate pre Clash 1.0 @Bundle ()@ instance+  , B.EmptyTuple(..)+  , TaggedEmptyTuple(..)   ) where -import           Control.Applicative           (liftA2) import           GHC.TypeLits                  (KnownNat) import           Prelude                       hiding (head, map, tail) @@ -69,9 +59,9 @@ -- data D = A | B -- -- instance Bundle D where---   type 'Unbundled' dom delay D = 'DSignal' dom d D---   'bundle'   _ s = s---   'unbundle' _ s = s+--   type 'Unbundled' dom delay D = 'DSignal' dom delay D+--   'bundle'   s = s+--   'unbundle' s = s -- @ -- class Bundle a where@@ -81,7 +71,7 @@   -- | Example:   --   -- @-  -- __bundle__ :: ('DSignal' dom d a, 'DSignal' dom d b) -> 'DSignal' clk d (a,b)+  -- __bundle__ :: ('DSignal' dom d a, 'DSignal' dom d b) -> 'DSignal' dom d (a,b)   -- @   --   -- However:@@ -222,3 +212,17 @@   type Unbundled t delay (RTree d a) = RTree d (DSignal t delay a)   bundle   = sequenceA   unbundle = sequenceA . fmap lazyT++-- | Same as 'Clash.Signal.Bundle.TaggedEmptyTuple' in "Clash.Signal.Bundle", but adapted for 'DSignal'.+data TaggedEmptyTuple (dom :: Domain) (d :: Nat) = TaggedEmptyTuple++-- | See [commit 94b0bff5](https://github.com/clash-lang/clash-compiler/pull/539/commits/94b0bff5770aa4961e04ddce2515130df3fc7863)+-- and documentation for 'Clash.Signal.Bundle.TaggedEmptyTuple'.+instance Bundle B.EmptyTuple where+  type Unbundled dom d B.EmptyTuple = TaggedEmptyTuple dom d++  bundle :: TaggedEmptyTuple dom d -> DSignal dom d B.EmptyTuple+  bundle TaggedEmptyTuple = pure B.EmptyTuple++  unbundle :: DSignal dom d B.EmptyTuple -> TaggedEmptyTuple dom d+  unbundle s = seq s TaggedEmptyTuple
src/Clash/Signal/Delayed/Internal.hs view
@@ -1,24 +1,17 @@ {-|   Copyright   :  (C) 2019     , Myrtle Software Ltd.                      2018     , @blaxill-                     2018-2019, QBayLogic B.V.+                     2018-2025, QBayLogic B.V.+                     2021     , LUMI GUIDE FIETSDETECTIE B.V.   License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com> -}-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveLift                 #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-#if __GLASGOW_HASKELL__ < 806-{-# LANGUAGE TypeInType #-}-#endif+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}  {-# LANGUAGE Trustworthy #-} @@ -37,47 +30,79 @@     -- * Experimental   , unsafeFromSignal   , antiDelay+  , forward   ) where  import Data.Coerce                (coerce)-import Data.Default.Class         (Default(..))+import Data.Default               (Default(..)) import GHC.TypeLits               (Nat, type (+)) import Language.Haskell.TH.Syntax (Lift) import Test.QuickCheck            (Arbitrary, CoArbitrary)  import Clash.Promoted.Nat         (SNat)-import Clash.Signal.Internal      (Domain)-import Clash.Explicit.Signal-  (Signal, fromList, fromList_lazy)+import Clash.Signal.Internal      (Signal, Domain, fromList, fromList_lazy) import Clash.XException           (NFDataX)  {- $setup >>> :set -XDataKinds >>> :set -XTypeOperators >>> import Clash.Explicit.Prelude+>>> import qualified Clash.Signal.Delayed.Bundle as DB >>> :{-let mac :: Clock System-        -> Reset System-        -> Enable System-        -> DSignal System 0 Int -> DSignal System 0 Int-        -> DSignal System 0 Int+let mac+      :: forall dom+       . KnownDomain dom+      => Clock dom+      -> Reset dom+      -> Enable dom+      -> DSignal dom 0 Int+      -> DSignal dom 0 Int+      -> DSignal dom 0 Int     mac clk rst en x y = feedback (mac' x y)       where-        mac' :: DSignal System 0 Int -> DSignal System 0 Int-             -> DSignal System 0 Int-             -> (DSignal System 0 Int, DSignal System 1 Int)+        mac'+          :: DSignal dom 0 Int+          -> DSignal dom 0 Int+          -> DSignal dom 0 Int+          -> (DSignal dom 0 Int, DSignal dom 1 Int)         mac' a b acc = let acc' = a * b + acc-                       in  (acc, delayed clk rst en (singleton 0) acc')+                       in  (acc, delayedI clk rst en 0 acc') :} +>>> :{+let numbers+      :: forall dom+       . KnownDomain dom+      => Clock dom+      -> Reset dom+      -> Enable dom+      -> DSignal dom 5 (Int, Int)+    numbers clk rst en = DB.bundle (forward d1 s1, s2)+      where+        s1 :: DSignal dom 4 Int+        s1 = delayed clk rst en (100 :> 10 :> 5 :> 1 :> Nil) (pure 200)+        s2 :: DSignal dom 5 Int+        s2 = fmap (2*) $ delayN d1 0 en clk s1+:}+ -}  -- | A synchronized signal with samples of type @a@, synchronized to clock -- @clk@, that has accumulated @delay@ amount of samples delay along its path.+--+-- DSignal has the <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html type role>+--+-- >>> :i DSignal+-- type role DSignal nominal nominal representational+-- ...+--+-- as it is safe to coerce the values in the signal, but not safe to coerce the+-- synthesis domain or delay in the signal.+type role DSignal nominal nominal representational newtype DSignal (dom :: Domain) (delay :: Nat) a =     DSignal { toSignal :: Signal dom a-              -- ^ Strip a 'DSignal' from its delay information.+              -- ^ Strip a 'DSignal' of its delay information.             }   deriving ( Show, Default, Functor, Applicative, Num, Fractional            , Foldable, Traversable, Arbitrary, CoArbitrary, Lift )@@ -87,7 +112,7 @@ -- Every element in the list will correspond to a value of the signal for one -- clock cycle. ----- >>> sampleN 2 (dfromList [1,2,3,4,5])+-- >>> sampleN 2 (toSignal (dfromList [1,2,3,4,5])) -- [1,2] -- -- __NB__: This function is not synthesizable@@ -99,7 +124,7 @@ -- Every element in the list will correspond to a value of the signal for one -- clock cycle. ----- >>> sampleN 2 (dfromList [1,2,3,4,5])+-- >>> sampleN 2 (toSignal (dfromList [1,2,3,4,5])) -- [1,2] -- -- __NB__: This function is not synthesizable@@ -109,17 +134,27 @@ -- | Feed the delayed result of a function back to its input: -- -- @--- mac :: Clock dom -> Reset dom -> Enable dom---     -> 'DSignal' dom 0 Int -> 'DSignal' dom 0 Int -> 'DSignal' dom 0 Int+-- mac+--   :: forall dom+--    . KnownDomain dom+--   => Clock dom+--   -> Reset dom+--   -> Enable dom+--   -> 'DSignal' dom 0 Int+--   -> 'DSignal' dom 0 Int+--   -> 'DSignal' dom 0 Int -- mac clk rst en x y = 'feedback' (mac' x y) --   where---     mac' :: 'DSignal' dom 0 Int -> 'DSignal' dom 0 Int -> 'DSignal' dom 0 Int---          -> ('DSignal' dom 0 Int, 'DSignal' dom 1 Int)+--     mac'+--       :: 'DSignal' dom 0 Int+--       -> 'DSignal' dom 0 Int+--       -> 'DSignal' dom 0 Int+--       -> ('DSignal' dom 0 Int, 'DSignal' dom 1 Int) --     mac' a b acc = let acc' = a * b + acc---                    in  (acc, 'delay' clk rst en ('singleton' 0) acc')+--                    in  (acc, 'Clash.Explicit.Signal.Delayed.delayedI' clk rst en 0 acc') -- @ ----- >>> sampleN 7 (mac systemClockGen systemResetGen enableGen (dfromList [0..]) (dfromList [0..]))+-- >>> sampleN 7 (toSignal (mac systemClockGen systemResetGen enableGen (dfromList [0..]) (dfromList [0..]))) -- [0,0,1,5,14,30,55] feedback   :: (DSignal dom n a -> (DSignal dom n a,DSignal dom (n + m + 1) a))@@ -127,14 +162,12 @@ feedback f = let (o,r) = f (coerce r) in o  -- | 'Signal's are not delayed------ > sample s == dsample (fromSignal s) fromSignal :: Signal dom a -> DSignal dom 0 a fromSignal = coerce  -- | __EXPERIMENTAL__ ----- __Unsafely__ convert a 'Signal' to /any/ 'DSignal' clk'.+-- __Unsafely__ convert a 'Signal' to a 'DSignal' with an arbitrary @delay@. -- -- __NB__: Should only be used to interface with functions specified in terms of -- 'Signal'.@@ -143,15 +176,57 @@  -- | __EXPERIMENTAL__ ----- Access a /delayed/ signal in the present.+-- Access a /delayed/ signal from the future in the present. Often required+-- When writing a circuit that requires feedback from itself. -- -- @--- mac :: Clock dom -> Reset dom -> Enable dom---     -> 'DSignal' dom 0 Int -> 'DSignal' dom 0 Int -> 'DSignal' dom 0 Int+-- mac+--   :: KnownDomain dom+--   => Clock dom+--   -> Reset dom+--   -> Enable dom+--   -> 'DSignal' dom 0 Int+--   -> 'DSignal' dom 0 Int+--   -> 'DSignal' dom 0 Int -- mac clk rst en x y = acc' --   where --     acc' = (x * y) + 'antiDelay' d1 acc---     acc  = 'delay' clk rst en ('singleton' 0) acc'+--     acc  = 'Clash.Explicit.Signal.Delayed.delayedI' clk rst en 0 acc' -- @ antiDelay :: SNat d -> DSignal dom (n + d) a -> DSignal dom n a antiDelay _ = coerce++-- | __EXPERIMENTAL__+--+-- Access a /delayed/ signal from the past in the present. In contrast with+-- 'Clash.Explicit.Signal.Delayed.delayed' and friends forward does not insert+-- any logic. This means using this function violates the delay invariant of+-- 'DSignal'. This is sometimes useful when combining unrelated delayed signals+-- where inserting logic is not wanted or when abstracting over internal+-- delayed signals where the internal delay information should not be leaked.+--+-- For example, the circuit below returns a sequence of numbers as a pair+-- but the internal delay information between the elements of the pair+-- should not leak into the type.+--+-- @+-- numbers+--   :: forall dom+--    . KnownDomain dom+--   => Clock dom+--   -> Reset dom+--   -> Enable dom+--   -> 'DSignal' dom 5 (Int, Int)+-- numbers clk rst en = DB.bundle (forward d1 s1, s2)+--   where+--     s1 :: 'DSignal' dom 4 Int+--     s1 = 'Clash.Explicit.Signal.Delayed.delayed' clk rst en (100 :> 10 :> 5 :> 1 :> Nil) (pure 200)+--     s2 :: 'DSignal' dom 5 Int+--     s2 = fmap (2*) $ 'Clash.Explicit.Signal.Delayed.delayN' d1 0 en clk s1+-- @+--+-- >>> sampleN 8 (toSignal (numbers systemClockGen systemResetGen enableGen))+-- [(1,0),(1,2),(5,2),(10,10),(100,20),(200,200),(200,400),(200,400)]++forward :: SNat d -> DSignal dom n a -> DSignal dom (n + d) a+forward _ = coerce
src/Clash/Signal/Internal.hs view
@@ -1,1365 +1,2217 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,-                  2017-2019, Myrtle Software Ltd-                  2017,      Google Inc.-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE ConstraintKinds        #-}-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE DeriveAnyClass         #-}-{-# LANGUAGE DeriveDataTypeable     #-}-{-# LANGUAGE DeriveGeneric          #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE MagicHash              #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE StandaloneDeriving     #-}-{-# LANGUAGE TemplateHaskell        #-}-{-# LANGUAGE TypeApplications       #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE ViewPatterns           #-}-#if __GLASGOW_HASKELL__ >= 806-{-# LANGUAGE NoStarIsType #-}-#endif-#if __GLASGOW_HASKELL__ < 806-{-# LANGUAGE TypeInType #-}-#endif--{-# LANGUAGE Unsafe #-}--{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}-{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}-{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}---- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c--- as to why we need this.-{-# OPTIONS_GHC -fno-cpr-anal #-}--{-# OPTIONS_HADDOCK show-extensions not-home #-}--module Clash.Signal.Internal-  ( -- * Datatypes-    Signal(..)-  , head#-  , tail#-    -- * Domains-  , Domain-  , KnownDomain(..)-  , KnownConfiguration-  , knownDomainByName-  , ActiveEdge(..)-  , SActiveEdge(..)-  , InitBehavior(..)-  , SInitBehavior(..)-  , ResetKind(..)-  , SResetKind(..)-  , ResetPolarity(..)-  , SResetPolarity(..)-  , DomainConfiguration(..)-  , SDomainConfiguration(..)-  -- ** Configuration type families-  , DomainPeriod-  , DomainActiveEdge-  , DomainResetKind-  , DomainInitBehavior-  , DomainResetPolarity-    -- ** Default domains-  , System-  , XilinxSystem-  , IntelSystem-  , vSystem-  , vIntelSystem-  , vXilinxSystem-    -- ** Domain utilities-  , VDomainConfiguration(..)-  , vDomain-  , createDomain-    -- * Clocks-  , Clock (..)-  , clockTag-  , hzToPeriod-  , periodToHz-    -- ** Enabling-  , Enable(..)-  , toEnable-  , fromEnable-  , enableGen-    -- * Resets-  , Reset(..)-  , unsafeToReset-  , unsafeFromReset-  , unsafeToHighPolarity-  , unsafeToLowPolarity-  , unsafeFromHighPolarity-  , unsafeFromLowPolarity-  , invertReset-    -- * Basic circuits-  , delay#-  , register#-  , mux-    -- * Simulation and testbench functions-  , clockGen-  , resetGen-  , resetGenN-    -- * Boolean connectives-  , (.&&.), (.||.)-    -- * Simulation functions (not synthesizable)-  , simulate-    -- ** lazy version-  , simulate_lazy-    -- * List \<-\> Signal conversion (not synthesizable)-  , sample-  , sampleN-  , fromList-    -- ** lazy versions-  , sample_lazy-  , sampleN_lazy-  , fromList_lazy-    -- * QuickCheck combinators-  , testFor-    -- * Type classes-    -- ** 'Eq'-like-  , (.==.), (./=.)-    -- ** 'Ord'-like-  , (.<.), (.<=.), (.>=.), (.>.)-    -- ** 'Functor'-  , mapSignal#-    -- ** 'Applicative'-  , signal#-  , appSignal#-    -- ** 'Foldable'-  , foldr#-    -- ** 'Traversable'-  , traverse#-  -- * EXTREMELY EXPERIMENTAL-  , joinSignal#-  )-where--import Type.Reflection            (Typeable)-import Control.Applicative        (liftA2, liftA3)-import Control.DeepSeq            (NFData)-import Clash.Annotations.Primitive (hasBlackBox)-import Data.Binary                (Binary)-import Data.Char                  (isAsciiUpper, isAlphaNum, isAscii)-import Data.Coerce                (coerce)-import Data.Data                  (Data)-import Data.Default.Class         (Default (..))-import Data.Hashable              (Hashable)-import Data.Proxy                 (Proxy(..))-import GHC.Generics               (Generic)-import GHC.Stack                  (HasCallStack)-import GHC.TypeLits               (KnownSymbol, Nat, Symbol, type (<=))-import Language.Haskell.TH.Syntax -- (Lift (..), Q, Dec)-import Language.Haskell.TH.Compat (mkTySynInstD)-import Numeric.Natural            (Natural)-import Test.QuickCheck            (Arbitrary (..), CoArbitrary(..), Property,-                                   property)--import Clash.Promoted.Nat         (SNat (..), snatToNum, snatToNatural)-import Clash.Promoted.Symbol      (SSymbol (..), ssymbolToString)-import Clash.XException-  (NFDataX, errorX, deepseqX, defaultSeqX, deepErrorX)--{- $setup->>> :set -XDataKinds->>> :set -XMagicHash->>> :set -XTypeApplications->>> import Clash.Promoted.Nat->>> import Clash.XException->>> type System = "System"->>> let systemClockGen = clockGen @System->>> let systemResetGen = resetGen @System->>> import Clash.Explicit.Signal (register)->>> let registerS = register->>> let registerA = register--}----- * Signal---- | Determines clock edge memory elements are sensitive to. Not yet--- implemented.-data ActiveEdge-  -- TODO: Implement in blackboxes:-  = Rising-  -- ^ Elements are sensitive to the rising edge (low-to-high) of the clock.-  | Falling-  -- ^ Elements are sensitive to the falling edge (high-to-low) of the clock.-  deriving (Show, Eq, Ord, Generic, NFData, Data, Hashable, Binary)---- | Singleton version of 'ActiveEdge'-data SActiveEdge (edge :: ActiveEdge) where-  SRising  :: SActiveEdge 'Rising-  SFalling :: SActiveEdge 'Falling--instance Show (SActiveEdge edge) where-  show SRising = "SRising"-  show SFalling = "SFalling"--data ResetKind-  = Asynchronous-  -- ^ Elements respond /asynchronously/ to changes in their reset input. This-  -- means that they do /not/ wait for the next active clock edge, but respond-  -- immediately instead. Common on Intel FPGA platforms.-  | Synchronous-  -- ^ Elements respond /synchronously/ to changes in their reset input. This-  -- means that changes in their reset input won't take effect until the next-  -- active clock edge. Common on Xilinx FPGA platforms.-  deriving (Show, Eq, Ord, Generic, NFData, Data, Hashable)---- | Singleton version of 'ResetKind'-data SResetKind (resetKind :: ResetKind) where-  SAsynchronous :: SResetKind 'Asynchronous-  -- See 'Asynchronous' ^--  SSynchronous  :: SResetKind 'Synchronous-  -- See 'Synchronous' ^--instance Show (SResetKind reset) where-  show SAsynchronous = "SAsynchronous"-  show SSynchronous = "SSynchronous"---- | Determines the value for which a reset line is considered "active"-data ResetPolarity-  = ActiveHigh-  -- ^ Reset is considered active if underlying signal is 'True'.-  | ActiveLow-  -- ^ Reset is considered active if underlying signal is 'False'.-  deriving (Eq, Ord, Show, Generic, NFData, Data, Hashable)---- | Singleton version of 'ResetPolarity'-data SResetPolarity (polarity :: ResetPolarity) where-  SActiveHigh :: SResetPolarity 'ActiveHigh-  -- See: 'ActiveHigh' ^--  SActiveLow :: SResetPolarity 'ActiveLow-  -- See: 'ActiveLow' ^--instance Show (SResetPolarity polarity) where-  show SActiveHigh = "SActiveHigh"-  show SActiveLow = "SActiveLow"--data InitBehavior-  = Unknown-  -- ^ Power up value of memory elements is /unknown/.-  | Defined-  -- ^ If applicable, power up value of a memory element is defined. Applies to-  -- 'register's for example, but not to 'blockRam'.-  deriving (Show, Eq, Ord, Generic, NFData, Data, Hashable)--data SInitBehavior (init :: InitBehavior) where-  SUnknown :: SInitBehavior 'Unknown-  -- See: 'Unknown' ^--  SDefined :: SInitBehavior 'Defined-  -- See: 'Defined' ^--instance Show (SInitBehavior init) where-  show SUnknown = "SUnknown"-  show SDefined = "SDefined"---- | A domain with a name (@Domain@). Configures the behavior of various aspects--- of a circuits. See the documentation of this record's field types for more--- information on the options.------ See module documentation of "Clash.Explicit.Signal" for more information on--- how to create custom synthesis domains.-data DomainConfiguration-  = DomainConfiguration-  { _name :: Domain-  -- ^ Domain name-  , _period :: Nat-  -- ^ Period of clock in /ps/-  , _activeEdge :: ActiveEdge-  -- ^ Active edge of the clock-  , _resetKind :: ResetKind-  -- ^ Whether resets are synchronous (edge-sensitive) or asynchronous (level-sensitive)-  , _initBehavior :: InitBehavior-  -- ^ Whether the initial (or "power up") value of memory elements is-  -- unknown/undefined, or configurable to a specific value-  , _resetPolarity :: ResetPolarity-  -- ^ Whether resets are active high or active low-  }-  deriving (Typeable)---- | Helper type family for 'DomainPeriod'-type family DomainConfigurationPeriod (config :: DomainConfiguration) :: Nat where-  DomainConfigurationPeriod ('DomainConfiguration name period edge reset init polarity) = period---- | Helper type family for 'DomainActiveEdge'-type family DomainConfigurationActiveEdge (config :: DomainConfiguration) :: ActiveEdge where-  DomainConfigurationActiveEdge ('DomainConfiguration name period edge reset init polarity) = edge---- | Helper type family for 'DomainResetKind'-type family DomainConfigurationResetKind (config :: DomainConfiguration) :: ResetKind where-  DomainConfigurationResetKind ('DomainConfiguration name period edge reset init polarity) = reset---- | Helper type family for 'DomainInitBehavior'-type family DomainConfigurationInitBehavior (config :: DomainConfiguration) :: InitBehavior where-  DomainConfigurationInitBehavior ('DomainConfiguration name period edge reset init polarity) = init---- | Helper type family for 'DomainResetPolarity'-type family DomainConfigurationResetPolarity (config :: DomainConfiguration) :: ResetPolarity where-  DomainConfigurationResetPolarity ('DomainConfiguration name period edge reset init polarity) = polarity---- | Convenience type to help to extract a period from a domain. Example usage:------ @--- myFunc :: (KnownDomain dom, DomainPeriod dom ~ 6000) => ...--- @-type DomainPeriod (dom :: Domain) =-  DomainConfigurationPeriod (KnownConf dom)---- | Convenience type to help to extract the active edge from a domain. Example--- usage:------ @--- myFunc :: (KnownDomain dom, DomainActiveEdge dom ~ 'Rising) => ...--- @-type DomainActiveEdge (dom :: Domain) =-  DomainConfigurationActiveEdge (KnownConf dom)---- | Convenience type to help to extract the reset synchronicity from a--- domain. Example usage:------ @--- myFunc :: (KnownDomain dom, DomainResetKind dom ~ 'Asynchronous) => ...--- @-type DomainResetKind (dom :: Domain) =-  DomainConfigurationResetKind (KnownConf dom)---- | Convenience type to help to extract the initial value behavior from a--- domain. Example usage:------ @--- myFunc :: (KnownDomain dom, DomainInitBehavior dom ~ 'Defined) => ...--- @-type DomainInitBehavior (dom :: Domain) =-  DomainConfigurationInitBehavior (KnownConf dom)---- | Convenience type to help to extract the reset polarity from a domain.--- Example usage:------ @--- myFunc :: (KnownDomain dom, DomainResetPolarity dom ~ 'ActiveHigh) => ...--- @-type DomainResetPolarity (dom :: Domain) =-  DomainConfigurationResetPolarity (KnownConf dom)---- | Singleton version of 'DomainConfiguration'-data SDomainConfiguration (dom :: Domain) (conf :: DomainConfiguration) where-  SDomainConfiguration-    :: SSymbol dom-    -- Domain name ^-    -> SNat period-    -- Period of clock in /ps/ ^-    -> SActiveEdge edge-    -- Active edge of the clock (not yet-    -- implemented) ^-    -> SResetKind reset-    -- Whether resets are synchronous (edge-sensitive) or asynchronous (level-sensitive) ^-    -> SInitBehavior init-    -- Whether the initial (or "power up") value of memory elements is-    -- unknown/undefined, or configurable to a specific value ^-    -> SResetPolarity polarity-    -- Whether resets are active high or active low ^-    -> SDomainConfiguration dom ('DomainConfiguration dom period edge reset init polarity)--instance Show (SDomainConfiguration dom conf) where-  show (SDomainConfiguration dom period edge reset init_ polarity) =-    unwords-      [ "SDomainConfiguration"-      , show dom-      , show period-      , show edge-      , show reset-      , show init_-      , show polarity-      ]--type KnownConfiguration dom conf = (KnownDomain dom, KnownConf dom ~ conf)---- | A 'KnownDomain' constraint indicates that a circuit's behavior depends on--- some properties of a domain. See 'DomainConfiguration' for more information.-class KnownSymbol dom => KnownDomain (dom :: Domain) where-  type KnownConf dom :: DomainConfiguration-  -- | Returns 'SDomainConfiguration' corresponding to an instance's 'DomainConfiguration'.-  ---  -- Example usage:-  -- > knownDomain @System-  ---  knownDomain :: SDomainConfiguration dom (KnownConf dom)---- | Version of 'knownDomain' that takes a 'SSymbol'. For example:------ >>> knownDomainByName (SSymbol @"System")--- SDomainConfiguration System d10000 SRising SAsynchronous SDefined SActiveHigh-knownDomainByName-  :: forall dom-   . KnownDomain dom-  => SSymbol dom-  -> SDomainConfiguration dom (KnownConf dom)-knownDomainByName =-  const knownDomain-{-# INLINE knownDomainByName #-}---- | A /clock/ (and /reset/) dom with clocks running at 100 MHz-instance KnownDomain System where-  type KnownConf System = 'DomainConfiguration System 10000 'Rising 'Asynchronous 'Defined 'ActiveHigh-  knownDomain = SDomainConfiguration SSymbol SNat SRising SAsynchronous SDefined SActiveHigh---- | System instance with defaults set for Xilinx FPGAs-instance KnownDomain XilinxSystem where-  type KnownConf XilinxSystem = 'DomainConfiguration XilinxSystem 10000 'Rising 'Synchronous 'Defined 'ActiveHigh-  knownDomain = SDomainConfiguration SSymbol SNat SRising SSynchronous SDefined SActiveHigh---- | System instance with defaults set for Intel FPGAs-instance KnownDomain IntelSystem where-  type KnownConf IntelSystem = 'DomainConfiguration IntelSystem 10000 'Rising 'Asynchronous 'Defined 'ActiveHigh-  knownDomain = SDomainConfiguration SSymbol SNat SRising SAsynchronous SDefined SActiveHigh---- | Convenience value to allow easy "subclassing" of System domain. Should--- be used in combination with 'createDomain'. For example, if you just want to--- change the period but leave all other settings in tact use:------ > createDomain vSystem{vName="System10", vPeriod=10}----vSystem :: VDomainConfiguration-vSystem = vDomain (knownDomain @System)---- | A clock (and reset) dom with clocks running at 100 MHz. Memory elements--- respond to the rising edge of the clock, and asynchronously to changes in--- reset signals. It has defined initial values, and active-high resets.------ See module documentation of "Clash.Explicit.Signal" for more information on--- how to create custom synthesis domains.-type System = ("System" :: Domain)----- | Convenience value to allow easy "subclassing" of IntelSystem domain. Should--- be used in combination with 'createDomain'. For example, if you just want to--- change the period but leave all other settings in tact use:------ > createDomain vIntelSystem{vName="Intel10", vPeriod=10}----vIntelSystem :: VDomainConfiguration-vIntelSystem = vDomain (knownDomain @IntelSystem)---- | A clock (and reset) dom with clocks running at 100 MHz. Memory elements--- respond to the rising edge of the clock, and asynchronously to changes in--- reset signals. It has defined initial values, and active-high resets.------ See module documentation of "Clash.Explicit.Signal" for more information on--- how to create custom synthesis domains.-type IntelSystem = ("IntelSystem" :: Domain)---- | Convenience value to allow easy "subclassing" of XilinxSystem domain. Should--- be used in combination with 'createDomain'. For example, if you just want to--- change the period but leave all other settings in tact use:------ > createDomain vXilinxSystem{vName="Xilinx10", vPeriod=10}----vXilinxSystem :: VDomainConfiguration-vXilinxSystem = vDomain (knownDomain @XilinxSystem)---- | A clock (and reset) dom with clocks running at 100 MHz. Memory elements--- respond to the rising edge of the clock, and synchronously to changes in--- reset signals. It has defined initial values, and active-high resets.------ See module documentation of "Clash.Explicit.Signal" for more information on--- how to create custom synthesis domains.-type XilinxSystem = ("XilinxSystem" :: Domain)---- | Same as SDomainConfiguration but allows for easy updates through record update syntax.--- Should be used in combination with 'vDomain' and 'createDomain'. Example:------ > createDomain (knownVDomain @System){vName="System10", vPeriod=10}------ This duplicates the settings in the "System" domain, replaces the name and--- period, and creates an instance for it. As most users often want to update--- the system domain, a shortcut is available in the form:------ > createDomain vSystem{vName="System10", vPeriod=10}----data VDomainConfiguration-  = VDomainConfiguration-  { vName :: String-  -- ^ Corresponds to '_name' on 'DomainConfiguration'-  , vPeriod :: Natural-  -- ^ Corresponds to '_period' on 'DomainConfiguration'-  , vActiveEdge :: ActiveEdge-  -- ^ Corresponds to '_edge' on 'DomainConfiguration'-  , vResetKind :: ResetKind-  -- ^ Corresponds to '_reset' on 'DomainConfiguration'-  , vInitBehavior :: InitBehavior-  -- ^ Corresponds to '_init' on 'DomainConfiguration'-  , vResetPolarity :: ResetPolarity-  -- ^ Corresponds to '_polarity' on 'DomainConfiguration'-  }---- | Convert 'SDomainConfiguration' to 'VDomainConfiguration'. Should be used in combination with--- 'createDomain' only.-vDomain :: SDomainConfiguration dom conf -> VDomainConfiguration-vDomain (SDomainConfiguration dom period edge reset init_ polarity) =-  VDomainConfiguration-    (ssymbolToString dom)-    (snatToNatural period)-    (case edge of {SRising -> Rising; SFalling -> Falling})-    (case reset of {SAsynchronous -> Asynchronous; SSynchronous -> Synchronous})-    (case init_ of {SDefined -> Defined; SUnknown -> Unknown})-    (case polarity of {SActiveHigh -> ActiveHigh; SActiveLow -> ActiveLow})---- TODO: Function might reject valid type names. Figure out what's allowed.-isValidDomainName :: String -> Bool-isValidDomainName (x:xs) = isAsciiUpper x && all isAscii xs && all isAlphaNum xs-isValidDomainName _ = False---- | Convenience method to express new domains in terms of others.------ > createDomain (knownVDomain @System){vName="System10", vPeriod=10}------ This duplicates the settings in the "System" domain, replaces the name and--- period, and creates an instance for it. As most users often want to update--- the system domain, a shortcut is available in the form:------ > createDomain vSystem{vName="System10", vPeriod=10}------ The function will create two extra identifiers. The first:------ > type System10 = ..------ You can use that as the dom to Clocks\/Resets\/Enables\/Signals. For example:--- @Signal System10 Int@. Additionally, it will create a 'VDomainConfiguration' that you can--- use in later calls to 'createDomain':------ > vSystem10 = knownVDomain @System10----createDomain :: VDomainConfiguration -> Q [Dec]-createDomain (VDomainConfiguration name period edge reset init_ polarity) =-  if isValidDomainName name then do-    kdType <- [t| KnownDomain $nameT |]-    kcType <- [t| ('DomainConfiguration $nameT $periodT $edgeT $resetKindT $initT $polarityT) |]-    sDom <- [| SDomainConfiguration SSymbol SNat $edgeE $resetKindE $initE $polarityE |]--    let vNameImpl = AppE (VarE 'vDomain) (AppTypeE (VarE 'knownDomain) (LitT (StrTyLit name)))-        kdImpl = FunD 'knownDomain [Clause [] (NormalB sDom) []]-        kcImpl = mkTySynInstD ''KnownConf [LitT (StrTyLit name)] kcType-        vName' = mkName ('v':name)--    pure  [ -- KnownDomain instance (ex: instance KnownDomain "System" where ...)-            InstanceD Nothing [] kdType [kcImpl, kdImpl]--            -- Type synonym (ex: type System = "System")-          , TySynD (mkName name) [] (LitT (StrTyLit name)  `SigT`  ConT ''Domain)--            -- vDomain helper (ex: vSystem = vDomain (knownDomain @System))-          , SigD vName' (ConT ''VDomainConfiguration)-          , FunD vName' [Clause [] (NormalB vNameImpl) []]-          ]-  else-    error ("Domain names should be a valid Haskell type name, not: " ++ name)- where--  edgeE =-    pure $-    case edge of-      Rising -> ConE 'SRising-      Falling -> ConE 'SFalling--  resetKindE =-    pure $-    case reset of-      Asynchronous -> ConE 'SAsynchronous-      Synchronous -> ConE 'SSynchronous--  initE =-    pure $-    case init_ of-      Unknown -> ConE 'SUnknown-      Defined -> ConE 'SDefined--  polarityE =-    pure $-    case polarity of-      ActiveHigh -> ConE 'SActiveHigh-      ActiveLow -> ConE 'SActiveLow--  nameT   = pure (LitT (StrTyLit name))-  periodT = pure (LitT (NumTyLit (toInteger period)))--  edgeT =-    pure $-    case edge of-      Rising -> PromotedT 'Rising-      Falling -> PromotedT 'Falling--  resetKindT =-    pure $-    case reset of-      Asynchronous -> PromotedT 'Asynchronous-      Synchronous -> PromotedT 'Synchronous--  initT =-    pure $-    case init_ of-      Unknown -> PromotedT 'Unknown-      Defined -> PromotedT 'Defined--  polarityT =-    pure $-    case polarity of-      ActiveHigh -> PromotedT 'ActiveHigh-      ActiveLow -> PromotedT 'ActiveLow---type Domain = Symbol--infixr 5 :--{- | Clash has synchronous 'Signal's in the form of:--@-'Signal' (dom :: 'Domain') a-@--Where /a/ is the type of the value of the 'Signal', for example /Int/ or /Bool/,-and /dom/ is the /clock-/ (and /reset-/) domain to which the memory elements-manipulating these 'Signal's belong.--The type-parameter, /dom/, is of the kind 'Domain' - a simple string. That-string refers to a single /synthesis domain/. A synthesis domain describes the-behavior of certain aspects of memory elements in it.--* __NB__: \"Bad things\"™  happen when you actually use a clock period of @0@,-so do __not__ do that!-* __NB__: You should be judicious using a clock with period of @1@ as you can-never create a clock that goes any faster!-* __NB__: For the best compatibility make sure your period is divisible by 2,-because some VHDL simulators don't support fractions of picoseconds.-* __NB__: Whether 'System' has good defaults depends on your target platform.-Check out 'IntelSystem' and 'XilinxSystem' too!--See the module documentation of "Clash.Signal" for more information about-domains.--}-data Signal (dom :: Domain) a-  -- | The constructor, @(':-')@, is __not__ synthesizable.-  = a :- Signal dom a--head# :: Signal dom a -> a-head# (x' :- _ )  = x'--tail# :: Signal dom a -> Signal dom a-tail# (_  :- xs') = xs'--instance Show a => Show (Signal dom a) where-  show (x :- xs) = show x ++ " " ++ show xs--instance Lift a => Lift (Signal dom a) where-  lift ~(x :- _) = [| signal# x |]--instance Default a => Default (Signal dom a) where-  def = signal# def--instance Functor (Signal dom) where-  fmap = mapSignal#--mapSignal# :: (a -> b) -> Signal dom a -> Signal dom b-mapSignal# f (a :- as) = f a :- mapSignal# f as-{-# NOINLINE mapSignal# #-}-{-# ANN mapSignal# hasBlackBox #-}--instance Applicative (Signal dom) where-  pure  = signal#-  (<*>) = appSignal#--signal# :: a -> Signal dom a-signal# a = let s = a :- s in s-{-# NOINLINE signal# #-}-{-# ANN signal# hasBlackBox #-}--appSignal# :: Signal dom (a -> b) -> Signal dom a -> Signal dom b-appSignal# (f :- fs) xs@(~(a :- as)) = f a :- (xs `seq` appSignal# fs as) -- See [NOTE: Lazy ap]-{-# NOINLINE appSignal# #-}-{-# ANN appSignal# hasBlackBox #-}--{- NOTE: Lazy ap-Signal's ap, i.e (Applicative.<*>), must be lazy in it's second argument:--> appSignal :: Signal clk (a -> b) -> Signal clk a -> Signal clk b-> appSignal (f :- fs) ~(a :- as) = f a :- appSignal fs as--because some feedback loops, such as the loop described in 'system' in the-example at http://hackage.haskell.org/package/clash-prelude-0.10.10/docs/Clash-Prelude-BlockRam.html,-will lead to "Exception <<loop>>".--However, this "naive" lazy version is _too_ lazy and induces spaceleaks.-The current version:--> appSignal# :: Signal clk (a -> b) -> Signal clk a -> Signal clk b-> appSignal# (f :- fs) xs@(~(a :- as)) = f a :- (xs `seq` appSignal# fs as)--Is lazy enough to handle the earlier mentioned feedback loops, but doesn't leak-(as much) memory like the "naive" lazy version, because the Signal constructor-of the second argument is evaluated as soon as the tail of the result is evaluated.--}----- | __WARNING: EXTREMELY EXPERIMENTAL__------ The circuit semantics of this operation are unclear and/or non-existent.--- There is a good reason there is no 'Monad' instance for 'Signal''.------ Is currently treated as 'id' by the Clash compiler.-joinSignal# :: Signal dom (Signal dom a) -> Signal dom a-joinSignal# ~(xs :- xss) = head# xs :- joinSignal# (mapSignal# tail# xss)-{-# NOINLINE joinSignal# #-}-{-# ANN joinSignal# hasBlackBox #-}--instance Num a => Num (Signal dom a) where-  (+)         = liftA2 (+)-  (-)         = liftA2 (-)-  (*)         = liftA2 (*)-  negate      = fmap negate-  abs         = fmap abs-  signum      = fmap signum-  fromInteger = signal# . fromInteger---- | __NB__: Not synthesizable------ __NB__: In \"@'foldr' f z s@\":------ * The function @f@ should be /lazy/ in its second argument.--- * The @z@ element will never be used.-instance Foldable (Signal dom) where-  foldr = foldr#---- | __NB__: Not synthesizable------ __NB__: In \"@'foldr#' f z s@\":------ * The function @f@ should be /lazy/ in its second argument.--- * The @z@ element will never be used.-foldr# :: (a -> b -> b) -> b -> Signal dom a -> b-foldr# f z (a :- s) = a `f` (foldr# f z s)-{-# NOINLINE foldr# #-}-{-# ANN foldr# hasBlackBox #-}--instance Traversable (Signal dom) where-  traverse = traverse#--traverse# :: Applicative f => (a -> f b) -> Signal dom a -> f (Signal dom b)-traverse# f (a :- s) = (:-) <$> f a <*> traverse# f s-{-# NOINLINE traverse# #-}-{-# ANN traverse# hasBlackBox #-}---- * Clocks, resets, and enables---- | A signal of booleans, indicating whether a component is enabled. No special--- meaning is implied, it's up to the component itself to decide how to respond--- to its enable line. It is used throughout Clash as a global enable signal.-newtype Enable dom = Enable (Signal dom Bool)---- | Convert 'Enable' construct to its underlying representation: a signal of--- bools.-fromEnable :: Enable dom -> Signal dom Bool-fromEnable = coerce-{-# INLINE fromEnable #-}---- | Convert a signal of bools to an 'Enable' construct-toEnable :: Signal dom Bool -> Enable dom-toEnable = coerce-{-# INLINE toEnable #-}---- | Enable generator for some domain. Is simply always True.-enableGen :: Enable dom-enableGen = toEnable (pure True)---- | A clock signal belonging to a domain named /dom/.-data Clock (dom :: Domain) = Clock (SSymbol dom)--instance Show (Clock dom) where-  show (Clock dom) = "<Clock: " ++ show dom ++ ">"---- | Extract dom symbol from Clock-clockTag-  :: Clock dom-  -> SSymbol dom-clockTag (Clock dom) = dom---- | Clock generator for simulations. Do __not__ use this clock generator for--- for the /testBench/ function, use 'tbClockGen' instead.------ To be used like:------ @--- clkSystem = clockGen @System--- @------ See 'DomainConfiguration' for more information on how to use synthesis domains.-clockGen-  :: KnownDomain dom-  => Clock dom-clockGen = Clock SSymbol-{-# NOINLINE clockGen #-}-{-# ANN clockGen hasBlackBox #-}------ | Reset generator------ To be used like:------ @--- rstSystem = resetGen @System--- @------ See 'tbClockGen' for example usage.----resetGen-  :: forall dom-   . KnownDomain dom-  => Reset dom-resetGen = resetGenN (SNat @1)-{-# INLINE resetGen #-}---- | Generate reset that's asserted for the first /n/ cycles.------ To be used like:------ @--- rstSystem5 = resetGen @System (SNat @5)--- @------ Example usage:------ >>> sampleN 7 (unsafeToHighPolarity (resetGenN @System (SNat @3)))--- [True,True,True,False,False,False,False]----resetGenN-  :: forall dom n-   . (KnownDomain dom, 1 <= n)-  => SNat n-  -- ^ Number of initial cycles to hold reset high-  -> Reset dom-resetGenN n =-  let asserted = replicate (snatToNum n) True in-  unsafeFromHighPolarity (fromList (asserted ++ repeat False))-{-# ANN resetGenN hasBlackBox #-}-{-# NOINLINE resetGenN #-}----- | A reset signal belonging to a domain called /dom/.------ The underlying representation of resets is 'Bool'.-data Reset (dom :: Domain) = Reset (Signal dom Bool)---- | Non-ambiguous version of 'Clash.Signal.Internal.Ambiguous.resetPolarity'-resetPolarityProxy-  :: forall dom proxy polarity-   . (KnownDomain dom, DomainResetPolarity dom ~ polarity)-  => proxy dom-  -> SResetPolarity polarity-resetPolarityProxy _proxy =-  case knownDomain @dom of-    SDomainConfiguration _dom _period _edge _sync _init polarity ->-      polarity---- | Convert a reset to an active high reset. Has no effect if reset is already--- an active high reset. Is unsafe because it can introduce:------ * <Clash-Explicit-Signal.html#metastability meta-stability>------ For asynchronous resets it is unsafe because it can cause combinatorial--- loops. In case of synchronous resets it can lead to--- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of--- asynchronous resets.-unsafeToHighPolarity-  :: forall dom-   . KnownDomain dom-  => Reset dom-  -> Signal dom Bool-unsafeToHighPolarity (unsafeFromReset -> r) =-  case resetPolarityProxy (Proxy @dom) of-    SActiveHigh -> r-    SActiveLow -> not <$> r-{-# INLINE unsafeToHighPolarity #-}---- | Convert a reset to an active low reset. Has no effect if reset is already--- an active low reset. It is unsafe because it can introduce:------ * <Clash-Explicit-Signal.html#metastability meta-stability>------ For asynchronous resets it is unsafe because it can cause combinatorial--- loops. In case of synchronous resets it can lead to--- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of--- asynchronous resets.-unsafeToLowPolarity-  :: forall dom-   . KnownDomain dom-  => Reset dom-  -> Signal dom Bool-unsafeToLowPolarity (unsafeFromReset -> r) =-  case resetPolarityProxy (Proxy @dom) of-    SActiveHigh -> not <$> r-    SActiveLow -> r-{-# INLINE unsafeToLowPolarity #-}---- | 'unsafeFromReset' is unsafe because it can introduce:------ * <Clash-Explicit-Signal.html#metastability meta-stability>------ For asynchronous resets it is unsafe because it can cause combinatorial--- loops. In case of synchronous resets it can lead to--- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of--- asynchronous resets.------ __NB__: You probably want to use 'unsafeToLowPolarity' or--- 'unsafeToHighPolarity'.-unsafeFromReset-  :: Reset dom-  -> Signal dom Bool-unsafeFromReset (Reset r) = r-{-# NOINLINE unsafeFromReset #-}-{-# ANN unsafeFromReset hasBlackBox #-}---- | 'unsafeToReset' is unsafe. For asynchronous resets it is unsafe--- because it can introduce combinatorial loops. In case of synchronous resets--- it can lead to <Clash-Explicit-Signal.html#metastability meta-stability>--- issues in the presence of asynchronous resets.------ __NB__: You probably want to use 'unsafeFromLowPolarity' or--- 'unsafeFromHighPolarity'.-unsafeToReset-  :: Signal dom Bool-  -> Reset dom-unsafeToReset r = Reset r-{-# NOINLINE unsafeToReset #-}-{-# ANN unsafeToReset hasBlackBox #-}---- | Interpret a signal of bools as an active high reset and convert it to--- a reset signal corresponding to the domain's setting.------ For asynchronous resets it is unsafe because it can cause combinatorial--- loops. In case of synchronous resets it can lead to--- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of--- asynchronous resets.-unsafeFromHighPolarity-  :: forall dom-   . KnownDomain dom-  => Signal dom Bool-  -- ^ Reset signal that's 'True' when active, and 'False' when inactive.-  -> Reset dom-unsafeFromHighPolarity r =-  unsafeToReset $-    case resetPolarityProxy (Proxy @dom) of-      SActiveHigh -> r-      SActiveLow -> not <$> r---- | Interpret a signal of bools as an active low reset and convert it to--- a reset signal corresponding to the domain's setting.------ For asynchronous resets it is unsafe because it can cause combinatorial--- loops. In case of synchronous resets it can lead to--- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of--- asynchronous resets.-unsafeFromLowPolarity-  :: forall dom-   . KnownDomain dom-  => Signal dom Bool-  -- ^ Reset signal that's 'False' when active, and 'True' when inactive.-  -> Reset dom-unsafeFromLowPolarity r =-  unsafeToReset $-    case resetPolarityProxy (Proxy @dom) of-      SActiveHigh -> not <$> r-      SActiveLow -> r---- | Invert reset signal-invertReset :: Reset dom -> Reset dom-invertReset = unsafeToReset . fmap not . unsafeFromReset--infixr 2 .||.--- | The above type is a generalization for:------ @--- __(.||.)__ :: 'Clash.Signal.Signal' 'Bool' -> 'Clash.Signal.Signal' 'Bool' -> 'Clash.Signal.Signal' 'Bool'--- @------ It is a version of ('||') that returns a 'Clash.Signal.Signal' of 'Bool'-(.||.) :: Applicative f => f Bool -> f Bool -> f Bool-(.||.) = liftA2 (||)--infixr 3 .&&.--- | The above type is a generalization for:------ @--- __(.&&.)__ :: 'Clash.Signal.Signal' 'Bool' -> 'Clash.Signal.Signal' 'Bool' -> 'Clash.Signal.Signal' 'Bool'--- @------ It is a version of ('&&') that returns a 'Clash.Signal.Signal' of 'Bool'-(.&&.) :: Applicative f => f Bool -> f Bool -> f Bool-(.&&.) = liftA2 (&&)---- [Note: register strictness annotations]------ In order to produce the first (current) value of the register's output--- signal, 'o', we don't need to know the shape of either input (enable or--- value-in).  This is important, because both values might be produced from--- the output in a feedback loop, so we can't know their shape (pattern--- match) them until we have produced output.------ Thus, we use lazy pattern matching to delay inspecting the shape of--- either argument until output has been produced.------ However, both arguments need to be evaluated to WHNF as soon as possible--- to avoid a space-leak.  Below, we explicitly reduce the value-in signal--- using 'seq' as the tail of our output signal is produced.  On the other--- hand, because the value of the tail depends on the value of the enable--- signal 'e', it will be forced by the 'if'/'then' statement and we don't--- need to 'seq' it explicitly.--delay#-  :: forall dom a-   . ( KnownDomain dom-     , NFDataX a )-  => Clock dom-  -> Enable dom-  -> a-  -> Signal dom a-  -> Signal dom a-delay# (Clock dom) (fromEnable -> en) powerUpVal0 =-    go powerUpVal1 en-  where-    powerUpVal1 :: a-    powerUpVal1 =-      case knownDomainByName dom of-        SDomainConfiguration _dom _period _edge _sync SDefined _polarity ->-          powerUpVal0-        SDomainConfiguration _dom _period _edge _sync SUnknown _polarity ->-          deepErrorX ("First value of `delay` unknown on domain " ++ show dom)--    go o (e :- es) as@(~(x :- xs)) =-      let o' = if e then x else o-      -- See [Note: register strictness annotations]-      in  o `defaultSeqX` o :- (as `seq` go o' es xs)-{-# NOINLINE delay# #-}-{-# ANN delay# hasBlackBox #-}---- | A register with a power up and reset value. Power up values are not--- supported on all platforms, please consult the manual of your target platform--- and check the notes below.------ Xilinx: power up values and reset values MUST be the same. If they are not,--- the Xilinx tooling __will ignore the reset value__ and use the power up value--- instead. Source: MIA------ Intel: power up values and reset values MUST be the same. If they are not,--- the Intel tooling __will ignore the power up value__ and use the reset value--- instead. Source: https://www.intel.com/content/www/us/en/programmable/support/support-resources/knowledge-base/solutions/rd01072011_91.html-register#-  :: forall dom  a-   . ( KnownDomain dom-     , NFDataX a )-  => Clock dom-  -> Reset dom-  -> Enable dom-  -> a-  -- ^ Power up value-  -> a-  -- ^ Reset value-  -> Signal dom a-  -> Signal dom a-register# (Clock dom) rst (fromEnable -> ena) powerUpVal0 resetVal =-  case knownDomainByName dom of-    SDomainConfiguration _name _period _edge SSynchronous _init _polarity ->-      goSync powerUpVal1 (unsafeToHighPolarity rst) ena-    SDomainConfiguration _name _period _edge SAsynchronous _init _polarity ->-      goAsync powerUpVal1 (unsafeToHighPolarity rst) ena- where-  powerUpVal1 :: a-  powerUpVal1 =-    case knownDomainByName dom of-      SDomainConfiguration _dom _period _edge _sync SDefined _polarity ->-        powerUpVal0-      SDomainConfiguration _dom _period _edge _sync SUnknown _polarity ->-        deepErrorX ("First value of register undefined on domain " ++ show dom)--  goSync-    :: a-    -> Signal dom Bool-    -> Signal dom Bool-    -> Signal dom a-    -> Signal dom a-  goSync o rt@(~(r :- rs)) enas@(~(e :- es)) as@(~(x :- xs)) =-    let oE = if e then x else o-        oR = if r then resetVal else oE-        -- [Note: register strictness annotations]-    in  o `defaultSeqX` o :- (rt `seq` enas `seq` as `seq` goSync oR rs es xs)--  goAsync-    :: a-    -> Signal dom Bool-    -> Signal dom Bool-    -> Signal dom a-    -> Signal dom a-  goAsync o (r :- rs) enas@(~(e :- es)) as@(~(x :- xs)) =-    let oR = if r then resetVal else o-        oE = if r then resetVal else (if e then x else o)-        -- [Note: register strictness annotations]-    in  oR `defaultSeqX` oR :- (as `seq` enas `seq` goAsync oE rs es xs)-{-# NOINLINE register# #-}-{-# ANN register# hasBlackBox #-}---- | The above type is a generalization for:------ @--- __mux__ :: 'Clash.Signal.Signal' 'Bool' -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' a--- @------ A multiplexer. Given "@'mux' b t f@", output @t@ when @b@ is 'True', and @f@--- when @b@ is 'False'.-mux :: Applicative f => f Bool -> f a -> f a -> f a-mux = liftA3 (\b t f -> if b then t else f)-{-# INLINE mux #-}--infix 4 .==.--- | The above type is a generalization for:------ @--- __(.==.)__ :: 'Eq' a => 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' 'Bool'--- @------ It is a version of ('==') that returns a 'Clash.Signal.Signal' of 'Bool'-(.==.) :: (Eq a, Applicative f) => f a -> f a -> f Bool-(.==.) = liftA2 (==)--infix 4 ./=.--- | The above type is a generalization for:------ @--- __(./=.)__ :: 'Eq' a => 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' 'Bool'--- @------ It is a version of ('/=') that returns a 'Clash.Signal.Signal' of 'Bool'-(./=.) :: (Eq a, Applicative f) => f a -> f a -> f Bool-(./=.) = liftA2 (/=)--infix 4 .<.--- | The above type is a generalization for:------ @--- __(.<.)__ :: 'Ord' a => 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' 'Bool'--- @------ It is a version of ('<') that returns a 'Clash.Signal.Signal' of 'Bool'-(.<.) :: (Ord a, Applicative f) => f a -> f a -> f Bool-(.<.) = liftA2 (<)--infix 4 .<=.--- | The above type is a generalization for:------ @--- __(.<=.)__ :: 'Ord' a => 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' 'Bool'--- @------ It is a version of ('<=') that returns a 'Clash.Signal.Signal' of 'Bool'-(.<=.) :: (Ord a, Applicative f) => f a -> f a -> f Bool-(.<=.) = liftA2 (<=)--infix 4 .>.--- | The above type is a generalization for:------ @--- __(.>.)__ :: 'Ord' a => 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' 'Bool'--- @------ It is a version of ('>') that returns a 'Clash.Signal.Signal' of 'Bool'-(.>.) :: (Ord a, Applicative f) => f a -> f a -> f Bool-(.>.) = liftA2 (>)--infix 4 .>=.--- | The above type is a generalization for:------ @--- __(.>=.)__ :: 'Ord' a => 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' 'Bool'--- @------  It is a version of ('>=') that returns a 'Clash.Signal.Signal' of 'Bool'-(.>=.) :: (Ord a, Applicative f) => f a -> f a -> f Bool-(.>=.) = liftA2 (>=)--instance Fractional a => Fractional (Signal dom a) where-  (/)          = liftA2 (/)-  recip        = fmap recip-  fromRational = signal# . fromRational--instance Arbitrary a => Arbitrary (Signal dom a) where-  arbitrary = liftA2 (:-) arbitrary arbitrary--instance CoArbitrary a => CoArbitrary (Signal dom a) where-  coarbitrary xs gen = do-    n <- arbitrary-    coarbitrary (take (abs n) (sample_lazy xs)) gen---- | The above type is a generalization for:------ @--- __testFor__ :: 'Int' -> 'Clash.Signal.Signal' Bool -> 'Property'--- @------ @testFor n s@ tests the signal @s@ for @n@ cycles.------ __NB__: This function is not synthesizable-testFor :: Foldable f => Int -> f Bool -> Property-testFor n = property . and . take n . sample---- * List \<-\> Signal conversion (not synthesizable)---- | The above type is a generalization for:------ @--- __sample__ :: 'Clash.Signal.Signal' a -> [a]--- @------ Get an infinite list of samples from a 'Clash.Signal.Signal'------ The elements in the list correspond to the values of the 'Clash.Signal.Signal'--- at consecutive clock cycles------ > sample s == [s0, s1, s2, s3, ...------ __NB__: This function is not synthesizable-sample :: (Foldable f, NFDataX a) => f a -> [a]-sample = foldr (\a b -> deepseqX a (a : b)) []---- | The above type is a generalization for:------ @--- __sampleN__ :: Int -> 'Clash.Signal.Signal' a -> [a]--- @------ Get a list of @n@ samples from a 'Clash.Signal.Signal'------ The elements in the list correspond to the values of the 'Clash.Signal.Signal'--- at consecutive clock cycles------ > sampleN 3 s == [s0, s1, s2]------ __NB__: This function is not synthesizable-sampleN :: (Foldable f, NFDataX a) => Int -> f a -> [a]-sampleN n = take n . sample---- | Create a 'Clash.Signal.Signal' from a list------ Every element in the list will correspond to a value of the signal for one--- clock cycle.------ >>> sampleN 2 (fromList [1,2,3,4,5])--- [1,2]------ __NB__: This function is not synthesizable-fromList :: NFDataX a => [a] -> Signal dom a-fromList = Prelude.foldr (\a b -> deepseqX a (a :- b)) (errorX "finite list")---- * Simulation functions (not synthesizable)---- | Simulate a (@'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' b@) function--- given a list of samples of type @a@------ >>> simulate (register systemClockGen resetGen enableGen 8) [1, 1, 2, 3]--- [8,8,1,2,3...--- ...------ __NB__: This function is not synthesizable-simulate :: (NFDataX a, NFDataX b) => (Signal dom1 a -> Signal dom2 b) -> [a] -> [b]-simulate f = sample . f . fromList---- | The above type is a generalization for:------ @--- __sample__ :: 'Clash.Signal.Signal' a -> [a]--- @------ Get an infinite list of samples from a 'Clash.Signal.Signal'------ The elements in the list correspond to the values of the 'Clash.Signal.Signal'--- at consecutive clock cycles------ > sample s == [s0, s1, s2, s3, ...------ __NB__: This function is not synthesizable-sample_lazy :: Foldable f => f a -> [a]-sample_lazy = foldr (:) []---- | The above type is a generalization for:------ @--- __sampleN__ :: Int -> 'Clash.Signal.Signal' a -> [a]--- @------ Get a list of @n@ samples from a 'Clash.Signal.Signal'------ The elements in the list correspond to the values of the 'Clash.Signal.Signal'--- at consecutive clock cycles------ > sampleN 3 s == [s0, s1, s2]------ __NB__: This function is not synthesizable-sampleN_lazy :: Foldable f => Int -> f a -> [a]-sampleN_lazy n = take n . sample_lazy---- | Create a 'Clash.Signal.Signal' from a list------ Every element in the list will correspond to a value of the signal for one--- clock cycle.------ >>> sampleN 2 (fromList [1,2,3,4,5] :: Signal System Int)--- [1,2]------ __NB__: This function is not synthesizable-fromList_lazy :: [a] -> Signal dom a-fromList_lazy = Prelude.foldr (:-) (error "finite list")---- * Simulation functions (not synthesizable)---- | Simulate a (@'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' b@) function--- given a list of samples of type @a@------ >>> simulate (register systemClockGen resetGen enableGen 8) [1, 1, 2, 3]--- [8,8,1,2,3...--- ...------ __NB__: This function is not synthesizable-simulate_lazy :: (Signal dom1 a -> Signal dom2 b) -> [a] -> [b]-simulate_lazy f = sample_lazy . f . fromList_lazy---- | Calculate the period, in __ps__, given a frequency in __Hz__------ i.e. to calculate the clock period for a circuit to run at 240 MHz we get------ >>> hzToPeriod 240e6--- 4167------ __NB__: This function is /not/ synthesizable--- __NB__: This function is lossy. I.e., hzToPeriod . periodToHz /= id.-hzToPeriod :: HasCallStack => Double -> Natural-hzToPeriod freq | freq <= 0.0 = error "Frequency must be strictly positive"-                | otherwise   = ceiling ((1.0 / freq) / 1.0e-12)---- | Calculate the frequence in __Hz__, given the period in __ps__------ i.e. to calculate the clock frequency of a clock with a period of 5000 ps:------ >>> periodToHz 5000--- 2.0e8------ __NB__: This function is /not/ synthesizable--- __NB__: This function is lossy. I.e., hzToPeriod . periodToHz /= id.-periodToHz :: Natural -> Double-periodToHz period = 1.0 / (1.0e-12 * fromIntegral period)+                  2017-2019, Myrtle Software Ltd,+                  2017-2022, Google Inc.,+                  2020     , Gergő Érdi,+                  2021-2025, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE Unsafe #-}++{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}++-- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c+-- as to why we need this.+{-# OPTIONS_GHC -fno-cpr-anal #-}++{-# OPTIONS_HADDOCK show-extensions not-home #-}++module Clash.Signal.Internal+  ( -- * Datatypes+    Signal(..)+  , head#+  , tail#+    -- * Domains+  , Domain+  , sameDomain+  , KnownDomain(..)+  , KnownConfiguration+  , knownDomainByName+  , ActiveEdge(..)+  , SActiveEdge(..)+  , InitBehavior(..)+  , SInitBehavior(..)+  , ResetKind(..)+  , SResetKind(..)+  , ResetPolarity(..)+  , SResetPolarity(..)+  , DomainConfiguration(..)+  , SDomainConfiguration(..)+  -- ** Configuration type families+  , DomainPeriod+  , DomainActiveEdge+  , DomainResetKind+  , DomainInitBehavior+  , DomainResetPolarity++  , DomainConfigurationPeriod+  , DomainConfigurationActiveEdge+  , DomainConfigurationResetKind+  , DomainConfigurationInitBehavior+  , DomainConfigurationResetPolarity++  -- *** Convenience types+  , HasSynchronousReset+  , HasAsynchronousReset+  , HasDefinedInitialValues+  -- **** Time representations+  , Seconds+  , Milliseconds+  , Microseconds+  , Nanoseconds+  , Picoseconds+  -- **** Time conversions+  , DomainToHz+  , HzToPeriod+  , PeriodToHz+  , PeriodToCycles+  , ClockDivider+    -- ** Default domains+  , System+  , XilinxSystem+  , IntelSystem+  , vSystem+  , vIntelSystem+  , vXilinxSystem+    -- ** Domain utilities+  , VDomainConfiguration(..)+  , vDomain+  , createDomain+    -- * Clocks+  , Clock (..)+  , ClockN (..)+  , DiffClock (..)+  , hzToPeriod+  , periodToHz+  , ClockAB (..)+  , clockTicks+  , clockTicksEither+    -- ** Enabling+  , Enable(..)+  , toEnable+  , fromEnable+  , enableGen+    -- * Resets+  , Reset(..)+  , unsafeToReset+  , unsafeFromReset+  , unsafeToActiveHigh+  , unsafeToActiveLow+  , unsafeFromActiveHigh+  , unsafeFromActiveLow+  , invertReset+    -- * Basic circuits+  , delay#+  , register#+  , asyncRegister#+  , syncRegister#+  , registerPowerup#+  , mux+  , apEn+    -- * Simulation and testbench functions+  , clockGen+  , tbClockGen+  , Femtoseconds(..)  -- experimental, do not expose in public API+  , fsToHz            -- experimental, do not expose in public API+  , hzToFs            -- experimental, do not expose in public API+  , unFemtoseconds    -- experimental, do not expose in public API+  , mapFemtoseconds   -- experimental, do not expose in public API+  , tbDynamicClockGen -- experimental, do not expose in public API+  , dynamicClockGen   -- experimental, do not expose in public API+  , resetGen+  , resetGenN+    -- * Boolean connectives+  , (.&&.), (&&.), (.&&), (.||.), (||.), (.||)+    -- * Simulation functions (not synthesizable)+  , simulate+    -- ** lazy version+  , simulate_lazy+    -- ** Automaton+  , signalAutomaton+    -- * List \<-\> Signal conversion (not synthesizable)+  , sample+  , sampleN+  , fromList+    -- ** lazy versions+  , sample_lazy+  , sampleN_lazy+  , fromList_lazy+    -- * QuickCheck combinators+  , testFor+    -- * Type classes+    -- ** 'Eq'-like+  , (.==.), (.==), (==.), (./=.), (./=), (/=.)+    -- ** 'Ord'-like+  , (.<.), (.<), (<.), (.<=.), (.<=), (<=.), (.>=.), (.>=), (>=.), (.>.), (.>), (>.)+    -- ** 'Functor'+  , mapSignal#+    -- ** 'Applicative'+  , signal#+  , appSignal#+    -- ** 'Foldable'+  , foldr#+    -- ** 'Traversable'+  , traverse#+  -- * EXTREMELY EXPERIMENTAL+  , joinSignal#++  -- * Deprecated+  , unsafeFromHighPolarity+  , unsafeFromLowPolarity+  , unsafeToHighPolarity+  , unsafeToLowPolarity+  )+where++import Data.IORef                 (IORef, atomicModifyIORef, newIORef, readIORef)+#if __GLASGOW_HASKELL__ < 912+import Type.Reflection            (Typeable)+#endif+import Control.Arrow.Transformer.Automaton+import Control.Applicative        (liftA3)+import Control.DeepSeq            (NFData)+import Clash.Annotations.Primitive (hasBlackBox, dontTranslate)+import Data.Binary                (Binary)+import Data.Char                  (isAsciiUpper, isAlphaNum, isAscii)+import Data.Coerce                (coerce)+import Data.Data                  (Data)+import Data.Default               (Default (..))+import Data.Hashable              (Hashable)+import Data.Int                   (Int64)+import Data.Maybe                 (isJust)+import Data.Proxy                 (Proxy(..))+import Data.Ratio                 (Ratio)+import Data.Type.Equality         ((:~:))+import GHC.Generics               (Generic)+import GHC.Stack                  (HasCallStack, withFrozenCallStack)+import GHC.TypeLits+  (Div, KnownSymbol, KnownNat, Nat, Symbol, type (<=), type (*), sameSymbol)+import GHC.TypeLits.Extra         (DivRU)+import GHC.Records                (HasField(getField))+import Language.Haskell.TH.Syntax -- (Lift (..), Q, Dec)+import Language.Haskell.TH.Compat+import Numeric.Natural            (Natural)+import System.IO.Unsafe           (unsafeInterleaveIO, unsafePerformIO)+import Test.QuickCheck            (Arbitrary (..), CoArbitrary(..), Property,+                                   property)++import Clash.Class.Num            (SaturatingNum(..))+import Clash.CPP                  (fStrictMapSignal)+import Clash.NamedTypes+import Clash.Promoted.Nat         (SNat (..), snatToNum, snatToNatural)+import Clash.Promoted.Symbol      (SSymbol (..), ssymbolToString)+import Clash.XException+  (NFDataX(..), errorX, isX, deepseqX, defaultSeqX, seqX)++{- $setup+>>> :set -XDataKinds+>>> :set -XMagicHash+>>> :set -XTypeApplications+>>> import Clash.Prelude (SSymbol(..))+>>> import Clash.Signal.Internal+>>> import Clash.Promoted.Nat+>>> import Clash.Promoted.Nat.Literals+>>> import Clash.XException+>>> import Data.Ratio (Ratio)+>>> import Numeric.Natural (Natural)+>>> type System = "System"+>>> let systemClockGen = clockGen @System+>>> let systemResetGen = resetGen @System+>>> import Clash.Explicit.Signal (register)+>>> let registerS = register+>>> let registerA = register+-}++-- * Signal++-- | Determines clock edge memory elements are sensitive to. Not yet+-- implemented.+data ActiveEdge+  -- TODO: Implement in blackboxes:+  = Rising+  -- ^ Elements are sensitive to the rising edge (low-to-high) of the clock.+  | Falling+  -- ^ Elements are sensitive to the falling edge (high-to-low) of the clock.+  deriving (Show, Read, Eq, Ord, Generic, NFData, Data, Hashable, Binary)++-- | Singleton version of 'ActiveEdge'+data SActiveEdge (edge :: ActiveEdge) where+  SRising  :: SActiveEdge 'Rising+  SFalling :: SActiveEdge 'Falling++instance Show (SActiveEdge edge) where+  show SRising = "SRising"+  show SFalling = "SFalling"++data ResetKind+  = Asynchronous+  -- ^ Elements respond /asynchronously/ to changes in their reset input. This+  -- means that they do /not/ wait for the next active clock edge, but respond+  -- immediately instead. Common on Intel FPGA platforms.+  | Synchronous+  -- ^ Elements respond /synchronously/ to changes in their reset input. This+  -- means that changes in their reset input won't take effect until the next+  -- active clock edge. Common on Xilinx FPGA platforms.+  deriving (Show, Read, Eq, Ord, Generic, NFData, Data, Hashable, Binary)++-- | Singleton version of 'ResetKind'+data SResetKind (resetKind :: ResetKind) where+  SAsynchronous :: SResetKind 'Asynchronous+  -- See 'Asynchronous' ^++  SSynchronous  :: SResetKind 'Synchronous+  -- See 'Synchronous' ^++instance Show (SResetKind reset) where+  show SAsynchronous = "SAsynchronous"+  show SSynchronous = "SSynchronous"++-- | Determines the value for which a reset line is considered "active"+data ResetPolarity+  = ActiveHigh+  -- ^ Reset is considered active if underlying signal is 'True'.+  | ActiveLow+  -- ^ Reset is considered active if underlying signal is 'False'.+  deriving (Eq, Ord, Show, Read, Generic, NFData, Data, Hashable, Binary)++-- | Singleton version of 'ResetPolarity'+data SResetPolarity (polarity :: ResetPolarity) where+  SActiveHigh :: SResetPolarity 'ActiveHigh+  -- See: 'ActiveHigh' ^++  SActiveLow :: SResetPolarity 'ActiveLow+  -- See: 'ActiveLow' ^++instance Show (SResetPolarity polarity) where+  show SActiveHigh = "SActiveHigh"+  show SActiveLow = "SActiveLow"++data InitBehavior+  = Unknown+  -- ^ Power up value of memory elements is /unknown/.+  | Defined+  -- ^ If applicable, power up value of a memory element is defined. Applies to+  -- 'Clash.Signal.register's for example, but not to+  -- 'Clash.Prelude.BlockRam.blockRam'.+  deriving (Show, Read, Eq, Ord, Generic, NFData, Data, Hashable, Binary)++data SInitBehavior (init :: InitBehavior) where+  SUnknown :: SInitBehavior 'Unknown+  -- See: 'Unknown' ^++  SDefined :: SInitBehavior 'Defined+  -- See: 'Defined' ^++instance Show (SInitBehavior init) where+  show SUnknown = "SUnknown"+  show SDefined = "SDefined"++-- | A domain with a name (@Domain@). Configures the behavior of various aspects+-- of a circuits. See the documentation of this record's field types for more+-- information on the options.+--+-- See module documentation of "Clash.Explicit.Signal" for more information on+-- how to create custom synthesis domains.+data DomainConfiguration+  = DomainConfiguration+  { _name :: Domain+  -- ^ Domain name+  , _period :: Nat+  -- ^ Period of clock in /ps/+  , _activeEdge :: ActiveEdge+  -- ^ Active edge of the clock+  , _resetKind :: ResetKind+  -- ^ Whether resets are synchronous (edge-sensitive) or asynchronous (level-sensitive)+  , _initBehavior :: InitBehavior+  -- ^ Whether the initial (or "power up") value of memory elements is+  -- unknown/undefined, or configurable to a specific value+  , _resetPolarity :: ResetPolarity+  -- ^ Whether resets are active high or active low+  }+#if __GLASGOW_HASKELL__ < 912+  deriving (Typeable)+#endif++-- | Helper type family for 'DomainPeriod'+type family DomainConfigurationPeriod (config :: DomainConfiguration) :: Nat where+  DomainConfigurationPeriod ('DomainConfiguration name period edge reset init polarity) = period++-- | Helper type family for 'DomainActiveEdge'+type family DomainConfigurationActiveEdge (config :: DomainConfiguration) :: ActiveEdge where+  DomainConfigurationActiveEdge ('DomainConfiguration name period edge reset init polarity) = edge++-- | Helper type family for 'DomainResetKind'+type family DomainConfigurationResetKind (config :: DomainConfiguration) :: ResetKind where+  DomainConfigurationResetKind ('DomainConfiguration name period edge reset init polarity) = reset++-- | Helper type family for 'DomainInitBehavior'+type family DomainConfigurationInitBehavior (config :: DomainConfiguration) :: InitBehavior where+  DomainConfigurationInitBehavior ('DomainConfiguration name period edge reset init polarity) = init++-- | Helper type family for 'DomainResetPolarity'+type family DomainConfigurationResetPolarity (config :: DomainConfiguration) :: ResetPolarity where+  DomainConfigurationResetPolarity ('DomainConfiguration name period edge reset init polarity) = polarity++-- | Convenience type to help to extract a period from a domain. Example usage:+--+-- @+-- myFunc :: (KnownDomain dom, DomainPeriod dom ~ 6000) => ...+-- @+type DomainPeriod (dom :: Domain) =+  DomainConfigurationPeriod (KnownConf dom)++-- | Convenience type to help to extract the active edge from a domain. Example+-- usage:+--+-- @+-- myFunc :: (KnownDomain dom, DomainActiveEdge dom ~ 'Rising) => ...+-- @+type DomainActiveEdge (dom :: Domain) =+  DomainConfigurationActiveEdge (KnownConf dom)++-- | Convenience type to help to extract the reset synchronicity from a+-- domain. Example usage:+--+-- @+-- myFunc :: (KnownDomain dom, DomainResetKind dom ~ 'Synchronous) => ...+-- @+type DomainResetKind (dom :: Domain) =+  DomainConfigurationResetKind (KnownConf dom)++-- | Convenience type to constrain a domain to have synchronous resets. Example+-- usage:+--+-- @+-- myFunc :: HasSynchronousReset dom => ...+-- @+--+-- Using this type implies 'KnownDomain'.+--+-- [Click here for usage hints]("Clash.Explicit.Signal#g:conveniencetypes")+type HasSynchronousReset (dom :: Domain) =+  (KnownDomain dom, DomainResetKind dom ~ 'Synchronous)++-- | Convenience type to constrain a domain to have asynchronous resets. Example+-- usage:+--+-- @+-- myFunc :: HasAsynchronousReset dom => ...+-- @+--+-- Using this type implies 'KnownDomain'.+--+-- [Click here for usage hints]("Clash.Explicit.Signal#g:conveniencetypes")+type HasAsynchronousReset (dom :: Domain) =+  (KnownDomain dom, DomainResetKind dom ~ 'Asynchronous)++-- | Convenience type to help to extract the initial value behavior from a+-- domain. Example usage:+--+-- @+-- myFunc :: (KnownDomain dom, DomainInitBehavior dom ~ 'Defined) => ...+-- @+type DomainInitBehavior (dom :: Domain) =+  DomainConfigurationInitBehavior (KnownConf dom)++-- | Convenience type to constrain a domain to have initial values. Example+-- usage:+--+-- @+-- myFunc :: HasDefinedInitialValues dom => ...+-- @+--+-- Using this type implies 'KnownDomain'.+--+-- Note that there is no @UnknownInitialValues dom@ as a component that works+-- without initial values will also work if it does have them.+--+-- [Click here for usage hints]("Clash.Explicit.Signal#g:conveniencetypes")+type HasDefinedInitialValues (dom :: Domain) =+  (KnownDomain dom, DomainInitBehavior dom ~ 'Defined)++-- | Convenience type to help to extract the reset polarity from a domain.+-- Example usage:+--+-- @+-- myFunc :: (KnownDomain dom, DomainResetPolarity dom ~ 'ActiveHigh) => ...+-- @+type DomainResetPolarity (dom :: Domain) =+  DomainConfigurationResetPolarity (KnownConf dom)++-- * Time representation++-- | Gets time in 'Picoseconds' from time in 'Seconds'+type Seconds      (s  :: Nat) = Milliseconds (1000 * s)+-- | Gets time in 'Picoseconds' from time in 'Milliseconds'+type Milliseconds (ms :: Nat) = Microseconds (1000 * ms)+-- | Gets time in 'Picoseconds' from time in 'Microseconds'+type Microseconds (us :: Nat) = Nanoseconds  (1000 * us)+-- | Gets time in 'Picoseconds' from time in 'Nanoseconds'+type Nanoseconds  (ns :: Nat) = Picoseconds  (1000 * ns)+-- | Gets time in 'Picoseconds' from time in picoseconds, essentially 'id'+type Picoseconds  (ps :: Nat) = ps++-- | Converts a frequency in hertz to a period in picoseconds. This might lead to rounding+-- errors.+type HzToPeriod (hz :: Nat) = Seconds 1 `Div` hz++-- | The domain's clock frequency in hertz, calculated based on the period stored in+-- picoseconds. This might lead to rounding errors.+type DomainToHz (dom :: Domain) = PeriodToHz (DomainPeriod dom)++-- | Number of clock cycles required at the clock frequency of @dom@ before a minimum+-- @period@ has passed+type PeriodToCycles (dom :: Domain) (period :: Nat) =  period `DivRU` DomainPeriod dom++-- | Converts a period in picoseconds to a frequency in hertz. This might lead to rounding+-- errors.+type PeriodToHz (period :: Nat) = (Seconds 1) `Div` period++-- | Number of clock cycles required at the clock frequency of @dom@ before a minimum+-- @period@ has passed. The same as 'PeriodToCycles'.+type ClockDivider (dom :: Domain) (period :: Nat) = PeriodToCycles dom period++-- | Singleton version of 'DomainConfiguration'+data SDomainConfiguration (dom :: Domain) (conf :: DomainConfiguration) where+  SDomainConfiguration ::+    1 <= period =>+    { sName :: SSymbol dom+      -- ^ Domain name+    , sPeriod :: SNat period+    -- ^ Period of clock in /ps/+    , sActiveEdge :: SActiveEdge edge+    -- ^ Active edge of the clock (not yet implemented)+    , sResetKind :: SResetKind reset+    -- ^ Whether resets are synchronous (edge-sensitive) or asynchronous (level-sensitive)+    , sInitBehavior :: SInitBehavior init+    -- ^ Whether the initial (or "power up") value of memory elements is+    -- unknown/undefined, or configurable to a specific value+    , sResetPolarity :: SResetPolarity polarity+    -- ^ Whether resets are active high or active low+    } -> SDomainConfiguration dom ('DomainConfiguration dom period edge reset init polarity)++deriving instance Show (SDomainConfiguration dom conf)++type KnownConfiguration dom conf = (KnownDomain dom, KnownConf dom ~ conf)++-- | A 'KnownDomain' constraint indicates that a circuit's behavior depends on+-- some properties of a domain. See 'DomainConfiguration' for more information.+class (KnownSymbol dom, KnownNat (DomainPeriod dom)) => KnownDomain (dom :: Domain) where+  type KnownConf dom :: DomainConfiguration+  -- | Returns 'SDomainConfiguration' corresponding to an instance's 'DomainConfiguration'.+  --+  -- Example usage:+  --+  -- >>> knownDomain @System+  -- SDomainConfiguration {sName = SSymbol @"System", sPeriod = SNat @10000, sActiveEdge = SRising, sResetKind = SAsynchronous, sInitBehavior = SDefined, sResetPolarity = SActiveHigh}+  knownDomain :: SDomainConfiguration dom (KnownConf dom)++-- | Version of 'knownDomain' that takes a 'SSymbol'. For example:+--+-- >>> knownDomainByName (SSymbol @"System")+-- SDomainConfiguration {sName = SSymbol @"System", sPeriod = SNat @10000, sActiveEdge = SRising, sResetKind = SAsynchronous, sInitBehavior = SDefined, sResetPolarity = SActiveHigh}+knownDomainByName+  :: forall dom+   . KnownDomain dom+  => SSymbol dom+  -> SDomainConfiguration dom (KnownConf dom)+knownDomainByName =+  const knownDomain+{-# INLINE knownDomainByName #-}++-- | A /clock/ (and /reset/) dom with clocks running at 100 MHz+instance KnownDomain System where+  type KnownConf System = 'DomainConfiguration System 10000 'Rising 'Asynchronous 'Defined 'ActiveHigh+  knownDomain = SDomainConfiguration SSymbol SNat SRising SAsynchronous SDefined SActiveHigh++-- | System instance with defaults set for Xilinx FPGAs+instance KnownDomain XilinxSystem where+  type KnownConf XilinxSystem = 'DomainConfiguration XilinxSystem 10000 'Rising 'Synchronous 'Defined 'ActiveHigh+  knownDomain = SDomainConfiguration SSymbol SNat SRising SSynchronous SDefined SActiveHigh++-- | System instance with defaults set for Intel FPGAs+instance KnownDomain IntelSystem where+  type KnownConf IntelSystem = 'DomainConfiguration IntelSystem 10000 'Rising 'Asynchronous 'Defined 'ActiveHigh+  knownDomain = SDomainConfiguration SSymbol SNat SRising SAsynchronous SDefined SActiveHigh++-- | Convenience value to allow easy "subclassing" of System domain. Should+-- be used in combination with 'createDomain'. For example, if you just want to+-- change the period but leave all other settings intact use:+--+-- > createDomain vSystem{vName="System10", vPeriod=10}+--+vSystem :: VDomainConfiguration+vSystem = vDomain (knownDomain @System)++-- | A clock (and reset) dom with clocks running at 100 MHz. Memory elements+-- respond to the rising edge of the clock, and asynchronously to changes in+-- reset signals. It has defined initial values, and active-high resets.+--+-- See module documentation of "Clash.Explicit.Signal" for more information on+-- how to create custom synthesis domains.+type System = ("System" :: Domain)+++-- | Convenience value to allow easy "subclassing" of IntelSystem domain. Should+-- be used in combination with 'createDomain'. For example, if you just want to+-- change the period but leave all other settings intact use:+--+-- > createDomain vIntelSystem{vName="Intel10", vPeriod=10}+--+vIntelSystem :: VDomainConfiguration+vIntelSystem = vDomain (knownDomain @IntelSystem)++-- | A clock (and reset) dom with clocks running at 100 MHz. Memory elements+-- respond to the rising edge of the clock, and asynchronously to changes in+-- reset signals. It has defined initial values, and active-high resets.+--+-- See module documentation of "Clash.Explicit.Signal" for more information on+-- how to create custom synthesis domains.+type IntelSystem = ("IntelSystem" :: Domain)++-- | Convenience value to allow easy "subclassing" of XilinxSystem domain. Should+-- be used in combination with 'createDomain'. For example, if you just want to+-- change the period but leave all other settings intact use:+--+-- > createDomain vXilinxSystem{vName="Xilinx10", vPeriod=10}+--+vXilinxSystem :: VDomainConfiguration+vXilinxSystem = vDomain (knownDomain @XilinxSystem)++-- | A clock (and reset) dom with clocks running at 100 MHz. Memory elements+-- respond to the rising edge of the clock, and synchronously to changes in+-- reset signals. It has defined initial values, and active-high resets.+--+-- See module documentation of "Clash.Explicit.Signal" for more information on+-- how to create custom synthesis domains.+type XilinxSystem = ("XilinxSystem" :: Domain)++-- | Same as SDomainConfiguration but allows for easy updates through record update syntax.+-- Should be used in combination with 'vDomain' and 'createDomain'. Example:+--+-- > createDomain (knownVDomain @System){vName="System10", vPeriod=10}+--+-- This duplicates the settings in the 'System' domain, replaces the name and+-- period, and creates an instance for it. As most users often want to update+-- the system domain, a shortcut is available in the form:+--+-- > createDomain vSystem{vName="System10", vPeriod=10}+--+data VDomainConfiguration+  = VDomainConfiguration+  { vName :: String+  -- ^ Corresponds to '_name' on 'DomainConfiguration'+  , vPeriod :: Natural+  -- ^ Corresponds to '_period' on 'DomainConfiguration'+  , vActiveEdge :: ActiveEdge+  -- ^ Corresponds to '_activeEdge' on 'DomainConfiguration'+  , vResetKind :: ResetKind+  -- ^ Corresponds to '_resetKind' on 'DomainConfiguration'+  , vInitBehavior :: InitBehavior+  -- ^ Corresponds to '_initBehavior' on 'DomainConfiguration'+  , vResetPolarity :: ResetPolarity+  -- ^ Corresponds to '_resetPolarity' on 'DomainConfiguration'+  }+  deriving (Eq, Generic, NFData, Show, Read, Binary)++-- | Convert 'SDomainConfiguration' to 'VDomainConfiguration'. Should be used in combination with+-- 'createDomain' only.+vDomain :: SDomainConfiguration dom conf -> VDomainConfiguration+vDomain (SDomainConfiguration dom period edge reset init_ polarity) =+  VDomainConfiguration+    (ssymbolToString dom)+    (snatToNatural period)+    (case edge of {SRising -> Rising; SFalling -> Falling})+    (case reset of {SAsynchronous -> Asynchronous; SSynchronous -> Synchronous})+    (case init_ of {SDefined -> Defined; SUnknown -> Unknown})+    (case polarity of {SActiveHigh -> ActiveHigh; SActiveLow -> ActiveLow})++-- TODO: Function might reject valid type names. Figure out what's allowed.+isValidDomainName :: String -> Bool+isValidDomainName (x:xs) = isAsciiUpper x && all isAscii xs && all isAlphaNum xs+isValidDomainName _ = False++-- | Convenience method to express new domains in terms of others.+--+-- > createDomain (knownVDomain @System){vName="System10", vPeriod=10}+--+-- This duplicates the settings in the "System" domain, replaces the name and+-- period, and creates an instance for it. As most users often want to update+-- the system domain, a shortcut is available in the form:+--+-- > createDomain vSystem{vName="System10", vPeriod=10}+--+-- The function will create two extra identifiers. The first:+--+-- > type System10 = ..+--+-- You can use that as the dom to Clocks\/Resets\/Enables\/Signals. For example:+-- @Signal System10 Int@. Additionally, it will create a 'VDomainConfiguration' that you can+-- use in later calls to 'createDomain':+--+-- > vSystem10 = knownVDomain @System10+--+-- It will also make @System10@ an instance of 'KnownDomain'.+--+-- If either identifier is already in scope it will not be generated a second time.+-- Note: This can be useful for example when documenting a new domain:+--+-- > -- | Here is some documentation for CustomDomain+-- > type CustomDomain = ("CustomDomain" :: Domain)+-- >+-- > -- | Here is some documentation for vCustomDomain+-- > createDomain vSystem{vName="CustomDomain"}+createDomain :: VDomainConfiguration -> Q [Dec]+createDomain (VDomainConfiguration name period edge reset init_ polarity) =+  if isValidDomainName name then do+    kdType <- [t| KnownDomain $nameT |]+    kcType <- [t| ('DomainConfiguration $nameT $periodT $edgeT $resetKindT $initT $polarityT) |]+    sDom <- [| SDomainConfiguration SSymbol SNat $edgeE $resetKindE $initE $polarityE |]++    let vNameImpl = AppE (VarE 'vDomain) (AppTypeE (VarE 'knownDomain) (LitT (StrTyLit name)))+        kdImpl = FunD 'knownDomain [Clause [] (NormalB sDom) []]+        kcImpl = mkTySynInstD ''KnownConf [LitT (StrTyLit name)] kcType+        vName' = mkName ('v':name)++    tySynExists <- isJust <$> lookupTypeName name+    vHelperExists <- isJust <$> lookupValueName ('v':name)++    pure $ concat+      [+        [ -- Type synonym (ex: type System = "System")+          TySynD (mkName name) [] (LitT (StrTyLit name)  `SigT`  ConT ''Domain)+        | not tySynExists+        ]++      , concat+        [ -- vDomain helper (ex: vSystem = vDomain (knownDomain @System))+          [ SigD vName' (ConT ''VDomainConfiguration)+          , FunD vName' [Clause [] (NormalB vNameImpl) []]+          ]+        | not vHelperExists+        ]+      , [ -- KnownDomain instance (ex: instance KnownDomain "System" where ...)+          InstanceD Nothing [] kdType [kcImpl, kdImpl]+        ]+      ]++  else+    error ("Domain names should be a valid Haskell type name, not: " ++ name)+ where++  edgeE =+    pure $+    case edge of+      Rising -> ConE 'SRising+      Falling -> ConE 'SFalling++  resetKindE =+    pure $+    case reset of+      Asynchronous -> ConE 'SAsynchronous+      Synchronous -> ConE 'SSynchronous++  initE =+    pure $+    case init_ of+      Unknown -> ConE 'SUnknown+      Defined -> ConE 'SDefined++  polarityE =+    pure $+    case polarity of+      ActiveHigh -> ConE 'SActiveHigh+      ActiveLow -> ConE 'SActiveLow++  nameT   = pure (LitT (StrTyLit name))+  periodT = pure (LitT (NumTyLit (toInteger period)))++  edgeT =+    pure $+    case edge of+      Rising -> PromotedT 'Rising+      Falling -> PromotedT 'Falling++  resetKindT =+    pure $+    case reset of+      Asynchronous -> PromotedT 'Asynchronous+      Synchronous -> PromotedT 'Synchronous++  initT =+    pure $+    case init_ of+      Unknown -> PromotedT 'Unknown+      Defined -> PromotedT 'Defined++  polarityT =+    pure $+    case polarity of+      ActiveHigh -> PromotedT 'ActiveHigh+      ActiveLow -> PromotedT 'ActiveLow+++type Domain = Symbol++-- | We either get evidence that this function was instantiated with the same+-- domains, or Nothing.+sameDomain+  :: forall (domA :: Domain) (domB :: Domain)+   . (KnownDomain domA, KnownDomain domB)+  => Maybe (domA :~: domB)+sameDomain = sameSymbol (Proxy @domA) (Proxy @domB)++infixr 5 :-+{- | Clash has synchronous 'Signal's in the form of:++@+'Signal' (dom :: 'Domain') a+@++Where /a/ is the type of the value of the 'Signal', for example /Int/ or /Bool/,+and /dom/ is the /clock-/ (and /reset-/) domain to which the memory elements+manipulating these 'Signal's belong.++The type-parameter, /dom/, is of the kind 'Domain' - a simple string. That+string refers to a single /synthesis domain/. A synthesis domain describes the+behavior of certain aspects of memory elements in it.++* __NB__: \"Bad things\"™  happen when you actually use a clock period of @0@,+so do __not__ do that!+* __NB__: You should be judicious using a clock with period of @1@ as you can+never create a clock that goes any faster!+* __NB__: For the best compatibility make sure your period is divisible by 2,+because some VHDL simulators don't support fractions of picoseconds.+* __NB__: Whether 'System' has good defaults depends on your target platform.+Check out 'IntelSystem' and 'XilinxSystem' too!++Signals have the <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html type role>++>>> :i Signal+type role Signal nominal representational+...++as it is safe to coerce the underlying value of a signal, but not safe to coerce+a signal between different synthesis domains.++See the module documentation of "Clash.Signal" for more information about+domains.+-}+type role Signal nominal representational+data Signal (dom :: Domain) a+  -- | The constructor, @(':-')@, is __not__ synthesizable.+  = a :- Signal dom a++head# :: Signal dom a -> a+head# (x' :- _ )  = x'++tail# :: Signal dom a -> Signal dom a+tail# (_  :- xs') = xs'++instance HasField (x :: k) r a => HasField x (Signal dom r) (Signal dom a) where+  getField = fmap (getField @x @r @a)++instance Show a => Show (Signal dom a) where+  show (x :- xs) = show x ++ " " ++ show xs++instance Lift a => Lift (Signal dom a) where+  lift ~(x :- _) = [| signal# x |]+  liftTyped = liftTypedFromUntyped++instance Default a => Default (Signal dom a) where+  def = signal# def++instance Functor (Signal dom) where+  fmap = mapSignal#++mapSignal# :: forall a b dom. (a -> b) -> Signal dom a -> Signal dom b+mapSignal# f = go+ where+  -- See -fstrict-mapSignal documentation in clash-prelude.cabal+  theSeq = if fStrictMapSignal then seqX else flip const+  go ~(xs@(a :- as)) = f a :- (a `theSeq` (xs `seq` go as))+{-# OPAQUE mapSignal# #-}+{-# ANN mapSignal# hasBlackBox #-}++instance Applicative (Signal dom) where+  pure  = signal#+  (<*>) = appSignal#++signal# :: a -> Signal dom a+signal# a = let s = a :- s in s+{-# OPAQUE signal# #-}+{-# ANN signal# hasBlackBox #-}++appSignal# :: Signal dom (a -> b) -> Signal dom a -> Signal dom b+appSignal# (f :- fs) xs@(~(a :- as)) = f a :- (xs `seq` appSignal# fs as) -- See [NOTE: Lazy ap]+{-# OPAQUE appSignal# #-}+{-# ANN appSignal# hasBlackBox #-}++instance NFDataX a => NFDataX (Signal domain a) where+  deepErrorX = pure . deepErrorX+  ensureSpine s = case isX s of+    Left e -> deepErrorX e+    Right (a :- s') -> ensureSpine a :- ensureSpine s'+  hasUndefined = error "hasUndefined on (Signal domain a): No sensible implementation exists"+  rnfX = error "rnfX on (Signal domain a): No sensible implementation exists"++{- NOTE: Lazy ap+Signal's ap, i.e (Applicative.<*>), must be lazy in it's second argument:++> appSignal :: Signal clk (a -> b) -> Signal clk a -> Signal clk b+> appSignal (f :- fs) ~(a :- as) = f a :- appSignal fs as++because some feedback loops, such as the loop described in 'system' in the+example at https://hackage.haskell.org/package/clash-prelude-1.0.0/docs/Clash-Prelude-BlockRam.html,+will lead to "Exception <<loop>>".++However, this "naive" lazy version is _too_ lazy and induces spaceleaks.+The current version:++> appSignal# :: Signal clk (a -> b) -> Signal clk a -> Signal clk b+> appSignal# (f :- fs) xs@(~(a :- as)) = f a :- (xs `seq` appSignal# fs as)++Is lazy enough to handle the earlier mentioned feedback loops, but doesn't leak+(as much) memory like the "naive" lazy version, because the Signal constructor+of the second argument is evaluated as soon as the tail of the result is evaluated.+-}+++-- | __WARNING: EXTREMELY EXPERIMENTAL__+--+-- The circuit semantics of this operation are unclear and/or non-existent.+-- There is a good reason there is no 'Monad' instance for 'Signal'.+--+-- Is currently treated as 'id' by the Clash compiler.+joinSignal# :: Signal dom (Signal dom a) -> Signal dom a+joinSignal# ~(xs :- xss) = head# xs :- joinSignal# (mapSignal# tail# xss)+{-# OPAQUE joinSignal# #-}+{-# ANN joinSignal# hasBlackBox #-}++instance Num a => Num (Signal dom a) where+  (+)         = liftA2 (+)+  (-)         = liftA2 (-)+  (*)         = liftA2 (*)+  negate      = fmap negate+  abs         = fmap abs+  signum      = fmap signum+  fromInteger = signal# . fromInteger++instance Bounded a => Bounded (Signal dom a) where+  minBound = pure minBound+  maxBound = pure maxBound++instance SaturatingNum a => SaturatingNum (Signal dom a) where+  satAdd mode = liftA2 (satAdd mode)+  satSub mode = liftA2 (satSub mode)+  satMul mode = liftA2 (satMul mode)+  satSucc mode = fmap (satSucc mode)+  satPred mode = fmap (satPred mode)++-- | __NB__: Not synthesizable+--+-- __NB__: In \"@'foldr' f z s@\":+--+-- * The function @f@ should be /lazy/ in its second argument.+-- * The @z@ element will never be used.+instance Foldable (Signal dom) where+  foldr = foldr#++-- | __NB__: Not synthesizable+--+-- __NB__: In \"@'foldr#' f z s@\":+--+-- * The function @f@ should be /lazy/ in its second argument.+-- * The @z@ element will never be used.+foldr# :: (a -> b -> b) -> b -> Signal dom a -> b+foldr# f z (a :- s) = a `f` (foldr# f z s)+{-# OPAQUE foldr# #-}+{-# ANN foldr# hasBlackBox #-}++instance Traversable (Signal dom) where+  traverse = traverse#++traverse# :: Applicative f => (a -> f b) -> Signal dom a -> f (Signal dom b)+traverse# f (a :- s) = (:-) <$> f a <*> traverse# f s+{-# OPAQUE traverse# #-}+{-# ANN traverse# hasBlackBox #-}++-- * Clocks, resets, and enables++-- | A signal of booleans, indicating whether a component is enabled. No special+-- meaning is implied, it's up to the component itself to decide how to respond+-- to its enable line. It is used throughout Clash as a global enable signal.+data Enable dom = Enable (Signal dom Bool)++-- | Convert 'Enable' construct to its underlying representation: a signal of+-- bools.+fromEnable :: Enable dom -> Signal dom Bool+fromEnable (Enable x) = x+{-# INLINE fromEnable #-}++-- | Convert a signal of bools to an 'Enable' construct+toEnable :: Signal dom Bool -> Enable dom+toEnable = Enable+{-# INLINE toEnable #-}++-- | Enable generator for some domain. Is simply always True.+enableGen :: Enable dom+enableGen = toEnable (pure True)++-- | A clock signal belonging to a domain named /dom/.+data Clock (dom :: Domain) = Clock+  { -- | Domain associated with the clock+    clockTag :: SSymbol dom++    -- | Periods of the clock. This is an experimental feature used to simulate+    -- clock frequency correction mechanisms. Currently, all ways to contruct+    -- such a clock are hidden from the public API.+  , clockPeriods :: Maybe (Signal dom Femtoseconds)+  }++instance Show (Clock dom) where+  show (Clock dom Nothing) = "<Clock: " ++ ssymbolToString dom ++ ">"+  show (Clock dom _) = "<Dynamic clock: " ++ ssymbolToString dom ++ ">"++-- | The negative or inverted phase of a differential clock signal. HDL+-- generation will treat it the same as 'Clock', except that no @create_clock@+-- command is issued in the SDC file for 'ClockN'. Used in 'DiffClock'.+newtype ClockN (dom :: Domain) = ClockN { clockNTag :: SSymbol dom }++instance Show (ClockN dom) where+  show (ClockN dom) = "<ClockN: " ++ ssymbolToString dom ++ ">"++-- | A differential clock signal belonging to a domain named /dom/. The clock+-- input of a design with such an input has two ports which are in antiphase.+-- The first input is the positive phase, the second the negative phase. When+-- using 'Clash.Annotations.TH.makeTopEntity', the names of the inputs will end+-- in @_p@ and @_n@ respectively.+--+-- To create a differential clock in a test bench, you can use+-- 'Clash.Explicit.Testbench.clockToDiffClock'.+data DiffClock (dom :: Domain) =+  DiffClock ("p" ::: Clock dom) ("n" ::: ClockN dom)++instance Show (DiffClock dom) where+  show (DiffClock (Clock dom Nothing) _) =+    "<DiffClock: " ++ ssymbolToString dom ++ ">"+  show (DiffClock (Clock dom _) _) =+    "<Dynamic DiffClock: " ++ ssymbolToString dom ++ ">"++-- | Clock generator for simulations. Do __not__ use this clock generator for+-- the /testBench/ function, use 'tbClockGen' instead.+--+-- To be used like:+--+-- @+-- clkSystem = clockGen @System+-- @+--+-- See 'DomainConfiguration' for more information on how to use synthesis domains.+clockGen+  :: KnownDomain dom+  => Clock dom+clockGen = tbClockGen (pure True)++-- | Clock generator to be used in the /testBench/ function.+--+-- To be used like:+--+-- @+-- clkSystem en = tbClockGen @System en+-- @+--+-- === __Example__+--+-- @+-- module Example where+--+-- import "Clash.Explicit.Prelude"+-- import "Clash.Explicit.Testbench"+--+-- -- Fast domain: twice as fast as \"Slow\"+-- 'Clash.Explicit.Prelude.createDomain' 'Clash.Explicit.Prelude.vSystem'{vName=\"Fast\", vPeriod=10}+--+-- -- Slow domain: twice as slow as \"Fast\"+-- 'Clash.Explicit.Prelude.createDomain' 'Clash.Explicit.Prelude.vSystem'{vName=\"Slow\", vPeriod=20}+--+-- topEntity+--   :: 'Clock' \"Fast\"+--   -> 'Reset' \"Fast\"+--   -> 'Enable' \"Fast\"+--   -> 'Clock' \"Slow\"+--   -> 'Signal' \"Fast\" (Unsigned 8)+--   -> 'Signal' \"Slow\" (Unsigned 8, Unsigned 8)+-- topEntity clk1 rst1 en1 clk2 i =+--   let h = register clk1 rst1 en1 0 (register clk1 rst1 en1 0 i)+--       l = register clk1 rst1 en1 0 i+--   in  unsafeSynchronizer clk1 clk2 (bundle (h, l))+--+-- testBench+--   :: 'Signal' \"Slow\" Bool+-- testBench = done+--   where+--     testInput      = 'Clash.Explicit.Testbench.stimuliGenerator' clkA1 rstA1 $('Clash.Sized.Vector.listToVecTH' [1::Unsigned 8,2,3,4,5,6,7,8])+--     expectedOutput = 'Clash.Explicit.Testbench.outputVerifier'   clkB2 rstB2 $('Clash.Sized.Vector.listToVecTH' [(0,0) :: (Unsigned 8, Unsigned 8),(1,2),(3,4),(5,6),(7,8)])+--     done           = expectedOutput (topEntity clkA1 rstA1 enableGen clkB2 testInput)+--     notDone        = not \<$\> done+--     clkA1          = 'tbClockGen' \@\"Fast\" (unsafeSynchronizer clkB2 clkA1 notDone)+--     clkB2          = 'tbClockGen' \@\"Slow\" notDone+--     rstA1          = 'Clash.Signal.resetGen' \@\"Fast\"+--     rstB2          = 'Clash.Signal.resetGen' \@\"Slow\"+-- @+tbClockGen+  :: KnownDomain testDom+  => Signal testDom Bool+  -> Clock testDom+tbClockGen done = Clock (done `seq` SSymbol) Nothing+{-# OPAQUE tbClockGen #-}+{-# ANN tbClockGen hasBlackBox #-}++-- | Femtoseconds expressed as an 'Int64'. Is a newtype to prevent accidental+-- mixups with picoseconds - the unit used in 'DomainConfiguration'.+--+newtype Femtoseconds = Femtoseconds Int64+  -- No 'Integral' instance to prevent accidental picoseconds / femtoseconds mixup+  deriving (Show, Eq, Generic, NFDataX, NFData, Lift, Ord)++-- | Strip newtype wrapper 'Femtoseconds'+unFemtoseconds :: Femtoseconds -> Int64+unFemtoseconds (Femtoseconds fs) = fs++-- | Map 'Int64' fields in 'Femtoseconds'+mapFemtoseconds :: (Int64 -> Int64) -> Femtoseconds -> Femtoseconds+mapFemtoseconds f (Femtoseconds fs) = Femtoseconds (f fs)++-- | Clock generator with dynamic clock periods for simulations. This is an+-- experimental feature and hence not part of the public API.+--+-- To be used like:+--+-- @+-- clkSystem = dynamicClockGen @System+-- @+--+-- See 'DomainConfiguration' for more information on how to use synthesis domains.+dynamicClockGen ::+  KnownDomain dom =>+  -- | Clock period in /femto/seconds.+  --+  -- * __NB__: Beware that the periods are given in femtoseconds; this differs+  --           from the usual unit Clash uses to represent period length,+  --           picoseconds.+  --+  -- * __NB__: Beware that not all simulators support femtoseconds. For example,+  --           Vivado's XSIM will round down to nearest picoseconds.+  --+  -- * __NB__: Beware that, by default, Clash will define @`timescale 100fs/100fs@+  --           in its generated Verilog. The latter will make simulators round+  --           time to 100fs. If you rely on more precision you should pass+  --           @-fclash-timescale-precision 1fs@ to Clash.+  Signal dom Femtoseconds ->+  Clock dom+dynamicClockGen periods = tbDynamicClockGen periods (pure True)++-- | Clock generator with dynamic clock periods for simulations. This is an+-- experimental feature and hence not part of the public API. Like 'tbClockGen'+--+--+-- To be used like:+--+-- @+-- clkSystem = dynamicClockGen @System+-- @+--+-- See 'DomainConfiguration' for more information on how to use synthesis domains.+tbDynamicClockGen ::+  KnownDomain dom =>+  -- | Clock period in /femto/seconds.+  --+  -- * __NB__: Beware that the periods are given in femtoseconds; this differs+  --           from the usual unit Clash uses to represent period length,+  --           picoseconds.+  --+  -- * __NB__: Beware that not all simulators support femtoseconds. For example,+  --           Vivado's XSIM will round down to nearest picoseconds.+  --+  -- * __NB__: Beware that, by default, Clash will define @`timescale 100fs/100fs@+  --           in its generated Verilog. The latter will make simulators round+  --           time to 100fs. If you rely on more precision you should pass+  --           @-fclash-timescale-precision 1fs@ to Clash.+  Signal dom Femtoseconds ->+  Signal dom Bool ->+  Clock dom+tbDynamicClockGen periods ena =+  Clock (ena `seq` periods `seq` SSymbol) (Just periods)+{-# OPAQUE tbDynamicClockGen #-}+{-# ANN tbDynamicClockGen hasBlackBox #-}+++-- | Reset generator for simulation purposes. Asserts the reset for a single+-- cycle.+--+-- To be used like:+--+-- @+-- rstSystem = resetGen @System+-- @+--+-- See 'Clash.Explicit.Testbench.tbClockGen' for example usage.+--+-- __NB__: While this can be used in the @testBench@ function, it cannot be+-- synthesized to hardware.+resetGen+  :: forall dom+   . KnownDomain dom+  => Reset dom+resetGen = resetGenN (SNat @1)+{-# INLINE resetGen #-}++-- | Reset generator for simulation purposes. Asserts the reset for the first /n/+-- cycles.+--+-- To be used like:+--+-- @+-- rstSystem5 = resetGen @System d5+-- @+--+-- Example usage:+--+-- >>> sampleN 7 (unsafeToActiveHigh (resetGenN @System d3))+-- [True,True,True,False,False,False,False]+--+-- __NB__: While this can be used in the @testBench@ function, it cannot be+-- synthesized to hardware.+resetGenN+  :: forall dom n+   . (KnownDomain dom, 1 <= n)+  => SNat n+  -- ^ Number of initial cycles to hold reset high+  -> Reset dom+resetGenN n =+  let asserted = replicate (snatToNum n) True in+  unsafeFromActiveHigh (fromList (asserted ++ repeat False))+{-# ANN resetGenN hasBlackBox #-}+{-# OPAQUE resetGenN #-}+++-- | A reset signal belonging to a domain called /dom/.+--+-- The underlying representation of resets is 'Bool'.+data Reset (dom :: Domain) = Reset (Signal dom Bool)++-- | Non-ambiguous version of 'Clash.Signal.Internal.Ambiguous.resetPolarity'+resetPolarityProxy+  :: forall dom proxy polarity+   . (KnownDomain dom, DomainResetPolarity dom ~ polarity)+  => proxy dom+  -> SResetPolarity polarity+resetPolarityProxy _proxy =+  case knownDomain @dom of+    SDomainConfiguration _dom _period _edge _sync _init polarity ->+      polarity++-- | Convert a reset to an active high reset. Has no effect if reset is already+-- an active high reset. Is unsafe because it can introduce:+--+-- * <Clash-Explicit-Signal.html#metastability meta-stability>+--+-- For asynchronous resets it is unsafe because it can cause combinational+-- loops. In case of synchronous resets it can lead to+-- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of+-- asynchronous resets.+unsafeToActiveHigh+  :: forall dom+   . KnownDomain dom+  => Reset dom+  -> Signal dom Bool+unsafeToActiveHigh (unsafeFromReset -> r) =+  case resetPolarityProxy (Proxy @dom) of+    SActiveHigh -> r+    SActiveLow -> not <$> r+{-# INLINE unsafeToActiveHigh #-}++-- | Convert a reset to an active high reset. Has no effect if reset is already+-- an active high reset. Is unsafe because it can introduce:+--+-- * <Clash-Explicit-Signal.html#metastability meta-stability>+--+-- For asynchronous resets it is unsafe because it can cause combinational+-- loops. In case of synchronous resets it can lead to+-- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of+-- asynchronous resets.+unsafeToHighPolarity+  :: forall dom+   . KnownDomain dom+  => Reset dom+  -> Signal dom Bool+unsafeToHighPolarity = unsafeToActiveHigh+{-# DEPRECATED unsafeToHighPolarity "Use 'unsafeToActiveHigh' instead. This function will be removed in Clash 1.12." #-}+{-# INLINE unsafeToHighPolarity #-}++-- | Convert a reset to an active low reset. Has no effect if reset is already+-- an active low reset. It is unsafe because it can introduce:+--+-- * <Clash-Explicit-Signal.html#metastability meta-stability>+--+-- For asynchronous resets it is unsafe because it can cause combinational+-- loops. In case of synchronous resets it can lead to+-- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of+-- asynchronous resets.+unsafeToActiveLow+  :: forall dom+   . KnownDomain dom+  => Reset dom+  -> Signal dom Bool+unsafeToActiveLow (unsafeFromReset -> r) =+  case resetPolarityProxy (Proxy @dom) of+    SActiveHigh -> not <$> r+    SActiveLow -> r+{-# INLINE unsafeToActiveLow #-}++-- | Convert a reset to an active low reset. Has no effect if reset is already+-- an active low reset. It is unsafe because it can introduce:+--+-- * <Clash-Explicit-Signal.html#metastability meta-stability>+--+-- For asynchronous resets it is unsafe because it can cause combinational+-- loops. In case of synchronous resets it can lead to+-- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of+-- asynchronous resets.+unsafeToLowPolarity+  :: forall dom+   . KnownDomain dom+  => Reset dom+  -> Signal dom Bool+unsafeToLowPolarity = unsafeToActiveLow+{-# DEPRECATED unsafeToLowPolarity "Use 'unsafeToActiveLow' instead. This function will be removed in Clash 1.12." #-}+{-# INLINE unsafeToLowPolarity #-}++-- | 'unsafeFromReset' is unsafe because it can introduce:+--+-- * <Clash-Explicit-Signal.html#metastability meta-stability>+--+-- For asynchronous resets it is unsafe because it can cause combinational+-- loops. In case of synchronous resets it can lead to+-- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of+-- asynchronous resets.+--+-- __NB__: You probably want to use 'unsafeToActiveLow' or+-- 'unsafeToActiveHigh'.+unsafeFromReset+  :: Reset dom+  -> Signal dom Bool+unsafeFromReset (Reset r) = r+{-# OPAQUE unsafeFromReset #-}+{-# ANN unsafeFromReset hasBlackBox #-}++-- | 'unsafeToReset' is unsafe. For asynchronous resets it is unsafe+-- because it can introduce combinational loops. In case of synchronous resets+-- it can lead to <Clash-Explicit-Signal.html#metastability meta-stability>+-- issues in the presence of asynchronous resets.+--+-- __NB__: You probably want to use 'unsafeFromActiveLow' or+-- 'unsafeFromActiveHigh'.+unsafeToReset+  :: KnownDomain dom+  => Signal dom Bool+  -> Reset dom+unsafeToReset r = Reset r+{-# OPAQUE unsafeToReset #-}+{-# ANN unsafeToReset hasBlackBox #-}++-- | Interpret a signal of bools as an active high reset and convert it to+-- a reset signal corresponding to the domain's setting.+--+-- For asynchronous resets it is unsafe because it can cause combinational+-- loops. In case of synchronous resets it can lead to+-- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of+-- asynchronous resets.+unsafeFromHighPolarity+  :: forall dom+   . KnownDomain dom+  => Signal dom Bool+  -- ^ Reset signal that's 'True' when active, and 'False' when inactive.+  -> Reset dom+unsafeFromHighPolarity = unsafeFromActiveHigh+{-# DEPRECATED unsafeFromHighPolarity "Use 'unsafeFromActiveHigh' instead. This function will be removed in Clash 1.12." #-}+{-# INLINE unsafeFromHighPolarity #-}++-- | Interpret a signal of bools as an active high reset and convert it to+-- a reset signal corresponding to the domain's setting.+--+-- For asynchronous resets it is unsafe because it can cause combinational+-- loops. In case of synchronous resets it can lead to+-- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of+-- asynchronous resets.+unsafeFromActiveHigh+  :: forall dom+   . KnownDomain dom+  => Signal dom Bool+  -- ^ Reset signal that's 'True' when active, and 'False' when inactive.+  -> Reset dom+unsafeFromActiveHigh r =+  unsafeToReset $+    case resetPolarityProxy (Proxy @dom) of+      SActiveHigh -> r+      SActiveLow -> not <$> r++-- | Interpret a signal of bools as an active low reset and convert it to+-- a reset signal corresponding to the domain's setting.+--+-- For asynchronous resets it is unsafe because it can cause combinational+-- loops. In case of synchronous resets it can lead to+-- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of+-- asynchronous resets.+unsafeFromLowPolarity+  :: forall dom+   . KnownDomain dom+  => Signal dom Bool+  -- ^ Reset signal that's 'False' when active, and 'True' when inactive.+  -> Reset dom+unsafeFromLowPolarity = unsafeFromActiveLow+{-# DEPRECATED unsafeFromLowPolarity "Use 'unsafeFromActiveLow' instead. This function will be removed in Clash 1.12." #-}+{-# INLINE unsafeFromLowPolarity #-}++-- | Interpret a signal of bools as an active low reset and convert it to+-- a reset signal corresponding to the domain's setting.+--+-- For asynchronous resets it is unsafe because it can cause combinational+-- loops. In case of synchronous resets it can lead to+-- <Clash-Explicit-Signal.html#metastability meta-stability> in the presence of+-- asynchronous resets.+unsafeFromActiveLow+  :: forall dom+   . KnownDomain dom+  => Signal dom Bool+  -- ^ Reset signal that's 'False' when active, and 'True' when inactive.+  -> Reset dom+unsafeFromActiveLow r =+  unsafeToReset $+    case resetPolarityProxy (Proxy @dom) of+      SActiveHigh -> not <$> r+      SActiveLow -> r++-- | Invert reset signal+invertReset :: KnownDomain dom => Reset dom -> Reset dom+invertReset = unsafeToReset . fmap not . unsafeFromReset++infixr 2 .||.+-- | The above type is a generalization for:+--+-- @+-- __(.||.)__ :: 'Clash.Signal.Signal' dom 'Bool' -> 'Clash.Signal.Signal' dom 'Bool' -> 'Clash.Signal.Signal' dom 'Bool'+-- @+--+-- It is a version of ('||') that returns a 'Clash.Signal.Signal' of 'Bool'+(.||.) :: Applicative f => f Bool -> f Bool -> f Bool+(.||.) = liftA2 (||)++infix 2 .||+-- | The above type is a generalization for:+--+-- @+-- __(.||)__ :: 'Ord' a => 'Clash.Signal.Signal' Bool -> 'Bool' -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('||') that allows comparing a @'Clash.Signal.Signal' Bool@ with a constant+-- @Bool@ and returns a 'Clash.Signal.Signal' of 'Bool'+(.||) :: Functor f => f Bool -> Bool -> f Bool+a .|| b = fmap (|| b) a++infixr 2 ||.+-- | The above type is a generalization for:+--+-- @+-- __(||.)__ :: 'Clash.Signal.Signal' 'Bool' -> 'Clash.Signal.Signal' 'Bool' -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('||') that allows comparing a constant @Bool@ with a @'Clash.Signal.Signal' Bool@+-- and returns a 'Clash.Signal.Signal' of 'Bool'+(||.) :: Functor f => Bool -> f Bool -> f Bool+a ||. b = fmap (a ||) b++infixr 3 .&&.+-- | The above type is a generalization for:+--+-- @+-- __(.&&.)__ :: 'Clash.Signal.Signal' dom 'Bool' -> 'Clash.Signal.Signal' dom 'Bool' -> 'Clash.Signal.Signal' dom 'Bool'+-- @+--+-- It is a version of ('&&') that returns a 'Clash.Signal.Signal' of 'Bool'+(.&&.) :: Applicative f => f Bool -> f Bool -> f Bool+(.&&.) = liftA2 (&&)++infixr 3 .&&+-- | The above type is a generalization for:+--+-- @+-- __(.&&)__ :: 'Clash.Signal.Signal' 'Bool' -> 'Clash.Signal.Signal' 'Bool' -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('&&') that allows comparing a @'Clash.Signal.Signal' Bool@ with a+-- constant @Bool@ and returns a 'Clash.Signal.Signal' of 'Bool'+(.&&) :: (Functor f) => f Bool -> Bool -> f Bool+(.&&) a b = fmap (&& b) a++infixr 3 &&.+-- | The above type is a generalization for:+--+-- @+-- __(&&.)__ :: 'Clash.Signal.Signal' 'Bool' -> 'Clash.Signal.Signal' 'Bool' -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('&&') that allows comparing a constant @'Bool@ with a+-- @'Clash.Signal.Signal' Bool@ and returns a 'Clash.Signal.Signal' of 'Bool'+(&&.) :: (Functor f) => Bool -> f Bool -> f Bool+(&&.) a b = fmap (a &&) b++-- [Note: register strictness annotations]+--+-- In order to produce the first (current) value of the register's output+-- signal, 'o', we don't need to know the shape of either input (enable or+-- value-in).  This is important, because both values might be produced from+-- the output in a feedback loop, so we can't know their shape (pattern+-- match) them until we have produced output.+--+-- Thus, we use lazy pattern matching to delay inspecting the shape of+-- either argument until output has been produced.+--+-- However, both arguments need to be evaluated to WHNF as soon as possible+-- to avoid a space-leak.  Below, we explicitly reduce the value-in signal+-- using 'seq' as the tail of our output signal is produced.  On the other+-- hand, because the value of the tail depends on the value of the enable+-- signal 'e', it will be forced by the 'if'/'then' statement and we don't+-- need to 'seq' it explicitly.++delay#+  :: forall dom a+   . ( KnownDomain dom+     , NFDataX a )+  => Clock dom+  -> Enable dom+  -> a+  -> Signal dom a+  -> Signal dom a+delay# (Clock dom _) (fromEnable -> en) powerUpVal0 =+    go powerUpVal1 en+  where+    powerUpVal1 :: a+    powerUpVal1 =+      case knownDomainByName dom of+        SDomainConfiguration _dom _period _edge _sync SDefined _polarity ->+          powerUpVal0+        SDomainConfiguration _dom _period _edge _sync SUnknown _polarity ->+          deepErrorX ("First value of `delay` unknown on domain " ++ show dom)++    go o (e :- es) as@(~(x :- xs)) =+      let o' = if e then x else o+      -- See [Note: register strictness annotations]+      in  o `defaultSeqX` o :- (as `seq` go o' es xs)+{-# OPAQUE delay# #-}+{-# ANN delay# hasBlackBox #-}++-- | A register with a power up and reset value. Power up values are not+-- supported on all platforms, please consult the manual of your target platform+-- and check the notes below.+--+-- Xilinx: power up values and reset values MUST be the same. If they are not,+-- the Xilinx tooling __will ignore the reset value__ and use the power up value+-- instead. Source: MIA+--+-- Intel: power up values and reset values MUST be the same. If they are not,+-- the Intel tooling __will ignore the power up value__ and use the reset value+-- instead. Source: https://www.intel.com/content/www/us/en/programmable/support/support-resources/knowledge-base/solutions/rd01072011_91.html+register#+  :: forall dom  a+   . ( KnownDomain dom+     , NFDataX a )+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> a+  -- ^ Power up value+  -> a+  -- ^ Reset value+  -> Signal dom a+  -> Signal dom a+register# clk@(Clock dom _) rst ena powerUpVal resetVal =+  case knownDomainByName dom of+    SDomainConfiguration _name _period _edge SSynchronous _init _polarity ->+      syncRegister# clk rst ena powerUpVal resetVal+    SDomainConfiguration _name _period _edge SAsynchronous _init _polarity ->+      asyncRegister# clk rst ena powerUpVal resetVal+{-# OPAQUE register# #-}+{-# ANN register# hasBlackBox #-}++-- | Acts like 'id' if given domain allows powerup values, but returns a+-- value constructed with 'deepErrorX' otherwise.+registerPowerup#+  :: forall dom a+   . ( KnownDomain dom+     , NFDataX a+     , HasCallStack )+  => Clock dom+  -> a+  -> a+registerPowerup# (Clock dom _) a =+  case knownDomainByName dom of+    SDomainConfiguration _dom _period _edge _sync SDefined _polarity -> a+    SDomainConfiguration _dom _period _edge _sync SUnknown _polarity ->+      deepErrorX ("First value of register undefined on domain " ++ show dom)++-- | Version of 'register#' that simulates a register on an asynchronous+-- domain. Is synthesizable.+asyncRegister#+  :: forall dom  a+   . ( KnownDomain dom+     , NFDataX a )+  => Clock dom+  -- ^ Clock signal+  -> Reset dom+  -- ^ Reset signal+  -> Enable dom+  -- ^ Enable signal+  -> a+  -- ^ Power up value+  -> a+  -- ^ Reset value+  -> Signal dom a+  -> Signal dom a+asyncRegister# clk (unsafeToActiveHigh -> rst) (fromEnable -> ena) initVal resetVal =+  go (registerPowerup# clk initVal) rst ena+ where+  go o (r :- rs) enas@(~(e :- es)) as@(~(x :- xs)) =+    let oR = if r then resetVal else o+        oE = if r then resetVal else (if e then x else o)+        -- [Note: register strictness annotations]+    in  o `defaultSeqX` oR :- (as `seq` enas `seq` go oE rs es xs)+{-# OPAQUE asyncRegister# #-}+{-# ANN asyncRegister# hasBlackBox #-}++-- | Version of 'register#' that simulates a register on a synchronous+-- domain. Not synthesizable.+syncRegister#+  :: forall dom  a+   . ( KnownDomain dom+     , NFDataX a )+  => Clock dom+  -- ^ Clock signal+  -> Reset dom+  -- ^ Reset signal+  -> Enable dom+  -- ^ Enable signal+  -> a+  -- ^ Power up value+  -> a+  -- ^ Reset value+  -> Signal dom a+  -> Signal dom a+syncRegister# clk (unsafeToActiveHigh -> rst) (fromEnable -> ena) initVal resetVal =+  go (registerPowerup# clk initVal) rst ena+ where+  go o rt@(~(r :- rs)) enas@(~(e :- es)) as@(~(x :- xs)) =+    let oE = if e then x else o+        oR = if r then resetVal else oE+        -- [Note: register strictness annotations]+    in  o `defaultSeqX` o :- (rt `seq` enas `seq` as `seq` go oR rs es xs)+{-# OPAQUE syncRegister# #-}+{-# ANN syncRegister# dontTranslate #-}++-- | The above type is a generalization for:+--+-- @+-- __mux__ :: 'Clash.Signal.Signal' dom 'Bool' -> 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom a+-- @+--+-- A multiplexer. Given "@'mux' b t f@", output @t@ when @b@ is 'True', and @f@+-- when @b@ is 'False'.+mux :: Applicative f => f Bool -> f a -> f a -> f a+mux = liftA3 (\b t f -> if b then t else f)+{-# INLINE mux #-}++-- | A 'mux' extension muxing between a given argument and an updated version.+-- Given @apEn b f s@, output an updated version of @s@ (i.e., @f s@)+-- when @b@ is 'True', but return it unchanged (i.e., @s@) when @b@ is 'False'.+apEn :: Applicative f => f Bool -> (a -> a) -> f a -> f a+apEn cond upd x = mux cond (upd <$> x) x+{-# INLINE apEn #-}++infix 4 .==.+-- | The above type is a generalization for:+--+-- @+-- __(.==.)__ :: 'Eq' a => 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom 'Bool'+-- @+--+-- It is a version of ('==') that returns a 'Clash.Signal.Signal' of 'Bool'+(.==.) :: (Eq a, Applicative f) => f a -> f a -> f Bool+(.==.) = liftA2 (==)++infix 4 .==+-- | The above type is a generalization for:+--+-- @+-- __(.==)__ :: 'Eq' a => 'Clash.Signal.Signal' a -> a -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('==') that allows comparing a @'Clash.Signal.Signal' a@ with a+-- constant @a@ and returns a 'Clash.Signal.Signal' of 'Bool'+(.==) :: (Eq a, Functor f) => f a -> a -> f Bool+(.==) a b = fmap (==b) a++infix 4 ==.+-- | The above type is a generalization for:+--+-- @+-- __(==.)__ :: 'Eq' a => a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('==') that allows comparing a @'Clash.Signal.Signal' a@ with a+-- constant @a@ and returns a 'Clash.Signal.Signal' of 'Bool'+(==.) :: (Eq a, Functor f) => a -> f a -> f Bool+(==.) a b = fmap (a==) b++infix 4 ./=.+-- | The above type is a generalization for:+--+-- @+-- __(./=.)__ :: 'Eq' a => 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom 'Bool'+-- @+--+-- It is a version of ('/=') that returns a 'Clash.Signal.Signal' of 'Bool'+(./=.) :: (Eq a, Applicative f) => f a -> f a -> f Bool+(./=.) = liftA2 (/=)++infix 4 ./=+-- | The above type is a generalization for:+--+-- @+-- __(./=)__ :: 'Eq' a => 'Clash.Signal.Signal' a -> a -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('/=') that allows comparing a @'Clash.Signal.Signal' a@ with a+-- constant @a@ and returns a 'Clash.Signal.Signal' of 'Bool'+(./=) :: (Eq a, Functor f) => f a -> a -> f Bool+(./=) a b = fmap (/=b) a++infix 4 /=.+-- | The above type is a generalization for:+--+-- @+-- __(/=.)__ :: 'Eq' a => a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('/=') that allows comparing a @'Clash.Signal.Signal' a@ with a+-- constant @a@ and returns a 'Clash.Signal.Signal' of 'Bool'++(/=.) :: (Eq a, Functor f) => a -> f a -> f Bool+(/=.) a b = fmap (a /=) b++infix 4 .<.+-- | The above type is a generalization for:+--+-- @+-- __(.<.)__ :: 'Ord' a => 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom 'Bool'+-- @+--+-- It is a version of ('<') that returns a 'Clash.Signal.Signal' of 'Bool'+(.<.) :: (Ord a, Applicative f) => f a -> f a -> f Bool+(.<.) = liftA2 (<)++infix 4 <.+-- | The above type is a generalization for:+--+-- @+-- __(<.)__ :: 'Ord' a => a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('<') that allows comparing a @'Clash.Signal.Signal' a@ with a constant+-- @a@ and returns a 'Clash.Signal.Signal' of 'Bool'+(<.) :: (Ord a, Functor f) => a -> f a -> f Bool+(<.) a b = fmap (a<) b++infix 4 .<+-- | The above type is a generalization for:+--+-- @+-- __(.<)__ :: 'Ord' a => 'Clash.Signal.Signal' a -> a -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('<') that allows comparing a @'Clash.Signal.Signal' a@ with a constant+-- @a@ and returns a 'Clash.Signal.Signal' of 'Bool'+(.<) :: (Ord a, Functor f) => f a -> a -> f Bool+(.<) a b = fmap (<b) a++infix 4 .<=.+-- | The above type is a generalization for:+--+-- @+-- __(.<=.)__ :: 'Ord' a => 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom 'Bool'+-- @+--+-- It is a version of ('GHC.TypeNats.<=') that returns a 'Clash.Signal.Signal' of 'Bool'+(.<=.) :: (Ord a, Applicative f) => f a -> f a -> f Bool+(.<=.) = liftA2 (<=)++infix 4 .<=+-- | The above type is a generalization for:+--+-- @+-- __(.<=)__ :: 'Ord' a => 'Clash.Signal.Signal' a -> a -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('GHC.TypeNats.<=') that allows comparing a @'Clash.Signal.Signal' a@ with a constant+-- @a@ and returns a 'Clash.Signal.Signal' of 'Bool'+(.<=) :: (Ord a, Functor f) => f a -> a -> f Bool+(.<=) a b = fmap (<=b) a++infix 4 <=.+-- | The above type is a generalization for:+--+-- @+-- __(<=.)__ :: 'Ord' a => a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('GHC.TypeNats.<=') that allows comparing a @'Clash.Signal.Signal' a@ with a constant+-- @a@ and returns a 'Clash.Signal.Signal' of 'Bool'+(<=.) :: (Ord a, Functor f) => a -> f a -> f Bool+(<=.) a b = fmap (a<=)b++infix 4 .>.+-- | The above type is a generalization for:+--+-- @+-- __(.>.)__ :: 'Ord' a => 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom 'Bool'+-- @+--+-- It is a version of ('>') that returns a 'Clash.Signal.Signal' of 'Bool'+(.>.) :: (Ord a, Applicative f) => f a -> f a -> f Bool+(.>.) = liftA2 (>)++infix 4 .>+-- | The above type is a generalization for:+--+-- @+-- __(.>)__ :: 'Ord' a => 'Clash.Signal.Signal' a -> a -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('>') that allows comparing a @'Clash.Signal.Signal' a@ with a constant+-- @a@ and returns a 'Clash.Signal.Signal' of 'Bool'+(.>) :: (Ord a, Functor f) => f a -> a -> f Bool+(.>) a b = fmap (>b) a++infix 4 >.+-- | The above type is a generalization for:+--+-- @+-- __(>.)__ :: 'Ord' a => a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('>') that allows comparing a @'Clash.Signal.Signal' a@ with a constant+-- @a@ and returns a 'Clash.Signal.Signal' of 'Bool'+(>.) :: (Ord a, Functor f) => a -> f a -> f Bool+(>.) a b = fmap (a>) b++infix 4 .>=.+-- | The above type is a generalization for:+--+-- @+-- __(.>=.)__ :: 'Ord' a => 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom a -> 'Clash.Signal.Signal' dom 'Bool'+-- @+--+--  It is a version of ('>=') that returns a 'Clash.Signal.Signal' of 'Bool'+(.>=.) :: (Ord a, Applicative f) => f a -> f a -> f Bool+(.>=.) = liftA2 (>=)++infix 4 .>=+-- | The above type is a generalization for:+--+-- @+-- __(.>=)__ :: 'Ord' a => 'Clash.Signal.Signal' a -> a -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('>=') that allows comparing a @'Clash.Signal.Signal' a@ with a constant+-- @a@ and returns a 'Clash.Signal.Signal' of 'Bool'+(.>=) :: (Ord a, Functor f) => f a -> a -> f Bool+(.>=) a b = fmap (>=b) a++infix 4 >=.+-- | The above type is a generalization for:+--+-- @+-- __(>=.)__ :: 'Ord' a => a -> 'Clash.Signal.Signal' a -> 'Clash.Signal.Signal' 'Bool'+-- @+--+-- It is a version of ('>=') that allows comparing a @'Clash.Signal.Signal' a@ with a constant+-- @a@ and returns a 'Clash.Signal.Signal' of 'Bool'+(>=.) :: (Ord a, Functor f) => a -> f a -> f Bool+(>=.) a b = fmap (a>=) b++instance Fractional a => Fractional (Signal dom a) where+  (/)          = liftA2 (/)+  recip        = fmap recip+  fromRational = signal# . fromRational++instance Arbitrary a => Arbitrary (Signal dom a) where+  arbitrary = liftA2 (:-) arbitrary arbitrary++instance CoArbitrary a => CoArbitrary (Signal dom a) where+  coarbitrary xs gen = do+    n <- arbitrary+    coarbitrary (take (abs n) (sample_lazy xs)) gen++-- | The above type is a generalization for:+--+-- @+-- __testFor__ :: 'Int' -> 'Clash.Signal.Signal' dom Bool -> 'Property'+-- @+--+-- @testFor n s@ tests the signal @s@ for @n@ cycles.+--+-- __NB__: This function is not synthesizable+testFor :: Foldable f => Int -> f Bool -> Property+testFor n = property . and . take n . sample++-- * List \<-\> Signal conversion (not synthesizable)++-- | The above type is a generalization for:+--+-- @+-- __sample__ :: 'Clash.Signal.Signal' dom a -> [a]+-- @+--+-- Get an infinite list of samples from a 'Clash.Signal.Signal'+--+-- The elements in the list correspond to the values of the 'Clash.Signal.Signal'+-- at consecutive clock cycles+--+-- > sample s == [s0, s1, s2, s3, ...+--+-- __NB__: This function is not synthesizable+sample :: (Foldable f, NFDataX a) => f a -> [a]+sample = foldr (\a b -> deepseqX a (a : b)) []++-- | The above type is a generalization for:+--+-- @+-- __sampleN__ :: Int -> 'Clash.Signal.Signal' dom a -> [a]+-- @+--+-- Get a list of @n@ samples from a 'Clash.Signal.Signal'+--+-- The elements in the list correspond to the values of the 'Clash.Signal.Signal'+-- at consecutive clock cycles+--+-- > sampleN 3 s == [s0, s1, s2]+--+-- __NB__: This function is not synthesizable+sampleN :: (Foldable f, NFDataX a) => Int -> f a -> [a]+sampleN n = take n . sample++-- | Create a 'Clash.Signal.Signal' from a list+--+-- Every element in the list will correspond to a value of the signal for one+-- clock cycle.+--+-- >>> sampleN 2 (fromList [1,2,3,4,5])+-- [1,2]+--+-- __NB__: This function is not synthesizable+fromList :: NFDataX a => [a] -> Signal dom a+fromList = Prelude.foldr (\a b -> deepseqX a (a :- b)) (errorX "finite list")++-- * Simulation functions (not synthesizable)++-- | Simulate a (@'Clash.Signal.Signal' dom1 a -> 'Clash.Signal.Signal' dom2 b@) function+-- given a list of samples of type @a@+--+-- >>> simulate (register systemClockGen resetGen enableGen 8) [1, 1, 2, 3]+-- [8,8,1,2,3...+-- ...+--+-- __NB__: This function is not synthesizable+simulate :: (NFDataX a, NFDataX b) => (Signal dom1 a -> Signal dom2 b) -> [a] -> [b]+simulate f = sample . f . fromList++-- | The above type is a generalization for:+--+-- @+-- __sample__ :: 'Clash.Signal.Signal' dom a -> [a]+-- @+--+-- Get an infinite list of samples from a 'Clash.Signal.Signal'+--+-- The elements in the list correspond to the values of the 'Clash.Signal.Signal'+-- at consecutive clock cycles+--+-- > sample s == [s0, s1, s2, s3, ...+--+-- __NB__: This function is not synthesizable+sample_lazy :: Foldable f => f a -> [a]+sample_lazy = foldr (:) []++-- | The above type is a generalization for:+--+-- @+-- __sampleN__ :: Int -> 'Clash.Signal.Signal' dom a -> [a]+-- @+--+-- Get a list of @n@ samples from a 'Clash.Signal.Signal'+--+-- The elements in the list correspond to the values of the 'Clash.Signal.Signal'+-- at consecutive clock cycles+--+-- > sampleN 3 s == [s0, s1, s2]+--+-- __NB__: This function is not synthesizable+sampleN_lazy :: Foldable f => Int -> f a -> [a]+sampleN_lazy n = take n . sample_lazy++-- | Create a 'Clash.Signal.Signal' from a list+--+-- Every element in the list will correspond to a value of the signal for one+-- clock cycle.+--+-- >>> sampleN 2 (fromList [1,2,3,4,5] :: Signal System Int)+-- [1,2]+--+-- __NB__: This function is not synthesizable+fromList_lazy :: [a] -> Signal dom a+fromList_lazy = Prelude.foldr (:-) (error "finite list")++-- * Simulation functions (not synthesizable)++-- | Simulate a (@'Clash.Signal.Signal' dom1 a -> 'Clash.Signal.Signal' dom2 b@) function+-- given a list of samples of type @a@+--+-- >>> simulate (register systemClockGen resetGen enableGen 8) [1, 1, 2, 3]+-- [8,8,1,2,3...+-- ...+--+-- __NB__: This function is not synthesizable+simulate_lazy :: (Signal dom1 a -> Signal dom2 b) -> [a] -> [b]+simulate_lazy f = sample_lazy . f . fromList_lazy++-- | Calculate the period in __ps__, given a frequency in __Hz__+--+-- I.e., to calculate the clock period for a circuit to run at 240 MHz we get+--+-- >>> hzToPeriod 240e6+-- 4166+--+-- If the value @hzToPeriod@ is applied to is not of the type 'Ratio'+-- 'Natural', you can use @hzToPeriod ('realToFrac' f)@. Note that if @f@ is+-- negative, @realToFrac@ will give an @'Control.Exception.Underflow' ::+-- t'Control.Exception.ArithException'@ without a call stack, making debugging+-- cumbersome.+--+-- Before Clash 1.8, this function always returned a 'Natural'. To get the old+-- behavior of this function, use a type application:+--+-- >>> hzToPeriod @Natural 240e6+-- 4166+--+-- * __NB__: This function is not synthesizable+-- * __NB__: This function is lossy. I.e., @periodToHz . hzToPeriod /= id@.+hzToPeriod :: (HasCallStack, Integral a) => Ratio Natural -> a+hzToPeriod freq+  | freq > 0  = floor ((1.0 / freq) / 1e-12)+  | otherwise = withFrozenCallStack $ error "Zero frequency"++-- | Calculate the period in __fs__, given a frequency in __Hz__+--+-- I.e., to calculate the clock period for a circuit to run at 240 MHz we get+--+-- >>> hzToFs 240e6+-- Femtoseconds 4166666+--+-- If the value @hzToFs@ is applied to is not of the type 'Ratio' 'Natural', you+-- can use @hzToFs ('realToFrac' f)@. Note that if @f@ is negative, @realToFrac@+-- will give an @'Control.Exception.Underflow' ::+-- t'Control.Exception.ArithException'@ without a call stack, making debugging+-- cumbersome.+--+-- * __NB__: This function is not synthesizable+-- * __NB__: This function is lossy. I.e.,  @fsToHz . hzToFs /= id@.+hzToFs :: HasCallStack => Ratio Natural -> Femtoseconds+hzToFs freq+  | freq > 0  = Femtoseconds (floor ((1.0 / freq) / 1e-15))+  | otherwise = withFrozenCallStack $ error "Zero frequency"++-- | Calculate the frequency in __Hz__, given the period in __ps__+--+-- I.e., to calculate the clock frequency of a clock with a period of 5000 ps:+--+-- >>> periodToHz 5000+-- 2.0e8+--+-- Note that if @p@ in @periodToHz ('fromIntegral' p)@ is negative,+-- @fromIntegral@ will give an @'Control.Exception.Underflow' ::+-- t'Control.Exception.ArithException'@ without a call stack, making debugging+-- cumbersome.+--+-- Before Clash 1.8, this function always returned a 'Ratio'+-- 'Natural'. To get the old behavior of this function, use a type application:+--+-- >>> periodToHz @(Ratio Natural) 5000+-- 200000000 % 1+--+-- __NB__: This function is not synthesizable+periodToHz :: (HasCallStack, Fractional a) => Natural -> a+periodToHz period+  | period > 0 = fromRational $ 1.0 / (fromIntegral period * 1e-12)+  | otherwise  = withFrozenCallStack $ error "Zero period"++-- | Calculate the frequency in __Hz__, given the period in __fs__+--+-- I.e., to calculate the clock frequency of a clock with a period of 5000 fs:+--+-- >>> fsToHz (Femtoseconds 5000)+-- 2.0e11+--+-- __NB__: This function is not synthesizable+fsToHz :: (HasCallStack, Fractional a) => Femtoseconds -> a+fsToHz (Femtoseconds period)+  | period > 0 = fromRational $ 1.0 / (fromIntegral period * 1e-15)+  | otherwise  = withFrozenCallStack $ error "Zero period"++-- | Build an 'Automaton' from a function over 'Signal's.+--+-- __NB__: Consumption of continuation of the 'Automaton' must be affine; that+-- is, you can only apply the continuation associated with a particular element+-- at most once.+signalAutomaton ::+  forall dom a b .+  (Signal dom a -> Signal dom b) -> Automaton (->) a b+signalAutomaton dut = Automaton $ \input0 -> unsafePerformIO $ do+  inputRefs <- infiniteRefList Nothing+  let inputs = input0 :- fmap readInput inputRefs+      readInput ref = unsafePerformIO $ do+        val <- readIORef ref+        case val of+          Nothing -> fail "signalAutomaton: non-affine use of continuation"+          Just x  -> return x++  let go (inRef :- inRefs) (out :- rest) = do+        let next :: Automaton (->) a b+            next = Automaton $ \i -> unsafePerformIO $ do+              old <- atomicModifyIORef inRef (\old -> (Just i,old))+              case old of+                Nothing -> return ()+                Just _  -> fail "signalAutomaton: non-affine use of continuation"+              unsafeInterleaveIO (go inRefs rest)+        return (out, next)++  go inputRefs (dut inputs)+{-# OPAQUE signalAutomaton #-}++infiniteRefList :: a -> IO (Signal dom (IORef a))+infiniteRefList val = go+ where+  go = do+    rest <- unsafeInterleaveIO go+    ref  <- newIORef val+    return (ref :- rest)++data ClockAB+  -- | Clock edge A produced+  = ClockA+  -- | Clock edge B produced+  | ClockB+  -- | Clock edges coincided+  | ClockAB+  deriving (Generic, Eq, Show, NFData, NFDataX)++-- | Given two clocks, produce a list of clock ticks indicating which clock+-- (or both) ticked. Can be used in components handling multiple clocks, such+-- as @unsafeSynchronizer@ or dual clock FIFOs.+--+-- If your primitive does not care about coincided clock edges, it should - by+-- convention - replace it by @ClockB:ClockA:@.+clockTicks ::+  (KnownDomain domA, KnownDomain domB) =>+  Clock domA ->+  Clock domB ->+  [ClockAB]+clockTicks clkA clkB = clockTicksEither (toEither clkA) (toEither clkB)+ where+  toEither ::+    forall dom.+    KnownDomain dom =>+    Clock dom ->+    Either Int64 (Signal dom Int64)+  toEither (Clock _ maybePeriods)+    | Just periods <- maybePeriods =+        Right (unFemtosecondsSignal periods)+    | SDomainConfiguration{sPeriod} <- knownDomain @dom =+        -- Convert to femtoseconds - dynamic clocks use them+        Left (1000 * snatToNum sPeriod)++  -- Coerce whole signal instead of `fmap coerce` to prevent useless constructor+  -- packing and unpacking.+  unFemtosecondsSignal :: forall dom . Signal dom Femtoseconds -> Signal dom Int64+  unFemtosecondsSignal = coerce++-- | Given two clock periods, produce a list of clock ticks indicating which clock+-- (or both) ticked. Can be used in components handling multiple clocks, such+-- as @unsafeSynchronizer@ or dual clock FIFOs.+--+-- If your primitive does not care about coincided clock edges, it should - by+-- convention - replace it by @ClockB:ClockA:@.+clockTicksEither ::+  Either Int64 (Signal domA Int64) ->+  Either Int64 (Signal domB Int64) ->+  [ClockAB]+clockTicksEither clkA clkB =+  case (clkA, clkB) of+    (Left  tA, Left  tB) | tA == tB -> repeat ClockAB+    (Left  tA, Left  tB) -> goStatic 0 tA tB+    (Right tA, Right tB) -> goDynamic 0 tA tB+    (Left  tA, Right tB) -> clockTicksEither (Right (pure tA)) (Right tB)+    (Right tA, Left  tB) -> clockTicksEither (Right tA) (Right (pure tB))+ where+  -- Given+  --   tAbsA = absolute time of next active edge of clock A+  --   tAbsB = absolute time of next active edge of clock B+  -- relativeTime is defined as relativeTime = tAbsB - tAbsA+  --+  -- Put differently, relative time 0 points at the next active edge of+  -- clock A, and relativeTime points at the next active edge of clock B.++  goStatic :: Int64 -> Int64 -> Int64 -> [ClockAB]+  goStatic relativeTime tA tB =+    case compare relativeTime 0 of+      LT -> ClockB  : goStatic (relativeTime + tB)      tA tB+      EQ -> ClockAB : goStatic (relativeTime - tA + tB) tA tB+      GT -> ClockA  : goStatic (relativeTime - tA)      tA tB++  goDynamic :: Int64 -> Signal domA Int64 -> Signal domB Int64 -> [ClockAB]+  goDynamic relativeTime tsA@(~(tA :- tsA0)) tsB@(~(tB :- tsB0)) =+    -- Even though we lazily match on the signal's constructor, this shouldn't+    -- build up a significant chain of chunks as 'relativeTime' gets evaluated+    -- every iteration.+    case compare relativeTime 0 of+      LT -> ClockB  : goDynamic (relativeTime + tB)      tsA  tsB0+      EQ -> ClockAB : goDynamic (relativeTime - tA + tB) tsA0 tsB0+      GT -> ClockA  : goDynamic (relativeTime - tA)      tsA0 tsB
src/Clash/Signal/Internal/Ambiguous.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE TypeApplications       #-}-{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}  module Clash.Signal.Internal.Ambiguous   ( knownVDomain@@ -23,9 +23,9 @@   => SNat period clockPeriod =   case knownDomain @dom of-    SDomainConfiguration _dom period _edge _sync _init _polarity ->-      period-{-# NOINLINE clockPeriod #-}+    SDomainConfiguration{sPeriod} ->+      sPeriod+{-# OPAQUE clockPeriod #-} -- @NOINLINE: https://github.com/clash-lang/clash-compiler/issues/662  -- | Get 'ActiveEdge' from a KnownDomain context. Example usage:@@ -43,9 +43,9 @@   => SActiveEdge edge activeEdge =   case knownDomain @dom of-    SDomainConfiguration _dom _period edge _sync _init _polarity ->-      edge-{-# NOINLINE activeEdge #-}+    SDomainConfiguration{sActiveEdge} ->+      sActiveEdge+{-# OPAQUE activeEdge #-} -- @NOINLINE: https://github.com/clash-lang/clash-compiler/issues/662  -- | Get 'ResetKind' from a KnownDomain context. Example usage:@@ -63,9 +63,9 @@   => SResetKind sync resetKind =   case knownDomain @dom of-    SDomainConfiguration _dom _period _edge sync _init _polarity ->-      sync-{-# NOINLINE resetKind #-}+    SDomainConfiguration{sResetKind} ->+      sResetKind+{-# OPAQUE resetKind #-} -- @NOINLINE: https://github.com/clash-lang/clash-compiler/issues/662  -- | Get 'InitBehavior' from a KnownDomain context. Example usage:@@ -83,9 +83,9 @@   => SInitBehavior init initBehavior =   case knownDomain @dom of-    SDomainConfiguration _dom _period _edge _sync init_ _polarity ->-      init_-{-# NOINLINE initBehavior #-}+    SDomainConfiguration{sInitBehavior} ->+      sInitBehavior+{-# OPAQUE initBehavior #-} -- @NOINLINE: https://github.com/clash-lang/clash-compiler/issues/662  -- | Get 'ResetPolarity' from a KnownDomain context. Example usage:@@ -103,9 +103,9 @@   => SResetPolarity polarity resetPolarity =   case knownDomain @dom of-    SDomainConfiguration _dom _period _edge _sync _init polarity ->-      polarity-{-# NOINLINE resetPolarity #-}+    SDomainConfiguration{sResetPolarity} ->+      sResetPolarity+{-# OPAQUE resetPolarity #-} -- @NOINLINE: https://github.com/clash-lang/clash-compiler/issues/662  -- | Like 'knownDomain but yields a 'VDomainConfiguration'. Should only be used
src/Clash/Signal/Trace.hs view
@@ -1,8 +1,9 @@ {-| Copyright  :  (C) 2018, Google Inc.                   2019, Myrtle Software Ltd+                  2022-2026, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  Utilities for tracing signals and dumping them in various ways. Example usage: @@ -44,17 +45,12 @@       writeFile "mainCounter.vcd" contents @ -}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}@@ -78,21 +74,32 @@    -- * Internal   -- ** Types+  , VCDFile(..)+  , VCDTime+  , IDCode+  , TimeUnit(..)+  , DeclarationCommand(..)+  , Var(..)+  , SimulationCommand(..)+  , ValueChange(..)   , Period   , Changed   , Value   , Width   , TraceMap+  , TypeRepBS   -- ** Functions   , traceSignal#   , traceVecSignal#   , dumpVCD#-  , dumpVCD##+  , dumpVCD0#+  , dumpVCD1#   , waitForTraces#   , traceMap#   ) where  -- Clash:+import           Clash.Annotations.Primitive (hasBlackBox) import           Clash.Signal.Internal (fromList) import           Clash.Signal   (KnownDomain(..), SDomainConfiguration(..), Signal, bundle, unbundle)@@ -100,7 +107,7 @@ import qualified Clash.Sized.Vector    as Vector import           Clash.Class.BitPack   (BitPack, BitSize, pack, unpack) import           Clash.Promoted.Nat    (snatToNum, SNat(..))-import           Clash.Signal.Internal (sample)+import           Clash.Signal.Internal (Signal ((:-)), sample) import           Clash.XException      (deepseqX, NFDataX) import           Clash.Sized.Internal.BitVector   (BitVector(BV))@@ -114,12 +121,17 @@ import           Data.Char             (ord, chr) import           Data.IORef   (IORef, atomicModifyIORef', atomicWriteIORef, newIORef, readIORef)-import           Data.List             (foldl1', foldl', unzip4, transpose)+#if !MIN_VERSION_base(4,20,0)+import           Data.List             (foldl')+#endif+import           Data.List             (foldl1', unzip4, transpose, uncons)+import           Data.List.Extra       (snoc) import qualified Data.Map.Strict       as Map import           Data.Maybe            (fromMaybe, catMaybes) import qualified Data.Text             as Text import           Data.Time.Clock       (UTCTime, getCurrentTime) import           Data.Time.Format      (formatTime, defaultTimeLocale)+import           GHC.Natural           (Natural) import           GHC.Stack             (HasCallStack) import           GHC.TypeLits          (KnownNat, type (+)) import           System.IO.Unsafe      (unsafePerformIO)@@ -132,7 +144,7 @@  type Period   = Int type Changed  = Bool-type Value    = (Integer, Integer) -- (Mask, Value)+type Value    = (Natural, Natural) -- (Mask, Value) type Width    = Int  -- | Serialized TypeRep we need to store for dumpReplayable / replay@@ -143,11 +155,10 @@ -- | Map of traces used by the non-internal trace and dumpvcd functions. traceMap# :: IORef TraceMap traceMap# = unsafePerformIO (newIORef Map.empty)-{-# NOINLINE traceMap# #-}+{-# OPAQUE traceMap# #-}  mkTrace   :: HasCallStack-  => KnownNat (BitSize a)   => BitPack a   => NFDataX a   => Signal dom a@@ -160,8 +171,7 @@ -- was previously registered. traceSignal#   :: forall dom a-   . ( KnownNat (BitSize a)-     , BitPack a+   . ( BitPack a      , NFDataX a      , Typeable a )   => IORef TraceMap@@ -187,16 +197,15 @@           m       , signal)  where-  width = snatToNum (SNat @ (BitSize a))-{-# NOINLINE traceSignal# #-}+  width = snatToNum (SNat @(BitSize a))+{-# OPAQUE traceSignal# #-}  -- | Trace a single vector signal: each element in the vector will show up as -- a different trace. If the trace name already exists, this function will emit -- an error. traceVecSignal#   :: forall dom n a-   . ( KnownNat (BitSize a)-     , KnownNat n+   . ( KnownNat n      , BitPack a      , NFDataX a      , Typeable a )@@ -215,18 +224,17 @@  where   trace' i s = traceSignal# traceMap period (name' i) s   name' i    = vecTraceName ++ "_" ++ show i-{-# NOINLINE traceVecSignal# #-}+{-# OPAQUE traceVecSignal# #-}  -- | Trace a single signal. Will emit an error if a signal with the same name -- was previously registered. ----- __NB__ Works correctly when creating VCD files from traced signal in+-- __NB__: Works correctly when creating VCD files from traced signal in -- multi-clock circuits. However 'traceSignal1' might be more convenient to -- use when the domain of your circuit is polymorphic. traceSignal   :: forall dom  a    . ( KnownDomain dom-     , KnownNat (BitSize a)      , BitPack a      , NFDataX a      , Typeable a )@@ -237,21 +245,21 @@   -> Signal dom a traceSignal traceName signal =   case knownDomain @dom of-    SDomainConfiguration _dom period _edge _reset _init _polarity ->+    SDomainConfiguration{sPeriod} ->       unsafePerformIO $-        traceSignal# traceMap# (snatToNum period) traceName signal-{-# NOINLINE traceSignal #-}+        traceSignal# traceMap# (snatToNum sPeriod) traceName signal+{-# OPAQUE traceSignal #-}+{-# ANN traceSignal hasBlackBox #-}  -- | Trace a single signal. Will emit an error if a signal with the same name -- was previously registered. ----- __NB__ associates the traced signal with a clock period of /1/, which+-- __NB__: Associates the traced signal with a clock period of /1/, which -- results in incorrect VCD files when working with circuits that have -- multiple clocks. Use 'traceSignal' when working with circuits that have -- multiple clocks. traceSignal1-  :: ( KnownNat (BitSize a)-     , BitPack a+  :: ( BitPack a      , NFDataX a      , Typeable a )   => String@@ -261,19 +269,19 @@   -> Signal dom a traceSignal1 traceName signal =   unsafePerformIO (traceSignal# traceMap# 1 traceName signal)-{-# NOINLINE traceSignal1 #-}+{-# OPAQUE traceSignal1 #-}+{-# ANN traceSignal1 hasBlackBox #-}  -- | Trace a single vector signal: each element in the vector will show up as -- a different trace. If the trace name already exists, this function will emit -- an error. ----- __NB__ Works correctly when creating VCD files from traced signal in--- multi-clock circuits. However 'traceSignal1' might be more convinient to+-- __NB__: Works correctly when creating VCD files from traced signal in+-- multi-clock circuits. However 'traceSignal1' might be more convenient to -- use when the domain of your circuit is polymorphic. traceVecSignal   :: forall dom a  n    . ( KnownDomain dom-     , KnownNat (BitSize a)      , KnownNat n      , BitPack a      , NFDataX a@@ -285,22 +293,22 @@   -> Signal dom (Vec (n+1) a) traceVecSignal traceName signal =   case knownDomain @dom of-    SDomainConfiguration _dom period _edge _reset _init _polarity ->+    SDomainConfiguration{sPeriod} ->       unsafePerformIO $-        traceVecSignal# traceMap# (snatToNum period) traceName signal-{-# NOINLINE traceVecSignal #-}+        traceVecSignal# traceMap# (snatToNum sPeriod) traceName signal+{-# OPAQUE traceVecSignal #-}+{-# ANN traceVecSignal hasBlackBox #-}  -- | Trace a single vector signal: each element in the vector will show up as -- a different trace. If the trace name already exists, this function will emit -- an error. ----- __NB__ associates the traced signal with a clock period of /1/, which+-- __NB__: Associates the traced signal with a clock period of /1/, which -- results in incorrect VCD files when working with circuits that have -- multiple clocks. Use 'traceSignal' when working with circuits that have -- multiple clocks. traceVecSignal1-  :: ( KnownNat (BitSize a)-     , KnownNat n+  :: ( KnownNat n      , BitPack a      , NFDataX a      , Typeable a )@@ -311,8 +319,53 @@   -> Signal dom (Vec (n+1) a) traceVecSignal1 traceName signal =   unsafePerformIO $ traceVecSignal# traceMap# 1 traceName signal-{-# NOINLINE traceVecSignal1 #-}+{-# OPAQUE traceVecSignal1 #-}+{-# ANN traceVecSignal1 hasBlackBox #-} +data VCDFile = VCDFile [DeclarationCommand] [SimulationCommand]+  deriving (Show)++type VCDTime = Int++type IDCode = String++data TimeUnit = S | MS | US | NS | PS | FS++instance Show TimeUnit where+  showsPrec _ S = ('s' :)+  showsPrec _ MS = showString "ms"+  showsPrec _ US = showString "us"+  showsPrec _ NS = showString "ns"+  showsPrec _ PS = showString "ps"+  showsPrec _ FS = showString "fs"++data DeclarationCommand+  = TimeScale VCDTime TimeUnit+  | Vars [Var]+  deriving (Show)++data Var+  = Var+  { varSize :: Width+  , varIDCode :: IDCode+  , varReference :: String+  }+  deriving (Show)++data SimulationCommand+  = DumpVars [ValueChange]+  | SimulationTime VCDTime+  | SimulationValueChange ValueChange+  deriving (Show, Eq)++data ValueChange+  = ValueChange+  { changeSize :: Width+  , changeIDCode :: IDCode+  , changeValue :: Value+  }+  deriving (Show, Eq)+ iso8601Format :: UTCTime -> String iso8601Format = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" @@ -330,45 +383,43 @@ printable :: Char -> Bool printable (ord -> c) = 33 <= c && c <= 126 --- | Same as @dumpVCD@, but supplied with a custom tracemap and a custom timestamp-dumpVCD##+-- | Worker for @dumpVCD0#@, containing all the actual work and producing a+-- 'VCDFile' representation of the VCD output+dumpVCD1#   :: (Int, Int)   -- ^ (offset, number of samples)   -> TraceMap-  -> UTCTime-  -> Either String Text.Text-dumpVCD## (offset, cycles) traceMap now+  -> Either String VCDFile+dumpVCD1# (offset, cycles) traceMap   | offset < 0 =       error $ "dumpVCD: offset was " ++ show offset ++ ", but cannot be negative."   | cycles < 0 =       error $ "dumpVCD: cycles was " ++ show cycles ++ ", but cannot be negative."   | null traceMap =       error $ "dumpVCD: no traces found. Extend the given trace names."-  | Map.size traceMap > 126 - 33 =-      Left $ "Tracemap contains more than 93 traces, which is not supported by VCD."-  | not $ null $ offensiveNames =-      Left $ unwords [ "Trace '" ++ head offensiveNames ++ "' contains"+  | (nm:_) <- offensiveNames =+      Left $ unwords [ "Trace '" ++ nm ++ "' contains"                      , "non-printable ASCII characters, which is not"                      , "supported by VCD." ]   | otherwise =-      Right $ Text.unlines [ Text.unwords headerDate-                           , Text.unwords headerVersion-                           , Text.unwords headerComment-                           , Text.pack $ unwords headerTimescale-                           , "$scope module logic $end"-                           , Text.intercalate "\n" headerWires-                           , "$upscope $end"-                           , "$enddefinitions $end"-                           , "#0"-                           , "$dumpvars"-                           , Text.intercalate "\n" initValues-                           , "$end"-                           , Text.intercalate "\n" $ catMaybes bodyParts-                           ]+      Right+        ( VCDFile+            [ TimeScale timescale PS+            , Vars [Var w l n | (w, l, n) <- zip3 widths labels traceNames]+            ]+            ( [ SimulationTime 0+              , DumpVars initValues+              ]+                ++ concat (catMaybes bodyParts)+            )+        )  where   offensiveNames = filter (any (not . printable)) traceNames -  labels = map chr [33..126]+  -- Generate labels in the pattern a,b,c,aa,ab,ac,ba,bb,bc,ca,cb,cc,aaa,...+  labels = concatMap (\s -> map (snoc s) alphabet) ([]: labels)+   where+    alphabet = map chr [33..126]    timescale = foldl1' gcd (Map.keys periodMap)   periodMap = toPeriodMap traceMap@@ -393,63 +444,126 @@    periods' = map (`quot` timescale) periods   valuess' = map slice $ zipWith normalize periods' valuess-  normalize period values = concatMap (replicate period) values+  normalize period (initial:values) = initial : concatMap (replicate period) values+  normalize _      []               = []   slice values = drop offset $ take cycles values -  headerDate       = ["$date", Text.pack $ iso8601Format now, "$end"]--#ifdef CABAL-  clashVer         = Data.Version.showVersion Paths_clash_prelude.version-#else-  clashVer         = "development"-#endif-  headerVersion    = ["$version", "Generated by Clash", Text.pack clashVer , "$end"]-  headerComment    = ["$comment", "No comment", "$end"]-  headerTimescale  = ["$timescale", (show timescale) ++ "ps", "$end"]-  headerWires      = [ Text.unwords $ headerWire w l n-                     | (w, l, n) <- (zip3 widths labels traceNames)]-  headerWire w l n = map Text.pack ["$var wire", show w, [l], n, "$end"]-  initValues       = map Text.pack $ zipWith ($) formatters inits+  initValues = zipWith ($) formatters inits -  formatters = zipWith format widths labels-  inits = map head valuess'+  formatters = zipWith ValueChange widths labels+  inits = map (maybe (error "dumpVCD##: empty value") fst . uncons) valuess'   tails = map changed valuess' -  -- | Format single value according to VCD spec-  format :: Width -> Char -> Value -> String-  format 1 label (0,0)   = ['0', label, '\n']-  format 1 label (0,1)   = ['1', label, '\n']-  format 1 label (1,_)   = ['x', label, '\n']-  format 1 label (mask,val) =-    error $ "Can't format 1 bit wide value for " ++ show label ++ ": value " ++ show val ++ " and mask " ++ show mask -  format n label (mask,val) =-    "b" ++ map digit (reverse [0..n-1]) ++ " " ++ [label]-    where-      digit d = case (testBit mask d, testBit val d) of-        (False,False) -> '0'-        (False,True)  -> '1'-        (True,_)      -> 'x'--  -- | Given a list of values, return a list of list of bools indicating+  -- Given a list of values, return a list of list of bools indicating   -- if a value changed. The first value is *not* included in the result.   changed :: [Value] -> [(Changed, Value)]   changed (s:ss) = zip (zipWith (/=) (s:ss) ss) ss   changed []     = [] -  bodyParts :: [Maybe Text.Text]-  bodyParts = zipWith go [0..] (map bodyPart (Data.List.transpose tails))-    where-      go :: Int -> Maybe Text.Text -> Maybe Text.Text-      go (Text.pack . show -> n) t =-        let pre = Text.concat ["#", n, "\n"] in-        fmap (Text.append pre) t+  bodyParts :: [Maybe [SimulationCommand]]+  bodyParts = zipWith go [0 ..] (map bodyPart (Data.List.transpose tails))+   where+    go :: VCDTime -> Maybe [SimulationCommand] -> Maybe [SimulationCommand]+    go t vc = fmap (SimulationTime t :) vc -  bodyPart :: [(Changed, Value)] -> Maybe Text.Text+  bodyPart :: [(Changed, Value)] -> Maybe [SimulationCommand]   bodyPart values =-    let formatted  = [(c, f v) | (f, (c,v)) <- zip formatters values]-        formatted' = map (Text.pack . snd) $ filter fst $ formatted in-    if null formatted' then Nothing else Just $ Text.intercalate "\n" formatted'+    let+      formatted = [(c, SimulationValueChange (f v)) | (f, (c, v)) <- zip formatters values]+      formatted' = map snd $ filter fst $ formatted+     in+      if null formatted' then Nothing else Just formatted' +-- | Same as @dumpVCD@, but supplied with a custom tracemap and a custom timestamp+dumpVCD0#+  :: (Int, Int)+  -- ^ (offset, number of samples)+  -> TraceMap+  -> UTCTime+  -> Either String Text.Text+dumpVCD0# slice traceMap now =+  fmap renderVCD (dumpVCD1# slice traceMap)+ where+  renderVCD (VCDFile decCmds simCmds) =+    Text.unlines $+      [ Text.unwords headerDate+      , Text.unwords headerVersion+      , Text.unwords headerComment+      ]+        ++ renderDecCmds decCmds+        ++ "$enddefinitions $end"+        : renderSimCmds simCmds++  renderDecCmds [] = []+  renderDecCmds ((TimeScale s u) : cmds) =+    [ Text.unwords+        [ "$timescale"+        , Text.pack $ shows s $ show u+        , "$end"+        ]+    ]+      ++ renderDecCmds cmds+  renderDecCmds ((Vars vs) : cmds) =+    [ "$scope module logic $end"+    , Text.intercalate "\n" (map renderVar vs)+    , "$upscope $end"+    ]+      ++ renderDecCmds cmds++  renderVar Var{..} =+    (Text.unwords . map Text.pack)+      [ "$var wire"+      , show varSize+      , varIDCode+      , varReference+      , "$end"+      ]++  renderSimCmds [] = []+  renderSimCmds ((DumpVars vars) : cmds) =+    "$dumpvars"+      : map renderValueChange vars+      ++ "$end"+      : renderSimCmds cmds+  renderSimCmds ((SimulationTime t) : cmds) =+    Text.pack ('#' : show t) : renderSimCmds cmds+  renderSimCmds ((SimulationValueChange vc) : cmds) =+    renderValueChange vc : renderSimCmds cmds++  renderValueChange (ValueChange 1 idCode (0, 0)) =+    Text.pack $ '0' : idCode+  renderValueChange (ValueChange 1 idCode (0, 1)) =+    Text.pack $ '1' : idCode+  renderValueChange (ValueChange 1 idCode (1, _)) =+    Text.pack $ 'x' : idCode+  renderValueChange (ValueChange 1 idCode (mask, val)) =+    error $+      "Can't format 1 bit wide value for "+        ++ show idCode+        ++ ": value "+        ++ show val+        ++ " and mask "+        ++ show mask+  renderValueChange ValueChange{..} =+    Text.pack $ 'b' : map digit (reverse [0 .. changeSize - 1]) ++ [' '] ++ changeIDCode+   where+    (mask, val) = changeValue+    digit d = case (testBit mask d, testBit val d) of+      (False,False) -> '0'+      (False,True)  -> '1'+      (True,_)      -> 'x'++  headerDate       = ["$date", Text.pack $ iso8601Format now, "$end"]++#ifdef CABAL+  clashVer         = Data.Version.showVersion Paths_clash_prelude.version+#else+  clashVer         = "development"+#endif++  headerVersion    = ["$version", "Generated by Clash", Text.pack clashVer , "$end"]+  headerComment    = ["$comment", "No comment", "$end"]+ -- | Same as @dumpVCD@, but supplied with a custom tracemap dumpVCD#   :: NFDataX a@@ -465,7 +579,7 @@ dumpVCD# traceMap slice signal traceNames = do   waitForTraces# traceMap signal traceNames   m <- readIORef traceMap-  fmap (dumpVCD## slice m) getCurrentTime+  fmap (dumpVCD0# slice m) getCurrentTime  -- | Produce a four-state VCD (Value Change Dump) according to IEEE -- 1364-{1995,2001}. This function fails if a trace name contains either@@ -514,7 +628,7 @@ -- | Take a serialized signal (dumped with @dumpReplayable@) and convert it -- back into a signal. Will error if dumped type does not match requested -- type. The first value in the signal that fails to decode will stop the--- decoding process and yield an error. Not that this always happens if you+-- decoding process and yield an error. Note that this always happens if you -- evaluate more values than were originally dumped. replay   :: forall a dom n@@ -564,14 +678,14 @@   -> IO () waitForTraces# traceMap signal traceNames = do   atomicWriteIORef traceMap Map.empty-  rest <- foldM go (sample signal) traceNames-  return $ deepseqX (head rest) ()+  rest <- foldM go signal traceNames+  seq rest (return ())  where-  go s nm = do+  go (s0 :- ss) nm = do     m <- readIORef traceMap     if Map.member nm m then-      return s+      deepseqX s0 (return ss)     else       deepseqX-        (head s)-        (go (tail s) nm)+        s0+        (go ss nm)
src/Clash/Sized/BitVector.hs view
@@ -1,12 +1,12 @@ {-| Copyright  :  (C) 2013-2016, University of Twente+                  2022-2024, Google Inc. License    :  BSD2 (see the file LICENSE) Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE MagicHash #-}- {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_HADDOCK show-extensions #-} @@ -25,11 +25,51 @@   , maxIndex#     -- ** Construction   , bLit+  , hLit+  , oLit     -- ** Concatenation   , (++#)+    -- * Modification+  , (+>>.)+  , (.<<+)     -- ** Pattern matching   , bitPattern   ) where  import Clash.Sized.Internal.BitVector+import Clash.Promoted.Nat (SNat(..), SNatLE(..), compareSNat, natToNum)+import Data.Bits (shiftL, shiftR)+import GHC.TypeNats (KnownNat)++{- $setup+>>> :set -XNumericUnderscores+-}++infixr 4 +>>.+-- | Shift in a bit from the MSB side of a 'BitVector'. Equal to right shifting+-- the 'BitVector' by one and replacing the MSB with the bit to be shifted in.+--+-- >>> 1 +>>. 0b1111_0000 :: BitVector 8+-- 0b1111_1000+-- >>> 0 +>>. 0b1111_0000 :: BitVector 8+-- 0b0111_1000+--+(+>>.) :: forall n. KnownNat n => Bit -> BitVector n -> BitVector n+b +>>. bv = case compareSNat (SNat @n) (SNat @0) of+  SNatGT -> replaceBit# (shiftR bv 1) (natToNum @n - 1) b+  SNatLE -> bv++infixr 4 .<<++-- | Shift in a bit from the LSB side of a 'BitVector'. Equal to left shifting+-- the 'BitVector' by one and replacing the LSB with the bit to be shifted in.+--+-- >>> 0b1111_0000 .<<+ 0 :: BitVector 8+-- 0b1110_0000+-- >>> 0b1111_0000 .<<+ 1 :: BitVector 8+-- 0b1110_0001+--+(.<<+) :: forall n. KnownNat n => BitVector n -> Bit -> BitVector n+bv .<<+ b = case compareSNat (SNat @n) (SNat @0) of+  SNatGT -> replaceBit# (shiftL bv 1) 0 b+  SNatLE -> bv
src/Clash/Sized/Fixed.hs view
@@ -1,7 +1,8 @@ {-|-Copyright  :  (C) 2013-2016, University of Twente+Copyright  :  (C) 2013-2016, University of Twente,+                  2021-2025, QBayLogic B.V., License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  Fixed point numbers @@ -10,35 +11,74 @@ * 'Fixed' has an instance for 'Fractional' meaning you use fractional   literals @(3.75 :: 'SFixed' 4 18)@. * Both integer literals and fractional literals are clipped to 'minBound' and- 'maxBound'.+  'maxBound'. __NB__: Needs the `-XNegativeLiterals` language extension to work+  for signed numbers. * There is no 'Floating' instance for 'Fixed', but you can use @$$('fLit' d)@   to create 'Fixed' point literal from 'Double' constant at compile-time. * Use <#constraintsynonyms Constraint synonyms> when writing type signatures   for polymorphic functions that use 'Fixed' point numbers. +BEWARE: rounding by truncation can introduce errors larger than naively assumed;+e.g. for /Fixed 16 1/, rounding by truncation turns the real number 4.99 to 4.5,+not 5.0, i.e. an error or 0.49 instead of 0.01+ BEWARE: rounding by truncation introduces a sign bias!  * Truncation for positive numbers effectively results in: round towards zero. * Truncation for negative numbers effectively results in: round towards -infinity.++== Reasoning about precision+Givens the real numbers /A/ and /B/, and the corresponding fixed point numbers+/FA+-da/ and /FB+db/, where /da/ and /db/ denote the (potential) error introduced+by truncation w.r.t. the original /A/ and /B/, the arithmetic operators on fixed+point numbers have the following error propagation properties:++* Addition: /da + db/+* Subtraction: /da - db/+* Multiplication: /FA*db + FB*da + da*db/+* Division: /(FA+da)\/(FB+db) - FA\/FB/++=== Additional error from truncation++Given:++>>> 4.13 :: UFixed 16 3+4.125+>>> 20.9 :: UFixed 16 3+20.875++The expected error that we would get from multiplication is:+/20.875*0.005 + 4.125*0.025 + 0.025*0.005 = 0.207625/++>>> 4.13 * 20.9 :: Double+86.317+>>> (4.13 :: UFixed 16 3) `mul` (20.9 :: UFixed 16 3) :: UFixed 32 6+86.109375+>>> 86.109375 + 0.207625 :: Double+86.317++However the /0.109375/ is smaller than /2^-3/, so the regular multiplication+operator that uses truncation introduces an additional error of /0.109375/:++>>> (4.13 :: UFixed 16 3) * (20.9 :: UFixed 16 3) :: UFixed 16 3+86.0+ -} -{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  {-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} @@ -73,19 +113,22 @@ import Control.Arrow              ((***), second) import Data.Bits                  (Bits (..), FiniteBits) import Data.Data                  (Data)-import Data.Default.Class         (Default (..))+import Data.Default               (Default (..)) import Data.Either                (isLeft)+import Data.Kind                  (Type) import Text.Read                  (Read(..)) import Data.List                  (find)-import Data.Maybe                 (fromJust) import Data.Proxy                 (Proxy (..)) import Data.Ratio                 ((%), denominator, numerator)-import Data.Typeable              (Typeable, TypeRep, typeRep)+import Data.Typeable              (Typeable, TypeRep, typeRep, typeOf) import GHC.TypeLits               (KnownNat, Nat, type (+), natVal) import GHC.TypeLits.Extra         (Max)-import Language.Haskell.TH        (Q, TExp, TypeQ, appT, conT, litT, mkName,+import Language.Haskell.TH        (Q, appT, conT, litT, mkName,                                    numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..))+import Language.Haskell.TH.Compat+import Language.Haskell.TH        (Quote)+import qualified Language.Haskell.TH as TH import Test.QuickCheck            (Arbitrary, CoArbitrary)  import Clash.Class.BitPack        (BitPack (..))@@ -93,14 +136,14 @@                                    SaturationMode (..), boundedAdd, boundedSub,                                    boundedMul) import Clash.Class.Resize         (Resize (..))-import Clash.Promoted.Nat         (SNat)-import Clash.Prelude.BitIndex     (msb, split)-import Clash.Prelude.BitReduction (reduceAnd, reduceOr)+import Clash.Promoted.Nat         (SNat, natToNum, natToInteger)+import Clash.Class.BitPack.BitIndex (lsb, msb, split)+import Clash.Class.BitPack.BitReduction (reduceAnd, reduceOr) import Clash.Sized.BitVector      (BitVector, (++#)) import Clash.Sized.Signed         (Signed) import Clash.Sized.Unsigned       (Unsigned) import Clash.XException-  (ShowX (..), NFDataX (..), isX, errorX, showsPrecXWith)+  (ShowX (..), NFDataX (..), isX, errorX, showsPrecXWith, fromJustX)  {- $setup >>> :set -XDataKinds@@ -121,7 +164,17 @@ -- -- The 'Num' operators for this type saturate to 'maxBound' on overflow and -- 'minBound' on underflow, and use truncation as the rounding method.-newtype Fixed (rep :: Nat -> *) (int :: Nat) (frac :: Nat) =+--+-- Fixed has the <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html type role>+--+-- >>> :i Fixed+-- type role Fixed representational nominal nominal+-- ...+--+-- as it is safe to coerce between different compatible underlying types, but+-- not necessasrily safe to coerce between different widths of this type.  To+-- change the width, use the functions in the 'Clash.Class.Resize.Resize' class.+newtype Fixed (rep :: Nat -> Type) (int :: Nat) (frac :: Nat) =   Fixed { unFixed :: rep (int + frac) }  deriving instance NFData (rep (int + frac)) => NFData (Fixed rep int frac)@@ -129,7 +182,6 @@                   , Data (rep (int + frac))) => Data (Fixed rep int frac) deriving instance Eq (rep (int + frac))      => Eq (Fixed rep int frac) deriving instance Ord (rep (int + frac))     => Ord (Fixed rep int frac)-deriving instance Enum (rep (int + frac))    => Enum (Fixed rep int frac) deriving instance Bounded (rep (int + frac)) => Bounded (Fixed rep int frac) deriving instance Default (rep (int + frac)) => Default (Fixed rep int frac) deriving instance Arbitrary (rep (int + frac)) => Arbitrary (Fixed rep int frac)@@ -258,7 +310,7 @@          ) => Show (Fixed rep int frac) where   show f@(Fixed fRep) =       i ++ "." ++ (uncurry pad . second (show . numerator) .-                   fromJust . find ((==1) . denominator . snd) .+                   fromJustX . find ((==1) . denominator . snd) .                    iterate (succ *** (*10)) . (,) 0 $ (nom % denom))     where       pad n str = replicate (n - length str) '0' ++ str@@ -279,6 +331,8 @@ instance NFDataX (rep (int + frac)) => NFDataX (Fixed rep int frac) where   deepErrorX = Fixed . errorX   rnfX f@(~(Fixed x)) = if isLeft (isX f) then () else rnfX x+  hasUndefined f@(~(Fixed x)) = if isLeft (isX f) then True else hasUndefined x+  ensureSpine ~(Fixed x) = Fixed x  -- | None of the 'Read' class' methods are synthesizable. instance (size ~ (int + frac), KnownNat frac, Bounded (rep size), Integral (rep size))@@ -323,7 +377,7 @@ the 'Num' class for the 'SFixed' datatype.  Although the number of constraints for the @mac@ function defined earlier might-be considered small, here is an \"this way lies madness\" example where you+be considered small, here is a \"this way lies madness\" example where you really want to use constraint kinds:  @@@ -410,15 +464,15 @@   type AResult (Fixed rep int1 frac1) (Fixed rep int2 frac2) =                Fixed rep (1 + Max int1 int2) (Max frac1 frac2)   add (Fixed f1) (Fixed f2) =-    let sh1 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac1)) :: Int+    let sh1 = natToNum @(Max frac1 frac2) - natToNum @frac1 :: Int         f1R = shiftL (resize f1) sh1 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))-        sh2 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac2)) :: Int+        sh2 = natToNum @(Max frac1 frac2) - natToNum @frac2 :: Int         f2R = shiftL (resize f2) sh2 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))     in  Fixed (f1R + f2R)   sub (Fixed f1) (Fixed f2) =-    let sh1 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac1)) :: Int+    let sh1 = natToNum @(Max frac1 frac2) - natToNum @frac1 :: Int         f1R = shiftL (resize f1) sh1 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))-        sh2 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac2)) :: Int+        sh2 = natToNum @(Max frac1 frac2) - natToNum @frac2 :: Int         f2R = shiftL (resize f2) sh2 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))     in  Fixed (f1R - f2R)   type MResult (Fixed rep int1 frac1) (Fixed rep int2 frac2) =@@ -435,12 +489,11 @@               (int + ((int + frac) + frac))     , BitPack (rep ((int + int) + (frac + frac)))     , Bits    (rep ((int + int) + (frac + frac)))-    , KnownNat (BitSize (rep (int + frac)))     , BitPack (rep (int + frac))-    , Enum    (rep (int + frac))     , Bits    (rep (int + frac))-    , Ord     (rep (int + frac))+    , Integral (rep (int + frac))     , Resize  rep+    , Typeable rep     , KnownNat int     , KnownNat frac     )@@ -473,17 +526,22 @@   (+)              = boundedAdd   (*)              = boundedMul   (-)              = boundedSub-  negate (Fixed a) = Fixed (negate a)+  negate           = boundedSub (Fixed 0)   abs    (Fixed a) = Fixed (abs a)   signum (Fixed a)     | a == 0       = 0     | a <  0       = -1     | otherwise    = 1-  fromInteger i    = let fSH = fromInteger (natVal (Proxy @frac))-                         res = Fixed (fromInteger i `shiftL` fSH)-                     in  res+  fromInteger i    = let fSH = natToNum @frac+                         res = i `shiftL` fSH+                         rMax = toInteger (maxBound :: rep (int + frac))+                         rMin = toInteger (minBound :: rep (int + frac))+                         sat | res > rMax = rMax+                             | res < rMin = rMin+                             | otherwise  = res+                     in  Fixed (fromInteger sat) -instance (BitPack (rep (int + frac))) => BitPack (Fixed rep int frac) where+instance (BitPack (rep (int + frac)), KnownNat (BitSize (rep (int + frac)))) => BitPack (Fixed rep int frac) where   type BitSize (Fixed rep int frac) = BitSize (rep (int + frac))   pack   (Fixed fRep) = pack fRep   unpack bv           = Fixed (unpack bv)@@ -494,8 +552,9 @@                           (decFixed (typeRep (asRepProxy f))                                     (natVal (asIntProxy f))                                     (natVal f))+  liftTyped = liftTypedFromUntyped -decFixed :: TypeRep -> Integer -> Integer -> TypeQ+decFixed :: Quote m => TypeRep -> Integer -> Integer -> m TH.Type decFixed r i f = do   foldl appT (conT ''Fixed) [ conT (mkName (show r))                             , litT (numTyLit i)@@ -564,11 +623,11 @@   where     fMin  = minBound :: rep (int2 + frac2)     fMax  = maxBound :: rep (int2 + frac2)-    argSZ = natVal (Proxy @(int1 + frac1))-    resSZ = natVal (Proxy @(int2 + frac2))+    argSZ = natToInteger @(int1 + frac1)+    resSZ = natToInteger @(int2 + frac2) -    argFracSZ = fromInteger (natVal (Proxy @frac1))-    resFracSZ = fromInteger (natVal (Proxy @frac2))+    argFracSZ = natToNum @frac1+    resFracSZ = natToNum @frac2      -- All size and frac comparisons and related if-then-else statements should     -- be optimized away by the compiler@@ -644,7 +703,7 @@      , Bounded (rep size)      , Integral (rep size) )   => Double-  -> Q (TExp (Fixed rep int frac))+  -> TH.Code Q (Fixed rep int frac) fLit a = [|| Fixed (fromInteger sat) ||]   where     rMax      = toInteger (maxBound :: rep size)@@ -655,23 +714,21 @@                            then rMin                            else truncated     truncated = truncate shifted :: Integer-    shifted   = a * (2 ^ (natVal (Proxy @frac)))+    shifted   = a * (2 ^ (natToInteger @frac))  -- | Convert, at run-time, a 'Double' to a 'Fixed'-point. ----- __NB__: this functions is /not/ synthesizable+-- __NB__: This function is /not/ synthesizable -- -- = Creating data-files #creatingdatafiles# ----- An example usage of this function is for example to convert a data file--- containing 'Double's to a data file with ASCI-encoded binary numbers to be--- used by a synthesizable function like 'Clash.Prelude.ROM.File.asyncRomFile'.--- For example, given a file @Data.txt@ containing:+-- An example usage of this function is to convert a data file containing+-- 'Double's to a data file with ASCII-encoded binary numbers to be used by a+-- synthesizable function like 'Clash.Prelude.ROM.File.asyncRomFile'. For+-- example, consider a file @Data.txt@ containing: ----- @--- 1.2 2.0 3.0 4.0--- -1.0 -2.0 -3.5 -4.0--- @+-- > 1.2 2.0 3.0 4.0+-- > -1.0 -2.0 -3.5 -4.0 -- -- which we want to put in a ROM, interpreting them as @8.8@ signed fixed point -- numbers. What we do is that we first create a conversion utility,@@ -683,12 +740,13 @@ -- module Main where -- -- import Clash.Prelude+-- import Clash.Prelude.ROM.File -- import System.Environment -- import qualified Data.List as L -- -- createRomFile---   :: KnownNat n---   => (Double -> BitVector n)+--   :: BitPack a+--   => (Double -> a) --   -> FilePath --   -> FilePath --   -> IO ()@@ -696,8 +754,8 @@ --   f <- readFile fileR --   let ds :: [Double] --       ds = L.concat . (L.map . L.map) read . L.map words $ lines f---       bvs = L.map (filter (/= '_') . show . convert) ds---   writeFile fileW (unlines bvs)+--       fes = L.map convert ds+--   writeFile fileW ('Clash.Prelude.ROM.File.memFile' Nothing fes) -- -- toSFixed8_8 :: Double -> SFixed 8 8 -- toSFixed8_8 = 'fLitR'@@ -705,35 +763,29 @@ -- main :: IO () -- main = do --   [fileR,fileW] <- getArgs---   createRomFile ('pack' . toSFixed8_8) fileR fileW+--   createRomFile toSFixed8_8 fileR fileW -- @ -- -- We then compile this to an executable: ----- @--- \$ clash --make createRomFile.hs--- @+-- > $ clash --make createRomFile.hs -- -- We can then use this utility to convert our @Data.txt@ file which contains--- 'Double's to a @Data.bin@ file which will containing the desired ASCI-encoded+-- 'Double's to a @Data.bin@ file which will containing the desired ASCII-encoded -- binary data: ----- @--- \$ ./createRomFile \"Data.txt\" \"Data.bin\"--- @+-- > $ ./createRomFile Data.txt Data.bin -- -- Which results in a @Data.bin@ file containing: ----- @--- 0000000100110011--- 0000001000000000--- 0000001100000000--- 0000010000000000--- 1111111100000000--- 1111111000000000--- 1111110010000000--- 1111110000000000--- @+-- > 0000000100110011+-- > 0000001000000000+-- > 0000001100000000+-- > 0000010000000000+-- > 1111111100000000+-- > 1111111000000000+-- > 1111110010000000+-- > 1111110000000000 -- -- We can then use this @Data.bin@ file in for our ROM: --@@ -756,30 +808,31 @@ -- -- For those of us who like to live on the edge, another option is to convert -- our @Data.txt@ at compile-time using--- <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#template-haskell Template Haskell>.+-- <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/template_haskell.html Template Haskell>. -- For this we first create a module @CreateRomFileTH.hs@: -- -- @ -- module CreateRomFileTH (romDataFromFile) where -- -- import Clash.Prelude--- import qualified Data.List        as L--- import Language.Haskell.TH        (ExpQ, litE, stringL)+-- import Clash.Prelude.ROM.File+-- import qualified Data.List as L+-- import Language.Haskell.TH (ExpQ, litE, stringL) -- import Language.Haskell.TH.Syntax (qRunIO) ----- createRomFile :: KnownNat n => (Double -> BitVector n)+-- createRomFile :: BitPack a => (Double -> a) --               -> FilePath -> FilePath -> IO () -- createRomFile convert fileR fileW = do --   f <- readFile fileR --   let ds :: [Double] --       ds = L.concat . (L.map . L.map) read . L.map words $ lines f---       bvs = L.map (filter (/= '_') . show . convert) ds---   writeFile fileW (unlines bvs)+--       fes = L.map convert ds+--   writeFile fileW ('Clash.Prelude.ROM.File.memFile' Nothing fes) ----- romDataFromFile :: KnownNat n => (Double -> BitVector n) -> String -> ExpQ+-- romDataFromFile :: BitPack a => (Double -> a) -> String -> ExpQ -- romDataFromFile convert fileR = do --   let fileW = fileR L.++ ".bin"---   bvF <- qRunIO (createRomFile convert fileR fileW)+--   qRunIO (createRomFile convert fileR fileW) --   litE (stringL fileW) -- @ --@@ -791,13 +844,10 @@ -- import Clash.Prelude -- import CreateRomFileTH ----- toSFixed8_8 :: Double -> SFixed 8 8--- toSFixed8_8 = 'fLitR'--- -- romF' :: Unsigned 3 -> Unsigned 3 -> SFixed 8 8 -- romF' rowAddr colAddr = unpack $ --   asyncRomFile d8---                $(romDataFromFile (pack . toSFixed8_8) "Data.txt") -- Template Haskell splice+--                $(romDataFromFile (fLitR :: Double -> SFixed 8 8) "Data.txt") -- Template Haskell splice --                ((rowAddr * 4) + colAddr) -- @ --@@ -827,25 +877,203 @@                            then rMin                            else truncated     truncated = truncate shifted :: Integer-    shifted   = a * (2 ^ (natVal (Proxy @frac)))+    shifted   = a * (2 ^ (natToInteger @frac)) +-- | These behave similar to 'Prelude.Float', 'Prelude.Double' and+-- 'Prelude.Rational'. 'succ'\/'pred' add\/subtract 1. See the+-- <https://www.haskell.org/onlinereport/haskell2010/haskellch6.html#dx13-131001 Haskell Report>+-- for full details.+--+-- The rules set out there for instances of both 'Enum' and+-- 'Bounded' are also observed. In particular, 'succ' and 'pred' result in a+-- runtime error if the result cannot be represented. See 'satSucc' and+-- 'satPred' for other options.+instance NumFixedC rep int frac => Enum (Fixed rep int frac) where+  succ f =+    let err = error $+             "Enum.succ{" ++ show (typeOf f) ++ "}: tried to take 'succ' of "+          ++ show f ++ ", causing overflow. Use 'satSucc' and specify a "+          ++ "SaturationMode if you need other behavior."+    in case natToInteger @int of+         0 -> err+         _ -> if f > satPred SatBound maxBound then+                err+              else+                satSucc SatWrap f+++  pred f =+    let err = error $+             "Enum.pred{" ++ show (typeOf f) ++ "}: tried to take 'pred' of "+          ++ show f ++ ", causing negative overflow. Use 'satPred' and "+          ++ "specify a SaturationMode if you need other behavior."+    in case natToInteger @int of+         0 -> err+         _ -> if f < satSucc SatBound minBound then+                err+              else+                satPred SatWrap f++  toEnum i =+    if res > rMax || res < rMin then+      error $  "Enum.toEnum{"+            ++ show (typeRep $ Proxy @(Fixed rep int frac)) ++ "}: tag ("+            ++ show i ++ ") is outside of bounds "+            ++ show ( minBound :: Fixed rep int frac+                    , maxBound :: Fixed rep int frac)+    else+      Fixed (fromInteger res)+     where+      sh   = natToNum @frac+      res  = toInteger i `shiftL` sh+      rMax = toInteger (maxBound :: rep (int + frac))+      rMin = toInteger (minBound :: rep (int + frac))++  fromEnum f@(Fixed fRep) =+    if res > rMax || res < rMin then+      error $  "Enum.fromEnum{" ++ show (typeOf f) ++ "}: value ("+            ++ show f ++ ") is outside of Int's bounds "+            ++ show (rMin, rMax)+    else+      fromInteger res+     where+      nF     = natToNum @frac+      frMask = fromInteger $ (1 `shiftL` nF) - 1+      offset = if f < 0 && fRep .&. frMask /= 0 then 1 else 0+      -- res amounts to "truncate f", but without needing all the constraints+      -- for RealFrac.+      res    = toInteger $ (fRep `shiftR` nF) + offset+      rMax   = toInteger (maxBound :: Int)+      rMin   = toInteger (minBound :: Int)++  enumFrom x1 = enumFromTo x1 maxBound+  enumFromThen (Fixed x1Rep) (Fixed x2Rep) =+    map Fixed $ enumFromThen x1Rep x2Rep++  enumFromTo x1@(Fixed x1Rep) y@(Fixed yRep)+    | yPlusHalf < x1 = []+    | closeToMax     = [x1]+    | otherwise      =  map Fixed $ enumFromThenTo+                                      x1Rep+                                      (unFixed $ satSucc SatWrap x1)+                                      (unFixed $ yPlusHalf)+   where+    closeToMax = natToInteger @int == 0 || x1 > satPred SatBound maxBound+    nF = natToNum @frac+    yPlusHalf | nF == 0       = y+              | isSigned yRep = y - (Fixed $ -1 `shiftL` (nF - 1))+              | otherwise     = y + (Fixed $ 1 `shiftL` (nF - 1))++  enumFromThenTo = enumFromThenTo#++-- Inspired by Enum Int from GHC.Enum in base-4.14.1.0+--+-- Note that if x2 /= x1, it is guaranteed that (int + frac) >= 1, because if it+-- were zero there would only be one concrete value. This fact is relied upon in+-- enumFromThenToUp and enumFromThenToDown, which would have undefined behavior+-- for (int + frac) == 0.+enumFromThenTo#+  :: forall f rep int frac+   . ( NumFixedC rep int frac+     , f ~ Fixed rep int frac)+  => f+  -> f+  -> f+  -> [f]+enumFromThenTo# x1 x2 y+  | x2 == x1  = if y < x1 then+                  []+                else+                  repeat x1+  | x2 > x1   = enumFromThenToUp x1 x2 y+  | otherwise = enumFromThenToDown x1 x2 y++enumFromThenToUp+  :: forall f rep int frac+   . ( NumFixedC rep int frac+     , f ~ Fixed rep int frac)+  => f+  -> f+  -> f+  -> [f]+enumFromThenToUp x1 x2 y+  | y < x1 = let y' = satAdd SatWrap y halfDelta  -- Never wraps+             in if y' < x1 || (isMinusHalf && y' <= x1) then+                  []+                else+                  [x1]+  | y < x2 = let x2' = satSub SatWrap x2 halfDelta  -- Never wraps `+             in if y > x2' || (not isMinusHalf && y >= x2') then+                  [x1, x2]+                else+                  [x1]+  | otherwise = let y' = satSub SatWrap y (delta `shiftR` 1) -- Does wrap+                    go_up x+                      | x' < x            = [x]+                      | isHalf && x >= y' = [x]+                      | x > y'            = [x]+                      | otherwise          = x : go_up x'+                     where+                      x' = satAdd SatWrap x delta  -- Does wrap+                in x1 : go_up x2+ where+   delta = satSub SatWrap x2 x1  -- Does wrap!+   halfDelta = satSub SatWrap (x2 `shiftR` 1) (x1 `shiftR` 1)  -- Never wraps+   isHalf = lsb delta == 1+   isMinusHalf = lsb x2 == 0 && lsb x1 == 1++enumFromThenToDown+  :: forall f rep int frac+   . ( NumFixedC rep int frac+     , f ~ Fixed rep int frac)+  => f+  -> f+  -> f+  -> [f]+enumFromThenToDown x1 x2 y+  | y > x1 = let y' = satSub SatWrap y halfDelta  -- Never wraps+             in if y' > x1 || (isMinusHalf && y' >= x1) then+                  []+                else+                  [x1]+  | y > x2 = let x2' = satAdd SatWrap x2 halfDelta  -- Never wraps `+             in if y < x2' || (not isMinusHalf && y <= x2') then+                  [x1, x2]+                else+                  [x1]+  | otherwise = let y' = satAdd SatWrap y (delta `shiftR` 1)  -- Does wrap+                    go_dn x+                      | x' > x            = [x]+                      | isHalf && x <= y' = [x]+                      | x < y'            = [x]+                      | otherwise         = x : go_dn x'+                     where+                      x' = satSub SatWrap x delta  -- Does wrap+                in x1 : go_dn x2+ where+  delta = satSub SatWrap x1 x2  -- Does wrap!+  halfDelta = satSub SatWrap (x1 `shiftR` 1) (x2 `shiftR` 1)  -- Never wraps+  isHalf = lsb delta == 1+  isMinusHalf = lsb x1 == 0 && lsb x2 == 1++ instance NumFixedC rep int frac => SaturatingNum (Fixed rep int frac) where   satAdd w (Fixed a) (Fixed b) = Fixed (satAdd w a b)   satSub  w (Fixed a) (Fixed b) = Fixed (satSub w a b)    satMul SatWrap (Fixed a) (Fixed b) =     let res  = a `mul` b-        sh   = fromInteger (natVal (Proxy @frac))+        sh   = natToNum @frac         res' = shiftR res sh     in  Fixed (resize res')    satMul SatBound (Fixed a) (Fixed b) =     let res     = a `mul` b-        sh      = fromInteger (natVal (Proxy @frac))+        sh      = natToNum @frac         (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac))     in  case isSigned a of           True  -> let overflow = complement (reduceOr (pack (msb rR) ++# pack rL)) .|.-                                             reduceAnd (pack (msb rR) ++# pack rL)+                                  reduceAnd (pack (msb rR) ++# pack rL)                    in  case overflow of                          1 -> unpack (resize (shiftR rR sh))                          _ -> case msb rL of@@ -857,11 +1085,11 @@    satMul SatZero (Fixed a) (Fixed b) =     let res     = a `mul` b-        sh      = fromInteger (natVal (Proxy @frac))+        sh      = natToNum @frac         (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac))     in  case isSigned a of           True  -> let overflow = complement (reduceOr (pack (msb rR) ++# pack rL)) .|.-                                             reduceAnd (pack (msb rR) ++# pack rL)+                                  reduceAnd (pack (msb rR) ++# pack rL)                    in  case overflow of                          1 -> unpack (resize (shiftR rR sh))                          _ -> 0@@ -869,22 +1097,67 @@                      0 -> unpack (resize (shiftR rR sh))                      _ -> 0 +  satMul SatError (Fixed a) (Fixed b) =+    let res     = a `mul` b+        sh      = natToNum @frac+        (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac))+    in  case isSigned a of+          True  -> let overflow = complement (reduceOr (pack (msb rR) ++# pack rL)) .|.+                                  reduceAnd (pack (msb rR) ++# pack rL)+                   in  case overflow of+                         1 -> unpack (resize (shiftR rR sh))+                         _ -> errorX "Fixed.satMul: result exceeds bounds"++          False -> case rL of+                     0 -> unpack (resize (shiftR rR sh))+                     _ -> errorX "Fixed.satMul: result exceeds maxBound"+   satMul SatSymmetric (Fixed a) (Fixed b) =     let res     = a `mul` b-        sh      = fromInteger (natVal (Proxy @frac))+        sh      = natToNum @frac         (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac))     in  case isSigned a of           True  -> let overflow = complement (reduceOr (pack (msb rR) ++# pack rL)) .|.-                                             reduceAnd (pack (msb rR) ++# pack rL)+                                  reduceAnd (pack (msb rR) ++# pack rL)                    in  case overflow of                          1 -> unpack (resize (shiftR rR sh))                          _ -> case msb rL of                                 0 -> maxBound-                                _ -> succ minBound+                                _ -> Fixed $ succ minBound           False -> case rL of                      0 -> unpack (resize (shiftR rR sh))                      _ -> maxBound +  satSucc satMode f@(Fixed fRep) =+    let sh    = natToNum @frac+    in case natToInteger @int of+         0 -> case satMode of+                SatWrap -> f+                SatZero -> 0+                SatError -> errorX "Fixed.satSucc: result exceeds maxBound"+                _       -> maxBound+         _ -> if isSigned fRep+              then satSub satMode f $ Fixed $ fromInteger $ (-1) `shiftL` sh+              else satAdd satMode f $ Fixed $ fromInteger $ 1 `shiftL` sh+  {-# INLINE satSucc #-}++  satPred satMode f@(Fixed fRep) =+    let sh       = natToNum @frac+        symBound = if isSigned fRep+                   then Fixed $ minBound + 1+                   else minBound+    in case natToInteger @int of+         0 -> case satMode of+                SatWrap      -> f+                SatBound     -> minBound+                SatZero      -> 0+                SatError     -> errorX "Fixed.satPred: result exceeds minBound"+                SatSymmetric -> symBound+         _ -> if isSigned fRep+              then satAdd satMode f $ Fixed $ fromInteger $ (-1) `shiftL` sh+              else satSub satMode f $ Fixed $ fromInteger $ 1 `shiftL` sh+  {-# INLINE satPred #-}+ -- | Constraint for the 'divide' function type DivideC rep int1 frac1 int2 frac2   = ( Resize   rep@@ -940,9 +1213,6 @@ type FracFixedC rep int frac   = ( NumFixedC rep int frac     , DivideC   rep int frac int frac-    , Integral  (rep (int + frac))-    , KnownNat  int-    , KnownNat  frac     )  -- | Constraint for the 'Fractional' instance of 'SFixed'@@ -983,18 +1253,17 @@       n    = numerator   r `shiftL` (2 * frac)       d    = denominator r `shiftL` frac -instance (NumFixedC rep int frac, Integral (rep (int + frac))) =>-         Real (Fixed rep int frac) where+instance NumFixedC rep int frac => Real (Fixed rep int frac) where   toRational f@(Fixed fRep) = nom % denom    where      nF        = fracShift f      denom     = 1 `shiftL` nF      nom       = toInteger fRep -instance (FracFixedC rep int frac, NumFixedC rep int frac, Integral (rep (int + frac))) =>-         RealFrac (Fixed rep int frac) where+instance FracFixedC rep int frac => RealFrac (Fixed rep int frac) where   properFraction f@(Fixed fRep) = (fromIntegral whole, fract)     where       whole = (fRep `shiftR` fracShift f) + offset       fract = Fixed $ fRep - (whole `shiftL` fracShift f)-      offset = if f < 0 then 1 else 0+      frMask = fromInteger $ (1 `shiftL` fracShift f) - 1+      offset = if f < 0 && fRep .&. frMask /= 0 then 1 else 0
src/Clash/Sized/Index.hs view
@@ -1,13 +1,10 @@ {-| Copyright  :  (C) 2013-2016, University of Twente+                  2025     , QBayLogic B.V. License    :  BSD2 (see the file LICENSE) Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DataKinds     #-}-{-# LANGUAGE MagicHash     #-}-{-# LANGUAGE TypeOperators #-}- {-# LANGUAGE Trustworthy #-}  {-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver -fplugin GHC.TypeLits.KnownNat.Solver #-}@@ -16,14 +13,13 @@ {-# OPTIONS_HADDOCK show-extensions #-}  module Clash.Sized.Index-  (Index, bv2i)+  (Index, bv2i, fromSNat) where -import GHC.TypeLits               (KnownNat, type (^))-import GHC.TypeLits.Extra         (CLog) -- documentation only+import GHC.TypeLits (KnownNat, type (^))+import GHC.TypeLits.Extra (CLog) -- documentation only -import Clash.Promoted.Nat         (SNat (..), pow2SNat)-import Clash.Sized.BitVector      (BitVector)+import Clash.Sized.Internal.BitVector (BitVector) import Clash.Sized.Internal.Index  -- | An alternative implementation of 'Clash.Class.BitPack.unpack' for the
+ src/Clash/Sized/Internal.hs view
@@ -0,0 +1,24 @@+{-|+Copyright  :  (C) 2024     , QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++module Clash.Sized.Internal where++-- | Format a range of numbers for use in error messages+--+-- If the upper bound is below the lower bound, @"\<empty range\>"@ is returned.+-- If the bounds are equal, @"[n]"@ is returned (for bounds equal to /n/).+-- Otherwise, @formatRange n m@ returns @"[n..m]"@.+formatRange ::+  (Ord a, Show a) =>+  -- | Lower bound+  a ->+  -- | Upper bound+  a ->+  String+formatRange n m+  | m < n     = "<empty range>"+  | m == n    = '[' : shows n "]"+  | otherwise = '[' : show n ++ ".." ++ shows m "]"
src/Clash/Sized/Internal/BitVector.hs view
@@ -1,25 +1,22 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2019     , Gergő Érdi-                  2016-2019, Myrtle Software Ltd+                  2016-2019, Myrtle Software Ltd,+                  2021-2025, QBayLogic B.V.+                  2023     , Nadia Chambers License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveAnyClass             #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE UndecidableInstances       #-}-{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  {-# LANGUAGE Unsafe #-} @@ -42,6 +39,8 @@   , ge##   , gt##   , le##+    -- *** Enum+  , toEnum##     -- *** Num   , fromInteger##     -- *** Bits@@ -59,6 +58,8 @@   , maxIndex#     -- ** Construction   , bLit+  , hLit+  , oLit   , undefined#     -- ** Concatenation   , (++#)@@ -78,12 +79,15 @@     -- **** Eq   , eq#   , neq#-  , isLike+  , isLike#     -- *** Ord   , lt#   , ge#   , gt#   , le#+    -- *** Enum+  , toEnum#+  , fromEnum#     -- *** Enum (not synthesizable)   , enumFrom#   , enumFromThen#@@ -127,79 +131,132 @@   , undefError   , checkUnpackUndef   , bitPattern+  , xToBV   ) where  import Control.DeepSeq            (NFData (..))+import Control.Exception          (catch, evaluate) import Control.Lens               (Index, Ixed (..), IxValue) import Data.Bits                  (Bits (..), FiniteBits (..)) import Data.Data                  (Data)-import Data.Default.Class         (Default (..))+import Data.Default               (Default (..))+import Data.Either                (isLeft) import Data.Proxy                 (Proxy (..)) import Data.Typeable              (Typeable, typeOf) import GHC.Generics               (Generic) import Data.Maybe                 (fromMaybe)-import GHC.Integer                (smallInteger)-import GHC.Prim                   (dataToTag#)-import GHC.Stack                  (HasCallStack, withFrozenCallStack)-import GHC.TypeLits               (KnownNat, Nat, type (+), type (-), natVal)+import Numeric                    (readOct, readHex)+import GHC.Exts+  (Word#, Word (W#), eqWord#, int2Word#, isTrue#, uncheckedShiftRL#)+import GHC.Exts (minusWord#, gtWord#, word2Int#, dataToTag#)+import GHC.Num.BigNat (bigNatShiftR#, bigNatToWord)+import GHC.Num.Integer (integerFromNatural, integerToNatural)+import GHC.Num.Natural+  (Natural (..), naturalFromWord, naturalShiftL, naturalShiftR, naturalToWord)+import GHC.Natural                (naturalToInteger)+import GHC.Stack                  (withFrozenCallStack)+import GHC.TypeLits               (KnownNat, Nat, type (+), type (-))+import GHC.TypeNats               (natVal) import GHC.TypeLits.Extra         (Max)-import Language.Haskell.TH        (Q, TExp, TypeQ, appT, conT, litT, numTyLit, sigE, Lit(..), litE, Pat, litP)+import Language.Haskell.TH+  (Lit (..), ExpQ, Type(ConT, AppT, LitT), Exp(VarE, AppE, SigE, LitE),+   TyLit(NumTyLit), Pat, Q, appT, conT, litE, litP, litT, mkName, numTyLit,+   sigE, tupE, tupP, varP) import Language.Haskell.TH.Syntax (Lift(..))+import Language.Haskell.TH.Compat+import Language.Haskell.TH        (Quote)+import System.IO.Unsafe               (unsafeDupablePerformIO) import Test.QuickCheck.Arbitrary  (Arbitrary (..), CoArbitrary (..),                                    arbitraryBoundedIntegral,                                    coarbitraryIntegral, shrinkIntegral) +import Clash.Annotations.Primitive (hasBlackBox) import Clash.Class.Num            (ExtendingNum (..), SaturatingNum (..),                                    SaturationMode (..)) import Clash.Class.Resize         (Resize (..)) import Clash.Promoted.Nat-  (SNat (..), SNatLE (..), compareSNat, snatToInteger, snatToNum)+  (SNat (..), SNatLE (..), compareSNat, snatToInteger, snatToNum, natToNum)+import Clash.Sized.Internal (formatRange) import Clash.XException-  (ShowX (..), NFDataX (..), errorX, showsPrecXWith, rwhnfX)+  (ShowX (..), NFDataX (..), errorX, isX, showsPrecXWith, rwhnfX, XException(..)) +import Clash.Sized.Internal.Mod+ import {-# SOURCE #-} qualified Clash.Sized.Vector         as V import {-# SOURCE #-} qualified Clash.Sized.Internal.Index as I+import                qualified Data.Char                  as C import                qualified Data.List                  as L+import                qualified Data.Map.Strict            as M +#include "MachDeps.h"+ {- $setup >>> :set -XTemplateHaskell >>> :set -XBinaryLiterals+>>> import Clash.Sized.Internal.BitVector -} +type role BitVector nominal+ -- * Type definitions --- | A vector of bits.+-- | A vector of bits -- -- * Bit indices are descending -- * 'Num' instance performs /unsigned/ arithmetic.+--+-- __NB__: The usual Haskell method of converting an integral numeric type to+-- another, 'fromIntegral', is not well suited for Clash as it will go through+-- 'Integer' which is arbitrarily bounded in HDL. Instead use+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class.+--+-- BitVector has the <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html type role>+--+-- >>> :i BitVector+-- type role BitVector nominal+-- ...+--+-- as it is not safe to coerce between different sizes of BitVector. To change+-- the size, use the functions in the 'Resize' class. data BitVector (n :: Nat) =-    -- | The constructor, 'BV', and  the field, 'unsafeToInteger', are not+    -- | The constructor, 'BV', and  the fields, 'unsafeMask' and 'unsafeToNatural', are not     -- synthesizable.-    BV { unsafeMask      :: !Integer-       , unsafeToInteger :: !Integer+    BV { unsafeMask      :: !Natural+       , unsafeToNatural :: !Natural        }   deriving (Data, Generic) +{-# ANN BV hasBlackBox #-}+ -- * Bit --- | Bit+-- | A single bit+--+-- __NB__: The usual Haskell method of converting an integral numeric type to+-- another, 'fromIntegral', is not well suited for Clash as it will go through+-- 'Integer' which is arbitrarily bounded in HDL. Instead use+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class. data Bit =-  -- | The constructor, 'Bit', and  the field, 'unsafeToInteger#', are not+  -- | The constructor, 'Bit', and  the fields, 'unsafeMask#' and 'unsafeToInteger#', are not   -- synthesizable.-  Bit { unsafeMask#      :: !Integer-      , unsafeToInteger# :: !Integer+  Bit { unsafeMask#      :: {-# unpack #-} !Word+      , unsafeToInteger# :: {-# unpack #-} !Word       }   deriving (Data, Generic) +{-# ANN Bit hasBlackBox #-}+ -- * Constructions -- ** Initialisation-{-# NOINLINE high #-}+{-# OPAQUE high #-}+{-# ANN high hasBlackBox #-} -- | logic '1' high :: Bit high = Bit 0 1 -{-# NOINLINE low #-}+{-# OPAQUE low #-}+{-# ANN low hasBlackBox #-} -- | logic '0' low :: Bit low = Bit 0 0@@ -221,11 +278,14 @@  instance NFDataX Bit where   deepErrorX = errorX+  ensureSpine = unpack# . xToBV . pack#   rnfX = rwhnfX+  hasUndefined bv = isLeft (isX bv) || unsafeMask# bv /= 0  instance Lift Bit where-  lift (Bit m i) = [| fromInteger## m i |]+  lift (Bit m i) = [| fromInteger## $(litE (WordPrimL (toInteger m))) i |]   {-# NOINLINE lift #-}+  liftTyped = liftTypedFromUntyped  instance Eq Bit where   (==) = eq##@@ -233,11 +293,13 @@  eq## :: Bit -> Bit -> Bool eq## b1 b2 = eq# (pack# b1) (pack# b2)-{-# NOINLINE eq## #-}+{-# OPAQUE eq## #-}+{-# ANN eq## hasBlackBox #-}  neq## :: Bit -> Bit -> Bool neq## b1 b2 = neq# (pack# b1) (pack# b2)-{-# NOINLINE neq## #-}+{-# OPAQUE neq## #-}+{-# ANN neq## hasBlackBox #-}  instance Ord Bit where   (<)  = lt##@@ -247,18 +309,27 @@  lt##,ge##,gt##,le## :: Bit -> Bit -> Bool lt## b1 b2 = lt# (pack# b1) (pack# b2)-{-# NOINLINE lt## #-}+{-# OPAQUE lt## #-}+{-# ANN lt## hasBlackBox #-} ge## b1 b2 = ge# (pack# b1) (pack# b2)-{-# NOINLINE ge## #-}+{-# OPAQUE ge## #-}+{-# ANN ge## hasBlackBox #-} gt## b1 b2 = gt# (pack# b1) (pack# b2)-{-# NOINLINE gt## #-}+{-# OPAQUE gt## #-}+{-# ANN gt## hasBlackBox #-} le## b1 b2 = le# (pack# b1) (pack# b2)-{-# NOINLINE le## #-}+{-# OPAQUE le## #-}+{-# ANN le## hasBlackBox #-}  instance Enum Bit where-  toEnum     = fromInteger## 0 . toInteger+  toEnum     = toEnum##   fromEnum b = if eq## b low then 0 else 1 +toEnum## :: Int -> Bit+toEnum## = fromInteger## 0## . toInteger+{-# OPAQUE toEnum## #-}+{-# ANN toEnum## hasBlackBox #-}+ instance Bounded Bit where   minBound = low   maxBound = high@@ -270,14 +341,15 @@   (+)         = xor##   (-)         = xor##   (*)         = and##-  negate      = complement##+  negate      = id   abs         = id   signum b    = b-  fromInteger = fromInteger## 0+  fromInteger = fromInteger## 0## -fromInteger## :: Integer -> Integer -> Bit-fromInteger## m i = Bit (m `mod` 2) (i `mod` 2)-{-# NOINLINE fromInteger## #-}+fromInteger## :: Word# -> Integer -> Bit+fromInteger## m# i = Bit ((W# m#) `mod` 2) (fromInteger i `mod` 2)+{-# OPAQUE fromInteger## #-}+{-# ANN fromInteger## hasBlackBox #-}  instance Real Bit where   toRational b = if eq## b low then 0 else 1@@ -305,8 +377,10 @@   bitSizeMaybe _    = Just 1   bitSize _         = 1   isSigned _        = False+  shift b i         = if i == 0 then b else low   shiftL b i        = if i == 0 then b else low   shiftR b i        = if i == 0 then b else low+  rotate b _        = b   rotateL b _       = b   rotateR b _       = b   popCount b        = if eq## b low then 0 else 1@@ -317,27 +391,40 @@   countTrailingZeros b = if eq## b low then 1 else 0  and##, or##, xor## :: Bit -> Bit -> Bit-and## b1 b2 = unpack# $ and# (pack# b1) (pack# b2)-{-# NOINLINE and## #-}+and## (Bit m1 v1) (Bit m2 v2) = Bit mask (v1 .&. v2 .&. complement mask)+  where mask = (m1.&.v2 .|. m1.&.m2 .|. m2.&.v1)+{-# OPAQUE and## #-}+{-# ANN and## hasBlackBox #-} -or## b1 b2 = unpack# $ or# (pack# b1) (pack# b2)-{-# NOINLINE or## #-}+or## (Bit m1 v1) (Bit m2 v2) = Bit mask ((v1 .|. v2) .&. complement mask)+  where mask = m1 .&. complement v2 .|.  m1.&.m2  .|.  m2 .&. complement v1+{-# OPAQUE or## #-}+{-# ANN or## hasBlackBox #-} -xor## b1 b2 = unpack# $ xor# (pack# b1) (pack# b2)-{-# NOINLINE xor## #-}+xor## (Bit m1 v1) (Bit m2 v2) = Bit mask ((v1 `xor` v2) .&. complement mask)+  where mask = m1 .|. m2+{-# OPAQUE xor## #-}+{-# ANN xor## hasBlackBox #-}  complement## :: Bit -> Bit-complement## = unpack# . complement# . pack#-{-# NOINLINE complement## #-}+complement## (Bit m v) = Bit m (complementB v .&. complementB m)+  where complementB (W# b#) = W# (int2Word# (eqWord# b# 0##))+{-# OPAQUE complement## #-}+{-# ANN complement## hasBlackBox #-}  -- *** BitPack pack# :: Bit -> BitVector 1-pack# (Bit m b) = BV m b-{-# NOINLINE pack# #-}+pack# (Bit (W# m) (W# b)) = BV (NS m) (NS b)+{-# OPAQUE pack# #-}+{-# ANN pack# hasBlackBox #-}  unpack# :: BitVector 1 -> Bit-unpack# (BV m b) = Bit m b-{-# NOINLINE unpack# #-}+unpack# (BV m b) = Bit (go m) (go b)+ where+  go (NS w) = W# w+  go (NB w) = bigNatToWord w+{-# OPAQUE unpack# #-}+{-# ANN unpack# hasBlackBox #-}  -- * Instances instance NFData (BitVector n) where@@ -347,64 +434,78 @@   -- coercion  instance KnownNat n => Show (BitVector n) where-  show bv@(BV msk i) = reverse . underScore . reverse $ showBV (natVal bv) msk i []-    where-      showBV 0 _ _ s = s-      showBV n m v s = let (v',vBit) = divMod v 2-                           (m',mBit) = divMod m 2-                       in  case (mBit,vBit) of-                           (0,0) -> showBV (n - 1) m' v' ('0':s)-                           (0,_) -> showBV (n - 1) m' v' ('1':s)-                           _     -> showBV (n - 1) m' v' ('.':s)+  show (BV m i) =+    case natToNum @n @Int of+      0 -> "0"+      _ -> '0' : 'b' : go groupSize (natToNum @n @Int) m i []+   where+    go _ 0 _ _ s = s+    go c n m0 v0 s =+      let+        (!v1, !vBit) = quotRem v0 2+        (!m1, !mBit) = quotRem m0 2+        !renderedBit = showBit mBit vBit+      in+        case c of+          0 -> go (groupSize - 1) (n - 1) m1 v1 (renderedBit : '_' : s)+          _ -> go (c - 1)         (n - 1) m1 v1 (renderedBit :       s) -      underScore xs = case splitAt 5 xs of-                        ([a,b,c,d,e],rest) -> [a,b,c,d,'_'] ++ underScore (e:rest)-                        (rest,_)               -> rest+    showBit 0 0 = '0'+    showBit 0 1 = '1'+    showBit _ _ = '.'++    groupSize :: Int+    groupSize = 4   {-# NOINLINE show #-}  instance KnownNat n => ShowX (BitVector n) where   showsPrecX = showsPrecXWith showsPrec -instance NFDataX (BitVector n) where-  deepErrorX = errorX+instance KnownNat n => NFDataX (BitVector n) where+  deepErrorX _ = undefined#   rnfX = rwhnfX+  hasUndefined bv = isLeft (isX bv) || unsafeMask bv /= 0+  ensureSpine = xToBV -- Converts `XException` to 'undefined#'  -- | Create a binary literal ----- >>> $$(bLit "1001") :: BitVector 4--- 1001--- >>> $$(bLit "1001") :: BitVector 3--- 001+-- >>> $(bLit "1001")+-- 0b1001 -- -- __NB__: You can also just write: -- -- >>> 0b1001 :: BitVector 4--- 1001+-- 0b1001 -- -- The advantage of 'bLit' is that you can use computations to create the -- string literal: -- -- >>> import qualified Data.List as List--- >>> $$(bLit (List.replicate 4 '1')) :: BitVector 4--- 1111+-- >>> $(bLit (List.replicate 4 '1'))+-- 0b1111 -- -- Also 'bLit' can handle don't care bits: ----- >>> $$(bLit "1.0.") :: BitVector 4--- 1.0.-bLit :: forall n. KnownNat n => String -> Q (TExp (BitVector n))-bLit s = [|| fromInteger# m i ||]-  where-    bv :: BitVector n-    bv = read# s+-- >>> $(bLit "1.0.")+-- 0b1.0.+--+-- __NB__: From Clash 1.6 an onwards 'bLit' will deduce the size of the+-- BitVector from the given string and annotate the splice it produces+-- accordingly.+bLit :: String -> ExpQ+bLit s = pure (SigE body typ)+ where+  typ = ConT ''BitVector `AppT` LitT (NumTyLit (toInteger n))+  body = VarE 'fromInteger# `AppE` iLit mask `AppE` iLit value -    m,i :: Integer-    BV m i = bv+  iLit = LitE . IntegerL . toInteger+  (n, BV mask value) = read# s :: (Natural, BitVector n) -read# :: KnownNat n => String -> BitVector n-read# cs = BV m v+read# :: String -> (Natural, BitVector n)+read# cs0 = (fromIntegral (length cs1), BV m v)   where-    (vs,ms) = unzip . map readBit . filter (/= '_') $ cs+    cs1 = filter (/= '_') cs0+    (vs, ms) = unzip (map readBit cs1)     combineBits = foldl (\b a -> b*2+a) 0     v = combineBits vs     m = combineBits ms@@ -412,19 +513,91 @@       '0' -> (0,0)       '1' -> (1,0)       '.' -> (0,1)-      _   -> error $ "Clash.Sized.Internal.bLit: unknown character: " ++ show c ++ " in input: " ++ cs+      _   -> error $+           "Clash.Sized.Internal.bLit: unknown character: "+        ++ show c ++ " in input: " ++ cs0 +-- | Create a hexadecimal literal+--+-- >>> $(hLit "dead")+-- 0b1101_1110_1010_1101+--+-- Don't care digits set 4 bits:+--+-- >>> $(hLit "de..")+-- 0b1101_1110_...._....+hLit :: String -> ExpQ+hLit s = pure (SigE body typ)+  where+    typ = ConT ''BitVector `AppT` LitT (NumTyLit (toInteger n))+    body = VarE 'fromInteger# `AppE` iLit mask `AppE` iLit value +    iLit = LitE . IntegerL . toInteger+    (n, BV mask value) = read16# s :: (Natural, BitVector n)++read16# :: String -> (Natural, BitVector n)+read16# cs0 = (fromIntegral $ 4 * length cs1, BV m v)+  where+    cs1 = filter (/= '_') cs0+    (vs, ms) = unzip $ map readHexDigit cs1+    combineHexDigits = foldl (\b a -> 16*b+a) 0+    v = combineHexDigits vs+    m = combineHexDigits ms+    -- The dot is a don't care, which applies to a whole digit.+    readHexDigit '.' = (0, 0xf)+    readHexDigit c = case readHex [c] of+      [(n,  "")] -> (n, 0)+      _ -> error $+             "Clash.Sized.Internal.hLit: unknown character: "+             ++ show c ++ " in input: " ++ cs0++-- | Create an octal literal+--+-- >>> $(oLit "5234")+-- 0b1010_1001_1100+--+-- Don't care digits set 3 bits:+--+-- >>> $(oLit "52..")+-- 0b1010_10.._....+oLit :: String -> ExpQ+oLit s = pure (SigE body typ)+  where+    typ = ConT ''BitVector `AppT` LitT (NumTyLit (toInteger n))+    body = VarE 'fromInteger# `AppE` iLit mask `AppE` iLit value++    iLit = LitE . IntegerL . toInteger+    (n, BV mask value) = read8# s :: (Natural, BitVector n)++read8# :: String -> (Natural, BitVector n)+read8# cs0 = (fromIntegral $ 3 * length cs1, BV m v)+  where+    cs1 = filter (/= '_') cs0+    (vs, ms) = unzip $ map readOctDigit cs1+    combineOctDigits = foldl (\b a -> 8*b+a) 0+    v = combineOctDigits vs+    m = combineOctDigits ms+    -- The dot is a don't care, which applies to a whole digit.+    readOctDigit '.' = (0, 0o7)+    readOctDigit c = case readOct [c] of+      [(n,  "")] -> (n, 0)+      _ -> error $+             "Clash.Sized.Internal.oLit: unknown character: "+             ++ show c ++ " in input: " ++ cs0++ instance KnownNat n => Eq (BitVector n) where   (==) = eq#   (/=) = neq# -{-# NOINLINE eq# #-}+{-# OPAQUE eq# #-}+{-# ANN eq# hasBlackBox #-} eq# :: KnownNat n => BitVector n -> BitVector n -> Bool eq# (BV 0 v1) (BV 0 v2 ) = v1 == v2 eq# bv1 bv2 = undefErrorI "==" bv1 bv2 -{-# NOINLINE neq# #-}+{-# OPAQUE neq# #-}+{-# ANN neq# hasBlackBox #-} neq# :: KnownNat n => BitVector n -> BitVector n -> Bool neq# (BV 0 v1) (BV 0 v2) = v1 /= v2 neq# bv1 bv2 = undefErrorI "/=" bv1 bv2@@ -436,16 +609,20 @@   (<=) = le#  lt#,ge#,gt#,le# :: KnownNat n => BitVector n -> BitVector n -> Bool-{-# NOINLINE lt# #-}+{-# OPAQUE lt# #-}+{-# ANN lt# hasBlackBox #-} lt# (BV 0 n) (BV 0 m) = n < m lt# bv1 bv2 = undefErrorI "<" bv1 bv2-{-# NOINLINE ge# #-}+{-# OPAQUE ge# #-}+{-# ANN ge# hasBlackBox #-} ge# (BV 0 n) (BV 0 m) = n >= m ge# bv1 bv2 = undefErrorI ">=" bv1 bv2-{-# NOINLINE gt# #-}+{-# OPAQUE gt# #-}+{-# ANN gt# hasBlackBox #-} gt# (BV 0 n) (BV 0 m) = n > m gt# bv1 bv2 = undefErrorI ">" bv1 bv2-{-# NOINLINE le# #-}+{-# OPAQUE le# #-}+{-# ANN le# hasBlackBox #-} le# (BV 0 n) (BV 0 m) = n <= m le#  bv1 bv2 = undefErrorI "<=" bv1 bv2 @@ -454,52 +631,85 @@ instance KnownNat n => Enum (BitVector n) where   succ           = (+# fromInteger# 0 1)   pred           = (-# fromInteger# 0 1)-  toEnum         = fromInteger# 0 . toInteger-  fromEnum       = fromEnum . toInteger#+  toEnum         = toEnum#+  fromEnum       = fromEnum#   enumFrom       = enumFrom#   enumFromThen   = enumFromThen#   enumFromTo     = enumFromTo#   enumFromThenTo = enumFromThenTo# -{-# NOINLINE enumFrom# #-}-{-# NOINLINE enumFromThen# #-}-{-# NOINLINE enumFromTo# #-}-{-# NOINLINE enumFromThenTo# #-}-enumFrom#       :: KnownNat n => BitVector n -> [BitVector n]-enumFromThen#   :: KnownNat n => BitVector n -> BitVector n -> [BitVector n]-enumFromTo#     :: KnownNat n => BitVector n -> BitVector n -> [BitVector n]-enumFromThenTo# :: KnownNat n => BitVector n -> BitVector n -> BitVector n -> [BitVector n]+toEnum# :: forall n. KnownNat n => Int -> BitVector n+toEnum# = fromInteger# 0 . toInteger+{-# OPAQUE toEnum# #-}+{-# ANN toEnum# hasBlackBox #-} -enumFrom# (BV 0 x)                           = map (fromInteger_INLINE 0) [x ..]-enumFrom# bv-  = undefErrorU "enumFrom" bv+fromEnum# :: forall n. KnownNat n => BitVector n -> Int+fromEnum# = fromEnum . toInteger#+{-# OPAQUE fromEnum# #-}+{-# ANN fromEnum# hasBlackBox #-} -enumFromThen# (BV 0 x) (BV 0 y)              = map (fromInteger_INLINE 0) [x, y ..]-enumFromThen# bv1 bv2-  = undefErrorP "enumFromThen" bv1 bv2+enumFrom# :: forall n. KnownNat n => BitVector n -> [BitVector n]+enumFrom# (BV 0 x) = map (BV 0 . (`mod` m)) [x .. unsafeToNatural (maxBound :: BitVector n)]+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))+enumFrom# bv = undefErrorU "enumFrom" bv+{-# OPAQUE enumFrom# #-} -enumFromTo# (BV 0 x) (BV 0 y)                = map (BV 0) [x .. y]-enumFromTo# bv1 bv2-  = undefErrorP "enumFromTo" bv1 bv2+enumFromThen#+  :: forall n+   . KnownNat n+  => BitVector n+  -> BitVector n+  -> [BitVector n]+enumFromThen# (BV 0 x) (BV 0 y) =+  toBvs [x, y .. unsafeToNatural bound]+ where+  bound = if x <= y then maxBound else minBound :: BitVector n+  toBvs = map (BV 0 . (`mod` m))+  m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))+enumFromThen# bv1 bv2 = undefErrorP "enumFromThen" bv1 bv2+{-# OPAQUE enumFromThen# #-} -enumFromThenTo# (BV 0 x1) (BV 0 x2) (BV 0 y) = map (BV 0) [x1, x2 .. y]-enumFromThenTo# bv1 bv2 bv3-  = undefErrorP3 "enumFromTo" bv1 bv2 bv3+enumFromTo#+  :: forall n+   . KnownNat n+  => BitVector n+  -> BitVector n+  -> [BitVector n]+enumFromTo# (BV 0 x) (BV 0 y) = map (BV 0 . (`mod` m)) [x .. y]+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))+enumFromTo# bv1 bv2 = undefErrorP "enumFromTo" bv1 bv2+{-# OPAQUE enumFromTo# #-} +enumFromThenTo#+  :: forall n+   . KnownNat n+  => BitVector n+  -> BitVector n+  -> BitVector n+  -> [BitVector n]+enumFromThenTo# (BV 0 x1) (BV 0 x2) (BV 0 y) = map (BV 0 . (`mod` m)) [x1, x2 .. y]+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))+enumFromThenTo# bv1 bv2 bv3 = undefErrorP3 "enumFromTo" bv1 bv2 bv3+{-# OPAQUE enumFromThenTo# #-} + instance KnownNat n => Bounded (BitVector n) where   minBound = minBound#   maxBound = maxBound# -{-# NOINLINE minBound# #-} minBound# :: BitVector n minBound# = BV 0 0+{-# OPAQUE minBound# #-}+{-# ANN minBound# hasBlackBox #-} -{-# NOINLINE maxBound# #-}-maxBound# :: forall n . KnownNat n => BitVector n-maxBound# = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))-            in  BV 0 (m-1)+maxBound# :: forall n. KnownNat n => BitVector n+maxBound# = let m = 1 `shiftL` natToNum @n in BV 0 (m-1)+{-# OPAQUE maxBound# #-}+{-# ANN maxBound# hasBlackBox #-} +-- | __NB__: 'fromInteger'/'fromIntegral' can cause unexpected truncation, as+-- 'Integer' is arbitrarily bounded during synthesis.  Prefer+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class. instance KnownNat n => Num (BitVector n) where   (+)         = (+#)   (-)         = (-#)@@ -510,41 +720,51 @@   fromInteger = fromInteger# 0  (+#),(-#),(*#) :: forall n . KnownNat n => BitVector n -> BitVector n -> BitVector n-{-# NOINLINE (+#) #-}-(+#) (BV 0 i) (BV 0 j) =-  let m = 1 `shiftL` fromInteger (natVal (Proxy @n))-      z = i + j-  in  if z >= m then BV 0 (z - m) else BV 0 z-(+#) bv1 bv2 = undefErrorI "+" bv1 bv2+{-# OPAQUE (+#) #-}+{-# ANN (+#) hasBlackBox #-}+(+#) = go+  where+    go (BV 0 i) (BV 0 j) = BV 0 (addMod m i j)+    go bv1 bv2 = undefErrorI "+" bv1 bv2 -{-# NOINLINE (-#) #-}-(-#) (BV 0 i) (BV 0 j) =-  let m = 1 `shiftL` fromInteger (natVal (Proxy @n))-      z = i - j-  in  if z < 0 then BV 0 (m + z) else BV 0 z-(-#) bv1 bv2 = undefErrorI "-" bv1 bv2+    m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n)) -{-# NOINLINE (*#) #-}-(*#) (BV 0 i) (BV 0 j) = fromInteger_INLINE 0 (i * j)-(*#) bv1 bv2 = undefErrorI "*" bv1 bv2+{-# OPAQUE (-#) #-}+{-# ANN (-#) hasBlackBox #-}+(-#) = go+  where+    go (BV 0 i) (BV 0 j) = BV 0 (subMod m i j)+    go bv1 bv2 = undefErrorI "-" bv1 bv2 -{-# NOINLINE negate# #-}+    m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))++{-# OPAQUE (*#) #-}+{-# ANN (*#) hasBlackBox #-}+(*#) = go+ where+  go (BV 0 i) (BV 0 j) = BV 0 (mulMod2 m i j)+  go bv1 bv2 = undefErrorI "*" bv1 bv2++  m = (1 `naturalShiftL` naturalToWord (natVal (Proxy @n))) - 1++{-# OPAQUE negate# #-}+{-# ANN negate# hasBlackBox #-} negate# :: forall n . KnownNat n => BitVector n -> BitVector n-negate# (BV 0 0) = BV 0 0-negate# (BV 0 i) = BV 0 (sz - i)-  where-    sz = 1 `shiftL` fromInteger (natVal (Proxy @n))-negate# bv = undefErrorU "negate" bv+negate# = go+ where+  go (BV 0 i) = BV 0 (negateMod m i)+  go bv = undefErrorU "negate" bv -{-# NOINLINE fromInteger# #-}-fromInteger# :: KnownNat n => Integer -> Integer -> BitVector n-fromInteger# = fromInteger_INLINE+  m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n)) -{-# INLINE fromInteger_INLINE #-}-fromInteger_INLINE :: forall n . KnownNat n => Integer -> Integer -> BitVector n-fromInteger_INLINE m i = sz `seq` BV (m `mod` sz) (i `mod` sz)+{-# OPAQUE fromInteger# #-}+{-# ANN fromInteger# hasBlackBox #-}+fromInteger# :: KnownNat n => Natural -> Integer -> BitVector n+fromInteger# m i = sz `seq` mx   where-    sz = 1 `shiftL` fromInteger (natVal (Proxy @n))+    mx = BV (m `mod` sz)+            (integerToNatural (i `mod` integerFromNatural sz))+    sz  = 1 `naturalShiftL` naturalToWord (natVal mx)  instance (KnownNat m, KnownNat n) => ExtendingNum (BitVector m) (BitVector n) where   type AResult (BitVector m) (BitVector n) = BitVector (Max m n + 1)@@ -553,29 +773,35 @@   type MResult (BitVector m) (BitVector n) = BitVector (m + n)   mul = times# -{-# NOINLINE plus# #-}+{-# OPAQUE plus# #-}+{-# ANN plus# hasBlackBox #-} plus# :: (KnownNat m, KnownNat n) => BitVector m -> BitVector n -> BitVector (Max m n + 1) plus# (BV 0 a) (BV 0 b) = BV 0 (a + b)-plus# bv1 bv2 = undefErrorP "plus" bv1 bv2+plus# bv1 bv2 = undefErrorP "add" bv1 bv2 -{-# NOINLINE minus# #-}+{-# OPAQUE minus# #-}+{-# ANN minus# hasBlackBox #-} minus# :: forall m n . (KnownNat m, KnownNat n) => BitVector m -> BitVector n                                                 -> BitVector (Max m n + 1)-minus# (BV 0 a) (BV 0 b) =-  let sz   = fromInteger (natVal (Proxy @(Max m n + 1)))-      mask = 1 `shiftL` sz-      z    = a - b-  in  if z < 0 then BV 0 (mask + z) else BV 0 z-minus# bv1 bv2 = undefErrorP "minus" bv1 bv2+minus# = go+ where+  go (BV 0 a) (BV 0 b) = BV 0 (subMod m a b)+  go bv1 bv2 = undefErrorP "sub" bv1 bv2 -{-# NOINLINE times# #-}+  m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @(Max m n + 1)))++{-# OPAQUE times# #-}+{-# ANN times# hasBlackBox #-} times# :: (KnownNat m, KnownNat n) => BitVector m -> BitVector n -> BitVector (m + n) times# (BV 0 a) (BV 0 b) = BV 0 (a * b)-times# bv1 bv2 = undefErrorP "times" bv1 bv2+times# bv1 bv2 = undefErrorP "mul" bv1 bv2  instance KnownNat n => Real (BitVector n) where   toRational = toRational . toInteger# +-- | __NB__: 'toInteger'/'fromIntegral' can cause unexpected truncation, as+-- 'Integer' is arbitrarily bounded during synthesis.  Prefer+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class. instance KnownNat n => Integral (BitVector n) where   quot        = quot#   rem         = rem#@@ -586,18 +812,25 @@   toInteger   = toInteger#  quot#,rem# :: KnownNat n => BitVector n -> BitVector n -> BitVector n-{-# NOINLINE quot# #-}+{-# OPAQUE quot# #-}+{-# ANN quot# hasBlackBox #-} quot# (BV 0 i) (BV 0 j) = BV 0 (i `quot` j) quot# bv1 bv2 = undefErrorP "quot" bv1 bv2-{-# NOINLINE rem# #-}+{-# OPAQUE rem# #-}+{-# ANN rem# hasBlackBox #-} rem# (BV 0 i) (BV 0 j) = BV 0 (i `rem` j) rem# bv1 bv2 = undefErrorP "rem" bv1 bv2 -{-# NOINLINE toInteger# #-}+{-# OPAQUE toInteger# #-}+{-# ANN toInteger# hasBlackBox #-} toInteger# :: KnownNat n => BitVector n -> Integer-toInteger# (BV 0 i) = i+toInteger# (BV 0 i) = naturalToInteger i toInteger# bv = undefErrorU "toInteger" bv +-- | @'shiftR' a n@:+--+-- * Returns 0 if @n >= 'bitSize' a@+-- * 'Clash.XException.XException' if @n < 0@ instance KnownNat n => Bits (BitVector n) where   (.&.)             = and#   (.|.)             = or#@@ -631,72 +864,99 @@ countTrailingZerosBV = V.foldl (\l r -> if eq## r low then 1 + l else 0) 0 . V.bv2v {-# INLINE countTrailingZerosBV #-} -{-# NOINLINE reduceAnd# #-}+{-# OPAQUE reduceAnd# #-}+{-# ANN reduceAnd# hasBlackBox #-} reduceAnd# :: KnownNat n => BitVector n -> Bit-reduceAnd# bv@(BV 0 i) = Bit 0 (smallInteger (dataToTag# check))+reduceAnd# bv@(BV 0 i) = Bit 0 (W# (int2Word# (dataToTag# check)))   where     check = i == maxI      sz    = natVal bv     maxI  = (2 ^ sz) - 1-reduceAnd# bv = V.foldl (.&.) 1 (V.bv2v bv)+reduceAnd# bv@(BV m i) =+    -- If any defined bit is 0, i.e., 'm .|. i /= maxI', then the result is+    -- '0' (Bit 0 0), otherwise the result is '.' (Bit 1 0).+    Bit (W# (int2Word# (dataToTag# check))) 0+  where+    check = m .|. i == maxI -{-# NOINLINE reduceOr# #-}+    sz    = natVal bv+    maxI  = (2 ^ sz) - 1++{-# OPAQUE reduceOr# #-}+{-# ANN reduceOr# hasBlackBox #-} reduceOr# :: KnownNat n => BitVector n -> Bit-reduceOr# (BV 0 i) = Bit 0 (smallInteger (dataToTag# check))+reduceOr# (BV 0 i) = Bit 0 (W# (int2Word# (dataToTag# check)))   where     check = i /= 0-reduceOr# bv = V.foldl (.|.) 0 (V.bv2v bv)+reduceOr# bv@(BV m i) | defI /= 0 = Bit 0 1+                      | otherwise = Bit 1 0+ where+  complementN = complementMod $ natVal bv+  defI = i .&. (complementN m) -{-# NOINLINE reduceXor# #-}+{-# OPAQUE reduceXor# #-}+{-# ANN reduceXor# hasBlackBox #-} reduceXor# :: KnownNat n => BitVector n -> Bit-reduceXor# (BV 0 i) = Bit 0 (toInteger (popCount i `mod` 2))-reduceXor# bv = undefErrorU "reduceXor" bv+reduceXor# (BV 0 i) = Bit 0 (fromIntegral (popCount i `mod` 2))+reduceXor# _ = Bit 1 0  instance Default (BitVector n) where   def = minBound#  -- * Accessors -- ** Length information-{-# NOINLINE size# #-}+{-# OPAQUE size# #-}+{-# ANN size# hasBlackBox #-} size# :: KnownNat n => BitVector n -> Int-size# bv = fromInteger (natVal bv)+size# bv = fromIntegral (natVal bv) -{-# NOINLINE maxIndex# #-}+{-# OPAQUE maxIndex# #-}+{-# ANN maxIndex# hasBlackBox #-} maxIndex# :: KnownNat n => BitVector n -> Int-maxIndex# bv = fromInteger (natVal bv) - 1+maxIndex# bv = fromIntegral (natVal bv) - 1  -- ** Indexing-{-# NOINLINE index# #-}+{-# OPAQUE index# #-}+{-# ANN index# hasBlackBox #-} index# :: KnownNat n => BitVector n -> Int -> Bit index# bv@(BV m v) i-    | i >= 0 && i < sz = Bit (smallInteger (dataToTag# (testBit m i)))-                             (smallInteger (dataToTag# (testBit v i)))+    | i >= 0 && i < sz = Bit (W# (int2Word# (dataToTag# (testBit m i))))+                             (W# (int2Word# (dataToTag# (testBit v i))))     | otherwise        = err   where-    sz  = fromInteger (natVal bv)+    sz  = fromIntegral (natVal bv)     err = error $ concat [ "(!): "                          , show i-                         , " is out of range ["-                         , show (sz - 1)-                         , "..0]"+                         , " is out of range "+                         , formatRange 0 (sz - 1)                          ] -{-# NOINLINE msb# #-}+{-# OPAQUE msb# #-}+{-# ANN msb# hasBlackBox #-} -- | MSB msb# :: forall n . KnownNat n => BitVector n -> Bit msb# (BV m v)-  = let i = fromInteger (natVal (Proxy @n) - 1)-    in  Bit (smallInteger (dataToTag# (testBit m i)))-            (smallInteger (dataToTag# (testBit v i)))+  = Bit (msbN m)+        (msbN v)+ where+  !(NS i#) = natVal (Proxy @n) -{-# NOINLINE lsb# #-}+  msbN (NS w) =+    if isTrue# (i# `gtWord#` WORD_SIZE_IN_BITS##)+    then W# 0##+    else W# (w `uncheckedShiftRL#` (word2Int# (i# `minusWord#` 1##)))+  msbN (NB bn) = bigNatToWord (bigNatShiftR# bn (i# `minusWord#` 1##))++{-# OPAQUE lsb# #-}+{-# ANN lsb# hasBlackBox #-} -- | LSB lsb# :: BitVector n -> Bit-lsb# (BV m v) = Bit (smallInteger (dataToTag# (testBit m 0)))-                    (smallInteger (dataToTag# (testBit v 0)))+lsb# (BV m v) = Bit (W# (int2Word# (dataToTag# (testBit m 0))))+                    (W# (int2Word# (dataToTag# (testBit v 0)))) -{-# NOINLINE slice# #-}+{-# OPAQUE slice# #-}+{-# ANN slice# hasBlackBox #-} slice# :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) slice# (BV msk i) m n = BV (shiftR (msk .&. mask) n')                            (shiftR (i   .&. mask) n')@@ -709,128 +969,168 @@ -- * Constructions  -- ** Concatenation-{-# NOINLINE (++#) #-}+{-# OPAQUE (++#) #-}+{-# ANN (++#) hasBlackBox #-} -- | Concatenate two 'BitVector's (++#) :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m) (BV m1 v1) ++# bv2@(BV m2 v2) = BV (m1' .|. m2) (v1' .|. v2)   where-    size2 = fromInteger (natVal bv2)-    v1' = shiftL v1 size2-    m1' = shiftL m1 size2+    size2 = fromIntegral (natVal bv2)+    v1' = naturalShiftL v1 size2+    m1' = naturalShiftL m1 size2  -- * Modifying BitVectors-{-# NOINLINE replaceBit# #-}+{-# OPAQUE replaceBit# #-}+{-# ANN replaceBit# hasBlackBox #-} replaceBit# :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n replaceBit# bv@(BV m v) i (Bit mb b)-    | i >= 0 && i < sz = BV (clearBit m i  .|. (mb `shiftL` i))+    | i >= 0 && i < sz = BV (clearBit m i .|. (naturalFromWord mb `shiftL` i))                             (if testBit b 0 && mb == 0 then setBit v i else clearBit v i)     | otherwise        = err   where-    sz   = fromInteger (natVal bv)+    sz   = fromIntegral (natVal bv)     err  = error $ concat [ "replaceBit: "                           , show i-                          , " is out of range ["-                          , show (sz - 1)-                          , "..0]"+                          , " is out of range "+                          , formatRange 0 (sz - 1)                           ] -{-# NOINLINE setSlice# #-}+{-# OPAQUE setSlice# #-}+{-# ANN setSlice# hasBlackBox #-} setSlice#-  :: BitVector (m + 1 + i)+  :: forall m i n+   . SNat (m + 1 + i)+  -> BitVector (m + 1 + i)   -> SNat m   -> SNat n   -> BitVector (m + 1 - n)   -> BitVector (m + 1 + i)-setSlice# (BV iMask i) m n (BV jMask j) = BV ((iMask .&. mask) .|. jMask')-                                             ((i     .&. mask) .|. j')-  where-    m' = snatToInteger m-    n' = snatToInteger n+setSlice# SNat =+  \(BV iMask i) m@SNat n (BV jMask j) ->+    let m' = snatToInteger m+        n' = snatToInteger n -    j'     = shiftL j     (fromInteger n')-    jMask' = shiftL jMask (fromInteger n')-    mask = complement ((2 ^ (m' + 1) - 1) `xor` (2 ^ n' - 1))+        j'     = shiftL j     (fromInteger n')+        jMask' = shiftL jMask (fromInteger n')+        mask   = complementN ((2 ^ (m' + 1) - 1) `xor` (2 ^ n' - 1))+    in  BV ((iMask .&. mask) .|. jMask') ((i .&. mask) .|. j')+ where+  complementN = complementMod (natVal (Proxy @(m + 1 + i))) -{-# NOINLINE split# #-}+{-# OPAQUE split# #-}+{-# ANN split# hasBlackBox #-} split#   :: forall n m    . KnownNat n   => BitVector (m + n)   -> (BitVector m, BitVector n)-split# (BV m i) = (BV lMask l, BV rMask r)-  where-    n     = fromInteger (natVal (Proxy @n))-    mask  = 1 `shiftL` n-    -- The code below is faster than:-    -- > (l,r) = i `divMod` mask-    r     = i `mod` mask-    rMask = m `mod` mask-    l     = i `shiftR` n-    lMask = m `shiftR` n-+split# (BV m i) =+  let n     = naturalToWord (natVal (Proxy @n))+      mask  = maskMod (natVal (Proxy @n))+      r     = mask i+      rMask = mask m+      l     = i `naturalShiftR` n+      lMask = m `naturalShiftR` n+  in  (BV lMask l, BV rMask r) -and#, or#, xor# :: BitVector n -> BitVector n -> BitVector n-{-# NOINLINE and# #-}-and# (BV m1 v1) (BV m2 v2) = BV mask (v1 .&. v2  .&. complement mask)+and#, or#, xor# :: forall n . KnownNat n => BitVector n -> BitVector n -> BitVector n+{-# OPAQUE and# #-}+{-# ANN and# hasBlackBox #-}+and# =+  \(BV m1 v1) (BV m2 v2) ->+    let mask = (m1.&.v2 .|. m1.&.m2 .|. m2.&.v1)+    in  BV mask (v1 .&. v2  .&. complementN mask)   where-    mask = (m1.&.v2 .|. m1.&.m2 .|. m2.&.v1)+    complementN = complementMod (natVal (Proxy @n)) -{-# NOINLINE or# #-}-or# (BV m1 v1) (BV m2 v2) = BV mask ((v1.|.v2) .&. complement mask)+{-# OPAQUE or# #-}+{-# ANN or# hasBlackBox #-}+or# =+  \(BV m1 v1) (BV m2 v2) ->+    let mask = m1 .&. complementN v2  .|.  m1.&.m2  .|.  m2 .&. complementN v1+    in  BV mask ((v1.|.v2) .&. complementN mask)   where-    mask = m1 .&. complement v2  .|.  m1.&.m2  .|.  m2 .&. complement v1+    complementN = complementMod (natVal (Proxy @n)) -{-# NOINLINE xor# #-}-xor# (BV m1 v1) (BV m2 v2) = BV mask ((v1 `xor` v2) .&. complement mask)+{-# OPAQUE xor# #-}+{-# ANN xor# hasBlackBox #-}+xor# =+  \(BV m1 v1) (BV m2 v2) ->+    let mask  = m1 .|. m2+    in  BV mask ((v1 `xor` v2) .&. complementN mask)   where-    mask = m1 .|. m2-+    complementN = complementMod (natVal (Proxy @n)) -{-# NOINLINE complement# #-}-complement# :: KnownNat n => BitVector n -> BitVector n-complement# (BV m v) = fromInteger_INLINE m (complement v .&. complement m)+{-# OPAQUE complement# #-}+{-# ANN complement# hasBlackBox #-}+complement# :: forall n . KnownNat n => BitVector n -> BitVector n+complement# = \(BV m v) -> BV m (complementN v .&. complementN m)+  where complementN = complementMod (natVal (Proxy @n))  shiftL#, shiftR#, rotateL#, rotateR#-  :: KnownNat n => BitVector n -> Int -> BitVector n+  :: forall n . KnownNat n => BitVector n -> Int -> BitVector n -{-# NOINLINE shiftL# #-}-shiftL# (BV m v) i-  | i < 0     = error-              $ "'shiftL undefined for negative number: " ++ show i-  | otherwise = fromInteger_INLINE (shiftL m i) (shiftL v i)+{-# OPAQUE shiftL# #-}+{-# ANN shiftL# hasBlackBox #-}+shiftL# = \(BV msk v) i ->+  if | i < 0+     -> error $ "'shiftL' undefined for negative number: " ++ show i+     | fromIntegral i >= sz+     -> BV 0 0+     | otherwise+     -> BV ((shiftL msk i) `mod` m) ((shiftL v i) `mod` m)+ where+  sz = naturalToWord (natVal (Proxy @n))+  m = 1 `naturalShiftL` sz -{-# NOINLINE shiftR# #-}+{-# OPAQUE shiftR# #-}+{-# ANN shiftR# hasBlackBox #-} shiftR# (BV m v) i   | i < 0     = error-              $ "'shiftR undefined for negative number: " ++ show i+              $ "'shiftR' undefined for negative number: " ++ show i   | otherwise = BV (shiftR m i) (shiftR v i) -{-# NOINLINE rotateL# #-}-rotateL# _ b | b < 0   = error "'shiftL undefined for negative numbers"-rotateL# bv@(BV m v) b = fromInteger_INLINE (ml .|. mr) (vl .|. vr)-  where-    vl    = shiftL v b'-    vr    = shiftR v b''--    ml    = shiftL m b'-    mr    = shiftR m b''+{-# OPAQUE rotateL# #-}+{-# ANN rotateL# hasBlackBox #-}+rotateL# =+  \(BV msk v) b ->+    if sz == 0 then+      BV msk v+    else if b >= 0 then+      let vl    = naturalShiftL v b'+          vr    = naturalShiftR v b'' -    b'   = b `mod` sz-    b''  = sz - b'-    sz   = fromInteger (natVal bv)+          ml    = naturalShiftL msk b'+          mr    = naturalShiftR msk b'' -{-# NOINLINE rotateR# #-}-rotateR# _ b | b < 0   = error "'shiftR undefined for negative numbers"-rotateR# bv@(BV m v) b = fromInteger_INLINE (ml .|. mr) (vl .|. vr)-  where-    vl   = shiftR v b'-    vr   = shiftL v b''-    ml   = shiftR m b'-    mr   = shiftL m b''+          b'   = fromIntegral b `mod` sz+          b''  = sz - b'+      in  BV ((ml .|. mr) `mod` m) ((vl .|. vr) `mod` m)+    else+      error $ "'rotateL' undefined for negative number: " ++ show b+ where+  sz = naturalToWord (natVal (Proxy @n))+  m  = 1 `naturalShiftL` sz -    b'  = b `mod` sz-    b'' = sz - b'-    sz  = fromInteger (natVal bv)+{-# OPAQUE rotateR# #-}+{-# ANN rotateR# hasBlackBox #-}+rotateR# =+  \(BV msk v) b ->+    if sz == 0 then+      BV msk v+    else if b >= 0 then+      let vl   = naturalShiftR v b'+          vr   = naturalShiftL v b''+          ml   = naturalShiftR msk b'+          mr   = naturalShiftL msk b''+          b'   = fromIntegral b `mod` sz+          b''  = sz - b'+      in  BV ((ml .|. mr) `mod` m) ((vl .|. vr) `mod` m)+    else+      error $ "'rotateR' undefined for negative number: " ++ show b+ where+  sz = naturalToWord (natVal (Proxy @n))+  m  = 1 `naturalShiftL` sz  popCountBV :: forall n . KnownNat n => BitVector (n+1) -> I.Index (n+2) popCountBV bv =@@ -851,15 +1151,18 @@ {-# INLINE resizeBV #-}  truncateB# :: forall a b . KnownNat a => BitVector (a + b) -> BitVector a-truncateB# (BV msk i) = fromInteger_INLINE msk i-{-# NOINLINE truncateB# #-}+truncateB# = \(BV msk i) -> BV (msk `mod` m) (i `mod` m)+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @a))+{-# OPAQUE truncateB# #-}+{-# ANN truncateB# hasBlackBox #-}  instance KnownNat n => Lift (BitVector n) where-  lift bv@(BV m i) = sigE [| fromInteger# m i |] (decBitVector (natVal bv))+  lift bv@(BV m i) = sigE [| fromInteger# m $(litE (IntegerL (toInteger i))) |] (decBitVector (natVal bv))   {-# NOINLINE lift #-}+  liftTyped = liftTypedFromUntyped -decBitVector :: Integer -> TypeQ-decBitVector n = appT (conT ''BitVector) (litT $ numTyLit n)+decBitVector :: Quote m => Natural -> m Type+decBitVector n = appT (conT ''BitVector) (litT $ numTyLit (integerFromNatural n))  instance KnownNat n => SaturatingNum (BitVector n) where   satAdd SatWrap a b = a +# b@@ -868,6 +1171,11 @@     in  if msb# r == low            then truncateB# r            else minBound#+  satAdd SatError a b =+    let r = plus# a b+    in  if msb# r == low+           then truncateB# r+           else undefined#   satAdd _ a b =     let r  = plus# a b     in  if msb# r == low@@ -875,6 +1183,11 @@            else maxBound#    satSub SatWrap a b = a -# b+  satSub SatError a b =+    let r = minus# a b+    in  if msb# r == low+           then truncateB# r+           else undefined#   satSub _ a b =     let r = minus# a b     in  if msb# r == low@@ -888,6 +1201,12 @@     in  case rL of           0 -> rR           _ -> minBound#+  satMul SatError a b =+    let r       = times# a b+        (rL,rR) = split# r+    in  case rL of+          0 -> rR+          _ -> undefined#   satMul _ a b =     let r       = times# a b         (rL,rR) = split# r@@ -921,42 +1240,42 @@   -- error for infix operator-undefErrorI :: (HasCallStack, KnownNat m, KnownNat n) => String -> BitVector m -> BitVector n -> a+undefErrorI :: (KnownNat m, KnownNat n) => String -> BitVector m -> BitVector n -> a undefErrorI op bv1 bv2 = withFrozenCallStack $   errorX $ "Clash.Sized.BitVector." ++ op   ++ " called with (partially) undefined arguments: "   ++ show bv1 ++ " " ++ op ++" " ++ show bv2  -- error for prefix operator/function-undefErrorP :: (HasCallStack, KnownNat m, KnownNat n) => String -> BitVector m -> BitVector n -> a+undefErrorP :: (KnownNat m, KnownNat n) => String -> BitVector m -> BitVector n -> a undefErrorP op bv1 bv2 = withFrozenCallStack $   errorX $ "Clash.Sized.BitVector." ++ op   ++ " called with (partially) undefined arguments: "   ++ show bv1 ++ " " ++ show bv2  -- error for prefix operator/function-undefErrorP3 :: (HasCallStack, KnownNat m, KnownNat n, KnownNat o) => String -> BitVector m -> BitVector n -> BitVector o -> a+undefErrorP3 :: (KnownNat m, KnownNat n, KnownNat o) => String -> BitVector m -> BitVector n -> BitVector o -> a undefErrorP3 op bv1 bv2 bv3 = withFrozenCallStack $   errorX $ "Clash.Sized.BitVector." ++ op   ++ " called with (partially) undefined arguments: "   ++ show bv1 ++ " " ++ show bv2 ++ " " ++ show bv3  -- error for unary operator/function-undefErrorU :: (HasCallStack, KnownNat n) => String -> BitVector n -> a+undefErrorU :: KnownNat n => String -> BitVector n -> a -- undefErrorU op bv1 = undefError ("Clash.Sized.BitVector." ++ op) [bv1] undefErrorU op bv1 = withFrozenCallStack $   errorX $ "Clash.Sized.BitVector." ++ op   ++ " called with (partially) undefined argument: "   ++ show bv1 -undefError :: (HasCallStack, KnownNat n) => String -> [BitVector n] -> a+undefError :: KnownNat n => String -> [BitVector n] -> a undefError op bvs = withFrozenCallStack $   errorX $ op   ++ " called with (partially) undefined arguments: "   ++ unwords (L.map show bvs)  --- | Implement BitVector undefinedness checking for unpack funtions+-- | Implement BitVector undefinedness checking for unpack functions checkUnpackUndef :: (KnownNat n, Typeable a)                  => (BitVector n -> a) -- ^ unpack function                  -> BitVector n -> a@@ -965,37 +1284,44 @@   where     ty = typeOf res     res = undefError (show ty ++ ".unpack") [bv]-{-# NOINLINE checkUnpackUndef #-}+{-# OPAQUE checkUnpackUndef #-}+{-# ANN checkUnpackUndef hasBlackBox #-}  -- | Create a BitVector with all its bits undefined undefined# :: forall n . KnownNat n => BitVector n undefined# =-  let m = 1 `shiftL` fromInteger (natVal (Proxy @n))+  let m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))   in  BV (m-1) 0-{-# NOINLINE undefined# #-}+{-# OPAQUE undefined# #-}+{-# ANN undefined# hasBlackBox #-} --- | Check if one BitVector is like another.--- NFDataX bits in the second argument are interpreted as don't care bits.+-- | Check if one BitVector is similar to another, interpreting undefined bits+-- in the second argument as being "don't care" bits. This is a more lenient+-- version of '(==)', similar to @std_match@ in VHDL or @casez@ in Verilog. ----- >>> let expected = $$(bLit "1.") :: BitVector 2--- >>> let checked  = $$(bLit "11") :: BitVector 2--- >>> checked  `isLike` expected+-- >>> let expected = $(bLit "1.")+-- >>> let checked  = $(bLit "11")+--+-- >>> checked  `isLike#` expected -- True--- >>> expected `isLike` checked+-- >>> expected `isLike#` checked -- False -- -- __NB__: Not synthesizable-isLike :: BitVector n -> BitVector n -> Bool-isLike (BV cMask c) (BV eMask e) = e' == c' && e' == c''-  where-    -- | set don't care bits to 0-    e' = e .&. complement eMask--    -- | checked with undefined bits set to 0-    c' = (c .&. complement cMask) .&. complement eMask-    -- | checked with undefined bits set to 1-    c'' = (c .|. cMask) .&. complement eMask-{-# NOINLINE isLike #-}+--+isLike# :: forall n . KnownNat n => BitVector n -> BitVector n -> Bool+isLike# =+  \(BV cMask c) (BV eMask e) ->+        -- set don't care bits to 0+    let e' = e .&. complementN eMask+        -- checked with undefined bits set to 0+        c' = (c .&. complementN cMask) .&. complementN eMask+        -- checked with undefined bits set to 1+        c'' = (c .|. cMask) .&. complementN eMask+    in  e' == c' && e' == c''+ where+  complementN = complementMod (natVal (Proxy @n))+{-# OPAQUE isLike# #-}  fromBits :: [Bit] -> Integer fromBits = L.foldl (\v b -> v `shiftL` 1 .|. fromIntegral b) 0@@ -1008,27 +1334,62 @@ -- pattern. The scrutinee can be any type that is an instance of the -- 'Num', 'Bits' and 'Eq' typeclasses. ----- The bit pattern is specified by a string which contains @\'0\'@ or--- @\'1\'@ for matching a bit, or @\'.\'@ for bits which are not matched.+-- The bit pattern is specified by a string which contains: --+--   * @\'0\'@ or @\'1\'@ for matching a bit+--+--   * @\'.\'@ for bits which are not matched (wildcard)+--+--   * @\'_\'@ can be used as a separator similar to the NumericUnderscores+--   language extension+--+--   * lowercase alphabetical characters can be used to bind some bits to variables.+--   For example @"0aab11bb"@ will bind two variables @aa :: BitVector 2@ and+--   @bbb :: BitVector 3@ with their values set by the corresponding bits+-- -- The following example matches a byte against two bit patterns where--- some bits are relevant and others are not:+-- some bits are relevant and others are not while binding two variables @aa@+-- and @bb@: -- -- @ --   decode :: Unsigned 8 -> Maybe Bool---   decode $(bitPattern "00...110") = Just True---   decode $(bitPattern "10..0001") = Just False+--   decode $(bitPattern "00.._.110") = Just True+--   decode $(bitPattern "10.._0001") = Just False+--   decode $(bitPattern "aa.._b0b1") = Just (aa + bb > 1) --   decode _ = Nothing -- @ bitPattern :: String -> Q Pat-bitPattern s = [p| (($mask .&.) -> $target) |]+bitPattern s = [p| ((\_x -> $preprocess) -> $tuple) |]   where-    bs = parse <$> s+    (_, bs, M.toList -> ns) = L.foldr parse (0, [], M.empty) $ filter (/= '_') s +    var c is = varP . mkName $ L.replicate (length is) c+    bitSelect i = [e| if testBit _x $(litE $ IntegerL i) then pack# high else pack# low |]+    varSelect is = L.foldr1 (\a b -> [e| $a ++# $b |]) (bitSelect <$> is)+     mask = litE . IntegerL . fromBits $ maybe 0 (const 1) <$> bs+    maskE = [e| $mask .&. _x |]     target = litP . IntegerL . fromBits $ fromMaybe 0 <$> bs -    parse '.' = Nothing-    parse '0' = Just 0-    parse '1' = Just 1-    parse c = error $ "Invalid bit pattern: " ++ show c+    preprocess = tupE $ maskE : (varSelect . snd <$> ns)+    tuple = tupP $ target : (uncurry var <$> ns)++    parse '.' (i, b, n) = (succ i, Nothing:b, n)+    parse '0' (i, b, n) = (succ i, Just 0:b, n)+    parse '1' (i, b, n) = (succ i, Just 1:b, n)+    parse c (i, b, n)+      | C.isAlpha c && C.isLower c =+        ( succ i+        , Nothing:b+        , M.alter (Just . (i:) . fromMaybe []) c n+        )+      | otherwise = error $+        "Invalid bit pattern: " ++ show c +++        ", expecting one of '0', '1', '.', '_', or a lowercase alphabetic character"++xToBV :: KnownNat n => BitVector n -> BitVector n+xToBV x =+  unsafeDupablePerformIO (catch (evaluate x)+                                (\(XException _) -> return undefined#))+{-# OPAQUE xToBV #-}+{-# ANN xToBV hasBlackBox #-}
src/Clash/Sized/Internal/BitVector.hs-boot view
@@ -4,16 +4,16 @@ Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DataKinds       #-}-{-# LANGUAGE KindSignatures  #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RoleAnnotations #-} module Clash.Sized.Internal.BitVector where  import GHC.TypeLits (KnownNat,Nat)-import GHC.Stack    (HasCallStack)+import Data.Kind    (Type) -type role BitVector phantom-data BitVector :: Nat -> *+type role BitVector nominal+data BitVector :: Nat -> Type data Bit -undefError :: (HasCallStack, KnownNat n) => String -> [BitVector n] -> a+undefError :: KnownNat n => String -> [BitVector n] -> a
src/Clash/Sized/Internal/Index.hs view
@@ -1,29 +1,19 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,-                  2016-2019, Myrtle Software Ltd+                  2016-2019, Myrtle Software Ltd,+                  2021-2026, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# LANGUAGE BangPatterns          #-}-{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE MagicHash             #-}-{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}-#if __GLASGOW_HASKELL__ >= 806-{-# LANGUAGE NoStarIsType #-}-#endif+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  {-# LANGUAGE Unsafe #-} @@ -52,6 +42,9 @@   , ge#   , gt#   , le#+    -- ** Enum+  , toEnum#+  , fromEnum#     -- ** Enum (not synthesizable)   , enumFrom#   , enumFromThen#@@ -63,6 +56,7 @@   , (+#)   , (-#)   , (*#)+  , negate#   , fromInteger#     -- ** ExtendingNum   , plus#@@ -77,36 +71,51 @@   ) where +import Prelude hiding             (even, odd)+ import Control.DeepSeq            (NFData (..)) import Data.Bits                  (Bits (..), FiniteBits (..)) import Data.Data                  (Data)-import Data.Default.Class         (Default (..))-import Data.Proxy                 (Proxy (..))+import Data.Default               (Default (..)) import Text.Read                  (Read (..), ReadPrec)-import Language.Haskell.TH        (TypeQ, appT, conT, litT, numTyLit, sigE)+import Text.Printf                (PrintfArg (..), printf)+import Data.Ix                    (Ix(..))+import Language.Haskell.TH        (appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..))-import Numeric.Natural            (Natural)+import Language.Haskell.TH.Compat+import Language.Haskell.TH        (Quote, Type) import GHC.Generics               (Generic)+import GHC.Natural                (Natural, naturalFromInteger)+import GHC.Natural                (naturalToInteger) import GHC.Stack                  (HasCallStack)-import GHC.TypeLits               (CmpNat, KnownNat, Nat, type (+), type (-),+import GHC.TypeLits               (KnownNat, Nat, type (+), type (-),                                    type (*), type (<=), natVal)-import GHC.TypeLits.Extra         (CLog)+import GHC.TypeLits.Extra         (CLogWZ) import Test.QuickCheck.Arbitrary  (Arbitrary (..), CoArbitrary (..),                                    arbitraryBoundedIntegral,                                    coarbitraryIntegral, shrinkIntegral) -import Clash.Class.BitPack        (BitPack (..), packXWith)+import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Class.BitPack.Internal (BitPack (..), packXWith) import Clash.Class.Num            (ExtendingNum (..), SaturatingNum (..),                                    SaturationMode (..))+import Clash.Class.Parity         (Parity (..)) import Clash.Class.Resize         (Resize (..))-import Clash.Prelude.BitIndex     (replaceBit)+import Clash.Class.BitPack.BitIndex (replaceBit)+import Clash.Sized.Internal       (formatRange) import {-# SOURCE #-} Clash.Sized.Internal.BitVector (BitVector (BV), high, low, undefError) import qualified Clash.Sized.Internal.BitVector as BV-import Clash.Promoted.Nat         (SNat(..), snatToNum, leToPlusKN)+import Clash.Promoted.Nat         (SNat(..), UNat(..), toUNat, snatToNum, natToInteger) import Clash.XException-  (ShowX (..), NFDataX (..), errorX, showsPrecXWith, rwhnfX)+  (ShowX (..), NFDataX (..), errorX, showsPrecXWith, rwhnfX, seqX) --- | Arbitrary-bounded unsigned integer represented by @ceil(log_2(n))@ bits.+{- $setup+>>> import Clash.Sized.Internal.Index+-}++type role Index nominal++-- | Arbitrarily-bounded unsigned integer represented by @ceil(log_2(n))@ bits -- -- Given an upper bound @n@, an 'Index' @n@ number has a range of: [0 .. @n@-1] --@@ -129,14 +138,30 @@ -- >>> 2 * 4 :: Index 8 -- *** Exception: X: Clash.Sized.Index: result 8 is out of bounds: [0..7] -- ...-newtype Index (n :: Nat) =+--+-- __NB__: The usual Haskell method of converting an integral numeric type to+-- another, 'fromIntegral', is not well suited for Clash as it will go through+-- 'Integer' which is arbitrarily bounded in HDL. Instead use+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class.+--+-- Index has the <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html type role>+--+-- >>> :i Index+-- type role Index nominal+-- ...+--+-- as it is not safe to coerce between 'Index'es with different ranges. To+-- change the size, use the functions in the 'Resize' class.+data Index (n :: Nat) =     -- | The constructor, 'I', and the field, 'unsafeToInteger', are not     -- synthesizable.-    I { unsafeToInteger :: Integer }+    I { unsafeToInteger :: !Integer }   deriving (Data, Generic) -{-# NOINLINE size# #-}-size# :: (KnownNat n, 1 <= n) => Index n -> Int+{-# ANN I hasBlackBox #-}++{-# OPAQUE size# #-}+size# :: KnownNat n => Index n -> Int size# = BV.size# . pack#  instance NFData (Index n) where@@ -145,33 +170,37 @@   -- NOINLINE is needed so that Clash doesn't trip on the "Index ~# Integer"   -- coercion -instance (KnownNat n, 1 <= n) => BitPack (Index n) where-  type BitSize (Index n) = CLog 2 n+instance KnownNat n => BitPack (Index n) where+  type BitSize (Index n) = CLogWZ 2 n 0   pack   = packXWith pack#   unpack = unpack#  -- | Safely convert an `SNat` value to an `Index`-fromSNat :: (KnownNat m, CmpNat n m ~ 'LT) => SNat n -> Index m+fromSNat :: (KnownNat m, n + 1 <= m) => SNat n -> Index m fromSNat = snatToNum -{-# NOINLINE pack# #-}-pack# :: Index n -> BitVector (CLog 2 n)-pack# (I i) = BV 0 i+{-# OPAQUE pack# #-}+{-# ANN pack# hasBlackBox #-}+pack# :: Index n -> BitVector (CLogWZ 2 n 0)+pack# (I i) = BV 0 (naturalFromInteger i) -{-# NOINLINE unpack# #-}-unpack# :: (KnownNat n, 1 <= n) => BitVector (CLog 2 n) -> Index n-unpack# (BV 0 i) = fromInteger_INLINE i+{-# OPAQUE unpack# #-}+{-# ANN unpack# hasBlackBox #-}+unpack# :: KnownNat n => BitVector (CLogWZ 2 n 0) -> Index n+unpack# (BV 0 i) = fromInteger_INLINE (naturalToInteger i) unpack# bv = undefError "Index.unpack" [bv]  instance Eq (Index n) where   (==) = eq#   (/=) = neq# -{-# NOINLINE eq# #-}+{-# OPAQUE eq# #-}+{-# ANN eq# hasBlackBox #-} eq# :: (Index n) -> (Index n) -> Bool (I n) `eq#` (I m) = n == m -{-# NOINLINE neq# #-}+{-# OPAQUE neq# #-}+{-# ANN neq# hasBlackBox #-} neq# :: (Index n) -> (Index n) -> Bool (I n) `neq#` (I m) = n /= m @@ -182,13 +211,17 @@   (<=) = le#  lt#,ge#,gt#,le# :: Index n -> Index n -> Bool-{-# NOINLINE lt# #-}+{-# OPAQUE lt# #-}+{-# ANN lt# hasBlackBox #-} lt# (I n) (I m) = n < m-{-# NOINLINE ge# #-}+{-# OPAQUE ge# #-}+{-# ANN ge# hasBlackBox #-} ge# (I n) (I m) = n >= m-{-# NOINLINE gt# #-}+{-# OPAQUE gt# #-}+{-# ANN gt# hasBlackBox #-} gt# (I n) (I m) = n > m-{-# NOINLINE le# #-}+{-# OPAQUE le# #-}+{-# ANN le# hasBlackBox #-} le# (I n) (I m) = n <= m  -- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and@@ -196,64 +229,93 @@ instance KnownNat n => Enum (Index n) where   succ           = (+# fromInteger# 1)   pred           = (-# fromInteger# 1)-  toEnum         = fromInteger# . toInteger-  fromEnum       = fromEnum . toInteger#+  toEnum         = toEnum#+  fromEnum       = fromEnum#   enumFrom       = enumFrom#   enumFromThen   = enumFromThen#   enumFromTo     = enumFromTo#   enumFromThenTo = enumFromThenTo# -{-# NOINLINE enumFrom# #-}-{-# NOINLINE enumFromThen# #-}-{-# NOINLINE enumFromTo# #-}-{-# NOINLINE enumFromThenTo# #-}-enumFrom#       :: KnownNat n => Index n -> [Index n]-enumFromThen#   :: KnownNat n => Index n -> Index n -> [Index n]-enumFromTo#     :: Index n -> Index n -> [Index n]+toEnum# :: forall n. KnownNat n => Int -> Index n+toEnum# = fromInteger# . toInteger+{-# OPAQUE toEnum# #-}+{-# ANN toEnum# hasBlackBox #-}++fromEnum# :: forall n. KnownNat n => Index n -> Int+fromEnum# = fromEnum . toInteger#+{-# OPAQUE fromEnum# #-}+{-# ANN fromEnum# hasBlackBox #-}++enumFrom# :: forall n. KnownNat n => Index n -> [Index n]+enumFrom# x = [x .. maxBound]+{-# OPAQUE enumFrom# #-}++enumFromThen# :: forall n. KnownNat n => Index n -> Index n -> [Index n]+enumFromThen# x y = if x <= y then [x, y .. maxBound] else [x, y .. minBound]+{-# OPAQUE enumFromThen# #-}++enumFromTo# :: Index n -> Index n -> [Index n]+enumFromTo# x y = map I [unsafeToInteger x .. unsafeToInteger y]+{-# OPAQUE enumFromTo# #-}+ enumFromThenTo# :: Index n -> Index n -> Index n -> [Index n]-enumFrom# x             = map fromInteger_INLINE [unsafeToInteger x ..]-enumFromThen# x y       = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..]-enumFromTo# x y         = map I [unsafeToInteger x .. unsafeToInteger y] enumFromThenTo# x1 x2 y = map I [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y]+{-# OPAQUE enumFromThenTo# #-}  instance KnownNat n => Bounded (Index n) where   minBound = fromInteger# 0   maxBound = maxBound# -{-# NOINLINE maxBound# #-}-maxBound# :: KnownNat n => Index n-maxBound# = let res = fromInteger_INLINE (natVal res - 1) in res+maxBound# :: forall n. KnownNat n => Index n+maxBound# =+  case natToInteger @n of+    0 -> errorX "maxBound of 'Index 0' is undefined"+    n -> fromInteger_INLINE (n - 1)+{-# OPAQUE maxBound# #-}+{-# ANN maxBound# hasBlackBox #-}  -- | Operators report an error on overflow and underflow+--+-- __NB__: 'fromInteger'/'fromIntegral' can cause unexpected truncation, as+-- 'Integer' is arbitrarily bounded during synthesis.  Prefer+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class. instance KnownNat n => Num (Index n) where   (+)         = (+#)   (-)         = (-#)   (*)         = (*#)-  negate      = (maxBound# -#)+  negate      = negate#   abs         = id   signum i    = if i == 0 then 0 else 1   fromInteger = fromInteger#  (+#),(-#),(*#) :: KnownNat n => Index n -> Index n -> Index n-{-# NOINLINE (+#) #-}+{-# OPAQUE (+#) #-}+{-# ANN (+#) hasBlackBox #-} (+#) (I a) (I b) = fromInteger_INLINE $ a + b -{-# NOINLINE (-#) #-}+{-# OPAQUE (-#) #-}+{-# ANN (-#) hasBlackBox #-} (-#) (I a) (I b) = fromInteger_INLINE $ a - b -{-# NOINLINE (*#) #-}+{-# OPAQUE (*#) #-}+{-# ANN (*#) hasBlackBox #-} (*#) (I a) (I b) = fromInteger_INLINE $ a * b +negate# :: KnownNat n => Index n -> Index n+negate# 0 = 0+negate# i = maxBound -# i +# 1+ fromInteger# :: KnownNat n => Integer -> Index n-{-# NOINLINE fromInteger# #-}+{-# OPAQUE fromInteger# #-}+{-# ANN fromInteger# hasBlackBox #-} fromInteger# = fromInteger_INLINE {-# INLINE fromInteger_INLINE #-} fromInteger_INLINE :: forall n . (HasCallStack, KnownNat n) => Integer -> Index n fromInteger_INLINE i = bound `seq` if i > (-1) && i < bound then I i else err   where-    bound = natVal (Proxy @n)+    bound = natToInteger @n     err   = errorX ("Clash.Sized.Index: result " ++ show i ++-                   " is out of bounds: [0.." ++ show (bound - 1) ++ "]")+                   " is out of bounds: " ++ formatRange 0 (bound - 1))  instance ExtendingNum (Index m) (Index n) where   type AResult (Index m) (Index n) = Index (m + n - 1)@@ -263,10 +325,12 @@   mul = times#  plus#, minus# :: Index m -> Index n -> Index (m + n - 1)-{-# NOINLINE plus# #-}+{-# OPAQUE plus# #-}+{-# ANN plus# hasBlackBox #-} plus# (I a) (I b) = I (a + b) -{-# NOINLINE minus# #-}+{-# OPAQUE minus# #-}+{-# ANN minus# hasBlackBox #-} minus# (I a) (I b) =   let z   = a - b       err = error ("Clash.Sized.Index.minus: result " ++ show z ++@@ -274,29 +338,38 @@       res = if z < 0 then err else I z   in  res -{-# NOINLINE times# #-}+{-# OPAQUE times# #-}+{-# ANN times# hasBlackBox #-} times# :: Index m -> Index n -> Index (((m - 1) * (n - 1)) + 1) times# (I a) (I b) = I (a * b) -instance (KnownNat n, 1 <= n) => SaturatingNum (Index n) where-  satAdd SatWrap !a !b =-    case snatToNum @Int (SNat @n) of-      1 -> fromInteger# 0-      _ -> leToPlusKN @1 @n $-        case plus# a b of-          z | let m = fromInteger# (natVal (Proxy @ n))-            , z >= m -> resize# (z - m)-          z -> resize# z-  satAdd SatZero a b =-    leToPlusKN @1 @n $+instance KnownNat n => SaturatingNum (Index n) where+  satAdd SatWrap a b = case toUNat (SNat @n) of+    UZero -> a+    USucc UZero -> a +# b+    USucc (USucc _) -> case plus# a b of+      z | let m = fromInteger# (natToInteger @n)+        , z >= m -> resize# (z - m)+      z -> resize# z+  satAdd SatZero a b = case toUNat (SNat @n) of+    UZero -> a+    USucc _ ->       case plus# a b of-        z | let m = fromInteger# (natVal (Proxy @ (n - 1)))+        z | let m = fromInteger# (natToInteger @(n - 1))           , z > m -> fromInteger# 0         z -> resize# z-  satAdd _ a b =-    leToPlusKN @1 @n $+  satAdd SatError a b = case toUNat (SNat @n) of+    UZero -> a+    USucc _ ->       case plus# a b of-        z | let m = fromInteger# (natVal (Proxy @ (n - 1)))+        z | let m = fromInteger# (natToInteger @(n - 1))+          , z > m -> errorX "Index.satAdd: overflow"+        z -> resize# z+  satAdd _ a b = case toUNat (SNat @n) of+    UZero -> a+    USucc _ ->+      case plus# a b of+        z | let m = fromInteger# (natToInteger @(n - 1))           , z > m -> maxBound#         z -> resize# z @@ -304,35 +377,70 @@     if lt# a b        then maxBound -# (b -# a) +# 1        else a -# b-+  satSub SatError a b =+    if lt# a b+       then errorX "Index.satSub: underflow"+       else a -# b   satSub _ a b =     if lt# a b        then fromInteger# 0        else a -# b -  satMul SatWrap !a !b =-    case snatToNum @Int (SNat @n) of-      1 -> fromInteger# 0-      _ -> leToPlusKN @1 @n $-        case times# a b of-          z -> let m = fromInteger# (natVal (Proxy @ n))-               in resize# (z `mod` m)-  satMul SatZero a b =-    leToPlusKN @1 @n $+  satMul SatWrap a b = case toUNat (SNat @n) of+    UZero -> a+    USucc UZero -> a *# b+    USucc (USucc UZero) -> case a of {0 -> 0; _ -> b}+    USucc (USucc (USucc _)) -> case times# a b of+      z -> let m = fromInteger# (natToInteger @n)+           in resize# (z `mod` m)+  satMul SatZero a b = case toUNat (SNat @n) of+    UZero -> a+    USucc _ ->       case times# a b of-        z | let m = fromInteger# (natVal (Proxy @ (n - 1)))+        z | let m = fromInteger# (natToInteger @(n - 1))           , z > m -> fromInteger# 0         z -> resize# z-  satMul _ a b =-    leToPlusKN @1 @n $+  satMul SatError a b = case toUNat (SNat @n) of+    UZero -> a+    USucc _ ->       case times# a b of-        z | let m = fromInteger# (natVal (Proxy @ (n - 1)))+        z | let m = fromInteger# (natToInteger @(n - 1))+          , z > m -> errorX "Index.satMul: overflow"+        z -> resize# z+  satMul _ a b = case toUNat (SNat @n) of+    UZero -> a+    USucc _ ->+      case times# a b of+        z | let m = fromInteger# (natToInteger @(n - 1))           , z > m -> maxBound#         z -> resize# z +  satSucc SatError a =+    case natToInteger @n of+      1 -> a `seqX` errorX "Index.satSucc: overflow"+      _ -> satAdd SatError a $ fromInteger# 1+  satSucc satMode !a =+    case natToInteger @n of+      1 -> fromInteger# 0+      _ -> satAdd satMode a $ fromInteger# 1+  {-# INLINE satSucc #-}++  satPred SatError a =+    case natToInteger @n of+      1 -> a `seqX` errorX "Index.satPred: underflow"+      _ -> satSub SatError a $ fromInteger# 1+  satPred satMode !a =+    case natToInteger @n of+      1 -> fromInteger# 0+      _ -> satSub satMode a $ fromInteger# 1+  {-# INLINE satPred #-}+ instance KnownNat n => Real (Index n) where   toRational = toRational . toInteger# +-- | __NB__: 'toInteger'/'fromIntegral' can cause unexpected truncation, as+-- 'Integer' is arbitrarily bounded during synthesis.  Prefer+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class. instance KnownNat n => Integral (Index n) where   quot        = quot#   rem         = rem#@@ -343,16 +451,30 @@   toInteger   = toInteger#  quot#,rem# :: Index n -> Index n -> Index n-{-# NOINLINE quot# #-}+{-# OPAQUE quot# #-}+{-# ANN quot# hasBlackBox #-} (I a) `quot#` (I b) = I (a `div` b)-{-# NOINLINE rem# #-}+{-# OPAQUE rem# #-}+{-# ANN rem# hasBlackBox #-} (I a) `rem#` (I b) = I (a `rem` b) -{-# NOINLINE toInteger# #-}+{-# OPAQUE toInteger# #-}+{-# ANN toInteger# hasBlackBox #-} toInteger# :: Index n -> Integer toInteger# (I n) = n -instance (KnownNat n, 1 <= n) => Bits (Index n) where+instance KnownNat n => PrintfArg (Index n) where+  formatArg = formatArg . toInteger++instance KnownNat n => Parity (Index n) where+  even = even . pack+  odd = odd . pack++-- | @'shiftR' a n@:+--+-- * Returns 0 if @n >= 'bitSize' a@+-- * 'Clash.XException.XException' if @n < 0@+instance KnownNat n => Bits (Index n) where   a .&. b           = unpack# $ BV.and# (pack# a) (pack# b)   a .|. b           = unpack# $ BV.or# (pack# a) (pack# b)   xor a b           = unpack# $ BV.xor# (pack# a) (pack# b)@@ -372,7 +494,7 @@   rotateR v i       = unpack# $ rotateR (pack# v) i   popCount i        = popCount (pack# i) -instance (KnownNat n, 1 <= n) => FiniteBits (Index n) where+instance KnownNat n => FiniteBits (Index n) where   finiteBitSize        = size#   countLeadingZeros  i = countLeadingZeros  (pack# i)   countTrailingZeros i = countTrailingZeros (pack# i)@@ -384,13 +506,15 @@  resize# :: KnownNat m => Index n -> Index m resize# (I i) = fromInteger_INLINE i-{-# NOINLINE resize# #-}+{-# OPAQUE resize# #-}+{-# ANN resize# hasBlackBox #-}  instance KnownNat n => Lift (Index n) where   lift u@(I i) = sigE [| fromInteger# i |] (decIndex (natVal u))   {-# NOINLINE lift #-}+  liftTyped = liftTypedFromUntyped -decIndex :: Integer -> TypeQ+decIndex :: Quote m => Integer -> m Type decIndex n = appT (conT ''Index) (litT $ numTyLit n)  instance Show (Index n) where@@ -402,6 +526,7 @@  instance NFDataX (Index n) where   deepErrorX = errorX+  ensureSpine = id   rnfX = rwhnfX  -- | None of the 'Read' class' methods are synthesizable.@@ -425,3 +550,10 @@  instance KnownNat n => CoArbitrary (Index n) where   coarbitrary = coarbitraryIntegral++instance (KnownNat n) => Ix (Index n) where+  range (a, b) = [a..b]+  index ab@(a, b) x+    | inRange ab x = fromIntegral $ x - a+    | otherwise = error $ printf "Index (%d) out of range ((%d, %d))" x a b+  inRange (a, b) x = a <= x && x <= b
src/Clash/Sized/Internal/Index.hs-boot view
@@ -4,16 +4,17 @@ Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DataKinds       #-}-{-# LANGUAGE KindSignatures  #-}-{-# LANGUAGE MagicHash       #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE RoleAnnotations #-} module Clash.Sized.Internal.Index where +import Data.Kind (Type) import GHC.TypeLits (KnownNat, Nat) -type role Index phantom-data Index :: Nat -> *+type role Index nominal+data Index :: Nat -> Type  instance KnownNat n => Num (Index n) toInteger# :: Index n -> Integer
+ src/Clash/Sized/Internal/Mod.hs view
@@ -0,0 +1,192 @@+{-|+Copyright  :  (C) 2019, Andrew Lelechenko+License    :  MIT+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++This module contains code from: https://hackage.haskell.org/package/mod and has+the following license:++Copyright (c) 2019 Andrew Lelechenko++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 CPP #-}+{-# LANGUAGE UnboxedTuples #-}++module Clash.Sized.Internal.Mod where++import GHC.Exts (eqWord#, leWord#, word2Int#)+import GHC.Exts+  ((<=#), geWord#, isTrue#, minusWord#, plusWord#, uncheckedShiftL#, xor#,+   timesWord2#, quotRemWord2#, and#, addWordC#)+import GHC.Num.BigNat+  (BigNat#, bigNatAdd, bigNatAddWord#, bigNatAnd, bigNatBit#, bigNatCompare,+   bigNatFromWord#, bigNatFromWord2#, bigNatMul, bigNatMulWord#, bigNatRem,+   bigNatSize#, bigNatSubUnsafe, bigNatSubWordUnsafe#, bigNatToWord#, bigNatXor)+import GHC.Num.Natural (Natural (..))++#include "MachDeps.h"++-- | modular subtraction+subMod :: Natural -> Natural -> Natural -> Natural+subMod (NS m#) (NS x#) (NS y#) =+  if isTrue# (x# `geWord#` y#) then NS z# else NS (z# `plusWord#` m#)+  where+    z# = x# `minusWord#` y#+subMod NS{} _ _ = brokenInvariant+subMod (NB m#) (NS x#) (NS y#) =+  if isTrue# (x# `geWord#` y#)+    then NS (x# `minusWord#` y#)+    else bigNatToNat (m# `bigNatSubWordUnsafe#` (y# `minusWord#` x#))+subMod (NB m#) (NS x#) (NB y#) =+  bigNatToNat ((m# `bigNatSubUnsafe` y#) `bigNatAddWord#` x#)+subMod NB{} (NB x#) (NS y#) =+  bigNatToNat (x# `bigNatSubWordUnsafe#` y#)+subMod (NB m#) (NB x#) (NB y#) = case x# `bigNatCompare` y# of+  LT -> bigNatToNat ((m# `bigNatSubUnsafe` y#) `bigNatAdd` x#)+  EQ -> NS 0##+  GT -> bigNatToNat (x# `bigNatSubUnsafe` y#)++-- | modular addition+addMod :: Natural -> Natural -> Natural -> Natural+addMod (NS m#) (NS x#) (NS y#) =+  if isTrue# c# || isTrue# (z# `geWord#` m#) then NS (z# `minusWord#` m#) else NS z#+  where+    !(# z#, c# #) = x# `addWordC#` y#+addMod NS{} _ _ = brokenInvariant+addMod (NB m#) (NS x#) (NS y#) =+  if isTrue# c# then subIfGe (bigNatFromWord2# 1## z#) m# else NS z#+  where+    !(# z#, c# #) = x# `addWordC#` y#+addMod (NB m#) (NS x#) (NB y#) = subIfGe (y# `bigNatAddWord#` x#) m#+addMod (NB m#) (NB x#) (NS y#) = subIfGe (x# `bigNatAddWord#` y#) m#+addMod (NB m#) (NB x#) (NB y#) = subIfGe (x# `bigNatAdd`     y#) m#++-- | modular multiplication+mulMod :: Natural -> Natural -> Natural -> Natural+mulMod (NS m#) (NS x#) (NS y#) = NS r#+  where+    !(# z1#, z2# #) = timesWord2# x# y#+    !(# _, r# #) = quotRemWord2# z1# z2# m#+mulMod NS{} _ _ = brokenInvariant+mulMod (NB m#) (NS x#) (NS y#) =+  bigNatToNat (bigNatFromWord2# z1# z2# `bigNatRem` m#)+  where+    !(# z1#, z2# #) = timesWord2# x# y#+mulMod (NB m#) (NS x#) (NB y#) =+  bigNatToNat ((y# `bigNatMulWord#` x#) `bigNatRem` m#)+mulMod (NB m#) (NB x#) (NS y#) =+  bigNatToNat ((x# `bigNatMulWord#` y#) `bigNatRem` m#)+mulMod (NB m#) (NB x#) (NB y#) =+  bigNatToNat ((x# `bigNatMul` y#) `bigNatRem` m#)++-- | modular multiplication for powers of 2, takes a mask instead of a+-- wrap-around point+mulMod2 :: Natural -> Natural -> Natural -> Natural+mulMod2 (NS m#) (NS x#) (NS y#) = NS (z2# `and#` m#)+  where+    !(# _, z2# #) = timesWord2# x# y#+mulMod2 NS{} _ _ = brokenInvariant+mulMod2 (NB m#) (NS x#) (NS y#) =+  bigNatToNat (bigNatFromWord2# z1# z2# `bigNatAnd` m#)+  where+    !(# z1#, z2# #) = timesWord2# x# y#+mulMod2 (NB m#) (NS x#) (NB y#) =+  bigNatToNat ((y# `bigNatMulWord#` x#) `bigNatAnd` m#)+mulMod2 (NB m#) (NB x#) (NS y#) =+  bigNatToNat ((x# `bigNatMulWord#` y#) `bigNatAnd` m#)+mulMod2 (NB m#) (NB x#) (NB y#) =+  bigNatToNat ((x# `bigNatMul` y#) `bigNatAnd` m#)++-- | modular negations+negateMod :: Natural -> Natural -> Natural+negateMod _ (NS 0##) = NS 0##+negateMod (NS m#) (NS x#) = NS (m# `minusWord#` x#)+negateMod NS{} _ = brokenInvariant+negateMod (NB m#) (NS x#) = bigNatToNat (m# `bigNatSubWordUnsafe#` x#)+negateMod (NB m#) (NB x#) = bigNatToNat (m# `bigNatSubUnsafe`      x#)++-- | Given a size in bits, return a function that complements the bits in a+-- 'Natural' up to that size.+complementMod+  :: Natural+  -> (Natural -> Natural)+complementMod (NS sz#) =+  if isTrue# (sz# `leWord#` WORD_SIZE_IN_BITS##) then+    let m# = if isTrue# (sz# `eqWord#` WORD_SIZE_IN_BITS##) then+#if WORD_SIZE_IN_BITS == 64+                0xFFFFFFFFFFFFFFFF##+#elif WORD_SIZE_IN_BITS == 32+                0xFFFFFFFF##+#else+#error Unhandled value for WORD_SIZE_IN_BITS+#endif+             else+               (1## `uncheckedShiftL#` (word2Int# sz#)) `minusWord#` 1##+        go (NS x#) = NS (x# `xor#` m#)+        go (NB r#) = NS (bigNatToWord# r# `xor#` m#)+    in  go+  else+    let m# = bigNatBit# sz# `bigNatSubWordUnsafe#` 1##++        go (NS x#) = bigNatToNat (bigNatXor (bigNatFromWord# x#) m#)+        go (NB x#) = bigNatToNat (bigNatXor x# m#)+    in  go+complementMod _ = error "size too large"++-- | Keep all the bits up to a certain size+maskMod+  :: Natural+  -> (Natural -> Natural)+maskMod (NS sz#) =+  if isTrue# (sz# `leWord#` WORD_SIZE_IN_BITS##) then+    if isTrue# (sz# `eqWord#` WORD_SIZE_IN_BITS##) then+       -- Mask equal to the word size+       let go (NB x#) = NS (bigNatToWord# x#)+           go n          = n+       in  go+    else+       let m# = (1## `uncheckedShiftL#` (word2Int# sz#)) `minusWord#` 1##++           go (NS x#) = NS (x# `and#` m#)+           go (NB x#) = NS (bigNatToWord# x# `and#` m#)+       in  go+  else+    let m# = bigNatBit# sz#++        -- faster than `bigNatAnd (m# `minuxBigNatWord` 1##)`+        go (NB x#) = bigNatToNat (bigNatRem x# m#)+        -- The mask is larger than the word size, so we can keep all the bits+        go x = x+    in  go+maskMod _ = error "size too large"++bigNatToNat :: BigNat# -> Natural+bigNatToNat r# =+  if isTrue# (bigNatSize# r# <=# 1#) then+    NS (bigNatToWord# r#)+  else+    NB r#++subIfGe :: BigNat# -> BigNat# -> Natural+subIfGe z# m# = case z# `bigNatCompare` m# of+  LT -> NB z#+  EQ -> NS 0##+  GT -> bigNatToNat (z# `bigNatSubUnsafe` m#)++brokenInvariant :: a+brokenInvariant = error "argument is larger than modulo"
src/Clash/Sized/Internal/Signed.hs view
@@ -1,23 +1,19 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,-                  2016     , Myrtle Software Ltd+                  2016     , Myrtle Software Ltd,+                  2021-2025, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveAnyClass             #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  {-# LANGUAGE Unsafe #-} @@ -43,6 +39,9 @@   , ge#   , gt#   , le#+    -- ** Enum+  , toEnum#+  , fromEnum#     -- ** Enum (not synthesizable)   , enumFrom#   , enumFromThen#@@ -85,40 +84,63 @@   ) where +import Prelude hiding                 (odd, even)+ import Control.DeepSeq                (NFData (..)) import Control.Lens                   (Index, Ixed (..), IxValue) import Data.Bits                      (Bits (..), FiniteBits (..)) import Data.Data                      (Data)-import Data.Default.Class             (Default (..))+import Data.Default                   (Default (..)) import Data.Proxy                     (Proxy (..)) import Text.Read                      (Read (..), ReadPrec)+import Text.Printf                    (PrintfArg (..), printf) import GHC.Generics                   (Generic)+import GHC.Natural                    (naturalFromInteger, naturalToInteger)+ import GHC.TypeLits                   (KnownNat, Nat, type (+), natVal) import GHC.TypeLits.Extra             (Max)-import Language.Haskell.TH            (TypeQ, appT, conT, litT, numTyLit, sigE)+import Data.Ix                        (Ix(..))+import Language.Haskell.TH            (appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax     (Lift(..))+import Language.Haskell.TH.Compat+import Language.Haskell.TH            (Quote, Type) import Test.QuickCheck.Arbitrary      (Arbitrary (..), CoArbitrary (..),                                        arbitraryBoundedIntegral,                                        coarbitraryIntegral, shrinkIntegral) +import Clash.Annotations.Primitive (hasBlackBox) import Clash.Class.BitPack            (BitPack (..), packXWith) import Clash.Class.Num                (ExtendingNum (..), SaturatingNum (..),                                        SaturationMode (..))+import Clash.Class.Parity             (Parity (..)) import Clash.Class.Resize             (Resize (..))-import Clash.Prelude.BitIndex         ((!), msb, replaceBit, split)-import Clash.Prelude.BitReduction     (reduceAnd, reduceOr)+import Clash.Class.BitPack.BitIndex   ((!), msb, replaceBit, split)+import Clash.Class.BitPack.BitReduction (reduceAnd, reduceOr)+import Clash.Promoted.Nat             (natToNatural) import Clash.Sized.Internal.BitVector (BitVector (BV), Bit, (++#), high, low, undefError) import qualified Clash.Sized.Internal.BitVector as BV import Clash.XException   (ShowX (..), NFDataX (..), errorX, showsPrecXWith, rwhnfX) +{- $setup+>>> :m -Prelude+>>> import Clash.Prelude+-}++type role Signed nominal+ -- | Arbitrary-width signed integer represented by @n@ bits, including the sign--- bit.+-- bit -- -- Uses standard 2-complements representation. Meaning that, given @n@ bits,--- a 'Signed' @n@ number has a range of: [-(2^(@n@-1)) .. 2^(@n@-1)-1]+-- a 'Signed' @n@ number has a range of: [-(2^(@n@-1)) .. 2^(@n@-1)-1] for+-- @n > 0@. When @n = 0@, both the min and max bound are 0. ----- __NB__: The 'Num' operators perform @wrap-around@ on overflow. If you want+-- * __NB__: The usual Haskell method of converting an integral numeric type to+-- another, 'fromIntegral', is not well suited for Clash as it will go through+-- 'Integer' which is arbitrarily bounded in HDL. Instead use+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class.+-- * __NB__: The 'Num' operators perform @wrap-around@ on overflow. If you want -- saturation on overflow, check out the 'SaturatingNum' class. -- -- >>>  maxBound :: Signed 3@@ -147,17 +169,30 @@ -- 3 -- >>> satAdd SatSymmetric (-2) (-3) :: Signed 3 -- -3-newtype Signed (n :: Nat) =+--+-- Signed has the <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html type role>+--+-- >>> :i Signed+-- type role Signed nominal+-- ...+--+-- as it is not safe to coerce between different width Signed. To change the+-- width, use the functions in the 'Clash.Class.Resize.Resize' class.+data Signed (n :: Nat) =     -- | The constructor, 'S', and the field, 'unsafeToInteger', are not     -- synthesizable.-    S { unsafeToInteger :: Integer}+    S { unsafeToInteger :: !Integer}   deriving (Data, Generic) +{-# ANN S hasBlackBox #-}+ instance NFDataX (Signed n) where   deepErrorX = errorX+  ensureSpine = id   rnfX = rwhnfX -{-# NOINLINE size# #-}+{-# OPAQUE size# #-}+{-# ANN size# hasBlackBox #-} size# :: KnownNat n => Signed n -> Int size# bv = fromInteger (natVal bv) @@ -183,27 +218,32 @@   pack   = packXWith pack#   unpack = unpack# -{-# NOINLINE pack# #-}+{-# OPAQUE pack# #-}+{-# ANN pack# hasBlackBox #-} pack# :: forall n . KnownNat n => Signed n -> BitVector n-pack# (S i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))-              in  if i < 0 then BV 0 (m + i) else BV 0 i+pack# (S i) = let m = 1 `shiftL0` fromInteger (natVal (Proxy @n))+              in  if i < 0 then BV 0 (naturalFromInteger (m + i)) else BV 0 (naturalFromInteger i) -{-# NOINLINE unpack# #-}+{-# OPAQUE unpack# #-}+{-# ANN unpack# hasBlackBox #-} unpack# :: forall n . KnownNat n => BitVector n -> Signed n unpack# (BV 0 i) =-  let m = 1 `shiftL` fromInteger (natVal (Proxy @n) - 1)-  in  if i >= m then S (i-2*m) else S i+  let m = 1 `shiftL0` fromInteger (natVal (Proxy @n) - 1)+      n = naturalToInteger i+  in  if n >= m then S (n-2*m) else S n unpack# bv = undefError "Signed.unpack" [bv]  instance Eq (Signed n) where   (==) = eq#   (/=) = neq# -{-# NOINLINE eq# #-}+{-# OPAQUE eq# #-}+{-# ANN eq# hasBlackBox #-} eq# :: Signed n -> Signed n -> Bool eq# (S v1) (S v2) = v1 == v2 -{-# NOINLINE neq# #-}+{-# OPAQUE neq# #-}+{-# ANN neq# hasBlackBox #-} neq# :: Signed n -> Signed n -> Bool neq# (S v1) (S v2) = v1 /= v2 @@ -214,52 +254,113 @@   (<=) = le#  lt#,ge#,gt#,le# :: Signed n -> Signed n -> Bool-{-# NOINLINE lt# #-}+{-# OPAQUE lt# #-}+{-# ANN lt# hasBlackBox #-} lt# (S n) (S m) = n < m-{-# NOINLINE ge# #-}+{-# OPAQUE ge# #-}+{-# ANN ge# hasBlackBox #-} ge# (S n) (S m) = n >= m-{-# NOINLINE gt# #-}+{-# OPAQUE gt# #-}+{-# ANN gt# hasBlackBox #-} gt# (S n) (S m) = n > m-{-# NOINLINE le# #-}+{-# OPAQUE le# #-}+{-# ANN le# hasBlackBox #-} le# (S n) (S m) = n <= m  -- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and -- 'enumFromThenTo', are not synthesizable. instance KnownNat n => Enum (Signed n) where-  succ           = (+# fromInteger# 1)-  pred           = (-# fromInteger# 1)-  toEnum         = fromInteger# . toInteger-  fromEnum       = fromEnum . toInteger#+  succ n+    | n == maxBound =+        error $ "'succ' was called on (" <> show @(Signed n) maxBound <> " :: "+             <> "Signed " <> show (natToNatural @n) <> ") and caused an "+             <> "overflow. Use 'satSucc' and specify a SaturationMode if you "+             <> "need other behavior."+    | otherwise = n +# fromInteger# 1++  pred n+    | n == minBound =+        error $ "'pred' was called on (" <> show @(Signed n) maxBound <> " :: "+             <> "Signed " <> show (natToNatural @n) <> ") and caused an "+             <> "underflow. Use 'satPred' and specify a SaturationMode if you "+             <> "need other behavior."+    | otherwise = n -# fromInteger# 1++  toEnum         = toEnum#+  fromEnum       = fromEnum#   enumFrom       = enumFrom#   enumFromThen   = enumFromThen#   enumFromTo     = enumFromTo#   enumFromThenTo = enumFromThenTo# -{-# NOINLINE enumFrom# #-}-{-# NOINLINE enumFromThen# #-}-{-# NOINLINE enumFromTo# #-}-{-# NOINLINE enumFromThenTo# #-}-enumFrom#       :: KnownNat n => Signed n -> [Signed n]-enumFromThen#   :: KnownNat n => Signed n -> Signed n -> [Signed n]-enumFromTo#     :: Signed n -> Signed n -> [Signed n]-enumFromThenTo# :: Signed n -> Signed n -> Signed n -> [Signed n]-enumFrom# x             = map fromInteger_INLINE [unsafeToInteger x ..]-enumFromThen# x y       = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..]-enumFromTo# x y         = map S [unsafeToInteger x .. unsafeToInteger y]-enumFromThenTo# x1 x2 y = map S [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y]+toEnum# :: forall n. KnownNat n => Int -> Signed n+toEnum# = fromInteger# . toInteger+{-# OPAQUE toEnum# #-}+{-# ANN toEnum# hasBlackBox #-} +fromEnum# :: forall n. KnownNat n => Signed n -> Int+fromEnum# = fromEnum . toInteger#+{-# OPAQUE fromEnum# #-}+{-# ANN fromEnum# hasBlackBox #-} +enumFrom# :: forall n. KnownNat n => Signed n -> [Signed n]+enumFrom# x = map (fromInteger_INLINE sz mB mask) [unsafeToInteger x .. unsafeToInteger (maxBound :: Signed n)]+  where sz   = fromInteger (natVal (Proxy @n)) - 1+        mB   = 1 `shiftL` sz+        mask = mB - 1+{-# OPAQUE enumFrom# #-}++enumFromThen# :: forall n. KnownNat n => Signed n -> Signed n -> [Signed n]+enumFromThen# x y =+  toSigneds [unsafeToInteger x, unsafeToInteger y .. unsafeToInteger bound]+ where+  bound = if x <= y then maxBound else minBound :: Signed n+  toSigneds = map (fromInteger_INLINE sz mB mask)+  sz = fromInteger (natVal (Proxy @n)) - 1+  mB = 1 `shiftL` sz+  mask = mB - 1+{-# OPAQUE enumFromThen# #-}++enumFromTo# :: forall n. KnownNat n => Signed n -> Signed n -> [Signed n]+enumFromTo# x y = map (fromInteger_INLINE sz mB mask) [unsafeToInteger x .. unsafeToInteger y]+  where sz   = fromInteger (natVal (Proxy @n)) - 1+        mB   = 1 `shiftL` sz+        mask = mB - 1+{-# OPAQUE enumFromTo# #-}++enumFromThenTo# :: forall n. KnownNat n => Signed n -> Signed n -> Signed n -> [Signed n]+enumFromThenTo# x1 x2 y = map (fromInteger_INLINE sz mB mask) [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y]+  where sz   = fromInteger (natVal (Proxy @n)) - 1+        mB   = 1 `shiftL` sz+        mask = mB - 1+{-# OPAQUE enumFromThenTo# #-}++ instance KnownNat n => Bounded (Signed n) where   minBound = minBound#   maxBound = maxBound# -minBound#,maxBound# :: KnownNat n => Signed n-{-# NOINLINE minBound# #-}-minBound# = let res = S $ negate $ 2 ^ (natVal res - 1) in res-{-# NOINLINE maxBound# #-}-maxBound# = let res = S $ 2 ^ (natVal res - 1) - 1 in res+minBound# :: forall n. KnownNat n => Signed n+minBound# =+  case natToNatural @n of+    0 -> 0+    n -> S (negate $ 2 ^ (n - 1))+{-# OPAQUE minBound# #-}+{-# ANN minBound# hasBlackBox #-} +maxBound# :: forall n. KnownNat n => Signed n+maxBound# =+  case natToNatural @n of+    0 -> 0+    n -> S (2 ^ (n - 1) - 1)+{-# OPAQUE maxBound# #-}+{-# ANN maxBound# hasBlackBox #-}+ -- | Operators do @wrap-around@ on overflow+--+-- __NB__: 'fromInteger'/'fromIntegral' can cause unexpected truncation, as+-- 'Integer' is arbitrarily bounded during synthesis.  Prefer+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class. instance KnownNat n => Num (Signed n) where   (+)         = (+#)   (-)         = (-#)@@ -271,44 +372,76 @@   fromInteger = fromInteger#  (+#), (-#), (*#) :: forall n . KnownNat n => Signed n -> Signed n -> Signed n-{-# NOINLINE (+#) #-}-(S a) +# (S b) = let m  = 1 `shiftL` fromInteger (natVal (Proxy @n) -1)-                     z  = a + b-                 in  if z >= m then S (z - 2*m) else-                        if z < negate m then S (z + 2*m) else S z+{-# OPAQUE (+#) #-}+{-# ANN (+#) hasBlackBox #-}+(+#) =+  \(S a) (S b) ->+    let z = a + b+    in  if z >= m then+          S (z - 2*m)+        else if z < negate m then+          S (z + 2*m)+        else+          S z+ where+  m = 1 `shiftL0` fromInteger (natVal (Proxy @n) -1) -{-# NOINLINE (-#) #-}-(S a) -# (S b) = let m  = 1 `shiftL` fromInteger (natVal (Proxy @n) -1)-                     z  = a - b-                 in  if z < negate m then S (z + 2*m) else-                        if z >= m then S (z - 2*m) else S z+{-# OPAQUE (-#) #-}+{-# ANN (-#) hasBlackBox #-}+(-#) =+  \(S a) (S b) ->+    let z = a - b+    in  if z < negate m then+          S (z + 2*m)+        else if z >= m then+          S (z - 2*m)+        else+          S z+ where+  m  = 1 `shiftL0` fromInteger (natVal (Proxy @n) -1) -{-# NOINLINE (*#) #-}-(S a) *# (S b) = fromInteger_INLINE (a * b)+{-# OPAQUE (*#) #-}+{-# ANN (*#) hasBlackBox #-}+(*#) = \(S a) (S b) -> fromInteger_INLINE sz mB mask (a * b)+  where sz   = fromInteger (natVal (Proxy @n)) - 1+        mB   = 1 `shiftL` sz+        mask = mB - 1  negate#,abs# :: forall n . KnownNat n => Signed n -> Signed n-{-# NOINLINE negate# #-}-negate# (S n) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1)-                    z = negate n-                in  if z == m then S n else S z+{-# OPAQUE negate# #-}+{-# ANN negate# hasBlackBox #-}+negate# =+  \(S n) ->+    let z = negate n+    in  if z == m then S n else S z+ where+  m = 1 `shiftL0` fromInteger (natVal (Proxy @n) -1) -{-# NOINLINE abs# #-}-abs# (S n) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1)-                 z = abs n-             in  if z == m then S n else S z+{-# OPAQUE abs# #-}+{-# ANN abs# hasBlackBox #-}+abs# =+  \(S n) ->+    let z = abs n+    in  if z == m then S n else S z+ where+  m = 1 `shiftL0` fromInteger (natVal (Proxy @n) -1) -{-# NOINLINE fromInteger# #-}-fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat)-fromInteger# = fromInteger_INLINE+{-# OPAQUE fromInteger# #-}+{-# ANN fromInteger# hasBlackBox #-}+fromInteger# :: forall n . KnownNat n => Integer -> Signed (n :: Nat)+fromInteger# = fromInteger_INLINE sz mB mask+  where sz   = fromInteger (natVal (Proxy @n)) - 1+        mB   = 1 `shiftL` sz+        mask = mB - 1  {-# INLINE fromInteger_INLINE #-}-fromInteger_INLINE :: forall n . KnownNat n => Integer -> Signed n-fromInteger_INLINE i = if mask == 0 then S 0 else S res-  where-    mask = 1 `shiftL` fromInteger (natVal (Proxy @n) -1)-    res  = case divMod i mask of-             (s,i') | even s    -> i'-                    | otherwise -> i' - mask+fromInteger_INLINE :: Int -> Integer -> Integer -> Integer -> Signed n+fromInteger_INLINE sz mb mask =+  \i -> let i1 = i .&. mask+            i2 = case i `shiftR` sz of+                   q | q .&. 1 == 0 -> i1+                     | otherwise    -> i1 - mb+        in  if sz < 0 then S 0 else S i2  instance ExtendingNum (Signed m) (Signed n) where   type AResult (Signed m) (Signed n) = Signed (Max m n + 1)@@ -318,19 +451,25 @@   mul = times#  plus#, minus# :: Signed m -> Signed n -> Signed (Max m n + 1)-{-# NOINLINE plus# #-}+{-# OPAQUE plus# #-}+{-# ANN plus# hasBlackBox #-} plus# (S a) (S b) = S (a + b) -{-# NOINLINE minus# #-}+{-# OPAQUE minus# #-}+{-# ANN minus# hasBlackBox #-} minus# (S a) (S b) = S (a - b) -{-# NOINLINE times# #-}+{-# OPAQUE times# #-}+{-# ANN times# hasBlackBox #-} times# :: Signed m -> Signed n -> Signed (m + n) times# (S a) (S b) = S (a * b)  instance KnownNat n => Real (Signed n) where   toRational = toRational . toInteger# +-- | __NB__: 'toInteger'/'fromIntegral' can cause unexpected truncation, as+-- 'Integer' is arbitrarily bounded during synthesis.  Prefer+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class. instance KnownNat n => Integral (Signed n) where   quot        = quot#   rem         = rem#@@ -340,22 +479,51 @@   divMod  n d = (n `div#`  d,n `mod#` d)   toInteger   = toInteger# -quot#,rem# :: Signed n -> Signed n -> Signed n-{-# NOINLINE quot# #-}-quot# (S a) (S b) = S (a `quot` b)-{-# NOINLINE rem# #-}+{-# OPAQUE quot# #-}+{-# ANN quot# hasBlackBox #-}+quot# :: forall n. KnownNat n => Signed n -> Signed n -> Signed n+quot# (S a) (S b)+  | a == minB && b == (-1) = S minB+  | otherwise = S (a `quot` b)+ where+  S minB = minBound @(Signed n)++{-# OPAQUE rem# #-}+{-# ANN rem# hasBlackBox #-}+rem# :: Signed n -> Signed n -> Signed n rem# (S a) (S b) = S (a `rem` b) -div#,mod# :: Signed n -> Signed n -> Signed n-{-# NOINLINE div# #-}-div# (S a) (S b) = S (a `div` b)-{-# NOINLINE mod# #-}+{-# OPAQUE div# #-}+{-# ANN div# hasBlackBox #-}+div# :: forall n. KnownNat n => Signed n -> Signed n -> Signed n+div# (S a) (S b)+  | a == minB && b == (-1) = S minB+  | otherwise = S (a `div` b)+ where+  S minB = minBound @(Signed n)++{-# OPAQUE mod# #-}+{-# ANN mod# hasBlackBox #-}+mod# :: Signed n -> Signed n -> Signed n mod# (S a) (S b) = S (a `mod` b) -{-# NOINLINE toInteger# #-}+{-# OPAQUE toInteger# #-}+{-# ANN toInteger# hasBlackBox #-} toInteger# :: Signed n -> Integer toInteger# (S n) = n +instance KnownNat n => PrintfArg (Signed n) where+  formatArg = formatArg . toInteger++instance KnownNat n => Parity (Signed n) where+  even = even . pack+  odd = odd . pack++-- | @'shiftR' a n@:+--+-- * Returns 0 if @a >= 0@ and @n >= 'bitSize' a@+-- * Returns -1 if @a < 0@ and @n >= 'bitSize' a@+-- * 'Clash.XException.XException' if @n < 0@ instance KnownNat n => Bits (Signed n) where   (.&.)             = and#   (.|.)             = or#@@ -376,49 +544,101 @@   rotateR v i       = rotateR# v i   popCount s        = popCount (pack# s) -and#,or#,xor# :: KnownNat n => Signed n -> Signed n -> Signed n-{-# NOINLINE and# #-}-and# (S a) (S b) = fromInteger_INLINE (a .&. b)-{-# NOINLINE or# #-}-or# (S a) (S b)  = fromInteger_INLINE (a .|. b)-{-# NOINLINE xor# #-}-xor# (S a) (S b) = fromInteger_INLINE (xor a b)+and#,or#,xor# :: forall n . KnownNat n => Signed n -> Signed n -> Signed n+{-# OPAQUE and# #-}+{-# ANN and# hasBlackBox #-}+and# = \(S a) (S b) -> fromInteger_INLINE sz mB mask (a .&. b)+  where sz   = fromInteger (natVal (Proxy @n)) - 1+        mB   = 1 `shiftL` sz+        mask = mB - 1 -{-# NOINLINE complement# #-}-complement# :: KnownNat n => Signed n -> Signed n-complement# (S a) = fromInteger_INLINE (complement a)+{-# OPAQUE or# #-}+{-# ANN or# hasBlackBox #-}+or# = \(S a) (S b) -> fromInteger_INLINE sz mB mask (a .|. b)+  where sz   = fromInteger (natVal (Proxy @n)) - 1+        mB   = 1 `shiftL` sz+        mask = mB - 1 -shiftL#,shiftR#,rotateL#,rotateR# :: KnownNat n => Signed n -> Int -> Signed n-{-# NOINLINE shiftL# #-}-shiftL# _ b | b < 0  = error "'shiftL undefined for negative numbers"-shiftL# (S n) b      = fromInteger_INLINE (shiftL n b)-{-# NOINLINE shiftR# #-}-shiftR# _ b | b < 0  = error "'shiftR undefined for negative numbers"-shiftR# (S n) b      = fromInteger_INLINE (shiftR n b)-{-# NOINLINE rotateL# #-}-rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers"-rotateL# s@(S n) b   = fromInteger_INLINE (l .|. r)-  where-    l    = shiftL n b'-    r    = shiftR n b'' .&. mask-    mask = 2 ^ b' - 1+{-# OPAQUE xor# #-}+{-# ANN xor# hasBlackBox #-}+xor# = \(S a) (S b) -> fromInteger_INLINE sz mB mask (xor a b)+  where sz   = fromInteger (natVal (Proxy @n)) - 1+        mB   = 1 `shiftL` sz+        mask = mB - 1 -    b'   = b `mod` sz-    b''  = sz - b'-    sz   = fromInteger (natVal s)+{-# OPAQUE complement# #-}+{-# ANN complement# hasBlackBox #-}+complement# :: forall n . KnownNat n => Signed n -> Signed n+complement# = \(S a) -> fromInteger_INLINE sz mB mask (complement a)+  where sz   = fromInteger (natVal (Proxy @n)) - 1+        mB   = 1 `shiftL` sz+        mask = mB - 1 -{-# NOINLINE rotateR# #-}-rotateR# _ b | b < 0 = error "'shiftR undefined for negative numbers"-rotateR# s@(S n) b   = fromInteger_INLINE (l .|. r)-  where-    l    = shiftR n b' .&. mask-    r    = shiftL n b''-    mask = 2 ^ b'' - 1+shiftL#,shiftR#,rotateL#,rotateR# :: forall n . KnownNat n => Signed n -> Int -> Signed n+{-# OPAQUE shiftL# #-}+{-# ANN shiftL# hasBlackBox #-}+shiftL# = \(S n) b ->+  if | b < 0     -> error $ "'shiftL' undefined for negative number: " ++ show b+     | b > sz    -> S 0+     | otherwise -> fromInteger_INLINE sz mB mask (shiftL n b)+ where+  sz   = fromInteger (natVal (Proxy @n)) - 1+  mB   = 1 `shiftL` sz+  mask = mB - 1 -    b'  = b `mod` sz-    b'' = sz - b'-    sz  = fromInteger (natVal s)+{-# OPAQUE shiftR# #-}+{-# ANN shiftR# hasBlackBox #-}+shiftR# =+  \(S n) b ->+    if b >= 0 then+      fromInteger_INLINE sz mB mask (shiftR n b)+    else+      error $ "'shiftR' undefined for negative number: " ++ show b+ where+  sz   = fromInteger (natVal (Proxy @n)) - 1+  mB   = 1 `shiftL` sz+  mask = mB - 1 +{-# OPAQUE rotateL# #-}+{-# ANN rotateL# hasBlackBox #-}+rotateL# =+  \(S n) b ->+    if b >= 0 then+      let l    = shiftL n b'+          r    = shiftR n b'' .&. mask+          mask = 2 ^ b' - 1++          b'   = b `mod` sz+          b''  = sz - b'+      in  fromInteger_INLINE sz1 mB maskM (l .|. r)+    else+      error $ "'rotateL undefined for negative number: " ++ show b+ where+  sz    = fromInteger (natVal (Proxy @n))+  sz1   = sz-1+  mB    = 1 `shiftL` sz1+  maskM = mB - 1++{-# OPAQUE rotateR# #-}+{-# ANN rotateR# hasBlackBox #-}+rotateR# =+  \(S n) b ->+    if b >= 0 then+      let l    = shiftR n b' .&. mask+          r    = shiftL n b''+          mask = 2 ^ b'' - 1++          b'  = b `mod` sz+          b'' = sz - b'+      in  fromInteger_INLINE sz1 mB maskM (l .|. r)+    else+      error $ "'rotateR' undefined for negative number: " ++ show b+ where+  sz    = fromInteger (natVal (Proxy @n))+  sz1   = sz - 1+  mB    = 1 `shiftL` sz1+  maskM = mB - 1+ instance KnownNat n => FiniteBits (Signed n) where   finiteBitSize        = size#   countLeadingZeros  s = countLeadingZeros  (pack# s)@@ -429,10 +649,13 @@   zeroExtend s = unpack# (0 ++# pack s)   truncateB    = truncateB# -{-# NOINLINE resize# #-}+{-# OPAQUE resize# #-}+{-# ANN resize# hasBlackBox #-} resize# :: forall m n . (KnownNat n, KnownNat m) => Signed n -> Signed m-resize# s@(S i) | n' <= m'  = extended-                | otherwise = truncated+resize# s@(S i)+  | natToNatural @m == 0 = S 0+  | n' <= m'  = extended+  | otherwise = truncated   where     n  = fromInteger (natVal s)     n' = shiftL 1 n@@ -445,9 +668,13 @@                    then S (i' - mask)                    else S i' -{-# NOINLINE truncateB# #-}-truncateB# :: KnownNat m => Signed (m + n) -> Signed m-truncateB# (S n) = fromInteger_INLINE n+{-# OPAQUE truncateB# #-}+{-# ANN truncateB# hasBlackBox #-}+truncateB# :: forall m n . KnownNat m => Signed (m + n) -> Signed m+truncateB# = \(S n) -> fromInteger_INLINE sz mB mask n+  where sz   = fromInteger (natVal (Proxy @m)) - 1+        mB   = 1 `shiftL` sz+        mask = mB - 1  instance KnownNat n => Default (Signed n) where   def = fromInteger# 0@@ -455,8 +682,9 @@ instance KnownNat n => Lift (Signed n) where   lift s@(S i) = sigE [| fromInteger# i |] (decSigned (natVal s))   {-# NOINLINE lift #-}+  liftTyped = liftTypedFromUntyped -decSigned :: Integer -> TypeQ+decSigned :: Quote m => Integer -> m Type decSigned n = appT (conT ''Signed) (litT $ numTyLit n)  instance KnownNat n => SaturatingNum (Signed n) where@@ -475,6 +703,12 @@     in  case msb r `xor` msb r' of           0 -> unpack# r'           _ -> fromInteger# 0+  satAdd SatError a b =+    let r      = plus# a b+        (_,r') = split r+    in  case msb r `xor` msb r' of+          0 -> unpack# r'+          _ -> errorX "Signed.satAdd: overflow/underflow"   satAdd SatSymmetric a b =     let r      = plus# a b         (_,r') = split r@@ -499,6 +733,12 @@     in  case msb r `xor` msb r' of           0 -> unpack# r'           _ -> fromInteger# 0+  satSub SatError a b =+    let r      = minus# a b+        (_,r') = split r+    in  case msb r `xor` msb r' of+          0 -> unpack# r'+          _ -> errorX "Signed.satSub: overflow/underflow"   satSub SatSymmetric a b =     let r      = minus# a b         (_,r') = split r@@ -513,7 +753,7 @@     let r        = times# a b         (rL,rR)  = split r         overflow = complement (reduceOr (BV.pack# (msb rR) ++# pack rL)) .|.-                              reduceAnd (BV.pack# (msb rR) ++# pack rL)+                   reduceAnd (BV.pack# (msb rR) ++# pack rL)     in  case overflow of           1 -> unpack# rR           _ -> case msb rL of@@ -523,21 +763,39 @@     let r        = times# a b         (rL,rR)  = split r         overflow = complement (reduceOr (BV.pack# (msb rR) ++# pack rL)) .|.-                              reduceAnd (BV.pack# (msb rR) ++# pack rL)+                   reduceAnd (BV.pack# (msb rR) ++# pack rL)     in  case overflow of           1 -> unpack# rR           _ -> fromInteger# 0+  satMul SatError a b =+    let r        = times# a b+        (rL,rR)  = split r+        overflow = complement (reduceOr (BV.pack# (msb rR) ++# pack rL)) .|.+                   reduceAnd (BV.pack# (msb rR) ++# pack rL)+    in  case overflow of+          1 -> unpack# rR+          _ -> errorX "Signed.satMul: overflow/underflow"   satMul SatSymmetric a b =     let r        = times# a b         (rL,rR)  = split r         overflow = complement (reduceOr (BV.pack# (msb rR) ++# pack rL)) .|.-                              reduceAnd (BV.pack# (msb rR) ++# pack rL)+                   reduceAnd (BV.pack# (msb rR) ++# pack rL)     in  case overflow of           1 -> unpack# rR           _ -> case msb rL of             0 -> maxBound#             _ -> minBoundSym# +  satSucc SatError a+    | a == maxBound = errorX "Signed.satSucc: overflow"+  satSucc satMode a = satSub satMode a $ fromInteger# (-1)+  {-# INLINE satSucc #-}++  satPred SatError a+    | a == minBound = errorX "Signed.satPred: underflow"+  satPred satMode a = satAdd satMode a $ fromInteger# (-1)+  {-# INLINE satPred #-}+ minBoundSym# :: KnownNat n => Signed n minBoundSym# = minBound# +# fromInteger# 1 @@ -564,3 +822,15 @@ instance KnownNat n => Ixed (Signed n) where   ix i f s = unpack# <$> BV.replaceBit# (pack# s) i                      <$> f (BV.index# (pack# s) i)++instance (KnownNat n) => Ix (Signed n) where+  range (a, b) = [a..b]+  index ab@(a, b) x+    | inRange ab x = fromIntegral $ x - a+    | otherwise = error $ printf "Index (%d) out of range ((%d, %d))" x a b+  inRange (a, b) x = a <= x && x <= b++-- | Shift left that ties to zero on negative shifts+shiftL0 :: Integer -> Int -> Integer+shiftL0 = \a sh -> if sh >= 0 then shiftL a sh else 0+{-# INLINE shiftL0 #-}
src/Clash/Sized/Internal/Unsigned.hs view
@@ -1,22 +1,19 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,-                  2016     , Myrtle Software Ltd+                  2016     , Myrtle Software Ltd,+                  2021-2025, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveAnyClass             #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  {-# LANGUAGE Unsafe #-} @@ -41,6 +38,9 @@   , ge#   , gt#   , le#+    -- ** Enum+  , toEnum#+  , fromEnum#     -- ** Enum (not synthesizable)   , enumFrom#   , enumFromThen#@@ -74,42 +74,78 @@   , rotateR#     -- ** Resize   , resize#+    -- ** Conversions+  , unsignedToWord+  , unsigned8toWord8+  , unsigned16toWord16+  , unsigned32toWord32   ) where +import Prelude hiding                 (even, odd)+ import Control.DeepSeq                (NFData (..)) import Control.Lens                   (Index, Ixed (..), IxValue) import Data.Bits                      (Bits (..), FiniteBits (..)) import Data.Data                      (Data)-import Data.Default.Class             (Default (..))+import Data.Default                   (Default (..)) import Data.Proxy                     (Proxy (..)) import Text.Read                      (Read (..), ReadPrec)+import Text.Printf                    (PrintfArg (..), printf)+import GHC.Exts                       (wordToWord8#, wordToWord16#, wordToWord32#) import GHC.Generics                   (Generic)-import GHC.TypeLits                   (KnownNat, Nat, type (+), natVal)+import GHC.Num.BigNat                 (bigNatToWord, bigNatToWord#)+import GHC.Num.Integer+  (integerFromNatural, integerShiftL, integerToNatural)+import GHC.Num.Natural+  (Natural (..), naturalShiftL, naturalShiftR, naturalToWord)+import GHC.Natural                    (naturalToInteger)+import GHC.TypeLits                   (KnownNat, Nat, type (+))+import GHC.TypeNats                   (natVal) import GHC.TypeLits.Extra             (Max)-import Language.Haskell.TH            (TypeQ, appT, conT, litT, numTyLit, sigE)+import GHC.Word                       (Word (..), Word8 (..), Word16 (..), Word32 (..))+import Data.Ix                        (Ix(..))+import Language.Haskell.TH            (appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax     (Lift(..))-import Numeric.Natural                (Natural)+import Language.Haskell.TH.Compat+import Language.Haskell.TH            (Quote, Type) import Test.QuickCheck.Arbitrary      (Arbitrary (..), CoArbitrary (..),                                        arbitraryBoundedIntegral,                                        coarbitraryIntegral) -import Clash.Class.BitPack            (BitPack (..), packXWith)+import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Class.BitPack            (BitPack (..), packXWith, bitCoerce) import Clash.Class.Num                (ExtendingNum (..), SaturatingNum (..),                                        SaturationMode (..))+import Clash.Class.Parity             (Parity (..)) import Clash.Class.Resize             (Resize (..))-import Clash.Prelude.BitIndex         ((!), msb, replaceBit, split)-import Clash.Prelude.BitReduction     (reduceOr)+import Clash.Class.BitPack.BitIndex   ((!), msb, replaceBit, split)+import Clash.Class.BitPack.BitReduction (reduceOr)+import Clash.Promoted.Nat             (natToNum, natToNatural) import Clash.Sized.Internal.BitVector (BitVector (BV), Bit, high, low, undefError) import qualified Clash.Sized.Internal.BitVector as BV+import Clash.Sized.Internal.Mod import Clash.XException   (ShowX (..), NFDataX (..), errorX, showsPrecXWith, rwhnfX) +{- $setup+>>> :m -Prelude+>>> import Clash.Prelude+-}++#include "MachDeps.h"++type role Unsigned nominal+ -- | Arbitrary-width unsigned integer represented by @n@ bits -- -- Given @n@ bits, an 'Unsigned' @n@ number has a range of: [0 .. 2^@n@-1] ----- __NB__: The 'Num' operators perform @wrap-around@ on overflow. If you want+-- * __NB__: The usual Haskell method of converting an integral numeric type to+-- another, 'fromIntegral', is not well suited for Clash as it will go through+-- 'Integer' which is arbitrarily bounded in HDL. Instead use+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class.+-- * __NB__: The 'Num' operators perform @wrap-around@ on overflow. If you want -- saturation on overflow, check out the 'SaturatingNum' class. -- -- >>> maxBound :: Unsigned 3@@ -136,20 +172,32 @@ -- 7 -- >>> satSub SatSymmetric 2 3 :: Unsigned 3 -- 0-newtype Unsigned (n :: Nat) =-    -- | The constructor, 'U', and the field, 'unsafeToInteger', are not+--+-- Unsigned has the <https://downloads.haskell.org/ghc/latest/docs/html/users_guide/exts/roles.html type role>+--+-- >>> :i Unsigned+-- type role Unsigned nominal+-- ...+--+-- as it is not safe to coerce between different width Unsigned. To change the+-- width, use the functions in the 'Clash.Class.Resize.Resize' class.+data Unsigned (n :: Nat) =+    -- | The constructor, 'U', and the field, 'unsafeToNatural', are not     -- synthesizable.-    U { unsafeToInteger :: Integer }+    U { unsafeToNatural :: !Natural }   deriving (Data, Generic) -{-# NOINLINE size# #-}+{-# ANN U hasBlackBox #-}++{-# OPAQUE size# #-}+{-# ANN size# hasBlackBox #-} size# :: KnownNat n => Unsigned n -> Int-size# u = fromInteger (natVal u)+size# u = fromIntegral (natVal u)  instance NFData (Unsigned n) where   rnf (U i) = rnf i `seq` ()   {-# NOINLINE rnf #-}-  -- NOINLINE is needed so that Clash doesn't trip on the "Unsigned ~# Integer"+  -- NOINLINE is needed so that Clash doesn't trip on the "Unsigned ~# Natural"   -- coercion  instance Show (Unsigned n) where@@ -161,6 +209,7 @@  instance NFDataX (Unsigned n) where   deepErrorX = errorX+  ensureSpine = id   rnfX = rwhnfX  -- | None of the 'Read' class' methods are synthesizable.@@ -172,11 +221,13 @@   pack   = packXWith pack#   unpack = unpack# -{-# NOINLINE pack# #-}+{-# OPAQUE pack# #-}+{-# ANN pack# hasBlackBox #-} pack# :: Unsigned n -> BitVector n pack# (U i) = BV 0 i -{-# NOINLINE unpack# #-}+{-# OPAQUE unpack# #-}+{-# ANN unpack# hasBlackBox #-} unpack# :: KnownNat n => BitVector n -> Unsigned n unpack# (BV 0 i) = U i unpack# bv = undefError "Unsigned.unpack" [bv]@@ -185,11 +236,13 @@   (==) = eq#   (/=) = neq# -{-# NOINLINE eq# #-}+{-# OPAQUE eq# #-}+{-# ANN eq# hasBlackBox #-} eq# :: Unsigned n -> Unsigned n -> Bool eq# (U v1) (U v2) = v1 == v2 -{-# NOINLINE neq# #-}+{-# OPAQUE neq# #-}+{-# ANN neq# hasBlackBox #-} neq# :: Unsigned n -> Unsigned n -> Bool neq# (U v1) (U v2) = v1 /= v2 @@ -200,53 +253,94 @@   (<=) = le#  lt#,ge#,gt#,le# :: Unsigned n -> Unsigned n -> Bool-{-# NOINLINE lt# #-}+{-# OPAQUE lt# #-}+{-# ANN lt# hasBlackBox #-} lt# (U n) (U m) = n < m-{-# NOINLINE ge# #-}+{-# OPAQUE ge# #-}+{-# ANN ge# hasBlackBox #-} ge# (U n) (U m) = n >= m-{-# NOINLINE gt# #-}+{-# OPAQUE gt# #-}+{-# ANN gt# hasBlackBox #-} gt# (U n) (U m) = n > m-{-# NOINLINE le# #-}+{-# OPAQUE le# #-}+{-# ANN le# hasBlackBox #-} le# (U n) (U m) = n <= m  -- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and -- 'enumFromThenTo', are not synthesizable. instance KnownNat n => Enum (Unsigned n) where-  succ           = (+# fromInteger# 1)-  pred           = (-# fromInteger# 1)-  toEnum         = fromInteger# . toInteger-  fromEnum       = fromEnum . toInteger#+  succ n+    | n == maxBound =+        error $ "'succ' was called on (" <> show @(Unsigned n) maxBound <> " :: "+             <> "Unsigned " <> show (natToNatural @n) <> ") and caused an "+             <> "overflow. Use 'satSucc' and specify a SaturationMode if you "+             <> "need other behavior."+    | otherwise = n +# fromInteger# 1++  pred n+    | n == minBound =+        error $ "'pred' was called on (0 :: Unsigned " <> show (natToNatural @n)+             <> ") and caused an overflow. Use 'satPred' and specify a "+             <> "SaturationMode if you need other behavior."+    | otherwise = n -# fromInteger# 1++  toEnum         = toEnum#+  fromEnum       = fromEnum#   enumFrom       = enumFrom#   enumFromThen   = enumFromThen#   enumFromTo     = enumFromTo#   enumFromThenTo = enumFromThenTo# -{-# NOINLINE enumFrom# #-}-{-# NOINLINE enumFromThen# #-}-{-# NOINLINE enumFromTo# #-}-{-# NOINLINE enumFromThenTo# #-}-enumFrom#       :: KnownNat n => Unsigned n -> [Unsigned n]-enumFromThen#   :: KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n]-enumFromTo#     :: Unsigned n -> Unsigned n -> [Unsigned n]-enumFromThenTo# :: Unsigned n -> Unsigned n -> Unsigned n -> [Unsigned n]-enumFrom# x             = map fromInteger_INLINE [unsafeToInteger x ..]-enumFromThen# x y       = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..]-enumFromTo# x y         = map U [unsafeToInteger x .. unsafeToInteger y]-enumFromThenTo# x1 x2 y = map U [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y]+toEnum# :: forall n. KnownNat n => Int -> Unsigned n+toEnum# = fromInteger# . toInteger+{-# OPAQUE toEnum# #-}+{-# ANN toEnum# hasBlackBox #-} +fromEnum# :: forall n. KnownNat n => Unsigned n -> Int+fromEnum# = fromEnum . toInteger#+{-# OPAQUE fromEnum# #-}+{-# ANN fromEnum# hasBlackBox #-}++enumFrom# :: forall n. KnownNat n => Unsigned n -> [Unsigned n]+enumFrom# = \x -> map (U . (`mod` m)) [unsafeToNatural x .. unsafeToNatural (maxBound :: Unsigned n)]+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))+{-# OPAQUE enumFrom# #-}++enumFromThen# :: forall n. KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n]+enumFromThen# = \x y -> toUnsigneds [unsafeToNatural x, unsafeToNatural y .. bound x y]+ where+  toUnsigneds = map (U . (`mod` m))+  bound x y = unsafeToNatural (if x <= y then maxBound else minBound :: Unsigned n)+  m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))+{-# OPAQUE enumFromThen# #-}++enumFromTo# :: forall n. KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n]+enumFromTo# = \x y -> map (U . (`mod` m)) [unsafeToNatural x .. unsafeToNatural y]+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))+{-# OPAQUE enumFromTo# #-}++enumFromThenTo# :: forall n. KnownNat n => Unsigned n -> Unsigned n -> Unsigned n -> [Unsigned n]+enumFromThenTo# = \x1 x2 y -> map (U . (`mod` m)) [unsafeToNatural x1, unsafeToNatural x2 .. unsafeToNatural y]+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))+{-# OPAQUE enumFromThenTo# #-}+ instance KnownNat n => Bounded (Unsigned n) where   minBound = minBound#   maxBound = maxBound# -{-# NOINLINE minBound# #-} minBound# :: Unsigned n minBound# = U 0+{-# OPAQUE minBound# #-}+{-# ANN minBound# hasBlackBox #-} -{-# NOINLINE maxBound# #-}-maxBound# :: forall n .KnownNat n => Unsigned n-maxBound# = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))-            in  U (m - 1)+maxBound# :: forall n. KnownNat n => Unsigned n+maxBound# = let m = 1 `shiftL` (natToNum @n) in  U (m - 1)+{-# OPAQUE maxBound# #-}+{-# ANN maxBound# hasBlackBox #-} +-- | __NB__: 'fromInteger'/'fromIntegral' can cause unexpected truncation, as+-- 'Integer' is arbitrarily bounded during synthesis.  Prefer+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class. instance KnownNat n => Num (Unsigned n) where   (+)         = (+#)   (-)         = (-#)@@ -257,35 +351,33 @@   fromInteger = fromInteger#  (+#),(-#),(*#) :: forall n . KnownNat n => Unsigned n -> Unsigned n -> Unsigned n-{-# NOINLINE (+#) #-}-(+#) (U i) (U j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))-                       z = i + j-                   in  if z >= m then U (z - m) else U z+{-# OPAQUE (+#) #-}+{-# ANN (+#) hasBlackBox #-}+(+#) = \(U i) (U j) -> U (addMod m i j)+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n)) -{-# NOINLINE (-#) #-}-(-#) (U i) (U j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))-                       z = i - j-                   in  if z < 0 then U (m + z) else U z+{-# OPAQUE (-#) #-}+{-# ANN (-#) hasBlackBox #-}+(-#) = \(U i) (U j) -> U (subMod m i j)+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n)) -{-# NOINLINE (*#) #-}-(*#) (U i) (U j) = fromInteger_INLINE (i * j)+{-# OPAQUE (*#) #-}+{-# ANN (*#) hasBlackBox #-}+(*#) = \(U i) (U j) -> U (mulMod2 m i j)+  where m = (1 `naturalShiftL` naturalToWord (natVal (Proxy @n))) - 1 -{-# NOINLINE negate# #-}+{-# OPAQUE negate# #-}+{-# ANN negate# hasBlackBox #-} negate# :: forall n . KnownNat n => Unsigned n -> Unsigned n-negate# (U 0) = U 0-negate# (U i) = sz `seq` U (sz - i)-  where-    sz = 1 `shiftL` fromInteger (natVal (Proxy @n))--{-# NOINLINE fromInteger# #-}-fromInteger# :: KnownNat n => Integer -> Unsigned n-fromInteger# = fromInteger_INLINE+negate# = \(U i) -> U (negateMod m i)+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n)) -{-# INLINE fromInteger_INLINE #-}-fromInteger_INLINE :: forall n . KnownNat n => Integer -> Unsigned n-fromInteger_INLINE i = U (i `mod` sz)-  where-    sz = 1 `shiftL` fromInteger (natVal (Proxy @n))+{-# OPAQUE fromInteger# #-}+{-# ANN fromInteger# hasBlackBox #-}+fromInteger# :: forall n . KnownNat n => Integer -> Unsigned n+fromInteger# = \x -> U (integerToNatural (x `mod` m))+ where+  m = 1 `integerShiftL` naturalToWord (natVal (Proxy @n))  instance (KnownNat m, KnownNat n) => ExtendingNum (Unsigned m) (Unsigned n) where   type AResult (Unsigned m) (Unsigned n) = Unsigned (Max m n + 1)@@ -294,26 +386,31 @@   type MResult (Unsigned m) (Unsigned n) = Unsigned (m + n)   mul = times# -{-# NOINLINE plus# #-}+{-# OPAQUE plus# #-}+{-# ANN plus# hasBlackBox #-} plus# :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1) plus# (U a) (U b) = U (a + b) -{-# NOINLINE minus# #-}+{-# OPAQUE minus# #-}+{-# ANN minus# hasBlackBox #-} minus# :: forall m n . (KnownNat m, KnownNat n) => Unsigned m -> Unsigned n                                                 -> Unsigned (Max m n + 1)-minus# (U a) (U b) =-  let sz   = fromInteger (natVal (Proxy @(Max m n + 1)))-      mask = 1 `shiftL` sz-      z    = a - b-  in  if z < 0 then U (mask + z) else U z+minus# = \(U a) (U b) -> U (subMod mask a b)+ where+  sz   = naturalToWord (natVal (Proxy @(Max m n + 1)))+  mask = 1 `naturalShiftL` sz -{-# NOINLINE times# #-}+{-# OPAQUE times# #-}+{-# ANN times# hasBlackBox #-} times# :: Unsigned m -> Unsigned n -> Unsigned (m + n) times# (U a) (U b) = U (a * b)  instance KnownNat n => Real (Unsigned n) where   toRational = toRational . toInteger# +-- | __NB__: 'toInteger'/'fromIntegral' can cause unexpected truncation, as+-- 'Integer' is arbitrarily bounded during synthesis.  Prefer+-- 'Clash.Class.BitPack.bitCoerce' and the 'Resize' class. instance KnownNat n => Integral (Unsigned n) where   quot        = quot#   rem         = rem#@@ -324,15 +421,29 @@   toInteger   = toInteger#  quot#,rem# :: Unsigned n -> Unsigned n -> Unsigned n-{-# NOINLINE quot# #-}+{-# OPAQUE quot# #-}+{-# ANN quot# hasBlackBox #-} quot# (U i) (U j) = U (i `quot` j)-{-# NOINLINE rem# #-}+{-# OPAQUE rem# #-}+{-# ANN rem# hasBlackBox #-} rem# (U i) (U j) = U (i `rem` j) -{-# NOINLINE toInteger# #-}+{-# OPAQUE toInteger# #-}+{-# ANN toInteger# hasBlackBox #-} toInteger# :: Unsigned n -> Integer-toInteger# (U i) = i+toInteger# (U i) = naturalToInteger i +instance KnownNat n => PrintfArg (Unsigned n) where+  formatArg = formatArg . toInteger++instance KnownNat n => Parity (Unsigned n) where+  even = even . pack+  odd = odd . pack++-- | @'shiftR' a n@:+--+-- * Returns 0 if @n >= 'bitSize' a@+-- * 'Clash.XException.XException' if @n < 0@ instance KnownNat n => Bits (Unsigned n) where   (.&.)             = and#   (.|.)             = or#@@ -353,59 +464,81 @@   rotateR v i       = rotateR# v i   popCount u        = popCount (pack# u) -{-# NOINLINE and# #-}+{-# OPAQUE and# #-}+{-# ANN and# hasBlackBox #-} and# :: Unsigned n -> Unsigned n -> Unsigned n and# (U v1) (U v2) = U (v1 .&. v2) -{-# NOINLINE or# #-}+{-# OPAQUE or# #-}+{-# ANN or# hasBlackBox #-} or# :: Unsigned n -> Unsigned n -> Unsigned n or# (U v1) (U v2) = U (v1 .|. v2) -{-# NOINLINE xor# #-}+{-# OPAQUE xor# #-}+{-# ANN xor# hasBlackBox #-} xor# :: Unsigned n -> Unsigned n -> Unsigned n xor# (U v1) (U v2) = U (v1 `xor` v2) -{-# NOINLINE complement# #-}-complement# :: KnownNat n => Unsigned n -> Unsigned n-complement# (U i) = fromInteger_INLINE (complement i)+{-# OPAQUE complement# #-}+{-# ANN complement# hasBlackBox #-}+complement# :: forall n . KnownNat n => Unsigned n -> Unsigned n+complement# = \(U i) -> U (complementN i)+  where complementN = complementMod (natVal (Proxy @n)) -shiftL#, shiftR#, rotateL#, rotateR# :: KnownNat n => Unsigned n -> Int -> Unsigned n-{-# NOINLINE shiftL# #-}-shiftL# (U v) i-  | i < 0     = error-              $ "'shiftL undefined for negative number: " ++ show i-  | otherwise = fromInteger_INLINE (shiftL v i)+shiftL#, shiftR#, rotateL#, rotateR# :: forall n .KnownNat n => Unsigned n -> Int -> Unsigned n+{-# OPAQUE shiftL# #-}+{-# ANN shiftL# hasBlackBox #-}+shiftL# = \(U v) i ->+  let i' = fromIntegral i in+  if | i < 0     -> error $ "'shiftL' undefined for negative number: " ++ show i+     | i' >= sz  -> U 0+     | otherwise -> U ((naturalShiftL v i') `mod` m)+ where+  sz = naturalToWord (natVal (Proxy @n))+  m  = 1 `naturalShiftL` sz -{-# NOINLINE shiftR# #-}+{-# OPAQUE shiftR# #-}+{-# ANN shiftR# hasBlackBox #-} -- shiftR# doesn't need the KnownNat constraint -- But having the same type signature for all shift and rotate functions -- makes implementing the Evaluator easier. shiftR# (U v) i   | i < 0     = error-              $ "'shiftR undefined for negative number: " ++ show i+              $ "'shiftR' undefined for negative number: " ++ show i   | otherwise = U (shiftR v i) -{-# NOINLINE rotateL# #-}-rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers"-rotateL# bv@(U n) b   = fromInteger_INLINE (l .|. r)+{-# OPAQUE rotateL# #-}+{-# ANN rotateL# hasBlackBox #-}+rotateL# =+  \(U n) b ->+    if b >= 0 then+      let l   = naturalShiftL n b'+          r   = naturalShiftR n b''+          b'  = fromIntegral b `mod` sz+          b'' = sz - b'+      in  U ((l .|. r) `mod` m)+    else+      error $ "'rotateL' undefined for negative number: " ++ show b   where-    l    = shiftL n b'-    r    = shiftR n b''--    b'   = b `mod` sz-    b''  = sz - b'-    sz   = fromInteger (natVal bv)+    sz = naturalToWord (natVal (Proxy @n))+    m  = 1 `naturalShiftL` sz -{-# NOINLINE rotateR# #-}-rotateR# _ b | b < 0 = error "'shiftR undefined for negative numbers"-rotateR# bv@(U n) b   = fromInteger_INLINE (l .|. r)+{-# OPAQUE rotateR# #-}+{-# ANN rotateR# hasBlackBox #-}+rotateR# =+  \(U n) b ->+    if b >= 0 then+      let l   = naturalShiftR n b'+          r   = naturalShiftL n b''+          b'  = fromIntegral b `mod` sz+          b'' = sz - b'+      in  U ((l .|. r) `mod` m)+    else+      error $ "'rotateR' undefined for negative number: " ++ show b   where-    l   = shiftR n b'-    r   = shiftL n b''+    sz = naturalToWord (natVal (Proxy @n))+    m  = 1 `naturalShiftL` sz -    b'  = b `mod` sz-    b'' = sz - b'-    sz  = fromInteger (natVal bv)  instance KnownNat n => FiniteBits (Unsigned n) where   finiteBitSize        = size#@@ -417,10 +550,11 @@   zeroExtend = extend   truncateB  = resize# -{-# NOINLINE resize# #-}+{-# OPAQUE resize# #-}+{-# ANN resize# hasBlackBox #-} resize# :: forall n m . KnownNat m => Unsigned n -> Unsigned m-resize# (U i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @m))-                in  if i >= m then fromInteger_INLINE i else U i+resize# = \(U i) -> if i >= m then U (i `mod` m) else U i+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @m))  instance Default (Unsigned n) where   def = minBound#@@ -428,9 +562,10 @@ instance KnownNat n => Lift (Unsigned n) where   lift u@(U i) = sigE [| fromInteger# i |] (decUnsigned (natVal u))   {-# NOINLINE lift #-}+  liftTyped = liftTypedFromUntyped -decUnsigned :: Integer -> TypeQ-decUnsigned n = appT (conT ''Unsigned) (litT $ numTyLit n)+decUnsigned :: Quote m => Natural -> m Type+decUnsigned n = appT (conT ''Unsigned) (litT $ numTyLit (integerFromNatural n))  instance KnownNat n => SaturatingNum (Unsigned n) where   satAdd SatWrap a b = a +# b@@ -439,6 +574,11 @@     in  case msb r of           0 -> resize# r           _ -> minBound#+  satAdd SatError a b =+    let r = plus# a b+    in  case msb r of+          0 -> resize# r+          _ -> errorX "Unsigned.satAdd: overflow"   satAdd _ a b =     let r  = plus# a b     in  case msb r of@@ -446,6 +586,11 @@           _ -> maxBound#    satSub SatWrap a b = a -# b+  satSub SatError a b =+    let r = minus# a b+    in  case msb r of+          0 -> resize# r+          _ -> errorX "Unsigned.satSub: overflow"   satSub _ a b =     let r = minus# a b     in  case msb r of@@ -459,6 +604,12 @@     in  case rL of           0 -> unpack# rR           _ -> minBound#+  satMul SatError a b =+    let r       = times# a b+        (rL,rR) = split r+    in  case rL of+          0 -> unpack# rR+          _ -> errorX "Unsigned.satMul: overflow"   satMul _ a b =     let r       = times# a b         (rL,rR) = split r@@ -466,6 +617,19 @@           0 -> unpack# rR           _ -> maxBound# +  -- Implementations for satSucc and satPred are needed because 1 :: Unsigned 0+  -- overflows to 0, meaning without the first check SatError would return 0.++  satSucc SatError a+    | a == maxBound = errorX "Unsigned.satSucc: overflow"+  satSucc satMode a = satAdd satMode a 1+  {-# INLINE satSucc #-}++  satPred SatError a+    | a == minBound = errorX "Unsigned.satPred: overflow"+  satPred satMode a = satSub satMode a 1+  {-# INLINE satPred #-}+ instance KnownNat n => Arbitrary (Unsigned n) where   arbitrary = arbitraryBoundedIntegral   shrink    = BV.shrinkSizedUnsigned@@ -478,3 +642,41 @@ instance KnownNat n => Ixed (Unsigned n) where   ix i f s = unpack# <$> BV.replaceBit# (pack# s) i                      <$> f (BV.index# (pack# s) i)++instance (KnownNat n) => Ix (Unsigned n) where+  range (a, b) = [a..b]+  index ab@(a, b) x+    | inRange ab x = fromIntegral $ x - a+    | otherwise = error $ printf "Index (%d) out of range ((%d, %d))" x a b+  inRange (a, b) x = a <= x && x <= b++unsignedToWord :: Unsigned WORD_SIZE_IN_BITS -> Word+unsignedToWord (U (NS u#)) = W# u#+unsignedToWord (U (NB u#)) = bigNatToWord u#+{-# OPAQUE unsignedToWord #-}+{-# ANN unsignedToWord hasBlackBox #-}++unsigned8toWord8 :: Unsigned 8 -> Word8+unsigned8toWord8 (U (NS u#)) = W8# (wordToWord8# u#)+unsigned8toWord8 (U (NB u#)) = W8# (wordToWord8# (bigNatToWord# u#))+{-# OPAQUE unsigned8toWord8 #-}+{-# ANN unsigned8toWord8 hasBlackBox #-}++unsigned16toWord16 :: Unsigned 16 -> Word16+unsigned16toWord16 (U (NS u#)) = W16# (wordToWord16# u#)+unsigned16toWord16 (U (NB u#)) = W16# (wordToWord16# (bigNatToWord# u#))+{-# OPAQUE unsigned16toWord16 #-}+{-# ANN unsigned16toWord16 hasBlackBox #-}++unsigned32toWord32 :: Unsigned 32 -> Word32+unsigned32toWord32 (U (NS u#)) = W32# (wordToWord32# u#)+unsigned32toWord32 (U (NB u#)) = W32# (wordToWord32# (bigNatToWord# u#))+{-# OPAQUE unsigned32toWord32 #-}+{-# ANN unsigned32toWord32 hasBlackBox #-}++{-# RULES+"bitCoerce/Unsigned WORD_SIZE_IN_BITS -> Word" bitCoerce = unsignedToWord+"bitCoerce/Unsigned 8 -> Word8" bitCoerce = unsigned8toWord8+"bitCoerce/Unsigned 16 -> Word16" bitCoerce = unsigned16toWord16+"bitCoerce/Unsigned 32 -> Word32" bitCoerce = unsigned32toWord32+ #-}
src/Clash/Sized/RTree.hs view
@@ -1,27 +1,17 @@ {-| Copyright  :  (C) 2016, University of Twente+                  2022-2025, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# LANGUAGE CPP                  #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE InstanceSigs         #-}-{-# LANGUAGE KindSignatures       #-}-{-# LANGUAGE PatternSynonyms      #-}-{-# LANGUAGE RankNTypes           #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TupleSections        #-}-{-# LANGUAGE TypeApplications     #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns         #-}-#if __GLASGOW_HASKELL__ >= 806-{-# LANGUAGE NoStarIsType #-}-#endif  {-# LANGUAGE Trustworthy #-} @@ -29,11 +19,13 @@  module Clash.Sized.RTree   ( -- * 'RTree' data type-    RTree (LR, BR)+    RTree (LR, BR, RLeaf, RBranch)     -- * Construction   , treplicate   , trepeat     -- * Accessors+  , thead+  , tlast     -- ** Indexing   , indexTree   , tindices@@ -51,31 +43,42 @@   , tfold     -- ** Specialised folds   , tdfold+    -- ** Prefix sums (scans)+    -- $scans+  , scanlPar+  , tscanl+  , scanrPar+  , tscanr     -- * Conversions   , v2t   , t2v     -- * Misc   , lazyT++  -- * Internal+  , textract+  , tsplit   ) where -import Control.Applicative         (liftA2) import Control.DeepSeq             (NFData(..)) import qualified Control.Lens      as Lens-import Data.Default.Class          (Default (..))+import Data.Default                (Default (..)) import Data.Either                 (isLeft) import Data.Foldable               (toList) import Data.Kind                   (Type)-import Data.Singletons.Prelude     (Apply, TyFun, type (@@))+import Data.Singletons             (Apply, TyFun, type (@@)) import Data.Proxy                  (Proxy (..)) import GHC.TypeLits                (KnownNat, Nat, type (+), type (^), type (*)) import Language.Haskell.TH.Syntax  (Lift(..))-import Prelude                     hiding ((++), (!!))+import Language.Haskell.TH.Compat+import Prelude                     hiding ((++), (!!), map) import Test.QuickCheck             (Arbitrary (..), CoArbitrary (..)) -import Clash.Class.BitPack         (BitPack (..), packXWith)-import Clash.Promoted.Nat          (SNat (..), UNat (..), pow2SNat, snatToNum,-                                    subSNat, toUNat)+import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Class.BitPack         (BitPack (..))+import Clash.Promoted.Nat          (SNat (..), UNat (..),+                                    pow2SNat, snatToNum, subSNat, toUNat) import Clash.Promoted.Nat.Literals (d1) import Clash.Sized.Index           (Index) import Clash.Sized.Vector          (Vec (..), (!!), (++), dtfold, replace)@@ -92,7 +95,10 @@ >>> :set -fplugin GHC.TypeLits.Normalise >>> :set -XUndecidableInstances >>> import Clash.Prelude->>> data IIndex (f :: TyFun Nat *) :: *+>>> import Data.Kind+>>> import Data.Singletons (Apply, TyFun)+>>> import Data.Proxy+>>> data IIndex (f :: TyFun Nat Type) :: Type >>> type instance Apply IIndex l = Index ((2^l)+1) >>> :{ let populationCount' :: (KnownNat k, KnownNat (2^k)) => BitVector (2^k) -> Index ((2^k)+1)@@ -108,24 +114,30 @@ -- * Only has elements at the leaf of the tree -- * A tree of depth /d/ has /2^d/ elements. data RTree :: Nat -> Type -> Type where-  LR_ :: a -> RTree 0 a-  BR_ :: RTree d a -> RTree d a -> RTree (d+1) a+  RLeaf :: a -> RTree 0 a+  RBranch :: RTree d a -> RTree d a -> RTree (d+1) a  instance NFData a => NFData (RTree d a) where-    rnf (LR_ x) = rnf x-    rnf (BR_ l r ) = rnf l `seq` rnf r+    rnf (RLeaf x) = rnf x+    rnf (RBranch l r ) = rnf l `seq` rnf r  textract :: RTree 0 a -> a-textract (LR_ x)   = x-textract (BR_ _ _) = error $ "textract: nodes hold no values"-{-# NOINLINE textract #-}+textract (RLeaf x)   = x+#if __GLASGOW_HASKELL__ < 912+textract (RBranch _ _) = error $ "textract: nodes hold no values"+#endif+{-# OPAQUE textract #-}+{-# ANN textract hasBlackBox #-}  tsplit :: RTree (d+1) a -> (RTree d a,RTree d a)-tsplit (BR_ l r) = (l,r)-tsplit (LR_ _)   = error $ "tsplit: leaf is atomic"-{-# NOINLINE tsplit #-}+tsplit (RBranch l r) = (l,r)+#if __GLASGOW_HASKELL__ < 912+tsplit (RLeaf _)   = error $ "tsplit: leaf is atomic"+#endif+{-# OPAQUE tsplit #-}+{-# ANN tsplit hasBlackBox #-} --- | Leaf of a perfect depth tree+-- | RLeaf of a perfect depth tree -- -- >>> LR 1 -- 1@@ -143,9 +155,9 @@ pattern LR :: a -> RTree 0 a pattern LR x <- (textract -> x)   where-    LR x = LR_ x+    LR x = RLeaf x --- | Branch of a perfect depth tree+-- | RBranch of a perfect depth tree -- -- >>> BR (LR 1) (LR 2) -- <1,2>@@ -163,7 +175,7 @@ pattern BR :: RTree d a -> RTree d a -> RTree (d+1) a pattern BR l r <- ((\t -> (tsplit t)) -> (l,r))   where-    BR l r = BR_ l r+    BR l r = RBranch l r  instance (KnownNat d, Eq a) => Eq (RTree d a) where   (==) t1 t2 = (==) (t2v t1) (t2v t2)@@ -172,15 +184,15 @@   compare t1 t2 = compare (t2v t1) (t2v t2)  instance Show a => Show (RTree n a) where-  showsPrec _ (LR_ a)   = shows a-  showsPrec _ (BR_ l r) = \s -> '<':shows l (',':shows r ('>':s))+  showsPrec _ (RLeaf a)   = shows a+  showsPrec _ (RBranch l r) = \s -> '<':shows l (',':shows r ('>':s))  instance ShowX a => ShowX (RTree n a) where   showsPrecX = showsPrecXWith go     where       go :: Int -> RTree d a -> ShowS-      go _ (LR_ a)   = showsX a-      go _ (BR_ l r) = \s -> '<':showsX l (',':showsX r ('>':s))+      go _ (RLeaf a)   = showsX a+      go _ (RBranch l r) = \s -> '<':showsX l (',':showsX r ('>':s))  instance KnownNat d => Functor (RTree d) where   fmap = tmap@@ -201,10 +213,10 @@                       (fmap LR . f)                       (const (liftA2 BR)) -instance (KnownNat d, KnownNat (BitSize a), BitPack a) =>+instance (KnownNat d, BitPack a) =>   BitPack (RTree d a) where   type BitSize (RTree d a) = (2^d) * (BitSize a)-  pack   = packXWith (pack . t2v)+  pack   = pack . t2v . lazyT   unpack = v2t . unpack  type instance Lens.Index   (RTree d a) = Int@@ -216,8 +228,9 @@   def = trepeat def  instance Lift a => Lift (RTree d a) where-  lift (LR_ a)     = [| LR_ a |]-  lift (BR_ t1 t2) = [| BR_ $(lift t1) $(lift t2) |]+  lift (RLeaf a)     = [| RLeaf a |]+  lift (RBranch t1 t2) = [| RBranch $(lift t1) $(lift t2) |]+  liftTyped = liftTypedFromUntyped  instance (KnownNat d, Arbitrary a) => Arbitrary (RTree d a) where   arbitrary = sequenceA (trepeat arbitrary)@@ -232,113 +245,149 @@   rnfX t = if isLeft (isX t) then () else go t    where     go :: RTree d a -> ()-    go (LR_ x)   = rnfX x-    go (BR_ l r) = rnfX l `seq` rnfX r+    go (RLeaf x)   = rnfX x+    go (RBranch l r) = rnfX l `seq` rnfX r +  hasUndefined t = if isLeft (isX t) then True else go t+   where+    go :: RTree d a -> Bool+    go (RLeaf x)   = hasUndefined x+    go (RBranch l r) = hasUndefined l || hasUndefined r --- | A /dependently/ typed fold over trees.------ As an example of when you might want to use 'dtfold' we will build a--- population counter: a circuit that counts the number of bits set to '1' in--- a 'BitVector'. Given a vector of /n/ bits, we only need we need a data type--- that can represent the number /n/: 'Index' @(n+1)@. 'Index' @k@ has a range--- of @[0 .. k-1]@ (using @ceil(log2(k))@ bits), hence we need 'Index' @n+1@.--- As an initial attempt we will use 'tfold', because it gives a nice (@log2(n)@)--- tree-structure of adders:------ @--- populationCount :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1))---                 => BitVector (2^d) -> Index (2^d+1)--- populationCount = tfold fromIntegral (+) . v2t . bv2v--- @------ The \"problem\" with this description is that all adders have the same--- bit-width, i.e. all adders are of the type:------ @--- (+) :: 'Index' (2^d+1) -> 'Index' (2^d+1) -> 'Index' (2^d+1).--- @------ This is a \"problem\" because we could have a more efficient structure:--- one where each layer of adders is /precisely/ wide enough to count the number--- of bits at that layer. That is, at height /d/ we want the adder to be of--- type:------ @--- 'Index' ((2^d)+1) -> 'Index' ((2^d)+1) -> 'Index' ((2^(d+1))+1)--- @------ We have such an adder in the form of the 'Clash.Class.Num.add' function, as--- defined in the instance 'Clash.Class.Num.ExtendingNum' instance of 'Index'.--- However, we cannot simply use 'fold' to create a tree-structure of--- 'Clash.Class.Num.add'es:------ >>> :{--- let populationCount' :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1))---                      => BitVector (2^d) -> Index (2^d+1)---     populationCount' = tfold fromIntegral add . v2t . bv2v--- :}--- <BLANKLINE>--- <interactive>:...---     • Couldn't match type ‘(((2 ^ d) + 1) + ((2 ^ d) + 1)) - 1’---                      with ‘(2 ^ d) + 1’---       Expected type: Index ((2 ^ d) + 1)---                      -> Index ((2 ^ d) + 1) -> Index ((2 ^ d) + 1)---         Actual type: Index ((2 ^ d) + 1)---                      -> Index ((2 ^ d) + 1)---                      -> AResult (Index ((2 ^ d) + 1)) (Index ((2 ^ d) + 1))---     • In the second argument of ‘tfold’, namely ‘add’---       In the first argument of ‘(.)’, namely ‘tfold fromIntegral add’---       In the expression: tfold fromIntegral add . v2t . bv2v---     • Relevant bindings include---         populationCount' :: BitVector (2 ^ d) -> Index ((2 ^ d) + 1)---           (bound at ...)------ because 'tfold' expects a function of type \"@b -> b -> b@\", i.e. a function--- where the arguments and result all have exactly the same type.------ In order to accommodate the type of our 'Clash.Class.Num.add', where the--- result is larger than the arguments, we must use a dependently typed fold in--- the form of 'dtfold':------ @--- {\-\# LANGUAGE UndecidableInstances \#-\}--- import Data.Singletons.Prelude--- import Data.Proxy------ data IIndex (f :: 'TyFun' Nat *) :: *--- type instance 'Apply' IIndex l = 'Index' ((2^l)+1)------ populationCount' :: (KnownNat k, KnownNat (2^k))---                  => BitVector (2^k) -> Index ((2^k)+1)--- populationCount' bv = 'tdfold' (Proxy @IIndex)---                              fromIntegral---                              (\\_ x y -> 'Clash.Class.Num.add' x y)---                              ('v2t' ('Clash.Sized.Vector.bv2v' bv))--- @------ And we can test that it works:------ >>> :t populationCount' (7 :: BitVector 16)--- populationCount' (7 :: BitVector 16) :: Index 17--- >>> populationCount' (7 :: BitVector 16)--- 3+  ensureSpine = fmap ensureSpine . lazyT+++{- | A /dependently/ typed fold over trees.++As an example of when you might want to use 'dtfold' we will build a+population counter: a circuit that counts the number of bits set to '1' in+a 'Clash.Sized.BitVector.BitVector'. Given a vector of /n/ bits, we only need we+need a data type that can represent the number /n/: 'Index' @(n+1)@. 'Index' @k@+has a range of @[0 .. k-1]@ (using @ceil(log2(k))@ bits), hence we need 'Index' @n+1@.+As an initial attempt we will use 'tfold', because it gives a nice (@log2(n)@)+tree-structure of adders:++@+populationCount :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1))+                => BitVector (2^d) -> Index (2^d+1)+populationCount = tfold (resize . bv2i . pack) (+) . v2t . bv2v+@++The \"problem\" with this description is that all adders have the same+bit-width, i.e. all adders are of the type:++@+(+) :: 'Index' (2^d+1) -> 'Index' (2^d+1) -> 'Index' (2^d+1).+@++This is a \"problem\" because we could have a more efficient structure:+one where each layer of adders is /precisely/ wide enough to count the number+of bits at that layer. That is, at height /d/ we want the adder to be of+type:++@+'Index' ((2^d)+1) -> 'Index' ((2^d)+1) -> 'Index' ((2^(d+1))+1)+@++We have such an adder in the form of the 'Clash.Class.Num.add' function, as+defined in the instance 'Clash.Class.Num.ExtendingNum' instance of 'Index'.+However, we cannot simply use 'Clash.Sized.Vector.fold' to create a tree-structure of+'Clash.Class.Num.add's:++#if __GLASGOW_HASKELL__ >= 910+>>> :{+let populationCount' :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1))+                     => BitVector (2^d) -> Index (2^d+1)+    populationCount' = tfold (resize . bv2i . pack) add . v2t . bv2v+:}+<interactive>:...+...+      Expected: Index ((2 ^ d) + 1)+                -> Index ((2 ^ d) + 1) -> Index ((2 ^ d) + 1)+        Actual: Index ((2 ^ d) + 1)+                -> Index ((2 ^ d) + 1)+                -> AResult (Index ((2 ^ d) + 1)) (Index ((2 ^ d) + 1))+...+    • In the second argument of ‘tfold’, namely ‘add’+      In the first argument of ‘(.)’, namely+        ‘tfold (resize . bv2i . pack) add’+      In the expression: tfold (resize . bv2i . pack) add . v2t . bv2v+    • Relevant bindings include+        populationCount' :: BitVector (2 ^ d) -> Index ((2 ^ d) + 1)+          (bound at ...)+<BLANKLINE>++#else+>>> :{+let populationCount' :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1))+                     => BitVector (2^d) -> Index (2^d+1)+    populationCount' = tfold (resize . bv2i . pack) add . v2t . bv2v+:}+<BLANKLINE>+<interactive>:...+...+      Expected: Index ((2 ^ d) + 1)+                -> Index ((2 ^ d) + 1) -> Index ((2 ^ d) + 1)+        Actual: Index ((2 ^ d) + 1)+                -> Index ((2 ^ d) + 1)+                -> AResult (Index ((2 ^ d) + 1)) (Index ((2 ^ d) + 1))+...+    • In the second argument of ‘tfold’, namely ‘add’+      In the first argument of ‘(.)’, namely+        ‘tfold (resize . bv2i . pack) add’+      In the expression: tfold (resize . bv2i . pack) add . v2t . bv2v+    • Relevant bindings include+        populationCount' :: BitVector (2 ^ d) -> Index ((2 ^ d) + 1)+          (bound at ...)++#endif++because 'tfold' expects a function of type \"@b -> b -> b@\", i.e. a function+where the arguments and result all have exactly the same type.++In order to accommodate the type of our 'Clash.Class.Num.add', where the+result is larger than the arguments, we must use a dependently typed fold in+the form of 'dtfold':++@+{\-\# LANGUAGE UndecidableInstances \#-\}+import Data.Singletons++data IIndex (f :: 'TyFun' Nat Type) :: Type+type instance 'Apply' IIndex l = 'Index' ((2^l)+1)++populationCount' :: (KnownNat k, KnownNat (2^k))+                 => BitVector (2^k) -> Index ((2^k)+1)+populationCount' bv = 'tdfold' (Proxy @IIndex)+                             (resize . bv2i . pack)+                             (\\_ x y -> 'Clash.Class.Num.add' x y)+                             ('v2t' ('Clash.Sized.Vector.bv2v' bv))+@++And we can test that it works:++>>> :t populationCount' (7 :: BitVector 16)+populationCount' (7 :: BitVector 16) :: Index 17+>>> populationCount' (7 :: BitVector 16)+3+-} tdfold :: forall p k a . KnownNat k        => Proxy (p :: TyFun Nat Type -> Type) -- ^ The /motive/        -> (a -> (p @@ 0)) -- ^ Function to apply to the elements on the leafs        -> (forall l . SNat l -> (p @@ l) -> (p @@ l) -> (p @@ (l+1)))        -- ^ Function to fold the branches with.        ---       -- __NB:__ @SNat l@ is the depth of the two sub-branches.+       -- __NB__: @SNat l@ is the depth of the two sub-branches.        -> RTree k a -- ^ Tree to fold over.        -> (p @@ k) tdfold _ f g = go SNat   where     go :: SNat m -> RTree m a -> (p @@ m)-    go _  (LR_ a)   = f a-    go sn (BR_ l r) = let sn' = sn `subSNat` d1+    go _  (RLeaf a)   = f a+    go sn (RBranch l r) = let sn' = sn `subSNat` d1                       in  g sn' (go sn' l) (go sn' r)-{-# NOINLINE tdfold #-}+{-# OPAQUE tdfold #-}+{-# ANN tdfold hasBlackBox #-}  data TfoldTree (a :: Type) (f :: TyFun Nat Type) :: Type type instance Apply (TfoldTree a) d = a@@ -366,7 +415,8 @@     go :: UNat n -> RTree n a     go UZero      = LR a     go (USucc un) = BR (go un) (go un)-{-# NOINLINE treplicate #-}+{-# OPAQUE treplicate #-}+{-# ANN treplicate hasBlackBox #-}  -- | \"'trepeat' @a@\" creates a tree with as many copies of /a/ as demanded by -- the context.@@ -402,9 +452,7 @@  -- | Convert a vector with /2^d/ elements to a tree of depth /d/. ----- >>> (1:>2:>3:>4:>Nil)--- <1,2,3,4>--- >>> v2t (1:>2:>3:>4:>Nil)+-- >>> v2t (1 :> 2 :> 3 :> 4:> Nil) -- <<1,2>,<3,4>> v2t :: forall d a . KnownNat d => Vec (2^d) a -> RTree d a v2t = dtfold (Proxy @(V2TTree a)) LR (const BR)@@ -417,7 +465,7 @@ -- >>> (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) -- <<1,2>,<3,4>> -- >>> t2v (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4)))--- <1,2,3,4>+-- 1 :> 2 :> 3 :> 4 :> Nil t2v :: forall d a . KnownNat d => RTree d a -> Vec (2^d) a t2v = tdfold (Proxy @(T2VTree a)) (:> Nil) (\_ l r -> l ++ r) @@ -447,7 +495,7 @@ -- >>> replaceTree 2 7 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) -- <<1,2>,<7,4>> -- >>> replaceTree 9 6 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4)))--- <<1,2>,<3,*** Exception: Clash.Sized.Vector.replace: index 9 is larger than maximum index 3+-- <<1,2>,<3,*** Exception: Clash.Sized.Vector.replace: index 9 is out of bounds: [0..3] -- ... replaceTree :: (KnownNat d, Enum i) => i -> a -> RTree d a -> RTree d a replaceTree i a = v2t . replace i a . t2v@@ -464,17 +512,18 @@ tzipWith f = tdfold (Proxy @(ZipWithTree b c)) lr br   where     lr :: a -> RTree 0 b -> RTree 0 c-    lr a (LR b) = LR (f a b)-    lr _ _      = error "impossible"+    lr a t = LR (f a (textract t))      br :: SNat l        -> (RTree l b -> RTree l c)        -> (RTree l b -> RTree l c)        -> RTree (l+1) b        -> RTree (l+1) c-    br _ fl fr (BR l r) = BR (fl l) (fr r)-    br _ _  _  _        = error "impossible"+    br _ fl fr t = BR (fl l) (fr r)+      where+        (l,r) = tsplit t + -- | 'tzip' takes two trees and returns a tree of corresponding pairs. tzip :: KnownNat d => RTree d a -> RTree d b -> RTree d (a,b) tzip = tzipWith (,)@@ -491,11 +540,134 @@      br _ (l1,r1) (l2,r2) = (BR l1 l2, BR r1 r2) --- | Given a function 'f' that is strict in its /n/th 'RTree' argument, make it+-- | Given a function @f@ that is strict in its /n/th 'RTree' argument, make it -- lazy by applying 'lazyT' to this argument: -- -- > f x0 x1 .. (lazyT xn) .. xn_plus_k lazyT :: KnownNat d       => RTree d a       -> RTree d a-lazyT = tzipWith (flip const) (trepeat undefined)+lazyT = tzipWith (flip const) (trepeat ())++-- | Extract the first element of a tree+--+-- The first element is defined to be the bottom-left leaf.+--+-- >>> thead $ BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))+-- 1+thead :: RTree n a -> a+thead (RLeaf x) = x+thead (RBranch x _) = thead x++-- | Extract the last element of a tree+--+-- The last element is defined to be the bottom-right leaf.+--+-- >>> tlast $ BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))+-- 4+tlast :: RTree n a -> a+tlast (RLeaf x) = x+tlast (RBranch _ y) = tlast y++{- $scans #scans#++Scans (`Clash.Sized.Vector.scanl`, `Clash.Sized.Vector.scanr`) are similar to+folds (`Clash.Sized.Vector.foldl`, `Clash.Sized.Vector.foldr`) but return a list+of successive reduced values. When the binary reduction operator @f@ is+associative, the scan functions in this module can be characterized as follows:++> tscanl f [x1, x2, x3, ...] == [x1, x1 `f` x2, x1 `f` x2 `f` x3, ...]++> tscanr f [..., xn2, xn1, xn] == [..., xn2 `f` xn1 `f` xn, xn1 `f` xn, xn]++The scan functions in this module provide a different trade-off between circuit+size and logic depth than the default `Clash.Sized.Vector.scanl` and+`Clash.Sized.Vector.scanr` functions. When \(n\) is the number of elements,+circuit size is \(\mathcal{O}(n \cdot \log n)\), but logic depth is \(\mathcal{O}(\log n)\).+This means the resource usage will likely increase, but the maximum clock+frequency also increases due to the reduced logic depth. The exact amount of+instantiations of @f@ given a tree of depth /d/ is:++> work 0 = 0+> work d = 2 ^ (d - 1) + 2 * work (d - 1)++-}++-- | `tscanl` applied to `Vec`+--+-- >>> scanlPar (+) (1 :> 2 :> 3 :> 4 :> Nil)+-- 1 :> 3 :> 6 :> 10 :> Nil+scanlPar ::+  KnownNat n =>+  -- | Must be associative+  (a -> a -> a) ->+  Vec (2^n) a ->+  Vec (2^n) a+scanlPar op = t2v . tscanl op . v2t+{-# INLINE scanlPar #-}++-- | `tscanr` applied to `Vec`+--+-- >>> scanrPar (+) (1 :> 2 :> 3 :> 4 :> Nil)+-- 10 :> 9 :> 7 :> 4 :> Nil+scanrPar ::+  KnownNat n =>+   -- | Must be associative+  (a -> a -> a) ->+  Vec (2^n) a ->+  Vec (2^n) a+scanrPar op = t2v . tscanr op . v2t+{-# INLINE scanrPar #-}++-- | Low-depth left scan+--+-- `tscanl` is similar to `Clash.Sized.Vector.foldl`, but returns a tree of+-- successive reduced values from the left:+--+-- > tscanl f [x1, x2, x3, ...] == [x1, x1 `f` x2, x1 `f` x2 `f` x3, ...]+--+-- >>> tscanl (+) (v2t (1 :> 2 :> 3 :> 4 :> Nil))+-- <<1,3>,<6,10>>+--+-- <<doc/scanlPar.svg>>+tscanl ::+  forall a n.+  KnownNat n =>+  -- | Must be associative+  (a -> a -> a) ->+  RTree n a ->+  RTree n a+tscanl op tr =+  case tr of+    RLeaf x -> LR x+    RBranch x y ->+      let+        x' = tscanl op x+        y' = tscanl op y+        l = tlast x'+      in BR x' (fmap (l `op`) y')++-- | Low-depth right scan+--+-- `tscanr` is similar to `Clash.Sized.Vector.foldr`, but returns a tree of+-- successive reduced values from the left:+--+-- > tscanr f [..., xn2, xn1, xn] == [..., xn2 `f` xn1 `f` xn, xn1 `f` xn, xn]+--+-- >>> tscanr (+) (v2t (1 :> 2 :> 3 :> 4 :> Nil))+-- <<10,9>,<7,4>>+tscanr ::+  forall a n.+  KnownNat n =>+  (a -> a -> a) ->+  RTree n a ->+  RTree n a+tscanr op tr =+  case tr of+    RLeaf x -> LR x+    RBranch x y ->+        let+          x' = tscanr op x+          y' = tscanr op y+          l = thead y'+        in BR (fmap (l `op`) x') y'
src/Clash/Sized/Vector.hs view
@@ -1,2238 +1,2771 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2017     , Myrtle Software Ltd-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE BangPatterns         #-}-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE GADTs                #-}-{-# LANGUAGE KindSignatures       #-}-{-# LANGUAGE MagicHash            #-}-{-# LANGUAGE PatternSynonyms      #-}-{-# LANGUAGE Rank2Types           #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TupleSections        #-}-{-# LANGUAGE TypeApplications     #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns         #-}-#if __GLASGOW_HASKELL__ >= 806-{-# LANGUAGE NoStarIsType #-}-#endif--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}--{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-redundant-constraints #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module Clash.Sized.Vector-  ( -- * 'Vec'tor data type-    Vec(Nil,(:>),(:<),Cons)-    -- * Accessors-    -- ** Length information-  , length, lengthS-    -- ** Indexing-  , (!!), head, last, at-  , indices, indicesI-  , findIndex, elemIndex-    -- ** Extracting sub-vectors (slicing)-  , tail, init-  , take, takeI, drop, dropI-  , select, selectI-    -- *** Splitting-  , splitAt, splitAtI-  , unconcat, unconcatI-    -- * Construction-    -- ** Initialisation-  , singleton-  , replicate, repeat-  , iterate, iterateI, generate, generateI-    -- *** Initialisation from a list-  , listToVecTH-    -- ** Concatenation-  , (++), (+>>), (<<+), concat, concatMap-  , shiftInAt0, shiftInAtN , shiftOutFrom0, shiftOutFromN-  , merge-    -- * Modifying vectors-  , replace-    -- ** Permutations-  , permute, backpermute, scatter, gather-    -- *** Specialised permutations-  , reverse, transpose, interleave-  , rotateLeft, rotateRight, rotateLeftS, rotateRightS-    -- * Element-wise operations-    -- ** Mapping-  , map, imap, smap-    -- ** Zipping-  , zipWith, zipWith3, zipWith4, zipWith5, zipWith6, zipWith7-  , zip, zip3, zip4, zip5, zip6, zip7-  , izipWith-    -- ** Unzipping-  , unzip, unzip3, unzip4, unzip5, unzip6, unzip7-    -- * Folding-  , foldr, foldl, foldr1, foldl1, fold-  , ifoldr, ifoldl-    -- ** Specialised folds-  , dfold, dtfold, vfold-    -- * Prefix sums (scans)-  , scanl, scanr, postscanl, postscanr-  , mapAccumL, mapAccumR-    -- * Stencil computations-  , stencil1d, stencil2d-  , windows1d, windows2d-    -- * Conversions-  , toList-  , bv2v-  , v2bv-    -- * Misc-  , lazyV, VCons, asNatProxy, seqV, forceV, seqVX, forceVX-    -- * Primitives-    -- ** 'Traversable' instance-  , traverse#-    -- ** 'BitPack' instance-  , concatBitVector#-  , unconcatBitVector#-  )-where--import Control.DeepSeq            (NFData (..))-import qualified Control.Lens     as Lens hiding (pattern (:>), pattern (:<))-import Data.Constraint            ((:-)(..), Dict (..))-import Data.Constraint.Nat        (leZero)-import Data.Data-  (Data (..), Constr, DataType, Fixity (..), Typeable, mkConstr, mkDataType)-import Data.Default.Class         (Default (..))-import qualified Data.Foldable    as F-import Data.Kind                  (Type)-import Data.Proxy                 (Proxy (..))-import Data.Singletons.Prelude    (TyFun,Apply,type (@@))-import GHC.TypeLits               (CmpNat, KnownNat, Nat, type (+), type (-), type (*),-                                   type (^), type (<=), natVal)-import GHC.Base                   (Int(I#),Int#,isTrue#)-import GHC.Generics               hiding (Fixity (..))-import GHC.Prim                   ((==#),(<#),(-#))-import Language.Haskell.TH        (ExpQ)-import Language.Haskell.TH.Syntax (Lift(..))-import Prelude                    hiding ((++), (!!), concat, concatMap, drop,-                                          foldl, foldl1, foldr, foldr1, head,-                                          init, iterate, last, length, map,-                                          repeat, replicate, reverse, scanl,-                                          scanr, splitAt, tail, take, unzip,-                                          unzip3, zip, zip3, zipWith, zipWith3)-import qualified Prelude          as P-import Test.QuickCheck            (Arbitrary (..), CoArbitrary (..))-import Unsafe.Coerce              (unsafeCoerce)--import Clash.Promoted.Nat-  (SNat (..), SNatLE (..), UNat (..), compareSNat, leToPlus, pow2SNat,-   snatProxy, snatToInteger, subSNat, withSNat, toUNat)-import Clash.Promoted.Nat.Literals (d1)-import Clash.Sized.Internal.BitVector (Bit, BitVector, (++#), split#)-import Clash.Sized.Index          (Index)--import Clash.Class.BitPack        (packXWith, BitPack (..))-import Clash.XException-  (ShowX (..), NFDataX (..), showsX, showsPrecXWith, seqX)--{- $setup->>> :set -XDataKinds->>> :set -XTypeFamilies->>> :set -XTypeOperators->>> :set -XTemplateHaskell->>> :set -XFlexibleContexts->>> :set -XTypeApplications->>> :set -fplugin GHC.TypeLits.Normalise->>> import Clash.Prelude->>> let compareSwapL a b = if a < b then (a,b) else (b,a)->>> :{-let sortV xs = map fst sorted :< (snd (last sorted))-      where-        lefts  = head xs :> map snd (init sorted)-        rights = tail xs-        sorted = zipWith compareSwapL lefts rights-:}-->>> :{-let sortVL xs = map fst sorted :< (snd (last sorted))-      where-        lefts  = head xs :> map snd (init sorted)-        rights = tail xs-        sorted = zipWith compareSwapL (lazyV lefts) rights-:}-->>> :{-let sortV_flip xs = map fst sorted :< (snd (last sorted))-      where-        lefts  = head xs :> map snd (init sorted)-        rights = tail xs-        sorted = zipWith (flip compareSwapL) rights lefts-:}-->>> data Append (m :: Nat) (a :: *) (f :: TyFun Nat *) :: *->>> type instance Apply (Append m a) l = Vec (l + m) a->>> let append' xs ys = dfold (Proxy :: Proxy (Append m a)) (const (:>)) ys xs->>> let compareSwap a b = if a > b then (a,b) else (b,a)->>> let insert y xs     = let (y',xs') = mapAccumL compareSwap y xs in xs' :< y'->>> let insertionSort   = vfold (const insert)->>> data IIndex (f :: TyFun Nat *) :: *->>> :set -XUndecidableInstances->>> type instance Apply IIndex l = Index ((2^l)+1)->>> :{-let populationCount' :: (KnownNat k, KnownNat (2^k)) => BitVector (2^k) -> Index ((2^k)+1)-    populationCount' bv = dtfold (Proxy @IIndex)-                                 fromIntegral-                                 (\_ x y -> add x y)-                                 (bv2v bv)-:}---}--infixr 5 `Cons`--- | Fixed size vectors.------ * Lists with their length encoded in their type--- * 'Vec'tor elements have an __ASCENDING__ subscript starting from 0 and---   ending at @'length' - 1@.-data Vec :: Nat -> Type -> Type where-  Nil  :: Vec 0 a-  Cons :: a -> Vec n a -> Vec (n + 1) a---- | In many cases, this Generic instance only allows generic--- functions/instances over vectors of at least size 1, due to the--- /n-1/ in the /Rep (Vec n a)/ definition.------ We'll have to wait for things like--- https://ryanglscott.github.io/2018/02/11/how-to-derive-generic-for-some-gadts/--- before we can work around this limitation-instance KnownNat n => Generic (Vec n a) where-  type Rep (Vec n a) =-    D1 ('MetaData "Vec" "Clash.Data.Vector" "clash-prelude" 'False)-      (C1 ('MetaCons "Nil" 'PrefixI 'False) U1 :+:-       C1 ('MetaCons "Cons" 'PrefixI 'False)-        (S1 ('MetaSel 'Nothing-                'NoSourceUnpackedness-                'NoSourceStrictness-                'DecidedLazy)-            (Rec0 a) :*:-         S1 ('MetaSel 'Nothing-                'NoSourceUnpackedness-                'NoSourceStrictness-                'DecidedLazy)-            (Rec0 (Vec (n-1) a))))-  from Nil         = M1 (L1 (M1 U1))-  from (Cons x xs) = M1 (R1 (M1 (M1 (K1 x) :*: M1 (K1 xs))))-  to (M1 g) = case compareSNat (SNat @n) (SNat @0) of-    SNatLE -> case leZero @n of-      Sub Dict -> Nil-    SNatGT -> case g of-      R1 (M1 (M1 (K1 p) :*: M1 (K1 q))) -> Cons p q--instance (KnownNat n, Typeable a, Data a) => Data (Vec n a) where-  gunfold k z _ = case compareSNat (SNat @n) (SNat @0) of-    SNatLE -> case leZero @n of-      Sub Dict -> z Nil-    SNatGT -> k (k (z @(a -> Vec (n-1) a -> Vec n a) Cons))-  toConstr Nil        = cNil-  toConstr (Cons _ _) = cCons-  dataTypeOf _        = tVec--tVec :: DataType-tVec = mkDataType "Vec" [cNil, cCons]--cNil :: Constr-cNil = mkConstr tVec "Nil" [] Prefix--cCons :: Constr-cCons = mkConstr tVec "Cons" [] Prefix--instance NFData a => NFData (Vec n a) where-  rnf = foldl (\() -> rnf) ()---- | Add an element to the head of a vector.------ >>> 3:>4:>5:>Nil--- <3,4,5>--- >>> let x = 3:>4:>5:>Nil--- >>> :t x--- x :: Num a => Vec 3 a------ Can be used as a pattern:------ >>> let f (x :> y :> _) = x + y--- >>> :t f--- f :: Num a => Vec ((n + 1) + 1) a -> a--- >>> f (3:>4:>5:>6:>7:>Nil)--- 7------ Also in conjunctions with (':<'):------ >>> let g (a :> b :> (_ :< y :< x)) = a + b +  x + y--- >>> :t g--- g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a--- >>> g (1:>2:>3:>4:>5:>Nil)--- 12-pattern (:>) :: a -> Vec n a -> Vec (n + 1) a-pattern (:>) x xs <- ((\ys -> (head ys,tail ys)) -> (x,xs))-  where-    (:>) x xs = Cons x xs--infixr 5 :>--instance Show a => Show (Vec n a) where-  showsPrec _ vs = \s -> '<':punc vs ('>':s)-    where-      punc :: Vec m a -> ShowS-      punc Nil            = id-      punc (x `Cons` Nil) = shows x-      punc (x `Cons` xs)  = \s -> shows x (',':punc xs s)--instance ShowX a => ShowX (Vec n a) where-  showsPrecX = showsPrecXWith go-    where-      go _ vs = \s -> '<': punc vs ('>':s)-        where-          punc :: Vec m a -> ShowS-          punc Nil            = id-          punc (x `Cons` Nil) = showsX x-          punc (x `Cons` xs)  = \s -> showsX x (',':punc xs s)--instance (KnownNat n, Eq a) => Eq (Vec n a) where-  (==) Nil _            = True-  (==) v1@(Cons _ _) v2 = fold (&&) (zipWith (==) v1 v2)--instance (KnownNat n, Ord a) => Ord (Vec n a) where-  compare x y = foldr f EQ $ zipWith compare x y-    where f EQ   keepGoing = keepGoing-          f done _         = done--instance KnownNat n => Applicative (Vec n) where-  pure      = repeat-  fs <*> xs = zipWith ($) fs xs--instance (KnownNat n, 1 <= n) => F.Foldable (Vec n) where-  fold      = leToPlus @1 @n $ fold mappend-  foldMap f = leToPlus @1 @n $ fold mappend . map f-  foldr     = foldr-  foldl     = foldl-  foldr1 f  = leToPlus @1 @n $ foldr1 f-  foldl1 f  = leToPlus @1 @n $ foldl1 f-  toList    = toList-  null _    = False-  length    = length-  maximum   = leToPlus @1 @n $ fold (\x y -> if x >= y then x else y)-  minimum   = leToPlus @1 @n $ fold (\x y -> if x <= y then x else y)-  sum       = leToPlus @1 @n $ fold (+)-  product   = leToPlus @1 @n $ fold (*)--instance Functor (Vec n) where-  fmap = map--instance (KnownNat n, 1 <= n) => Traversable (Vec n) where-  traverse = traverse#--{-# NOINLINE traverse# #-}-traverse# :: forall a f b n . Applicative f => (a -> f b) -> Vec n a -> f (Vec n b)-traverse# _ Nil           = pure Nil-traverse# f (x `Cons` xs) = Cons <$> f x <*> traverse# f xs--instance (Default a, KnownNat n) => Default (Vec n a) where-  def = repeat def--instance (NFDataX a, KnownNat n) => NFDataX (Vec n a) where-  deepErrorX x = repeat (deepErrorX x)--  rnfX v =-    -- foldl will fail if the spine of the vector is undefined, so we need to-    -- seqX the result of it. We need to use foldl so Clash won't treat it as-    -- a recursive function.-    seqX (foldl (\() -> rnfX) () v) ()---{-# INLINE singleton #-}--- | Create a vector of one element------ >>> singleton 5--- <5>-singleton :: a -> Vec 1 a-singleton = (`Cons` Nil)--{-# NOINLINE head #-}--- | Extract the first element of a vector------ >>> head (1:>2:>3:>Nil)--- 1--- >>> head Nil--- <BLANKLINE>--- <interactive>:...---     • Couldn't match type ‘1’ with ‘0’---       Expected type: Vec (0 + 1) a---         Actual type: Vec 0 a---     • In the first argument of ‘head’, namely ‘Nil’---       In the expression: head Nil---       In an equation for ‘it’: it = head Nil-head :: Vec (n + 1) a -> a-head (x `Cons` _) = x--{-# NOINLINE tail #-}--- | Extract the elements after the head of a vector------ >>> tail (1:>2:>3:>Nil)--- <2,3>--- >>> tail Nil--- <BLANKLINE>--- <interactive>:...---     • Couldn't match type ‘1’ with ‘0’---       Expected type: Vec (0 + 1) a---         Actual type: Vec 0 a---     • In the first argument of ‘tail’, namely ‘Nil’---       In the expression: tail Nil---       In an equation for ‘it’: it = tail Nil-tail :: Vec (n + 1) a -> Vec n a-tail (_ `Cons` xs) = xs--{-# NOINLINE last #-}--- | Extract the last element of a vector------ >>> last (1:>2:>3:>Nil)--- 3--- >>> last Nil--- <BLANKLINE>--- <interactive>:...---     • Couldn't match type ‘1’ with ‘0’---       Expected type: Vec (0 + 1) a---         Actual type: Vec 0 a---     • In the first argument of ‘last’, namely ‘Nil’---       In the expression: last Nil---       In an equation for ‘it’: it = last Nil-last :: Vec (n + 1) a -> a-last (x `Cons` Nil)         = x-last (_ `Cons` y `Cons` ys) = last (y `Cons` ys)--{-# NOINLINE init #-}--- | Extract all the elements of a vector except the last element------ >>> init (1:>2:>3:>Nil)--- <1,2>--- >>> init Nil--- <BLANKLINE>--- <interactive>:...---     • Couldn't match type ‘1’ with ‘0’---       Expected type: Vec (0 + 1) a---         Actual type: Vec 0 a---     • In the first argument of ‘init’, namely ‘Nil’---       In the expression: init Nil---       In an equation for ‘it’: it = init Nil-init :: Vec (n + 1) a -> Vec n a-init (_ `Cons` Nil)         = Nil-init (x `Cons` y `Cons` ys) = x `Cons` init (y `Cons` ys)--{-# INLINE shiftInAt0 #-}--- | Shift in elements to the head of a vector, bumping out elements at the--- tail. The result is a tuple containing:------ * The new vector--- * The shifted out elements------ >>> shiftInAt0 (1 :> 2 :> 3 :> 4 :> Nil) ((-1) :> 0 :> Nil)--- (<-1,0,1,2>,<3,4>)--- >>> shiftInAt0 (1 :> Nil) ((-1) :> 0 :> Nil)--- (<-1>,<0,1>)-shiftInAt0 :: KnownNat n-           => Vec n a -- ^ The old vector-           -> Vec m a -- ^ The elements to shift in at the head-           -> (Vec n a, Vec m a) -- ^ (The new vector, shifted out elements)-shiftInAt0 xs ys = splitAtI zs-  where-    zs = ys ++ xs--{-# INLINE shiftInAtN #-}--- | Shift in element to the tail of a vector, bumping out elements at the head.--- The result is a tuple containing:------ * The new vector--- * The shifted out elements------ >>> shiftInAtN (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> Nil)--- (<3,4,5,6>,<1,2>)--- >>> shiftInAtN (1 :> Nil) (2 :> 3 :> Nil)--- (<3>,<1,2>)-shiftInAtN :: KnownNat m-           => Vec n a -- ^ The old vector-           -> Vec m a -- ^ The elements to shift in at the tail-           -> (Vec n a,Vec m a) -- ^ (The new vector, shifted out elements)-shiftInAtN xs ys = (zsR, zsL)-  where-    zs        = xs ++ ys-    (zsL,zsR) = splitAtI zs--infixl 5 :<--- | Add an element to the tail of a vector.------ >>> (3:>4:>5:>Nil) :< 1--- <3,4,5,1>--- >>> let x = (3:>4:>5:>Nil) :< 1--- >>> :t x--- x :: Num a => Vec 4 a------ Can be used as a pattern:------ >>> let f (_ :< y :< x) = y + x--- >>> :t f--- f :: Num a => Vec ((n + 1) + 1) a -> a--- >>> f (3:>4:>5:>6:>7:>Nil)--- 13------ Also in conjunctions with (':>'):------ >>> let g (a :> b :> (_ :< y :< x)) = a + b +  x + y--- >>> :t g--- g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a--- >>> g (1:>2:>3:>4:>5:>Nil)--- 12-pattern (:<) :: Vec n a -> a -> Vec (n+1) a-pattern (:<) xs x <- ((\ys -> (init ys,last ys)) -> (xs,x))-  where-    (:<) xs x = xs ++ singleton x--infixr 4 +>>--- | Add an element to the head of a vector, and extract all but the last--- element.------ >>> 1 +>> (3:>4:>5:>Nil)--- <1,3,4>--- >>> 1 +>> Nil--- <>-(+>>) :: KnownNat n => a -> Vec n a -> Vec n a-s +>> xs = fst (shiftInAt0 xs (singleton s))-{-# INLINE (+>>) #-}---infixl 4 <<+--- | Add an element to the tail of a vector, and extract all but the first--- element.------ >>> (3:>4:>5:>Nil) <<+ 1--- <4,5,1>--- >>> Nil <<+ 1--- <>-(<<+) :: Vec n a -> a -> Vec n a-xs <<+ s = fst (shiftInAtN xs (singleton s))-{-# INLINE (<<+) #-}---- | Shift /m/ elements out from the head of a vector, filling up the tail with--- 'Default' values. The result is a tuple containing:------ * The new vector--- * The shifted out values------ >>> shiftOutFrom0 d2 ((1 :> 2 :> 3 :> 4 :> 5 :> Nil) :: Vec 5 Integer)--- (<3,4,5,0,0>,<1,2>)-shiftOutFrom0 :: (Default a, KnownNat m)-              => SNat m        -- ^ @m@, the number of elements to shift out-              -> Vec (m + n) a -- ^ The old vector-              -> (Vec (m + n) a, Vec m a)-              -- ^ (The new vector, shifted out elements)-shiftOutFrom0 m xs = shiftInAtN xs (replicate m def)-{-# INLINE shiftOutFrom0 #-}---- | Shift /m/ elements out from the tail of a vector, filling up the head with--- 'Default' values. The result is a tuple containing:------ * The new vector--- * The shifted out values------ >>> shiftOutFromN d2 ((1 :> 2 :> 3 :> 4 :> 5 :> Nil) :: Vec 5 Integer)--- (<0,0,1,2,3>,<4,5>)-shiftOutFromN :: (Default a, KnownNat n)-              => SNat m        -- ^ @m@, the number of elements to shift out-              -> Vec (m + n) a -- ^ The old vector-              -> (Vec (m + n) a, Vec m a)-              -- ^ (The new vector, shifted out elements)-shiftOutFromN m@SNat xs = shiftInAt0 xs (replicate m def)-{-# INLINE shiftOutFromN #-}--infixr 5 ++--- | Append two vectors.------ >>> (1:>2:>3:>Nil) ++ (7:>8:>Nil)--- <1,2,3,7,8>-(++) :: Vec n a -> Vec m a -> Vec (n + m) a-Nil           ++ ys = ys-(x `Cons` xs) ++ ys = x `Cons` xs ++ ys-{-# NOINLINE (++) #-}---- | Split a vector into two vectors at the given point.------ >>> splitAt (SNat :: SNat 3) (1:>2:>3:>7:>8:>Nil)--- (<1,2,3>,<7,8>)--- >>> splitAt d3 (1:>2:>3:>7:>8:>Nil)--- (<1,2,3>,<7,8>)-splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)-splitAt n xs = splitAtU (toUNat n) xs-{-# NOINLINE splitAt #-}--splitAtU :: UNat m -> Vec (m + n) a -> (Vec m a, Vec n a)-splitAtU UZero     ys            = (Nil,ys)-splitAtU (USucc s) (y `Cons` ys) = let (as,bs) = splitAtU s ys-                                   in  (y `Cons` as, bs)---- | Split a vector into two vectors where the length of the two is determined--- by the context.------ >>> splitAtI (1:>2:>3:>7:>8:>Nil) :: (Vec 2 Int, Vec 3 Int)--- (<1,2>,<3,7,8>)-splitAtI :: KnownNat m => Vec (m + n) a -> (Vec m a, Vec n a)-splitAtI = withSNat splitAt-{-# INLINE splitAtI #-}---- | Concatenate a vector of vectors.------ >>> concat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil)--- <1,2,3,4,5,6,7,8,9,10,11,12>-concat :: Vec n (Vec m a) -> Vec (n * m) a-concat Nil           = Nil-concat (x `Cons` xs) = x ++ concat xs-{-# NOINLINE concat #-}---- | Map a function over all the elements of a vector and concatentate the resulting vectors.------ >>> concatMap (replicate d3) (1:>2:>3:>Nil)--- <1,1,1,2,2,2,3,3,3>-concatMap :: (a -> Vec m b) -> Vec n a -> Vec (n * m) b-concatMap f xs = concat (map f xs)-{-# INLINE concatMap #-}---- | Split a vector of \(n * m)\ elements into a vector of \"vectors of length--- /m/\", where the length /m/ is given.------ >>> unconcat d4 (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil)--- <<1,2,3,4>,<5,6,7,8>,<9,10,11,12>>-unconcat :: KnownNat n => SNat m -> Vec (n * m) a -> Vec n (Vec m a)-unconcat n xs = unconcatU (withSNat toUNat) (toUNat n) xs-{-# NOINLINE unconcat #-}--unconcatU :: UNat n -> UNat m -> Vec (n * m) a -> Vec n (Vec m a)-unconcatU UZero      _ _  = Nil-unconcatU (USucc n') m ys = let (as,bs) = splitAtU m ys-                            in  as `Cons` unconcatU n' m bs---- | Split a vector of /(n * m)/ elements into a vector of \"vectors of length--- /m/\", where the length /m/ is determined by the context.------ >>> unconcatI (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil) :: Vec 2 (Vec 6 Int)--- <<1,2,3,4,5,6>,<7,8,9,10,11,12>>-unconcatI :: (KnownNat n, KnownNat m) => Vec (n * m) a -> Vec n (Vec m a)-unconcatI = withSNat unconcat-{-# INLINE unconcatI #-}---- | Merge two vectors, alternating their elements, i.e.,------ >>> merge (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> 7 :> 8 :> Nil)--- <1,5,2,6,3,7,4,8>-merge :: KnownNat n => Vec n a -> Vec n a -> Vec (2 * n) a-merge x y = concat (transpose (x :> singleton y))-{-# INLINE merge #-}---- | The elements in a vector in reverse order.------ >>> reverse (1:>2:>3:>4:>Nil)--- <4,3,2,1>-reverse :: Vec n a -> Vec n a-reverse Nil           = Nil-reverse (x `Cons` xs) = reverse xs :< x-{-# NOINLINE reverse #-}---- | \"'map' @f xs@\" is the vector obtained by applying /f/ to each element--- of /xs/, i.e.,------ > map f (x1 :> x2 :>  ... :> xn :> Nil) == (f x1 :> f x2 :> ... :> f xn :> Nil)------ and corresponds to the following circuit layout:------ <<doc/map.svg>>-map :: (a -> b) -> Vec n a -> Vec n b-map _ Nil           = Nil-map f (x `Cons` xs) = f x `Cons` map f xs-{-# NOINLINE map #-}---- | Apply a function of every element of a vector and its index.------ >>> :t imap (+) (2 :> 2 :> 2 :> 2 :> Nil)--- imap (+) (2 :> 2 :> 2 :> 2 :> Nil) :: Vec 4 (Index 4)--- >>> imap (+) (2 :> 2 :> 2 :> 2 :> Nil)--- <2,3,*** Exception: X: Clash.Sized.Index: result 4 is out of bounds: [0..3]--- ...--- >>> imap (\i a -> fromIntegral i + a) (2 :> 2 :> 2 :> 2 :> Nil) :: Vec 4 (Unsigned 8)--- <2,3,4,5>------ \"'imap' @f xs@\" corresponds to the following circuit layout:------ <<doc/imap.svg>>-imap :: forall n a b . KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b-imap f = go 0-  where-    go :: Index n -> Vec m a -> Vec m b-    go _ Nil           = Nil-    go n (x `Cons` xs) = f n x `Cons` go (n+1) xs-{-# NOINLINE imap #-}---- | Zip two vectors with a functions that also takes the elements' indices.------ >>> izipWith (\i a b -> i + a + b) (2 :> 2 :> Nil)  (3 :> 3:> Nil)--- <*** Exception: X: Clash.Sized.Index: result 3 is out of bounds: [0..1]--- ...--- >>> izipWith (\i a b -> fromIntegral i + a + b) (2 :> 2 :> Nil) (3 :> 3 :> Nil) :: Vec 2 (Unsigned 8)--- <5,6>------ \"'imap' @f xs@\" corresponds to the following circuit layout:------ <<doc/izipWith.svg>>------ __NB:__ 'izipWith' is /strict/ in its second argument, and /lazy/ in its--- third. This matters when 'izipWith' is used in a recursive setting. See--- 'lazyV' for more information.-izipWith :: KnownNat n => (Index n -> a -> b -> c) -> Vec n a -> Vec n b-         -> Vec n c-izipWith f xs ys = imap (\i -> uncurry (f i)) (zip xs ys)-{-# INLINE izipWith #-}---- | Right fold (function applied to each element and its index)------ >>> let findLeftmost x xs = ifoldr (\i a b -> if a == x then Just i else b) Nothing xs--- >>> findLeftmost 3 (1:>3:>2:>4:>3:>5:>6:>Nil)--- Just 1--- >>> findLeftmost 8 (1:>3:>2:>4:>3:>5:>6:>Nil)--- Nothing------ \"'ifoldr' @f z xs@\" corresponds to the following circuit layout:------ <<doc/ifoldr.svg>>-ifoldr :: KnownNat n => (Index n -> a -> b -> b) -> b -> Vec n a -> b-ifoldr f z xs = head ws-  where-    ws = izipWith f xs ((tail ws)) :< z-{-# INLINE ifoldr #-}---- | Left fold (function applied to each element and its index)------ >>> let findRightmost x xs = ifoldl (\a i b -> if b == x then Just i else a) Nothing xs--- >>> findRightmost 3 (1:>3:>2:>4:>3:>5:>6:>Nil)--- Just 4--- >>> findRightmost 8 (1:>3:>2:>4:>3:>5:>6:>Nil)--- Nothing------ \"'ifoldl' @f z xs@\" corresponds to the following circuit layout:------ <<doc/ifoldl.svg>>-ifoldl :: KnownNat n => (a -> Index n -> b -> a) -> a -> Vec n b -> a-ifoldl f z xs = last ws-  where-    ws = z `Cons` izipWith (\i b a -> f a i b) xs (init ws)-{-# INLINE ifoldl #-}---- | Generate a vector of indices.------ >>> indices d4--- <0,1,2,3>-indices :: KnownNat n => SNat n -> Vec n (Index n)-indices _ = indicesI-{-# INLINE indices #-}---- | Generate a vector of indices, where the length of the vector is determined--- by the context.------ >>> indicesI :: Vec 4 (Index 4)--- <0,1,2,3>-indicesI :: KnownNat n => Vec n (Index n)-indicesI = imap const (repeat ())-{-# INLINE indicesI #-}---- | \"'findIndex' @p xs@\" returns the index of the /first/ element of /xs/--- satisfying the predicate /p/, or 'Nothing' if there is no such element.------ >>> findIndex (> 3) (1:>3:>2:>4:>3:>5:>6:>Nil)--- Just 3--- >>> findIndex (> 8) (1:>3:>2:>4:>3:>5:>6:>Nil)--- Nothing-findIndex :: KnownNat n => (a -> Bool) -> Vec n a -> Maybe (Index n)-findIndex f = ifoldr (\i a b -> if f a then Just i else b) Nothing-{-# INLINE findIndex #-}---- | \"'elemIndex' @a xs@\" returns the index of the /first/ element which is--- equal (by '==') to the query element /a/, or 'Nothing' if there is no such--- element.------ >>> elemIndex 3 (1:>3:>2:>4:>3:>5:>6:>Nil)--- Just 1--- >>> elemIndex 8 (1:>3:>2:>4:>3:>5:>6:>Nil)--- Nothing-elemIndex :: (KnownNat n, Eq a) => a -> Vec n a -> Maybe (Index n)-elemIndex x = findIndex (x ==)-{-# INLINE elemIndex #-}---- | 'zipWith' generalizes 'zip' by zipping with the function given--- as the first argument, instead of a tupling function.--- For example, \"'zipWith' @(+)@\" applied to two vectors produces the--- vector of corresponding sums.------ > zipWith f (x1 :> x2 :> ... xn :> Nil) (y1 :> y2 :> ... :> yn :> Nil) == (f x1 y1 :> f x2 y2 :> ... :> f xn yn :> Nil)------ \"'zipWith' @f xs ys@\" corresponds to the following circuit layout:------ <<doc/zipWith.svg>>------ __NB:__ 'zipWith' is /strict/ in its second argument, and /lazy/ in its--- third. This matters when 'zipWith' is used in a recursive setting. See--- 'lazyV' for more information.-zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c-zipWith _ Nil           _  = Nil-zipWith f (x `Cons` xs) ys = f x (head ys) `Cons` zipWith f xs (tail ys)-{-# NOINLINE zipWith #-}---- | 'zipWith3' generalizes 'zip3' by zipping with the function given--- as the first argument, instead of a tupling function.------ > zipWith3 f (x1 :> x2 :> ... xn :> Nil) (y1 :> y2 :> ... :> yn :> Nil) (z1 :> z2 :> ... :> zn :> Nil) == (f x1 y1 z1 :> f x2 y2 z2 :> ... :> f xn yn zn :> Nil)------ \"'zipWith3' @f xs ys zs@\" corresponds to the following circuit layout:------ <<doc/zipWith3.svg>>------ __NB:__ 'zipWith3' is /strict/ in its second argument, and /lazy/ in its--- third and fourth. This matters when 'zipWith3' is used in a recursive setting.--- See 'lazyV' for more information.-zipWith3 :: (a -> b -> c -> d) -> Vec n a -> Vec n b -> Vec n c -> Vec n d-zipWith3 f us vs ws = zipWith (\a (b,c) -> f a b c) us (zip vs ws)-{-# INLINE zipWith3 #-}---- 'zipWith4' is analogous to 'zipWith3', but with four vectors.------ __NB:__ 'zipWith4' is /strict/ in its second argument, and /lazy/ its following--- arguments. This matters when 'zipWith4' is used in a recursive setting. See--- 'lazyV' for more information.-zipWith4-  :: (a -> b -> c -> d -> e)-  -> Vec n a-  -> Vec n b-  -> Vec n c-  -> Vec n d-  -> Vec n e-zipWith4 f us vs ws xs =-  zipWith (\a (b,c,d) -> f a b c d) us (zip3 vs ws xs)-{-# INLINE zipWith4 #-}---- 'zipWith5' is analogous to 'zipWith3', but with five vectors.------ __NB:__ 'zipWith5' is /strict/ in its second argument, and /lazy/ its following--- arguments. This matters when 'zipWith5' is used in a recursive setting. See--- 'lazyV' for more information.-zipWith5-  :: (a -> b -> c -> d -> e -> f)-  -> Vec n a-  -> Vec n b-  -> Vec n c-  -> Vec n d-  -> Vec n e-  -> Vec n f-zipWith5 f us vs ws xs ys =-  zipWith (\a (b,c,d,e) -> f a b c d e) us (zip4 vs ws xs ys)-{-# INLINE zipWith5 #-}---- 'zipWith6' is analogous to 'zipWith3', but with six vectors.------ __NB:__ 'zipWith6' is /strict/ in its second argument, and /lazy/ its following--- arguments. This matters when 'zipWith6' is used in a recursive setting. See--- 'lazyV' for more information.-zipWith6-  :: (a -> b -> c -> d -> e -> f -> g)-  -> Vec n a-  -> Vec n b-  -> Vec n c-  -> Vec n d-  -> Vec n e-  -> Vec n f-  -> Vec n g-zipWith6 f us vs ws xs ys zs =-  zipWith (\u (v,w,x,y,z) -> f u v w x y z) us (zip5 vs ws xs ys zs)-{-# INLINE zipWith6 #-}---- 'zipWith7' is analogous to 'zipWith3', but with seven vectors.------ __NB:__ 'zipWith7' is /strict/ in its second argument, and /lazy/ its following--- arguments. This matters when 'zipWith7' is used in a recursive setting. See--- 'lazyV' for more information.-zipWith7-  :: (a -> b -> c -> d -> e -> f -> g -> h)-  -> Vec n a-  -> Vec n b-  -> Vec n c-  -> Vec n d-  -> Vec n e-  -> Vec n f-  -> Vec n g-  -> Vec n h-zipWith7 f ts us vs ws xs ys zs =-  zipWith (\t (u,v,w,x,y,z) -> f t u v w x y z) ts (zip6 us vs ws xs ys zs)-{-# INLINE zipWith7 #-}---- | 'foldr', applied to a binary operator, a starting value (typically--- the right-identity of the operator), and a vector, reduces the vector--- using the binary operator, from right to left:------ > foldr f z (x1 :> ... :> xn1 :> xn :> Nil) == x1 `f` (... (xn1 `f` (xn `f` z))...)--- > foldr r z Nil                             == z------ >>> foldr (/) 1 (5 :> 4 :> 3 :> 2 :> Nil)--- 1.875------ \"'foldr' @f z xs@\" corresponds to the following circuit layout:------ <<doc/foldr.svg>>------ __NB__: @"'foldr' f z xs"@ produces a linear structure, which has a depth, or--- delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is--- associative, as @"'fold' f xs"@ produces a structure with a depth of--- O(log_2(@'length' xs@)).-foldr :: (a -> b -> b) -> b -> Vec n a -> b-foldr _ z Nil           = z-foldr f z (x `Cons` xs) = f x (foldr f z xs)-{-# NOINLINE foldr #-}---- | 'foldl', applied to a binary operator, a starting value (typically--- the left-identity of the operator), and a vector, reduces the vector--- using the binary operator, from left to right:------ > foldl f z (x1 :> x2 :> ... :> xn :> Nil) == (...((z `f` x1) `f` x2) `f`...) `f` xn--- > foldl f z Nil                            == z------ >>> foldl (/) 1 (5 :> 4 :> 3 :> 2 :> Nil)--- 8.333333333333333e-3------ \"'foldl' @f z xs@\" corresponds to the following circuit layout:------ <<doc/foldl.svg>>------ __NB__: @"'foldl' f z xs"@ produces a linear structure, which has a depth, or--- delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is--- associative, as @"'fold' f xs"@ produces a structure with a depth of--- O(log_2(@'length' xs@)).-foldl :: (b -> a -> b) -> b -> Vec n a -> b-foldl f z xs = last (scanl f z xs)-{-# INLINE foldl #-}---- | 'foldr1' is a variant of 'foldr' that has no starting value argument,--- and thus must be applied to non-empty vectors.------ > foldr1 f (x1 :> ... :> xn2 :> xn1 :> xn :> Nil) == x1 `f` (... (xn2 `f` (xn1 `f` xn))...)--- > foldr1 f (x1 :> Nil)                            == x1--- > foldr1 f Nil                                    == TYPE ERROR------ >>> foldr1 (/) (5 :> 4 :> 3 :> 2 :> 1 :> Nil)--- 1.875------ \"'foldr1' @f xs@\" corresponds to the following circuit layout:------ <<doc/foldr1.svg>>------ __NB__: @"'foldr1' f z xs"@ produces a linear structure, which has a depth,--- or delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is--- associative, as @"'fold' f xs"@ produces a structure with a depth of--- O(log_2(@'length' xs@)).-foldr1 :: (a -> a -> a) -> Vec (n + 1) a -> a-foldr1 f xs = foldr f (last xs) (init xs)-{-# INLINE foldr1 #-}---- | 'foldl1' is a variant of 'foldl' that has no starting value argument,--- and thus must be applied to non-empty vectors.------ > foldl1 f (x1 :> x2 :> x3 :> ... :> xn :> Nil) == (...((x1 `f` x2) `f` x3) `f`...) `f` xn--- > foldl1 f (x1 :> Nil)                          == x1--- > foldl1 f Nil                                  == TYPE ERROR------ >>> foldl1 (/) (1 :> 5 :> 4 :> 3 :> 2 :> Nil)--- 8.333333333333333e-3------ \"'foldl1' @f xs@\" corresponds to the following circuit layout:------ <<doc/foldl1.svg>>------ __NB__: @"'foldl1' f z xs"@ produces a linear structure, which has a depth,--- or delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is--- associative, as @"'fold' f xs"@ produces a structure with a depth of--- O(log_2(@'length' xs@)).-foldl1 :: (a -> a -> a) -> Vec (n + 1) a -> a-foldl1 f xs = foldl f (head xs) (tail xs)-{-# INLINE foldl1 #-}---- | 'fold' is a variant of 'foldr1' and 'foldl1', but instead of reducing from--- right to left, or left to right, it reduces a vector using a tree-like--- structure. The depth, or delay, of the structure produced by--- \"@'fold' f xs@\", is hence @O(log_2('length' xs))@, and not--- @O('length' xs)@.------ __NB__: The binary operator \"@f@\" in \"@'fold' f xs@\" must be associative.------ > fold f (x1 :> x2 :> ... :> xn1 :> xn :> Nil) == ((x1 `f` x2) `f` ...) `f` (... `f` (xn1 `f` xn))--- > fold f (x1 :> Nil)                           == x1--- > fold f Nil                                   == TYPE ERROR------ >>> fold (+) (5 :> 4 :> 3 :> 2 :> 1 :> Nil)--- 15------ \"'fold' @f xs@\" corresponds to the following circuit layout:------ <<doc/fold.svg>>-fold :: (a -> a -> a) -> Vec (n + 1) a -> a-fold f vs = fold' (toList vs)-  where-    fold' [x] = x-    fold' xs  = fold' ys `f` fold' zs-      where-        (ys,zs) = P.splitAt (P.length xs `div` 2) xs-{-# NOINLINE fold #-}---- | 'scanl' is similar to 'foldl', but returns a vector of successive reduced--- values from the left:------ > scanl f z (x1 :> x2 :> ... :> Nil) == z :> (z `f` x1) :> ((z `f` x1) `f` x2) :> ... :> Nil------ >>> scanl (+) 0 (5 :> 4 :> 3 :> 2 :> Nil)--- <0,5,9,12,14>------ \"'scanl' @f z xs@\" corresponds to the following circuit layout:------ <<doc/scanl.svg>>------ __NB__:------ > last (scanl f z xs) == foldl f z xs-scanl :: (b -> a -> b) -> b -> Vec n a -> Vec (n + 1) b-scanl f z xs = ws-  where-    ws = z `Cons` zipWith (flip f) xs (init ws)-{-# INLINE scanl #-}---- | 'postscanl' is a variant of 'scanl' where the first result is dropped:------ > postscanl f z (x1 :> x2 :> ... :> Nil) == (z `f` x1) :> ((z `f` x1) `f` x2) :> ... :> Nil------ >>> postscanl (+) 0 (5 :> 4 :> 3 :> 2 :> Nil)--- <5,9,12,14>------ \"'postscanl' @f z xs@\" corresponds to the following circuit layout:------ <<doc/sscanl.svg>>-postscanl :: (b -> a -> b) -> b -> Vec n a -> Vec n b-postscanl f z xs = tail (scanl f z xs)-{-# INLINE postscanl #-}---- | 'scanr' is similar to 'foldr', but returns a vector of successive reduced--- values from the right:------ > scanr f z (... :> xn1 :> xn :> Nil) == ... :> (xn1 `f` (xn `f` z)) :> (xn `f` z) :> z :> Nil------ >>> scanr (+) 0 (5 :> 4 :> 3 :> 2 :> Nil)--- <14,9,5,2,0>------ \"'scanr' @f z xs@\" corresponds to the following circuit layout:------ <<doc/scanr.svg>>------ __NB__:------ > head (scanr f z xs) == foldr f z xs-scanr :: (a -> b -> b) -> b -> Vec n a -> Vec (n + 1) b-scanr f z xs = ws-  where-    ws = zipWith f xs ((tail ws)) :< z-{-# INLINE scanr #-}---- | 'postscanr' is a variant of 'scanr' that where the last result is dropped:------ > postscanr f z (... :> xn1 :> xn :> Nil) == ... :> (xn1 `f` (xn `f` z)) :> (xn `f` z) :> Nil------ >>> postscanr (+) 0 (5 :> 4 :> 3 :> 2 :> Nil)--- <14,9,5,2>------ \"'postscanr' @f z xs@\" corresponds to the following circuit layout:------ <<doc/sscanr.svg>>-postscanr :: (a -> b -> b) -> b -> Vec n a -> Vec n b-postscanr f z xs = init (scanr f z xs)-{-# INLINE postscanr #-}---- | The 'mapAccumL' function behaves like a combination of 'map' and 'foldl';--- it applies a function to each element of a vector, passing an accumulating--- parameter from left to right, and returning a final value of this accumulator--- together with the new vector.------ >>> mapAccumL (\acc x -> (acc + x,acc + 1)) 0 (1 :> 2 :> 3 :> 4 :> Nil)--- (10,<1,2,4,7>)------ \"'mapAccumL' @f acc xs@\" corresponds to the following circuit layout:------ <<doc/mapAccumL.svg>>-mapAccumL :: (acc -> x -> (acc,y)) -> acc -> Vec n x -> (acc,Vec n y)-mapAccumL f acc xs = (acc',ys)-  where-    accs  = acc `Cons` accs'-    ws    = zipWith (flip f) xs (init accs)-    accs' = map fst ws-    ys    = map snd ws-    acc'  = last accs-{-# INLINE mapAccumL #-}---- | The 'mapAccumR' function behaves like a combination of 'map' and 'foldr';--- it applies a function to each element of a vector, passing an accumulating--- parameter from right to left, and returning a final value of this accumulator--- together with the new vector.------ >>> mapAccumR (\acc x -> (acc + x,acc + 1)) 0 (1 :> 2 :> 3 :> 4 :> Nil)--- (10,<10,8,5,1>)------ \"'mapAccumR' @f acc xs@\" corresponds to the following circuit layout:------ <<doc/mapAccumR.svg>>-mapAccumR :: (acc -> x -> (acc,y)) -> acc -> Vec n x -> (acc, Vec n y)-mapAccumR f acc xs = (acc',ys)-  where-    accs  = accs' :< acc-    ws    = zipWith (flip f) xs (tail accs)-    accs' = map fst ws-    ys    = map snd ws-    acc'  = head accs-{-# INLINE mapAccumR #-}---- | 'zip' takes two vectors and returns a vector of corresponding pairs.------ >>> zip (1:>2:>3:>4:>Nil) (4:>3:>2:>1:>Nil)--- <(1,4),(2,3),(3,2),(4,1)>-zip :: Vec n a -> Vec n b -> Vec n (a,b)-zip = zipWith (,)-{-# INLINE zip #-}---- | 'zip3' takes three vectors and returns a vector of corresponding triplets.------ >>> zip3 (1:>2:>3:>4:>Nil) (4:>3:>2:>1:>Nil) (5:>6:>7:>8:>Nil)--- <(1,4,5),(2,3,6),(3,2,7),(4,1,8)>-zip3 :: Vec n a -> Vec n b -> Vec n c -> Vec n (a,b,c)-zip3 = zipWith3 (,,)-{-# INLINE zip3 #-}---- | 'zip4' takes four vectors and returns a list of quadruples, analogous--- to 'zip'.-zip4 :: Vec n a -> Vec n b -> Vec n c -> Vec n d -> Vec n (a,b,c,d)-zip4 = zipWith4 (,,,)-{-# INLINE zip4 #-}---- | 'zip5' takes five vectors and returns a list of five-tuples, analogous--- to 'zip'.-zip5 :: Vec n a -> Vec n b -> Vec n c -> Vec n d -> Vec n e -> Vec n (a,b,c,d,e)-zip5 = zipWith5 (,,,,)-{-# INLINE zip5 #-}---- | 'zip6' takes six vectors and returns a list of six-tuples, analogous--- to 'zip'.-zip6-  :: Vec n a-  -> Vec n b-  -> Vec n c-  -> Vec n d-  -> Vec n e-  -> Vec n f-  -> Vec n (a,b,c,d,e,f)-zip6 = zipWith6 (,,,,,)-{-# INLINE zip6 #-}---- | 'zip7' takes seven vectors and returns a list of seven-tuples, analogous--- to 'zip'.-zip7-  :: Vec n a-  -> Vec n b-  -> Vec n c-  -> Vec n d-  -> Vec n e-  -> Vec n f-  -> Vec n g-  -> Vec n (a,b,c,d,e,f,g)-zip7 = zipWith7 (,,,,,,)-{-# INLINE zip7 #-}---- | 'unzip' transforms a vector of pairs into a vector of first components--- and a vector of second components.------ >>> unzip ((1,4):>(2,3):>(3,2):>(4,1):>Nil)--- (<1,2,3,4>,<4,3,2,1>)-unzip :: Vec n (a,b) -> (Vec n a, Vec n b)-unzip xs = (map fst xs, map snd xs)-{-# INLINE unzip #-}---- | 'unzip3' transforms a vector of triplets into a vector of first components,--- a vector of second components, and a vector of third components.------ >>> unzip3 ((1,4,5):>(2,3,6):>(3,2,7):>(4,1,8):>Nil)--- (<1,2,3,4>,<4,3,2,1>,<5,6,7,8>)-unzip3 :: Vec n (a,b,c) -> (Vec n a, Vec n b, Vec n c)-unzip3 xs = ( map (\(x,_,_) -> x) xs-            , map (\(_,y,_) -> y) xs-            , map (\(_,_,z) -> z) xs-            )-{-# INLINE unzip3 #-}---- | 'unzip4' takes a vector of quadruples and returns four vectors, analogous--- to 'unzip'.-unzip4 :: Vec n (a,b,c,d) -> (Vec n a, Vec n b, Vec n c, Vec n d)-unzip4 xs = ( map (\(w,_,_,_) -> w) xs-            , map (\(_,x,_,_) -> x) xs-            , map (\(_,_,y,_) -> y) xs-            , map (\(_,_,_,z) -> z) xs-            )-{-# INLINE unzip4 #-}---- | 'unzip5' takes a vector of five-tuples and returns five vectors, analogous--- to 'unzip'.-unzip5 :: Vec n (a,b,c,d,e) -> (Vec n a, Vec n b, Vec n c, Vec n d, Vec n e)-unzip5 xs = ( map (\(v,_,_,_,_) -> v) xs-            , map (\(_,w,_,_,_) -> w) xs-            , map (\(_,_,x,_,_) -> x) xs-            , map (\(_,_,_,y,_) -> y) xs-            , map (\(_,_,_,_,z) -> z) xs-            )-{-# INLINE unzip5 #-}---- | 'unzip6' takes a vector of six-tuples and returns six vectors, analogous--- to 'unzip'.-unzip6-  :: Vec n (a,b,c,d,e,f)-  -> (Vec n a, Vec n b, Vec n c, Vec n d, Vec n e, Vec n f)-unzip6 xs = ( map (\(u,_,_,_,_,_) -> u) xs-            , map (\(_,v,_,_,_,_) -> v) xs-            , map (\(_,_,w,_,_,_) -> w) xs-            , map (\(_,_,_,x,_,_) -> x) xs-            , map (\(_,_,_,_,y,_) -> y) xs-            , map (\(_,_,_,_,_,z) -> z) xs-            )-{-# INLINE unzip6 #-}---- | 'unzip7' takes a vector of seven-tuples and returns seven vectors, analogous--- to 'unzip'.-unzip7-  :: Vec n (a,b,c,d,e,f,g)-  -> (Vec n a, Vec n b, Vec n c, Vec n d, Vec n e, Vec n f, Vec n g)-unzip7 xs = ( map (\(t,_,_,_,_,_,_) -> t) xs-            , map (\(_,u,_,_,_,_,_) -> u) xs-            , map (\(_,_,v,_,_,_,_) -> v) xs-            , map (\(_,_,_,w,_,_,_) -> w) xs-            , map (\(_,_,_,_,x,_,_) -> x) xs-            , map (\(_,_,_,_,_,y,_) -> y) xs-            , map (\(_,_,_,_,_,_,z) -> z) xs-            )-{-# INLINE unzip7 #-}---index_int :: KnownNat n => Vec n a -> Int -> a-index_int xs i@(I# n0)-  | isTrue# (n0 <# 0#) = error "Clash.Sized.Vector.(!!): negative index"-  | otherwise          = sub xs n0-  where-    sub :: Vec m a -> Int# -> a-    sub Nil     _ = error (P.concat [ "Clash.Sized.Vector.(!!): index "-                                    , show i-                                    , " is larger than maximum index "-                                    , show ((length xs)-1)-                                    ])-    sub (y `Cons` (!ys)) n = if isTrue# (n ==# 0#)-                                then y-                                else sub ys (n -# 1#)-{-# NOINLINE index_int #-}---- | \"@xs@ '!!' @n@\" returns the /n/'th element of /xs/.------ __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and--- ending at @'length' - 1@.------ >>> (1:>2:>3:>4:>5:>Nil) !! 4--- 5--- >>> (1:>2:>3:>4:>5:>Nil) !! (length (1:>2:>3:>4:>5:>Nil) - 1)--- 5--- >>> (1:>2:>3:>4:>5:>Nil) !! 1--- 2--- >>> (1:>2:>3:>4:>5:>Nil) !! 14--- *** Exception: Clash.Sized.Vector.(!!): index 14 is larger than maximum index 4--- ...-(!!) :: (KnownNat n, Enum i) => Vec n a -> i -> a-xs !! i = index_int xs (fromEnum i)-{-# INLINE (!!) #-}---- | The length of a 'Vec'tor as an 'Int' value.------ >>> length (6 :> 7 :> 8 :> Nil)--- 3-length :: KnownNat n => Vec n a -> Int-length = fromInteger . natVal . asNatProxy-{-# NOINLINE length #-}--replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a-replace_int xs i@(I# n0) a-  | isTrue# (n0 <# 0#) = error "Clash.Sized.Vector.replace: negative index"-  | otherwise          = sub xs n0 a-  where-    sub :: Vec m b -> Int# -> b -> Vec m b-    sub Nil     _ _ = error (P.concat [ "Clash.Sized.Vector.replace: index "-                                      , show i-                                      , " is larger than maximum index "-                                      , show (length xs - 1)-                                      ])-    sub (y `Cons` (!ys)) n b = if isTrue# (n ==# 0#)-                                 then b `Cons` ys-                                 else y `Cons` sub ys (n -# 1#) b-{-# NOINLINE replace_int #-}---- | \"'replace' @n a xs@\" returns the vector /xs/ where the /n/'th element is--- replaced by /a/.------ __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and--- ending at @'length' - 1@.------ >>> replace 3 7 (1:>2:>3:>4:>5:>Nil)--- <1,2,3,7,5>--- >>> replace 0 7 (1:>2:>3:>4:>5:>Nil)--- <7,2,3,4,5>--- >>> replace 9 7 (1:>2:>3:>4:>5:>Nil)--- <1,2,3,4,*** Exception: Clash.Sized.Vector.replace: index 9 is larger than maximum index 4--- ...-replace :: (KnownNat n, Enum i) => i -> a -> Vec n a -> Vec n a-replace i y xs = replace_int xs (fromEnum i) y-{-# INLINE replace #-}---- | \"'take' @n xs@\" returns the /n/-length prefix of /xs/.------ >>> take (SNat :: SNat 3) (1:>2:>3:>4:>5:>Nil)--- <1,2,3>--- >>> take d3               (1:>2:>3:>4:>5:>Nil)--- <1,2,3>--- >>> take d0               (1:>2:>Nil)--- <>--- >>> take d4               (1:>2:>Nil)--- <BLANKLINE>--- <interactive>:...---     • Couldn't match type ‘4 + n0’ with ‘2’---       Expected type: Vec (4 + n0) a---         Actual type: Vec (1 + 1) a---       The type variable ‘n0’ is ambiguous---     • In the second argument of ‘take’, namely ‘(1 :> 2 :> Nil)’---       In the expression: take d4 (1 :> 2 :> Nil)---       In an equation for ‘it’: it = take d4 (1 :> 2 :> Nil)-take :: SNat m -> Vec (m + n) a -> Vec m a-take n = fst . splitAt n-{-# INLINE take #-}---- | \"'takeI' @xs@\" returns the prefix of /xs/ as demanded by the context.------ >>> takeI (1:>2:>3:>4:>5:>Nil) :: Vec 2 Int--- <1,2>-takeI :: KnownNat m => Vec (m + n) a -> Vec m a-takeI = withSNat take-{-# INLINE takeI #-}---- | \"'drop' @n xs@\" returns the suffix of /xs/ after the first /n/ elements.------ >>> drop (SNat :: SNat 3) (1:>2:>3:>4:>5:>Nil)--- <4,5>--- >>> drop d3               (1:>2:>3:>4:>5:>Nil)--- <4,5>--- >>> drop d0               (1:>2:>Nil)--- <1,2>--- >>> drop d4               (1:>2:>Nil)--- <BLANKLINE>--- <interactive>:...: error:---     • Couldn't match...type ‘4 + n0...---       The type variable ‘n0’ is ambiguous---     • In the first argument of ‘print’, namely ‘it’---       In a stmt of an interactive GHCi command: print it-drop :: SNat m -> Vec (m + n) a -> Vec n a-drop n = snd . splitAt n-{-# INLINE drop #-}---- | \"'dropI' @xs@\" returns the suffix of /xs/ as demanded by the context.------ >>> dropI (1:>2:>3:>4:>5:>Nil) :: Vec 2 Int--- <4,5>-dropI :: KnownNat m => Vec (m + n) a -> Vec n a-dropI = withSNat drop-{-# INLINE dropI #-}---- | \"'at' @n xs@\" returns /n/'th element of /xs/------ __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and--- ending at @'length' - 1@.------ >>> at (SNat :: SNat 1) (1:>2:>3:>4:>5:>Nil)--- 2--- >>> at d1               (1:>2:>3:>4:>5:>Nil)--- 2-at :: SNat m -> Vec (m + (n + 1)) a -> a-at n xs = head $ snd $ splitAt n xs-{-# INLINE at #-}---- | \"'select' @f s n xs@\" selects /n/ elements with step-size /s/ and--- offset @f@ from /xs/.------ >>> select (SNat :: SNat 1) (SNat :: SNat 2) (SNat :: SNat 3) (1:>2:>3:>4:>5:>6:>7:>8:>Nil)--- <2,4,6>--- >>> select d1 d2 d3 (1:>2:>3:>4:>5:>6:>7:>8:>Nil)--- <2,4,6>-select :: (CmpNat (i + s) (s * n) ~ 'GT)-       => SNat f-       -> SNat s-       -> SNat n-       -> Vec (f + i) a-       -> Vec n a-select f s n xs = select' (toUNat n) $ drop f xs-  where-    select' :: UNat n -> Vec i a -> Vec n a-    select' UZero      _               = Nil-    select' (USucc n') vs@(x `Cons` _) = x `Cons`-                                         select' n' (drop s (unsafeCoerce vs))-{-# NOINLINE select #-}---- | \"'selectI' @f s xs@\" selects as many elements as demanded by the context--- with step-size /s/ and offset /f/ from /xs/.------ >>> selectI d1 d2 (1:>2:>3:>4:>5:>6:>7:>8:>Nil) :: Vec 2 Int--- <2,4>-selectI :: (CmpNat (i + s) (s * n) ~ 'GT, KnownNat n)-        => SNat f-        -> SNat s-        -> Vec (f + i) a-        -> Vec n a-selectI f s xs = withSNat (\n -> select f s n xs)-{-# INLINE selectI #-}---- | \"'replicate' @n a@\" returns a vector that has /n/ copies of /a/.------ >>> replicate (SNat :: SNat 3) 6--- <6,6,6>--- >>> replicate d3 6--- <6,6,6>-replicate :: SNat n -> a -> Vec n a-replicate n a = replicateU (toUNat n) a-{-# NOINLINE replicate #-}--replicateU :: UNat n -> a -> Vec n a-replicateU UZero     _ = Nil-replicateU (USucc s) x = x `Cons` replicateU s x---- | \"'repeat' @a@\" creates a vector with as many copies of /a/ as demanded--- by the context.------ >>> repeat 6 :: Vec 5 Int--- <6,6,6,6,6>-repeat :: KnownNat n => a -> Vec n a-repeat = withSNat replicate-{-# INLINE repeat #-}---- | \"'iterate' @n f x@\" returns a vector starting with /x/ followed by--- /n/ repeated applications of /f/ to /x/.------ > iterate (SNat :: SNat 4) f x == (x :> f x :> f (f x) :> f (f (f x)) :> Nil)--- > iterate d4 f x               == (x :> f x :> f (f x) :> f (f (f x)) :> Nil)------ >>> iterate d4 (+1) 1--- <1,2,3,4>------ \"'iterate' @n f z@\" corresponds to the following circuit layout:------ <<doc/iterate.svg>>-iterate :: SNat n -> (a -> a) -> a -> Vec n a-iterate SNat = iterateI-{-# INLINE iterate #-}---- | \"'iterate' @f x@\" returns a vector starting with @x@ followed by @n@--- repeated applications of @f@ to @x@, where @n@ is determined by the context.------ > iterateI f x :: Vec 3 a == (x :> f x :> f (f x) :> Nil)------ >>> iterateI (+1) 1 :: Vec 3 Int--- <1,2,3>------ \"'iterateI' @f z@\" corresponds to the following circuit layout:------ <<doc/iterate.svg>>-iterateI :: KnownNat n => (a -> a) -> a -> Vec n a-iterateI f a = xs-  where-    xs = init (a `Cons` ws)-    ws = map f (lazyV xs)-{-# INLINE iterateI #-}---- | \"'generate' @n f x@\" returns a vector with @n@ repeated applications of--- @f@ to @x@.------ > generate (SNat :: SNat 4) f x == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil)--- > generate d4 f x               == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil)------ >>> generate d4 (+1) 1--- <2,3,4,5>------ \"'generate' @n f z@\" corresponds to the following circuit layout:------ <<doc/generate.svg>>-generate :: SNat n -> (a -> a) -> a -> Vec n a-generate SNat f a = iterateI f (f a)-{-# INLINE generate #-}---- | \"'generateI' @f x@\" returns a vector with @n@ repeated applications of--- @f@ to @x@, where @n@ is determined by the context.------ > generateI f x :: Vec 3 a == (f x :> f (f x) :> f (f (f x)) :> Nil)------ >>> generateI (+1) 1 :: Vec 3 Int--- <2,3,4>------ \"'generateI' @f z@\" corresponds to the following circuit layout:------ <<doc/generate.svg>>-generateI :: KnownNat n => (a -> a) -> a -> Vec n a-generateI f a = iterateI f (f a)-{-# INLINE generateI #-}---- | Transpose a matrix: go from row-major to column-major------ >>> let xss = (1:>2:>Nil):>(3:>4:>Nil):>(5:>6:>Nil):>Nil--- >>> xss--- <<1,2>,<3,4>,<5,6>>--- >>> transpose xss--- <<1,3,5>,<2,4,6>>-transpose :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)-transpose = traverse# id-{-# NOINLINE transpose #-}---- | 1-dimensional stencil computations------ \"'stencil1d' @stX f xs@\", where /xs/ has /stX + n/ elements, applies the--- stencil computation /f/ on: /n + 1/ overlapping (1D) windows of length /stX/,--- drawn from /xs/. The resulting vector has /n + 1/ elements.------ >>> let xs = (1:>2:>3:>4:>5:>6:>Nil)--- >>> :t xs--- xs :: Num a => Vec 6 a--- >>> :t stencil1d d2 sum xs--- stencil1d d2 sum xs :: Num b => Vec 5 b--- >>> stencil1d d2 sum xs--- <3,5,7,9,11>-stencil1d :: KnownNat n-          => SNat (stX + 1) -- ^ Windows length /stX/, at least size 1-          -> (Vec (stX + 1) a -> b) -- ^ The stencil (function)-          -> Vec ((stX + n) + 1) a-          -> Vec (n + 1) b-stencil1d stX f xs = map f (windows1d stX xs)-{-# INLINE stencil1d #-}---- | 2-dimensional stencil computations------ \"'stencil2d' @stY stX f xss@\", where /xss/ is a matrix of /stY + m/ rows--- of /stX + n/ elements, applies the stencil computation /f/ on:--- /(m + 1) * (n + 1)/ overlapping (2D) windows of /stY/ rows of /stX/ elements,--- drawn from /xss/. The result matrix has /m + 1/ rows of /n + 1/ elements.------ >>> let xss = ((1:>2:>3:>4:>Nil):>(5:>6:>7:>8:>Nil):>(9:>10:>11:>12:>Nil):>(13:>14:>15:>16:>Nil):>Nil)--- >>> :t xss--- xss :: Num a => Vec 4 (Vec 4 a)--- >>> :t stencil2d d2 d2 (sum . map sum) xss--- stencil2d d2 d2 (sum . map sum) xss :: Num b => Vec 3 (Vec 3 b)--- >>> stencil2d d2 d2 (sum . map sum) xss--- <<14,18,22>,<30,34,38>,<46,50,54>>-stencil2d :: (KnownNat n, KnownNat m)-          => SNat (stY + 1) -- ^ Window hight /stY/, at least size 1-          -> SNat (stX + 1) -- ^ Window width /stX/, at least size 1-          -> (Vec (stY + 1) (Vec (stX + 1) a) -> b) -- ^ The stencil (function)-          -> Vec ((stY + m) + 1) (Vec ((stX + n) + 1) a)-          -> Vec (m + 1) (Vec (n + 1) b)-stencil2d stY stX f xss = (map.map) f (windows2d stY stX xss)-{-# INLINE stencil2d #-}---- | \"'windows1d' @stX xs@\", where the vector /xs/ has /stX + n/ elements,--- returns a vector of /n + 1/ overlapping (1D) windows of /xs/ of length /stX/.------ >>> let xs = (1:>2:>3:>4:>5:>6:>Nil)--- >>> :t xs--- xs :: Num a => Vec 6 a--- >>> :t windows1d d2 xs--- windows1d d2 xs :: Num a => Vec 5 (Vec 2 a)--- >>> windows1d d2 xs--- <<1,2>,<2,3>,<3,4>,<4,5>,<5,6>>-windows1d :: KnownNat n-          => SNat (stX + 1) -- ^ Length of the window, at least size 1-          -> Vec ((stX + n) + 1) a-          -> Vec (n + 1) (Vec (stX + 1) a)-windows1d stX xs = map (take stX) (rotations xs)-  where-    rotateL ys   = tail ys :< head ys-    rotations ys = iterateI rotateL ys-{-# INLINE windows1d #-}---- | \"'windows2d' @stY stX xss@\", where matrix /xss/ has /stY + m/ rows of--- /stX + n/, returns a matrix of /m+1/ rows of /n+1/ elements. The elements--- of this new matrix are the overlapping (2D) windows of /xss/, where every--- window has /stY/ rows of /stX/ elements.------ >>> let xss = ((1:>2:>3:>4:>Nil):>(5:>6:>7:>8:>Nil):>(9:>10:>11:>12:>Nil):>(13:>14:>15:>16:>Nil):>Nil)--- >>> :t xss--- xss :: Num a => Vec 4 (Vec 4 a)--- >>> :t windows2d d2 d2 xss--- windows2d d2 d2 xss :: Num a => Vec 3 (Vec 3 (Vec 2 (Vec 2 a)))--- >>> windows2d d2 d2 xss--- <<<<1,2>,<5,6>>,<<2,3>,<6,7>>,<<3,4>,<7,8>>>,<<<5,6>,<9,10>>,<<6,7>,<10,11>>,<<7,8>,<11,12>>>,<<<9,10>,<13,14>>,<<10,11>,<14,15>>,<<11,12>,<15,16>>>>-windows2d :: (KnownNat n,KnownNat m)-          => SNat (stY + 1) -- ^ Window hight /stY/, at least size 1-          -> SNat (stX + 1) -- ^ Window width /stX/, at least size 1-          -> Vec ((stY + m) + 1) (Vec (stX + n + 1) a)-          -> Vec (m + 1) (Vec (n + 1) (Vec (stY + 1) (Vec (stX + 1) a)))-windows2d stY stX xss = map (transpose . (map (windows1d stX))) (windows1d stY xss)-{-# INLINE windows2d #-}---- | Forward permutation specified by an index mapping, /ix/. The result vector--- is initialized by the given defaults, /def/, and an further values that are--- permuted into the result are added to the current value using the given--- combination function, /f/.------ The combination function must be /associative/ and /commutative/.-permute :: (Enum i, KnownNat n, KnownNat m)-        => (a -> a -> a)  -- ^ Combination function, /f/-        -> Vec n a        -- ^ Default values, /def/-        -> Vec m i        -- ^ Index mapping, /is/-        -> Vec (m + k) a  -- ^ Vector to be permuted, /xs/-        -> Vec n a-permute f defs is xs = ys-  where-    ixs = zip is (takeI xs)-    ys  = foldl (\ks (i,x) -> let ki = ks!!i in replace i (f x ki) ks) defs ixs-{-# INLINE permute #-}---- | Backwards permutation specified by an index mapping, /is/, from the--- destination vector specifying which element of the source vector /xs/ to--- read.------ \"'backpermute' @xs is@\" is equivalent to \"'map' @(xs '!!') is@\".------ For example:------ >>> let input = 1:>9:>6:>4:>4:>2:>0:>1:>2:>Nil--- >>> let from  = 1:>3:>7:>2:>5:>3:>Nil--- >>> backpermute input from--- <9,4,1,6,2,4>-backpermute :: (Enum i, KnownNat n)-            => Vec n a  -- ^ Source vector, /xs/-            -> Vec m i  -- ^ Index mapping, /is/-            -> Vec m a-backpermute xs = map (xs!!)-{-# INLINE backpermute #-}---- | Copy elements from the source vector, /xs/, to the destination vector--- according to an index mapping /is/. This is a forward permute operation where--- a /to/ vector encodes an input to output index mapping. Output elements for--- indices that are not mapped assume the value in the default vector /def/.------ For example:------ >>> let defVec = 0:>0:>0:>0:>0:>0:>0:>0:>0:>Nil--- >>> let to = 1:>3:>7:>2:>5:>8:>Nil--- >>> let input = 1:>9:>6:>4:>4:>2:>5:>Nil--- >>> scatter defVec to input--- <0,1,4,9,0,4,0,6,2>------ __NB__: If the same index appears in the index mapping more than once, the--- latest mapping is chosen.-scatter :: (Enum i, KnownNat n, KnownNat m)-        => Vec n a       -- ^ Default values, /def/-        -> Vec m i       -- ^ Index mapping, /is/-        -> Vec (m + k) a -- ^ Vector to be scattered, /xs/-        -> Vec n a-scatter = permute const-{-# INLINE scatter #-}---- | Backwards permutation specified by an index mapping, /is/, from the--- destination vector specifying which element of the source vector /xs/ to--- read.------ \"'gather' @xs is@\" is equivalent to \"'map' @(xs '!!') is@\".------ For example:------ >>> let input = 1:>9:>6:>4:>4:>2:>0:>1:>2:>Nil--- >>> let from  = 1:>3:>7:>2:>5:>3:>Nil--- >>> gather input from--- <9,4,1,6,2,4>-gather :: (Enum i, KnownNat n)-       => Vec n a  -- ^ Source vector, /xs/-       -> Vec m i  -- ^ Index mapping, /is/-       -> Vec m a-gather xs = map (xs!!)-{-# INLINE gather #-}---- | \"'interleave' @d xs@\" creates a vector:------ @--- \<x_0,x_d,x_(2d),...,x_1,x_(d+1),x_(2d+1),...,x_(d-1),x_(2d-1),x_(3d-1)\>--- @------ >>> let xs = 1 :> 2 :> 3 :> 4 :> 5 :> 6 :> 7 :> 8 :> 9 :> Nil--- >>> interleave d3 xs--- <1,4,7,2,5,8,3,6,9>-interleave :: (KnownNat n, KnownNat d)-           => SNat d -- ^ Interleave step, /d/-           -> Vec (n * d) a-           -> Vec (d * n) a-interleave d = concat . transpose . unconcat d-{-# INLINE interleave #-}---- | /Dynamically/ rotate a 'Vec'tor to the left:------ >>> let xs = 1 :> 2 :> 3 :> 4 :> Nil--- >>> rotateLeft xs 1--- <2,3,4,1>--- >>> rotateLeft xs 2--- <3,4,1,2>--- >>> rotateLeft xs (-1)--- <4,1,2,3>------ __NB:__ use `rotateLeftS` if you want to rotate left by a /static/ amount.-rotateLeft :: (Enum i, KnownNat n)-           => Vec n a-           -> i-           -> Vec n a-rotateLeft xs i = map ((xs !!) . (`mod` len)) (iterateI (+1) i')-  where-    i'  = fromEnum i-    len = length xs-{-# INLINE rotateLeft #-}---- | /Dynamically/ rotate a 'Vec'tor to the right:------ >>> let xs = 1 :> 2 :> 3 :> 4 :> Nil--- >>> rotateRight xs 1--- <4,1,2,3>--- >>> rotateRight xs 2--- <3,4,1,2>--- >>> rotateRight xs (-1)--- <2,3,4,1>------ __NB:__ use `rotateRightS` if you want to rotate right by a /static/ amount.-rotateRight :: (Enum i, KnownNat n)-            => Vec n a-            -> i-            -> Vec n a-rotateRight xs i = map ((xs !!) . (`mod` len)) (iterateI (+1) i')-  where-    i'  = negate (fromEnum i)-    len = length xs-{-# INLINE rotateRight #-}---- | /Statically/ rotate a 'Vec'tor to the left:------ >>> let xs = 1 :> 2 :> 3 :> 4 :> Nil--- >>> rotateLeftS xs d1--- <2,3,4,1>------ __NB:__ use `rotateLeft` if you want to rotate left by a /dynamic/ amount.-rotateLeftS :: KnownNat n-            => Vec n a-            -> SNat d-            -> Vec n a-rotateLeftS xs d = go (snatToInteger d `mod` natVal (asNatProxy xs)) xs-  where-    go :: Integer -> Vec k a -> Vec k a-    go _ Nil           = Nil-    go 0 ys            = ys-    go n (y `Cons` ys) = go (n-1) (ys :< y)-{-# NOINLINE rotateLeftS #-}---- | /Statically/ rotate a 'Vec'tor to the right:------ >>> let xs = 1 :> 2 :> 3 :> 4 :> Nil--- >>> rotateRightS xs d1--- <4,1,2,3>------ __NB:__ use `rotateRight` if you want to rotate right by a /dynamic/ amount.-rotateRightS :: KnownNat n-             => Vec n a-             -> SNat d-             -> Vec n a-rotateRightS xs d = go (snatToInteger d `mod` natVal (asNatProxy xs)) xs-  where-    go _ Nil            = Nil-    go 0 ys             = ys-    go n ys@(Cons _ _)  = go (n-1) (last ys :> init ys)-{-# NOINLINE rotateRightS #-}---- | Convert a vector to a list.------ >>> toList (1:>2:>3:>Nil)--- [1,2,3]-toList :: Vec n a -> [a]-toList = foldr (:) []-{-# INLINE toList #-}---- | Create a vector literal from a list literal.------ > $(listToVecTH [1::Signed 8,2,3,4,5]) == (8:>2:>3:>4:>5:>Nil) :: Vec 5 (Signed 8)------ >>> [1 :: Signed 8,2,3,4,5]--- [1,2,3,4,5]--- >>> $(listToVecTH [1::Signed 8,2,3,4,5])--- <1,2,3,4,5>-listToVecTH :: Lift a => [a] -> ExpQ-listToVecTH []     = [| Nil |]-listToVecTH (x:xs) = [| x :> $(listToVecTH xs) |]---- | 'Vec'tor as a 'Proxy' for 'Nat'-asNatProxy :: Vec n a -> Proxy n-asNatProxy _ = Proxy---- | Length of a 'Vec'tor as an 'SNat' value-lengthS :: KnownNat n => Vec n a -> SNat n-lengthS _ = SNat-{-# INLINE lengthS #-}---- | What you should use when your vector functions are too strict in their--- arguments.------ For example:------ @--- -- Bubble sort for 1 iteration--- sortV xs = 'map' fst sorted ':<' (snd ('last' sorted))---  where---    lefts  = 'head' xs :> 'map' snd ('init' sorted)---    rights = 'tail' xs---    sorted = 'zipWith' compareSwapL lefts rights------ -- Compare and swap--- compareSwapL a b = if a < b then (a,b)---                             else (b,a)--- @------ Will not terminate because 'zipWith' is too strict in its second argument.------ In this case, adding 'lazyV' on 'zipWith's second argument:------ @--- sortVL xs = 'map' fst sorted ':<' (snd ('last' sorted))---  where---    lefts  = 'head' xs :> map snd ('init' sorted)---    rights = 'tail' xs---    sorted = 'zipWith' compareSwapL ('lazyV' lefts) rights--- @------ Results in a successful computation:------ >>> sortVL (4 :> 1 :> 2 :> 3 :> Nil)--- <1,2,3,4>------ __NB__: There is also a solution using 'flip', but it slightly obfuscates the--- meaning of the code:------ @--- sortV_flip xs = 'map' fst sorted ':<' (snd ('last' sorted))---  where---    lefts  = 'head' xs :> 'map' snd ('init' sorted)---    rights = 'tail' xs---    sorted = 'zipWith' ('flip' compareSwapL) rights lefts--- @------ >>> sortV_flip (4 :> 1 :> 2 :> 3 :> Nil)--- <1,2,3,4>-lazyV :: KnownNat n-      => Vec n a-      -> Vec n a-lazyV = lazyV' (repeat undefined)-  where-    lazyV' :: Vec n a -> Vec n a -> Vec n a-    lazyV' Nil           _  = Nil-    lazyV' (_ `Cons` xs) ys = head ys `Cons` lazyV' xs (tail ys)-{-# NOINLINE lazyV #-}---- | A /dependently/ typed fold.------ Using lists, we can define /append/ (a.k.a. @Data.List.@'Data.List.++') in--- terms of @Data.List.@'Data.List.foldr':------ >>> import qualified Data.List--- >>> let append xs ys = Data.List.foldr (:) ys xs--- >>> append [1,2] [3,4]--- [1,2,3,4]------ However, when we try to do the same for 'Vec', by defining /append'/ in terms--- of @Clash.Sized.Vector.@'foldr':------ @--- append' xs ys = 'foldr' (:>) ys xs--- @------ we get a type error:------ @--- __>>> let append' xs ys = foldr (:>) ys xs__------ \<interactive\>:...---     • Occurs check: cannot construct the infinite type: ... ~ ... + 1---       Expected type: a -> Vec ... a -> Vec ... a---         Actual type: a -> Vec ... a -> Vec (... + 1) a---     • In the first argument of ‘foldr’, namely ‘(:>)’---       In the expression: foldr (:>) ys xs---       In an equation for ‘append'’: append' xs ys = foldr (:>) ys xs---     • Relevant bindings include---         ys :: Vec ... a (bound at ...)---         append' :: Vec n a -> Vec ... a -> Vec ... a---           (bound at ...)--- @------ The reason is that the type of 'foldr' is:------ >>> :t foldr--- foldr :: (a -> b -> b) -> b -> Vec n a -> b------ While the type of (':>') is:------ >>> :t (:>)--- (:>) :: a -> Vec n a -> Vec (n + 1) a------ We thus need a @fold@ function that can handle the growing vector type:--- 'dfold'. Compared to 'foldr', 'dfold' takes an extra parameter, called the--- /motive/, that allows the folded function to have an argument and result type--- that /depends/ on the current length of the vector. Using 'dfold', we can--- now correctly define /append'/:------ @--- import Data.Singletons.Prelude--- import Data.Proxy------ data Append (m :: Nat) (a :: *) (f :: 'TyFun' Nat *) :: *--- type instance 'Apply' (Append m a) l = 'Vec' (l + m) a------ append' xs ys = 'dfold' (Proxy :: Proxy (Append m a)) (const (':>')) ys xs--- @------ We now see that /append'/ has the appropriate type:------ >>> :t append'--- append' :: KnownNat k => Vec k a -> Vec m a -> Vec (k + m) a------ And that it works:------ >>> append' (1 :> 2 :> Nil) (3 :> 4 :> Nil)--- <1,2,3,4>------ __NB__: \"@'dfold' m f z xs@\" creates a linear structure, which has a depth,--- or delay, of O(@'length' xs@). Look at 'dtfold' for a /dependently/ typed--- fold that produces a structure with a depth of O(log_2(@'length' xs@)).-dfold :: forall p k a . KnownNat k-      => Proxy (p :: TyFun Nat Type -> Type) -- ^ The /motive/-      -> (forall l . SNat l -> a -> (p @@ l) -> (p @@ (l + 1)))-      -- ^ Function to fold.-      ---      -- __NB__: The @SNat l@ is __not__ the index (see (`!!`)) to the-      -- element /a/. @SNat l@ is the number of elements that occur to the-      -- right of /a/.-      -> (p @@ 0) -- ^ Initial element-      -> Vec k a -- ^ Vector to fold over-      -> (p @@ k)-dfold _ f z xs = go (snatProxy (asNatProxy xs)) xs-  where-    go :: SNat n -> Vec n a -> (p @@ n)-    go _ Nil                        = z-    go s (y `Cons` (ys :: Vec z a)) =-      let s' = s `subSNat` d1-      in  f s' y (go s' ys)-{-# NOINLINE dfold #-}---- | A combination of 'dfold' and 'fold': a /dependently/ typed fold that--- reduces a vector in a tree-like structure.------ As an example of when you might want to use 'dtfold' we will build a--- population counter: a circuit that counts the number of bits set to '1' in--- a 'BitVector'. Given a vector of /n/ bits, we only need we need a data type--- that can represent the number /n/: 'Index' @(n+1)@. 'Index' @k@ has a range--- of @[0 .. k-1]@ (using @ceil(log2(k))@ bits), hence we need 'Index' @n+1@.--- As an initial attempt we will use 'sum', because it gives a nice (@log2(n)@)--- tree-structure of adders:------ @--- populationCount :: (KnownNat (n+1), KnownNat (n+2))---                 => 'BitVector' (n+1) -> 'Index' (n+2)--- populationCount = sum . map fromIntegral . 'bv2v'--- @------ The \"problem\" with this description is that all adders have the same--- bit-width, i.e. all adders are of the type:------ @--- (+) :: 'Index' (n+2) -> 'Index' (n+2) -> 'Index' (n+2).--- @------ This is a \"problem\" because we could have a more efficient structure:--- one where each layer of adders is /precisely/ wide enough to count the number--- of bits at that layer. That is, at height /d/ we want the adder to be of--- type:------ @--- 'Index' ((2^d)+1) -> 'Index' ((2^d)+1) -> 'Index' ((2^(d+1))+1)--- @------ We have such an adder in the form of the 'Clash.Class.Num.add' function, as--- defined in the instance 'Clash.Class.Num.ExtendingNum' instance of 'Index'.--- However, we cannot simply use 'fold' to create a tree-structure of--- 'Clash.Class.Num.add'es:------ >>> :{--- let populationCount' :: (KnownNat (n+1), KnownNat (n+2))---                      => BitVector (n+1) -> Index (n+2)---     populationCount' = fold add . map fromIntegral . bv2v--- :}--- <BLANKLINE>--- <interactive>:...---     • Couldn't match type ‘((n + 2) + (n + 2)) - 1’ with ‘n + 2’---       Expected type: Index (n + 2) -> Index (n + 2) -> Index (n + 2)---         Actual type: Index (n + 2)---                      -> Index (n + 2) -> AResult (Index (n + 2)) (Index (n + 2))---     • In the first argument of ‘fold’, namely ‘add’---       In the first argument of ‘(.)’, namely ‘fold add’---       In the expression: fold add . map fromIntegral . bv2v---     • Relevant bindings include---         populationCount' :: BitVector (n + 1) -> Index (n + 2)---           (bound at ...)------ because 'fold' expects a function of type \"@a -> a -> a@\", i.e. a function--- where the arguments and result all have exactly the same type.------ In order to accommodate the type of our 'Clash.Class.Num.add', where the--- result is larger than the arguments, we must use a dependently typed fold in--- the form of 'dtfold':------ @--- {\-\# LANGUAGE UndecidableInstances \#-\}--- import Data.Singletons.Prelude--- import Data.Proxy------ data IIndex (f :: 'TyFun' Nat *) :: *--- type instance 'Apply' IIndex l = 'Index' ((2^l)+1)------ populationCount' :: (KnownNat k, KnownNat (2^k))---                  => BitVector (2^k) -> Index ((2^k)+1)--- populationCount' bv = 'dtfold' (Proxy @IIndex)---                              fromIntegral---                              (\\_ x y -> 'Clash.Class.Num.add' x y)---                              ('bv2v' bv)--- @------ And we can test that it works:------ >>> :t populationCount' (7 :: BitVector 16)--- populationCount' (7 :: BitVector 16) :: Index 17--- >>> populationCount' (7 :: BitVector 16)--- 3------ Some final remarks:------   * By using 'dtfold' instead of 'fold', we had to restrict our 'BitVector'---     argument to have bit-width that is a power of 2.---   * Even though our original /populationCount/ function specified a structure---     where all adders had the same width. Most VHDL/(System)Verilog synthesis---     tools will create a more efficient circuit, i.e. one where the adders---     have an increasing bit-width for every layer, from the---     VHDL/(System)Verilog produced by the Clash compiler.------ __NB__: The depth, or delay, of the structure produced by--- \"@'dtfold' m f g xs@\" is O(log_2(@'length' xs@)).-dtfold :: forall p k a . KnownNat k-       => Proxy (p :: TyFun Nat Type -> Type) -- ^ The /motive/-       -> (a -> (p @@ 0)) -- ^ Function to apply to every element-       -> (forall l . SNat l -> (p @@ l) -> (p @@ l) -> (p @@ (l + 1)))-       -- ^ Function to combine results.-       ---       -- __NB__: The @SNat l@ indicates the depth/height of the node in the-       -- tree that is created by applying this function. The leafs of the tree-       -- have depth\/height /0/, and the root of the tree has height /k/.-       -> Vec (2^k) a-       -- ^ Vector to fold over.-       ---       -- __NB__: Must have a length that is a power of 2.-       -> (p @@ k)-dtfold _ f g = go (SNat :: SNat k)-  where-    go :: forall n . SNat n -> Vec (2^n) a -> (p @@ n)-    go _  (x `Cons` Nil) = f x-    go sn xs@(Cons _ (Cons _ _)) =-      let sn' :: SNat (n - 1)-          sn'       = sn `subSNat` d1-          (xsL,xsR) = splitAt (pow2SNat sn') xs-      in  g sn' (go sn' xsL) (go sn' xsR)-{-# NOINLINE dtfold #-}---- | To be used as the motive /p/ for 'dfold', when the /f/ in \"'dfold' @p f@\"--- is a variation on (':>'), e.g.:------ @--- map' :: forall n a b . KnownNat n => (a -> b) -> Vec n a -> Vec n b--- map' f = 'dfold' (Proxy @('VCons' b)) (\_ x xs -> f x :> xs)--- @-data VCons (a :: Type) (f :: TyFun Nat Type) :: Type-type instance Apply (VCons a) l = Vec l a---- | Specialised version of 'dfold' that builds a triangular computational--- structure.------ Example:------ @--- compareSwap a b = if a > b then (a,b) else (b,a)--- insert y xs     = let (y',xs') = 'mapAccumL' compareSwap y xs in xs' ':<' y'--- insertionSort   = 'vfold' (const insert)--- @------ Builds a triangular structure of compare and swaps to sort a row.------ >>> insertionSort (7 :> 3 :> 9 :> 1 :> Nil)--- <1,3,7,9>------ The circuit layout of @insertionSort@, build using 'vfold', is:------ <<doc/csSort.svg>>-vfold :: forall k a b . KnownNat k-      => (forall l . SNat l -> a -> Vec l b -> Vec (l + 1) b)-      -> Vec k a-      -> Vec k b-vfold f xs = dfold (Proxy @(VCons b)) f Nil xs-{-# INLINE vfold #-}---- | Apply a function to every element of a vector and the element's position--- (as an 'SNat' value) in the vector.------ >>> let rotateMatrix = smap (flip rotateRightS)--- >>> let xss = (1:>2:>3:>Nil):>(1:>2:>3:>Nil):>(1:>2:>3:>Nil):>Nil--- >>> xss--- <<1,2,3>,<1,2,3>,<1,2,3>>--- >>> rotateMatrix xss--- <<1,2,3>,<3,1,2>,<2,3,1>>-smap :: forall k a b . KnownNat k => (forall l . SNat l -> a -> b) -> Vec k a -> Vec k b-smap f xs = reverse-          $ dfold (Proxy @(VCons b))-                  (\sn x xs' -> f sn x :> xs')-                  Nil (reverse xs)-{-# INLINE smap #-}--instance (KnownNat n, KnownNat (BitSize a), BitPack a) => BitPack (Vec n a) where-  type BitSize (Vec n a) = n * (BitSize a)-  pack   = packXWith (concatBitVector# . map pack)-  unpack = map unpack . unconcatBitVector#--concatBitVector#-  :: (KnownNat n, KnownNat m)-  => Vec n (BitVector m)-  -> BitVector (n * m)-concatBitVector# Nil           = 0-concatBitVector# (x `Cons` xs) = x ++# concatBitVector# xs-{-# NOINLINE concatBitVector# #-}--unconcatBitVector#-  :: forall n m-   . (KnownNat n, KnownNat m)-  => BitVector (n * m)-  -> Vec n (BitVector m)-unconcatBitVector# = go (toUNat (SNat @ n))-  where-    go :: KnownNat x => UNat x -> BitVector (x * m) -> Vec x (BitVector m)-    go UZero     _  = Nil-    go (USucc n) bv = let (x :: BitVector m,bv') = split# bv-                      in  x :> go n bv'-{-# NOINLINE unconcatBitVector# #-}---- | Convert a 'BitVector' to a 'Vec' of 'Bit's.------ >>> let x = 6 :: BitVector 8--- >>> x--- 0000_0110--- >>> bv2v x--- <0,0,0,0,0,1,1,0>-bv2v :: KnownNat n => BitVector n -> Vec n Bit-bv2v = unpack---- | Convert a 'Vec' of 'Bit's to a 'BitVector'.------ >>> let x = (0:>0:>0:>1:>0:>0:>1:>0:>Nil) :: Vec 8 Bit--- >>> x--- <0,0,0,1,0,0,1,0>--- >>> v2bv x--- 0001_0010-v2bv :: KnownNat n => Vec n Bit -> BitVector n-v2bv = pack---- | Evaluate all elements of a vector to WHNF, returning the second argument-seqV-  :: KnownNat n-  => Vec n a-  -> b-  -> b-seqV v b =-  let s () e = seq e () in-  foldl s () v `seq` b-{-# NOINLINE seqV #-}-infixr 0 `seqV`---- | Evaluate all elements of a vector to WHNF-forceV-  :: KnownNat n-  => Vec n a-  -> Vec n a-forceV v =-  v `seqV` v-{-# INLINE forceV #-}---- | Evaluate all elements of a vector to WHNF, returning the second argument.--- Does not propagate 'XException's.-seqVX-  :: KnownNat n-  => Vec n a-  -> b-  -> b-seqVX v b =-  let s () e = seqX e () in-  foldl s () v `seqX` b-{-# NOINLINE seqVX #-}-infixr 0 `seqVX`---- | Evaluate all elements of a vector to WHNF. Does not propagate 'XException's.-forceVX-  :: KnownNat n-  => Vec n a-  -> Vec n a-forceVX v =-  v `seqVX` v-{-# INLINE forceVX #-}--instance Lift a => Lift (Vec n a) where-  lift Nil           = [| Nil |]-  lift (x `Cons` xs) = [| x `Cons` $(lift xs) |]--instance (KnownNat n, Arbitrary a) => Arbitrary (Vec n a) where-  arbitrary = traverse# id $ repeat arbitrary-  shrink    = traverse# id . fmap shrink--instance CoArbitrary a => CoArbitrary (Vec n a) where-  coarbitrary = coarbitrary . toList--type instance Lens.Index   (Vec n a) = Index n-type instance Lens.IxValue (Vec n a) = a-instance KnownNat n => Lens.Ixed (Vec n a) where-  ix i f xs = replace_int xs (fromEnum i) <$> f (index_int xs (fromEnum i))+                  2022-2025, QBayLogic B.V.+                  2024,      Alex Mason+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Sized.Vector+  ( -- * 'Vec'tor data type+    Vec(Nil,(:>),(:<),Cons)+    -- * Accessors+    -- ** Length information+  , length, lengthS+    -- ** Indexing+  , (!!), head, last, at+  , indices, indicesI+  , findIndex, elemIndex+    -- ** Extracting sub-vectors (slicing)+  , tail, init+  , take, takeI, drop, dropI+  , select, selectI+    -- *** Splitting+  , splitAt, splitAtI+  , unconcat, unconcatI+    -- * Construction+    -- ** Initialization+  , singleton+  , replicate, repeat+  , iterate, iterateI, generate, generateI+  , unfoldr, unfoldrI+    -- *** Initialization from a list+  , listToVecTH+    -- ** Concatenation+  , (++), (+>>), (<<+), concat, concatMap+  , shiftInAt0, shiftInAtN , shiftOutFrom0, shiftOutFromN+  , merge+    -- * Modifying vectors+  , replace+    -- ** Permutations+  , permute, backpermute, scatter, gather+    -- *** Specialized permutations+  , reverse, transpose, interleave+  , rotateLeft, rotateRight, rotateLeftS, rotateRightS+    -- * Element-wise operations+    -- ** Mapping+  , map, imap, smap, smapWithBounds+    -- ** Zipping+  , zipWith, zipWith3, zipWith4, zipWith5, zipWith6, zipWith7+  , zip, zip3, zip4, zip5, zip6, zip7+  , izipWith+    -- ** Unzipping+  , unzip, unzip3, unzip4, unzip5, unzip6, unzip7+    -- * Folding+  , foldr, foldl, foldr1, foldl1, fold+  , ifoldr, ifoldl+    -- ** Specialized folds+  , dfold, dtfold, vfold, maximum, minimum+    -- * Prefix sums (scans)+  , scanl, scanl1, scanr, scanr1, postscanl, postscanr+  , mapAccumL, mapAccumR+    -- * Stencil computations+  , stencil1d, stencil2d+  , windows1d, windows2d+    -- * Conversions+  , toList+  , fromList+  , unsafeFromList+  , bv2v+  , v2bv+    -- * Misc+  , lazyV, VCons, asNatProxy, seqV, forceV, seqVX, forceVX+    -- * Primitives+    -- ** 'Traversable' instance+  , traverse#+    -- ** 'BitPack' instance+  , concatBitVector#+  , unconcatBitVector#+  )+where++import Control.DeepSeq            (NFData (..))+import qualified Control.Lens     as Lens hiding (pattern (:>), pattern (:<))+import Data.Bits                  ((.|.), shiftL)+import Data.Constraint            ((:-)(Sub), Dict (..))+import Data.Constraint.Nat        (leZero)+import Data.Data+  (Data (..), Constr, DataType, Fixity (..), Typeable, mkConstr, mkDataType)+import Data.Either                (isLeft)+import Data.Distributive+import Data.Functor.Rep+import qualified Data.Foldable1   as F1+import Data.Default               (Default (..))+import qualified Data.Foldable    as F+import Data.Kind                  (Type)+import Data.Proxy                 (Proxy (..))+import Data.Singletons            (TyFun,Apply,type (@@))+import GHC.TypeLits               (KnownNat, Nat, type (+), type (-), type (*),+                                   type (^), type (<=), natVal)+import GHC.Base                   (Int(I#),Int#,isTrue#)+import GHC.Generics               hiding (Fixity (..))+import qualified GHC.Magic+import GHC.Prim                   ((==#),(<#),(-#))+import Language.Haskell.TH        (ExpQ)+import Language.Haskell.TH.Syntax (Lift(..))+import Language.Haskell.TH.Compat+import Prelude                    hiding ((++), (!!), concat, concatMap, drop,+                                          foldl, foldl1, foldr, foldr1, head,+                                          init, iterate, last, length, map,+                                          repeat, replicate, reverse, scanl,+                                          scanl1, scanr, scanr1, splitAt, tail,+                                          take, unzip, unzip3, zip, zip3, zipWith,+                                          zipWith3, maximum, minimum)+import qualified Data.String.Interpolate as I+import qualified Prelude          as P+import Test.QuickCheck+  (Arbitrary(arbitrary, shrink), CoArbitrary(coarbitrary))++import Clash.Annotations.Primitive+  (Primitive(InlineYamlPrimitive), HDL(..), dontTranslate, hasBlackBox)+import Clash.Magic (clashCompileError, clashSimulation)+import Clash.Promoted.Nat+  (SNat (..), SNatLE (..), UNat (..), compareSNat, pow2SNat,+   snatProxy, snatToInteger, subSNat, withSNat, toUNat, natToInteger)+import Clash.Promoted.Nat (leToPlus)+import Clash.Promoted.Nat.Literals (d1)+import Clash.Sized.Internal.BitVector (Bit, BitVector (..), split#)+import Clash.Sized.Index          (Index)++import Clash.Class.BitPack        (BitPack (..))+import Clash.XException           (ShowX (..), NFDataX (..), seqX, isX)++{- $setup+>>> :set -XTypeFamilies+>>> :set -XTypeOperators+>>> :set -XTemplateHaskell+>>> :set -XFlexibleContexts+>>> :set -fplugin GHC.TypeLits.Normalise+>>> :set -fplugin GHC.TypeLits.KnownNat.Solver+>>> :set -fplugin GHC.TypeLits.Extra.Solver+>>> :m -Prelude+>>> import Clash.Prelude+>>> import qualified Clash.Sized.Vector as Vec+-}++#define CONS_PREC 5++infixr CONS_PREC `Cons`+-- | Fixed size vectors.+--+-- * Lists with their length encoded in their type+-- * 'Vec'tor elements have an __ASCENDING__ subscript starting from 0 and+--   ending at @'length' - 1@.+data Vec :: Nat -> Type -> Type where+  Nil  :: Vec 0 a+  Cons :: a -> Vec n a -> Vec (n + 1) a++{-# COMPLETE Nil, (:>) #-}++-- | Tag for K1: @n ~ 0@ proof+data N++-- | In many cases, this Generic instance only allows generic+-- functions/instances over vectors of at least size 1, due to the+-- /n-1/ in the /Rep (Vec n a)/ definition.+--+-- We'll have to wait for things like+-- https://ryanglscott.github.io/2018/02/11/how-to-derive-generic-for-some-gadts/+-- before we can work around this limitation+instance KnownNat n => Generic (Vec n a) where+  type Rep (Vec n a) =+    D1 ('MetaData "Vec" "Clash.Data.Vector" "clash-prelude" 'False)+      (C1 ('MetaCons "Nil" 'PrefixI 'False) (K1 N (Dict (n ~ 0))) :+:+       C1 ('MetaCons "Cons" 'PrefixI 'False)+        (S1 ('MetaSel 'Nothing+                'NoSourceUnpackedness+                'NoSourceStrictness+                'DecidedLazy)+            (Rec0 a) :*:+         S1 ('MetaSel 'Nothing+                'NoSourceUnpackedness+                'NoSourceStrictness+                'DecidedLazy)+            (Rec0 (Vec (n-1) a))))+  from Nil         = M1 (L1 (M1 (K1 Dict)))+  from (Cons x xs) = M1 (R1 (M1 (M1 (K1 x) :*: M1 (K1 xs))))+  to (M1 g) = case compareSNat (SNat @n) (SNat @0) of+    SNatLE -> case leZero @n of+      Sub Dict -> Nil+    SNatGT -> case g of+      R1 (M1 (M1 (K1 p) :*: M1 (K1 q))) -> Cons p q+      L1 (M1 (K1 eqZero)) -> case eqZero of {}++instance (KnownNat n, Typeable a, Data a) => Data (Vec n a) where+  gunfold k z _ = case compareSNat (SNat @n) (SNat @0) of+    SNatLE -> case leZero @n of+      Sub Dict -> z Nil+    SNatGT -> k (k (z @(a -> Vec (n-1) a -> Vec n a) Cons))+  toConstr Nil        = cNil+  toConstr (Cons _ _) = cCons+  dataTypeOf _        = tVec++  gfoldl+    :: (forall d b. Data d => c (d -> b) -> d -> c b)+    -> (forall g. g -> c g)+    -> Vec n a+    -> c (Vec n a)+  gfoldl f z xs = case compareSNat (SNat @n) (SNat @0) of+    SNatLE -> case leZero @n of+                  Sub Dict -> z Nil+    SNatGT -> case xs of+                  (y :> ys) -> (z @(a -> Vec (n-1) a -> Vec n a) (:>) `f` y `f` ys)++tVec :: DataType+tVec = mkDataType "Vec" [cNil, cCons]++cNil :: Constr+cNil = mkConstr tVec "Nil" [] Prefix++cCons :: Constr+cCons = mkConstr tVec "Cons" [] Prefix++instance NFData a => NFData (Vec n a) where+  rnf = foldl (\() -> rnf) ()++-- | Add an element to the head of a vector.+--+-- >>> 3:>4:>5:>Nil+-- 3 :> 4 :> 5 :> Nil+-- >>> let x = 3:>4:>5:>Nil+-- >>> :t x+-- x :: Num a => Vec 3 a+--+-- Can be used as a pattern:+--+-- >>> let f (x :> y :> _) = x + y+-- >>> :t f+-- f :: Num a => Vec ((n + 1) + 1) a -> a+-- >>> f (3:>4:>5:>6:>7:>Nil)+-- 7+--+-- Also in conjunctions with (':<'):+--+-- >>> let g (a :> b :> (_ :< y :< x)) = a + b +  x + y+-- >>> :t g+-- g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a+-- >>> g (1:>2:>3:>4:>5:>Nil)+-- 12+pattern (:>) :: a -> Vec n a -> Vec (n + 1) a+pattern (:>) x xs <- ((\ys -> (head ys,tail ys)) -> (x,xs))+  where+    (:>) x xs = Cons x xs++infixr CONS_PREC :>++instance Show a => Show (Vec n a) where+  showsPrec n = \case+    Nil -> showString "Nil"+    vs -> showParen (n > CONS_PREC) (go vs)++   where+    go :: Vec m a -> ShowS+    go Nil = showString "Nil"+    go (x `Cons` xs) =+        showsPrec (CONS_PREC + 1) x+      . showString " :> "+      . go xs++instance ShowX a => ShowX (Vec n a) where+  showsPrecX n vs =+    case isX vs of+      Right Nil -> showString "Nil"+      Left _ -> showString "undefined"+      _ -> showParen (n > CONS_PREC) (go vs)+   where+    go :: Vec m a -> ShowS+    go (isX -> Left _) = showString "undefined"+    go Nil = showString "Nil"+    go (x `Cons` xs) =+        showsPrecX (CONS_PREC + 1) x+      . showString " :> "+      . go xs++instance (KnownNat n, Eq a) => Eq (Vec n a) where+  (==) Nil _            = True+  (==) v1@(Cons _ _) v2 = fold (&&) (zipWith (==) v1 v2)++instance (KnownNat n, Ord a) => Ord (Vec n a) where+  compare x y = foldr f EQ $ zipWith compare x y+    where f EQ   keepGoing = keepGoing+          f done _         = done++instance (KnownNat n, Semigroup a) => Semigroup (Vec n a) where+  (<>) = zipWith (<>)++instance (KnownNat n, Monoid a) => Monoid (Vec n a) where+  mempty = repeat mempty+  mappend = (<>)++instance KnownNat n => Applicative (Vec n) where+  pure      = repeat+  fs <*> xs = zipWith ($) fs xs++{-# RULES+"zipWith$map" forall f xs ys. zipWith (\g a -> g a) (map f xs) ys = zipWith f xs ys+  #-}++instance KnownNat n => F.Foldable (Vec n) where+  fold Nil      = mempty+  fold z@Cons{} = fold mappend z+  foldMap _ Nil      = mempty+  foldMap f z@Cons{} = fold mappend (map f z)+  foldr     = foldr+  foldl     = foldl+  foldr1 _ Nil      = clashCompileError "foldr1: empty Vec"+  foldr1 f z@Cons{} = foldr1 f z+  foldl1 _ Nil      = clashCompileError "foldl1: empty Vec"+  foldl1 f z@Cons{} = foldl1 f z+  toList    = toList+  null Nil  = True+  null _    = False+  length    = length+  maximum Nil      = clashCompileError "maximum: empty Vec"+  maximum z@Cons{} = fold (\x y -> if x >= y then x else y) z+  minimum Nil      = clashCompileError "minimum: empty Vec"+  minimum z@Cons{} = fold (\x y -> if x <= y then x else y) z+  sum Nil      = 0+  sum z@Cons{} = fold (+) z+  product Nil      = 1+  product z@Cons{} = fold (*) z++instance (KnownNat n, 1 <= n) => F1.Foldable1 (Vec n) where+  fold1         = leToPlus @1 @n $ fold (<>)+  foldMap1 f    = leToPlus @1 @n $ fold (<>) . map f+  maximum       = leToPlus @1 @n maximum+  minimum       = leToPlus @1 @n minimum+  head          = leToPlus @1 @n head+  last          = leToPlus @1 @n last++instance Functor (Vec n) where+  fmap = map++instance KnownNat n => Traversable (Vec n) where+  traverse = traverse#++{-# OPAQUE traverse# #-}+{-# ANN traverse# hasBlackBox #-}+traverse# :: forall a f b n . Applicative f => (a -> f b) -> Vec n a -> f (Vec n b)+traverse# _ Nil           = pure Nil+traverse# f (x `Cons` xs) = Cons <$> f x <*> traverse# f xs++instance (Default a, KnownNat n) => Default (Vec n a) where+  def = repeat def++instance (NFDataX a, KnownNat n) => NFDataX (Vec n a) where+  deepErrorX x = repeat (deepErrorX x)++  rnfX v =+    -- foldl will fail if the spine of the vector is undefined, so we need to+    -- seqX the result of it. We need to use foldl so Clash won't treat it as+    -- a recursive function.+    seqX (foldl (\() -> rnfX) () v) ()++  hasUndefined v =+    if isLeft (isX v) then True else go v+   where+    go :: forall m b . (NFDataX b, KnownNat m) => Vec m b -> Bool+    go Nil = False+    go (x `Cons` xs) = hasUndefined x || hasUndefined xs++  ensureSpine = map ensureSpine . lazyV++{-# INLINE singleton #-}+-- | Create a vector of one element+--+-- >>> singleton 5+-- 5 :> Nil+singleton :: a -> Vec 1 a+singleton = (`Cons` Nil)++{-# OPAQUE head #-}+{-# ANN head hasBlackBox #-}+{- | Extract the first element of a vector++>>> head (1:>2:>3:>Nil)+1++#if __GLASGOW_HASKELL__ >= 910+>>> head Nil+<interactive>:...+    • Couldn't match type ‘1’ with ‘0’+      Expected: Vec (0 + 1) a+        Actual: Vec 0 a+    • In the first argument of ‘head’, namely ‘Nil’+      In the expression: head Nil+      In an equation for ‘it’: it = head Nil+<BLANKLINE>++#else+>>> head Nil+<BLANKLINE>+<interactive>:...+    • Couldn't match type ‘1’ with ‘0’+      Expected: Vec (0 + 1) a+        Actual: Vec 0 a+    • In the first argument of ‘head’, namely ‘Nil’+      In the expression: head Nil+      In an equation for ‘it’: it = head Nil++#endif+-}+head :: Vec (n + 1) a -> a+head (x `Cons` _) = x+#if __GLASGOW_HASKELL__ < 912+head xs = unreachable xs+ where+  unreachable :: forall n a. 1 <= n => Vec n a -> a+  unreachable (x `Cons` _) = x+#endif++{-# OPAQUE tail #-}+{-# ANN tail hasBlackBox #-}+{- | Extract the elements after the head of a vector++>>> tail (1:>2:>3:>Nil)+2 :> 3 :> Nil++#if __GLASGOW_HASKELL__ >= 910+>>> tail Nil+<interactive>:...+    • Couldn't match type ‘1’ with ‘0’+      Expected: Vec (0 + 1) a+        Actual: Vec 0 a+    • In the first argument of ‘tail’, namely ‘Nil’+      In the expression: tail Nil+      In an equation for ‘it’: it = tail Nil+<BLANKLINE>++#else+>>> tail Nil+<BLANKLINE>+<interactive>:...+    • Couldn't match type ‘1’ with ‘0’+      Expected: Vec (0 + 1) a+        Actual: Vec 0 a+    • In the first argument of ‘tail’, namely ‘Nil’+      In the expression: tail Nil+      In an equation for ‘it’: it = tail Nil++#endif+-}+tail :: Vec (n + 1) a -> Vec n a+tail (_ `Cons` xr) = xr+#if __GLASGOW_HASKELL__ < 912+tail xs = unreachable xs+ where+  unreachable :: forall n a. 1 <= n => Vec n a -> Vec (n - 1) a+  unreachable (_ `Cons` xr) = xr+#endif++{-# OPAQUE last #-}+{-# ANN last hasBlackBox #-}+{- | Extract the last element of a vector++>>> last (1:>2:>3:>Nil)+3++#if __GLASGOW_HASKELL__ >= 910+>>> last Nil+<interactive>:...+    • Couldn't match type ‘1’ with ‘0’+      Expected: Vec (0 + 1) a+        Actual: Vec 0 a+    • In the first argument of ‘last’, namely ‘Nil’+      In the expression: last Nil+      In an equation for ‘it’: it = last Nil+<BLANKLINE>++#else+>>> last Nil+<BLANKLINE>+<interactive>:...+    • Couldn't match type ‘1’ with ‘0’+      Expected: Vec (0 + 1) a+        Actual: Vec 0 a+    • In the first argument of ‘last’, namely ‘Nil’+      In the expression: last Nil+      In an equation for ‘it’: it = last Nil++#endif+-}+last :: Vec (n + 1) a -> a+last (x `Cons` Nil)         = x+last (_ `Cons` y `Cons` xr) = last (y `Cons` xr)+#if __GLASGOW_HASKELL__ < 912+last xs = unreachable xs+ where+  unreachable :: 1 <= n => Vec n a -> a+  unreachable ys@(Cons _ _) = last ys+#endif++{-# OPAQUE init #-}+{-# ANN init hasBlackBox #-}+{- | Extract all the elements of a vector except the last element++>>> init (1:>2:>3:>Nil)+1 :> 2 :> Nil++#if __GLASGOW_HASKELL__ >= 910+>>> init Nil+<interactive>:...+    • Couldn't match type ‘1’ with ‘0’+      Expected: Vec (0 + 1) a+        Actual: Vec 0 a+    • In the first argument of ‘init’, namely ‘Nil’+      In the expression: init Nil+      In an equation for ‘it’: it = init Nil+<BLANKLINE>++#else+>>> init Nil+<BLANKLINE>+<interactive>:...+    • Couldn't match type ‘1’ with ‘0’+      Expected: Vec (0 + 1) a+        Actual: Vec 0 a+    • In the first argument of ‘init’, namely ‘Nil’+      In the expression: init Nil+      In an equation for ‘it’: it = init Nil++#endif+-}+init :: Vec (n + 1) a -> Vec n a+init (_ `Cons` Nil)         = Nil+init (x `Cons` y `Cons` xr) = x `Cons` init (y `Cons` xr)+#if __GLASGOW_HASKELL__ < 912+init xs = unreachable xs+ where+  unreachable :: 1 <= n => Vec n a -> Vec (n - 1) a+  unreachable ys@(Cons _ _) = init ys+#endif++{-# INLINE shiftInAt0 #-}+-- | Shift in elements to the head of a vector, bumping out elements at the+-- tail. The result is a tuple containing:+--+-- * The new vector+-- * The shifted out elements+--+-- >>> shiftInAt0 (1 :> 2 :> 3 :> 4 :> Nil) ((-1) :> 0 :> Nil)+-- (-1 :> 0 :> 1 :> 2 :> Nil,3 :> 4 :> Nil)+-- >>> shiftInAt0 (1 :> Nil) ((-1) :> 0 :> Nil)+-- (-1 :> Nil,0 :> 1 :> Nil)+shiftInAt0 :: KnownNat n+           => Vec n a -- ^ The old vector+           -> Vec m a -- ^ The elements to shift in at the head+           -> (Vec n a, Vec m a) -- ^ (The new vector, shifted out elements)+shiftInAt0 xs ys = splitAtI zs+  where+    zs = ys ++ xs++{-# INLINE shiftInAtN #-}+-- | Shift in element to the tail of a vector, bumping out elements at the head.+-- The result is a tuple containing:+--+-- * The new vector+-- * The shifted out elements+--+-- >>> shiftInAtN (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> Nil)+-- (3 :> 4 :> 5 :> 6 :> Nil,1 :> 2 :> Nil)+-- >>> shiftInAtN (1 :> Nil) (2 :> 3 :> Nil)+-- (3 :> Nil,1 :> 2 :> Nil)+shiftInAtN :: KnownNat m+           => Vec n a -- ^ The old vector+           -> Vec m a -- ^ The elements to shift in at the tail+           -> (Vec n a,Vec m a) -- ^ (The new vector, shifted out elements)+shiftInAtN xs ys = (zsR, zsL)+  where+    zs        = xs ++ ys+    (zsL,zsR) = splitAtI zs++infixl 5 :<+-- | Add an element to the tail of a vector.+--+-- >>> (3:>4:>5:>Nil) :< 1+-- 3 :> 4 :> 5 :> 1 :> Nil+-- >>> let x = (3:>4:>5:>Nil) :< 1+-- >>> :t x+-- x :: Num a => Vec 4 a+--+-- Can be used as a pattern:+--+-- >>> let f (_ :< y :< x) = y + x+-- >>> :t f+-- f :: Num a => Vec ((n + 1) + 1) a -> a+-- >>> f (3:>4:>5:>6:>7:>Nil)+-- 13+--+-- Also in conjunctions with (':>'):+--+-- >>> let g (a :> b :> (_ :< y :< x)) = a + b +  x + y+-- >>> :t g+-- g :: Num a => Vec ((((n + 1) + 1) + 1) + 1) a -> a+-- >>> g (1:>2:>3:>4:>5:>Nil)+-- 12+pattern (:<) :: Vec n a -> a -> Vec (n+1) a+pattern (:<) xs x <- ((\ys -> (init ys,last ys)) -> (xs,x))+  where+    (:<) xs x = xs ++ singleton x++infixr 4 +>>+-- | Add an element to the head of a vector, and extract all but the last+-- element.+--+-- >>> 1 +>> (3:>4:>5:>Nil)+-- 1 :> 3 :> 4 :> Nil+-- >>> 1 +>> Nil+-- Nil+(+>>) :: forall n a . a -> Vec n a -> Vec n a+s +>> xs = init (s :> xs)+{-# INLINE (+>>) #-}+++infixl 4 <<++-- | Add an element to the tail of a vector, and extract all but the first+-- element.+--+-- >>> (3:>4:>5:>Nil) <<+ 1+-- 4 :> 5 :> 1 :> Nil+-- >>> Nil <<+ 1+-- Nil+(<<+) :: Vec n a -> a -> Vec n a+xs <<+ s = fst (shiftInAtN xs (singleton s))+{-# INLINE (<<+) #-}++-- | Shift /m/ elements out from the head of a vector, filling up the tail with+-- 'Default' values. The result is a tuple containing:+--+-- * The new vector+-- * The shifted out values+--+-- >>> shiftOutFrom0 d2 ((1 :> 2 :> 3 :> 4 :> 5 :> Nil) :: Vec 5 Integer)+-- (3 :> 4 :> 5 :> 0 :> 0 :> Nil,1 :> 2 :> Nil)+shiftOutFrom0 :: (Default a, KnownNat m)+              => SNat m        -- ^ @m@, the number of elements to shift out+              -> Vec (m + n) a -- ^ The old vector+              -> (Vec (m + n) a, Vec m a)+              -- ^ (The new vector, shifted out elements)+shiftOutFrom0 m xs = shiftInAtN xs (replicate m def)+{-# INLINE shiftOutFrom0 #-}++-- | Shift /m/ elements out from the tail of a vector, filling up the head with+-- 'Default' values. The result is a tuple containing:+--+-- * The new vector+-- * The shifted out values+--+-- >>> shiftOutFromN d2 ((1 :> 2 :> 3 :> 4 :> 5 :> Nil) :: Vec 5 Integer)+-- (0 :> 0 :> 1 :> 2 :> 3 :> Nil,4 :> 5 :> Nil)+shiftOutFromN :: (Default a, KnownNat n)+              => SNat m        -- ^ @m@, the number of elements to shift out+              -> Vec (m + n) a -- ^ The old vector+              -> (Vec (m + n) a, Vec m a)+              -- ^ (The new vector, shifted out elements)+shiftOutFromN m@SNat xs = shiftInAt0 xs (replicate m def)+{-# INLINE shiftOutFromN #-}++infixr 5 +++-- | Append two vectors.+--+-- >>> (1:>2:>3:>Nil) ++ (7:>8:>Nil)+-- 1 :> 2 :> 3 :> 7 :> 8 :> Nil+(++) :: Vec n a -> Vec m a -> Vec (n + m) a+Nil           ++ ys = ys+(x `Cons` xs) ++ ys = x `Cons` xs ++ ys+{-# OPAQUE (++) #-}+{-# ANN (++) hasBlackBox #-}++-- | Split a vector into two vectors at the given point.+--+-- >>> splitAt (SNat :: SNat 3) (1:>2:>3:>7:>8:>Nil)+-- (1 :> 2 :> 3 :> Nil,7 :> 8 :> Nil)+-- >>> splitAt d3 (1:>2:>3:>7:>8:>Nil)+-- (1 :> 2 :> 3 :> Nil,7 :> 8 :> Nil)+splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)+splitAt n xs = splitAtU (toUNat n) xs+{-# OPAQUE splitAt #-}+{-# ANN splitAt hasBlackBox #-}++splitAtU :: UNat m -> Vec (m + n) a -> (Vec m a, Vec n a)+splitAtU UZero     ys = (Nil, ys)+splitAtU (USucc s) ys = let (as, bs) = splitAtU s $ tail ys+                        in  (head ys `Cons` as, bs)++-- | Split a vector into two vectors where the length of the two is determined+-- by the context.+--+-- >>> splitAtI (1:>2:>3:>7:>8:>Nil) :: (Vec 2 Int, Vec 3 Int)+-- (1 :> 2 :> Nil,3 :> 7 :> 8 :> Nil)+splitAtI :: KnownNat m => Vec (m + n) a -> (Vec m a, Vec n a)+splitAtI = withSNat splitAt+{-# INLINE splitAtI #-}++-- | Concatenate a vector of vectors.+--+-- >>> concat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil)+-- 1 :> 2 :> 3 :> 4 :> 5 :> 6 :> 7 :> 8 :> 9 :> 10 :> 11 :> 12 :> Nil+concat :: Vec n (Vec m a) -> Vec (n * m) a+concat Nil           = Nil+concat (x `Cons` xs) = x ++ concat xs+{-# OPAQUE concat #-}+{-# ANN concat hasBlackBox #-}++-- | Map a function over all the elements of a vector and concatentate the resulting vectors.+--+-- >>> concatMap (replicate d3) (1:>2:>3:>Nil)+-- 1 :> 1 :> 1 :> 2 :> 2 :> 2 :> 3 :> 3 :> 3 :> Nil+concatMap :: (a -> Vec m b) -> Vec n a -> Vec (n * m) b+concatMap f xs = concat (map f xs)+{-# INLINE concatMap #-}++-- | Split a vector of \(n * m)\ elements into a vector of \"vectors of length+-- /m/\", where the length /m/ is given.+--+-- >>> unconcat d4 (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil)+-- (1 :> 2 :> 3 :> 4 :> Nil) :> (5 :> 6 :> 7 :> 8 :> Nil) :> (9 :> 10 :> 11 :> 12 :> Nil) :> Nil+unconcat :: KnownNat n => SNat m -> Vec (n * m) a -> Vec n (Vec m a)+unconcat n xs = unconcatU (withSNat toUNat) (toUNat n) xs+{-# OPAQUE unconcat #-}+{-# ANN unconcat hasBlackBox #-}++unconcatU :: UNat n -> UNat m -> Vec (n * m) a -> Vec n (Vec m a)+unconcatU UZero      _ _  = Nil+unconcatU (USucc n') m ys = let (as,bs) = splitAtU m ys+                            in  as `Cons` unconcatU n' m bs++-- | Split a vector of /(n * m)/ elements into a vector of \"vectors of length+-- /m/\", where the length /m/ is determined by the context.+--+-- >>> unconcatI (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil) :: Vec 2 (Vec 6 Int)+-- (1 :> 2 :> 3 :> 4 :> 5 :> 6 :> Nil) :> (7 :> 8 :> 9 :> 10 :> 11 :> 12 :> Nil) :> Nil+unconcatI :: (KnownNat n, KnownNat m) => Vec (n * m) a -> Vec n (Vec m a)+unconcatI = withSNat unconcat+{-# INLINE unconcatI #-}++-- | Merge two vectors, alternating their elements, i.e.,+--+-- >>> merge (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> 7 :> 8 :> Nil)+-- 1 :> 5 :> 2 :> 6 :> 3 :> 7 :> 4 :> 8 :> Nil+merge :: Vec n a -> Vec n a -> Vec (2 * n) a+merge x y = concat $ zipWith (\a b -> a :> singleton b) x y+{-# INLINE merge #-}++-- | The elements in a vector in reverse order.+--+-- >>> reverse (1:>2:>3:>4:>Nil)+-- 4 :> 3 :> 2 :> 1 :> Nil+reverse :: Vec n a -> Vec n a+reverse xs = go Nil xs+ where+  go :: i <= n => Vec (n - i) a -> Vec i a -> Vec n a+  go a (y `Cons` ys) = go (y `Cons` a) ys+  go a Nil = a+{-# OPAQUE reverse #-}+{-# ANN reverse hasBlackBox #-}++-- | \"'map' @f xs@\" is the vector obtained by applying /f/ to each element+-- of /xs/, i.e.,+--+-- > map f (x1 :> x2 :>  ... :> xn :> Nil) == (f x1 :> f x2 :> ... :> f xn :> Nil)+--+-- and corresponds to the following circuit layout:+--+-- <<doc/map.svg>>+map :: (a -> b) -> Vec n a -> Vec n b+map _ Nil           = Nil+map f (x `Cons` xs) = f x `Cons` map f xs+{-# OPAQUE map #-}+{-# ANN map hasBlackBox #-}++-- | Apply a function of every element of a vector and its index.+--+-- >>> :t imap (+) (2 :> 2 :> 2 :> 2 :> Nil)+-- imap (+) (2 :> 2 :> 2 :> 2 :> Nil) :: Vec 4 (Index 4)+-- >>> imap (+) (2 :> 2 :> 2 :> 2 :> Nil)+-- 2 :> 3 :> *** Exception: X: Clash.Sized.Index: result 4 is out of bounds: [0..3]+-- ...+-- >>> imap (\i a -> extend (bitCoerce i) + a) (2 :> 2 :> 2 :> 2 :> Nil) :: Vec 4 (Unsigned 8)+-- 2 :> 3 :> 4 :> 5 :> Nil+--+-- \"'imap' @f xs@\" corresponds to the following circuit layout:+--+-- <<doc/imap.svg>>+imap :: forall n a b . KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b+imap f = go 0+  where+    -- NOTE This has a black box called imap_go+    go :: Index n -> Vec m a -> Vec m b+    go _ Nil           = Nil+    go n (x `Cons` xs) = f n x `Cons` go (n+1) xs+{-# OPAQUE imap #-}+{-# ANN imap hasBlackBox #-}++{- | Zip two vectors with a functions that also takes the elements' indices.++>>> izipWith (\i a b -> i + a + b) (2 :> 2 :> Nil)  (3 :> 3:> Nil)+*** Exception: X: Clash.Sized.Index: result 2 is out of bounds: [0..1]+...+>>> izipWith (\i a b -> extend (bitCoerce i) + a + b) (2 :> 2 :> Nil) (3 :> 3 :> Nil) :: Vec 2 (Unsigned 8)+5 :> 6 :> Nil++\"'imap' @f xs@\" corresponds to the following circuit layout:++<<doc/izipWith.svg>>++__NB__: 'izipWith' is /strict/ in its second argument, and /lazy/ in its+third. This matters when 'izipWith' is used in a recursive setting. See+'lazyV' for more information.+-}+izipWith :: KnownNat n => (Index n -> a -> b -> c) -> Vec n a -> Vec n b+         -> Vec n c+izipWith f xs ys = imap (\i -> uncurry (f i)) (zip xs ys)+{-# INLINE izipWith #-}++-- | Right fold (function applied to each element and its index)+--+-- >>> let findLeftmost x xs = ifoldr (\i a b -> if a == x then Just i else b) Nothing xs+-- >>> findLeftmost 3 (1:>3:>2:>4:>3:>5:>6:>Nil)+-- Just 1+-- >>> findLeftmost 8 (1:>3:>2:>4:>3:>5:>6:>Nil)+-- Nothing+--+-- \"'ifoldr' @f z xs@\" corresponds to the following circuit layout:+--+-- <<doc/ifoldr.svg>>+ifoldr :: KnownNat n => (Index n -> a -> b -> b) -> b -> Vec n a -> b+ifoldr f z xs = head ws+  where+    ws = izipWith f xs ((tail ws)) :< z+{-# INLINE ifoldr #-}++-- | Left fold (function applied to each element and its index)+--+-- >>> let findRightmost x xs = ifoldl (\a i b -> if b == x then Just i else a) Nothing xs+-- >>> findRightmost 3 (1:>3:>2:>4:>3:>5:>6:>Nil)+-- Just 4+-- >>> findRightmost 8 (1:>3:>2:>4:>3:>5:>6:>Nil)+-- Nothing+--+-- \"'ifoldl' @f z xs@\" corresponds to the following circuit layout:+--+-- <<doc/ifoldl.svg>>+ifoldl :: KnownNat n => (a -> Index n -> b -> a) -> a -> Vec n b -> a+ifoldl f z xs = last ws+  where+    ws = z `Cons` izipWith (\i b a -> f a i b) xs (init ws)+{-# INLINE ifoldl #-}++-- | Generate a vector of indices.+--+-- >>> indices d4+-- 0 :> 1 :> 2 :> 3 :> Nil+indices :: KnownNat n => SNat n -> Vec n (Index n)+indices _ = indicesI+{-# INLINE indices #-}++-- | Generate a vector of indices, where the length of the vector is determined+-- by the context.+--+-- >>> indicesI :: Vec 4 (Index 4)+-- 0 :> 1 :> 2 :> 3 :> Nil+indicesI :: KnownNat n => Vec n (Index n)+indicesI = imap const (repeat ())+{-# INLINE indicesI #-}++-- | \"'findIndex' @p xs@\" returns the index of the /first/ element of /xs/+-- satisfying the predicate /p/, or 'Nothing' if there is no such element.+--+-- >>> findIndex (> 3) (1:>3:>2:>4:>3:>5:>6:>Nil)+-- Just 3+-- >>> findIndex (> 8) (1:>3:>2:>4:>3:>5:>6:>Nil)+-- Nothing+findIndex :: KnownNat n => (a -> Bool) -> Vec n a -> Maybe (Index n)+findIndex f = ifoldr (\i a b -> if f a then Just i else b) Nothing+{-# INLINE findIndex #-}++-- | \"'elemIndex' @a xs@\" returns the index of the /first/ element which is+-- equal (by '==') to the query element /a/, or 'Nothing' if there is no such+-- element.+--+-- >>> elemIndex 3 (1:>3:>2:>4:>3:>5:>6:>Nil)+-- Just 1+-- >>> elemIndex 8 (1:>3:>2:>4:>3:>5:>6:>Nil)+-- Nothing+elemIndex :: (KnownNat n, Eq a) => a -> Vec n a -> Maybe (Index n)+elemIndex x = findIndex (x ==)+{-# INLINE elemIndex #-}++-- | 'zipWith' generalizes 'zip' by zipping with the function given+-- as the first argument, instead of a tupling function.+-- For example, \"'zipWith' @(+)@\" applied to two vectors produces the+-- vector of corresponding sums.+--+-- > zipWith f (x1 :> x2 :> ... xn :> Nil) (y1 :> y2 :> ... :> yn :> Nil) == (f x1 y1 :> f x2 y2 :> ... :> f xn yn :> Nil)+--+-- \"'zipWith' @f xs ys@\" corresponds to the following circuit layout:+--+-- <<doc/zipWith.svg>>+--+-- __NB__: 'zipWith' is /strict/ in its second argument, and /lazy/ in its+-- third. This matters when 'zipWith' is used in a recursive setting. See+-- 'lazyV' for more information.+zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c+zipWith _ Nil           _  = Nil+zipWith f (x `Cons` xs) ys = f x (head ys) `Cons` zipWith f xs (tail ys)+{-# OPAQUE zipWith #-}+{-# ANN zipWith hasBlackBox #-}++-- | 'zipWith3' generalizes 'zip3' by zipping with the function given+-- as the first argument, instead of a tupling function.+--+-- > zipWith3 f (x1 :> x2 :> ... xn :> Nil) (y1 :> y2 :> ... :> yn :> Nil) (z1 :> z2 :> ... :> zn :> Nil) == (f x1 y1 z1 :> f x2 y2 z2 :> ... :> f xn yn zn :> Nil)+--+-- \"'zipWith3' @f xs ys zs@\" corresponds to the following circuit layout:+--+-- <<doc/zipWith3.svg>>+--+-- __NB__: 'zipWith3' is /strict/ in its second argument, and /lazy/ in its+-- third and fourth. This matters when 'zipWith3' is used in a recursive setting.+-- See 'lazyV' for more information.+zipWith3 :: (a -> b -> c -> d) -> Vec n a -> Vec n b -> Vec n c -> Vec n d+zipWith3 f us vs ws = zipWith (\a (b,c) -> f a b c) us (zip vs ws)+{-# INLINE zipWith3 #-}++-- 'zipWith4' is analogous to 'zipWith3', but with four vectors.+--+-- __NB__: 'zipWith4' is /strict/ in its second argument, and /lazy/ its following+-- arguments. This matters when 'zipWith4' is used in a recursive setting. See+-- 'lazyV' for more information.+zipWith4+  :: (a -> b -> c -> d -> e)+  -> Vec n a+  -> Vec n b+  -> Vec n c+  -> Vec n d+  -> Vec n e+zipWith4 f us vs ws xs =+  zipWith (\a (b,c,d) -> f a b c d) us (zip3 vs ws xs)+{-# INLINE zipWith4 #-}++-- 'zipWith5' is analogous to 'zipWith3', but with five vectors.+--+-- __NB__: 'zipWith5' is /strict/ in its second argument, and /lazy/ its following+-- arguments. This matters when 'zipWith5' is used in a recursive setting. See+-- 'lazyV' for more information.+zipWith5+  :: (a -> b -> c -> d -> e -> f)+  -> Vec n a+  -> Vec n b+  -> Vec n c+  -> Vec n d+  -> Vec n e+  -> Vec n f+zipWith5 f us vs ws xs ys =+  zipWith (\a (b,c,d,e) -> f a b c d e) us (zip4 vs ws xs ys)+{-# INLINE zipWith5 #-}++-- 'zipWith6' is analogous to 'zipWith3', but with six vectors.+--+-- __NB__: 'zipWith6' is /strict/ in its second argument, and /lazy/ its following+-- arguments. This matters when 'zipWith6' is used in a recursive setting. See+-- 'lazyV' for more information.+zipWith6+  :: (a -> b -> c -> d -> e -> f -> g)+  -> Vec n a+  -> Vec n b+  -> Vec n c+  -> Vec n d+  -> Vec n e+  -> Vec n f+  -> Vec n g+zipWith6 f us vs ws xs ys zs =+  zipWith (\u (v,w,x,y,z) -> f u v w x y z) us (zip5 vs ws xs ys zs)+{-# INLINE zipWith6 #-}++-- 'zipWith7' is analogous to 'zipWith3', but with seven vectors.+--+-- __NB__: 'zipWith7' is /strict/ in its second argument, and /lazy/ its following+-- arguments. This matters when 'zipWith7' is used in a recursive setting. See+-- 'lazyV' for more information.+zipWith7+  :: (a -> b -> c -> d -> e -> f -> g -> h)+  -> Vec n a+  -> Vec n b+  -> Vec n c+  -> Vec n d+  -> Vec n e+  -> Vec n f+  -> Vec n g+  -> Vec n h+zipWith7 f ts us vs ws xs ys zs =+  zipWith (\t (u,v,w,x,y,z) -> f t u v w x y z) ts (zip6 us vs ws xs ys zs)+{-# INLINE zipWith7 #-}++-- | 'foldr', applied to a binary operator, a starting value (typically+-- the right-identity of the operator), and a vector, reduces the vector+-- using the binary operator, from right to left:+--+-- > foldr f z (x1 :> ... :> xn1 :> xn :> Nil) == x1 `f` (... (xn1 `f` (xn `f` z))...)+-- > foldr r z Nil                             == z+--+-- >>> foldr (/) 1 (5 :> 4 :> 3 :> 2 :> Nil)+-- 1.875+--+-- \"'foldr' @f z xs@\" corresponds to the following circuit layout:+--+-- <<doc/foldr.svg>>+--+-- __NB__: @"'foldr' f z xs"@ produces a linear structure, which has a depth, or+-- delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is+-- associative, as @"'fold' f xs"@ produces a structure with a depth of+-- O(log_2(@'length' xs@)).+foldr :: (a -> b -> b) -> b -> Vec n a -> b+foldr _ z Nil           = z+foldr f z (x `Cons` xs) = f x (foldr f z xs)+{-# OPAQUE foldr #-}+{-# ANN foldr hasBlackBox #-}++-- | 'foldl', applied to a binary operator, a starting value (typically+-- the left-identity of the operator), and a vector, reduces the vector+-- using the binary operator, from left to right:+--+-- > foldl f z (x1 :> x2 :> ... :> xn :> Nil) == (...((z `f` x1) `f` x2) `f`...) `f` xn+-- > foldl f z Nil                            == z+--+-- >>> foldl (/) 1 (5 :> 4 :> 3 :> 2 :> Nil)+-- 8.333333333333333e-3+--+-- \"'foldl' @f z xs@\" corresponds to the following circuit layout:+--+-- <<doc/foldl.svg>>+--+-- __NB__: @"'foldl' f z xs"@ produces a linear structure, which has a depth, or+-- delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is+-- associative, as @"'fold' f xs"@ produces a structure with a depth of+-- O(log_2(@'length' xs@)).+foldl :: forall b a n . (b -> a -> b) -> b -> Vec n a -> b+foldl f z0 xs0+  -- We use 'go' to make 'foldl' strict during Haskell simulation, while using+  -- 'scanl' to make Clash's life easier during normalization. We make 'foldl'+  -- strict due to similar reasoning to:+  --+  --   https://well-typed.com/blog/90/+  --+  -- Also see:+  --+  --   https://github.com/hasura/graphql-engine/pull/2933#discussion_r328821960+  --+  | clashSimulation = go z0 xs0+  | otherwise = last (scanl f z0 xs0)+ where+  go :: forall m. b -> Vec m a -> b+  go z Nil = z+  go z (Cons x xs) =+    let z1 = f z x+    in z1 `seq` go z1 xs+{-# INLINE foldl #-}++-- | 'foldr1' is a variant of 'foldr' that has no starting value argument,+-- and thus must be applied to non-empty vectors.+--+-- > foldr1 f (x1 :> ... :> xn2 :> xn1 :> xn :> Nil) == x1 `f` (... (xn2 `f` (xn1 `f` xn))...)+-- > foldr1 f (x1 :> Nil)                            == x1+-- > foldr1 f Nil                                    == TYPE ERROR+--+-- >>> foldr1 (/) (5 :> 4 :> 3 :> 2 :> 1 :> Nil)+-- 1.875+--+-- \"'foldr1' @f xs@\" corresponds to the following circuit layout:+--+-- <<doc/foldr1.svg>>+--+-- __NB__: @"'foldr1' f z xs"@ produces a linear structure, which has a depth,+-- or delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is+-- associative, as @"'fold' f xs"@ produces a structure with a depth of+-- O(log_2(@'length' xs@)).+foldr1 :: (a -> a -> a) -> Vec (n + 1) a -> a+foldr1 f xs = foldr f (last xs) (init xs)+{-# INLINE foldr1 #-}++-- | 'foldl1' is a variant of 'foldl' that has no starting value argument,+-- and thus must be applied to non-empty vectors.+--+-- > foldl1 f (x1 :> x2 :> x3 :> ... :> xn :> Nil) == (...((x1 `f` x2) `f` x3) `f`...) `f` xn+-- > foldl1 f (x1 :> Nil)                          == x1+-- > foldl1 f Nil                                  == TYPE ERROR+--+-- >>> foldl1 (/) (1 :> 5 :> 4 :> 3 :> 2 :> Nil)+-- 8.333333333333333e-3+--+-- \"'foldl1' @f xs@\" corresponds to the following circuit layout:+--+-- <<doc/foldl1.svg>>+--+-- __NB__: @"'foldl1' f z xs"@ produces a linear structure, which has a depth,+-- or delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is+-- associative, as @"'fold' f xs"@ produces a structure with a depth of+-- O(log_2(@'length' xs@)).+foldl1 :: (a -> a -> a) -> Vec (n + 1) a -> a+foldl1 f xs = foldl f (head xs) (tail xs)+{-# INLINE foldl1 #-}++-- | 'fold' is a variant of 'foldr1' and 'foldl1', but instead of reducing from+-- right to left, or left to right, it reduces a vector using a tree-like+-- structure. The depth, or delay, of the structure produced by+-- \"@'fold' f xs@\", is hence @O(log_2('length' xs))@, and not+-- @O('length' xs)@.+--+-- __NB__: The binary operator \"@f@\" in \"@'fold' f xs@\" must be associative.+--+-- > fold f (x1 :> x2 :> ... :> xn1 :> xn :> Nil) == ((x1 `f` x2) `f` ...) `f` (... `f` (xn1 `f` xn))+-- > fold f (x1 :> Nil)                           == x1+-- > fold f Nil                                   == TYPE ERROR+--+-- >>> fold (+) (5 :> 4 :> 3 :> 2 :> 1 :> Nil)+-- 15+--+-- \"'fold' @f xs@\" corresponds to the following circuit layout:+--+-- <<doc/fold.svg>>+fold :: forall n a . (a -> a -> a) -> Vec (n + 1) a -> a+fold f vs = fold' (toList vs)+  where+    fold' [x] = x+    fold' xs  = fold' ys `f` fold' zs+      where+        (ys,zs) = P.splitAt (P.length xs `div` 2) xs+{-# OPAQUE fold #-}+{-# ANN fold (InlineYamlPrimitive [VHDL,Verilog,SystemVerilog] [I.__i|+  BlackBoxHaskell:+    name: Clash.Sized.Vector.fold+    templateFunction: Clash.Primitives.Sized.Vector.foldBBF+  |]) #-}++-- | 'scanl' is similar to 'foldl', but returns a vector of successive reduced+-- values from the left:+--+-- > scanl f z (x1 :> x2 :> ... :> Nil) == z :> (z `f` x1) :> ((z `f` x1) `f` x2) :> ... :> Nil+--+-- >>> scanl (+) 0 (5 :> 4 :> 3 :> 2 :> Nil)+-- 0 :> 5 :> 9 :> 12 :> 14 :> Nil+--+-- \"'scanl' @f z xs@\" corresponds to the following circuit layout:+--+-- <<doc/scanl.svg>>+--+-- * __NB__:+--+--     > last (scanl f z xs) == foldl f z xs+--+-- * For a different trade-off between circuit size and logic depth for+-- associative operators, see "Clash.Sized.RTree#scans"+scanl :: (b -> a -> b) -> b -> Vec n a -> Vec (n + 1) b+scanl f z xs = ws+  where+    ws = z `Cons` zipWith (flip f) xs (init ws)+{-# INLINE scanl #-}++-- | 'scanl' with no seed value+--+-- >>> scanl1 (-) (1 :> 2 :> 3 :> 4 :> Nil)+-- 1 :> -1 :> -4 :> -8 :> Nil+scanl1 :: forall n a. (a -> a -> a) -> Vec (n+1) a -> Vec (n+1) a+scanl1 op vs = scanl op (head vs) (tail vs)+{-# INLINE scanl1 #-}++-- | 'scanr' with no seed value+--+-- >>> scanr1 (-) (1 :> 2 :> 3 :> 4 :> Nil)+-- -2 :> 3 :> -1 :> 4 :> Nil+scanr1 :: forall n a. (a -> a -> a) -> Vec (n+1) a -> Vec (n+1) a+scanr1 op vs = scanr op (last vs) (init vs)+{-# INLINE scanr1 #-}++-- | 'postscanl' is a variant of 'scanl' where the first result is dropped:+--+-- > postscanl f z (x1 :> x2 :> ... :> Nil) == (z `f` x1) :> ((z `f` x1) `f` x2) :> ... :> Nil+--+-- >>> postscanl (+) 0 (5 :> 4 :> 3 :> 2 :> Nil)+-- 5 :> 9 :> 12 :> 14 :> Nil+--+-- \"'postscanl' @f z xs@\" corresponds to the following circuit layout:+--+-- <<doc/sscanl.svg>>+postscanl :: (b -> a -> b) -> b -> Vec n a -> Vec n b+postscanl f z xs = tail (scanl f z xs)+{-# INLINE postscanl #-}++-- | 'scanr' is similar to 'foldr', but returns a vector of successive reduced+-- values from the right:+--+-- > scanr f z (... :> xn1 :> xn :> Nil) == ... :> (xn1 `f` (xn `f` z)) :> (xn `f` z) :> z :> Nil+--+-- >>> scanr (+) 0 (5 :> 4 :> 3 :> 2 :> Nil)+-- 14 :> 9 :> 5 :> 2 :> 0 :> Nil+--+-- \"'scanr' @f z xs@\" corresponds to the following circuit layout:+--+-- <<doc/scanr.svg>>+--+-- * __NB__:+--+--     > head (scanr f z xs) == foldr f z xs+--+-- * For a different trade-off between circuit size and logic depth for+-- associative operators, see "Clash.Sized.RTree#scans"+scanr :: (a -> b -> b) -> b -> Vec n a -> Vec (n + 1) b+scanr f z xs = ws+  where+    ws = zipWith f xs ((tail ws)) :< z+{-# INLINE scanr #-}++-- | 'postscanr' is a variant of 'scanr' that where the last result is dropped:+--+-- > postscanr f z (... :> xn1 :> xn :> Nil) == ... :> (xn1 `f` (xn `f` z)) :> (xn `f` z) :> Nil+--+-- >>> postscanr (+) 0 (5 :> 4 :> 3 :> 2 :> Nil)+-- 14 :> 9 :> 5 :> 2 :> Nil+--+-- \"'postscanr' @f z xs@\" corresponds to the following circuit layout:+--+-- <<doc/sscanr.svg>>+postscanr :: (a -> b -> b) -> b -> Vec n a -> Vec n b+postscanr f z xs = init (scanr f z xs)+{-# INLINE postscanr #-}++-- | The 'mapAccumL' function behaves like a combination of 'map' and 'foldl';+-- it applies a function to each element of a vector, passing an accumulating+-- parameter from left to right, and returning a final value of this accumulator+-- together with the new vector.+--+-- >>> mapAccumL (\acc x -> (acc + x,acc + 1)) 0 (1 :> 2 :> 3 :> 4 :> Nil)+-- (10,1 :> 2 :> 4 :> 7 :> Nil)+--+-- \"'mapAccumL' @f acc xs@\" corresponds to the following circuit layout:+--+-- <<doc/mapAccumL.svg>>+mapAccumL :: (acc -> x -> (acc,y)) -> acc -> Vec n x -> (acc,Vec n y)+mapAccumL f acc xs = (acc',ys)+  where+    accs        = acc `Cons` accs'+    ws          = zipWith (flip f) xs (init accs)+    (accs', ys) = unzip ws+    acc'        = last accs+{-# INLINE mapAccumL #-}++-- | The 'mapAccumR' function behaves like a combination of 'map' and 'foldr';+-- it applies a function to each element of a vector, passing an accumulating+-- parameter from right to left, and returning a final value of this accumulator+-- together with the new vector.+--+-- >>> mapAccumR (\acc x -> (acc + x,acc + 1)) 0 (1 :> 2 :> 3 :> 4 :> Nil)+-- (10,10 :> 8 :> 5 :> 1 :> Nil)+--+-- \"'mapAccumR' @f acc xs@\" corresponds to the following circuit layout:+--+-- <<doc/mapAccumR.svg>>+mapAccumR :: (acc -> x -> (acc,y)) -> acc -> Vec n x -> (acc, Vec n y)+mapAccumR f acc xs = (acc',ys)+  where+    accs        = accs' :< acc+    ws          = zipWith (flip f) xs (tail accs)+    (accs', ys) = unzip ws+    acc'        = head accs+{-# INLINE mapAccumR #-}++-- | 'zip' takes two vectors and returns a vector of corresponding pairs.+--+-- >>> zip (1:>2:>3:>4:>Nil) (4:>3:>2:>1:>Nil)+-- (1,4) :> (2,3) :> (3,2) :> (4,1) :> Nil+zip :: Vec n a -> Vec n b -> Vec n (a,b)+zip = zipWith (,)+{-# INLINE zip #-}++-- | 'zip3' takes three vectors and returns a vector of corresponding triplets.+--+-- >>> zip3 (1:>2:>3:>4:>Nil) (4:>3:>2:>1:>Nil) (5:>6:>7:>8:>Nil)+-- (1,4,5) :> (2,3,6) :> (3,2,7) :> (4,1,8) :> Nil+zip3 :: Vec n a -> Vec n b -> Vec n c -> Vec n (a,b,c)+zip3 = zipWith3 (,,)+{-# INLINE zip3 #-}++-- | 'zip4' takes four vectors and returns a list of quadruples, analogous+-- to 'zip'.+zip4 :: Vec n a -> Vec n b -> Vec n c -> Vec n d -> Vec n (a,b,c,d)+zip4 = zipWith4 (,,,)+{-# INLINE zip4 #-}++-- | 'zip5' takes five vectors and returns a list of five-tuples, analogous+-- to 'zip'.+zip5 :: Vec n a -> Vec n b -> Vec n c -> Vec n d -> Vec n e -> Vec n (a,b,c,d,e)+zip5 = zipWith5 (,,,,)+{-# INLINE zip5 #-}++-- | 'zip6' takes six vectors and returns a list of six-tuples, analogous+-- to 'zip'.+zip6+  :: Vec n a+  -> Vec n b+  -> Vec n c+  -> Vec n d+  -> Vec n e+  -> Vec n f+  -> Vec n (a,b,c,d,e,f)+zip6 = zipWith6 (,,,,,)+{-# INLINE zip6 #-}++-- | 'zip7' takes seven vectors and returns a list of seven-tuples, analogous+-- to 'zip'.+zip7+  :: Vec n a+  -> Vec n b+  -> Vec n c+  -> Vec n d+  -> Vec n e+  -> Vec n f+  -> Vec n g+  -> Vec n (a,b,c,d,e,f,g)+zip7 = zipWith7 (,,,,,,)+{-# INLINE zip7 #-}++-- | 'unzip' transforms a vector of pairs into a vector of first components+-- and a vector of second components.+--+-- >>> unzip ((1,4):>(2,3):>(3,2):>(4,1):>Nil)+-- (1 :> 2 :> 3 :> 4 :> Nil,4 :> 3 :> 2 :> 1 :> Nil)+unzip :: Vec n (a,b) -> (Vec n a, Vec n b)+unzip xs+  | clashSimulation = unzipSim xs+  | otherwise = (map fst xs, map snd xs)+ where+  unzipSim :: Vec m (a,b) -> (Vec m a, Vec m b)+  unzipSim Nil = (Nil, Nil)+  unzipSim (~(a,b) `Cons` rest) =+    let (as, bs) = unzipSim rest+    in (a `Cons` as, b `Cons` bs)+{-# INLINE unzip #-}++-- | 'unzip3' transforms a vector of triplets into a vector of first components,+-- a vector of second components, and a vector of third components.+--+-- >>> unzip3 ((1,4,5):>(2,3,6):>(3,2,7):>(4,1,8):>Nil)+-- (1 :> 2 :> 3 :> 4 :> Nil,4 :> 3 :> 2 :> 1 :> Nil,5 :> 6 :> 7 :> 8 :> Nil)+unzip3 :: Vec n (a,b,c) -> (Vec n a, Vec n b, Vec n c)+unzip3 xs+  | clashSimulation = unzip3Sim xs+  | otherwise = ( map (\(x,_,_) -> x) xs+                , map (\(_,y,_) -> y) xs+                , map (\(_,_,z) -> z) xs+                )+ where+  unzip3Sim :: Vec m (a,b,c) -> (Vec m a, Vec m b, Vec m c)+  unzip3Sim Nil = (Nil, Nil, Nil)+  unzip3Sim (~(a,b,c) `Cons` rest) =+    let (as, bs, cs) = unzip3Sim rest+    in (a `Cons` as, b `Cons` bs, c `Cons` cs)+{-# INLINE unzip3 #-}++-- | 'unzip4' takes a vector of quadruples and returns four vectors, analogous+-- to 'unzip'.+unzip4 :: Vec n (a,b,c,d) -> (Vec n a, Vec n b, Vec n c, Vec n d)+unzip4 xs+  | clashSimulation = unzip4Sim xs+  | otherwise = ( map (\(w,_,_,_) -> w) xs+                , map (\(_,x,_,_) -> x) xs+                , map (\(_,_,y,_) -> y) xs+                , map (\(_,_,_,z) -> z) xs+                )+ where+  unzip4Sim :: Vec m (a,b,c,d) -> (Vec m a, Vec m b, Vec m c, Vec m d)+  unzip4Sim Nil = (Nil, Nil, Nil, Nil)+  unzip4Sim (~(a,b,c,d) `Cons` rest) =+    let (as, bs, cs, ds) = unzip4Sim rest+    in (a `Cons` as, b `Cons` bs, c `Cons` cs, d `Cons` ds)+{-# INLINE unzip4 #-}++-- | 'unzip5' takes a vector of five-tuples and returns five vectors, analogous+-- to 'unzip'.+unzip5 :: Vec n (a,b,c,d,e) -> (Vec n a, Vec n b, Vec n c, Vec n d, Vec n e)+unzip5 xs+  | clashSimulation = unzip5Sim xs+  | otherwise = ( map (\(v,_,_,_,_) -> v) xs+                , map (\(_,w,_,_,_) -> w) xs+                , map (\(_,_,x,_,_) -> x) xs+                , map (\(_,_,_,y,_) -> y) xs+                , map (\(_,_,_,_,z) -> z) xs+                )+ where+  unzip5Sim :: Vec m (a,b,c,d,e) -> (Vec m a, Vec m b, Vec m c, Vec m d, Vec m e)+  unzip5Sim Nil = (Nil, Nil, Nil, Nil, Nil)+  unzip5Sim (~(a,b,c,d,e) `Cons` rest) =+    let (as, bs, cs, ds, es) = unzip5Sim rest+    in (a `Cons` as, b `Cons` bs, c `Cons` cs, d `Cons` ds, e `Cons` es)+{-# INLINE unzip5 #-}++-- | 'unzip6' takes a vector of six-tuples and returns six vectors, analogous+-- to 'unzip'.+unzip6+  :: Vec n (a,b,c,d,e,f)+  -> (Vec n a, Vec n b, Vec n c, Vec n d, Vec n e, Vec n f)+unzip6 xs+  | clashSimulation = unzip6Sim xs+  | otherwise = ( map (\(u,_,_,_,_,_) -> u) xs+                , map (\(_,v,_,_,_,_) -> v) xs+                , map (\(_,_,w,_,_,_) -> w) xs+                , map (\(_,_,_,x,_,_) -> x) xs+                , map (\(_,_,_,_,y,_) -> y) xs+                , map (\(_,_,_,_,_,z) -> z) xs+                )+ where+  unzip6Sim :: Vec m (a,b,c,d,e,f) -> (Vec m a, Vec m b, Vec m c, Vec m d, Vec m e, Vec m f)+  unzip6Sim Nil = (Nil, Nil, Nil, Nil, Nil, Nil)+  unzip6Sim (~(a,b,c,d,e,f) `Cons` rest) =+    let (as, bs, cs, ds, es, fs) = unzip6Sim rest+    in (a `Cons` as, b `Cons` bs, c `Cons` cs, d `Cons` ds, e `Cons` es, f `Cons` fs)+{-# INLINE unzip6 #-}++-- | 'unzip7' takes a vector of seven-tuples and returns seven vectors, analogous+-- to 'unzip'.+unzip7+  :: Vec n (a,b,c,d,e,f,g)+  -> (Vec n a, Vec n b, Vec n c, Vec n d, Vec n e, Vec n f, Vec n g)+unzip7 xs+  | clashSimulation = unzip7Sim xs+  | otherwise = ( map (\(t,_,_,_,_,_,_) -> t) xs+                , map (\(_,u,_,_,_,_,_) -> u) xs+                , map (\(_,_,v,_,_,_,_) -> v) xs+                , map (\(_,_,_,w,_,_,_) -> w) xs+                , map (\(_,_,_,_,x,_,_) -> x) xs+                , map (\(_,_,_,_,_,y,_) -> y) xs+                , map (\(_,_,_,_,_,_,z) -> z) xs+                )+ where+  unzip7Sim :: Vec m (a,b,c,d,e,f,g) -> (Vec m a, Vec m b, Vec m c, Vec m d, Vec m e, Vec m f, Vec m g)+  unzip7Sim Nil = (Nil, Nil, Nil, Nil, Nil, Nil, Nil)+  unzip7Sim (~(a,b,c,d,e,f,g) `Cons` rest) =+    let (as, bs, cs, ds, es, fs, gs) = unzip7Sim rest+    in (a `Cons` as, b `Cons` bs, c `Cons` cs, d `Cons` ds, e `Cons` es, f `Cons` fs, g `Cons` gs)+{-# INLINE unzip7 #-}+++index_int :: KnownNat n => Vec n a -> Int -> a+index_int xs i@(I# n0)+  | isTrue# (n0 <# 0#) = error "Clash.Sized.Vector.(!!): negative index"+  | otherwise          = sub xs n0+  where+    sub :: Vec m a -> Int# -> a+    sub Nil     _ = error (P.concat [ "Clash.Sized.Vector.(!!): index "+                                    , show i+                                    , " is larger than maximum index "+                                    , show ((length xs)-1)+                                    ])+    sub (y `Cons` (!ys)) n = if isTrue# (n ==# 0#)+                                then y+                                else sub ys (n -# 1#)+{-# OPAQUE index_int #-}+{-# ANN index_int hasBlackBox #-}++-- | \"@xs@ '!!' @n@\" returns the /n/'th element of /xs/.+--+-- __NB__: Vector elements have an __ASCENDING__ subscript starting from 0 and+-- ending at @'length' - 1@.+--+-- >>> (1:>2:>3:>4:>5:>Nil) !! 4+-- 5+-- >>> (1:>2:>3:>4:>5:>Nil) !! (length (1:>2:>3:>4:>5:>Nil) - 1)+-- 5+-- >>> (1:>2:>3:>4:>5:>Nil) !! 1+-- 2+-- >>> (1:>2:>3:>4:>5:>Nil) !! 14+-- *** Exception: Clash.Sized.Vector.(!!): index 14 is larger than maximum index 4+-- ...+(!!) :: (KnownNat n, Enum i) => Vec n a -> i -> a+xs !! i = index_int xs (fromEnum i)+{-# INLINE (!!) #-}++-- | The length of a 'Vec'tor as an 'Int' value.+--+-- >>> length (6 :> 7 :> 8 :> Nil)+-- 3+length :: KnownNat n => Vec n a -> Int+length = fromInteger . natVal . asNatProxy+{-# OPAQUE length #-}+{-# ANN length hasBlackBox #-}++replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a+replace_int xs i@(I# n0) a+  | isTrue# (n0 <# 0#) = error "Clash.Sized.Vector.replace: negative index"+  | otherwise          = sub xs n0 a+  where+    sub :: Vec m b -> Int# -> b -> Vec m b+    sub Nil     _ _ = error (P.concat [ "Clash.Sized.Vector.replace: index "+                                      , show i+                                      , " is out of bounds: "+                                      , if length xs == 0+                                         then "<empty range>"+                                         else "[0.." <> show (length xs - 1) <> "]"+                                      ])+    sub (y `Cons` (!ys)) n b = if isTrue# (n ==# 0#)+                                 then b `Cons` ys+                                 else y `Cons` sub ys (n -# 1#) b+{-# OPAQUE replace_int #-}+{-# ANN replace_int hasBlackBox #-}++-- | \"'replace' @n a xs@\" returns the vector /xs/ where the /n/'th element is+-- replaced by /a/.+--+-- __NB__: Vector elements have an __ASCENDING__ subscript starting from 0 and+-- ending at @'length' - 1@.+--+-- >>> replace 3 7 (1:>2:>3:>4:>5:>Nil)+-- 1 :> 2 :> 3 :> 7 :> 5 :> Nil+-- >>> replace 0 7 (1:>2:>3:>4:>5:>Nil)+-- 7 :> 2 :> 3 :> 4 :> 5 :> Nil+-- >>> replace 9 7 (1:>2:>3:>4:>5:>Nil)+-- 1 :> 2 :> 3 :> 4 :> 5 :> *** Exception: Clash.Sized.Vector.replace: index 9 is out of bounds: [0..4]+-- ...+replace :: (KnownNat n, Enum i) => i -> a -> Vec n a -> Vec n a+replace i y xs = replace_int xs (fromEnum i) y+{-# INLINE replace #-}++{- | \"'take' @n xs@\" returns the /n/-length prefix of /xs/.++>>> take (SNat :: SNat 3) (1:>2:>3:>4:>5:>Nil)+1 :> 2 :> 3 :> Nil+>>> take d3               (1:>2:>3:>4:>5:>Nil)+1 :> 2 :> 3 :> Nil+>>> take d0               (1:>2:>Nil)+Nil++#if __GLASGOW_HASKELL__ >= 910+>>> take d4               (1:>2:>Nil)+<interactive>:...+    • Couldn't match type ‘4 + n0’ with ‘2’+      Expected: Vec (4 + n0) a+        Actual: Vec (1 + 1) a+      The type variable ‘n0’ is ambiguous+    • In the second argument of ‘take’, namely ‘(1 :> 2 :> Nil)’+      In the expression: take d4 (1 :> 2 :> Nil)+      In an equation for ‘it’: it = take d4 (1 :> 2 :> Nil)+<BLANKLINE>++#elif __GLASGOW_HASKELL__ == 906+>>> take d4               (1:>2:>Nil)+<BLANKLINE>+<interactive>:...+    • Couldn't match type ‘4 + n0’ with ‘2’+      Expected: Vec (4 + n0) a+        Actual: Vec (1 + 1) a+        The type variable ‘n0’ is ambiguous+    • In the second argument of ‘take’, namely ‘(1 :> 2 :> Nil)’+      In the expression: take d4 (1 :> 2 :> Nil)+      In an equation for ‘it’: it = take d4 (1 :> 2 :> Nil)++#else+>>> take d4               (1:>2:>Nil)+<BLANKLINE>+<interactive>:...+    • Couldn't match type ‘4 + n0’ with ‘2’+      Expected: Vec (4 + n0) a+        Actual: Vec (1 + 1) a+      The type variable ‘n0’ is ambiguous+    • In the second argument of ‘take’, namely ‘(1 :> 2 :> Nil)’+      In the expression: take d4 (1 :> 2 :> Nil)+      In an equation for ‘it’: it = take d4 (1 :> 2 :> Nil)++#endif+-}+take :: SNat m -> Vec (m + n) a -> Vec m a+take n = fst . splitAt n+{-# INLINE take #-}++-- | \"'takeI' @xs@\" returns the prefix of /xs/ as demanded by the context.+--+-- >>> takeI (1:>2:>3:>4:>5:>Nil) :: Vec 2 Int+-- 1 :> 2 :> Nil+takeI :: KnownNat m => Vec (m + n) a -> Vec m a+takeI = withSNat take+{-# INLINE takeI #-}++{- | \"'drop' @n xs@\" returns the suffix of /xs/ after the first /n/ elements.++>>> drop (SNat :: SNat 3) (1:>2:>3:>4:>5:>Nil)+4 :> 5 :> Nil+>>> drop d3               (1:>2:>3:>4:>5:>Nil)+4 :> 5 :> Nil+>>> drop d0               (1:>2:>Nil)+1 :> 2 :> Nil++#if __GLASGOW_HASKELL__ >= 910+>>> drop d4               (1:>2:>Nil)+<interactive>:...: error:...+    • Couldn't match...type ‘4 + n0...+      The type variable ‘n0’ is ambiguous+    • In the first argument of ‘print’, namely ‘it’+      In a stmt of an interactive GHCi command: print it+<BLANKLINE>++#elif __GLASGOW_HASKELL__ == 906+>>> drop d4               (1:>2:>Nil)+<BLANKLINE>+<interactive>:...: error:...+    • Couldn't match...type ‘4 + n0...+        The type variable ‘n0’ is ambiguous+    • In the first argument of ‘print’, namely ‘it’+      In a stmt of an interactive GHCi command: print it++#else+>>> drop d4               (1:>2:>Nil)+<BLANKLINE>+<interactive>:...: error:...+    • Couldn't match...type ‘4 + n0...+      The type variable ‘n0’ is ambiguous+    • In the first argument of ‘print’, namely ‘it’+      In a stmt of an interactive GHCi command: print it++#endif+-}+drop :: SNat m -> Vec (m + n) a -> Vec n a+drop n = snd . splitAt n+{-# INLINE drop #-}++-- | \"'dropI' @xs@\" returns the suffix of /xs/ as demanded by the context.+--+-- >>> dropI (1:>2:>3:>4:>5:>Nil) :: Vec 2 Int+-- 4 :> 5 :> Nil+dropI :: KnownNat m => Vec (m + n) a -> Vec n a+dropI = withSNat drop+{-# INLINE dropI #-}++-- | \"'at' @n xs@\" returns /n/'th element of /xs/+--+-- __NB__: Vector elements have an __ASCENDING__ subscript starting from 0 and+-- ending at @'length' - 1@.+--+-- >>> at (SNat :: SNat 1) (1:>2:>3:>4:>5:>Nil)+-- 2+-- >>> at d1               (1:>2:>3:>4:>5:>Nil)+-- 2+at :: SNat m -> Vec (m + (n + 1)) a -> a+at n xs = head $ snd $ splitAt n xs+{-# INLINE at #-}++-- | \"'select' @f s n xs@\" selects /n/ elements with step-size /s/ and+-- offset @f@ from /xs/.+--+-- >>> select (SNat :: SNat 1) (SNat :: SNat 2) (SNat :: SNat 3) (1:>2:>3:>4:>5:>6:>7:>8:>Nil)+-- 2 :> 4 :> 6 :> Nil+-- >>> select d1 d2 d3 (1:>2:>3:>4:>5:>6:>7:>8:>Nil)+-- 2 :> 4 :> 6 :> Nil+select :: forall i s n f a. s * n + 1 <= i + s+       => SNat f+       -> SNat s+       -> SNat n+       -> Vec (f + i) a+       -> Vec n a+select f s n xs = select' (toUNat n) $ drop f xs+ where+  select' :: forall m j b. (s * m + 1 <= j + s) => UNat m -> Vec j b -> Vec m b+  select' m vs = case m of+    UZero -> Nil+    USucc UZero -> head @(j - 1) vs `Cons` Nil+    USucc m'@(USucc _) -> case deduce @(s * (m - 1) + 1) @j Proxy Proxy of+      Dict -> head @(j - 1) vs `Cons` select' m' (drop @s @(j - s) s vs)++  deduce :: e + s <= k + s => p e -> p k -> Dict (e <= k)+  deduce _ _ = Dict++{-# OPAQUE select #-}+{-# ANN select hasBlackBox #-}++-- | \"'selectI' @f s xs@\" selects as many elements as demanded by the context+-- with step-size /s/ and offset /f/ from /xs/.+--+-- >>> selectI d1 d2 (1:>2:>3:>4:>5:>6:>7:>8:>Nil) :: Vec 2 Int+-- 2 :> 4 :> Nil+selectI :: (1 <= s, s * n + 1 <= i + s, KnownNat n)+        => SNat f+        -> SNat s+        -> Vec (f + i) a+        -> Vec n a+selectI f s xs = withSNat (\n -> select f s n xs)+{-# INLINE selectI #-}++-- | \"'replicate' @n a@\" returns a vector that has /n/ copies of /a/.+--+-- >>> replicate (SNat :: SNat 3) 6+-- 6 :> 6 :> 6 :> Nil+-- >>> replicate d3 6+-- 6 :> 6 :> 6 :> Nil+replicate :: SNat n -> a -> Vec n a+replicate n a = replicateU (toUNat n) a+{-# OPAQUE replicate #-}+{-# ANN replicate hasBlackBox #-}++replicateU :: UNat n -> a -> Vec n a+replicateU UZero     _ = Nil+replicateU (USucc s) x = x `Cons` replicateU s x++-- | \"'repeat' @a@\" creates a vector with as many copies of /a/ as demanded+-- by the context.+--+-- >>> repeat 6 :: Vec 5 Int+-- 6 :> 6 :> 6 :> 6 :> 6 :> Nil+repeat :: KnownNat n => a -> Vec n a+repeat = withSNat replicate+{-# INLINE repeat #-}++-- | \"'iterate' @n f x@\" returns a vector starting with /x/ followed by+-- /n/ repeated applications of /f/ to /x/.+--+-- > iterate (SNat :: SNat 4) f x == (x :> f x :> f (f x) :> f (f (f x)) :> Nil)+-- > iterate d4 f x               == (x :> f x :> f (f x) :> f (f (f x)) :> Nil)+--+-- >>> iterate d4 (+1) 1+-- 1 :> 2 :> 3 :> 4 :> Nil+--+-- \"'iterate' @n f z@\" corresponds to the following circuit layout:+--+-- <<doc/iterate.svg>>+iterate :: SNat n -> (a -> a) -> a -> Vec n a+iterate SNat = iterateI+{-# INLINE iterate #-}++-- | \"'iterateI' @f x@\" returns a vector starting with @x@ followed by @n@+-- repeated applications of @f@ to @x@, where @n@ is determined by the context.+--+-- > iterateI f x :: Vec 3 a == (x :> f x :> f (f x) :> Nil)+--+-- >>> iterateI (+1) 1 :: Vec 3 Int+-- 1 :> 2 :> 3 :> Nil+--+-- \"'iterateI' @f z@\" corresponds to the following circuit layout:+--+-- <<doc/iterate.svg>>+iterateI :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a+iterateI f = iterateU (toUNat (SNat @n))+ where+  iterateU :: forall m. UNat m -> a -> Vec m a+  iterateU UZero _ = Nil+  iterateU (USucc s) a = a `Cons` iterateU s (f a)+{-# OPAQUE iterateI #-}+{-# ANN iterateI (InlineYamlPrimitive [VHDL,Verilog,SystemVerilog] [I.__i|+  BlackBoxHaskell:+    name: Clash.Sized.Vector.iterateI+    templateFunction: Clash.Primitives.Sized.Vector.iterateBBF+  |]) #-}++-- | \"'unfoldr' @n f s@\" builds a vector of length @n@ from a seed value @s@,+-- where every element @a@ is created by successive calls of @f@ on @s@. Unlike+-- 'Data.List.unfoldr' from "Data.List" the generating function @f@ cannot+-- dictate the length of the resulting vector, it must be statically known.+--+-- a simple use of 'unfoldr':+--+-- >>> unfoldr d10 (\s -> (s,s-1)) 10+-- 10 :> 9 :> 8 :> 7 :> 6 :> 5 :> 4 :> 3 :> 2 :> 1 :> Nil+unfoldr :: SNat n -> (s -> (a,s)) -> s -> Vec n a+unfoldr SNat = unfoldrI+{-# INLINE unfoldr #-}++-- | \"'unfoldrI' @f s@\" builds a vector from a seed value @s@, where every+-- element @a@ is created by successive calls of @f@ on @s@; the length of the+-- vector is inferred from the context. Unlike 'Data.List.unfoldr' from+-- "Data.List" the generating function @f@ cannot  dictate the length of the+-- resulting vector, it must be statically known.+--+-- a simple use of 'unfoldrI':+--+-- >>> unfoldrI (\s -> (s,s-1)) 10 :: Vec 10 Int+-- 10 :> 9 :> 8 :> 7 :> 6 :> 5 :> 4 :> 3 :> 2 :> 1 :> Nil+unfoldrI :: KnownNat n => (s -> (a,s)) -> s -> Vec n a+unfoldrI f s0 = map fst xs+ where+  xs = init (f s0 `Cons` ws)+  ws = map (f . snd) (lazyV xs)+{-# INLINE unfoldrI #-}++-- | \"'generate' @n f x@\" returns a vector with @n@ repeated applications of+-- @f@ to @x@.+--+-- > generate (SNat :: SNat 4) f x == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil)+-- > generate d4 f x               == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil)+--+-- >>> generate d4 (+1) 1+-- 2 :> 3 :> 4 :> 5 :> Nil+--+-- \"'generate' @n f z@\" corresponds to the following circuit layout:+--+-- <<doc/generate.svg>>+generate :: SNat n -> (a -> a) -> a -> Vec n a+generate SNat f a = iterateI f (f a)+{-# INLINE generate #-}++-- | \"'generateI' @f x@\" returns a vector with @n@ repeated applications of+-- @f@ to @x@, where @n@ is determined by the context.+--+-- > generateI f x :: Vec 3 a == (f x :> f (f x) :> f (f (f x)) :> Nil)+--+-- >>> generateI (+1) 1 :: Vec 3 Int+-- 2 :> 3 :> 4 :> Nil+--+-- \"'generateI' @f z@\" corresponds to the following circuit layout:+--+-- <<doc/generate.svg>>+generateI :: KnownNat n => (a -> a) -> a -> Vec n a+generateI f a = iterateI f (f a)+{-# INLINE generateI #-}++-- | Transpose a matrix: go from row-major to column-major+--+-- >>> let xss = (1:>2:>Nil):>(3:>4:>Nil):>(5:>6:>Nil):>Nil+-- >>> xss+-- (1 :> 2 :> Nil) :> (3 :> 4 :> Nil) :> (5 :> 6 :> Nil) :> Nil+-- >>> transpose xss+-- (1 :> 3 :> 5 :> Nil) :> (2 :> 4 :> 6 :> Nil) :> Nil+transpose :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)+transpose = traverse# id+{-# OPAQUE transpose #-}+{-# ANN transpose hasBlackBox #-}++-- | 1-dimensional stencil computations+--+-- \"'stencil1d' @stX f xs@\", where /xs/ has /stX + n/ elements, applies the+-- stencil computation /f/ on: /n + 1/ overlapping (1D) windows of length /stX/,+-- drawn from /xs/. The resulting vector has /n + 1/ elements.+--+-- >>> let xs = (1:>2:>3:>4:>5:>6:>Nil)+-- >>> :t xs+-- xs :: Num a => Vec 6 a+-- >>> :t stencil1d d2 sum xs+-- stencil1d d2 sum xs :: Num b => Vec 5 b+-- >>> stencil1d d2 sum xs+-- 3 :> 5 :> 7 :> 9 :> 11 :> Nil+stencil1d :: KnownNat n+          => SNat (stX + 1) -- ^ Windows length /stX/, at least size 1+          -> (Vec (stX + 1) a -> b) -- ^ The stencil (function)+          -> Vec ((stX + n) + 1) a+          -> Vec (n + 1) b+stencil1d stX f xs = map f (windows1d stX xs)+{-# INLINE stencil1d #-}++{- | 2-dimensional stencil computations++\"'stencil2d' @stY stX f xss@\", where /xss/ is a matrix of /stY + m/ rows+of /stX + n/ elements, applies the stencil computation /f/ on:+/(m + 1) * (n + 1)/ overlapping (2D) windows of /stY/ rows of /stX/ elements,+drawn from /xss/. The result matrix has /m + 1/ rows of /n + 1/ elements.++>>> let xss = ((1:>2:>3:>4:>Nil):>(5:>6:>7:>8:>Nil):>(9:>10:>11:>12:>Nil):>(13:>14:>15:>16:>Nil):>Nil)+>>> :t xss+xss :: Num a => Vec 4 (Vec 4 a)++>>> :t stencil2d d2 d2 (sum . map sum) xss+stencil2d d2 d2 (sum . map sum) xss :: Num a => Vec 3 (Vec 3 a)++>>> stencil2d d2 d2 (sum . map sum) xss+(14 :> 18 :> 22 :> Nil) :> (30 :> 34 :> 38 :> Nil) :> (46 :> 50 :> 54 :> Nil) :> Nil+-}+stencil2d :: (KnownNat n, KnownNat m)+          => SNat (stY + 1) -- ^ Window hight /stY/, at least size 1+          -> SNat (stX + 1) -- ^ Window width /stX/, at least size 1+          -> (Vec (stY + 1) (Vec (stX + 1) a) -> b) -- ^ The stencil (function)+          -> Vec ((stY + m) + 1) (Vec ((stX + n) + 1) a)+          -> Vec (m + 1) (Vec (n + 1) b)+stencil2d stY stX f xss = (map.map) f (windows2d stY stX xss)+{-# INLINE stencil2d #-}++-- | \"'windows1d' @stX xs@\", where the vector /xs/ has /stX + n/ elements,+-- returns a vector of /n + 1/ overlapping (1D) windows of /xs/ of length /stX/.+--+-- >>> let xs = (1:>2:>3:>4:>5:>6:>Nil)+-- >>> :t xs+-- xs :: Num a => Vec 6 a+-- >>> :t windows1d d2 xs+-- windows1d d2 xs :: Num a => Vec 5 (Vec 2 a)+-- >>> windows1d d2 xs+-- (1 :> 2 :> Nil) :> (2 :> 3 :> Nil) :> (3 :> 4 :> Nil) :> (4 :> 5 :> Nil) :> (5 :> 6 :> Nil) :> Nil+windows1d :: KnownNat n+          => SNat (stX + 1) -- ^ Length of the window, at least size 1+          -> Vec ((stX + n) + 1) a+          -> Vec (n + 1) (Vec (stX + 1) a)+windows1d stX xs = map (take stX) (rotations xs)+  where+    rotateL ys   = tail ys :< head ys+    rotations ys = iterateI rotateL ys+{-# INLINE windows1d #-}++-- | \"'windows2d' @stY stX xss@\", where matrix /xss/ has /stY + m/ rows of+-- /stX + n/, returns a matrix of /m+1/ rows of /n+1/ elements. The elements+-- of this new matrix are the overlapping (2D) windows of /xss/, where every+-- window has /stY/ rows of /stX/ elements.+--+-- >>> let xss = ((1:>2:>3:>4:>Nil):>(5:>6:>7:>8:>Nil):>(9:>10:>11:>12:>Nil):>(13:>14:>15:>16:>Nil):>Nil)+-- >>> :t xss+-- xss :: Num a => Vec 4 (Vec 4 a)+-- >>> :t windows2d d2 d2 xss+-- windows2d d2 d2 xss :: Num a => Vec 3 (Vec 3 (Vec 2 (Vec 2 a)))+-- >>> windows2d d2 d2 xss+-- (((1 :> 2 :> Nil) :> (5 :> 6 :> Nil) :> Nil) :> ((2 :> 3 :> Nil) :> (6 :> 7 :> Nil) :> Nil) :> ((3 :> 4 :> Nil) :> (7 :> 8 :> Nil) :> Nil) :> Nil) :> (((5 :> 6 :> Nil) :> (9 :> 10 :> Nil) :> Nil) :> ((6 :> 7 :> Nil) :> (10 :> 11 :> Nil) :> Nil) :> ((7 :> 8 :> Nil) :> (11 :> 12 :> Nil) :> Nil) :> Nil) :> (((9 :> 10 :> Nil) :> (13 :> 14 :> Nil) :> Nil) :> ((10 :> 11 :> Nil) :> (14 :> 15 :> Nil) :> Nil) :> ((11 :> 12 :> Nil) :> (15 :> 16 :> Nil) :> Nil) :> Nil) :> Nil+windows2d :: (KnownNat n,KnownNat m)+          => SNat (stY + 1) -- ^ Window hight /stY/, at least size 1+          -> SNat (stX + 1) -- ^ Window width /stX/, at least size 1+          -> Vec ((stY + m) + 1) (Vec (stX + n + 1) a)+          -> Vec (m + 1) (Vec (n + 1) (Vec (stY + 1) (Vec (stX + 1) a)))+windows2d stY stX xss = map (transpose . (map (windows1d stX))) (windows1d stY xss)+{-# INLINE windows2d #-}++-- | Forward permutation specified by an index mapping, /ix/. The result vector+-- is initialized by the given defaults, /def/, and an further values that are+-- permuted into the result are added to the current value using the given+-- combination function, /f/.+--+-- The combination function must be /associative/ and /commutative/.+permute :: (Enum i, KnownNat n, KnownNat m)+        => (a -> a -> a)  -- ^ Combination function, /f/+        -> Vec n a        -- ^ Default values, /def/+        -> Vec m i        -- ^ Index mapping, /is/+        -> Vec (m + k) a  -- ^ Vector to be permuted, /xs/+        -> Vec n a+permute f defs is xs = ys+  where+    ixs = zip is (takeI xs)+    ys  = foldl (\ks (i,x) -> let ki = ks!!i in replace i (f x ki) ks) defs ixs+{-# INLINE permute #-}++-- | Backwards permutation specified by an index mapping, /is/, from the+-- destination vector specifying which element of the source vector /xs/ to+-- read.+--+-- \"'backpermute' @xs is@\" is equivalent to \"'map' @(xs '!!') is@\".+--+-- For example:+--+-- >>> let input = 1:>9:>6:>4:>4:>2:>0:>1:>2:>Nil+-- >>> let from  = 1:>3:>7:>2:>5:>3:>Nil+-- >>> backpermute input from+-- 9 :> 4 :> 1 :> 6 :> 2 :> 4 :> Nil+backpermute :: (Enum i, KnownNat n)+            => Vec n a  -- ^ Source vector, /xs/+            -> Vec m i  -- ^ Index mapping, /is/+            -> Vec m a+backpermute xs = map (xs!!)+{-# INLINE backpermute #-}++-- | Copy elements from the source vector, /xs/, to the destination vector+-- according to an index mapping /is/. This is a forward permute operation where+-- a /to/ vector encodes an input to output index mapping. Output elements for+-- indices that are not mapped assume the value in the default vector /def/.+--+-- For example:+--+-- >>> let defVec = 0:>0:>0:>0:>0:>0:>0:>0:>0:>Nil+-- >>> let to = 1:>3:>7:>2:>5:>8:>Nil+-- >>> let input = 1:>9:>6:>4:>4:>2:>5:>Nil+-- >>> scatter defVec to input+-- 0 :> 1 :> 4 :> 9 :> 0 :> 4 :> 0 :> 6 :> 2 :> Nil+--+-- __NB__: If the same index appears in the index mapping more than once, the+-- latest mapping is chosen.+scatter :: (Enum i, KnownNat n, KnownNat m)+        => Vec n a       -- ^ Default values, /def/+        -> Vec m i       -- ^ Index mapping, /is/+        -> Vec (m + k) a -- ^ Vector to be scattered, /xs/+        -> Vec n a+scatter = permute const+{-# INLINE scatter #-}++-- | Backwards permutation specified by an index mapping, /is/, from the+-- destination vector specifying which element of the source vector /xs/ to+-- read.+--+-- \"'gather' @xs is@\" is equivalent to \"'map' @(xs '!!') is@\".+--+-- For example:+--+-- >>> let input = 1:>9:>6:>4:>4:>2:>0:>1:>2:>Nil+-- >>> let from  = 1:>3:>7:>2:>5:>3:>Nil+-- >>> gather input from+-- 9 :> 4 :> 1 :> 6 :> 2 :> 4 :> Nil+gather :: (Enum i, KnownNat n)+       => Vec n a  -- ^ Source vector, /xs/+       -> Vec m i  -- ^ Index mapping, /is/+       -> Vec m a+gather xs = map (xs!!)+{-# INLINE gather #-}++-- | \"'interleave' @d xs@\" creates a vector:+--+-- > <x_0,x_d,x_(2d),...,x_1,x_(d+1),x_(2d+1),...,x_(d-1),x_(2d-1),x_(3d-1)>+--+-- >>> let xs = 1 :> 2 :> 3 :> 4 :> 5 :> 6 :> 7 :> 8 :> 9 :> Nil+-- >>> interleave d3 xs+-- 1 :> 4 :> 7 :> 2 :> 5 :> 8 :> 3 :> 6 :> 9 :> Nil+interleave :: KnownNat n+           => SNat d -- ^ Interleave step, /d/+           -> Vec (n * d) a+           -> Vec (d * n) a+interleave d@SNat = concat . transpose . unconcat d+{-# INLINE interleave #-}++-- | /Dynamically/ rotate a 'Vec'tor to the left:+--+-- >>> let xs = 1 :> 2 :> 3 :> 4 :> Nil+-- >>> rotateLeft xs 1+-- 2 :> 3 :> 4 :> 1 :> Nil+-- >>> rotateLeft xs 2+-- 3 :> 4 :> 1 :> 2 :> Nil+-- >>> rotateLeft xs (-1)+-- 4 :> 1 :> 2 :> 3 :> Nil+--+-- __NB__: Use `rotateLeftS` if you want to rotate left by a /static/ amount.+rotateLeft :: (Enum i, KnownNat n)+           => Vec n a+           -> i+           -> Vec n a+rotateLeft xs i = map ((xs !!) . (`mod` len)) (iterateI (+1) i')+  where+    i'  = fromEnum i+    len = length xs+{-# INLINE rotateLeft #-}++-- | /Dynamically/ rotate a 'Vec'tor to the right:+--+-- >>> let xs = 1 :> 2 :> 3 :> 4 :> Nil+-- >>> rotateRight xs 1+-- 4 :> 1 :> 2 :> 3 :> Nil+-- >>> rotateRight xs 2+-- 3 :> 4 :> 1 :> 2 :> Nil+-- >>> rotateRight xs (-1)+-- 2 :> 3 :> 4 :> 1 :> Nil+--+-- __NB__: Use `rotateRightS` if you want to rotate right by a /static/ amount.+rotateRight :: (Enum i, KnownNat n)+            => Vec n a+            -> i+            -> Vec n a+rotateRight xs i = map ((xs !!) . (`mod` len)) (iterateI (+1) i')+  where+    i'  = negate (fromEnum i)+    len = length xs+{-# INLINE rotateRight #-}++-- | /Statically/ rotate a 'Vec'tor to the left:+--+-- >>> let xs = 1 :> 2 :> 3 :> 4 :> Nil+-- >>> rotateLeftS xs d1+-- 2 :> 3 :> 4 :> 1 :> Nil+--+-- __NB__: Use `rotateLeft` if you want to rotate left by a /dynamic/ amount.+rotateLeftS :: KnownNat n+            => Vec n a+            -> SNat d+            -> Vec n a+rotateLeftS xs d = go (snatToInteger d `mod` natVal (asNatProxy xs)) xs+  where+    go :: Integer -> Vec k a -> Vec k a+    go _ Nil           = Nil+    go 0 ys            = ys+    go n (y `Cons` ys) = go (n-1) (ys :< y)+{-# OPAQUE rotateLeftS #-}+{-# ANN rotateLeftS hasBlackBox #-}++-- | /Statically/ rotate a 'Vec'tor to the right:+--+-- >>> let xs = 1 :> 2 :> 3 :> 4 :> Nil+-- >>> rotateRightS xs d1+-- 4 :> 1 :> 2 :> 3 :> Nil+--+-- __NB__: Use `rotateRight` if you want to rotate right by a /dynamic/ amount.+rotateRightS :: KnownNat n+             => Vec n a+             -> SNat d+             -> Vec n a+rotateRightS xs d = go (snatToInteger d `mod` natVal (asNatProxy xs)) xs+  where+    go _ Nil            = Nil+    go 0 ys             = ys+    go n ys@(Cons _ _)  = go (n-1) (last ys :> init ys)+{-# OPAQUE rotateRightS #-}+{-# ANN rotateRightS hasBlackBox #-}++-- | Convert a vector to a list.+--+-- >>> toList (1:>2:>3:>Nil)+-- [1,2,3]+--+-- __NB__: This function is not synthesizable+toList :: Vec n a -> [a]+toList = foldr (:) []+{-# INLINE toList #-}++-- | Convert a list to a vector. This function returns Nothing if the size of+-- the list is not equal to the size of the resulting vector.+--+-- >>> Vec.fromList [1,2,3,4,5] :: Maybe (Vec 5 Int)+-- Just (1 :> 2 :> 3 :> 4 :> 5 :> Nil)+--+-- >>> Vec.fromList [1,2,3,4,5] :: Maybe (Vec 3 Int)+-- Nothing+--+-- >>> Vec.fromList [1,2,3,4,5] :: Maybe (Vec 10 Int)+-- Nothing+--+-- * __NB__: Use `listToVecTH` if you want to make a /statically known/ vector+-- * __NB__: This function is not synthesizable+--+fromList :: forall n a. (KnownNat n) => [a] -> Maybe (Vec n a)+fromList xs+  | exactLength (natToInteger @n) xs = Just (unsafeFromList xs)+  | otherwise = Nothing+ where+  exactLength 0 acc = null acc+  exactLength _ []  = False+  exactLength i (_:ys) = exactLength (i - 1) ys+{-# OPAQUE fromList #-}+{-# ANN fromList dontTranslate #-}++-- | Convert a list to a vector. This function always returns a vector of the+-- desired length, by either truncating the list or padding the vector with+-- undefined elements.+--+-- >>> Vec.unsafeFromList [1,2,3,4,5] :: Vec 5 Int+-- 1 :> 2 :> 3 :> 4 :> 5 :> Nil+--+-- >>> Vec.unsafeFromList [1,2,3,4,5] :: Vec 3 Int+-- 1 :> 2 :> 3 :> Nil+--+-- >>> Vec.unsafeFromList [1,2,3,4,5] :: Vec 10 Int+-- 1 :> 2 :> 3 :> 4 :> 5 :> *** Exception: Clash.Sized.Vector.unsafeFromList: vector larger than list+-- ...+--+-- * __NB__: Use `listToVecTH` if you want to make a /statically known/ vector+-- * __NB__: This function is not synthesizable+--+unsafeFromList :: forall n a. (KnownNat n) => [a] -> Vec n a+unsafeFromList = unfoldr SNat go+ where+  go :: [a] -> (a, [a])+  go (x:xs) = (x, xs)+  go [] =+    let item = error "Clash.Sized.Vector.unsafeFromList: vector larger than list"+     in (item, [])+{-# OPAQUE unsafeFromList #-}+{-# ANN unsafeFromList dontTranslate #-}++-- | Create a vector literal from a list literal.+--+-- > $(listToVecTH [1::Signed 8,2,3,4,5]) == (8:>2:>3:>4:>5:>Nil) :: Vec 5 (Signed 8)+--+-- >>> [1 :: Signed 8,2,3,4,5]+-- [1,2,3,4,5]+-- >>> $(listToVecTH [1::Signed 8,2,3,4,5])+-- 1 :> 2 :> 3 :> 4 :> 5 :> Nil+listToVecTH :: Lift a => [a] -> ExpQ+listToVecTH []     = [| Nil |]+listToVecTH (x:xs) = [| x :> $(listToVecTH xs) |]++-- | 'Vec'tor as a 'Proxy' for 'Nat'+asNatProxy :: Vec n a -> Proxy n+asNatProxy _ = Proxy++-- | Length of a 'Vec'tor as an 'SNat' value+lengthS :: KnownNat n => Vec n a -> SNat n+lengthS _ = SNat+{-# INLINE lengthS #-}++-- | What you should use when your vector functions are too strict in their+-- arguments.+--+-- === __doctests setup__+-- >>> let compareSwapL a b = if a < b then (a,b) else (b,a)+-- >>> :{+-- let sortVL :: (Ord a, KnownNat (n + 1)) => Vec ((n + 1) + 1) a -> Vec ((n + 1) + 1) a+--     sortVL xs = map fst sorted :< (snd (last sorted))+--       where+--         lefts  = head xs :> map snd (init sorted)+--         rights = tail xs+--         sorted = zipWith compareSwapL (lazyV lefts) rights+-- :}+--+-- >>> :{+-- let sortV_flip xs = map fst sorted :< (snd (last sorted))+--       where+--         lefts  = head xs :> map snd (init sorted)+--         rights = tail xs+--         sorted = zipWith (flip compareSwapL) rights lefts+-- :}+--+-- === Example usage+--+-- For example:+--+-- @+-- -- Bubble sort for 1 iteration+-- sortV xs = 'map' fst sorted ':<' (snd ('last' sorted))+--  where+--    lefts  = 'head' xs :> 'map' snd ('init' sorted)+--    rights = 'tail' xs+--    sorted = 'zipWith' compareSwapL lefts rights+--+-- -- Compare and swap+-- compareSwapL a b = if a < b then (a,b)+--                             else (b,a)+-- @+--+-- Will not terminate because 'zipWith' is too strict in its second argument.+--+-- In this case, adding 'lazyV' on 'zipWith's second argument:+--+-- @+-- sortVL xs = 'map' fst sorted ':<' (snd ('last' sorted))+--  where+--    lefts  = 'head' xs :> map snd ('init' sorted)+--    rights = 'tail' xs+--    sorted = 'zipWith' compareSwapL ('lazyV' lefts) rights+-- @+--+-- Results in a successful computation:+--+-- >>> sortVL (4 :> 1 :> 2 :> 3 :> Nil)+-- 1 :> 2 :> 3 :> 4 :> Nil+--+-- __NB__: There is also a solution using 'flip', but it slightly obfuscates the+-- meaning of the code:+--+-- @+-- sortV_flip xs = 'map' fst sorted ':<' (snd ('last' sorted))+--  where+--    lefts  = 'head' xs :> 'map' snd ('init' sorted)+--    rights = 'tail' xs+--    sorted = 'zipWith' ('flip' compareSwapL) rights lefts+-- @+--+-- >>> sortV_flip (4 :> 1 :> 2 :> 3 :> Nil)+-- 1 :> 2 :> 3 :> 4 :> Nil+lazyV :: KnownNat n+      => Vec n a+      -> Vec n a+lazyV = lazyV' (repeat ())+  where+    lazyV' :: Vec n () -> Vec n a -> Vec n a+    lazyV' Nil           _  = Nil+    lazyV' (_ `Cons` xs) ys = head ys `Cons` lazyV' xs (tail ys)+{-# OPAQUE lazyV #-}+{-# ANN lazyV hasBlackBox #-}++-- | A /dependently/ typed fold.+--+-- === __doctests setup__+-- >>> :seti -fplugin GHC.TypeLits.Normalise+-- >>> import Data.Singletons (Apply, Proxy (..), TyFun)+-- >>> data Append (m :: Nat) (a :: Type) (f :: TyFun Nat Type) :: Type+-- >>> type instance Apply (Append m a) l = Vec (l + m) a+-- >>> :{+-- >>> append' :: forall a k m. KnownNat k => Vec k a -> Vec m a -> Vec (k + m) a+-- >>> append' xs ys = dfold (Proxy :: Proxy (Append m a)) (const ((:>) @a)) ys xs+-- >>> :}+--+-- === Example usage+--+-- Using lists, we can define /append/ (a.k.a. @Data.List.@'Data.List.++') in+-- terms of @Data.List.@'Data.List.foldr':+--+-- >>> import qualified Data.List+-- >>> let append xs ys = Data.List.foldr (:) ys xs+-- >>> append [1,2] [3,4]+-- [1,2,3,4]+--+-- However, when we try to do the same for 'Vec', by defining /append'/ in terms+-- of @Clash.Sized.Vector.@'foldr':+--+-- @+-- append' xs ys = 'foldr' (:>) ys xs+-- @+--+-- we get a type error:+--+-- @+-- __>>> let append' xs ys = foldr (:>) ys xs__+--+-- \<interactive\>:...+--     • Occurs check: cannot construct the infinite type: ... ~ ... + 1+--       Expected type: a -> Vec ... a -> Vec ... a+--         Actual type: a -> Vec ... a -> Vec (... + 1) a+--     • In the first argument of ‘foldr’, namely ‘(:>)’+--       In the expression: foldr (:>) ys xs+--       In an equation for ‘append'’: append' xs ys = foldr (:>) ys xs+--     • Relevant bindings include+--         ys :: Vec ... a (bound at ...)+--         append' :: Vec n a -> Vec ... a -> Vec ... a+--           (bound at ...)+-- @+--+-- The reason is that the type of 'foldr' is:+--+-- >>> :t foldr+-- foldr :: (a -> b -> b) -> b -> Vec n a -> b+--+-- While the type of (':>') is:+--+-- >>> :t (:>)+-- (:>) :: a -> Vec n a -> Vec (n + 1) a+--+-- We thus need a @fold@ function that can handle the growing vector type:+-- 'dfold'. Compared to 'foldr', 'dfold' takes an extra parameter, called the+-- /motive/, that allows the folded function to have an argument and result type+-- that /depends/ on the current length of the vector. Using 'dfold', we can+-- now correctly define /append'/:+--+-- @+-- import Data.Singletons+-- import Data.Proxy+--+-- data Append (m :: Nat) (a :: Type) (f :: 'TyFun' Nat Type) :: Type+-- type instance 'Apply' (Append m a) l = 'Vec' (l + m) a+--+-- append' xs ys = 'dfold' (Proxy :: Proxy (Append m a)) (const (':>')) ys xs+-- @+--+-- We now see that /append'/ has the appropriate type:+--+-- >>> :t append'+-- append' :: KnownNat k => Vec k a -> Vec m a -> Vec (k + m) a+--+-- And that it works:+--+-- >>> append' (1 :> 2 :> Nil) (3 :> 4 :> Nil)+-- 1 :> 2 :> 3 :> 4 :> Nil+--+-- __NB__: \"@'dfold' m f z xs@\" creates a linear structure, which has a depth,+-- or delay, of O(@'length' xs@). Look at 'dtfold' for a /dependently/ typed+-- fold that produces a structure with a depth of O(log_2(@'length' xs@)).+dfold :: forall p k a . KnownNat k+      => Proxy (p :: TyFun Nat Type -> Type) -- ^ The /motive/+      -> (forall n . n + 1 <= k => SNat n -> a -> (p @@ n) -> (p @@ (n + 1)))+      -- ^ Function to fold.+      --+      -- __NB__: The @SNat l@ is __not__ the index (see (`!!`)) to the+      -- element /a/. @SNat l@ is the number of elements that occur to the+      -- right of /a/.+      -> (p @@ 0) -- ^ Initial element+      -> Vec k a -- ^ Vector to fold over+      -> (p @@ k)+dfold _ f z xs = go (snatProxy (asNatProxy xs)) xs+  where+    go :: n <= k => SNat n -> Vec n a -> (p @@ n)+    go _ Nil                        = z+    go s (y `Cons` ys) =+      let s' = s `subSNat` d1+      in  f s' y (go s' ys)+{-# OPAQUE dfold #-}+{-# ANN dfold hasBlackBox #-}++{- | A combination of 'dfold' and 'fold': a /dependently/ typed fold that+reduces a vector in a tree-like structure.++=== __doctests setup__+>>> :seti -XUndecidableInstances+>>> import Data.Singletons (Apply, Proxy (..), TyFun)+>>> data IIndex (f :: TyFun Nat Type) :: Type+>>> type instance Apply IIndex l = Index ((2^l)+1)+>>> :{+let populationCount' :: (KnownNat k, KnownNat (2^k)) => BitVector (2^k) -> Index ((2^k)+1)+    populationCount' bv = dtfold (Proxy @IIndex)+                                 fromIntegral+                                 (\_ x y -> add x y)+                                 (bv2v bv)+:}++=== Example usage++As an example of when you might want to use 'dtfold' we will build a+population counter: a circuit that counts the number of bits set to '1' in+a 'BitVector'. Given a vector of /n/ bits, we only need we need a data type+that can represent the number /n/: 'Index' @(n+1)@. 'Index' @k@ has a range+of @[0 .. k-1]@ (using @ceil(log2(k))@ bits), hence we need 'Index' @n+1@.+As an initial attempt we will use 'sum', because it gives a nice (@log2(n)@)+tree-structure of adders:++@+populationCount :: (KnownNat (n+1), KnownNat (n+2))+                => 'BitVector' (n+1) -> 'Index' (n+2)+populationCount = sum . map fromIntegral . 'bv2v'+@++The \"problem\" with this description is that all adders have the same+bit-width, i.e. all adders are of the type:++@+(+) :: 'Index' (n+2) -> 'Index' (n+2) -> 'Index' (n+2).+@++This is a \"problem\" because we could have a more efficient structure:+one where each layer of adders is /precisely/ wide enough to count the number+of bits at that layer. That is, at height /d/ we want the adder to be of+type:++@+'Index' ((2^d)+1) -> 'Index' ((2^d)+1) -> 'Index' ((2^(d+1))+1)+@++We have such an adder in the form of the 'Clash.Class.Num.add' function, as+defined in the instance 'Clash.Class.Num.ExtendingNum' instance of 'Index'.+However, we cannot simply use 'fold' to create a tree-structure of+'Clash.Class.Num.add'es:++#if __GLASGOW_HASKELL__ >= 910+>>> :{+let populationCount' :: (KnownNat (n+1), KnownNat (n+2))+                     => BitVector (n+1) -> Index (n+2)+    populationCount' = fold add . map fromIntegral . bv2v+:}+<interactive>:...+    • Couldn't match type: ((n + 2) + (n + 2)) - 1+                     with: n + 2+      Expected: Index (n + 2) -> Index (n + 2) -> Index (n + 2)+        Actual: Index (n + 2)+                -> Index (n + 2) -> AResult (Index (n + 2)) (Index (n + 2))+    • In the first argument of ‘fold’, namely ‘add’+      In the first argument of ‘(.)’, namely ‘fold add’+      In the expression: fold add . map fromIntegral . bv2v+    • Relevant bindings include+        populationCount' :: BitVector (n + 1) -> Index (n + 2)+          (bound at ...)+<BLANKLINE>++#else+>>> :{+let populationCount' :: (KnownNat (n+1), KnownNat (n+2))+                     => BitVector (n+1) -> Index (n+2)+    populationCount' = fold add . map fromIntegral . bv2v+:}+<BLANKLINE>+<interactive>:...+    • Couldn't match type: ((n + 2) + (n + 2)) - 1+                     with: n + 2+      Expected: Index (n + 2) -> Index (n + 2) -> Index (n + 2)+        Actual: Index (n + 2)+                -> Index (n + 2) -> AResult (Index (n + 2)) (Index (n + 2))+    • In the first argument of ‘fold’, namely ‘add’+      In the first argument of ‘(.)’, namely ‘fold add’+      In the expression: fold add . map fromIntegral . bv2v+    • Relevant bindings include+        populationCount' :: BitVector (n + 1) -> Index (n + 2)+          (bound at ...)++#endif++because 'fold' expects a function of type \"@a -> a -> a@\", i.e. a function+where the arguments and result all have exactly the same type.++In order to accommodate the type of our 'Clash.Class.Num.add', where the+result is larger than the arguments, we must use a dependently typed fold in+the form of 'dtfold':++@+{\-\# LANGUAGE UndecidableInstances \#-\}+import Data.Singletons+import Data.Proxy++data IIndex (f :: 'TyFun' Nat Type) :: Type+type instance 'Apply' IIndex l = 'Index' ((2^l)+1)++populationCount' :: (KnownNat k, KnownNat (2^k))+                 => BitVector (2^k) -> Index ((2^k)+1)+populationCount' bv = 'dtfold' (Proxy @IIndex)+                             fromIntegral+                             (\\_ x y -> 'Clash.Class.Num.add' x y)+                             ('bv2v' bv)+@++And we can test that it works:++>>> :t populationCount' (7 :: BitVector 16)+populationCount' (7 :: BitVector 16) :: Index 17+>>> populationCount' (7 :: BitVector 16)+3++Some final remarks:++  * By using 'dtfold' instead of 'fold', we had to restrict our 'BitVector'+    argument to have bit-width that is a power of 2.+  * Even though our original /populationCount/ function specified a structure+    where all adders had the same width. Most VHDL/(System)Verilog synthesis+    tools will create a more efficient circuit, i.e. one where the adders+    have an increasing bit-width for every layer, from the+    VHDL/(System)Verilog produced by the Clash compiler.++__NB__: The depth, or delay, of the structure produced by+\"@'dtfold' m f g xs@\" is O(log_2(@'length' xs@)).+-}+dtfold :: forall p k a . KnownNat k+       => Proxy (p :: TyFun Nat Type -> Type) -- ^ The /motive/+       -> (a -> (p @@ 0)) -- ^ Function to apply to every element+       -> (forall n . SNat n -> (p @@ n) -> (p @@ n) -> (p @@ (n + 1)))+       -- ^ Function to combine results.+       --+       -- __NB__: The @SNat l@ indicates the depth/height of the node in the+       -- tree that is created by applying this function. The leafs of the tree+       -- have depth\/height /0/, and the root of the tree has height /k/.+       -> Vec (2^k) a+       -- ^ Vector to fold over.+       --+       -- __NB__: Must have a length that is a power of 2.+       -> (p @@ k)+dtfold _ f g = go (SNat :: SNat k)+  where+    go :: forall n . SNat n -> Vec (2^n) a -> (p @@ n)+    go _  (x `Cons` Nil) = f x+    go sn xs@(Cons _ (Cons _ _)) =+      let sn' :: SNat (n - 1)+          sn'       = sn `subSNat` d1+          (xsL,xsR) = splitAt (pow2SNat sn') xs+      in  g sn' (go sn' xsL) (go sn' xsR)+#if __GLASGOW_HASKELL__ < 912+    go _  Nil =+      case (const Dict :: forall m. Proxy m -> Dict (1 <= 2 ^ m)) (Proxy @n) of+        {}+#endif+{-# OPAQUE dtfold #-}+{-# ANN dtfold hasBlackBox #-}++-- | To be used as the motive /p/ for 'dfold', when the /f/ in \"'dfold' @p f@\"+-- is a variation on (':>'), e.g.:+--+-- @+-- map' :: forall n a b . KnownNat n => (a -> b) -> Vec n a -> Vec n b+-- map' f = 'dfold' (Proxy @('VCons' b)) (\_ x xs -> f x :> xs)+-- @+data VCons (a :: Type) (f :: TyFun Nat Type) :: Type+type instance Apply (VCons a) l = Vec l a++-- | Specialised version of 'dfold' that builds a triangular computational+-- structure.+--+-- === __doctests setup__+-- >>> let compareSwap a b = if a > b then (a,b) else (b,a)+-- >>> let insert y xs = let (y',xs') = mapAccumL compareSwap y xs in xs' :< y'+-- >>> let insertionSort = vfold (const insert)+--+-- === Example usage+--+-- @+-- compareSwap a b = if a > b then (a,b) else (b,a)+-- insert y xs     = let (y',xs') = 'mapAccumL' compareSwap y xs in xs' ':<' y'+-- insertionSort   = 'vfold' (const insert)+-- @+--+-- Builds a triangular structure of compare and swaps to sort a row.+--+-- >>> insertionSort (7 :> 3 :> 9 :> 1 :> Nil)+-- 1 :> 3 :> 7 :> 9 :> Nil+--+-- The circuit layout of @insertionSort@, build using 'vfold', is:+--+-- <<doc/csSort.svg>>+vfold :: forall k a b . KnownNat k+      => (forall n . SNat n -> a -> Vec n b -> Vec (n + 1) b)+      -> Vec k a+      -> Vec k b+vfold f xs = dfold (Proxy @(VCons b)) f Nil xs+{-# INLINE vfold #-}++-- | The largest element of a non-empty vector+maximum ::+  Ord a =>+  Vec (n + 1) a ->+  a+maximum = fold (\x y -> if x >= y then x else y)++-- | The least element of a non-empty vector+minimum ::+  Ord a =>+  Vec (n + 1) a ->+  a+minimum = fold (\x y -> if x <= y then x else y)++-- | Apply a function to every element of a vector and the element's position+-- (as an 'SNat' value) in the vector.+--+-- >>> let rotateMatrix = smap (flip rotateRightS)+-- >>> let xss = (1:>2:>3:>Nil):>(1:>2:>3:>Nil):>(1:>2:>3:>Nil):>Nil+-- >>> xss+-- (1 :> 2 :> 3 :> Nil) :> (1 :> 2 :> 3 :> Nil) :> (1 :> 2 :> 3 :> Nil) :> Nil+-- >>> rotateMatrix xss+-- (1 :> 2 :> 3 :> Nil) :> (3 :> 1 :> 2 :> Nil) :> (2 :> 3 :> 1 :> Nil) :> Nil+smap :: forall k a b . KnownNat k => (forall n . SNat n -> a -> b) -> Vec k a -> Vec k b+smap f xs = reverse+          $ dfold (Proxy @(VCons b))+                  (\sn x xs' -> f sn x :> xs')+                  Nil (reverse xs)+{-# INLINE smap #-}++-- | Extended version of 'smap' offering an additional boundary proof to+-- the mapped function. Note that the type checker may need additional type+-- annotations to resolve type ambiguity for this. Thus, if the boundary constraint+-- is not needed it is recommended to stay with 'smap' instead.+smapWithBounds ::+  forall k a b .+  KnownNat k =>+  (forall n . n + 1 <= k => SNat n -> a -> b) ->+  Vec k a ->+  Vec k b+smapWithBounds f xs = reverse+                    $ dfold (Proxy @(VCons b))+                            (\sn x xs' -> f sn x :> xs')+                            Nil (reverse xs)+{-# INLINE smapWithBounds #-}++instance (KnownNat n, BitPack a) => BitPack (Vec n a) where+  type BitSize (Vec n a) = n * (BitSize a)+  pack   = concatBitVector# . map pack . lazyV+  unpack = map unpack . unconcatBitVector#++concatBitVector#+  :: forall n m+   . (KnownNat n, KnownNat m)+  => Vec n (BitVector m)+  -> BitVector (n * m)+concatBitVector# = go 0+ where+  go :: BitVector (n*m) -> Vec p (BitVector m) -> BitVector (n * m)+  go acc Nil = acc+  go (BV accMsk accVal) ((BV xMsk xVal) `Cons` xs) =+    let sh = fromInteger (natVal (Proxy @m)) :: Int in+    go (BV (shiftL accMsk sh .|. xMsk) (shiftL accVal sh .|. xVal)) xs+{-# OPAQUE concatBitVector# #-}+{-# ANN concatBitVector# hasBlackBox #-}++unconcatBitVector#+  :: forall n m+   . (KnownNat n, KnownNat m)+  => BitVector (n * m)+  -> Vec n (BitVector m)+unconcatBitVector# orig = snd (go (toUNat (SNat @n)))+  where+    go :: forall p . (p <= n) => UNat p -> (BitVector ((n-p)*m), Vec p (BitVector m))+    go UZero = (orig,Nil)+    go (USucc (n :: UNat (p-1))) =+      let (bv,xs) = go n+          (l,x) = (GHC.Magic.noinline split#) bv+      in  (l,x :> xs)+{-# OPAQUE unconcatBitVector# #-}+{-# ANN unconcatBitVector# hasBlackBox #-}++-- | Convert a 'BitVector' to a 'Vec' of 'Bit's.+--+-- >>> let x = 6 :: BitVector 8+-- >>> x+-- 0b0000_0110+-- >>> bv2v x+-- 0 :> 0 :> 0 :> 0 :> 0 :> 1 :> 1 :> 0 :> Nil+bv2v :: KnownNat n => BitVector n -> Vec n Bit+bv2v = unpack++-- | Convert a 'Vec' of 'Bit's to a 'BitVector'.+--+-- >>> let x = (0:>0:>0:>1:>0:>0:>1:>0:>Nil) :: Vec 8 Bit+-- >>> x+-- 0 :> 0 :> 0 :> 1 :> 0 :> 0 :> 1 :> 0 :> Nil+-- >>> v2bv x+-- 0b0001_0010+v2bv :: KnownNat n => Vec n Bit -> BitVector n+v2bv = pack++-- | Evaluate all elements of a vector to WHNF, returning the second argument+seqV+  :: KnownNat n+  => Vec n a+  -> b+  -> b+seqV v b =+  let s () e = seq e () in+  foldl s () v `seq` b+{-# OPAQUE seqV #-}+{-# ANN seqV hasBlackBox #-}+infixr 0 `seqV`++-- | Evaluate all elements of a vector to WHNF+forceV+  :: KnownNat n+  => Vec n a+  -> Vec n a+forceV v =+  v `seqV` v+{-# INLINE forceV #-}++-- | Evaluate all elements of a vector to WHNF, returning the second argument.+-- Does not propagate 'Clash.XException.XException's.+seqVX+  :: KnownNat n+  => Vec n a+  -> b+  -> b+seqVX v b =+  let s () e = seqX e () in+  foldl s () v `seqX` b+{-# OPAQUE seqVX #-}+{-# ANN seqVX hasBlackBox #-}+infixr 0 `seqVX`++-- | Evaluate all elements of a vector to WHNF. Does not propagate+-- 'Clash.XException.XException's.+forceVX+  :: KnownNat n+  => Vec n a+  -> Vec n a+forceVX v =+  v `seqVX` v+{-# INLINE forceVX #-}++instance Lift a => Lift (Vec n a) where+  lift Nil           = [| Nil |]+  lift (x `Cons` xs) = [| x `Cons` $(lift xs) |]+  liftTyped = liftTypedFromUntyped++instance (KnownNat n, Arbitrary a) => Arbitrary (Vec n a) where+  arbitrary = traverse# id $ repeat arbitrary+  shrink    = traverse# id . fmap shrink++instance CoArbitrary a => CoArbitrary (Vec n a) where+  coarbitrary = coarbitrary . toList++type instance Lens.Index   (Vec n a) = Index n+type instance Lens.IxValue (Vec n a) = a+instance KnownNat n => Lens.Ixed (Vec n a) where+  ix i f xs = replace_int xs (fromEnum i) <$> f (index_int xs (fromEnum i))++instance KnownNat n => Distributive (Vec n) where+    distribute fxs = tabulate $ \i -> fmap (!! i) fxs+    {-# INLINE distribute #-}++instance KnownNat n => Representable (Vec n) where+    type Rep (Vec n) = Index n++    tabulate f = map f indicesI+    {-# INLINE tabulate #-}++    index = (!!)+    {-# INLINE index #-}
src/Clash/Sized/Vector.hs-boot view
@@ -4,20 +4,22 @@ Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DataKinds       #-}-{-# LANGUAGE GADTs           #-}-{-# LANGUAGE KindSignatures  #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeOperators   #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Clash.Sized.Vector where -import GHC.TypeLits  (KnownNat, Nat, type (<=))+import Data.Kind (Type)+import GHC.TypeLits  (KnownNat, Nat) import {-# SOURCE #-} Clash.Sized.Internal.BitVector (BitVector, Bit)  type role Vec nominal representational-data Vec :: Nat -> * -> *+data Vec :: Nat -> Type -> Type -instance (KnownNat n, 1 <= n) => Foldable (Vec n)+instance KnownNat n => Foldable (Vec n)  bv2v  :: KnownNat n => BitVector n -> Vec n Bit map   :: (a -> b) -> Vec n a -> Vec n b
+ src/Clash/Sized/Vector/ToTuple.hs view
@@ -0,0 +1,83 @@+{-|+Copyright  :  (C) 2024, Google LLC+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Tooling to safely work around @incomplete-uni-patterns@ and @incomplete-patterns@+warnings. See 'vecToTuple' for more information and examples.++Note: This module has been added to make upgrading to GHC 9.2 easier. As of GHC+      9.2, the @incomplete-uni-patterns@ has been added to the @-Wall@, making+      previously warning-free code now produce warnings.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilyDependencies #-}++-- Purpose of this module+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}++-- For debugging:+-- {-# OPTIONS_GHC -ddump-splices #-}++module Clash.Sized.Vector.ToTuple (VecToTuple(..)) where++import Clash.CPP+import Clash.Sized.Vector+import Clash.Sized.Vector.ToTuple.TH (vecToTupleInstances)++import Data.Tagged (Tagged(..))++import Data.Tuple (Solo(MkSolo))++{- $setup+>>> :set -XMonoLocalBinds -XGADTs+>>> import Clash.Sized.Vector+-}++class VecToTuple a where+  type TupType a = r | r -> a++  -- | Given a vector with three elements:+  --+  -- >>> myVec = (1 :> 2 :> 3 :> Nil) :: Vec 3 Int+  --+  -- The following would produce a warning even though we can be sure+  -- no other pattern can ever apply:+  --+  -- >>> (a :> b :> c :> Nil) = myVec+  --+  -- 'vecToTuple' can be used to work around the warning:+  --+  -- >>> (a, b, c) = vecToTuple myVec+  --+  -- Of course, you will still get an error if you try to match a vector of the+  -- wrong length:+  --+  -- >>> (a, b, c, d) = vecToTuple myVec+  -- ...+  --     • Couldn't match type: (a, b, c, d)+  --                      with: (Int, Int, Int)+  -- ...+  vecToTuple ::  a -> TupType a++instance VecToTuple (Vec 0 a) where+  type TupType (Vec 0 a) = Tagged a ()+  vecToTuple _ = Tagged ()++-- | Instead of using 'vecToTuple' for @Vec 1 _@, you could also consider using 'head'+instance VecToTuple (Vec 1 a) where+  type TupType (Vec 1 a) = Solo a+  vecToTuple (a1 :> _) = MkSolo a1++-- | __NB__: The documentation only shows instances up to /3/-tuples. By+-- default, instances up to and including /12/-tuples will exist. If the flag+-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The+-- GHC imposed limit is either 62 or 64 depending on the GHC version.+instance VecToTuple (Vec 2 a) where+  type TupType (Vec 2 a) = (a, a)+  vecToTuple (a1 :> a2 :> _) = (a1, a2)++vecToTupleInstances maxTupleSize
+ src/Clash/Sized/Vector/ToTuple/TH.hs view
@@ -0,0 +1,50 @@+{-# OPTIONS_HADDOCK hide #-}++{-# LANGUAGE TemplateHaskellQuotes #-}++module Clash.Sized.Vector.ToTuple.TH (vecToTupleInstance, vecToTupleInstances) where++import Clash.Sized.Vector (Vec((:>)))+import Language.Haskell.TH++appTs :: Q Type -> [Q Type] -> Q Type+appTs = foldl appT++appPsInfix :: Name -> [Q Pat] -> Q Pat+appPsInfix f = foldl1 (\l r -> uInfixP l f r)++tupT :: [Q Type] -> Q Type+tupT tyArgs = tupleT (length tyArgs) `appTs` tyArgs++vecToTupleInstances :: Integer -> Q [Dec]+vecToTupleInstances n = mapM vecToTupleInstance [3..n]++vecToTupleInstance :: Integer -> Q Dec+vecToTupleInstance n =+  instanceD+    -- No superclasses+    (pure [])++    -- Head+    (vecToTupleCon `appT` vecType)++    -- Implementation+    [ tySynInstD (tySynEqn Nothing aTypeLhs aTypeRhs)+    , funD vecToTupleFunName [clause [vecToTuplePat] (normalB vecToTupleImpl) []]+    ]++ where+  vecToTupleCon = conT (mkName "VecToTuple")+  vecType = conT ''Vec `appT` litT (numTyLit n) `appT` varT (mkName "a")++  -- associated type+  tupTypeCon = conT (mkName "TupType")+  aTypeLhs = tupTypeCon `appT` vecType+  aTypeRhs = tupT [varT (mkName "a") | _ <- [1..n]]++  -- vecToTuple+  vecToTupleFunName = mkName "vecToTuple"+  vecToTuplePat = appPsInfix '(:>) (map varP varNames ++ [wildP])+  vecToTupleImpl = tupE (map varE varNames)++  varNames = map (mkName . ('a':) . show) [1..n]
src/Clash/Tutorial.hs view
@@ -1,2548 +1,25 @@ {-| Copyright : © 2014-2016, Christiaan Baaij,               2017-2019, Myrtle Software Ltd-              2017     , QBayLogic, Google Inc.-Licence   : Creative Commons 4.0 (CC BY 4.0) (http://creativecommons.org/licenses/by/4.0/)--}--{-# LANGUAGE NoImplicitPrelude, MagicHash #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}--module Clash.Tutorial (-  -- * Introduction-  -- $introduction--  -- * Install Clash-  -- $installation--  -- * Working with this tutorial-  -- $working--  -- * Your first circuit-  -- $mac_example--  -- *** Sequential circuit-  -- $mac2--  -- *** Generating VHDL-  -- $mac3--  -- *** Circuit testbench-  -- $mac4--  -- *** Generating Verilog and SystemVerilog-  -- $mac5--  -- *** Alternative specifications-  -- $mac6--  -- * Higher-order functions-  -- $higher_order--  -- * Composition of sequential circuits-  -- $composition_sequential--  -- * Synthesize annotations: controlling the VHDL\/(System)Verilog generation.-  -- $annotations--  -- * Multiple clock domains-  -- $multiclock--  -- * Advanced: Primitives-  -- $primitives--  -- *** Verilog primitives-  -- $vprimitives--  -- *** SystemVerilog primitives-  -- $svprimitives--  -- * Conclusion-  -- $conclusion--  -- * Troubleshooting-  -- $errorsandsolutions--  -- * Limitations of Clash-  -- $limitations--  -- * Clash vs Lava-  -- $vslava--  -- * Migration guide from Clash 0.99-  -- $migration-  )-where--import Clash.Prelude-import Clash.Explicit.Testbench-import Clash.XException (NFDataX)-import Control.Monad.ST-import Data.Array-import Data.Char-import Data.Int-import GHC.Prim-import GHC.TypeLits-import GHC.Word-import Data.Default.Class--{- $setup->>> :set -XTemplateHaskell -XDataKinds -XConstraintKinds -XTypeApplications->>> :{-let ma :: Num a => a -> (a, a) -> a-    ma acc (x,y) = acc + x * y-:}-->>> :{-let macT :: Num a => a -> (a,a) -> (a,a)-    macT acc (x,y) = (acc',o)-       where-         acc' = ma acc (x,y)-         o    = acc-:}-->>> :set -XFlexibleContexts->>> :set -fplugin GHC.TypeLits.Normalise->>> let compareSwapL a b = if a < b then (a,b) else (b,a)->>> :{-let sortV xs = map fst sorted :< (snd (last sorted))-      where-        lefts  = head xs :> map snd (init sorted)-        rights = tail xs-        sorted = zipWith compareSwapL lefts rights-:}-->>> :{-let sortVL xs = map fst sorted :< (snd (last sorted))-      where-        lefts  = head xs :> map snd (init sorted)-        rights = tail xs-        sorted = zipWith compareSwapL (lazyV lefts) rights-:}-->>> let mac = mealy macT 0->>> :{-topEntity-  :: Clock System-  -> Reset System-  -> Enable System-  -> Signal System (Signed 9, Signed 9)-  -> Signal System (Signed 9)-topEntity = exposeClockResetEnable mac-:}-->>> :{-let testBench :: Signal System Bool-    testBench = done-      where-        testInput      = stimuliGenerator clk rst $(listToVecTH [(1,1) :: (Signed 9,Signed 9),(2,2),(3,3),(4,4)])-        expectedOutput = outputVerifier' clk rst $(listToVecTH [0 :: Signed 9,1,5,14,14,14,14])-        done           = expectedOutput (topEntity clk rst enableGen testInput)-        clk            = tbSystemClockGen (not <$> done)-        rst            = systemResetGen-:}-->>> :{-let fibR :: Unsigned 64 -> Unsigned 64-    fibR 0 = 0-    fibR 1 = 1-    fibR n = fibR (n-1) + fibR (n-2)-:}-->>> :{-let fibS :: SystemClockResetEnable => Signal System (Unsigned 64)-    fibS = r-      where r = register 0 r + register 0 (register 1 r)-:}---}--{- $introduction-Clash is a functional hardware description language that borrows both its syntax-and semantics from the functional programming language Haskell. It provides a-familiar structural design approach to both combination and synchronous-sequential circuits. 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.-  * Compile your designs for fast simulation.-  * Higher-order functions, in combination 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.-  * Multiple clock domains, with type safe clock domain crossing.-  * Template language for introducing new VHDL/(System)Verilog primitives.--Although we say that Clash borrows the semantics of Haskell, that statement-should be taken with a grain of salt. What we mean to say is that the Clash-compiler views a circuit description as /structural/ description. This means,-in an academic handwavy way, that every function denotes a component and every-function application denotes an instantiation of said component. Now, this has-consequences on how we view /recursively/ defined functions: structurally, a-recursively defined function would denote an /infinitely/ deep / structured-component, something that cannot be turned into an actual circuit-(See also <#limitations Limitations of Clash>).--On the other hand, Haskell's by-default non-strict evaluation works very well-for the simulation of the feedback loops, which are ubiquitous in digital-circuits. That is, when we take our structural view to circuit descriptions,-value-recursion corresponds directly to a feedback loop:--@-counter = s-  where-    s = 'register' 0 (s + 1)-@--The above definition, which uses value-recursion, /can/ be synthesized to a-circuit by the Clash compiler.--Over time, you will get a better feeling for the consequences of taking a-/structural/ view on circuit descriptions. What is always important to-remember is that every applied functions results in an instantiated component,-and also that the compiler will /never/ infer / invent more logic than what is-specified in the circuit description.--With that out of the way, let us continue with installing Clash and building-our first circuit.--}--{- $installation-For installation instructions, see <https://clash-lang.org/install/ clash-lang.org/install/>.--}--{- $working-This tutorial can be followed best whilst having the Clash interpreter running-at the same time. If you followed the installation instructions, you already-know how to start the Clash compiler in interpretive mode:--@-clash.clashi  # When installed from source, use 'clashi'-@--For those familiar with Haskell/GHC, this is indeed just @GHCi@, with three-added commands (@:vhdl@, @:verilog@, and @:systemverilog@). You can load files-into the interpreter using the @:l \<FILENAME\>@ command. Now, depending on your-choice in editor, the following @edit-load-run@ cycle probably work best for you:--  * __Commandline (e.g. emacs, vim):__--      * You can run system commands using @:!@, for example @:! touch \<FILENAME\>@-      * Set the /editor/ mode to your favourite editor using: @:set editor \<EDITOR\>@-      * You can load files using @:l@ as noted above.-      * You can go into /editor/ mode using: @:e@-      * Leave the editor mode by quitting the editor (e.g. @:wq@ in @vim@)--  * __GUI (e.g. SublimeText, Notepad++):__--      * Just create new files in your editor.-      * Load the files using @:l@ as noted above.-      * Once a file has been edited and saved, type @:r@ to reload the files in-        the interpreter--You are of course free to deviate from these suggestions as you see fit :-) It-is just recommended that you have the Clash interpreter open during this-tutorial.--}--{- $mac_example-The very first circuit that we will build is the \"classic\" multiply-and-accumulate-(MAC) circuit. This circuit is as simple as it sounds, it multiplies its inputs-and accumulates them. Before we describe any logic, we must first create the-file we will be working on and input some preliminaries:--* Create the file:--    @-    MAC.hs-    @--* Write on the first line the module header:--    @-    module MAC where-    @--    Module names must always start with a __C__apital letter. Also make sure that-    the file name corresponds to the module name.--* Add the import statement for the Clash prelude library:--    @-    import Clash.Prelude-    @--    This imports all the necessary functions and datatypes for circuit description.--We can now finally start describing the logic of our circuit, starting with just-the multiplication and addition:--@-ma acc (x, y) = acc + x * y-@--The circuit we just wrote is a combinational circuit: no registers are inserted-(you describe explicitly where Clash will insert registers, as we'll later see). We usually-refer to circuits as /functions/, similar to programming languages such as C,-Python, or Haskell. In this case, the function we just defined is called @ma@.-Its first argument is @acc@, its second is @(x, y)@ - a composite type called a-tuple. This component is "unpacked", and its first element is called @x@, its-second @y@. Everything to the right of the equals symbol is @ma@'s-result.-If you followed the instructions of running the interpreter side-by-side, you-can already test this function:-->>> ma 4 (8, 9)-76->>> ma 2 (3, 4)-14--We can also examine the inferred type of @ma@ in the interpreter:-->>> :t ma-ma :: Num a => a -> (a, a) -> a--You should read this as follows:-- * __@ma ::@__, @ma@ is of type..-- * __@Num a@__, there is some type called @a@ that is a @'Num'@. Examples of-   instances of @'Num'@ are @'Int'@, @'Signed' 16@, @'Index' 32@, and @'Float'@.-- * __@a@__, @ma@'s first argument is of type @a@-- * __@(a, a)@__, @ma@'s second argument is of type @(a, a)@-- * __@a@__, @ma@'s result is of type @a@--Note that @ma@ therefore works on multiple types! The only condition we-imposed is that @a@ should be a @'Num'@ber type. In Clash this means it should-support the operations @'Prelude.+'@, @'Prelude.-'@, @'Prelude.*'@, and some-others. Indeed, this is why Clash adds the constraint in the first place: the-definition of @ma@ uses @+@ and @*@. Whenever a function works over multiple-types, we call it /polymorphic/ ("poly" meaning "many", "morphic" meaning-"forms"). While powerful, its not clear how Clash should synthesize this as-numbers come in a great variety in (bit)sizes. We will later see how to use this-function in a /monomorphic/ manner.--Talking about /types/ also brings us to one of the most important parts of this-tutorial: /types/ and /synchronous sequential logic/. Especially how we can-always determine, through the types of a specification, if it describes-combinational logic or (synchronous) sequential logic. We do this by examining-the definition of one of the sequential primitives, the @'register'@ function:--@-register-     ( 'HiddenClockResetEnable' dom-     , 'Clash.XException.NFDataX' a )-  => a-  -> 'Signal' dom a-  -> 'Signal' dom a-register i s = ...-@--Where we see that the second argument and the result are not just of the-/polymorphic/ @a@ type, but of the type: @'Signal' dom a@. All (synchronous)-sequential circuits work on values of type @'Signal' dom a@. Combinational-circuits always work on values of, well, not of type @'Signal' dom a@. A 'Signal'-is an (infinite) list of samples, where the samples correspond to the values-of the 'Signal' at discrete, consecutive, ticks of the /clock/. All (sequential)-components in the circuit are synchronized to this global /clock/. For the-rest of this tutorial, and probably at any moment where you will be working with-Clash, you should probably not actively think about 'Signal's as infinite lists-of samples, but just as values that are manipulated by sequential circuits. To-make this even easier, it actually not possible to manipulate the underlying-representation directly: you can only modify 'Signal' values through a set of-primitives such as the 'register' function above.--Now, let us get back to the functionality of the 'register' function: it is-a simple <https://en.wikipedia.org/wiki/Flip-flop_(electronics) latch> that-only changes state at the tick of the global /clock/, and-it has an initial value @a@ which is its output at time 0. We can further-examine the 'register' function by taking a look at the first 4 samples of the-'register' functions applied to a constant signal with the value 8:-->>> sampleN @System 4 (register 0 (pure (8 :: Signed 8)))-[0,0,8,8]--Where we see that the initial value of the signal is the specified 0 value,-followed by 8's. You might be surprised to see /two/ zeros instead of just a-single zero. What happens is that in Clash you get to see the output of the-circuit /before/ the clock becomes actives. In other words, in Clash you get to-describe the powerup values of registers too. Whether this is a defined or-unknown value depends on your hardware target, and can be configured by using a-different synthesis @'Domain'@. The default synthesis domain, @'System', assumes-that registers do have a powerup value - as is true for most FPGA platforms in-most contexts.--}--{- $mac2-The 'register' function is our primary sequential building block to capture-/state/. It is used internally by one of the "Clash.Prelude" function that we-will use to describe our MAC circuit. Note that the following paragraphs will-only show one of many ways to specify a sequential circuit, at the section we-will show a couple more.--A principled way to describe a sequential circuit is to use one of the classic-machine models, within the Clash prelude library offer standard function to-support the <http://en.wikipedia.org/wiki/Mealy_machine Mealy machine>.-To improve sharing, we will combine the transition function and output function-into one. This gives rise to the following Mealy specification of the MAC-circuit:--@-macT acc (x, y) = (acc', o)-  where-    acc' = ma acc (x, y)-    o    = acc-@--Note that the @where@ clause and explicit tuple are just for demonstrative-purposes, without loss of sharing we could've also written:--@-macT acc inp = (ma acc inp, acc)-@--Going back to the original specification we note the following:--  * 'acc' is the current /state/ of the circuit.-  * '(x, y)' is its input.-  * 'acc'' is the updated, or next, /state/.-  * 'o' is the output.--When we examine the type of 'macT' we see that is still completely combinational:-->>> :t macT-macT :: Num a => a -> (a, a) -> (a, a)--The "Clash.Prelude" library contains a function that creates a sequential-circuit from a combinational circuit that has the same Mealy machine type /-shape of @macT@:--@-mealy-  :: ('HiddenClockResetEnable' dom, 'Clash.XException.NFDataX' s)-  => (s -> i -> (s,o))-  -> s-  -> ('Signal' dom i -> 'Signal' dom o)-mealy f initS = ...-@--The complete sequential MAC circuit can now be specified as:--@-mac = 'mealy' macT 0-@--Where the first argument of @'mealy'@ is our @macT@ function, and the second-argument is the initial state, in this case 0. We can see it is functioning-correctly in our interpreter:-->>> import qualified Data.List as L->>> L.take 4 $ simulate @System mac [(1,1),(2,2),(3,3),(4,4)]-[0,1,5,14]--Where we simulate our sequential circuit over a list of input samples and take-the first 4 output samples. We have now completed our first sequential circuit-and have made an initial confirmation that it is working as expected.--}--{- $mac3-We are now almost at the point that we can create actual hardware, in the form-of a <http://en.wikipedia.org/wiki/VHDL VHDL> netlist, from our sequential-circuit specification. The first thing we have to do is create a function-called 'topEntity' and ensure that it has a __monomorphic__ type. In our case-that means that we have to give it an explicit type annotation. It might not-always be needed, you can always check the type with the @:t@ command and see-if the function is monomorphic:--@-topEntity-  :: 'Clock' 'System'-  -> 'Reset' 'System'-  -> 'Signal' 'System' ('Signed' 9, 'Signed' 9)-  -> 'Signal' 'System' ('Signed' 9)-topEntity = 'exposeClockResetEnable' mac-@--Which makes our circuit work on 9-bit signed integers. Including the above-definition, our complete @MAC.hs@ should now have the following content:--@-module MAC where--import "Clash.Prelude"--ma acc (x,y) = acc + x * y--macT acc (x,y) = (acc',o)-  where-    acc' = ma acc (x,y)-    o    = acc--mac = 'mealy' macT 0--topEntity-  :: 'Clock' 'System'-  -> 'Reset' 'System'-  -> 'Enable' 'System'-  -> 'Signal' 'System' ('Signed' 9, 'Signed' 9)-  -> 'Signal' 'System' ('Signed' 9)-topEntity = 'exposeClockResetEnable' mac-@--The 'topEntity' function is the starting point for the Clash compiler to-transform your circuit description into a VHDL netlist. It must meet the-following restrictions in order for the Clash compiler to work:--  * It must be completely monomorphic-  * It must be completely first-order-  * Although not strictly necessary, it is recommended to /expose/ 'Hidden'-    clock and reset arguments, as it makes user-controlled-    <Clash-Tutorial.html#annotations name assignment> in the generated HDL-    easier to do.--Our 'topEntity' meets those restrictions, and so we can convert it successfully-to VHDL by executing the @:vhdl@ command in the interpreter. This will create-a directory called 'vhdl', which contains a directory called @MAC@, which-ultimately contains all the generated VHDL files. You can now load these files-into your favourite VHDL synthesis tool, marking @mac_topentity.vhdl@ as the file-containing the top level entity.--}--{- $mac4-There are multiple reasons as to why you might want to create a so-called-/test bench/ for the generated HDL:--  * You want to compare post-synthesis / post-place&route behavior to that of-    the behavior of the original generated HDL.-  * Need representative stimuli for your dynamic power calculations.-  * Verify that the HDL output of the Clash compiler has the same behavior as-    the Haskell / Clash specification.--For these purposes, you can have the Clash compiler generate a /test bench/. In-order for the Clash compiler to do this you need to do one of the following:--  * Create a function called /testBench/ in the root module.-  * Annotate your /topEntity/ function (or function with a-    <Clash-Tutorial.html#g:12 Synthesize> annotation)-    with a 'TestBench' annotation.--For example, you can test the earlier defined /topEntity/ by:--@-import "Clash.Explicit.Testbench"--topEntity-  :: 'Clock' System-  -> 'Reset' System-  -> 'Enable' System-  -> 'Signal' System ('Signed' 9, 'Signed' 9)-  -> 'Signal' System ('Signed' 9)-topEntity = 'exposeClockReset' mac--testBench :: 'Signal' System Bool-testBench = done-  where-    testInput    = 'stimuliGenerator' clk rst $('listToVecTH' [(1,1) :: ('Signed' 9,'Signed' 9),(2,2),(3,3),(4,4)])-    expectOutput = 'outputVerifier'' clk rst $('listToVecTH' [0 :: 'Signed' 9,1,5,14,14,14,14])-    done         = expectOutput (topEntity clk rst en testInput)-    en           = 'enableGen'-    clk          = 'tbSystemClockGen' (not '<$>' done)-    rst          = 'systemResetGen'-@--This will create a stimulus generator that creates the same inputs as we used-earlier for the simulation of the circuit, and creates an output verifier that-compares against the results we got from our earlier simulation. We can even-simulate the behavior of the /testBench/:-->>> sampleN 8 testBench-[False,False,False,False,False-cycle(<Clock: System>): 5, outputVerifier-expected value: 14, not equal to actual value: 30-,False-cycle(<Clock: System>): 6, outputVerifier-expected value: 14, not equal to actual value: 46-,False-cycle(<Clock: System>): 7, outputVerifier-expected value: 14, not equal to actual value: 62-,False]--We can see that for the first 4 samples, everything is working as expected,-after which warnings are being reported. The reason is that 'stimuliGenerator'-will keep on producing the last sample, (4,4), while the 'outputVerifier'' will-keep on expecting the last sample, 14. In the VHDL testbench these errors won't-show, as the global clock will be stopped after 4 ticks.--You should now again run @:vhdl@ in the interpreter; this time the compiler-will take a bit longer to generate all the circuits. Inside the @.\/vhdl\/MAC@-directory you will now also find a /mac_testbench/ subdirectory containing all-the @vhdl@ files for the /test bench/.---After compilation is finished you  load all the files in your favourite VHDL-simulation tool. Once all files are loaded into the VHDL simulator, run the-simulation on the @mac_testbench_testbench@ entity.-On questasim / modelsim: doing a @run -all@ will finish once the output verifier-will assert its output to @true@. The generated testbench, modulo the clock-signal generator(s), is completely synthesizable. This means that if you want to-test your circuit on an FPGA, you will only have to replace the clock signal-generator(s) by actual clock sources, such as an onboard PLL.--}--{- $mac5-Aside from being able to generate VHDL, the Clash compiler can also generate Verilog-and SystemVerilog. You can repeat the previous two parts of the tutorial, but-instead of executing the @:vhdl@ command, you execute the @:verilog@ or-@:sytemverilog@ command in the interpreter. This will create a directory called-@verilog@, respectively @systemverilog@, which contains a directory called @MAC@,-which ultimately contains all the generated Verilog and SystemVerilog files.-Verilog files end in the file extension @v@, while SystemVerilog files end in-the file extension @sv@.--This concludes the main part of this section on \"Your first circuit\", read on-for alternative specifications for the same 'mac' circuit, or just skip to the-next section where we will describe another DSP classic: an FIR filter-structure.--}--{- $mac6-* __'Num' instance for 'Signal'__:--    @'Signal' a@ is also also considered a 'Num'eric type as long as the value-    type /a/ is also 'Num'eric.  This means that we can also use the standard-    numeric operators, such as ('*') and ('+'), directly on signals. An-    alternative specification of the 'mac' circuit will also use the 'register'-    function directly:--    @-    macN (x,y) = acc-      where-        acc = 'register' 0 (acc + x * y)-    @--* __'Applicative' instance for 'Signal'__:--    We can also mix the combinational 'ma' function, with the sequential-    'register' function, by lifting the 'ma' function to the sequential 'Signal'-    domain using the operators ('<$>' and '<*>') of the 'Applicative' type-    class:--    @-    macA (x,y) = acc-      where-        acc  = 'register' 0 acc'-        acc' = ma '<$>' acc '<*>' 'bundle' (x,y)-    @--* __'Control.Monad.State.Lazy.State' Monad__--    We can also implement the original @macT@ function as a-    @'Control.Monad.State.Lazy.State'@-    monadic computation. First we must add an extra import statement, right-    after the import of "Clash.Prelude":--    @-    import Control.Monad.State-    @--    We can then implement macT as follows:--    @-    macTS (x,y) = do-      acc <- 'Control.Monad.State.Lazy.get'-      'Control.Monad.State.Lazy.put' (acc + x * y)-      return acc-    @--    We can use the 'mealy' function again, although we will have to change-    position of the arguments and result:--    @-    asStateM-      :: ( 'HiddenClockResetEnable' dom-         , 'NFDataX' s )-      => (i -> 'Control.Monad.State.Lazy.State' s o)-      -> s-      -> ('Signal' dom i -> 'Signal' dom o)-    asStateM f i = 'mealy' g i-      where-        g s x = let (o,s') = 'Control.Monad.State.Lazy.runState' (f x) s-                in  (s',o)-    @--    We can then create the complete 'mac' circuit as:--    @-    macS = asStateM macTS 0-    @--}--{- $higher_order-An FIR filter is defined as: the dot-product of a set of filter coefficients and-a window over the input, where the size of the window matches the number-of coefficients.--@-dotp as bs = 'sum' ('zipWith' (*) as bs)--fir coeffs x_t = y_t-  where-    y_t = dotp coeffs xs-    xs  = 'window' x_t--topEntity-  :: 'Clock' 'System'-  -> 'Reset' 'System'-  -> 'Enable' 'System'-  -> 'Signal' 'System' ('Signed' 16)-  -> 'Signal' 'System' ('Signed' 16)-topEntity = exposeClockResetEnableEnable (fir (0 ':>' 1 ':>' 2 ':>' 3 ':>' 'Nil'))-@--Here we can see that, although the Clash compiler handles recursive function-definitions poorly, many of the regular patterns that we often encounter in-circuit design are already captured by the higher-order functions that are-present for the 'Vec'tor type.--}--{- $composition_sequential-Given a function @f@ of type:--@-__f__ :: Int -> (Bool, Int) -> (Int, (Int, Bool))-@--When we want to make compositions of @f@ in @g@ using 'mealy', we have to-write:--@-g a b c = (b1,b2,i2)-  where-    (i1,b1) = 'unbundle' ('mealy' f 0 ('bundle' (a,b)))-    (i2,b2) = 'unbundle' ('mealy' f 3 ('bundle' (c,i1)))-@--Why do we need these 'bundle', and 'unbundle' functions you might ask? When we-look at the type of 'mealy':--@-__mealy__-  :: HiddenClockResetEnable dom-  => (s -> i -> (s,o))-  -> s-  -> ('Signal' dom i -> 'Signal' dom o)-@--we see that the resulting function has an input of type @'Signal' i@, and an-output of @'Signal' o@. However, the type of @(a,b)@ in the definition of @g@ is:-@('Signal' Bool, 'Signal' Int)@. And the type of @(i1,b1)@ is of type-@('Signal' Int, 'Signal' Bool)@.--Syntactically, @'Signal' dom (Bool,Int)@ and @('Signal' dom Bool,-'Signal' dom Int)@ are /unequal/.-So we need to make a conversion between the two, that is what 'bundle' and-'unbundle' are for. In the above case 'bundle' gets the type:--@-__bundle__ :: ('Signal' dom Bool, 'Signal' dom Int) -> 'Signal' dom (Bool,Int)-@--and 'unbundle':--@-__unbundle__ :: 'Signal' dom (Int,Bool) -> ('Signal' dom Int, 'Signal' dom Bool)-@--The /true/ types of these two functions are, however:--@-__bundle__   :: 'Bundle' a => 'Unbundled' dom a -> 'Signal' dom a-__unbundle__ :: 'Bundle' a => 'Signal' dom a -> 'Unbundled' dom a-@--'Unbundled' is an <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#associated-data-and-type-families associated type family>-belonging to the 'Bundle' <http://en.wikipedia.org/wiki/Type_class type class>,-which, together with 'bundle' and 'unbundle' defines the isomorphism between a-product type of 'Signal's and a 'Signal' of a product type. That is, while-@(Signal a, Signal b)@ and @Signal (a,b)@ are not equal, they are /isomorphic/-and can be converted from, or to, the other using 'bundle' and 'unbundle'.--Instances of this 'Bundle' type-class are defined as /isomorphisms/ for:--  * All tuples up to and including 62-tuples (GHC limit)-  * The 'Vec'tor type--But they are defined as /identities/ for:--  * All elementary / primitive types such as: 'Bit', 'Bool', @'Signed' n@, etc.--That is:--@-instance 'Bundle' (a,b) where-  type 'Unbundled' dom (a,b) = ('Signal' dom a, 'Signal' dom b)-  bundle   (a,b) = (,) '<$>' a '<*>' b-  unbundle tup   = (fst '<$>' tup, snd '<*>' tup)-@--but,--@-instance 'Bundle' Bool where-  type 'Unbundled' clk Bool = 'Signal' clk Bool-  bundle   s = s-  unbundle s = s-@--What you need take away from the above is that a product type (e.g. a tuple) of-'Signal's is not syntactically equal to a 'Signal' of a product type, but that-the functions of the 'Bundle' type class allow easy conversion between the two.--As a final note on this section we also want to mention the 'mealyB' function,-which does the bundling and unbundling for us:--@-mealyB-  :: ('Bundle' i, 'Bundle' o)-  => (s -> i -> (s,o))-  -> s-  -> 'Unbundled' dom i-  -> 'Unbundled' dom o-@--Using 'mealyB' we can define @g@ as:--@-g a b c = (b1,b2,i2)-  where-    (i1,b1) = 'mealyB' f 0 (a,b)-    (i2,b2) = 'mealyB' f 3 (c,i1)-@--The general rule of thumb is: always use 'mealy', unless you do pattern matching-or construction of product types, then use 'mealyB'.--}--{- $annotations #annotations#-'Synthesize' annotations allow us to control hierarchy and naming aspects of the-Clash compiler, specifically, they allow us to:--    * Assign names to entities (VHDL) \/ modules ((System)Verilog), and their-      ports.-    * Put generated HDL files of a logical (sub)entity in their own directory.-    * Use cached versions of generated HDL, i.e., prevent recompilation of-      (sub)entities that have not changed since the last run. Caching is based-      on a @.manifest@ which is generated alongside the HDL; deleting this file-      means deleting the cache; changing this file will result in /undefined/-      behavior.--Functions with a 'Synthesize' annotation must adhere to the following-restrictions:--    * Although functions with a 'Synthesize' annotation can of course depend-      on functions with another 'Synthesize' annotation, they must not be-      mutually recursive.-    * Functions with a 'Synthesize' annotation must be completely /monomorphic/-      and /first-order/, and cannot have any /non-representable/ arguments or-      result.--Also take the following into account when using 'Synthesize' annotations.--    * The Clash compiler is based on the GHC Haskell compiler, and the GHC-      machinery does not understand 'Synthesize' annotations and it might-      subsequently decide to inline those functions. You should therefor also-      add a @{\-\# NOINLINE f \#-\}@ pragma to the functions which you give-      a 'Synthesize' functions.-    * Functions with a 'Synthesize' annotation will not be specialized-      on constants.--Finally, the root module, the module which you pass as an argument to the-Clash compiler must either have:--    * A function with a 'Synthesize' annotation.-    * A function called /topEntity/.--You apply 'Synthesize' annotations to functions using an @ANN@ pragma:--@-{\-\# ANN topEntity (Synthesize {t_name = ..., ...  }) \#-\}-topEntity x = ...-@--For example, given the following specification:--@-module Blinker where--import "Clash.Signal"-import "Clash.Prelude"-import "Clash.Intel.ClockGen"--'createDomain' vSystem{vName=\"DomInput\", vPeriod=20000}-'createDomain' vSystem{vName=\"Dom50\", vPeriod=50000}--topEntity-  :: Clock \"DomInput\"-  -> Signal \"DomInput\" Bool-  -> Signal \"Dom50\" Bit-  -> Signal \"Dom50\" (BitVector 8)-topEntity clk rst =-    'exposeClockResetEnable' ('mealy' blinkerT (1,False,0) . Clash.Prelude.isRising 1) pllOut rstSync 'enableGen'-  where-    (pllOut,pllStable) = 'Clash.Intel.ClockGen.altpll' @"Dom50" (SSymbol @"altpll50") clk ('Clash.Signal.unsafeFromLowPolarity' rst)-    rstSync            = 'Clash.Signal.resetSynchronizer' pllOut ('Clash.Signal.unsafeFromLowPolarity' pllStable) enableGen--blinkerT (leds,mode,cntr) key1R = ((leds',mode',cntr'),leds)-  where-    -- clock frequency = 50e6  (50 MHz)-    -- led update rate = 333e-3 (every 333ms)-    cnt_max = 16650000 :: ('Index' 16650001) -- 50e6 * 333e-3--    cntr' | cntr == cnt_max = 0-          | otherwise       = cntr + 1--    mode' | key1R     = not mode-          | otherwise = mode--    leds' | cntr == 0 = if mode then complement leds-                                else rotateL leds 1-          | otherwise = leds-@--The Clash compiler will normally generate the following @blinker_topEntity.vhdl@ file:--@--- Automatically generated VHDL-93-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.blinker_types.all;--entity blinker_topentity is-  port(-- clock-       clk  : in blinker_types.clk_dominput;-       rst  : in boolean;-       x    : in std_logic;-       leds : out std_logic_vector(7 downto 0));-end;--architecture structural of blinker_topentity is- ...-end;-@--However, if we add the following 'Synthesize' annotation in the file:--@-{\-\# ANN topEntity-  ('Synthesize'-    { t_name   = "blinker"-    , t_inputs = [PortName \"CLOCK_50\", PortName \"KEY0\", PortName \"KEY1\"]-    , t_output = PortName \"LED\"-    }) \#-\}-@--The Clash compiler will generate the following @blinker.vhdl@ file instead:--@--- Automatically generated VHDL-93-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.blinker_types.all;--entity blinker is-  port(-- clock-       CLOCK_50 : in blinker_types.clk_dominput;-       KEY0     : in boolean;-       KEY1     : in std_logic;-       LED      : out std_logic_vector(7 downto 0));-end;--architecture structural of blinker is- ...-end;-@--Where we now have:--* A top-level component that is called @blinker@.-* Inputs and outputs that have a /user/-chosen name: @CLOCK_50@, @KEY0@, @KEY1@, @LED@, etc.--See the documentation of 'Synthesize' for the meaning of all its fields.--}--{- $primitives #primitives#-There are times when you already have an existing piece of IP, or there are-times where you need the VHDL to have a specific shape so that the VHDL-synthesis tool can infer a specific component. In these specific cases you can-resort to defining your own VHDL primitives. Actually, most of the primitives-in Clash are specified in the same way as you will read about in this section.-There are perhaps 10 (at most) functions which are truly hard-coded into the-Clash compiler. You can take a look at the files in-<https://github.com/clash-lang/clash-compiler/tree/master/clash-lib/prims/vhdl>-(or <https://github.com/clash-lang/clash-compiler/tree/master/clash-lib/prims/verilog>-for the Verilog primitives or <https://github.com/clash-lang/clash-compiler/tree/master/clash-lib/prims/systemverilog>-for the SystemVerilog primitives) if you want to know which functions are defined-as \"regular\" primitives. The compiler looks for primitives in four locations:--* The official install location: e.g.--    * @$CABAL_DIR\/share\/\<GHC_VERSION\>\/clash-lib\-<VERSION\>\/prims\/common@-    * @$CABAL_DIR\/share\/\<GHC_VERSION\>\/clash-lib\-<VERSION\>\/prims\/commonverilog@-    * @$CABAL_DIR\/share\/\<GHC_VERSION\>\/clash-lib\-<VERSION\>\/prims\/systemverilog@-    * @$CABAL_DIR\/share\/\<GHC_VERSION\>\/clash-lib\-<VERSION\>\/prims\/verilog@-    * @$CABAL_DIR\/share\/\<GHC_VERSION\>\/clash-lib\-<VERSION\>\/prims\/vhdl@--* Directories indicated by a 'Clash.Annotations.Primitive.Primitive' annotation-* The current directory (the location given by @pwd@)-* The include directories specified on the command-line: @-i\<DIR\>@--Where redefined primitives in the current directory or include directories will-overwrite those in the official install location. For now, files containing-primitive definitions must have an @.json@ file-extension.--Clash differentiates between two types of primitives, /expression/ primitives-and /declaration/ primitives, corresponding to whether the primitive is a VHDL-/expression/ or a VHDL /declaration/. We will first explore /expression/-primitives, using 'Signed' multiplication ('*') as an example. The-"Clash.Sized.Internal.Signed" module specifies multiplication as follows:--@-(*#) :: 'GHC.TypeLits.KnownNat' n => 'Signed' n -> 'Signed' n -> 'Signed' n-(S a) *# (S b) = fromInteger_INLINE (a * b)-{\-\# NOINLINE (*#) \#-\}-@--For which the VHDL /expression/ primitive is:--@-{ \"BlackBox\" :-  { "name"     : "Clash.Sized.Internal.Signed.*#"-  , "kind"     : \"Expression\"-  , "template" : "resize(~ARG[1] * ~ARG[2], ~LIT[0])"-  }-}-@--The @name@ of the primitive is the /fully qualified/ name of the function you-are creating the primitive for. Because we are creating an /expression/-primitive the kind must be set to @Expression@. As the name suggest, it is a VHDL-/template/, meaning that the compiler must fill in the holes heralded by the-tilde (~). Here:--  * @~ARG[1]@ denotes the second argument given to the @(*#)@ function, which-    corresponds to the LHS of the ('*') operator.-  * @~ARG[2]@ denotes the third argument given to the @(*#)@ function, which-    corresponds to the RHS of the ('*') operator.-  * @~LIT[0]@ denotes the first argument given to the @(*#)@ function, with-    the extra condition that it must be a @LIT@eral. If for some reason this-    first argument does not turn out to be a literal then the compiler will-    raise an error. This first arguments corresponds to the \"@'KnownNat' n@\"-    class constraint.--An extensive list with all of the template holes will be given the end of this-section. What we immediately notice is that class constraints are counted as-normal arguments in the primitive definition. This is because these class-constraints are actually represented by ordinary record types, with fields-corresponding to the methods of the type class. In the above case, 'KnownNat'-is actually just like a @newtype@ wrapper for 'Integer'.--The second kind of primitive that we will explore is the /declaration/ primitive.-We will use 'blockRam#' as an example, for which the Haskell/Clash code is:--@-{\-\# LANGUAGE BangPatterns \#\-\}--module BlockRam where--import Clash.Explicit.Prelude-import qualified Data.Vector           as V-import           GHC.Stack             (HasCallStack, withFrozenCallStack)--import Clash.Signal.Internal-  (Clock, Signal (..), (.&&.))-import Clash.Sized.Vector     (Vec, toList)-import Clash.XException       (defaultSeqX)---blockRam#-  :: ( HasCallStack-     , NFDataX a )-  => 'Clock' dom           -- ^ 'Clock' to synchronize to-  -> 'Enable' dom          -- ^ Global enable-  -> 'Vec' n a             -- ^ Initial content of the BRAM, also-                           -- determines the size, @n@, of the BRAM.-                           ---                           -- __NB__: __MUST__ be a constant.-  -> 'Signal' dom Int      -- ^ Read address @r@-  -> 'Signal' dom Bool     -- ^ Write enable-  -> 'Signal' dom Int      -- ^ Write address @w@-  -> 'Signal' dom a        -- ^ Value to write (at address @w@)-  -> 'Signal' dom a        -- ^ Value of the @blockRAM@ at address @r@ from-                           -- the previous clock cycle-blockRam# (Clock _) gen content rd wen =-  go-    (V.fromList ('toList' content))-    (withFrozenCallStack ('deepErrorX' "blockRam: intial value undefined"))-    (fromEnable gen)-    rd-    (fromEnable gen '.&&.' wen)- where-  go !ram o ret\@(~(re :- res)) rt\@(~(r :- rs)) et\@(~(e :- en)) wt\@(~(w :- wr)) dt\@(~(d :- din)) =-    let ram' = d ``defaultSeqX`` upd ram e (fromEnum w) d-        o'   = if re then ram V.! r else o-    in  o ``seqX`` o :- (ret ``seq`` rt ``seq`` et ``seq`` wt ``seq`` dt ``seq`` go ram' o' res rs en wr din)--  upd ram we waddr d = case maybeIsX we of-    Nothing -> case maybeIsX waddr of-      Nothing -> V.map (const (seq waddr d)) ram-      Just wa -> ram V.// [(wa,d)]-    Just True -> case maybeIsX waddr of-      Nothing -> V.map (const (seq waddr d)) ram-      Just wa -> ram V.// [(wa,d)]-    _ -> ram-{\-\# NOINLINE blockRam# \#\-\}-@--And for which the /declaration/ primitive is:--@-{ \"BlackBox\" :-  { "name" : "Clash.Explicit.BlockRam.blockRam#"-  , "kind" : \"Declaration\"-  , "type" :-"blockRam#-  :: ( HasCallStack  --       ARG[0]-     , NFDataX a ) --       ARG[1]-  => Clock dom       -- clk,  ARG[2]-  -> Enable dom      -- en,   ARG[3]-  -> Vec n a         -- init, ARG[4]-  -> Signal dom Int  -- rd,   ARG[5]-  -> Signal dom Bool -- wren, ARG[6]-  -> Signal dom Int  -- wr,   ARG[7]-  -> Signal dom a    -- din,  ARG[8]-  -> Signal dom a"-    , "template" :-"-- blockRam begin-~GENSYM[~RESULT_blockRam][0] : block-  signal ~GENSYM[~RESULT_RAM][1] : ~TYP[4] := ~CONST[4];-  signal ~GENSYM[rd][3]  : integer range 0 to ~LENGTH[~TYP[4]] - 1;-  signal ~GENSYM[wr][4]  : integer range 0 to ~LENGTH[~TYP[4]] - 1;-begin-  ~SYM[3] <= to_integer(~ARG[5])-  -- pragma translate_off-                mod ~LENGTH[~TYP[4]]-  -- pragma translate_on-                ;--  ~SYM[4] <= to_integer(~ARG[7])-  -- pragma translate_off-                mod ~LENGTH[~TYP[4]]-  -- pragma translate_on-                ;-~IF ~VIVADO ~THEN-  ~SYM[5] : process(~ARG[2])-  begin-    if rising_edge(~ARG[2]) then-      if ~ARG[6] ~IF ~ISACTIVEENABLE[3] ~THEN and ~ARG[3] ~ELSE ~FI then-        ~SYM[1](~SYM[4]) <= ~TOBV[~ARG[8]][~TYP[8]];-      end if;-      ~RESULT <= fromSLV(~SYM[1](~SYM[3]))-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;-    end if;-  end process; ~ELSE-  ~SYM[5] : process(~ARG[2])-  begin-    if rising_edge(~ARG[2]) then-      if ~ARG[6] ~IF ~ISACTIVEENABLE[3] ~THEN and ~ARG[3] ~ELSE ~FI then-        ~SYM[1](~SYM[4]) <= ~ARG[8];-      end if;-      ~RESULT <= ~SYM[1](~SYM[3])-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;-    end if;-  end process; ~FI-end block;---end blockRam"-  }-}-@--Again, the @name@ of the primitive is the fully qualified name of the function-you are creating the primitive for. Because we are creating a /declaration/-primitive the /kind/ must be set to @Declaration@. Instead of discussing what the-individual template holes mean in the above context, we will instead just give-a general listing of the available template holes:--* @~RESULT@: Signal to which the result of a primitive must be assigned-  to. NB: Only used in a /declaration/ primitive.-* @~ARG[N]@: @(N+1)@'th argument to the function.-* @~LIT[N]@: @(N+1)@'th argument to the function. An extra condition that must-  hold is that this @(N+1)@'th argument is an (integer) literal.-* @~CONST[N]@: @(N+1)@'th argument to the function. Clash will try to reduce-* this to a literal, even if it would otherwise consider it too expensive. As-* opposed to ~LIT, ~CONST will render a valid HDL expression.-* @~TYP[N]@: VHDL type of the @(N+1)@'th argument.-* @~TYPO@: VHDL type of the result.-* @~TYPM[N]@: VHDL type/name/ of the @(N+1)@'th argument; used in /type/-  /qualification/.-* @~TYPM@: VHDL type/name/ of the result; used in /type qualification/.-* @~ERROR[N]@: Error value for the VHDL type of the @(N+1)@'th argument.-* @~ERRORO@: Error value for the VHDL type of the result.-* @~GENSYM[\<NAME\>][N]@: Create a unique name, trying to stay as close to-  the given @\<NAME\>@ as possible. This unique symbol can be referred to in-  other places using @~SYM[N]@.-* @~SYM[N]@: a reference to the unique symbol created by @~GENSYM[\<NAME\>][N]@.-* @~SIGD[\<HOLE\>][N]@: Create a signal declaration, using @\<HOLE\>@ as the name-  of the signal, and the type of the @(N+1)@'th argument.-* @~SIGDO[\<HOLE\>]@: Create a signal declaration, using @\<HOLE\>@ as the name-  of the signal, and the type of the result.-* @~TYPELEM[\<HOLE\>]@: The element type of the vector type represented by @\<HOLE\>@.-  The content of @\<HOLE\>@ must either be: @TYP[N]@, @TYPO@, or @TYPELEM[\<HOLE\>]@.-* @~COMPNAME@: The name of the component in which the primitive is instantiated.-* @~LENGTH[\<HOLE\>]@: The vector length of the type represented by @\<HOLE\>@.-* @~DEPTH[\<HOLE\>]@: The tree depth of the type represented by @\<HOLE\>@.-  The content of @\<HOLE\>@ must either be: @TYP[N]@, @TYPO@, or @TYPELEM[\<HOLE\>]@.-* @~SIZE[\<HOLE\>]@: The number of bits needed to encode the type represented by @\<HOLE\>@.-  The content of @\<HOLE\>@ must either be: @TYP[N]@, @TYPO@, or @TYPELEM[\<HOLE\>]@.-* @~IF \<CONDITION\> ~THEN \<THEN\> ~ELSE \<ELSE\> ~FI@: renders the \<ELSE\>-  part when \<CONDITION\> evaluates to /0/, and renders the \<THEN\> in all-  other cases. Valid @\<CONDITION\>@s are @~LENGTH[\<HOLE\>]@, @~SIZE[\<HOLE\>]@,-  @~DEPTH[\<HOLE\>]@, @~VIVADO@, @~IW64@, @~ISLIT[N]@, @~ISVAR[N], @~ISACTIVEENABLE[N]@,-  @~ISSYNC[N]@, and @~AND[\<HOLE1\>,\<HOLE2\>,..]@.-* @~VIVADO@: /1/ when Clash compiler is invoked with the @-fclash-xilinx@ or-  @-fclash-vivado@ flag. To be used with in an @~IF .. ~THEN .. ~ElSE .. ~FI@-  statement.-* @~TOBV[\<HOLE\>][\<TYPE\>]@: create conversion code that so that the-  expression in @\<HOLE\>@ is converted to a bit vector (@std_logic_vector@).-  The @\<TYPE\>@ hole indicates the type of the expression and must be either-  @~TYP[N]@, @~TYPO@, or @~TYPELEM[\<HOLE\>]@.-* @~FROMBV[\<HOLE\>][\<TYPE\>]@: create conversion code that so that the-  expression in @\<HOLE\>@, which has a bit vector (@std_logic_vector@) type, is-  converted to type indicated by @\<TYPE\>@. The @\<TYPE\>@ hole indicates the-  must be either @~TYP[N]@, @~TYPO@, or @~TYPELEM[\<HOLE\>]@.-* @~INCLUDENAME[N]@: the generated name of the @N@'th included component.-* @~FILEPATH[\<HOLE\>]@: The argument mentioned in @\<HOLE\>@ is a file which-  must be copied to the location of the generated HDL.-* @~GENERATE@: Verilog: create a /generate/ statement, except when already in-  as /generate/ context.-* @~ENDGENERATE@: Verilog: create an /endgenerate/ statement, except when already-  in a /generate/ context.-* @~ISLIT[N]@: Is the @(N+1)@'th argument to the function a literal.-* @~ISVAR[N]@: Is the @(N+1)@'th argument to the function explicitly not a-  literal-* @~TAG[N]@: Name of given domain. Errors when called on an argument which is not-  a 'KnownDomain', 'Reset', or 'Clock'.-* @~PERIOD[N]@: Clock period of given domain. Errors when called on an argument-  which is not a 'KnownDomain' or 'KnownConf'.-* @~ISACTIVEENABLE[N]@: Is the @(N+1)@'th argument a an Enable line NOT set to a-  constant True. Can be used instead of deprecated (and removed) template tag-  ~ISGATED. Errors when called on an argument which is not a signal of bools.-* @~ISSYNC[N]@: Does synthesis domain at the @(N+1)@'th argument have synchronous resets. Errors-  when called on an argument which is not a 'KnownDomain' or 'KnownConf'.-* @~ISINITDEFINED[N]@: Does synthesis domain at the @(N+1)@'th argument have defined initial-  values. Errors when called on an argument which is not a 'KnownDomain' or 'KnownConf'.-* @~ACTIVEEDGE[edge][N]@: Does synthesis domain at the @(N+1)@'th argument respond to-  /edge/. /edge/ must be one of 'Falling' or 'Rising'. Errors when called on an-  argument which is not a 'KnownDomain' or 'KnownConf'.-* @~AND[\<HOLE1\>,\<HOLE2\>,..]@: Logically /and/ the conditions in the @\<HOLE\>@'s-* @~VARS[N]@: VHDL: Return the variables at the @(N+1)@'th argument argument.-* @~NAME[N]@: Render the @(N+1)@'th string literal argument as an identifier-  instead of a string literal. Fails when the @(N+1)@'th argument is not a-  string literal.-* @~DEVNULL[\<HOLE\>]@: Render all dependencies of @\<HOLE\>@, but disregard direct output-* @~REPEAT[\<HOLE\>][N]@: Repeat literal value of @\<HOLE\>@ a total of @N@ times.-* @~TEMPLATE[\<HOLE1\>][\<HOLE2\>]@: Render a file @\<HOLE1\>@ with contents @\<HOLE2\>@.---Some final remarks to end this section: VHDL primitives are there to instruct the-Clash compiler to use the given VHDL template, instead of trying to do normal-synthesis. As a consequence you can use constructs inside the Haskell-definitions that are normally not synthesizable by the Clash compiler. However,-VHDL primitives do not give us /co-simulation/: where you would be able to-simulate VHDL and Haskell in a /single/ environment. If you still want to-simulate your design in Haskell, you will have to describe, in a cycle- and-bit-accurate way, the behavior of that (potentially complex) IP you are trying-to include in your design.--Perhaps in the future, someone will figure out how to connect the two simulation-worlds, using e.g. VHDL's foreign function interface VHPI.--}--{- $vprimitives-For those who are interested, the equivalent Verilog primitives are:--@-{ \"BlackBox\" :-  { "name"     : "Clash.Sized.Internal.Signed.*#"-  , "kind"     : \"Expression\"-  , "template" : "~ARG[1] * ~ARG[2]"-  }-}-@--and--@-{ \"BlackBox\" :-  { "name" : "Clash.Explicit.BlockRam.blockRam#"-  , "kind" : \"Declaration\"-  , "type" :-"blockRam#-  :: ( HasCallStack  --       ARG[0]-     , NFDataX a ) --       ARG[1]-  => Clock dom       -- clk,  ARG[2]-  => Enable dom      -- en,   ARG[3]-  -> Vec n a         -- init, ARG[4]-  -> Signal dom Int  -- rd,   ARG[5]-  -> Signal dom Bool -- wren, ARG[6]-  -> Signal dom Int  -- wr,   ARG[7]-  -> Signal dom a    -- din,  ARG[8]-  -> Signal dom a"-    , "outputReg" : true-    , "template" :-"// blockRam begin-reg ~TYPO ~GENSYM[~RESULT_RAM][0] [0:~LENGTH[~TYP[4]]-1];--reg ~TYP[4] ~GENSYM[ram_init][2];-integer ~GENSYM[i][3];-initial begin-  ~SYM[2] = ~CONST[4];-  for (~SYM[3]=0; ~SYM[3] < ~LENGTH[~TYP[4]]; ~SYM[3] = ~SYM[3] + 1) begin-    ~SYM[0][~LENGTH[~TYP[4]]-1-~SYM[3]] = ~SYM[2][~SYM[3]*~SIZE[~TYPO]+:~SIZE[~TYPO]];-  end-end-~IF ~ISACTIVEENABLE[3] ~THEN-always @(posedge ~ARG[2]) begin : ~GENSYM[~RESULT_blockRam][4]~IF ~VIVADO ~THEN-  if (~ARG[3]) begin-    if (~ARG[6]) begin-      ~SYM[0][~ARG[7]] <= ~ARG[8];-    end-    ~RESULT <= ~SYM[0][~ARG[5]];-  end~ELSE-  if (~ARG[6] & ~ARG[3]) begin-    ~SYM[0][~ARG[7]] <= ~ARG[8];-  end-  if (~ARG[3]) begin-    ~RESULT <= ~SYM[0][~ARG[5]];-  end~FI-end~ELSE-always @(posedge ~ARG[2]) begin : ~SYM[4]-  if (~ARG[6]) begin-    ~SYM[0][~ARG[7]] <= ~ARG[8];-  end-  ~RESULT <= ~SYM[0][~ARG[5]];-end~FI-// blockRam end"-  }-}-@---}--{- $svprimitives-And the equivalent SystemVerilog primitives are:--@-{ \"BlackBox\" :-  { "name"     : "Clash.Sized.Internal.Signed.*#"-  , "kind"     : \"Expression\"-  , "template" : "~ARG[1] * ~ARG[2]"-  }-}-@--and--@-{ \"BlackBox\" :-  { "name" : "Clash.Explicit.BlockRam.blockRam#"-  , "kind" : \"Declaration\"-  , "type" :-"blockRam#-  :: ( HasCallStack  --       ARG[0]-     , NFDataX a ) --       ARG[1]-  => Clock dom       -- clk,  ARG[2]-  -> Enable dom      -- en,   ARG[3]-  -> Vec n a         -- init, ARG[4]-  -> Signal dom Int  -- rd,   ARG[5]-  -> Signal dom Bool -- wren, ARG[6]-  -> Signal dom Int  -- wr,   ARG[7]-  -> Signal dom a    -- din,  ARG[8]-  -> Signal dom a"-    , "template" :-"// blockRam begin-~SIGD[~GENSYM[RAM][0]][4];-logic [~SIZE[~TYP[8]]-1:0] ~GENSYM[~RESULT_q][1];-initial begin-  ~SYM[0] = ~CONST[4];-end~IF ~ISACTIVEENABLE[3] ~THEN-always @(posedge ~ARG[2]) begin : ~GENSYM[~COMPNAME_blockRam][2]~IF ~VIVADO ~THEN-  if (~ARG[3]) begin-    if (~ARG[6]) begin-      ~SYM[0][~ARG[7]] <= ~TOBV[~ARG[8]][~TYP[8]];-    end-    ~SYM[1] <= ~SYM[0][~ARG[5]];-  end~ELSE-  if (~ARG[6] & ~ARG[3]) begin-    ~SYM[0][~ARG[7]] <= ~TOBV[~ARG[8]][~TYP[8]];-  end-  if (~ARG[3]) begin-    ~SYM[1] <= ~SYM[0][~ARG[5]];-  end~FI-end~ELSE-always @(posedge ~ARG[2]) begin : ~SYM[2]-  if (~ARG[6]) begin-    ~SYM[0][~ARG[7]] <= ~TOBV[~ARG[8]][~TYP[8]];-  end-  ~SYM[1] <= ~SYM[0][~ARG[5]];-end~FI-assign ~RESULT = ~FROMBV[~SYM[1]][~TYP[8]];-// blockRam end"-  }-}-@---}--{- $multiclock #multiclock#-Clash supports designs multiple /clock/ (and /reset/) domains, though perhaps in-a slightly limited form. What is possible is:--* Create clock primitives, such as PPLs, which have an accompanying HDL primitive-  (described <#primitives later on> in this tutorial).-* Explicitly assign clocks to memory primitives.-* Synchronize between differently-clocked parts of your design in a type-safe-  way.--What is /not/ possible is:--* Directly generate a clock signal in module A, and assign this clock signal to-  a memory primitive in module B. For example, the following is not possible:--  @-  pow2Clocks-    :: ( 'KnownConfiguration' domIn (''DomainConfiguration' domIn pIn eIn rIn iIn polIn)-       , 'KnownConfiguration' dom2  (''DomainConfiguration' dom2 (2*pIn) e2 r2 i2 p2)-       , 'KnownConfiguration' dom4  (''DomainConfiguration' dom4 (4*pIn) e4 r4 i4 p4)-       , 'KnownConfiguration' dom8  (''DomainConfiguration' dom8 (8*pIn) e8 r8 i8 p8)-       , 'KnownConfiguration' dom16 (''DomainConfiguration' dom16 (16*pIn) e16 r16 i16 p16)-    => 'Clock' domIn-    -> 'Reset' domIn-    -> ( 'Clock' dom16-       , 'Clock' dom8-       , 'Clock' dom4-       , 'Clock' dom2 )-  pow2Clocks clk rst = (cnt!3, cnt!2, cnt!1, cnt!0)-    where-      cnt = 'Clash.Explicit.Signal.register' clk rst 0 (cnt + 1)-  @--  As it is not possible to convert the individual bits to a 'Clock'.--  However! What is possible is to do the following:--  @-  pow2Clocks'-    :: ( 'KnownConfiguration' domIn (''DomainConfiguration' domIn pIn eIn rIn iIn polIn)-       , 'KnownConfiguration' dom2  (''DomainConfiguration' dom2 (2*pIn) e2 r2 i2 p2)-       , 'KnownConfiguration' dom4  (''DomainConfiguration' dom4 (4*pIn) e4 r4 i4 p4)-       , 'KnownConfiguration' dom8  (''DomainConfiguration' dom8 (8*pIn) e8 r8 i8 p8)-       , 'KnownConfiguration' dom16 (''DomainConfiguration' dom16 (16*pIn) e16 r16 i16 p16)-    => 'Clock' domIn-    -> 'Reset' domIn-    -> ( 'Clock' dom16-       , 'Clock' dom8-       , 'Clock' dom4-       , 'Clock' dom2 )-  pow2Clocks' clk rst = ('clockGen', 'clockGen', 'clockGen', 'clockGen')-  {\-\# NOINLINE pow2Clocks' \#-\}-  @--  And then create a HDL primitive, as described in later on in-  this <#primitives tutorial>, to implement the desired behavior in HDL.--What this means is that when Clash converts your design to VHDL/(System)Verilog,-you end up with a top-level module/entity with multiple clock and reset ports-for the different clock domains. If you're targeting an FPGA, you can use e.g. a-<https://www.altera.com/literature/ug/ug_altpll.pdf PPL> or-<http://www.xilinx.com/support/documentation/user_guides/ug472_7Series_Clocking.pdf MMCM>-to provide the clock signals.--== Building a FIFO synchronizer--This part of the tutorial assumes you know what <https://en.wikipedia.org/wiki/Metastability_in_electronics metastability>-is, and how it can never truly be avoided in any asynchronous circuit. Also-it assumes that you are familiar with the design of synchronizer circuits, and-why a dual flip-flop synchronizer only works for bit-synchronization and not-word-synchronization.-The explicitly clocked versions of all synchronous functions and primitives can-be found in "Clash.Explicit.Prelude", which also re-exports the functions in-"Clash.Signal.Explicit". We will use those functions to create a FIFO where-the read and write port are synchronized to different clocks. Below you can find-the code to build the FIFO synchronizer based on the design described in:-<http://www.sunburst-design.com/papers/CummingsSNUG2002SJ_FIFO1.pdf>--We start with enable a few options that will make writing the type-signatures for-our components a bit easier. Instead of importing the standard "Clash.Prelude"-module, we will import the "Clash.Explicit.Prelude" module where all our clocks-and resets must be explicitly routed (other imports will be used later):--@-module MultiClockFifo where--import "Clash.Explicit.Prelude"-import "Clash.Prelude"          (mux)-import Data.Maybe             (isJust)-import Data.Constraint        (Dict (..), (:-)( Sub ))-import Data.Constraint.Nat    (leTrans)-@--Then we'll start with the /heart/ of the FIFO synchronizer, an asynchronous RAM-in the form of 'asyncRam'. It's called an asynchronous RAM because the read-port is not synchronized to any clock (though the write port is). Note that in-Clash we don't really have asynchronous logic, there is only combinational and-synchronous logic. As a consequence, we see in the type signature of-'Clash.Explicit.Prelude.asyncRam':--@-__asyncRam__-  :: ( 'Enum' addr-     , 'HasCallStack'-     , 'KnownDomain' wdom wconf-     , 'KnownDomain' rdom rconf-     )-  => 'Clock' wdom                     -- ^ Clock to which to synchronize the write port of the RAM-  -> 'Clock' rdom                     -- ^ 'Clock' to which the read address signal, @r@, is synchronized to-  -> 'Enable' wdom                    -- ^ Global enable-  -> 'SNat' n                         -- ^ Size @n@ of the RAM-  -> 'Signal' rdom addr               -- ^ Read address @r@-  -> 'Signal' wdom (Maybe (addr, a))  -- ^ (write address @w@, value to write)-  -> 'Signal' rdom a                  -- ^ Value of the @RAM@ at address @r@-@--that the signal containing the read address __r__ is synchronized to a different-clock. That is, there is __no__ such thing as an @AsyncSignal@ in Clash.--We continue by instantiating the 'Clash.Explicit.Prelude.asyncRam':--@-fifoMem wclk rclk en addrSize\@SNat full raddr writeM =-  'Clash.Explicit.Prelude.asyncRam'-    wclk rclk en-    ('pow2SNat' addrSize)-    raddr-    ('mux' full (pure Nothing) writeM)-@--We see that we give it @2^addrSize@ elements, where @addrSize@ is the bit-size-of the address. Also, we only write new values to the RAM when a new write is-requested, indicated by @wdataM@ having a 'Data.Maybe.Just' value, and the-buffer is not full, indicated by @wfull@.--The next part of the design calculates the read and write address for the-asynchronous RAM, and creates the flags indicating whether the FIFO is full-or empty. The address and flag generator is given in 'mealy' machine style:--@-ptrCompareT-  :: SNat addrSize-  -> (BitVector (addrSize + 1) -> BitVector (addrSize + 1) -> Bool)-  -> ( BitVector (addrSize + 1)-     , BitVector (addrSize + 1)-     , Bool )-  -> ( BitVector (addrSize + 1)-     , Bool )-  -> ( ( BitVector (addrSize + 1)-       , BitVector (addrSize + 1)-       , Bool )-     , ( Bool-       , BitVector addrSize-       , BitVector (addrSize + 1)-       )-     )-ptrCompareT addrSize\@SNat flagGen (bin, ptr, flag) (s_ptr, inc) =-  ( (bin', ptr', flag')-  , (flag, addr, ptr) )- where-  -- GRAYSTYLE2 pointer-  bin' = bin + 'boolToBV' (inc && not flag)-  ptr' = (bin' \`shiftR\` 1) \`xor\` bin'-  addr = 'truncateB' bin-  flag' = flagGen ptr' s_ptr-@--It is parametrized in both address size, @addrSize@, and status flag generator,-@flagGen@. It has two inputs, @s_ptr@, the synchronized pointer from the other-clock domain, and @inc@, which indicates we want to perform a write or read of-the FIFO. It creates three outputs: @flag@, the full or empty flag, @addr@, the-read or write address into the RAM, and @ptr@, the Gray-encoded version of the-read or write address which will be synchronized between the two clock domains.--Next follow the initial states of address generators, and the flag generators-for the empty and full flags:--@--- FIFO empty: when next pntr == synchronized wptr or on reset-isEmpty       = (==)-rptrEmptyInit = (0, 0, True)---- FIFO full: when next pntr == synchronized {~wptr[addrSize:addrSize-1],wptr[addrSize-2:0]}-isFull-  :: forall addrSize-   . (2 <= addrSize)-  => 'SNat' addrSize-  -> 'BitVector' (addrSize + 1)-  -> 'BitVector' (addrSize + 1)-  -> Bool-isFull addrSize\@SNat ptr s_ptr = case leTrans \@1 \@2 \@addrSize of-  Sub Dict ->-    let a1 = 'SNat' \@(addrSize - 1)-        a2 = 'SNat' \@(addrSize - 2)-    in  ptr == ('complement' ('slice' addrSize a1 s_ptr) '++#' 'slice' a2 d0 s_ptr)--wptrFullInit = (0, 0, False)-@--We create a dual flip-flop synchronizer to be used to synchronize the-Gray-encoded pointers between the two clock domains:--@-ptrSync clk1 clk2 rst2 =-  'Clash.Explicit.Signal.register' clk2 rst2 0 . 'Clash.Explicit.Signal.register' clk2 rst2 0 . 'Clash.Explicit.Signal.unsafeSynchronizer' clk1 clk2-@--It uses the 'unsafeSynchronizer' primitive, which is needed to go from one clock-domain to the other. All synchronizers are specified in terms of-'unsafeSynchronizer' (see for example the <src/Clash-Prelude-RAM.html#line-103 source of asyncRam>).-The 'unsafeSynchronizer' primitive is turned into a (bundle of) wire(s) by the-Clash compiler, so developers must ensure that it is only used as part of a-proper synchronizer.--Finally we combine all the component in:--@-asyncFIFOSynchronizer-  :: ( 'KnownDomain' wdom wconf-     , 'KnownDomain' rdom rconf-     , 2 <= addrSize )-  => SNat addrSize-  -- ^ Size of the internally used addresses, the  FIFO contains @2^addrSize@-  -- elements.-  -> 'Clock' wdom-  -- ^ 'Clock' to which the write port is synchronized-  -> 'Clock' rdom-  -- ^ 'Clock' to which the read port is synchronized-  -> 'Reset' wdom-  -> 'Reset' rdom-  -> 'Enable' wdom-  -> 'Enable' rdom-  -> 'Signal' rdom Bool-  -- ^ Read request-  -> 'Signal' wdom (Maybe a)-  -- ^ Element to insert-  -> ('Signal' rdom a, 'Signal' rdom Bool, 'Signal' wdom Bool)-  -- ^ (Oldest element in the FIFO, @empty@ flag, @full@ flag)-asyncFIFOSynchronizer addrSize\@SNat wclk rclk wrst rrst wen ren rinc wdataM =-  (rdata, rempty, wfull)- where-  s_rptr = 'dualFlipFlopSynchronizer' rclk wclk wrst wen 0 rptr-  s_wptr = 'dualFlipFlopSynchronizer' wclk rclk rrst ren 0 wptr--  rdata =-    fifoMem-      wclk rclk wen-      addrSize wfull raddr-      (liftA2 (,) \<$\> (pure \<$\> waddr) \<*\> wdataM)--  (rempty, raddr, rptr) =-    'mealyB'-      rclk rrst ren-      (ptrCompareT addrSize (==))-      (0, 0, True)-      (s_wptr, rinc)--  (wfull, waddr, wptr) =-    'mealyB'-      wclk wrst wen-      (ptrCompareT addrSize (isFull addrSize))-      (0, 0, False)-      (s_rptr, isJust \<$\> wdataM)-@--where we first specify the synchronization of the read and the write pointers,-instantiate the asynchronous RAM, and instantiate the read address \/ pointer \/-flag generator and write address \/ pointer \/ flag generator.--Ultimately, the whole file containing our FIFO design will look like this:--@-module MultiClockFifo where--import "Clash.Explicit.Prelude"-import "Clash.Prelude"          (mux)-import Data.Maybe             (isJust)-import Data.Constraint        (Dict (..), (:-)( Sub ))-import Data.Constraint.Nat    (leTrans)--fifoMem wclk rclk en addrSize\@SNat full raddr writeM =-  'Clash.Explicit.Prelude.asyncRam'-    wclk rclk en-    ('pow2SNat' addrSize)-    raddr-    ('mux' full (pure Nothing) writeM)--ptrCompareT-  :: SNat addrSize-  -> (BitVector (addrSize + 1) -> BitVector (addrSize + 1) -> Bool)-  -> ( BitVector (addrSize + 1)-     , BitVector (addrSize + 1)-     , Bool )-  -> ( BitVector (addrSize + 1)-     , Bool )-  -> ( ( BitVector (addrSize + 1)-       , BitVector (addrSize + 1)-       , Bool )-     , ( Bool-       , BitVector addrSize-       , BitVector (addrSize + 1)-       )-     )-ptrCompareT addrSize\@SNat flagGen (bin, ptr, flag) (s_ptr, inc) =-  ( (bin', ptr', flag')-  , (flag, addr, ptr) )- where-  -- GRAYSTYLE2 pointer-  bin' = bin + 'boolToBV' (inc && not flag)-  ptr' = (bin' \`shiftR\` 1) \`xor\` bin'-  addr = 'truncateB' bin--  flag' = flagGen ptr' s_ptr---- FIFO empty: when next pntr == synchronized wptr or on reset-isEmpty       = (==)-rptrEmptyInit = (0, 0, True)---- FIFO full: when next pntr == synchronized {~wptr[addrSize:addrSize-1],wptr[addrSize-2:0]}-isFull-  :: forall addrSize-   . (2 <= addrSize)-  => 'SNat' addrSize-  -> 'BitVector' (addrSize + 1)-  -> 'BitVector' (addrSize + 1)-  -> Bool-isFull addrSize\@SNat ptr s_ptr = case leTrans \@1 \@2 \@addrSize of-  Sub Dict ->-    let a1 = 'SNat' \@(addrSize - 1)-        a2 = 'SNat' \@(addrSize - 2)-    in  ptr == ('complement' ('slice' addrSize a1 s_ptr) '++#' 'slice' a2 d0 s_ptr)--wptrFullInit = (0, 0, False)---- Dual flip-flop synchronizer-ptrSync clk1 clk2 rst2 =-  'Clash.Explicit.Signal.register' clk2 rst2 0 . 'Clash.Explicit.Signal.register' clk2 rst2 0 . 'Clash.Explicit.Signal.unsafeSynchronizer' clk1 clk2---- Async FIFO synchronizer-asyncFIFOSynchronizer-  :: ( 'KnownDomain' wdom wconf-     , 'KnownDomain' rdom rconf-     , 2 <= addrSize )-  => SNat addrSize-  -- ^ Size of the internally used addresses, the  FIFO contains @2^addrSize@-  -- elements.-  -> 'Clock' wdom-  -- ^ Clock to which the write port is synchronized-  -> 'Clock' rdom-  -- ^ Clock to which the read port is synchronized-  -> 'Reset' wdom-  -> 'Reset' rdom-  -> 'Enable' wdom-  -> 'Enable' rdom-  -> 'Signal' rdom Bool-  -- ^ Read request-  -> 'Signal' wdom (Maybe a)-  -- ^ Element to insert-  -> ('Signal' rdom a, 'Signal' rdom Bool, 'Signal' wdom Bool)-  -- ^ (Oldest element in the FIFO, @empty@ flag, @full@ flag)-asyncFIFOSynchronizer addrSize\@SNat wclk rclk wrst rrst wen ren rinc wdataM =-  (rdata, rempty, wfull)- where-  s_rptr = 'dualFlipFlopSynchronizer' rclk wclk wrst wen 0 rptr-  s_wptr = 'dualFlipFlopSynchronizer' wclk rclk rrst ren 0 wptr--  rdata =-    fifoMem-      wclk rclk wen-      addrSize wfull raddr-      (liftA2 (,) \<$\> (pure \<$\> waddr) \<*\> wdataM)--  (rempty, raddr, rptr) =-    'mealyB'-      rclk rrst ren-      (ptrCompareT addrSize (==))-      (0, 0, True)-      (s_wptr, rinc)--  (wfull, waddr, wptr) =-    'mealyB'-      wclk wrst wen-      (ptrCompareT addrSize (isFull addrSize))-      (0, 0, False)-      (s_rptr, isJust \<$\> wdataM)-@--== Instantiating a FIFO synchronizer--Having finished our FIFO synchronizer it's time to instantiate with concrete-clock domains. Let us assume we have part of our system connected to an ADC-which runs at 20 MHz, and we have created an FFT component running at only 9-MHz. We want to connect part of our design connected to the ADC, and running-at 20 MHz, to part of our design connected to the FFT running at 9 MHz.--We can calculate the clock periods using 'hzToPeriod':-->>> hzToPeriod 20e6-50000->>> hzToPeriod 9e6-111112--We can then create the clock and reset domains:--@-'createDomain' vSystem{vName=\"ADC\", vPeriod=hzToPeriod 20e6}-'createDomain' vSystem{vName=\"FFT\", vPeriod=hzToPeriod 9e6}-@--and subsequently a 256-space FIFO synchronizer that safely bridges the ADC clock-domain and to the FFT clock domain:--@-adcToFFT-  :: 'Clock' \"ADC\"-  -> 'Clock' \"FFT\"-  -> 'Reset' \"ADC\"-  -> 'Reset' \"FFT\"-  -> 'Signal' \"FFT\" Bool-  -> 'Signal' \"ADC\" (Maybe (SFixed 8 8))-  -> ( 'Signal' \"FFT\" (SFixed 8 8)-     , 'Signal' \"FFT\" Bool-     , 'Signal' \"ADC\" Bool )-adcToFFT = asyncFIFOSynchronizer d8-@---}--{- $conclusion-For now, this is the end of this tutorial. We will be adding updates over time,-so check back from time to time. We recommend that you continue with-exploring the "Clash.Prelude" module, and get a better understanding of the-capabilities of Clash in the process.--}--{- $errorsandsolutions-A list of often encountered errors and their solutions:--* __Type error: Couldn't match expected type @'Signal' dom (a,b)@ with actual type__-  __@('Signal' dom a, 'Signal' dom b)@__:--    Signals of product types and product types (to which tuples belong) of-    signals are __isomorphic__ due to synchronisity principle, but are not-    (structurally) equal. Use the 'bundle' function to convert from a product type-    to the signal type. So if your code which gives the error looks like:--    @-    ... = f a b (c,d)-    @--    add the 'bundle' function like so:--    @-    ... = f a b ('bundle' (c,d))-    @--    Product types supported by 'bundle' are:--    * All tuples up to and including 62-tuples (GHC limit)-    * The 'Vec'tor type--* __Type error: Couldn't match expected type @('Signal' dom a, 'Signal' dom b)@ with__-  __ actual type @'Signal' dom (a,b)@__:--    Product types (to which tuples belong) of signals and signals of product-    types are __isomorphic__ due to synchronicity principle, but are not-    (structurally) equal. Use the 'unbundle' function to convert from a signal-    type to the product type. So if your code which gives the error looks like:--    @-    (c,d) = f a b-    @--    add the 'unbundle' function like so:--    @-    (c,d) = 'unbundle' (f a b)-    @--    Product types supported by 'unbundle' are:--    * All tuples up to and including 62-tuples (GHC limit)-    * The 'Vec'tor type--* __Clash.Netlist(..): Not in normal form: \<REASON\>: \<EXPR\>__:--    A function could not be transformed into the expected normal form. This-    usually means one of the following:--    * The @topEntity@ has residual polymorphism.-    * The @topEntity@ has higher-order arguments, or a higher-order result.-    * You are using types which cannot be represented in hardware.--    The solution for all the above listed reasons is quite simple: remove them.-    That is, make sure that the @topEntity@ is completely monomorphic and-    first-order. Also remove any variables and constants/literals that have a-    non-representable type, see <#unsupported Unsupported Haskell features> to-    find out which types are not representable.--* __Clash.Normalize(94): Expr belonging to bndr: \<FUNCTION\> remains__-  __recursive after normalization__:--    * If you actually wrote a recursive function, rewrite it to a non-recursive-      one using e.g. one of the higher-order functions in "Clash.Sized.Vector" :-)--    * You defined a recursively defined value, but left it polymorphic:--    @-    topEntity x y = acc-      where-        acc = 'register' 3 (acc + x * y)-    @--    The above function, works for any number-like type. This means that @acc@ is-    a recursively defined __polymorphic__ value. Adding a monomorphic type-    annotation makes the error go away:--    @-    topEntity-      :: 'SystemClockReset'-      => 'Signal' 'System' ('Signed' 8)-      -> 'Signal' 'System' ('Signed' 8)-      -> 'Signal' 'System' ('Signed' 8)-    topEntity x y = acc-      where-        acc = 'register' 3 (acc + x * y)-    @--* __Clash.Normalize.Transformations(155): InlineNonRep: \<FUNCTION\> already__-  __inlined 100 times in:\<FUNCTION\>, \<TYPE\>__:--    You left the @topEntity@ function polymorphic or higher-order: use-    @:t topEntity@ to check if the type is indeed polymorphic or higher-order.-    If it is, add a monomorphic type signature, and / or supply higher-order-    arguments.--*  __\<*** Exception: \<\<loop\>\>__ or "blinking cursor"--    You are using value-recursion, but one of the 'Vec'tor functions that you-    are using is too /strict/ in one of the recursive arguments. For example:--    @-    -- Bubble sort for 1 iteration-    sortV xs = 'map' fst sorted ':<' (snd ('last' sorted))-     where-       lefts  = 'head' xs :> 'map' snd ('init' sorted)-       rights = 'tail' xs-       sorted = 'zipWith' compareSwapL lefts rights--    -- Compare and swap-    compareSwapL a b = if a < b then (a,b)-                                else (b,a)-    @--    Will not terminate because 'zipWith' is too strict in its second argument.--    In this case, adding 'lazyV' on 'zipWith's second argument:--    @-    sortVL xs = 'map' fst sorted ':<' (snd ('last' sorted))-     where-       lefts  = 'head' xs :> map snd ('init' sorted)-       rights = 'tail' xs-       sorted = 'zipWith' compareSwapL ('lazyV' lefts) rights-    @--    Results in a successful computation:--    >>> sortVL (4 :> 1 :> 2 :> 3 :> Nil)-    <1,2,3,4>--}--{- $limitations #limitations#-Here is a list of Haskell features for which the Clash compiler has only-/limited/ support (for now):--* __Recursively defined functions__--    At first hand, it seems rather bad that a compiler for a functional language-    cannot synthesize recursively defined functions to circuits. However, when-    viewing your functions as a /structural/ specification of a circuit, this-    /feature/ of the Clash compiler makes sense. Also, only certain types of-    recursion are considered non-synthesizable; recursively defined values are-    for example synthesizable: they are (often) synthesized to feedback loops.--    Let us distinguish between three variants of recursion:--    * __Dynamic data-dependent recursion__--        As demonstrated in this definition of a function that calculates the-        n'th Fibbonacci number:--        @-        fibR 0 = 0-        fibR 1 = 1-        fibR n = fibR (n-1) + fibR (n-2)-        @--        To get the first 10 numbers, we do the following:--        >>> import qualified Data.List as L-        >>> L.map fibR [0..9]-        [0,1,1,2,3,5,8,13,21,34]--        The @fibR@ function is not synthesizable by the Clash compiler, because,-        when we take a /structural/ view, @fibR@ describes an infinitely deep-        structure.--        In principal, descriptions like the above could be synthesized to a-        circuit, but it would have to be a /sequential/ circuit. Where the most-        general synthesis would then require a stack. Such a synthesis approach-        is also known as /behavioral/ synthesis, something which the Clash-        compiler simply does not do. One reason that Clash does not do this is-        because it does not fit the paradigm that only functions working on-        values of type 'Signal' result in sequential circuits, and all other-        (non higher-order) functions result in combinational circuits. This-        paradigm gives the designer the most straightforward mapping from the-        original Haskell description to generated circuit, and thus the greatest-        control over the eventual size of the circuit and longest propagation-        delay.--    * __Value-recursion__--        As demonstrated in this definition of a function that calculates the-        n'th Fibbonaci number on the n'th clock cycle:--        @-        fibS = r-          where r = 'register' 0 r + 'register' 0 ('register' 1 r)-        @--        To get the first 10 numbers, we do the following:--        >>> sampleN @System 11 fibS-        [0,0,1,1,2,3,5,8,13,21,34]--        Unlike the @fibR@ function, the above @fibS@ function /is/ synthesizable-        by the Clash compiler. Where the recursively defined (non-function)-        value /r/ is synthesized to a feedback loop containing three registers-        and one adder.--        Note that not all recursively defined values result in a feedback loop.-        An example that uses recursively defined values which does not result-        in a feedback loop is the following function that performs one iteration-        of bubble sort:--        @-        sortV xs = 'map' fst sorted :< (snd ('last' sorted))-         where-           lefts  = 'head' xs :> 'map' snd ('init' sorted)-           rights = 'tail' xs-           sorted = 'zipWith' compareSwapL lefts rights-        @--        Where we can clearly see that 'lefts' and 'sorted' are defined in terms-        of each other. Also the above @sortV@ function /is/ synthesizable.--    * __Static/Structure-dependent recursion__--        Static, or, structure-dependent recursion is a rather /vague/ concept.-        What we mean by this concept are recursive definitions where a user can-        sensibly imagine that the recursive definition can be completely-        unfolded (all recursion is eliminated) at compile-time in a finite-        amount of time.--        Such definitions would e.g. be:--        @-        mapV :: (a -> b) -> Vec n a -> Vec n b-        mapV _ Nil         = Nil-        mapV f (Cons x xs) = Cons (f x) (mapV f xs)--        topEntity :: Vec 4 Int -> Vec 4 Int-        topEntity = mapV (+1)-        @--        Where one can imagine that a compiler can unroll the definition of-        @mapV@ four times, knowing that the @topEntity@ function applies @mapV@-        to a 'Vec' of length 4. Sadly, the compile-time evaluation mechanisms in-        the Clash compiler are very poor, and a user-defined function such as-        the @mapV@ function defined above, is /currently/ not synthesizable.-        We /do/ plan to add support for this in the future. In the mean time,-        this poor support for user-defined recursive functions is amortized by-        the fact that the Clash compiler has built-in support for the-        higher-order functions defined in "Clash.Sized.Vector". Most regular-        design patterns often encountered in circuit design are captured by the-        higher-order functions in "Clash.Sized.Vector".--* __Recursive datatypes__--    The Clash compiler needs to be able to determine a bit-size for any value-    that will be represented in the eventual circuit. More specifically, we need-    to know the maximum number of bits needed to represent a value. While this-    is trivial for values of the elementary types, sum types, and product types,-    putting a fixed upper bound on recursive types is not (always) feasible.-    This means that the ubiquitous list type is unsupported! The only recursive-    types that are currently supported by the Clash compiler is the 'Vec'tor and-    'RTree' types, for which the compiler has hard-coded knowledge.--    For \"easy\" 'Vec'tor literals you should use Template Haskell splices and-    the 'listToVecTH' /meta/-function that as we have seen earlier in this tutorial.--* __GADTs__--    Clash has experimental support for GADTs. Similar to recursive types, Clash-    can't determine bit-sizes of GADTs. Notable exceptions to this rule are-    'Vec' and 'RTree'. You can still use your own GADTs, as long as they can be-    removed through static analysis. For example, the following case will be-    optimized away and is therefore fine to use:--    @-    x =-      case 'resetKind' @@'System' of-        SAsynchronous -> 'a'-        SSynchronous -> 'b'-    @--* __Floating point types__--    There is no support for the 'Float' and 'Double' types, if you need numbers-    with a /fractional/ part you can use the 'Fixed' point type.--    As to why there is no support for these floating point types:--        1.  In order to achieve reasonable operating frequencies, arithmetic-            circuits for floating point data types must be pipelined.-        2.  Haskell's primitive arithmetic operators on floating point data types,-            such as 'plusFloat#'--            @-            __plusFloat#__ :: 'Float#' -> 'Float#' -> 'Float#'-            @--            which underlie @'Float'@'s 'Num' instance, must be implemented as-            purely combinational circuits according to their type. Remember,-            sequential circuits operate on values of type \"@'Signal' a@\".--    Although it is possible to implement purely combinational (not pipelined)-    arithmetic circuits for floating point data types, the circuit would be-    unreasonable slow. And so, without synthesis possibilities for the basic-    arithmetic operations, there is no point in supporting the floating point-    data types.--* __Haskell primitive types__--    Only the following primitive Haskell types are supported:--        * 'Integer'-        * 'Int'-        * 'Int8'-        * 'Int16'-        * 'Int32'-        * 'Int64' (not available when compiling with @-fclash-intwidth=32@ on a 64-bit machine)-        * 'Word'-        * 'Word8'-        * 'Word16'-        * 'Word32'-        * 'Word64' (not available when compiling with @-fclash-intwidth=32@ on a 64-bit machine)-        * 'Char'--    There are several aspects of which you should take note:--        *   'Int' and 'Word' are represented by the same number of bits as is-            native for the architecture of the computer on which the Clash-            compiler is executed. This means that if you are working on a 64-bit-            machine, 'Int' and 'Word' will be 64-bit. This might be problematic-            when you are working in a team, and one designer has a 32-bit-            machine, and the other has a 64-bit machine. In general, you should-            be avoiding 'Int' in such cases, but as a band-aid solution, you can-            force the Clash compiler to use a specific bit-width for `Int` and-            `Word` using the @-fclash-intwidth=N@ flag, where /N/ must either be-            /32/ or /64/.--        *   When you use the @-fclash-intwidth=32@ flag on a /64-bit/ machine,-            the 'Word64' and 'Int64' types /cannot/ be translated. This-            restriction does /not/ apply to the other three combinations of-            @-fclash-intwidth@ flag and machine type.--        *   The translation of 'Integer' is not meaning-preserving. 'Integer' in-            Haskell is an arbitrary precision integer, something that cannot-            be represented in a statically known number of bits. In the Clash-            compiler, we chose to represent 'Integer' by the same number of bits-            as we do for 'Int' and 'Word'. As you have read in a previous-            bullet point, this number of bits is either 32 or 64, depending on-            the architecture of the machine the Clash compiler is running on, or-            the setting of the @-fclash-intwidth@ flag.--            Consequently, you should use `Integer` with due diligence; be-            especially careful when using `fromIntegral` as it does a conversion-            via 'Integer'. For example:--                > signedToUnsigned :: Signed 128 -> Unsigned 128-                > signedToUnsigned = fromIntegral--            can either lose the top 64 or 96 bits depending on whether 'Integer'-            is represented by 64 or 32 bits. Instead, when doing such conversions,-            you should use 'bitCoerce':--                > signedToUnsigned :: Signed 128 -> Unsigned 128-                > signedToUnsigned = bitCoerce--* __Side-effects: 'IO', 'ST', etc.__--    There is no support for side-effecting computations such as those in the-    'IO' or 'ST' monad. There is also no support for Haskell's-    <http://www.haskell.org/haskellwiki/Foreign_Function_Interface FFI>.--}--{- $vslava-In Haskell land the most well-known way of describing digital circuits is the-Lava family of languages:--* <http://hackage.haskell.org/package/chalmers-lava2000 Chalmers Lava>-* <http://hackage.haskell.org/package/xilinx-lava Xilinx Lava>-* <http://hackage.haskell.org/package/york-lava York Lava>-* <http://hackage.haskell.org/package/kansas-lava Kansas Lava>--The big difference between Clash and Lava is that Clash uses a \"standard\"-compiler (static analysis) approach towards synthesis, where Lava is an-embedded domain specific language. One downside of static analysis vs. the-embedded language approach is already clearly visible: synthesis of recursive-descriptions does not come for \"free\". This will be implemented in Clash in-due time, but that doesn't help the circuit designer right now. As already-mentioned earlier, the poor support for recursive functions is amortized by-the built-in support for the higher-order in "Clash.Sized.Vector".--The big upside of Clash and its static analysis approach is that Clash can-do synthesis of \"normal\" functions: there is no forced encasing datatype (often-called /Signal/ in Lava) on all the arguments and results of a synthesizable-function. This enables the following features not available to Lava:--* Automatic synthesis for user-defined ADTs-* Synthesis of all choice constructs (pattern matching, guards, etc.)-* 'Applicative' instance for the 'Signal' type-* Working with \"normal\" functions permits the use of e.g. the-  'Control.Monad.State.Lazy.State' monad to describe the functionality of a-  circuit.--Although there are Lava alternatives to some of the above features (e.g.-first-class patterns to replace pattern matching) they are not as \"beautiful\"-and / or easy to use as the standard Haskell features.--}--{- $migration--* Clash has overhauled the way synthesis options are represented. You can read-  about this change in the blogpost: <https://clash-lang.org/blog/0005-synthesis-domain/ New feature: configurable initial values>.-  The executive summary is as follows:--+------------------------------------------------------------------------------+--------------------------------------------------------------------+-| __0.99__                                                                     | __1.0__                                                            |-+------------------------------------------------------------------------------+--------------------------------------------------------------------+-| @topEntity (clk::Clock d 'Source) rst = withClockReset f clk  rst@           | @topEntity clk rst = withClockResetEnable clk rst enableGen f@     |-+------------------------------------------------------------------------------+--------------------------------------------------------------------+-| @topEntity (clk::Clock d 'Gated) rst  = withClockReset f clk  rst@           | @topEntity clk rst enable = withClockResetEnable clk rst enable f@ |-+------------------------------------------------------------------------------+--------------------------------------------------------------------+-| @data A = ... @ (and @A@ is used as state, for example in register or mealy) | @data A = ... deriving (Generic,NFDataX)@                          |-+------------------------------------------------------------------------------+--------------------------------------------------------------------+-| @SystemClockReset@                                                           | @SystemClockResetEnable@                                           |-+------------------------------------------------------------------------------+--------------------------------------------------------------------+-| @HiddenClockReset dom gated sync@                                            | @HiddenClockResetEnable dom@                                       |-+------------------------------------------------------------------------------+--------------------------------------------------------------------+-| @HiddenClock dom gated@                                                      | @HiddenClock dom@                                                  |-+------------------------------------------------------------------------------+--------------------------------------------------------------------+-| @HiddenReset dom sync@                                                       | @HiddenReset dom@                                                  |-+------------------------------------------------------------------------------+--------------------------------------------------------------------+-| @Clock dom gated@                                                            | @Clock dom@                                                        |-+------------------------------------------------------------------------------+--------------------------------------------------------------------+-| @Reset dom sync@                                                             | @Reset dom@                                                        |-+------------------------------------------------------------------------------+--------------------------------------------------------------------+--* @outputVerifier@ now operates on two domains. If you only need one, simply-  change it to @outputVerifier'@--* For an overview of all other changes, check out <https://github.com/clash-lang/clash-compiler/blob/1.0/clash-ghc/CHANGELOG.md the changelog>--=== Examples--==== FIR filter--FIR filter in Clash 1.0:--@-module FIR where--import Clash.Prelude-import Clash.Explicit.Testbench--dotp :: SaturatingNum a-     => Vec (n + 1) a-     -> Vec (n + 1) a-     -> a-dotp as bs = fold boundedPlus (zipWith boundedMult as bs)--fir-  :: (Default a, KnownNat n, SaturatingNum a, HiddenClockResetEnable dom)-  => Vec (n + 1) a -> Signal dom a -> Signal dom a-fir coeffs x_t = y_t-  where-    y_t = dotp coeffs \<$\> bundle xs-    xs  = window x_t--topEntity-  :: Clock  System Source-  -> Reset  System Asynchronous-  -> Signal System (Signed 16)-  -> Signal System (Signed 16)-topEntity = exposeClockReset (fir (2:>3:>(-2):>8:>Nil))-{-# NOINLINE topEntity #-}--testBench :: Signal System Bool-testBench = done-  where-    testInput      = stimuliGenerator clk rst (2:>3:>(-2):>8:>Nil)-    expectedOutput = outputVerifier clk rst (4:>12:>1:>20:>Nil)-    done           = expectedOutput (topEntity clk rst testInput)-    clk            = tbSystemClockGen (not \<$\> done)-    rst            = systemResetGen-@--FIR filter in current version:--@--module FIR where--import Clash.Prelude-import Clash.Explicit.Testbench--dotp :: SaturatingNum a-     => Vec (n + 1) a-     -> Vec (n + 1) a-     -> a-dotp as bs = fold boundedAdd (zipWith boundedMul as bs)--fir-  :: ( HiddenClockResetEnable dom-     , Default a-     , KnownNat n-     , SaturatingNum a-     , NFDataX a )-  => Vec (n + 1) a -> Signal tag a -> Signal tag a-fir coeffs x_t = y_t-  where-    y_t = dotp coeffs \<$\> bundle xs-    xs  = window x_t--topEntity-  :: Clock  System-  -> Reset  System-  -> Enable System-  -> Signal System (Signed 16)-  -> Signal System (Signed 16)-topEntity = exposeClockResetEnable (fir (2:>3:>(-2):>8:>Nil))-{-# NOINLINE topEntity #-}--testBench :: Signal System Bool-testBench = done-  where-    testInput      = stimuliGenerator clk rst (2:>3:>(-2):>8:>Nil)-    expectedOutput = outputVerifier' clk rst (4:>12:>1:>20:>Nil)-    done           = expectedOutput (topEntity clk rst enableGen testInput)-    clk            = tbSystemClockGen (not \<$\> done)-    rst            = systemResetGen-@--==== Blinker circuit--Blinker circuit in Clash 0.99:--@-{-# LANGUAGE NoMonoLocalBinds #-}-module Blinker where--import Clash.Prelude-import Clash.Promoted.Symbol-import Clash.Intel.ClockGen--type Dom50 = Dom \"System\" 20000--{\-\# ANN topEntity-  (Synthesize-    { t_name   = \"blinker\"-    , t_inputs = [ PortName \"CLOCK_50\"-                 , PortName \"KEY0\"-                 , PortName \"KEY1\"-                 ]-    , t_output = PortName \"LED\"-    }) \#-\}-topEntity-  :: Clock Dom50 Source-  -> Reset Dom50 Asynchronous-  -> Signal Dom50 Bit-  -> Signal Dom50 (BitVector 8)-topEntity clk rst =-    exposeClockReset (mealy blinkerT (1,False,0) . isRising 1) pllOut rstSync-  where-    (pllOut,pllStable) = altpll \@Dom50 (SSymbol \@ \"altpll50\") clk rst-    rstSync            = resetSynchronizer pllOut (unsafeToAsyncReset pllStable)--blinkerT (leds,mode,cntr) key1R = ((leds',mode',cntr'),leds)-  where-    -- clock frequency = 50e6  (50 MHz)-    -- led update rate = 333e-3 (every 333ms)-    cnt_max = 16650000 -- 50e6 * 333e-3--    cntr' | cntr == cnt_max = 0-          | otherwise       = cntr + 1--    mode' | key1R     = not mode-          | otherwise = mode--    leds' | cntr == 0 = if mode then complement leds-                                else rotateL leds 1-          | otherwise = leds-@--Blinker in Clash 1.0:--@-module Blinker where--import Clash.Prelude-import Clash.Intel.ClockGen--data LedMode-  = Rotate-  -- ^ After some period, rotate active led to the left-  | Complement-  -- ^ After some period, turn on all disable LEDs, and vice versa-  deriving (Generic, 'Undefined')---- Define a synthesis domain with a clock with a period of 20000 /ps/.-'createDomain' 'vSystem'{vName=\"Input\", vPeriod=20000}---- Define a synthesis domain with a clock with a period of 50000 /ps/.-'createDomain' 'vSystem'{vName=\"Dom50\", vPeriod=50000}--{\-\# ANN topEntity-  ('Synthesize'-    { t_name   = \"blinker\"-    , t_inputs = [ PortName \"CLOCK_50\"-                 , PortName \"KEY0\"-                 , PortName \"KEY1\"-                 ]-    , t_output = PortName \"LED\"-    }) \#-\}-topEntity-  :: Clock Input-  -- ^ Incoming clock-  -> Signal Input Bool-  -- ^ Reset signal, straight from KEY0-  -> Signal Dom50 Bit-  -- ^ Mode choice, straight from KEY1. See \'LedMode\'.-  -> Signal Dom50 (BitVector 8)-  -- ^ Output containing 8 bits, corresponding to 8 LEDs-topEntity clk20 rstBtn modeBtn =-  exposeClockResetEnable-    (mealy blinkerT initialStateBlinkerT . isRising 1)-    clk50-    rstSync-    en-    modeBtn- where-  -- | Enable line for subcomponents: we'll keep it always running-  en = enableGen--  -- Start with the first LED turned on, in rotate mode, with the counter on zero-  initialStateBlinkerT = (1, Rotate, 0)--  -- Signal coming from the reset button is low when pressed, and high when-  -- not pressed. We convert this signal to the polarity of our domain with-  -- 'unsafeFromActiveLow'.-  rst = 'Clash.Signal.unsafeFromLowPolarity' rstBtn--  -- Instantiate a PLL: this stabilizes the incoming clock signal and indicates-  -- when the signal is stable. We're also using it to transform an incoming-  -- clock signal running at 20 MHz to a clock signal running at 50 MHz.-  (clk50, pllStable) =-    altpll-      \@Dom50-      (SSymbol \@\"altpll50\")-      clk20-      rst--  -- Synchronize reset to clock signal coming from PLL. We want the reset to-  -- remain active while the PLL is NOT stable, hence the conversion with-  -- 'unsafeFromActiveLow'-  rstSync =-    'Clash.Signal.resetSynchronizer'-      clk50-      (unsafeFromLowPolarity pllStable)-      en--flipMode :: LedMode -> LedMode-flipMode Rotate = Complement-flipMode Complement = Rotate--blinkerT-  :: (BitVector 8, LedMode, Index 16650001)-  -> Bool-  -> ((BitVector 8, LedMode, Index 16650001), BitVector 8)-blinkerT (leds, mode, cntr) key1R = ((leds', mode', cntr'), leds)-  where-    -- clock frequency = 50e6  (50 MHz)-    -- led update rate = 333e-3 (every 333ms)-    cnt_max = 16650000 :: Index 16650001 -- 50e6 * 333e-3--    cntr' | cntr == cnt_max = 0-          | otherwise       = cntr + 1--    mode' | key1R     = flipMode mode-          | otherwise = mode--    leds' | cntr == 0 =-              case mode of-                Rotate -> rotateL leds 1-                Complement -> complement leds-          | otherwise = leds-@+              2017     , QBayLogic, Google Inc.,+              2021-2025, QBayLogic B.V.+              2022     , LUMI GUIDE FIETSDETECTIE B.V.+              2023     , Alex Mason++Licence   : Creative Commons 4.0 (CC BY 4.0) (https://creativecommons.org/licenses/by/4.0/)+Maintainer:  QBayLogic B.V. <devops@qbaylogic.com>+-}++module Clash.Tutorial (+  -- * The content of this page has been moved+  -- $moved+  )+where++{- $moved+The content of this page has been moved:++* The tutorial can now be found at: https://docs.clash-lang.org/tutorial/+* Compiler user guide material can now be found at: https://docs.clash-lang.org/compiler-user-guide/+ -}
+ src/Clash/Verification.hs view
@@ -0,0 +1,84 @@+{-|+Copyright  :  (C) 2019, Myrtle Software Ltd+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++See "Clash.Explicit.Verification" for an introduction.++The verification API is currently experimental and subject to change.++-}++module Clash.Verification+  ( -- * Types+    Assertion+  , Property+  , RenderAs(..)++    -- * Bootstrapping functions+  , EV.name+  , EV.lit++    -- * Functions to build a PSL/SVA expressions+  , EV.not+  , EV.and+  , EV.or+  , EV.implies+  , EV.next+  , EV.nextN+  , EV.before+  , EV.timplies+  , EV.timpliesOverlapping+  , EV.always+  , EV.never+  , EV.eventually++  -- * Asserts+  , EV.assert+  , EV.cover++  -- * Assertion checking+  , check+  , checkI++  -- * Functions to deal with assertion results+  , EV.hideAssertion+  ) where+++import qualified Clash.Explicit.Verification     as EV+import           Clash.Signal+  (KnownDomain, HiddenClock, HiddenReset, Signal, hasClock, hasReset)+import           Clash.Verification.Internal+import           Data.Text                       (Text)++-- | Print property as PSL/SVA in HDL. Clash simulation support not yet+-- implemented.+check+  :: ( KnownDomain dom+     , HiddenClock dom+     , HiddenReset dom+     )+  => Text+  -- ^ Property name (used in reports and error messages)+  -> RenderAs+  -- ^ Assertion language to use in HDL+  -> Property dom+  -> Signal dom AssertionResult+check = EV.check hasClock hasReset++-- | Same as 'check', but doesn't require a design to explicitly carried to+-- top-level.+checkI+  :: ( KnownDomain dom+     , HiddenClock dom+     , HiddenReset dom+     )+  => Text+  -- ^ Property name (used in reports and error messages)+  -> RenderAs+  -- ^ Assertion language to use in HDL+  -> Property dom+  -> Signal dom a+  -> Signal dom a+checkI = EV.checkI hasClock hasReset
+ src/Clash/Verification/DSL.hs view
@@ -0,0 +1,42 @@+module Clash.Verification.DSL where++import qualified Clash.Verification           as Cv+import           Clash.Verification.Internal++-- Precedences taken from:+--+--   Table 2—FL operator precedence and associativity+--+-- of+--+--   IEEE Std 1850-2010a, Annex B.1, p149++infixr 5 |&|+(|&|) :: (AssertionValue dom a, AssertionValue dom b) => a -> b -> Assertion dom+a |&| b = Cv.and a b+{-# INLINE (|&|) #-}++infixr 4 |||+(|||) :: (AssertionValue dom a, AssertionValue dom b) => a -> b -> Assertion dom+a ||| b = Cv.or a b+{-# INLINE (|||) #-}++(~>) :: (AssertionValue dom a, AssertionValue dom b) => a -> b -> Assertion dom+a ~> b = Cv.implies a b+{-# INLINE (~>) #-}+infixr 0 ~>++(|=>) :: (AssertionValue dom a, AssertionValue dom b) => a -> b -> Assertion dom+a |=> b = Cv.timplies a b+{-# INLINE (|=>) #-}+infixr 1 |=>++(|->) :: (AssertionValue dom a, AssertionValue dom b) => a -> b -> Assertion dom+a |-> b = Cv.timpliesOverlapping a b+{-# INLINE (|->) #-}+infixr 1 |->++(#|#) :: (AssertionValue dom a, AssertionValue dom b) => a -> b -> Assertion dom+a #|# b = Cv.before a b+{-# INLINE (#|#) #-}+infixr 3 #|#
+ src/Clash/Verification/Internal.hs view
@@ -0,0 +1,157 @@+{-|+Copyright  :  (C) 2019, Myrtle Software Ltd+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Verification+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Verification.Internal+ ( AssertionResult(..)+ , Property(..)+ , Assertion(..)+ , RenderAs(..)+ , IsTemporal(..)+ , AssertionValue(toAssertionValue)+ , Assertion'(..)+ , Property'(..)+ , toTemporal+ , isTemporal+ , assertion+ )+ where++import           Data.Text                      (Text)++import Clash.Annotations.BitRepresentation+  (ConstrRepr(..), DataReprAnn(..), liftQ)+import           Clash.Signal.Internal          (Domain, Signal)++-- | Render target for HDL+data RenderAs+  = PSL+  -- ^ Property Specification Language+  | SVA+  -- ^ SystemVerilog Assertions+  | AutoRenderAs+  -- ^ Use SVA for SystemVerilog, PSL for others+  | YosysFormal+  -- ^ Yosys Formal Extensions for Verilog and SystemVerilog. See:+  -- https://symbiyosys.readthedocs.io/en/latest/verilog.html and+  -- https://symbiyosys.readthedocs.io/en/latest/verific.html+  --+  -- Falls back to PSL for VHDL, however currently Clash's PSL syntax isn't+  -- suported by GHDL+SymbiYosys;+  deriving (Show, Eq)++data IsTemporal+  = IsNotTemporal+  | IsTemporal+  deriving (Eq, Ord)++-- | Internal version of 'Assertion'.+data Assertion' a+  = CvPure a+  -- ^ (Bootstrapping) signal of booleans+  | CvToTemporal (Assertion' a)+  -- ^ Tag to force a non-temporal assertion to a temporal one+  | CvLit Bool+  -- ^ Boolean literal++  | CvNot (Assertion' a)+  -- ^ Logical not+  | CvAnd (Assertion' a) (Assertion' a)+  -- ^ Logical and+  | CvOr (Assertion' a) (Assertion' a)+  -- ^ Logical or+  | CvImplies (Assertion' a) (Assertion' a)+  -- ^ Logical implies++  | CvNext Word (Assertion' a)+  -- ^ Moves start point of assertion /n/ cycles forward+  | CvBefore (Assertion' a) (Assertion' a)+  -- ^ Before @CvBefore a b@ is the same as @CvAnd a (CvNext 1 b)@+  | CvTemporalImplies Word (Assertion' a) (Assertion' a)+  -- ^ Temporal implies @CvTemporalImplies n a b@:+  --+  --   n | n == 0    -> same as @CvImplies a b@+  --     | otherwise -> same as @CvImplies a (CvNextN n b)@+  --+  | CvAlways (Assertion' a)+  -- ^ Assertion should _always_ hold+  | CvNever (Assertion' a)+  -- ^ Assertion should _never_ hold (not supported by SVA)+  | CvEventually (Assertion' a)+  -- ^ Assertion should _eventually_ hold+  deriving (Show, Functor, Foldable, Traversable)++-- | Internal version of 'Property'. All user facing will instantiate @a@+-- with @(Maybe Text, Signal dom Bool)@. Blackboxes will instantiate it with+-- @(Maybe Text, Term)@ instead.+data Property' a+  = CvAssert (Assertion' a)+  | CvCover (Assertion' a)+  | CvAssume (Assertion' a)+  deriving (Show, Functor, Foldable, Traversable)++data Assertion (dom :: Domain) =+  Assertion IsTemporal (Assertion' (Maybe Text, Signal dom Bool))++toTemporal :: Assertion dom -> Assertion' (Maybe Text, Signal dom Bool)+toTemporal (Assertion IsTemporal a) = a+toTemporal (Assertion IsNotTemporal a) = CvToTemporal a+{-# INLINE toTemporal #-}++isTemporal :: Assertion dom -> IsTemporal+isTemporal (Assertion it _assert) = it+{-# INLINE isTemporal #-}++assertion :: Assertion dom -> Assertion' (Maybe Text, Signal dom Bool)+assertion (Assertion _it assert) = assert+{-# INLINE assertion #-}++-- | A property is a temporal or basic assertion that's specified to either+-- used as an _assert_ or _cover_ statement. See+-- 'Clash.Explicit.Verification.assert' and 'Clash.Explicit.Verification.cover'.+newtype Property (dom :: Domain) =+  Property (Property' (Maybe Text, Signal dom Bool))++-- | A result of some property. Besides carrying the actual boolean result, it+-- carries some properties used to make reports.+data AssertionResult = AssertionResult+  { cvPropName :: !String  -- I'd like text, but Clash complains :[+  -- ^ Name of property belonging to this result+  , cvPass :: !Bool+  -- ^ False whenever property is violated, True otherwise+  }+  deriving (Eq)+{-# ANN module (+  DataReprAnn+    $(liftQ [t| AssertionResult |])+    0+    [ ConstrRepr 'AssertionResult 0 0 [0b0, 0b0]+    ]) #-}+{- Marked as zero-width so Clash won't stumble on the fact it's unrepresentable. ^ -}++-- | An AssertionValue is a bool-like value or stream that can be used in+-- property specifications. Clash implements two: a stream of booleans+-- (Signal dom Bool), and the result of a property expression (Assertion+-- dom).+class AssertionValue dom a | a -> dom where+  -- | Convert given type into a Assertion.+  toAssertionValue :: a -> Assertion dom++-- | Stream of booleans, originating from a circuit+instance AssertionValue dom (Signal dom Bool) where+  toAssertionValue s = Assertion IsNotTemporal (CvPure (Nothing, s))+  {-# INLINE toAssertionValue #-}++-- | Result of a property specification+instance AssertionValue dom (Assertion dom) where+  toAssertionValue = id+  {-# INLINE toAssertionValue #-}
src/Clash/XException.hs view
@@ -1,94 +1,218 @@ {-| Copyright  :  (C) 2016,      University of Twente,                   2017,      QBayLogic, Google Inc.-                  2017-2019, Myrtle Software Ltd+                  2017-2019, Myrtle Software Ltd,+                  2021-2025, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -'X': An exception for uninitialized values+'XException': An exception for uninitialized values ->>> show (errorX "undefined" :: Integer, 4 :: Int)-"(*** Exception: X: undefined+>>> show (errorX "No value here" :: Integer, 4 :: Int)+"(*** Exception: X: No value here CallStack (from HasCallStack): ...->>> showX (errorX "undefined" :: Integer, 4 :: Int)-"(X,4)"+>>> showX (errorX "No value here" :: Integer, 4 :: Int)+"(undefined,4)" -} -{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DefaultSignatures     #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE EmptyCase             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MagicHash             #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE StandaloneDeriving    #-}-{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}  {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -Wno-orphans #-}- module Clash.XException-  ( -- * 'X': An exception for uninitialized values-    XException(..), errorX, isX, hasX, maybeIsX, maybeHasX-    -- * Printing 'X' exceptions as \"X\"+  ( -- * 'XException': An exception for uninitialized values+    XException(..), errorX, isX, hasX, maybeIsX, maybeHasX, fromJustX, undefined,+    xToErrorCtx, xToError+    -- * Printing 'XException's as @undefined@   , ShowX (..), showsX, printX, showsPrecXWith     -- * Strict evaluation-  , seqX, forceX, deepseqX, rwhnfX, defaultSeqX+  , seqX, seqErrorX, forceX, deepseqX, rwhnfX, defaultSeqX, hwSeqX     -- * Structured undefined / deep evaluation with undefined values-  , NFDataX (rnfX, deepErrorX)+  , NFDataX (rnfX, deepErrorX, hasUndefined, ensureSpine)   ) where -import Control.Exception (Exception, catch, evaluate, throw)-import Control.DeepSeq   (NFData, rnf)-import Data.Complex      (Complex)-import Data.Either       (isLeft)-import Data.Foldable     (toList)-import Data.Int          (Int8,Int16,Int32,Int64)-import Data.Ord          (Down (Down))-import Data.Ratio        (Ratio, numerator, denominator)-import qualified Data.Semigroup as SG-import Data.Sequence     (Seq(Empty, (:<|)))-import Data.Word         (Word8,Word16,Word32,Word64)-import GHC.Exts          (Char (C#), Double (D#), Float (F#), Int (I#), Word (W#))-import GHC.Generics-import GHC.Natural       (Natural)-import GHC.Show          (appPrec)-import GHC.Stack         (HasCallStack, callStack, prettyCallStack, withFrozenCallStack)-import Numeric.Half      (Half)-import System.IO.Unsafe  (unsafeDupablePerformIO)+import           Prelude             hiding (undefined) --- | An exception representing an \"uninitialized\" value.-newtype XException = XException String+import           Clash.Annotations.Primitive (hasBlackBox)+import           Clash.CPP           (maxTupleSize, fSuperStrict)+import           Clash.XException.Internal+import           Clash.XException.TH+import           Control.Exception+  (ErrorCall (..), Handler(..), catch, catches, evaluate, throw)+import           Control.DeepSeq     (NFData, rnf)+import           Data.Complex        (Complex)+import           Data.Either         (isLeft)+import           Data.Foldable       (toList)+import           Data.Functor.Compose (Compose)+import           Data.Functor.Const  (Const)+import           Data.Functor.Identity (Identity)+import           Data.Functor.Product (Product)+import           Data.Functor.Sum    (Sum)+import           Data.Int            (Int8, Int16, Int32, Int64)+import qualified Data.List.Infinite  as Inf+import           Data.List.Infinite  (Infinite (..))+import           Data.List.NonEmpty  (NonEmpty)+import           Data.Ord            (Down (Down))+import           Data.Proxy          (Proxy)+import           Data.Ratio          (Ratio, numerator, denominator)+import qualified Data.Semigroup      as SG+import qualified Data.Monoid         as M+import           Data.Sequence       (Seq(Empty, (:<|)))+import           Data.Word           (Word8, Word16, Word32, Word64)+import           Foreign.C.Types     (CUShort)+import           GHC.Generics+import           GHC.Natural         (Natural)+import           GHC.Stack+  (HasCallStack, callStack, prettyCallStack, withFrozenCallStack)+import           Numeric.Half        (Half)+import           System.IO.Unsafe    (unsafeDupablePerformIO) -instance Show XException where-  show (XException s) = s+-- $setup+-- >>> :m -Prelude+-- >>> import Clash.Prelude+-- >>> import Clash.Class.BitPack (pack)+-- >>> import Clash.Sized.Vector (Vec)+-- >>> import Clash.Sized.RTree (RTree)+-- >>> :set -fplugin GHC.TypeLits.Normalise+-- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver -instance Exception XException --- | Either 'seqX' or 'deepSeqX' depending on the value of the cabal flag+-- | Either 'seqX' or 'deepseqX' depending on the value of the cabal flag -- '-fsuper-strict'. If enabled, 'defaultSeqX' will be 'deepseqX', otherwise -- 'seqX'. Flag defaults to /false/ and thus 'seqX'. defaultSeqX :: NFDataX a => a -> b -> b-#ifdef CLASH_SUPER_STRICT-defaultSeqX = deepseqX-#else-defaultSeqX = seqX-#endif+defaultSeqX = if fSuperStrict then deepseqX else seqX {-# INLINE defaultSeqX #-}+infixr 0 `defaultSeqX`  -- | Like 'error', but throwing an 'XException' instead of an 'ErrorCall' ----- The 'ShowX' methods print these error-values as \"X\"; instead of error'ing+-- The 'ShowX' methods print these error-values as @undefined@; instead of error'ing -- out with an exception. errorX :: HasCallStack => String -> a errorX msg = throw (XException ("X: " ++ msg ++ "\n" ++ prettyCallStack callStack))+{-# OPAQUE errorX #-}+{-# ANN errorX hasBlackBox #-} +-- | Convert 'XException' to 'ErrorCall'+--+-- This is useful when tracking the source of 'XException' that gets eaten up by+-- 'Clash.Classes.BitPack.pack' inside of your circuit; since+-- 'Clash.Classes.BitPack.pack' translates 'XException' into undefined bits.+--+-- So for example if you have some large function f:+--+-- > f a b = ... pack a ... pack b ...+--+-- Where it is basically an error if either /a/ or /b/ ever throws an 'XException',+-- and so you want that to be reported the moment /a/ or /b/ is used, instead of+-- it being thrown when evaluating the result of /f/, then do:+--+-- > {-# LANGUAGE ViewPatterns #-}+-- > f (xToErrorCtx "a is X" -> a) (xToErrorCtx "b is X" -> b) = ...+--+-- Where we pass an extra string, for context, to know which argument evaluated+-- to an 'XException'. We can also use BangPatterns to report the potential+-- 'XException' being thrown by /a/ or /b/ even earlier, i.e. when /f/ is applied:+--+-- > {-# LANGUAGE ViewPatterns, BangPatterns #-}+-- > f (xToErrorCtx "a is X" -> !a) (xToErrorCtx "b is X" -> !b) = ...+--+-- __NB__: Fully synthesizable, so doesn't have to be removed before synthesis+--+-- === __Example__+--+-- >>> :set -XViewPatterns -XDataKinds+-- >>> import Clash.Sized.BitVector+-- >>> import GHC.Stack+-- >>> :{+-- let h, h' :: Bit -> BitVector 8 -> BitVector 8+--     h (xToErrorCtx "a is X" -> a) (xToErrorCtx "b is X" -> b) = slice d7 d0 (pack a ++# b)+--     h' a b = slice d7 d0 (pack a ++# b)+-- :}+--+-- >>> h' (errorX "QQ") 3+-- 0b0000_0011+-- >>> h (errorX "QQ") 3+-- *** Exception: a is X+-- X: QQ+-- CallStack (from HasCallStack):+--   errorX, called at ...+-- ...+xToErrorCtx :: String -> a -> a+xToErrorCtx ctx a = unsafeDupablePerformIO+  (catch (evaluate a >> return a)+         (\(XException msg) ->+           throw (ErrorCall (unlines [ctx,msg]))))+{-# OPAQUE xToErrorCtx #-}++-- | Convert 'XException' to 'ErrorCall'+--+-- This is useful when tracking the source of 'XException' that gets eaten up by+-- 'Clash.Classes.BitPack.pack' inside of your circuit; since+-- 'Clash.Classes.BitPack.pack' translates 'XException' into undefined bits.+--+-- So for example if you have some large function f:+--+-- > f a b = ... pack a ... pack b ...+--+-- Where it is basically an error if either /a/ or /b/ ever throws an 'XException',+-- and so you want that to be reported the moment /a/ or /b/ is used, instead of+-- it being thrown when evaluating the result of /f/, then do:+--+-- > {-# LANGUAGE ViewPatterns #-}+-- > f (xToError -> a) (xToError -> b) = ...+--+-- Unlike 'xToErrorCtx', where we have an extra String argument to distinguish+-- one call to 'xToError' to the other, 'xToError' will use the 'GHC.CallStack'+-- mechanism to aid the user in distinguishing different call to 'xToError'.+-- We can also use BangPatterns to report the potential 'XException' being+-- thrown by /a/ or /b/ even earlier, i.e. when /f/ is applied:+--+-- > {-# LANGUAGE ViewPatterns, BangPatterns #-}+-- > f (xToError -> !a) (xToError -> !b) = ...+--+-- __NB__: Fully synthesizable, so doesn't have to be removed before synthesis+--+-- === __Example__+--+-- >>> :set -XViewPatterns -XDataKinds+-- >>> import Clash.Sized.BitVector+-- >>> import GHC.Stack+-- >>> :{+-- let f, g, h, h' :: HasCallStack => Bit -> BitVector 8 -> BitVector 8+--     f = g+--     g = h+--     h (xToError -> a) (xToError -> b) = slice d7 d0 (pack a ++# b)+--     h' a b = slice d7 d0 (pack a ++# b)+-- :}+--+-- >>> h' (errorX "QQ") 3+-- 0b0000_0011+-- >>> f (errorX "QQ") 3+-- *** Exception: CallStack (from HasCallStack):+--   xToError, called at ...+--   h, called at ...+--   g, called at ...+--   f, called at ...+-- X: QQ+-- CallStack (from HasCallStack):+--   errorX, called at ...+-- ...+xToError :: HasCallStack => a -> a+xToError = xToErrorCtx (prettyCallStack callStack)+{-# INLINE xToError #-}+ -- | Like 'seq', however, whereas 'seq' will always do: -- -- > seq  _|_              b = _|_@@ -100,17 +224,56 @@ seqX :: a -> b -> b seqX a b = unsafeDupablePerformIO   (catch (evaluate a >> return b) (\(XException _) -> return b))-{-# NOINLINE seqX #-}+{-# OPAQUE seqX #-}+{-# ANN seqX hasBlackBox #-} infixr 0 `seqX` +-- | Like 'seqX', but will also catch ErrorCall exceptions which are thrown.+-- This should be used with care.+--+-- > seqErrorX (ErrorCall msg)  b = b+-- > seqErrorX (XException msg) b = b+-- > seqErrorX _|_              b = _|_+seqErrorX :: a -> b -> b+seqErrorX a b = unsafeDupablePerformIO+  ((evaluate a >> return b) `catches`+     [ Handler (\(XException _) -> return b)+     , Handler (\(ErrorCall _) -> return b)+     ])+{-# OPAQUE seqErrorX #-}+{-# ANN seqErrorX hasBlackBox #-}+infixr 0 `seqErrorX`++-- | Like 'seqX' in simulation, but will force its first argument to be rendered+-- in HDL. This is useful for components that need to be rendered in hardware,+-- but otherwise have no meaning in simulation. An example of such a component+-- would be an ILA: a component monitoring an internal signal of a design. The+-- output of such a component (typically a unit) can be passed as the first+-- argument to 'hwSeqX' to ensure the ILA ends up in the generated HDL.+--+-- __NB__: The result of 'hwSeqX' must (indirectly) be used at the very top of+-- a design. If it's not, Clash will remove it like it does for any other unused+-- circuit parts.+--+-- __NB__: Make sure the blackbox for the component with zero-width results+-- uses 'Clash.Netlist.BlackBox.Types.RenderVoid'+hwSeqX :: a -> b -> b+hwSeqX = seqX+{-# OPAQUE hwSeqX #-}+{-# ANN hwSeqX hasBlackBox #-}+infixr 0 `hwSeqX`+ -- | Evaluate a value with given function, returning 'Nothing' if it throws--- 'XException'.+-- 'XException'. Note that non-'XException' errors take precedence over 'XException'+-- ones ----- > maybeX hasX 42                  = Just 42--- > maybeX hasX (XException msg)    = Nothing--- > maybeX hasX (3, XException msg) = Nothing--- > maybeX hasX (3, _|_)            = _|_--- > maybeX hasX _|_                 = _|_+-- > maybeX hasX 42                    = Just 42+-- > maybeX hasX (XException msg)      = Nothing+-- > maybeX hasX (3, XException msg)   = Nothing+-- > maybeX hasX (XException msg, _|_) = _|_+-- > maybeX hasX (_|_, XException msg) = _|_+-- > maybeX hasX (3, _|_)              = _|_+-- > maybeX hasX _|_                   = _|_ -- > -- > maybeX isX 42                  = Just 42 -- > maybeX isX (XException msg)    = Nothing@@ -118,18 +281,21 @@ -- > maybeX isX (3, _|_)            = Just (3, _|_) -- > maybeX isX _|_                 = _|_ ---maybeX :: NFData a => (a -> Either String a) -> a -> Maybe a+maybeX :: (a -> Either String a) -> a -> Maybe a maybeX f a = either (const Nothing) Just (f a) --- | Fully evaluate a value, returning 'Nothing' if it throws 'XException'.+-- | Fully evaluate a value, returning 'Nothing' if it throws 'XException'. Note+-- that non-'XException' errors take precedence over 'XException' ones. ----- > maybeX 42                  = Just 42--- > maybeX (XException msg)    = Nothing--- > maybeX (3, XException msg) = Nothing--- > maybeX (3, _|_)            = _|_--- > maybeX _|_                 = _|_+-- > maybeHasX 42                    = Just 42+-- > maybeHasX (XException msg)      = Nothing+-- > maybeHasX (3, XException msg)   = Nothing+-- > maybeHasX (XException msg, _|_) = _|_+-- > maybeHasX (_|_, XException msg) = _|_+-- > maybeHasX (3, _|_)              = _|_+-- > maybeHasX _|_                   = _|_ ---maybeHasX :: NFData a => a -> Maybe a+maybeHasX :: (NFData a, NFDataX a) => a -> Maybe a maybeHasX = maybeX hasX  -- | Evaluate a value to WHNF, returning 'Nothing' if it throws 'XException'.@@ -139,33 +305,41 @@ -- > maybeIsX (3, XException msg) = Just (3, XException msg) -- > maybeIsX (3, _|_)            = Just (3, _|_) -- > maybeIsX _|_                 = _|_-maybeIsX :: NFData a => a -> Maybe a+maybeIsX :: a -> Maybe a maybeIsX = maybeX isX  -- | Fully evaluate a value, returning @'Left' msg@ if it throws 'XException'.+-- If you want to determine if a value contains undefined parts, use+-- 'hasUndefined' instead. ----- > hasX 42                  = Right 42--- > hasX (XException msg)    = Left msg--- > hasX (3, XException msg) = Left msg--- > hasX (3, _|_)            = _|_--- > hasX _|_                 = _|_+-- > hasX 42                    = Right 42+-- > hasX (XException msg)      = Left msg+-- > hasX (3, XException msg)   = Left msg+-- > hasX (XException msg, _|_) = _|_+-- > hasX (_|_, XException msg) = _|_+-- > hasX (3, _|_)              = _|_+-- > hasX _|_                   = _|_ -- -- If a data structure contains multiple 'XException's, the "first" message is--- picked according to the implementation of 'rnf'.-hasX :: NFData a => a -> Either String a+-- picked according to the implementation of 'rnfX'.+hasX :: (NFData a, NFDataX a) => a -> Either String a hasX a =+  -- TODO: Whenever 'a' contains an 'XException', we need to reevaluate the+  --       structure using 'rnfX' to make sure it didn't also contain another+  --       error call. We could prevent the two traversals by making 'hasX' a+  --       type class method. Also see: https://github.com/clash-lang/clash-compiler/issues/2450.   unsafeDupablePerformIO     (catch       (evaluate (rnf a) >> return (Right a))-      (\(XException msg) -> return (Left msg)))-{-# NOINLINE hasX #-}+      (\(XException msg) -> evaluate (rnfX a) >> return (Left msg)))+{-# OPAQUE hasX #-}  -- | Evaluate a value to WHNF, returning @'Left' msg@ if is a 'XException'. -- -- > isX 42                  = Right 42 -- > isX (XException msg)    = Left msg -- > isX (3, XException msg) = Right (3, XException msg)--- > isX (3, _|_)            = (3, _|_)+-- > isX (3, _|_)            = Right (3, _|_) -- > isX _|_                 = _|_ isX :: a -> Either String a isX a =@@ -173,50 +347,17 @@     (catch       (evaluate a >> return (Right a))       (\(XException msg) -> return (Left msg)))-{-# NOINLINE isX #-}--showXWith :: (a -> ShowS) -> a -> ShowS-showXWith f x =-  \s -> unsafeDupablePerformIO (catch (f <$> evaluate x <*> pure s)-                                      (\(XException _) -> return ('X': s)))---- | Use when you want to create a 'ShowX' instance where:------ - There is no 'Generic' instance for your data type--- - The 'Generic' derived ShowX method would traverse into the (hidden)---   implementation details of your data type, and you just want to show the---   entire value as \"X\".------ Can be used like:------ > data T = ...--- >--- > instance Show T where ...--- >--- > instance ShowX T where--- >   showsPrecX = showsPrecXWith showsPrec-showsPrecXWith :: (Int -> a -> ShowS) -> Int -> a -> ShowS-showsPrecXWith f n = showXWith (f n)---- | Like 'shows', but values that normally throw an 'X' exception are--- converted to \"X\", instead of error'ing out with an exception.-showsX :: ShowX a => a -> ShowS-showsX = showsPrecX 0---- | Like 'print', but values that normally throw an 'X' exception are--- converted to \"X\", instead of error'ing out with an exception-printX :: ShowX a => a -> IO ()-printX x = putStrLn $ showX x+{-# OPAQUE isX #-} --- | Like the 'Show' class, but values that normally throw an 'X' exception are--- converted to \"X\", instead of error'ing out with an exception.+-- | Like the 'Show' class, but values that normally throw an 'XException' are+-- converted to @undefined@, instead of error'ing out with an exception. ----- >>> show (errorX "undefined" :: Integer, 4 :: Int)--- "(*** Exception: X: undefined+-- >>> show (errorX "No value here" :: Integer, 4 :: Int)+-- "(*** Exception: X: No value here -- CallStack (from HasCallStack): -- ...--- >>> showX (errorX "undefined" :: Integer, 4 :: Int)--- "(X,4)"+-- >>> showX (errorX "No value here" :: Integer, 4 :: Int)+-- "(undefined,4)" -- -- Can be derived using 'GHC.Generics': --@@ -228,76 +369,36 @@ -- > data T = MkTA Int | MkTB Bool -- >   deriving (Show,Generic,ShowX) class ShowX a where-  -- | Like 'showsPrec', but values that normally throw an 'X' exception are-  -- converted to \"X\", instead of error'ing out with an exception.+  -- | Like 'showsPrec', but values that normally throw an 'XException' are+  -- converted to @undefined@, instead of error'ing out with an exception.   showsPrecX :: Int -> a -> ShowS -  -- | Like 'show', but values that normally throw an 'X' exception are-  -- converted to \"X\", instead of error'ing out with an exception.+  -- | Like 'show', but values that normally throw an 'XException' are+  -- converted to @undefined@, instead of error'ing out with an exception.   showX :: a -> String   showX x = showsX x "" -  -- | Like 'showList', but values that normally throw an 'X' exception are-  -- converted to \"X\", instead of error'ing out with an exception.+  -- | Like 'showList', but values that normally throw an 'XException' are+  -- converted to @undefined@, instead of error'ing out with an exception.   showListX :: [a] -> ShowS   showListX ls s = showListX__ showsX ls s    default showsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS   showsPrecX = genericShowsPrecX -showListX__ :: (a -> ShowS) -> [a] -> ShowS-showListX__ showx = showXWith go-  where-    go []     s = "[]" ++ s-    go (x:xs) s = '[' : showx x (showl xs)-      where-        showl []     = ']':s-        showl (y:ys) = ',' : showx y (showl ys)--data ShowType = Rec        -- Record-              | Tup        -- Tuple-              | Pref       -- Prefix-              | Inf String -- Infix--genericShowsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS-genericShowsPrecX n = gshowsPrecX Pref n . from+-- | Like 'print', but values that normally throw an 'XException' are+-- converted to @undefined@, instead of error'ing out with an exception+printX :: ShowX a => a -> IO ()+printX x = putStrLn $ showX x  instance ShowX ()-instance (ShowX a, ShowX b) => ShowX (a,b)-instance (ShowX a, ShowX b, ShowX c) => ShowX (a,b,c)-instance (ShowX a, ShowX b, ShowX c, ShowX d) => ShowX (a,b,c,d)-instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e) => ShowX (a,b,c,d,e)-instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f) => ShowX (a,b,c,d,e,f)-instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g) => ShowX (a,b,c,d,e,f,g)---- Show is defined up to 15-tuples, but GHC.Generics only has Generic instances--- up to 7-tuples, hence we need these orphan instances.-deriving instance Generic ((,,,,,,,) a b c d e f g h)-deriving instance Generic ((,,,,,,,,) a b c d e f g h i)-deriving instance Generic ((,,,,,,,,,) a b c d e f g h i j)-deriving instance Generic ((,,,,,,,,,,) a b c d e f g h i j k)-deriving instance Generic ((,,,,,,,,,,,) a b c d e f g h i j k l)-deriving instance Generic ((,,,,,,,,,,,,) a b c d e f g h i j k l m)-deriving instance Generic ((,,,,,,,,,,,,,) a b c d e f g h i j k l m n)-deriving instance Generic ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o)--instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h) => ShowX (a,b,c,d,e,f,g,h)-instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i) => ShowX (a,b,c,d,e,f,g,h,i)-instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j)-  => ShowX (a,b,c,d,e,f,g,h,i,j)-instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k)-  => ShowX (a,b,c,d,e,f,g,h,i,j,k)-instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l)-  => ShowX (a,b,c,d,e,f,g,h,i,j,k,l)-instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l-         ,ShowX m)-  => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m)-instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l-         ,ShowX m, ShowX n)-  => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m,n)-instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l-         ,ShowX m, ShowX n, ShowX o)-  => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)+-- | @since 1.8.2+instance ShowX (Proxy a)+instance ShowX a => ShowX (Identity a)+instance ShowX a => ShowX (Const a b)+instance (ShowX (f a), ShowX (g a)) => ShowX (Product f g a)+instance (ShowX (f a), ShowX (g a)) => ShowX (Sum f g a)+instance (ShowX (f (g a))) => ShowX (Compose f g a)  instance {-# OVERLAPPABLE #-} ShowX a => ShowX [a] where   showsPrecX _ = showListX@@ -339,6 +440,8 @@ instance ShowX Natural where   showsPrecX = showsPrecXWith showsPrec +instance ShowX Ordering+ instance ShowX a => ShowX (Seq a) where   showsPrecX _ = showListX . toList @@ -357,6 +460,9 @@ instance ShowX Word64 where   showsPrecX = showsPrecXWith showsPrec +instance ShowX CUShort where+  showsPrecX = showsPrecXWith showsPrec+ instance ShowX a => ShowX (Maybe a)  instance ShowX a => ShowX (Ratio a) where@@ -367,86 +473,7 @@ instance {-# OVERLAPPING #-} ShowX String where   showsPrecX = showsPrecXWith showsPrec -class GShowX f where-  gshowsPrecX :: ShowType -> Int -> f a -> ShowS-  isNullary   :: f a -> Bool-  isNullary = error "generic showX (isNullary): unnecessary case" -instance GShowX U1 where-  gshowsPrecX _ _ U1 = id-  isNullary _ = True--instance (ShowX c) => GShowX (K1 i c) where-  gshowsPrecX _ n (K1 a) = showsPrecX n a-  isNullary _ = False--instance (GShowX a, Constructor c) => GShowX (M1 C c a) where-  gshowsPrecX _ n c@(M1 x) =-    case fixity of-      Prefix ->-        showParen (n > appPrec && not (isNullary x))-          ( (if conIsTuple c then id else showString (conName c))-          . (if isNullary x || conIsTuple c then id else showString " ")-          . showBraces t (gshowsPrecX t appPrec x))-      Infix _ m -> showParen (n > m) (showBraces t (gshowsPrecX t m x))-      where fixity = conFixity c-            t = if conIsRecord c then Rec else-                  case conIsTuple c of-                    True -> Tup-                    False -> case fixity of-                                Prefix    -> Pref-                                Infix _ _ -> Inf (show (conName c))-            showBraces :: ShowType -> ShowS -> ShowS-            showBraces Rec     p = showChar '{' . p . showChar '}'-            showBraces Tup     p = showChar '(' . p . showChar ')'-            showBraces Pref    p = p-            showBraces (Inf _) p = p--            conIsTuple :: C1 c f p -> Bool-            conIsTuple y = tupleName (conName y) where-              tupleName ('(':',':_) = True-              tupleName _           = False--instance (Selector s, GShowX a) => GShowX (M1 S s a) where-  gshowsPrecX t n s@(M1 x) | selName s == "" =   gshowsPrecX t n x-                           | otherwise       =   showString (selName s)-                                               . showString " = "-                                               . gshowsPrecX t 0 x-  isNullary (M1 x) = isNullary x--instance (GShowX a) => GShowX (M1 D d a) where-  gshowsPrecX t = showsPrecXWith go-    where go n (M1 x) = gshowsPrecX t n x--instance (GShowX a, GShowX b) => GShowX (a :+: b) where-  gshowsPrecX t n (L1 x) = gshowsPrecX t n x-  gshowsPrecX t n (R1 x) = gshowsPrecX t n x--instance (GShowX a, GShowX b) => GShowX (a :*: b) where-  gshowsPrecX t@Rec     n (a :*: b) =-    gshowsPrecX t n     a . showString ", " . gshowsPrecX t n     b-  gshowsPrecX t@(Inf s) n (a :*: b) =-    gshowsPrecX t n     a . showString s    . gshowsPrecX t n     b-  gshowsPrecX t@Tup     n (a :*: b) =-    gshowsPrecX t n     a . showChar ','    . gshowsPrecX t n     b-  gshowsPrecX t@Pref    n (a :*: b) =-    gshowsPrecX t (n+1) a . showChar ' '    . gshowsPrecX t (n+1) b--  -- If we have a product then it is not a nullary constructor-  isNullary _ = False---- Unboxed types-instance GShowX UChar where-  gshowsPrecX _ _ (UChar c)   = showsPrec 0 (C# c) . showChar '#'-instance GShowX UDouble where-  gshowsPrecX _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##"-instance GShowX UFloat where-  gshowsPrecX _ _ (UFloat f)  = showsPrec 0 (F# f) . showChar '#'-instance GShowX UInt where-  gshowsPrecX _ _ (UInt i)    = showsPrec 0 (I# i) . showChar '#'-instance GShowX UWord where-  gshowsPrecX _ _ (UWord w)   = showsPrec 0 (W# w) . showString "##"- -- | a variant of 'deepseqX' that is useful in some circumstances: -- -- > forceX x = x `deepseqX` x@@ -458,7 +485,9 @@ -- second. Does not propagate 'XException's. deepseqX :: NFDataX a => a -> b -> b deepseqX a b = rnfX a `seq` b-{-# NOINLINE deepseqX #-}+{-# OPAQUE deepseqX #-}+{-# ANN deepseqX hasBlackBox #-}+infixr 0 `deepseqX`  -- | Reduce to weak head normal form --@@ -469,210 +498,201 @@ rwhnfX = (`seqX` ()) {-# INLINE rwhnfX #-} --- | Hidden internal type-class. Adds a generic implementation for the "NFData"--- part of 'NFDataX'-class GNFDataX arity f where-  grnfX :: RnfArgs arity a -> f a -> ()--instance GNFDataX arity V1 where-  grnfX _ x = case x of {}--data Zero-data One--data RnfArgs arity a where-  RnfArgs0 :: RnfArgs Zero a-  RnfArgs1  :: (a -> ()) -> RnfArgs One a--instance GNFDataX arity U1 where-  grnfX _ u = if isLeft (isX u) then () else case u of U1 -> ()--instance NFDataX a => GNFDataX arity (K1 i a) where-  grnfX _ = rnfX . unK1-  {-# INLINEABLE grnfX #-}--instance GNFDataX arity a => GNFDataX arity (M1 i c a) where-  grnfX args a =-    -- Check for X needed to handle edge-case "data Void"-    if isLeft (isX a) then-      ()-    else-      grnfX args (unM1 a)-  {-# INLINEABLE grnfX #-}--instance (GNFDataX arity a, GNFDataX arity b) => GNFDataX arity (a :*: b) where-  grnfX args xy@(~(x :*: y)) =-    if isLeft (isX xy) then-      ()-    else-      grnfX args x `seq` grnfX args y-  {-# INLINEABLE grnfX #-}--instance (GNFDataX arity a, GNFDataX arity b) => GNFDataX arity (a :+: b) where-  grnfX args lrx =-    if isLeft (isX lrx) then-      ()-    else-      case lrx of-        L1 x -> grnfX args x-        R1 x -> grnfX args x-  {-# INLINEABLE grnfX #-}--instance GNFDataX One Par1 where-  grnfX (RnfArgs1 r) = r . unPar1--instance NFDataX1 f => GNFDataX One (Rec1 f) where-  grnfX (RnfArgs1 r) = liftRnfX r . unRec1--instance (NFDataX1 f, GNFDataX One g) => GNFDataX One (f :.: g) where-  grnfX args = liftRnfX (grnfX args) . unComp1---- | A class of functors that can be fully evaluated, according to semantics--- of NFDataX.-class NFDataX1 f where-  -- | 'liftRnfX' should reduce its argument to normal form (that is, fully-  -- evaluate all sub-components), given an argument to reduce @a@ arguments,-  -- and then return '()'.-  ---  -- See 'rnfX' for the generic deriving.-  liftRnfX :: (a -> ()) -> f a -> ()--  default liftRnfX :: (Generic1 f, GNFDataX One (Rep1 f)) => (a -> ()) -> f a -> ()-  liftRnfX r = grnfX (RnfArgs1 r) . from1- -- | Class that houses functions dealing with /undefined/ values in Clash. See -- 'deepErrorX' and 'rnfX'. class NFDataX a where-  -- | Create a value where all the elements have an 'errorX', but the spine-  -- is defined.+  -- | Create a value where all the elements have an 'errorX',+  -- but the spine is defined.   deepErrorX :: HasCallStack => String -> a    default deepErrorX :: (HasCallStack, Generic a, GDeepErrorX (Rep a)) => String -> a   deepErrorX = withFrozenCallStack $ to . gDeepErrorX -  -- | Evaluate a value to NF. As opposed to 'NFData's 'rnf', it does not bubble-  -- up 'XException's.+  -- | Determines whether any of parts of a given construct contain undefined+  -- parts. Note that a negative answer does not mean its bit representation+  -- is fully defined. For example:+  --+  -- >>> m = Nothing :: Maybe Bool+  -- >>> hasUndefined m+  -- False+  -- >>> pack m+  -- 0b0.+  -- >>> hasUndefined (pack m)+  -- True+  --+  hasUndefined :: a -> Bool++  default hasUndefined :: (Generic a, GHasUndefined (Rep a)) => a -> Bool+  hasUndefined = gHasUndefined . from++  -- | Create a value where at the very least the spine is defined. For example:+  --+  -- >>> spined = ensureSpine (errorX "?" :: (Int, Int))+  -- >>> case spined of (_, _) -> 'a'+  -- 'a'+  -- >>> fmap (const 'b') (ensureSpine undefined :: Vec 3 Int)+  -- 'b' :> 'b' :> 'b' :> Nil+  -- >>> fmap (const 'c') (ensureSpine undefined :: RTree 2 Int)+  -- <<'c','c'>,<'c','c'>>+  --+  -- For users familiar with 'Clash.Sized.Vector.lazyV': this is the generalized+  -- version of it.+  ensureSpine :: a -> a++  default ensureSpine :: (Generic a, GEnsureSpine (Rep a)) => a -> a+  ensureSpine = to . gEnsureSpine . from++  -- | Evaluate a value to NF. As opposed to 'NFData's+  -- 'rnf', it does not bubble up 'XException's.   rnfX :: a -> ()    default rnfX :: (Generic a, GNFDataX Zero (Rep a)) => a -> ()   rnfX = grnfX RnfArgs0 . from  instance NFDataX ()-instance (NFDataX a, NFDataX b) => NFDataX (a,b)-instance (NFDataX a, NFDataX b, NFDataX c) => NFDataX (a,b,c)-instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d) => NFDataX (a,b,c,d)-instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e) => NFDataX (a,b,c,d,e)-instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e ,NFDataX f)-  => NFDataX (a,b,c,d,e,f)-instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e-         ,NFDataX f, NFDataX g)-  => NFDataX (a,b,c,d,e,f,g)-instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e-         ,NFDataX f, NFDataX g, NFDataX h)-  => NFDataX (a,b,c,d,e,f,g,h)-instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e-         ,NFDataX f, NFDataX g, NFDataX h, NFDataX i)-  => NFDataX (a,b,c,d,e,f,g,h,i)-instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e-         ,NFDataX f, NFDataX g, NFDataX h, NFDataX i, NFDataX j)-  => NFDataX (a,b,c,d,e,f,g,h,i,j)-instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e-         ,NFDataX f, NFDataX g, NFDataX h, NFDataX i, NFDataX j-         ,NFDataX k)-  => NFDataX (a,b,c,d,e,f,g,h,i,j,k)-instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e-         ,NFDataX f, NFDataX g, NFDataX h, NFDataX i, NFDataX j-         ,NFDataX k, NFDataX l)-  => NFDataX (a,b,c,d,e,f,g,h,i,j,k,l)-instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e-         ,NFDataX f, NFDataX g, NFDataX h, NFDataX i, NFDataX j-         ,NFDataX k, NFDataX l, NFDataX m)-  => NFDataX (a,b,c,d,e,f,g,h,i,j,k,l,m)-instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e-         ,NFDataX f, NFDataX g, NFDataX h, NFDataX i, NFDataX j-         ,NFDataX k, NFDataX l, NFDataX m, NFDataX n)-  => NFDataX (a,b,c,d,e,f,g,h,i,j,k,l,m,n)-instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e-         ,NFDataX f, NFDataX g, NFDataX h, NFDataX i, NFDataX j-         ,NFDataX k, NFDataX l, NFDataX m, NFDataX n, NFDataX o)-  => NFDataX (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)  instance NFDataX b => NFDataX (a -> b) where   deepErrorX = pure . deepErrorX   rnfX = rwhnfX+  hasUndefined = error "hasUndefined on NFDataX (a -> b): Not Yet Implemented"+  ensureSpine = id  instance NFDataX a => NFDataX (Down a) where   deepErrorX = Down . deepErrorX   rnfX d@(~(Down x)) = if isLeft (isX d) then () else rnfX x+  hasUndefined d@(~(Down x))= if isLeft (isX d) then True else hasUndefined x+  ensureSpine ~(Down x) = Down (ensureSpine x) +instance NFDataX a => NFDataX (Infinite a) where+  deepErrorX msg = Inf.repeat (deepErrorX msg)+  rnfX d@(~(x :< xs)) =+    if isLeft (isX d) then+      ()+    else+      rnfX x `seq` rnfX xs+  hasUndefined d@(~(x :< xs)) =+    if isLeft (isX d) then+      True+    else+      hasUndefined x || hasUndefined xs++  ensureSpine ~(x :< xs) = ensureSpine x :< ensureSpine xs+ instance NFDataX Bool+instance NFDataX Ordering instance NFDataX a => NFDataX [a]+instance NFDataX a => NFDataX (NonEmpty a) instance (NFDataX a, NFDataX b) => NFDataX (Either a b) instance NFDataX a => NFDataX (Maybe a)+-- | @since 1.8.2+instance NFDataX (Proxy a)+instance NFDataX a => NFDataX (Identity a)+instance NFDataX a => NFDataX (Const a b)+instance (NFDataX (f a), NFDataX (g a)) => NFDataX (Product f g a)+instance (NFDataX (f a), NFDataX (g a)) => NFDataX (Sum f g a)+instance (NFDataX (f (g a))) => NFDataX (Compose f g a)  instance NFDataX Char where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Double where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Float where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Int where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Int8 where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Int16 where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Int32 where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Int64 where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Integer where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Natural where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Word where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Word8 where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Word16 where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Word32 where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX Word64 where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id +instance NFDataX CUShort where+  deepErrorX = errorX+  rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id+ instance NFDataX Half where   deepErrorX = errorX   rnfX = rwhnfX+  hasUndefined = isLeft . isX+  ensureSpine = id  instance NFDataX a => NFDataX (Seq a) where   deepErrorX = errorX@@ -681,10 +701,19 @@    where     go Empty = ()     go (x :<| xs) = rnfX x `seq` go xs+  ensureSpine = id +  hasUndefined s =+    if isLeft (isX s) then True else go s+   where+    go Empty = False+    go (x :<| xs) = hasUndefined x || hasUndefined xs+ instance NFDataX a => NFDataX (Ratio a) where   deepErrorX = errorX   rnfX r = rnfX (numerator r) `seq` rnfX (denominator r)+  hasUndefined r = isLeft (isX (numerator r)) || isLeft (isX (denominator r))+  ensureSpine = id  instance NFDataX a => NFDataX (Complex a) where   deepErrorX = errorX@@ -698,27 +727,29 @@ instance NFDataX a => NFDataX (SG.Last a) instance NFDataX a => NFDataX (SG.Max a) instance NFDataX a => NFDataX (SG.Min a)-instance NFDataX a => NFDataX (SG.Option a) instance NFDataX a => NFDataX (SG.Product a) instance NFDataX a => NFDataX (SG.Sum a)--class GDeepErrorX f where-  gDeepErrorX :: HasCallStack => String -> f a--instance GDeepErrorX V1 where-  gDeepErrorX = errorX--instance GDeepErrorX U1 where-  gDeepErrorX = const U1+instance NFDataX a => NFDataX (M.First a)+instance NFDataX a => NFDataX (M.Last a) -instance (GDeepErrorX a) => GDeepErrorX (M1 m d a) where-  gDeepErrorX e = M1 (gDeepErrorX e)+-- | __NB__: The documentation only shows instances up to /3/-tuples. By+-- default, instances up to and including /12/-tuples will exist. If the flag+-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The+-- GHC imposed limit is either 62 or 64 depending on the GHC version.+mkShowXTupleInstances [2..maxTupleSize] -instance (GDeepErrorX f, GDeepErrorX g) => GDeepErrorX (f :*: g) where-  gDeepErrorX e = gDeepErrorX e :*: gDeepErrorX e+-- | __NB__: The documentation only shows instances up to /3/-tuples. By+-- default, instances up to and including /12/-tuples will exist. If the flag+-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The+-- GHC imposed limit is either 62 or 64 depending on the GHC version.+mkNFDataXTupleInstances [2..maxTupleSize] -instance NFDataX c => GDeepErrorX (K1 i c) where-  gDeepErrorX e = K1 (deepErrorX e)+-- | Call to 'errorX' with default string+undefined :: HasCallStack => a+undefined = errorX "undefined" -instance GDeepErrorX (f :+: g) where-  gDeepErrorX = errorX+-- | Same as 'Data.Maybe.fromJust', but returns a bottom/undefined value that+-- other Clash constructs are aware of.+fromJustX :: (HasCallStack, NFDataX a) => Maybe a -> a+fromJustX Nothing = deepErrorX "fromJustX: Nothing"+fromJustX (Just a) = a
+ src/Clash/XException.hs-boot view
@@ -0,0 +1,17 @@+module Clash.XException where++import Data.Kind (Type)+import GHC.Stack (HasCallStack)++isX :: a -> Either String a++class ShowX (a :: Type)+showsPrecX :: ShowX a => Int -> a -> ShowS++class NFDataX (a :: Type)+deepErrorX :: NFDataX a => HasCallStack => String -> a+hasUndefined :: NFDataX a => a -> Bool+rnfX :: NFDataX a => a -> ()+ensureSpine :: NFDataX a => a -> a++errorX :: HasCallStack => String -> a
+ src/Clash/XException/Internal.hs view
@@ -0,0 +1,354 @@+{-|+Copyright  :  (C) 2016,      University of Twente,+                  2017,      Google Inc.,+                  2017-2019, Myrtle Software Ltd,+                  2017-2025, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++'XException': An exception for uninitialized values++>>> show (errorX "No value here" :: Integer, 4 :: Int)+"(*** Exception: X: No value here+CallStack (from HasCallStack):+...+>>> showX (errorX "No value here" :: Integer, 4 :: Int)+"(undefined,4)"+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_HADDOCK not-home #-}++module Clash.XException.Internal+  ( XException(..)+    -- * Printing 'XException's as @undefined@+  , showsX, showsPrecXWith+  , showXWith++    -- * Internals+  , GShowX(..), GDeepErrorX(..), GHasUndefined(..), GEnsureSpine(..)+  , GNFDataX(..), Zero, One, ShowType(..), RnfArgs(..), NFDataX1(..)+  , showListX__, genericShowsPrecX+  )+where++import           Prelude             hiding (undefined)++import {-# SOURCE #-} Clash.XException+import           Control.Exception+  (Exception,  catch, evaluate)+import           Data.Either         (isLeft)+import           GHC.Exts+  (Char (C#), Double (D#), Float (F#), Int (I#), Word (W#))+import           GHC.Generics+import           GHC.Show            (appPrec)+import           GHC.Stack           (HasCallStack)+import           System.IO.Unsafe    (unsafeDupablePerformIO)++-- $setup+-- >>> import Clash.Prelude++-- | An exception representing an \"uninitialized\" value.+newtype XException = XException String++instance Show XException where+  show (XException s) = s++instance Exception XException++-- | Like 'shows', but values that normally throw an 'XException' are+-- converted to @undefined@, instead of error'ing out with an exception.+showsX :: ShowX a => a -> ShowS+showsX = showsPrecX 0++showListX__ :: (a -> ShowS) -> [a] -> ShowS+showListX__ showx = showXWith go+  where+    go []     s = "[]" ++ s+    go (x:xs) s = '[' : showx x (showl xs)+      where+        showl []     = ']':s+        showl (y:ys) = ',' : showx y (showl ys)++genericShowsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS+genericShowsPrecX n = gshowsPrecX Pref n . from++showXWith :: (a -> ShowS) -> a -> ShowS+showXWith f x =+  unsafeDupablePerformIO $+    catch+      (f <$> evaluate x)+      (\(XException _) -> return (showString "undefined"))++-- | Use when you want to create a 'ShowX' instance where:+--+-- - There is no 'Generic' instance for your data type+-- - The 'Generic' derived ShowX method would traverse into the (hidden)+--   implementation details of your data type, and you just want to show the+--   entire value as @undefined@.+--+-- Can be used like:+--+-- > data T = ...+-- >+-- > instance Show T where ...+-- >+-- > instance ShowX T where+-- >   showsPrecX = showsPrecXWith showsPrec+showsPrecXWith :: (Int -> a -> ShowS) -> Int -> a -> ShowS+showsPrecXWith f n = showXWith (f n)++class GShowX f where+  gshowsPrecX :: ShowType -> Int -> f a -> ShowS+  isNullary   :: f a -> Bool+  isNullary = error "generic showX (isNullary): unnecessary case"++data ShowType = Rec        -- Record+              | Tup        -- Tuple+              | Pref       -- Prefix+              | Inf String -- Infix++instance GShowX U1 where+  gshowsPrecX _ _ U1 = id+  isNullary _ = True++instance (ShowX c) => GShowX (K1 i c) where+  gshowsPrecX _ n (K1 a) = showsPrecX n a+  isNullary _ = False++instance (GShowX a, Constructor c) => GShowX (M1 C c a) where+  gshowsPrecX _ n c@(M1 x) =+    case fixity of+      Prefix ->+        showParen (n > appPrec && not (isNullary x))+          ( (if conIsTuple c then id else showString (conName c))+          . (if isNullary x || conIsTuple c then id else showString " ")+          . showBraces t (gshowsPrecX t appPrec x))+      Infix _ m -> showParen (n > m) (showBraces t (gshowsPrecX t m x))+      where fixity = conFixity c+            t = if conIsRecord c then Rec else+                  case conIsTuple c of+                    True -> Tup+                    False -> case fixity of+                                Prefix    -> Pref+                                Infix _ _ -> Inf (show (conName c))+            showBraces :: ShowType -> ShowS -> ShowS+            showBraces Rec     p = showChar '{' . p . showChar '}'+            showBraces Tup     p = showChar '(' . p . showChar ')'+            showBraces Pref    p = p+            showBraces (Inf _) p = p++            conIsTuple :: C1 c f p -> Bool+            conIsTuple y = tupleName (conName y) where+              tupleName ('(':',':_) = True+              tupleName _           = False++instance (Selector s, GShowX a) => GShowX (M1 S s a) where+  gshowsPrecX t n s@(M1 x) | selName s == "" =   gshowsPrecX t n x+                           | otherwise       =   showString (selName s)+                                               . showString " = "+                                               . gshowsPrecX t 0 x+  isNullary (M1 x) = isNullary x++instance (GShowX a) => GShowX (M1 D d a) where+  gshowsPrecX t = showsPrecXWith go+    where go n (M1 x) = gshowsPrecX t n x++instance (GShowX a, GShowX b) => GShowX (a :+: b) where+  gshowsPrecX t n (L1 x) = gshowsPrecX t n x+  gshowsPrecX t n (R1 x) = gshowsPrecX t n x++instance (GShowX a, GShowX b) => GShowX (a :*: b) where+  gshowsPrecX t@Rec     n (a :*: b) =+    gshowsPrecX t n     a . showString ", " . gshowsPrecX t n     b+  gshowsPrecX t@(Inf s) n (a :*: b) =+    gshowsPrecX t n     a . showString s    . gshowsPrecX t n     b+  gshowsPrecX t@Tup     n (a :*: b) =+    gshowsPrecX t n     a . showChar ','    . gshowsPrecX t n     b+  gshowsPrecX t@Pref    n (a :*: b) =+    gshowsPrecX t (n+1) a . showChar ' '    . gshowsPrecX t (n+1) b++  -- If we have a product then it is not a nullary constructor+  isNullary _ = False++-- Unboxed types+instance GShowX UChar where+  gshowsPrecX _ _ (UChar c)   = showsPrec 0 (C# c) . showChar '#'+instance GShowX UDouble where+  gshowsPrecX _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##"+instance GShowX UFloat where+  gshowsPrecX _ _ (UFloat f)  = showsPrec 0 (F# f) . showChar '#'+instance GShowX UInt where+  gshowsPrecX _ _ (UInt i)    = showsPrec 0 (I# i) . showChar '#'+instance GShowX UWord where+  gshowsPrecX _ _ (UWord w)   = showsPrec 0 (W# w) . showString "##"++-- | Hidden internal type-class. Adds a generic implementation for the \"NFData\"+-- part of 'NFDataX'+class GNFDataX arity f where+  grnfX :: RnfArgs arity a -> f a -> ()++instance GNFDataX arity V1 where+  grnfX _ x = case x of {}++data Zero+data One++data RnfArgs arity a where+  RnfArgs0 :: RnfArgs Zero a+  RnfArgs1  :: (a -> ()) -> RnfArgs One a++instance GNFDataX arity U1 where+  grnfX _ u = if isLeft (isX u) then () else case u of U1 -> ()++instance NFDataX a => GNFDataX arity (K1 i a) where+  grnfX _ = rnfX . unK1+  {-# INLINEABLE grnfX #-}++instance GNFDataX arity a => GNFDataX arity (M1 i c a) where+  grnfX args a =+    -- Check for X needed to handle edge-case "data Void"+    if isLeft (isX a) then+      ()+    else+      grnfX args (unM1 a)+  {-# INLINEABLE grnfX #-}++instance (GNFDataX arity a, GNFDataX arity b) => GNFDataX arity (a :*: b) where+  grnfX args xy@(~(x :*: y)) =+    if isLeft (isX xy) then+      ()+    else+      grnfX args x `seq` grnfX args y+  {-# INLINEABLE grnfX #-}++instance (GNFDataX arity a, GNFDataX arity b) => GNFDataX arity (a :+: b) where+  grnfX args lrx =+    if isLeft (isX lrx) then+      ()+    else+      case lrx of+        L1 x -> grnfX args x+        R1 x -> grnfX args x+  {-# INLINEABLE grnfX #-}++instance GNFDataX One Par1 where+  grnfX (RnfArgs1 r) = r . unPar1++instance NFDataX1 f => GNFDataX One (Rec1 f) where+  grnfX (RnfArgs1 r) = liftRnfX r . unRec1++instance (NFDataX1 f, GNFDataX One g) => GNFDataX One (f :.: g) where+  grnfX args = liftRnfX (grnfX args) . unComp1++class GEnsureSpine f where+  gEnsureSpine :: f a -> f a++instance GEnsureSpine U1 where+  gEnsureSpine _u = U1++instance NFDataX a => GEnsureSpine (K1 i a) where+  gEnsureSpine = K1 . ensureSpine . unK1+  {-# INLINEABLE gEnsureSpine #-}++instance GEnsureSpine a => GEnsureSpine (M1 i c a) where+  gEnsureSpine a = M1 (gEnsureSpine (unM1 a))+  {-# INLINEABLE gEnsureSpine #-}++instance (GEnsureSpine a, GEnsureSpine b) => GEnsureSpine (a :*: b) where+  gEnsureSpine ~(x :*: y) = gEnsureSpine x :*: gEnsureSpine y+  {-# INLINEABLE gEnsureSpine #-}++instance (GEnsureSpine a, GEnsureSpine b) => GEnsureSpine (a :+: b) where+  gEnsureSpine lrx =+    case lrx of+      (L1 x) -> L1 (gEnsureSpine x)+      (R1 x) -> R1 (gEnsureSpine x)+  {-# INLINEABLE gEnsureSpine #-}++instance GEnsureSpine V1 where+  gEnsureSpine _ = error "Unreachable code?"++-- | A class of functors that can be fully evaluated, according to semantics+-- of NFDataX.+class NFDataX1 f where+  -- | 'liftRnfX' should reduce its argument to normal form (that is, fully+  -- evaluate all sub-components), given an argument to reduce @a@ arguments,+  -- and then return @()@.+  --+  -- See 'rnfX' for the generic deriving.+  liftRnfX :: (a -> ()) -> f a -> ()++  default liftRnfX :: (Generic1 f, GNFDataX One (Rep1 f)) => (a -> ()) -> f a -> ()+  liftRnfX r = grnfX (RnfArgs1 r) . from1+++class GHasUndefined f where+  gHasUndefined :: f a -> Bool++instance GHasUndefined U1 where+  gHasUndefined u = if isLeft (isX u) then True else case u of U1 -> False++instance NFDataX a => GHasUndefined (K1 i a) where+  gHasUndefined = hasUndefined . unK1+  {-# INLINEABLE gHasUndefined #-}++instance GHasUndefined a => GHasUndefined (M1 i c a) where+  gHasUndefined a =+    -- Check for X needed to handle edge-case "data Void"+    if isLeft (isX a) then+      True+    else+      gHasUndefined (unM1 a)+  {-# INLINEABLE gHasUndefined #-}++instance (GHasUndefined a, GHasUndefined b) => GHasUndefined (a :*: b) where+  gHasUndefined xy@(~(x :*: y)) =+    if isLeft (isX xy) then+      True+    else+      gHasUndefined x || gHasUndefined y+  {-# INLINEABLE gHasUndefined #-}++instance (GHasUndefined a, GHasUndefined b) => GHasUndefined (a :+: b) where+  gHasUndefined lrx =+    if isLeft (isX lrx) then+      True+    else+      case lrx of+        L1 x -> gHasUndefined x+        R1 x -> gHasUndefined x+  {-# INLINEABLE gHasUndefined #-}++instance GHasUndefined V1 where+  gHasUndefined _ = error "Unreachable code?"++class GDeepErrorX f where+  gDeepErrorX :: HasCallStack => String -> f a++instance GDeepErrorX V1 where+  gDeepErrorX = errorX++instance GDeepErrorX U1 where+  gDeepErrorX = const U1++instance (GDeepErrorX a) => GDeepErrorX (M1 m d a) where+  gDeepErrorX e = M1 (gDeepErrorX e)++instance (GDeepErrorX f, GDeepErrorX g) => GDeepErrorX (f :*: g) where+  gDeepErrorX e = gDeepErrorX e :*: gDeepErrorX e++instance NFDataX c => GDeepErrorX (K1 i c) where+  gDeepErrorX e = K1 (deepErrorX e)++instance GDeepErrorX (f :+: g) where+  gDeepErrorX = errorX
+ src/Clash/XException/MaybeX.hs view
@@ -0,0 +1,152 @@+{-|+Copyright  :  (C) 2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Helpers to make 'Clash.XException.XException' explicit in the type system.+Using these helpers can help programmers account for 'Clash.XException.XException's+properly in blackbox models or tests. Note that none of these operations can be+translated to HDL.++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}++module Clash.XException.MaybeX+  ( MaybeX(IsX, IsDefined)++    -- * Construction+  , toMaybeX+  , hasXToMaybeX++    -- * Deconstruction+  , fromMaybeX++    -- * Operations+  , andX+  , orX+  , maybeX+  ) where++import Prelude++import Control.DeepSeq (NFData)+import Control.Exception (throw)++import Clash.XException (XException(..), NFDataX, isX, hasX)++-- | Structure helping programmers to deal with 'Clash.XException.XException'+-- values. For safety reasons it can't be constructed directly, but should be+-- constructed using either 'pure' or 'toMaybeX'. After construction, it can be+-- deconstructed using either 'IsX' or 'IsDefined'.+data MaybeX a+  = IsX_ String+  -- ^ Upon construction, @a@ evaluated to 'Clash.XException.XException'+  | IsDefined_ !a+  -- ^ Upon construction, @a@ evaluated to a non-bottom WHNF++instance Show a => Show (MaybeX a) where+  showsPrec d = \case+    IsX_ msg     -> showParen (d > 10) $ showString "IsX "       . showsPrec 11 msg+    IsDefined_ a -> showParen (d > 10) $ showString "IsDefined " . showsPrec 11 a++-- | Upon construction, @a@ evaluated to 'Clash.XException.XException'+pattern IsX :: forall a. String -> MaybeX a+pattern IsX msg <- IsX_ msg++-- | Upon construction, @a@ evaluated to a non-bottom WHNF+pattern IsDefined :: forall a. a -> MaybeX a+pattern IsDefined a <- IsDefined_ a+{-# COMPLETE IsX, IsDefined #-}++-- | Note that 'fmap' is X-strict in its argument. That is, if its input is 'IsX',+-- its output will be too.+instance Functor MaybeX where+  fmap _f (IsX_ msg) = IsX_ msg+  fmap f  (IsDefined_ a) = pure (f a)++-- | Note that '<*>' and 'liftA2' are X-strict in their arguments. That is, if+-- any of their inputs are 'IsX', their outputs will be too.+instance Applicative MaybeX where+  pure = either IsX_ IsDefined_ . isX++  liftA2 f (IsDefined_ a) (IsDefined_ b) = pure (f a b)+  liftA2 _ (IsX_ msg)     _              = IsX_ msg+  liftA2 _ _              (IsX_ msg)     = IsX_ msg++-- | Construct a 'MaybeX' value. If @a@ evaluates to 'Clash.XException.XException',+-- this function will return 'IsX'. Otherwise, it will return 'IsDefined'.+toMaybeX :: a -> MaybeX a+toMaybeX = pure++-- | Construct a 'MaybeX' value. If 'hasX' evaluates to 'Left', this function+-- will return 'IsX'. Otherwise, it will return 'IsDefined'.+hasXToMaybeX :: (NFDataX a, NFData a) => a -> MaybeX a+hasXToMaybeX = either IsX_ IsDefined_ . hasX++-- | Deconstruct 'MaybeX' into an @a@ - the opposite of 'toMaybeX'. Be careful+-- when using this function, because it might return an 'Clash.XException.XException'+-- if the argument was 'IsX'.+fromMaybeX :: MaybeX a -> a+fromMaybeX = maybeX (throw . XException) id++-- | Map functions over both constructors.+maybeX :: (String -> b) -> (a -> b) -> MaybeX a -> b+maybeX f _ (IsX_ msg)     = f msg+maybeX _ g (IsDefined_ a) = g a++-- | Implements '&&' accounting for X+--+-- +-------------------------+-------------------------+-------------------------+-------------------------++-- |                         | &#x2003;__@X@__&#x2003; | &#x2003;__@1@__&#x2003; | &#x2003;__@0@__&#x2003; |+-- +-------------------------+-------------------------+-------------------------+-------------------------++-- | &#x2003;__@X@__&#x2003; | &#x2003;@X@&#x2003;     | &#x2003;@X@&#x2003;     | &#x2003;@0@&#x2003;     |+-- +-------------------------+-------------------------+-------------------------+-------------------------++-- | &#x2003;__@1@__&#x2003; | &#x2003;@X@&#x2003;     | &#x2003;@1@&#x2003;     | &#x2003;@0@&#x2003;     |+-- +-------------------------+-------------------------+-------------------------+-------------------------++-- | &#x2003;__@0@__&#x2003; | &#x2003;@0@&#x2003;     | &#x2003;@0@&#x2003;     | &#x2003;@0@&#x2003;     |+-- +-------------------------+-------------------------+-------------------------+-------------------------+++-- (This is not part of the Haddock, a more readable version of the table+-- above)+--    | X | 1 | 0+-- ---|---|---|---+--  X | X | X | 0+--  1 | X | 1 | 0+--  0 | 0 | 0 | 0+andX :: MaybeX Bool -> MaybeX Bool -> MaybeX Bool+andX (IsDefined_ False) _                  = IsDefined_ False+andX _                  (IsDefined_ False) = IsDefined_ False+andX (IsDefined_ True)  (IsDefined_ True)  = IsDefined_ True+andX (IsX_ msg)         _                  = IsX_ msg+andX _                  (IsX_ msg)         = IsX_ msg+infixr 3 `andX`++-- | Implements '||' accounting for X+--+-- +-------------------------+-------------------------+-------------------------+-------------------------++-- |                         | &#x2003;__@X@__&#x2003; | &#x2003;__@1@__&#x2003; | &#x2003;__@0@__&#x2003; |+-- +-------------------------+-------------------------+-------------------------+-------------------------++-- | &#x2003;__@X@__&#x2003; | &#x2003;X&#x2003;       | &#x2003;1&#x2003;       | &#x2003;X&#x2003;       |+-- +-------------------------+-------------------------+-------------------------+-------------------------++-- | &#x2003;__@1@__&#x2003; | &#x2003;1&#x2003;       | &#x2003;1&#x2003;       | &#x2003;1&#x2003;       |+-- +-------------------------+-------------------------+-------------------------+-------------------------++-- | &#x2003;__@0@__&#x2003; | &#x2003;X&#x2003;       | &#x2003;1&#x2003;       | &#x2003;0&#x2003;       |+-- +-------------------------+-------------------------+-------------------------+-------------------------+++-- (This is not part of the Haddock, a more readable version of the table+-- above)+--    | X | 1 | 0+-- ---|---|---|---+--  X | X | 1 | X+--  1 | 1 | 1 | 1+--  0 | X | 1 | 0+orX :: MaybeX Bool -> MaybeX Bool -> MaybeX Bool+orX (IsDefined_ True)  _                  = IsDefined_ True+orX _                  (IsDefined_ True)  = IsDefined_ True+orX (IsDefined_ False) (IsDefined_ False) = IsDefined_ False+orX (IsX_ msg)         _                  = IsX_ msg+orX _                  (IsX_ msg)         = IsX_ msg+infixr 2 `orX`
+ src/Clash/XException/TH.hs view
@@ -0,0 +1,159 @@+{-|+Copyright  :  (C) 2019, Myrtle Software Ltd+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE TemplateHaskellQuotes #-}++module Clash.XException.TH+  ( mkShowXTupleInstances+  , mkNFDataXTupleInstances+  , mkShowXTupleInstance+  ) where++import Data.Either (isLeft)+import Data.List (intersperse)+import Language.Haskell.TH.Compat+import Language.Haskell.TH.Syntax++-- Spliced in in XException, so these names should be in scope:+isXName, hasUndefinedName, deepErrorXName, rnfXName, ensureSpineName :: Name+isXName = mkName "isX"+hasUndefinedName = mkName "hasUndefined"+deepErrorXName = mkName "deepErrorX"+rnfXName = mkName "rnfX"+ensureSpineName = mkName "ensureSpine"++showxName :: Name+showxName = mkName "ShowX"++showXFnName :: Name+showXFnName = mkName "showX"++showsPrecXName :: Name+showsPrecXName = mkName "showsPrecX"++nfdataxName :: Name+nfdataxName = mkName "NFDataX"++mkTup :: [Type] -> Type+mkTup names@(length -> n) =+  foldl AppT (TupleT n) names++-- | Creates an instance of the form:+--+--  instance (ShowX a0, ShowX a1) => ShowX (a0, a1)+--+-- With /n/ number of variables.+mkShowXTupleInstance :: Int -> Dec+mkShowXTupleInstance n =+  InstanceD Nothing constraints instanceTyp [showsPrecXDecl, showXDecl]+ where+  constraints = fmap (AppT (ConT showxName)) vars+  instanceTyp = ConT showxName `AppT` mkTup vars+  names = fmap (mkName . ('a':) . show) [0..n-1]+  vars = fmap VarT names++  x = mkName "x"+  s = mkName "s"++  showsPrecXDecl = FunD showsPrecXName+    [ Clause+        [WildP, VarP x, VarP s]+        (NormalB+          (VarE 'mappend `AppE` (VarE showXFnName `AppE` VarE x) `AppE` VarE s))+        []+    ]++  showXDecl = FunD showXFnName+    [ Clause+        [TupP (fmap VarP names)]+        (NormalB+          (VarE 'mconcat `AppE` (ListE+            ([LitE (StringL "(")]+               <> intersperse (LitE (StringL ",")) (fmap toShowX names)+               <> [LitE (StringL ")")]))))+        []+    ]+   where+    toShowX a = VarE showXFnName `AppE` VarE a++-- | Creates instances of ShowX for all tuple sizes listed.+-- See 'mkShowXTupleInstance' for more information.+mkShowXTupleInstances :: [Int] -> Q [Dec]+mkShowXTupleInstances tupSizes =+  return (fmap mkShowXTupleInstance tupSizes)++-- | Creates an instance of the form:+--+--  instance (NFDataX a0, NFDataX a1) => NFDataX (a0, a1)+--+-- With /n/ number of variables.+mkNFDataXTupleInstance :: Int -> Dec+mkNFDataXTupleInstance n =+  InstanceD+    Nothing+    constraints+    instanceTyp+    [ ensureSpineDecl+    , hasUndefinedDecl+    , deepErrorXDecl+    , rnfXDecl+    ]+ where+  constraints = map (AppT (ConT nfdataxName)) vars+  instanceTyp = ConT nfdataxName `AppT` mkTup vars+  names = map (mkName . ('a':) . show) [0..n-1]+  vars = map VarT names++  t = mkName "t"+  s = mkName "s"++  rnfXDecl = FunD rnfXName [+    Clause+      [AsP t (TildeP (TupP (map VarP names)))]+      (NormalB (+        CondE+          (VarE 'isLeft `AppE` (VarE isXName `AppE` VarE t))+          (TupE [])+          (case names of+            (nm:nms) -> foldl+              (\e1 e2 -> UInfixE e1 (VarE 'seq) (VarE rnfXName `AppE` e2))+              (VarE rnfXName `AppE` VarE nm)+              (map VarE nms)+            [] -> error ("mkNFDataXTupleInstance, n must be atleast 1: " <> show n))+      ))+      []+    ]++  hasUndefinedDecl = FunD hasUndefinedName [+    Clause+      [AsP t (TildeP (TupP (map VarP names)))]+      (NormalB (+        CondE+          (VarE 'isLeft `AppE` (VarE isXName `AppE` VarE t))+          (ConE 'True)+          (VarE 'or `AppE` ListE+            (map ((VarE hasUndefinedName `AppE`) . VarE) names))+      ))+      []+    ]++  ensureSpineDecl = FunD ensureSpineName  [+    Clause+      [TildeP (TupP (map VarP names))]+      (NormalB (mkTupE (map (AppE (VarE ensureSpineName) . VarE) names)))+      []+    ]++  deepErrorXDecl = FunD deepErrorXName [+     Clause+       [VarP s]+       (NormalB (mkTupE (replicate n (VarE deepErrorXName `AppE` VarE s))))+       []+     ]++mkNFDataXTupleInstances :: [Int] -> Q [Dec]+mkNFDataXTupleInstances tupSizes =+  pure (map mkNFDataXTupleInstance tupSizes)
src/Clash/Xilinx/ClockGen.hs view
@@ -1,103 +1,393 @@ {-|-Copyright  :  (C) 2017, Google Inc+Copyright  :  (C) 2017, Google Inc,+                  2023, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -PLL and other clock-related components for Xilinx FPGAs+This module contains functions for instantiating clock generators on Xilinx+FPGA's.++We suggest you use a clock generator even if your oscillator runs at the+frequency you want to run your circuit at.++A clock generator generates a stable clock signal for your design at a+configurable frequency. A clock generator in an FPGA is frequently referred to+as a PLL (Phase-Locked Loop). However, Xilinx differentiates between several+types of clock generator implementations in their FPGAs and uses the term PLL to+refer to one specific type, so we choose to use the more generic term /clock/+/generator/ here.++For most use cases, you would create two or more synthesis domains describing+the oscillator input and the domains you wish to use in your design, and use+the [regular functions](#g:regular) below to generate the clocks and resets of+the design from the oscillator input. There are use cases not covered by this+simpler approach, and the [unsafe functions](#g:unsafe) are provided as a means+to build advanced reset managers for the output domains. -} -{-# LANGUAGE BangPatterns     #-}-{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ExplicitForAll   #-}-{-# LANGUAGE GADTs            #-}-module Clash.Xilinx.ClockGen where+{-# LANGUAGE GADTs #-} -import Clash.Annotations.Primitive    (hasBlackBox)-import Clash.Promoted.Symbol+module Clash.Xilinx.ClockGen+  ( -- * Choosing domains+    -- $domains++    -- ** Caution: actual output frequency+    -- $caution++    -- * Using+    -- $using++    -- ** Example+    -- $example++    -- ** Type checking errors+    -- $error++    -- ** Tcl+    -- $tcl++    -- * Regular functions #regular#+    clockWizard+  , clockWizardDifferential+    -- * Unsafe functions #unsafe#+    -- $unsafe++    -- ** Example+    -- $unsafe_example+  , unsafeClockWizard+  , unsafeClockWizardDifferential+  ) where++import GHC.TypeLits (type (<=))++import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Clocks+  (Clocks(..), ClocksSync(..), ClocksSyncCxt, NumOutClocksSync) import Clash.Signal.Internal-import Unsafe.Coerce+  (Clock, DiffClock(..), Reset, KnownDomain, HasAsynchronousReset) --- | A clock source that corresponds to the Xilinx PLL/MMCM component created--- with the \"Clock Wizard\" with settings to provide a stable 'Clock' from--- a single free-running input------ Only works when configured with:------ * 1 reference clock--- * 1 output clock--- * a reset port--- * a locked port------ You must use type applications to specify the output clock domain, e.g.:------ @--- type Dom100MHz = Dom \"A\" 10000+{- $domains+Synthesis domains are denoted by the type-parameter+@dom :: t'Clash.Signal.Domain'@ as occurring in for instance+@t'Clash.Signal.Signal' dom a@; see "Clash.Signal" for more information. For+each domain, there is only a single clock signal which clocks that domain;+mixing clock signals is a design error. Conversely, it is possible to clock+multiple domains using the same clock signal, in complex designs.++For the clock generator inputs, create a domain with the correct clock frequency+and reset polarity. For instance, if the clock input is a free-running clock at+a frequency of 50 MHz (a period of 20 ns or 20,000 ps), and the reset input+connected to the clock generator is /active-low/, the following will instantiate+the required input domain:++@+'Clash.Signal.createDomain' 'Clash.Signal.vSystem'{vName=\"DomInput\", vPeriod=20000, vResetPolarity='Clash.Signal.ActiveLow'}+@++If you haven't determined the frequency you want the design to run at, the+predefined 100 MHz domain t'Clash.Signal.XilinxSystem' can be a good starting+point. The datasheet for your FPGA specifies lower and upper limits, but the+true maximum frequency is determined by your design.++Supposing you need a clock running at 150 MHz for your design, the following+will instantiate a suitable domain:++@+'Clash.Signal.createDomain' 'Clash.Signal.vXilinxSystem'{vName=\"Dom150\", vPeriod='Clash.Signal.hzToPeriod' 150e6}+@++@Dom150@ will have 'Clash.Signal.Synchronous' resets on its memory elements+because it was derived from 'Clash.Signal.vXilinxSystem', whereas @DomInput@+will have 'Clash.Signal.Asynchronous' resets because it was derived from+'Clash.Signal.vSystem'. Xilinx recommends synchronous resets for circuits, but+the clock generator reacts asynchronously to its reset input instead, which will+need to be declared correctly in Clash. If you use the /unsafe/ functions below,+Clash does not enforce this.+-}++{- $caution+The clock generator in the FPGA is limited in which clock frequencies it can+generate, especially when one clock generator has multiple outputs. The clock+generator will pick the attainable frequency closest to the requested frequency+(or possibly fail to synthesize). You can check the frequency that the wizard+chose by loading your design into the Vivado GUI. In the /IP sources/ window,+choose the clock wizard and select /Re-customize IP.../. On the /Output Clocks/+tab, the relevant column is /Actual Output Freq (MHz)/. If the actual value+differs, copy the actual value back to the Clash design.+-}++{- $using+The functions in this module will instantiate a Xilinx MMCM clock generator+corresponding to the Xilinx \"Clock Wizard\" with 1 reference clock input and a+reset input, and 1 to 7 output clocks and a @locked@ output.++The [regular functions](#g:regular) incorporate 'Clash.Signal.resetSynchronizer'+to convert the @locked@ output port into a proper 'Reset' signal for the domains+which will keep the circuit in reset while the clock is still stabilizing.++The clock generator will react asynchronously to the incoming reset input. When+the reset input is asserted, the clock generator's @locked@ output will+deassert, in turn causing the 'Reset' output(s) of these functions to assert.++You can use 'Clash.Magic.setName' to give the IP instance a specific name, which+can be useful if you need to refer to the instance in Synopsys Design+Constraints files.++The output of the function for /n/ output clocks is a /2n/-tuple with clock and+reset outputs. The compiler needs to be able to fully determine the types of the+individual tuple elements from the context; the clock generator function itself+will not constrain them. If the types of the tuple elements cannot be inferred,+you can use pattern type signatures to specify the types. Supposing the+referenced domains have been created with 'Clash.Signal.createDomain', an+instance with a single output clock can be instantiated using:++@+(clk150 :: 'Clock' Dom150, rst150 :: 'Reset' Dom150) = 'clockWizard' clkIn rstIn+@++An instance with two clocks can be instantiated using++@+( clk100 :: 'Clock' Dom100+  , rst100 :: 'Reset' Dom100+  , clk150 :: 'Clock' Dom150+  , rst150 :: 'Reset' Dom150) = 'clockWizard' clkIn rstIn+@++and so on up to 7 clocks, following the general pattern @('Clock' dom1, 'Reset'+dom1, 'Clock' dom2, 'Reset' dom2, ..., 'Clock' dom/n/, 'Reset' dom/n/)@.++If you need access to the @locked@ output to build a more advanced reset+manager, you should use the [unsafe functions](#g:unsafe) instead.++See also the [Clocking Wizard LogiCORE IP Product Guide](https://docs.xilinx.com/r/en-US/pg065-clk-wiz)+-}++{- $example++When the oscillator connected to the FPGA runs at 50 MHz and the external reset+signal is /active-low/, this will generate a 150 MHz clock for use by the+circuit:++@+'Clash.Signal.createDomain' 'Clash.Signal.vSystem'{vName=\"DomInput\", vPeriod=20000, vResetPolarity='Clash.Signal.ActiveLow'}+'Clash.Signal.createDomain' 'Clash.Signal.vXilinxSystem'{vName=\"Dom150\", vPeriod='Clash.Signal.hzToPeriod' 150e6}++topEntity+  :: 'Clock' DomInput+  -> 'Reset' DomInput+  -> t'Clash.Signal.Signal' Dom150 Int+  -> t'Clash.Signal.Signal' Dom150 Int+topEntity clkIn rstIn = 'Clash.Signal.exposeClockResetEnable' (register 0) clk rst 'Clash.Signal.enableGen'+ where+  (clk, rst) = 'clockWizard' clkIn rstIn+@+-}++{- $error+When type checking cannot infer the types of the tuple elements, or they have+the wrong type, the GHC compiler will complain about satisfying @NumOutClocks@.+The error message on GHC 9.4 and up is:++>     • Cannot satisfy: clash-prelude-[...]:Clash.Clocks.Internal.NumOutClocks+>                         (clash-prelude-[...]:Clash.Clocks.Internal.ClocksSyncClocksInst+>                            ([...])+>                            DomInput) <= 7+>     • In the expression: clockWizard clkIn rstIn++On older GHC versions, the error message is:++>     • Couldn't match type ‘clash-prelude-[...]:Clash.Clocks.Internal.NumOutClocks+>                              (clash-prelude-[...]:Clash.Clocks.Internal.ClocksSyncClocksInst+>                                 ([...])+>                                 DomInput)+>                            <=? 7’+>                      with ‘'True’+>         arising from a use of ‘clockWizard’+>     • In the expression: clockWizard clkIn rstIn++The above error message is also emitted when trying to instantiate more than 18+output clocks, as it will fail to find an instance. As the wizard supports no+more than 7 clocks, trying to instantiate between 8 and 18 output clocks will+also cause a type checking error. On GHC 9.4 and up, the error for attempting to+instantiate 8 clocks is:++>     • Cannot satisfy: 8 <= 7+>     • In the expression: clockWizard clkIn rstIn++On older GHC versions, the error message is less clear:++>     • Couldn't match type ‘'False’ with ‘'True’+>         arising from a use of ‘clockWizard’+>     • In the expression: clockWizard clkIn rstIn+-}++{- $tcl+When generating HDL, these functions will emit a Tcl script for Vivado that+instantiates the needed IP core for the function. This Tcl script adheres to the+Clash\<-\>Tcl API. The Tcl Connector bundled in @clash-lib:Clash.DataFiles@ will+automatically process these scripts and build your design in Vivado. See+@clash-lib:Clash.DataFiles@ for more information.+-}++{- $unsafe+These functions are provided for the cases where the [regular+functions](#g:regular) cannot provide the desired behavior, like when+implementing certain advanced reset managers. These functions directly expose+the /asynchronous/ @locked@ output of the clock generator, which will assert+when the output clocks are stable. @locked@ is usually connected to reset+circuitry to keep the circuit in reset while the clock is still stabilizing.++The output of the function for /n/ output clocks is an /n+1/-tuple with /n/+clock outputs and a @locked@ signal. The compiler needs to be able to fully+determine the types of the individual tuple elements from the context; the clock+generator function itself will not constrain them. If the types of the tuple+elements cannot be inferred, you can use pattern type signatures to specify the+types. Supposing the referenced domains have been created with+'Clash.Signal.createDomain', an instance with a single output clock can be+instantiated using:++@+(clk150 :: 'Clock' Dom150, locked :: t'Clash.Signal.Signal' Dom150 'Bool') = 'unsafeClockWizard' clkIn rstIn+@++An instance with two clocks can be instantiated using++@+(clk100 :: 'Clock' Dom100+  , clk150 :: 'Clock' Dom150+  , locked :: t'Clash.Signal.Signal' Dom100 'Bool') = 'unsafeClockWizard' clkIn rstIn+@++and so on up to 7 clocks, following the general pattern @('Clock' dom1, 'Clock'+dom2, ..., 'Clock' dom/n/, t'Clash.Signal.Signal' pllLock Bool)@.++Though the @locked@ output is specified as a @t'Clash.Signal.Signal' pllLock+'Bool'@, it is an asynchronous signal and will need to be synchronized before it+can be used as a (reset) signal. While in the examples above the+@locked@ output has been assigned the domain of one of the output clocks, the+domain @pllLock@ is left unrestricted. If the lock signal is to be used in+multiple domains, the @pllLock@ domain should probably be set to @domIn@ (the+domain of the input clock and reset). While in HDL+'Clash.Explicit.Signal.unsafeSynchronizer' is just a wire, in Haskell simulation+it does actually resample the signal, and by setting @pllLock@ to @domIn@, there+is no resampling of the simulated lock signal. The simulated lock signal is+simply the inverse of the reset input: @locked@ is asserted whenever the reset+input is deasserted and vice versa.+-}++{- $unsafe_example+@+'Clash.Signal.createDomain' 'Clash.Signal.vSystem'{vName=\"DomInput\", vPeriod=20000, vResetPolarity='Clash.Signal.ActiveLow'}+'Clash.Signal.createDomain' 'Clash.Signal.vXilinxSystem'{vName=\"Dom150\", vPeriod='Clash.Signal.hzToPeriod' 150e6}++topEntity+  :: 'Clock' DomInput+  -> 'Reset' DomInput+  -> t'Clash.Signal.Signal' Dom150 Int+  -> t'Clash.Signal.Signal' Dom150 Int+topEntity clkIn rstIn = 'Clash.Signal.exposeClockResetEnable' (register 0) clk rst 'Clash.Signal.enableGen'+ where+  (clk, locked) = 'unsafeClockWizard' clkIn rstIn+  rst = 'Clash.Signal.resetSynchronizer' clk ('Clash.Signal.unsafeFromActiveLow' locked)+@++'Clash.Signal.resetSynchronizer' will keep the reset asserted when @locked@ is+'False', hence the use of @'Clash.Signal.unsafeFromActiveLow' locked@.+-}++-- | Instantiate a Xilinx MMCM clock generator corresponding to the Xilinx+-- \"Clock Wizard\" with 1 single-ended reference clock input and a reset input,+-- and 1 to 7 output clocks and a @locked@ output. ----- -- outputs a clock running at 100 MHz--- clockWizard @@Dom100MHz (SSymbol @@"clkWizard50to100") clk50 rst--- @-clockWizard-  :: forall domIn domOut periodIn periodOut edge init polarity name-   . ( KnownConfiguration domIn  ('DomainConfiguration domIn periodIn edge 'Asynchronous init polarity)-     , KnownConfiguration domOut ('DomainConfiguration domOut periodOut edge 'Asynchronous init polarity) )-  => SSymbol name-  -- ^ Name of the component, must correspond to the name entered in the-  -- \"Clock Wizard\" dialog.-  ---  -- For example, when you entered \"clockWizard50\", instantiate as follows:-  ---  -- > SSymbol @ "clockWizard50"-  -> Clock domIn-  -- ^ Free running clock (i.e. a clock pin connected to a crystal)-  -> Reset domIn-  -- ^ Reset for the PLL-  -> (Clock domOut, Enable domOut)-  -- ^ (Stable PLL clock, PLL lock)-clockWizard !_ clk rst =-  (unsafeCoerce clk, unsafeCoerce (toEnable (unsafeToHighPolarity rst)))-{-# NOINLINE clockWizard #-}-{-# ANN clockWizard hasBlackBox #-}+-- This function incorporates 'Clash.Signal.resetSynchronizer's to convert the+-- @locked@ output port into proper 'Reset' signals for the output domains which+-- will keep the circuit in reset while the clock is still stabilizing.+clockWizard ::+  forall t domIn .+  ( HasAsynchronousReset domIn+  , ClocksSyncCxt t domIn+  , NumOutClocksSync t domIn <= 7+  ) =>+  -- | Free running clock (e.g. a clock pin connected to a crystal oscillator)+  Clock domIn ->+  -- | Reset for the clock generator+  Reset domIn ->+  t+clockWizard clkIn rstIn =+  clocksResetSynchronizer (unsafeClockWizard clkIn rstIn) clkIn --- | A clock source that corresponds to the Xilinx PLL/MMCM component created--- with the \"Clock Wizard\", with settings to provide a stable 'Clock'--- from differential free-running inputs.+-- | Instantiate a Xilinx MMCM clock generator corresponding to the Xilinx+-- \"Clock Wizard\" with 1 single-ended reference clock input and a reset input,+-- and 1 to 7 output clocks and a @locked@ output. ----- Only works when configured with:+-- __NB__: Because the clock generator reacts asynchronously to the incoming+-- reset input, the signal __must__ be glitch-free.+unsafeClockWizard ::+  forall t domIn .+  ( KnownDomain domIn+  , Clocks t+  , ClocksCxt t+  , NumOutClocks t <= 7+  ) =>+  -- | Free running clock (e.g. a clock pin connected to a crystal oscillator)+  Clock domIn ->+  -- | Reset for the clock generator+  Reset domIn ->+  t+unsafeClockWizard = clocks+{-# OPAQUE unsafeClockWizard #-}+{-# ANN unsafeClockWizard hasBlackBox #-}++-- | Instantiate a Xilinx MMCM clock generator corresponding to the Xilinx+-- \"Clock Wizard\" with 1 differential reference clock input and a reset input,+-- and 1 to 7 output clocks and a @locked@ output. ----- * 1 differential reference pair--- * 1 output clock--- * a reset port--- * a locked port+-- This function incorporates 'Clash.Signal.resetSynchronizer's to convert the+-- @locked@ output port into proper 'Reset' signals for the output domains which+-- will keep the circuit in reset while the clock is still stabilizing. ----- You must use type applications to specify the output clock domain, e.g.:+-- To create a differential clock in a test bench, you can use+-- 'Clash.Explicit.Testbench.clockToDiffClock'.+clockWizardDifferential ::+  forall t domIn .+  ( HasAsynchronousReset domIn+  , ClocksSyncCxt t domIn+  , NumOutClocksSync t domIn <= 7+  ) =>+  -- | Free running clock (e.g. a clock pin pair connected to a crystal+  -- oscillator)+  DiffClock domIn ->+  -- | Reset for the clock generator+  Reset domIn ->+  t+clockWizardDifferential clkIn@(DiffClock clkInP _) rstIn =+  clocksResetSynchronizer (unsafeClockWizardDifferential clkIn rstIn) clkInP++-- | Instantiate a Xilinx MMCM clock generator corresponding to the Xilinx+-- \"Clock Wizard\" with 1 differential reference clock input and a reset input,+-- and 1 to 7 output clocks and a @locked@ output. ----- @--- type Dom100MHz = Dom \"A\" 10000+-- __NB__: Because the clock generator reacts asynchronously to the incoming+-- reset input, the signal __must__ be glitch-free. ----- -- outputs a clock running at 100 MHz--- clockWizardDifferential @@Dom100MHz (SSymbol @@"clkWizardD50to100") clk50N clk50P rst--- @-clockWizardDifferential-  :: forall domIn domOut periodIn periodOut edge init polarity name-   . ( KnownConfiguration domIn ('DomainConfiguration domIn periodIn edge 'Asynchronous init polarity)-     , KnownConfiguration domOut ('DomainConfiguration domOut periodOut edge 'Asynchronous init polarity) )-  => SSymbol name-  -- ^ Name of the component, must correspond to the name entered in the-  -- \"Clock Wizard\" dialog.-  ---  -- For example, when you entered \"clockWizardD50\", instantiate as follows:-  ---  -- > SSymbol @ "clockWizardD50"-  -> Clock domIn-  -- ^ Free running clock, negative phase-  -> Clock domIn-  -- ^ Free running clock, positive phase-  -> Reset domIn-  -- ^ Reset for the PLL-  -> (Clock domOut, Enable domOut)-  -- ^ (Stable PLL clock, PLL lock)-clockWizardDifferential !_name (Clock _) (Clock _) rst =-  (Clock SSymbol, unsafeCoerce (toEnable (unsafeToHighPolarity rst)))-{-# NOINLINE clockWizardDifferential #-}-{-# ANN clockWizardDifferential hasBlackBox #-}+-- To create a differential clock in a test bench, you can use+-- 'Clash.Explicit.Testbench.clockToDiffClock'.+unsafeClockWizardDifferential ::+  forall t domIn .+  ( KnownDomain domIn+  , Clocks t+  , ClocksCxt t+  , NumOutClocks t <= 7+  ) =>+  -- | Free running clock (e.g. a clock pin pair connected to a crystal+  -- oscillator)+  DiffClock domIn ->+  -- | Reset for the clock generator+  Reset domIn ->+  t+unsafeClockWizardDifferential (DiffClock clk _) = clocks clk+{-# OPAQUE unsafeClockWizardDifferential #-}+{-# ANN unsafeClockWizardDifferential hasBlackBox #-}
src/Clash/Xilinx/DDR.hs view
@@ -10,26 +10,24 @@ For more information about the Xilinx DDR primitives see:  * Vivado Design Suite 7 Series FPGA and Zynq-7000 All Programmable SoC-  Libraries Guide, UG953 (v2018.3) December 5, 2018, p371-373,p481-483,-  <https://www.xilinx.com/support/documentation/sw_manuals/xilinx2018_3/ug953-vivado-7series-libraries.pdf>+  Libraries Guide, UG953 (v2022.2) October 19, 2022, p369-371, p477-479,+  <https://www.xilinx.com/content/dam/xilinx/support/documents/sw_manuals/xilinx2022_2/ug953-vivado-7series-libraries.pdf> -} -{-# LANGUAGE CPP              #-}-{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash        #-}-{-# LANGUAGE TypeFamilies     #-}-{-# LANGUAGE TypeOperators    #-}-#if __GLASGOW_HASKELL__ >= 806-{-# LANGUAGE NoStarIsType #-}-#endif+{-# LANGUAGE TypeFamilies #-}  module Clash.Xilinx.DDR   ( iddr   , oddr+    -- * Internal+  , iddr#+  , oddr#   ) where +import Data.Bifunctor import GHC.Stack (HasCallStack, withFrozenCallStack)  import Clash.Annotations.Primitive (hasBlackBox)@@ -40,55 +38,91 @@ -- primitive in @SAME_EDGE@ mode. -- -- Reset values are @0@+--+-- Of the output pair @(o0, o1)@, @o0@ is the data clocked in on the /falling/+-- edge and @o1@ is the data clocked in on the /rising/ edge, and @o0@ comes+-- before @o1@ in time.+--+-- __NB__: This primitive only supports rising edges as the active edge. iddr-  :: ( HasCallStack-     , KnownConfiguration fast ('DomainConfiguration fast fPeriod edge reset init polarity)-     , KnownConfiguration slow ('DomainConfiguration slow (2*fPeriod) edge reset init polarity)-     , KnownNat m )-  => Clock slow-  -- ^ clock-  -> Reset slow-  -- ^ reset-  -> Enable slow-  -- ^ global enable-  -> Signal fast (BitVector m)+  :: forall a dom domDDR+   . HasCallStack+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => DomainActiveEdge dom ~ 'Rising+  => BitPack a+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> Signal domDDR a   -- ^ DDR input signal-  -> Signal slow ((BitVector m),(BitVector m))-  -- ^ normal speed output pairs-iddr clk rst en = withFrozenCallStack ddrIn# clk rst en 0 0 0-{-# NOINLINE iddr #-}-{-# ANN iddr hasBlackBox #-}+  -> Signal dom (a, a)+  -- ^ Normal speed output pair @(o0, o1)@+iddr clk rst en =+  fmap (bimap unpack unpack) . withFrozenCallStack (iddr# clk rst en) .+    fmap pack +iddr#+  :: forall n dom domDDR+   . HasCallStack+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => DomainActiveEdge dom ~ 'Rising+  => KnownNat n+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> Signal domDDR (BitVector n)+  -> Signal dom (BitVector n, BitVector n)+iddr# clk rst en = withFrozenCallStack ddrIn# clk rst en 0 0 0+{-# OPAQUE iddr# #-}+{-# ANN iddr# hasBlackBox #-}+ -- | Xilinx specific variant of 'ddrOut' implemented using the Xilinx ODDR -- primitive in @SAME_EDGE@ mode. -- -- Reset value is @0@+--+-- Of the input pair @(i0, i1)@, @i0@ is the data clocked out on the /rising/+-- edge and @i1@ is the data clocked out on the /falling/ edge, and @i0@ comes+-- before @i1@ in time.+--+-- __NB__: This primitive only supports rising edges as the active edge. oddr-  :: ( KnownConfiguration fast ('DomainConfiguration fast fPeriod edge reset init polarity)-     , KnownConfiguration slow ('DomainConfiguration slow (2*fPeriod) edge reset init polarity)-     , KnownNat m )-  => Clock slow-  -- ^ clock-  -> Reset slow-  -- ^ reset-  -> Enable slow-  -- ^ global enable-  -> Signal slow (BitVector m, BitVector m)-  -- ^ normal speed input pairs-  -> Signal fast (BitVector m)+  :: forall a dom domDDR+   . HasCallStack+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => DomainActiveEdge dom ~ 'Rising+  => BitPack a+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> Signal dom (a, a)+  -- ^ Normal speed input pair @(i0, i1)@+  -> Signal domDDR a   -- ^ DDR output signal-oddr clk rst en = uncurry (withFrozenCallStack oddr# clk rst en) . unbundle+oddr clk rst en =+  fmap unpack . uncurry (withFrozenCallStack oddr# clk rst en) . unbundle .+    fmap (bimap pack pack)  oddr#-  :: ( KnownConfiguration fast ('DomainConfiguration fast fPeriod edge reset init polarity)-     , KnownConfiguration slow ('DomainConfiguration slow (2*fPeriod) edge reset init polarity)-     , KnownNat m )-  => Clock slow-  -> Reset slow-  -> Enable slow-  -> Signal slow (BitVector m)-  -> Signal slow (BitVector m)-  -> Signal fast (BitVector m)+  :: forall n dom domDDR+   . HasCallStack+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => DomainActiveEdge dom ~ 'Rising+  => KnownNat n+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> Signal dom (BitVector n)+  -> Signal dom (BitVector n)+  -> Signal domDDR (BitVector n) oddr# clk rst en = ddrOut# clk rst en 0-{-# NOINLINE oddr# #-}+{-# OPAQUE oddr# #-} {-# ANN oddr# hasBlackBox #-}
src/Language/Haskell/TH/Compat.hs view
@@ -1,16 +1,19 @@ {-# LANGUAGE CPP #-}+ module Language.Haskell.TH.Compat where-import           Language.Haskell.TH+import           Language.Haskell.TH.Syntax  -- | Compatibility helper to create TySynInstD mkTySynInstD :: Name -> [Type] -> Type -> Dec mkTySynInstD tyConNm tyArgs rhs =-#if MIN_VERSION_template_haskell(2,15,0)         TySynInstD (TySynEqn Nothing                      (foldl AppT (ConT tyConNm) tyArgs)                      rhs)-#else-        TySynInstD tyConNm-                   (TySynEqn tyArgs-                             rhs)-#endif++-- | Compatibility helper to create (total) tuple expressions+mkTupE :: [Exp] -> Exp+mkTupE = TupE+         . map Just++liftTypedFromUntyped :: (Lift a, Quote m) => a -> Code m a+liftTypedFromUntyped = unsafeCodeCoerce . lift
+ tests/Clash/Tests/AsyncFIFOSynchronizer.hs view
@@ -0,0 +1,1155 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Clash.Tests.AsyncFIFOSynchronizer (tests) where++import Data.Maybe (isJust, catMaybes)+import qualified Prelude as P++import Hedgehog as H+import qualified Hedgehog.Range as Range+import qualified Hedgehog.Gen as Gen+import Test.Tasty+import Test.Tasty.Hedgehog.Extra+import Test.Tasty.HUnit++import Clash.Explicit.Prelude++createDomain vSystem{vName = "Slow", vPeriod = 2 * vPeriod vSystem}++sync12RW+  :: ( KnownDomain dom1+     , KnownDomain dom2+     )+  => Int+  -> Int+  -> Int+  -> ( Signal dom1 (Bool, (Int, Bool))+     , Signal dom2 (Maybe Int, Bool)+     )+sync12RW w1 w2 w3 =+  ( bundle (inputRInc, bundle (rdata, rempty))+  , bundle (inputWDataM, wfull)+  )+ where+  (rdata, rempty, wfull) =+    asyncFIFOSynchronizer d4 clockGen clockGen resetGen resetGen enableGen+      enableGen inputRInc inputWDataM+  inputRInc = fromList $ P.replicate w1 False <> P.replicate 4 True <>+                P.replicate w2 False <> P.replicate 4 True <> P.repeat False+  inputWDataM = fromList $ Nothing : P.map Just [1 .. 4] <>+                  P.replicate w3 Nothing <> P.map Just [5 .. 8] <>+                  P.repeat Nothing++-- Test n.1:+--  - Write 4+--  - Empty as soon as we can stream all in a row+--  - Stay empty for a moment+--  - Write another 4+--  - Empty as soon as we can stream all in a row++sync1R1 :: Signal Slow (Bool, (Int, Bool))+sync1W1 :: Signal System (Maybe Int, Bool)+(sync1R1, sync1W1) = sync12RW 4 2 7++sync2R1 :: Signal System (Bool, (Int, Bool))+sync2W1 :: Signal Slow (Maybe Int, Bool)+(sync2R1, sync2W1) = sync12RW 9 6 1++-- Test n.2:+--  - Write 4+--  - Don't start immediately, but then empty all in a row+--  - Stay empty for a moment+--  - Write another 4+--  - Empty as soon as we can stream all in a row++sync1R2 :: Signal Slow (Bool, (Int, Bool))+sync1W2 :: Signal System (Maybe Int, Bool)+(sync1R2, sync1W2) = sync12RW 5 2 8++sync2R2 :: Signal System (Bool, (Int, Bool))+sync2W2 :: Signal Slow (Maybe Int, Bool)+(sync2R2, sync2W2) = sync12RW 10 10 1++-- Test n.3:+--  - Write 4+--  - Empty as soon as we can stream all in a row+--  - Stay empty for a moment+--  - Write another 4+--  - Don't start immediately, but then empty all in a row++sync1R3 :: Signal Slow (Bool, (Int, Bool))+sync1W3 :: Signal System (Maybe Int, Bool)+(sync1R3, sync1W3) = sync12RW 4 4 7++sync2R3 :: Signal System (Bool, (Int, Bool))+sync2W3 :: Signal Slow (Maybe Int, Bool)+(sync2R3, sync2W3) = sync12RW 9 8 1++-- Test n.4:+--  - Write 4+--  - Don't start immediately, but then empty all in a row+--  - Stay empty for a moment+--  - Write another 4+--  - Don't start immediately, but then empty all in a row++sync1R4 :: Signal Slow (Bool, (Int, Bool))+sync1W4 :: Signal System (Maybe Int, Bool)+(sync1R4, sync1W4) = sync12RW 5 3 8++sync2R4 :: Signal System (Bool, (Int, Bool))+sync2W4 :: Signal Slow (Maybe Int, Bool)+(sync2R4, sync2W4) = sync12RW 10 12 1++sync34RW+  :: ( KnownDomain dom1+     , KnownDomain dom2+     )+  => Int+  -> Int+  -> Int+  -> Int+  -> ( Signal dom1 (Bool, (Int, Bool))+     , Signal dom2 (Maybe Int, Bool)+     )+sync34RW w1 n1 w2 w3 =+  ( bundle (inputRInc, bundle (rdata, rempty))+  , bundle (inputWDataM, wfull)+  )+ where+  (rdata, rempty, wfull) =+    asyncFIFOSynchronizer d4 clockGen clockGen resetGen resetGen enableGen+      enableGen inputRInc inputWDataM+  inputRInc = fromList $ P.replicate w1 False <> P.replicate n1 True <>+                P.replicate w2 False <> P.replicate 16 True <> P.repeat False+  inputWDataM = fromList $ Nothing : P.map Just [1 .. n1] <>+                  P.replicate w3 Nothing <> P.map Just [n1 + 1 .. n1 + 16] <>+                  P.repeat Nothing++-- Test n.5: Fully fill the FIFO, then empty it again++sync3R5 :: Signal Slow (Bool, (Int, Bool))+sync3W5 :: Signal System (Maybe Int, Bool)+(sync3R5, sync3W5) = sync34RW 0 0 7 0++sync4R5 :: Signal System (Bool, (Int, Bool))+sync4W5 :: Signal Slow (Maybe Int, Bool)+(sync4R5, sync4W5) = sync34RW 0 0 28 0++-- Test n.6: Transfer 3 elements (so pointers are not zero), then fully fill+-- the FIFO, then empty it again++sync3R6 :: Signal Slow (Bool, (Int, Bool))+sync3W6 :: Signal System (Maybe Int, Bool)+(sync3R6, sync3W6) = sync34RW 4 3 4 4++sync4R6 :: Signal System (Bool, (Int, Bool))+sync4W6 :: Signal Slow (Maybe Int, Bool)+(sync4R6, sync4W6) = sync34RW 8 3 25 1++sync56RW+  :: ( KnownDomain dom1+     , KnownDomain dom2+     )+  => ( Signal dom1 (Bool, (Int, Bool))+     , Signal dom2 (Maybe Int, Bool)+     )+sync56RW =+  ( bundle (inputRInc, bundle (rdata, rempty))+  , bundle (inputWDataM, wfull)+  )+ where+  (rdata, rempty, wfull) =+    asyncFIFOSynchronizer d4 clockGen clockGen resetGen resetGen enableGen+      enableGen inputRInc inputWDataM+  inputRInc = not <$> rempty+  inputWDataM = fromList $ Nothing : P.map Just [1 .. 17] <> P.repeat Nothing++-- Test n.7: Read data as quickly as it comes, all through the memory and one+--           beyond the wrap of the circular buffer++sync5R7 :: Signal Slow (Bool, (Int, Bool))+sync5W7 :: Signal System (Maybe Int, Bool)+(sync5R7, sync5W7) = sync56RW++sync6R7 :: Signal System (Bool, (Int, Bool))+sync6W7 :: Signal Slow (Maybe Int, Bool)+(sync6R7, sync6W7) = sync56RW++-- For use with syncXRY syncXWY.+-- It prints (sample number, (input, output))+printTest+  :: (Foldable f, NFDataX a, ShowX a)+  => f a+  -> IO ()+printTest t = P.mapM_ (putStrLn . showX) $ P.zip [1 :: Int ..] $ sampleN 60 t++sampleR+  :: Foldable f+  => Int+  -> f (Bool, (Int, Bool))+  -> [(Bool, (Maybe Int, Bool))]+sampleR n r =+  P.map (\(inputRInc, (rdata, rempty)) -> (inputRInc, (maybeIsX rdata, rempty)))+    (sampleN n r)++-- For creating the expected constants below+printR+  :: Foldable f+  => f (Bool, (Int, Bool))+  -> IO ()+printR r = case P.map show $ sampleR 60 r of+  (first:rest) ->+    putStrLn $ (P.foldl (\b a -> b <> "  , " <> a <> "\n")+                  ("  [ " <> first <> "\n") rest) <> "  ]"+  _ -> error "impossible"++printW+  :: (Foldable f, NFDataX a, Show a)+  => f a+  -> IO ()+printW w = case P.map show $ sampleN 60 w of+  (first:rest) ->+    putStrLn $ (P.foldl (\b a -> b <> "  , " <> a <> "\n")+                  ("  [ " <> first <> "\n") rest) <> "  ]"+  _ -> error "impossible"++testR+  :: Foldable f+  => f (Bool, (Int, Bool))+  -> [(Bool, (Maybe Int, Bool))]+  -> Assertion+testR r expected = sampleR (P.length expected) r @?= expected++testW+  :: (Foldable f, NFDataX a, Eq a, Show a)+  => f a+  -> [a]+  -> Assertion+testW w expected = sampleN (P.length expected) w @?= expected+++test1R1 :: Assertion+test1R1 = testR sync1R1+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (True,(Just 4,False))+  , (False,(Just 5,True))+  , (False,(Just 5,True))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (False,(Nothing,True))+  ]++test1W1 :: Assertion+test1W1 = testW sync1W1+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Just 4,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Nothing,False)+  ]++test2R1 :: Assertion+test2R1 = testR sync2R1+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (True,(Just 4,False))+  , (False,(Nothing,True))+  , (False,(Just 5,True))+  , (False,(Just 5,True))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (False,(Nothing,True))+  ]++test2W1 :: Assertion+test2W1 = testW sync2W1+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Just 4,False)+  , (Nothing,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Nothing,False)+  ]++test1R2 :: Assertion+test1R2 = testR sync1R2+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (False,(Just 1,False))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (True,(Just 4,False))+  , (False,(Just 5,True))+  , (False,(Just 5,False))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (False,(Nothing,True))+  ]++test1W2 :: Assertion+test1W2 = testW sync1W2+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Just 4,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Nothing,False)+  ]++test2R2 :: Assertion+test2R2 = testR sync2R2+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (True,(Just 4,False))+  , (False,(Just 5,True))+  , (False,(Just 5,True))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (False,(Nothing,True))+  ]++test2W2 :: Assertion+test2W2 = testW sync2W2+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Just 4,False)+  , (Nothing,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Nothing,False)+  ]++test1R3 :: Assertion+test1R3 = testR sync1R3+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (True,(Just 4,False))+  , (False,(Just 5,True))+  , (False,(Just 5,True))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (False,(Nothing,True))+  ]++test1W3 :: Assertion+test1W3 = testW sync1W3+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Just 4,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Nothing,False)+  ]++test2R3 :: Assertion+test2R3 = testR sync2R3+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (True,(Just 4,False))+  , (False,(Nothing,True))+  , (False,(Just 5,True))+  , (False,(Just 5,True))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (False,(Nothing,True))+  ]++test2W3 :: Assertion+test2W3 = testW sync2W3+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Just 4,False)+  , (Nothing,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Nothing,False)+  ]++test1R4 :: Assertion+test1R4 = testR sync1R4+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (False,(Just 1,False))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (True,(Just 4,False))+  , (False,(Just 5,True))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (False,(Nothing,True))+  ]++test1W4 :: Assertion+test1W4 = testW sync1W4+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Just 4,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Nothing,False)+  ]++test2R4 :: Assertion+test2R4 = testR sync2R4+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (True,(Just 4,False))+  , (False,(Just 5,True))+  , (False,(Just 5,True))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (False,(Just 5,False))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (False,(Nothing,True))+  ]++test2W4 :: Assertion+test2W4 = testW sync2W4+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Just 4,False)+  , (Nothing,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Nothing,False)+  ]++test3R5 :: Assertion+test3R5 = testR sync3R5+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (True,(Just 4,False))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (True,(Just 9,False))+  , (True,(Just 10,False))+  , (True,(Just 11,False))+  , (True,(Just 12,False))+  , (True,(Just 13,False))+  , (True,(Just 14,False))+  , (True,(Just 15,False))+  , (True,(Just 16,False))+  , (False,(Just 1,True))+  ]++test3W5 :: Assertion+test3W5 = testW sync3W5+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Just 4,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Just 9,False)+  , (Just 10,False)+  , (Just 11,False)+  , (Just 12,False)+  , (Just 13,False)+  , (Just 14,False)+  , (Just 15,False)+  , (Just 16,False)+  , (Nothing,True)+  , (Nothing,False)+  ]++test4R5 :: Assertion+test4R5 = testR sync4R5+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (True,(Just 4,False))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (True,(Just 9,False))+  , (True,(Just 10,False))+  , (True,(Just 11,False))+  , (True,(Just 12,False))+  , (True,(Just 13,False))+  , (True,(Just 14,False))+  , (True,(Just 15,False))+  , (True,(Just 16,False))+  , (False,(Just 1,True))+  ]++test4W5 :: Assertion+test4W5 = testW sync4W5+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Just 4,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Just 9,False)+  , (Just 10,False)+  , (Just 11,False)+  , (Just 12,False)+  , (Just 13,False)+  , (Just 14,False)+  , (Just 15,False)+  , (Just 16,False)+  , (Nothing,True)+  , (Nothing,False)+  ]++test3R6 :: Assertion+test3R6 = testR sync3R6+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (False,(Just 4,True))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (True,(Just 4,False))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (True,(Just 9,False))+  , (True,(Just 10,False))+  , (True,(Just 11,False))+  , (True,(Just 12,False))+  , (True,(Just 13,False))+  , (True,(Just 14,False))+  , (True,(Just 15,False))+  , (True,(Just 16,False))+  , (True,(Just 17,False))+  , (True,(Just 18,False))+  , (True,(Just 19,False))+  , (False,(Just 4,True))+  ]++test3W6 :: Assertion+test3W6 = testW sync3W6+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Nothing,False)+  , (Just 4,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Just 9,False)+  , (Just 10,False)+  , (Just 11,False)+  , (Just 12,False)+  , (Just 13,False)+  , (Just 14,False)+  , (Just 15,False)+  , (Just 16,False)+  , (Just 17,False)+  , (Just 18,False)+  , (Just 19,False)+  , (Nothing,True)+  , (Nothing,True)+  , (Nothing,False)+  ]++test4R6 :: Assertion+test4R6 = testR sync4R6+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (False,(Just 1,False))+  , (False,(Just 1,False))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (False,(Nothing,True))+  , (False,(Just 4,True))+  , (False,(Just 4,True))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (False,(Just 4,False))+  , (True,(Just 4,False))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (True,(Just 9,False))+  , (True,(Just 10,False))+  , (True,(Just 11,False))+  , (True,(Just 12,False))+  , (True,(Just 13,False))+  , (True,(Just 14,False))+  , (True,(Just 15,False))+  , (True,(Just 16,False))+  , (True,(Just 17,False))+  , (True,(Just 18,False))+  , (True,(Just 19,False))+  , (False,(Just 4,True))+  ]++test4W6 :: Assertion+test4W6 = testW sync4W6+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Nothing,False)+  , (Just 4,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Just 9,False)+  , (Just 10,False)+  , (Just 11,False)+  , (Just 12,False)+  , (Just 13,False)+  , (Just 14,False)+  , (Just 15,False)+  , (Just 16,False)+  , (Just 17,False)+  , (Just 18,False)+  , (Just 19,False)+  , (Nothing,True)+  , (Nothing,False)+  ]++test5R7 :: Assertion+test5R7 = testR sync5R7+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (True,(Just 1,False))+  , (True,(Just 2,False))+  , (True,(Just 3,False))+  , (True,(Just 4,False))+  , (True,(Just 5,False))+  , (True,(Just 6,False))+  , (True,(Just 7,False))+  , (True,(Just 8,False))+  , (True,(Just 9,False))+  , (True,(Just 10,False))+  , (True,(Just 11,False))+  , (True,(Just 12,False))+  , (True,(Just 13,False))+  , (True,(Just 14,False))+  , (True,(Just 15,False))+  , (True,(Just 16,False))+  , (True,(Just 17,False))+  , (False,(Just 2,True))+  ]++test5W7 :: Assertion+test5W7 = testW sync5W7+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Just 4,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Just 9,False)+  , (Just 10,False)+  , (Just 11,False)+  , (Just 12,False)+  , (Just 13,False)+  , (Just 14,False)+  , (Just 15,False)+  , (Just 16,False)+  , (Just 17,False)+  , (Nothing,False)+  ]++test6R7 :: Assertion+test6R7 = testR sync6R7+  [ (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Nothing,True))+  , (False,(Just 1,True))+  , (False,(Just 1,True))+  , (True,(Just 1,False))+  , (False,(Just 2,True))+  , (True,(Just 2,False))+  , (False,(Just 3,True))+  , (True,(Just 3,False))+  , (False,(Just 4,True))+  , (True,(Just 4,False))+  , (False,(Just 5,True))+  , (True,(Just 5,False))+  , (False,(Just 6,True))+  , (True,(Just 6,False))+  , (False,(Just 7,True))+  , (True,(Just 7,False))+  , (False,(Just 8,True))+  , (True,(Just 8,False))+  , (False,(Just 9,True))+  , (True,(Just 9,False))+  , (False,(Just 10,True))+  , (True,(Just 10,False))+  , (False,(Just 11,True))+  , (True,(Just 11,False))+  , (False,(Just 12,True))+  , (True,(Just 12,False))+  , (False,(Just 13,True))+  , (True,(Just 13,False))+  , (False,(Just 14,True))+  , (True,(Just 14,False))+  , (False,(Just 15,True))+  , (True,(Just 15,False))+  , (False,(Just 16,True))+  , (True,(Just 16,False))+  , (False,(Just 17,True))+  , (True,(Just 17,False))+  , (False,(Just 2,True))+  ]++test6W7 :: Assertion+test6W7 = testW sync6W7+  [ (Nothing,False)+  , (Just 1,False)+  , (Just 2,False)+  , (Just 3,False)+  , (Just 4,False)+  , (Just 5,False)+  , (Just 6,False)+  , (Just 7,False)+  , (Just 8,False)+  , (Just 9,False)+  , (Just 10,False)+  , (Just 11,False)+  , (Just 12,False)+  , (Just 13,False)+  , (Just 14,False)+  , (Just 15,False)+  , (Just 16,False)+  , (Just 17,False)+  , (Nothing,False)+  ]++createDomain vSystem{vName="A", vPeriod=hzToPeriod 20e6} -- fast+createDomain vSystem{vName="B", vPeriod=hzToPeriod 10e6} -- slow+createDomain vSystem{vName="C", vPeriod=hzToPeriod 7e6} -- slower++data DomProxy (dom :: Domain) where+  DomProxy+    :: KnownDomain dom+    => DomProxy dom++-- A more useful Show instance than the one for 'Proxy'+instance Show (DomProxy dom) where+  showsPrec d dom@DomProxy =+    showParen (d > app_prec) $ ("DomProxy @" <>) . (symbolVal dom <>)+   where app_prec = 10++data NamedTest a = NamedTest+  { namedTest :: a+  , testName :: String+  }++instance Show (NamedTest a) where+  show nt = testName nt++testNameShowsPrec+  :: Int+  -> ShowS+  -> DomProxy dom1+  -> DomProxy dom2+  -> ShowS+testNameShowsPrec d baseName dom1 dom2 =+  showParen (d > app_prec) $ baseName . (' ':) . showsPrec 11 dom1 .+    (' ':) . showsPrec 11 dom2+ where app_prec = 10++forAllNamedTestProperties+  :: [NamedTest (PropertyT IO ())]+  -> Property++forAllNamedTestProperties nts = property $ do+  t <- fmap namedTest . forAllWith show . Gen.resize 99 $ Gen.element nts+  t++data WriteAction =+    Write+  | WNoOp+  | WGated+  | GatedWrite+  deriving (Eq, Enum, Bounded, Show, Generic, NFDataX)++data ReadAction =+    Read+  | RNoOp+  | RGated+  | GatedRead+  deriving (Eq, Enum, Bounded, Show, Generic, NFDataX)++fifoOperations+  :: forall wdom rdom+   . (KnownDomain wdom, KnownDomain rdom)+  => [ReadAction]+  -> [WriteAction]+  -> ( Signal rdom ( Bool+                     -- Test fully done+                   , Maybe Int+                     -- Element read from FIFO+                   )+     , Signal wdom ( Bool+                     -- Test fully done+                   , Maybe Int+                    -- Element written to FIFO+                   )+     )+fifoOperations racts wacts = (bundle (rAllDone, rel), bundle (wAllDone, wel))+ where+  (rdata, rempty, wfull) =+    asyncFIFOSynchronizer d3 wclk rclk noWRst noRRst (toEnable wen)+      (toEnable ren) rinc wDataM+  rclk = clockGen @rdom+  wclk = clockGen @wdom+  -- Not resetting makes the test easier to interpret and actual proper testing+  -- of reset behaviour is a lot more involved.+  noRRst = unsafeFromActiveHigh @rdom (pure False)+  noWRst = unsafeFromActiveHigh @wdom (pure False)+  (wdone, wact) =+    unbundle $ fromList $ P.zip (P.repeat False) wacts <> P.repeat (True, WNoOp)+  (rdone, ract) =+    unbundle $ fromList $ P.zip (P.repeat False) racts <> P.repeat (True, RNoOp)+  (wen, wDataM) = unbundle $+    liftA2 (\wact0 d -> case wact0 of+                          Write      -> (True , Just d )+                          WNoOp      -> (True , Nothing)+                          WGated     -> (False, Nothing)+                          GatedWrite -> (False, Just d )+           ) wact wdata+  wdata = regEn wclk noWRst enableGen 1 (isJust <$> wDataM) (wdata + 1)+  (ren, rinc) = unbundle $+    fmap (\ract0 -> case ract0 of+                      Read       -> (True , True )+                      RNoOp      -> (True , False)+                      RGated     -> (False, False)+                      GatedRead  -> (False, True)+         ) ract1+  mainDone = rdone .&&. unsafeSynchronizer wclk rclk wdone+  -- Empty FIFO after main test+  ract1 = mux mainDone (pure Read) ract+  flushCnt = regEn rclk noRRst enableGen (1 :: Int) mainDone (flushCnt + 1)+  -- Surely in 20 cycles we have seen all of the FIFO even if something has gone+  -- wrong with the pointers+  rAllDone = fmap (> 20) flushCnt+  wAllDone = unsafeSynchronizer rclk wclk rAllDone+  rel = mux (liftA3 (\en inc em -> en && inc && not em) ren rinc rempty)+            (Just <$> rdata) (pure Nothing)+  wel = mux (liftA3 (\en wdm fu -> en && isJust wdm && not fu) wen wDataM wfull)+            (Just <$> wdata) (pure Nothing)++fifoFunctionalTest+  :: forall wdom rdom m+   . Monad m+  => DomProxy wdom+  -> DomProxy rdom+  -> NamedTest (PropertyT m ())+fifoFunctionalTest wdom@DomProxy rdom@DomProxy =+  NamedTest { namedTest=test0, testName = name }+ where+  name = testNameShowsPrec 0 (shows 'fifoFunctionalTest) wdom rdom ""+  genInput :: (Bounded e, Enum e, Show e) => PropertyT m [e]+  genInput = fmap P.concat . forAll . Gen.list (Range.linear 1 10) .+               Gen.list (Range.linear 0 20) $ Gen.enumBounded+  test0 = do+    racts <- genInput+    wacts <- genInput+    let+      results = fifoOperations @wdom @rdom racts wacts+      catValids = catMaybes . P.map snd . P.takeWhile (not . fst)+      rels = catValids . sample $ fst results+      wels = catValids . sample $ snd results+    rels === wels++fifoFunctionalTestCombinations :: Monad m => [NamedTest (PropertyT m ())]+fifoFunctionalTestCombinations =+  [ fifoFunctionalTest (DomProxy @A) (DomProxy @A)+  , fifoFunctionalTest (DomProxy @A) (DomProxy @B)+  , fifoFunctionalTest (DomProxy @A) (DomProxy @C)+  , fifoFunctionalTest (DomProxy @B) (DomProxy @A)+  , fifoFunctionalTest (DomProxy @B) (DomProxy @C)+  , fifoFunctionalTest (DomProxy @C) (DomProxy @A)+  , fifoFunctionalTest (DomProxy @C) (DomProxy @B)+  ]++tests :: TestTree+tests = testGroup "asyncFIFOSynchronizer"+  [ testCase "Test 1.1 Read" test1R1+  , testCase "Test 1.1 Write" test1W1+  , testCase "Test 2.1 Read" test2R1+  , testCase "Test 2.1 Write" test2W1+  , testCase "Test 1.2 Read" test1R2+  , testCase "Test 1.2 Write" test1W2+  , testCase "Test 2.2 Read" test2R2+  , testCase "Test 2.2 Write" test2W2+  , testCase "Test 1.3 Read" test1R3+  , testCase "Test 1.3 Write" test1W3+  , testCase "Test 2.3 Read" test2R3+  , testCase "Test 2.3 Write" test2W3+  , testCase "Test 1.4 Read" test1R4+  , testCase "Test 1.4 Write" test1W4+  , testCase "Test 2.4 Read" test2R4+  , testCase "Test 2.4 Write" test2W4+  , testCase "Test 3.5 Read" test3R5+  , testCase "Test 3.5 Write" test3W5+  , testCase "Test 4.5 Read" test4R5+  , testCase "Test 4.5 Write" test4W5+  , testCase "Test 3.6 Read" test3R6+  , testCase "Test 3.6 Write" test3W6+  , testCase "Test 4.6 Read" test4R6+  , testCase "Test 4.6 Write" test4W6+  , testCase "Test 5.7 Read" test5R7+  , testCase "Test 5.7 Write" test5W7+  , testCase "Test 6.7 Read" test6R7+  , testCase "Test 6.7 Write" test6W7+  , testPropertyXXX "Functional test" $ forAllNamedTestProperties fifoFunctionalTestCombinations+  ]
+ tests/Clash/Tests/AutoReg.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE DeriveAnyClass #-}++module Clash.Tests.AutoReg where++import Test.Tasty+import Test.Tasty.QuickCheck+import qualified Data.List as L+import Clash.Prelude++test :: (Eq a, Show a, AutoReg a, Arbitrary a) => a -> [a] -> Property+test initVal xs = testFor (L.length xs) $ register initVal input .==. autoReg initVal input+  where input = fromList @_ @System xs++tests :: TestTree+tests =+  testGroup+    "AutoReg"+      [ testGroup "autoReg === register"+        [ testProperty "Int" $ test @Int+        , testProperty "(Unsigned 4, Bool)" $ test @(Unsigned 4, Bool)+        , testProperty "Maybe Bool" $ test @(Maybe Bool)+        -- , testProperty "Either Bool (Unsigned 3)" $ test @(Either Bool (Unsigned 3))++        , testProperty "Vec 4 Bool" $ test @(Vec 4 Bool)+        , testProperty "Vec 4 (Maybe Bool)" $ test @(Vec 4 (Maybe Bool))++        , testProperty "Maybe (Vec 4 Bool)" $ test @(Maybe (Vec 4 Bool))+        , testProperty "Maybe (Maybe (Vec 4 Bool))" $ test @(Maybe (Maybe (Vec 4 Bool)))++        , testProperty "RTree 2 Bool" $ test @(RTree 2 Bool)+        , testProperty "Maybe (RTree 2 Bool)" $ test @(Maybe (RTree 2 Bool))+        , testProperty "Maybe (Maybe (RTree 2 Bool))" $ test @(Maybe (Maybe (RTree 2 Bool)))++        , testProperty "Maybe (Vec 4 (Maybe (Vec 3 Bool)))" $ test @(Maybe (Vec 4 (Maybe (Vec 3 Bool))))+        ]+      ]
tests/Clash/Tests/BitPack.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE CPP            #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric  #-}-{-# LANGUAGE MagicHash      #-}  {-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-} @@ -11,6 +9,11 @@ import Test.Tasty.HUnit  import Clash.Class.BitPack+import Clash.Sized.RTree+import Clash.Sized.Signed+import Clash.Sized.Unsigned+import Clash.Sized.Vector+import Clash.XException  import GHC.Generics (Generic) @@ -26,6 +29,24 @@ rtt :: (Eq a, Show a, BitPack a) => a -> Assertion rtt u = unpack (pack u) @?= u +{-+@pack@ will still output defined elements even if the spine is not fully defined.+-}+undefSpineVec :: Assertion+undefSpineVec = showX (pack v) @?= "0b0001_...._...."+ where+  v :: Vec 3 (Unsigned 4)+  v = 1 :> Clash.XException.undefined++{-+@pack@ will still output defined elements even if the spine is not fully defined.+-}+undefSpineRTree :: Assertion+undefSpineRTree = showX (pack t) @?= "0b...._...._0101_...."+ where+  t :: RTree 2 (Unsigned 4)+  t = BR Clash.XException.undefined (BR (LR 5) Clash.XException.undefined)+ tests :: TestTree tests =   testGroup@@ -47,5 +68,7 @@         , testCase "Rec1" (rtt (Rec1 10))         , testCase "Rec2" (rtt (Rec2 10 30))         ]+    , testCase "Vec" (rtt ((1 :: Signed 6) :> 2 :> (-5) :> 4 :> Nil))+    , testCase "undefSpineVec" undefSpineVec+    , testCase "undefSpineRTree" undefSpineRTree     ]-
tests/Clash/Tests/BitVector.hs view
@@ -1,29 +1,70 @@-{-# LANGUAGE BinaryLiterals  #-}-{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE LambdaCase      #-}-{-# LANGUAGE ViewPatterns    #-}+{-# LANGUAGE TypeFamilies #-} -module Clash.Tests.BitVector where+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-} +module Clash.Tests.BitVector (tests, main) where++import qualified Hedgehog as H+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Data.Proxy+import GHC.TypeNats (KnownNat, SomeNat (..), natVal, someNatVal) import Test.Tasty import Test.Tasty.HUnit -import Clash.Prelude (BitVector, bitPattern)+import qualified Test.Tasty.Hedgehog.Extra as H+import qualified Test.Tasty.QuickCheck as Q +import Data.Bits (Bits(shiftR))++import Clash.Prelude+  (Bit, high, low, bitPattern, type (<=), type (-), natToInteger, msb, bLit, hLit, oLit, rotateL, rotateR)+import Clash.Sized.Internal.BitVector (BitVector (..))++import Test.Tasty.HUnit.Extra (expectException)++import Clash.Tests.SizedNum++-- | Generates a BitVector either with the MSB set or not, and checks whether+-- 'msb' agrees with it.+msbTest :: forall n. (1 <= n, KnownNat n) => H.Property+msbTest = H.property $ do+  (bv, b) <- H.forAll msbGen+  b H.=== msb bv+ where+  msbGen :: H.Gen (BitVector n, Bit)+  msbGen = Gen.choice+    [ liftA2 (,) msbSetGen (Gen.constant high)+    , liftA2 (,) msbUnsetGen (Gen.constant low) ]++  msbSetGen :: H.Gen (BitVector n)+  msbSetGen = Gen.integral (Range.linear (2^natToInteger @(n-1)) maxBound)++  msbUnsetGen :: H.Gen (BitVector n)+  msbUnsetGen = Gen.integral (Range.linear 0 (pred (2^natToInteger @(n-1))))+ test1 :: BitVector 8 -> Int test1 =   \case-    $(bitPattern "0.......") -> 0-    $(bitPattern "01......") -> 1-    $(bitPattern "11....01") -> 2-    $(bitPattern "11111110") -> 3-    $(bitPattern "........") -> 4-    _                        -> 5  -- To keep exhaustiveness checker happy+    $(bitPattern "0..._....") -> 0+    $(bitPattern "01.._....") -> 1+    $(bitPattern "11.._..01") -> 2+    $(bitPattern "1111_1110") -> 3+    $(bitPattern "110a_babb") -> 4 + fromIntegral aa + fromIntegral bbb+    $(bitPattern "...._....") -> 4+    _                         -> 5  -- To keep exhaustiveness checker happy  tests :: TestTree-tests =-  testGroup+tests = localOption (Q.QuickCheckMaxRatio 2) $ testGroup "All"+  [ testGroup     "bitPattern"     [ testCase "case0-0" $ test1 0b00000000 @?= 0     , testCase "case0-1" $ test1 0b00011001 @?= 0@@ -33,6 +74,100 @@     , testCase "case2-1" $ test1 0b11100001 @?= 2     , testCase "case3-0" $ test1 0b11111110 @?= 3     , testCase "case3-1" $ test1 0b11111111 @?= 4-    , testCase "case3-2" $ test1 0b11010110 @?= 4+    , testCase "case3-2" $ test1 0b11010110 @?= 9     ]+  , testGroup "BitVector 1" $+      Q.testProperty "fromInteger"+        (fromIntegerProp (Proxy :: Proxy 1)) :+      map lawsToTest (laws1 (Proxy :: Proxy (BitVector 1)))+  , testGroup "BitVector 21" $+      Q.testProperty "fromInteger"+        (fromIntegerProp (Proxy :: Proxy 21)) :+      map lawsToTest (laws (Proxy :: Proxy (BitVector 21)))+  , testGroup "BitVector 83" $+      Q.testProperty "fromInteger"+        (fromIntegerProp (Proxy :: Proxy 83)) :+      map lawsToTest (laws (Proxy :: Proxy (BitVector 83)))+  , testGroup "Random BitVector"+    [ Q.testProperty "fromInteger" fromIntegerRandomProp ]+  , testGroup "Enum"+    [ testCase "[4,3..]" $ [4,3..] @?= [4,3,2,1,0 :: BitVector 8]+    , testCase "[4,2..]" $ [4,2..] @?= [4,2,0 :: BitVector 8]+    , testCase "take 5 [4,4..]" $ take 5 [4,4..] @?= [4,4,4,4,4 :: BitVector 8]+    , testCase "[2,4..]" $ [2,4..] @?= [2,4,6 :: BitVector 3]+    , testCase "[3,4..]" $ [3,4..] @?= [3,4,5,6,7 :: BitVector 3]+    ]+  , testGroup "Bounds"+    [ testCase "maxBound :: BitVector 0" $ maxBound @(BitVector 0) @?= 0+    , testCase "minBound :: BitVector 0" $ minBound @(BitVector 0) @?= 0+    ]+  , testGroup "Rotate"+    [ testCase "rotateL BitVector 0" $ rotateL @(BitVector 0) 0 2 @?= 0+    , testCase "rotateR BitVector 0" $ rotateR @(BitVector 0) 0 2 @?= 0+    ]+  , testGroup "MSB"+    [ H.testPropertyXXX "msb @(BitVector 1)" (msbTest @1)+    , H.testPropertyXXX "msb @(BitVector 2)" (msbTest @2)+    , H.testPropertyXXX "msb @(BitVector 3)" (msbTest @3)+    , H.testPropertyXXX "msb @(BitVector 37)" (msbTest @37)+    , H.testPropertyXXX "msb @(BitVector 64)" (msbTest @64)+    , H.testPropertyXXX "msb @(BitVector 128)" (msbTest @128)+    , H.testPropertyXXX "msb @(BitVector 129)" (msbTest @129)+    ]+  , testGroup "shiftR"+    [ testCase "shiftR 5 0 == 5" $+        shiftR (5 :: BitVector 8) 0 @?= 5+    , testCase "returns 0 when n == bitSize" $+        shiftR (0xFF :: BitVector 8) 8 @?= 0+    , testCase "returns 0 when n > bitSize" $+        shiftR (0xFF :: BitVector 8) (8 + 1) @?= 0+    , testCase "returns 0 when n >> bitSize" $+        shiftR (0xFF :: BitVector 8) (8 + 1000) @?= 0+    , testCase "undefined when n < 0" $+        expectException (shiftR (1 :: BitVector 8) (-1))+    ]+  , testGroup "show"+    [ testCase "show0"  $ show @(BitVector 0) 0b0 @?= "0"+    , testCase "show1"  $ show @(BitVector 1) 0b1 @?= "0b1"+    , testCase "show2"  $ show @(BitVector 1) 0b0 @?= "0b0"+    , testCase "show3"  $ show @(BitVector 2) 0b00 @?= "0b00"+    , testCase "show4"  $ show @(BitVector 2) 0b01 @?= "0b01"+    , testCase "show5"  $ show @(BitVector 2) 0b10 @?= "0b10"+    , testCase "show6"  $ show @(BitVector 2) 0b11 @?= "0b11"+    , testCase "show7"  $ show @(BitVector 3) 0b111 @?= "0b111"+    , testCase "show8"  $ show @(BitVector 4) $(bLit "0000") @?= "0b0000"+    , testCase "show9"  $ show @(BitVector 4) $(bLit "000.") @?= "0b000."+    , testCase "show10" $ show @(BitVector 4) $(bLit "010.") @?= "0b010."+    , testCase "show11" $ show @(BitVector 5) $(bLit "1010.") @?= "0b1_010."+    , testCase "show12" $ show @(BitVector 8) $(bLit "0001010.") @?= "0b0001_010."+    , testCase "show13" $ show @(BitVector 9) $(bLit "10001010.") @?= "0b1_0001_010." +    , testCase "show14" $ show @(BitVector 16) $(hLit "dead") @?= "0b1101_1110_1010_1101"+    , testCase "show14" $ show @(BitVector 16) $(hLit "de.d") @?= "0b1101_1110_...._1101"+    , testCase "show15" $ show @(BitVector 16) $(hLit "beef") @?= "0b1011_1110_1110_1111"+    , testCase "show15" $ show @(BitVector 16) $(hLit ".eef") @?= "0b...._1110_1110_1111"+    , testCase "show16" $ show @(BitVector 12) $(oLit "7734") @?= "0b1111_1101_1100"+    , testCase "show16" $ show @(BitVector 12) $(oLit "77.4") @?= "0b1111_11.._.100"+    , testCase "show17" $ show @(BitVector 12) $(oLit "5324") @?= "0b1010_1101_0100"+    , testCase "show17" $ show @(BitVector 12) $(oLit ".324") @?= "0b...0_1101_0100"+    ]+  ]++fromIntegerProp :: forall m. KnownNat m => Proxy m -> Integer -> Q.Property+fromIntegerProp p n = unsafeToNatural m Q.=== fromInteger (n `mod` (2 ^ toInteger (natVal p)))+  where+    m :: BitVector m+    m = fromInteger n++fromIntegerRandomProp :: Q.Positive Integer -> Integer -> Q.Property+fromIntegerRandomProp (Q.Positive m) n = m > 1 Q.==> case someNatVal (fromInteger m) of+  SomeNat p -> fromIntegerProp p n++-- Run with:+--+--    ./repld p:tests -T Clash.Tests.BitVector.main+--+-- Add -W if you want to run tests in spite of warnings+--+main :: IO ()+main = defaultMain tests
+ tests/Clash/Tests/BlockRam.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Clash.Tests.BlockRam (tests) where++import qualified Data.List as List+import Test.Tasty+import Test.Tasty.HUnit++import qualified Clash.Explicit.Prelude as E+import Clash.Explicit.BlockRam (blockRam#)+import Clash.Prelude++readRam+  :: (HiddenClockResetEnable dom)+  => Signal dom (Unsigned 4)+  -> Signal dom (Unsigned 8)+readRam addr = mux (register False $ addr .< 8) ram (pure 0xff)+  where+    ram = blockRam1 NoClearOnReset (SNat @8) 0 addr (pure Nothing)++-- If the block RAM uses the address argument too strictly, then it will+-- attempt to access an out of bounds address when using readRam.+--+addrNotTooStrict :: Assertion+addrNotTooStrict =+  let addr = fromList [0..15]+   in List.drop 1 (sampleN @System 15 (readRam addr)) @?=+        [255,0,0,0,0,0,0,0,255,255,255,255,255,255]++primRam+  :: Signal System Int+  -> Signal System Bool+  -> Signal System Int+  -> Signal System Int+  -> Signal System (Maybe Int)+primRam rd we wr din =+  maybeIsX <$> blockRam# clockGen enableGen (0 :> 1 :> Nil) rd we wr din++type PrimSamples = [(Int, Bool, Int, Int, Maybe Int)]++undefEn :: PrimSamples++-- Undefined enable:+--    The written-to address should read 'undefined', but other addresses+--    should still have their data.++--                               rd  enable     waddr      wdata      dout++undefEn =                     [ ( 0, undefined, 0        , 2        , Nothing)+                              , ( 0, False    , 0        , 3        , Just 0 )+                              , ( 1, False    , 0        , 3        , Nothing)+                              , ( 1, False    , 0        , 3        , Just 1 )+                              ]++primRamAssertion+  :: PrimSamples+  -> Assertion+primRamAssertion samples = actual @?= expectedOutput+ where+  (rd, we, wr, din, expectedOutput) = List.unzip5 samples+  actual = E.sampleN (List.length samples) $ primRam (fromList rd)+                                                     (fromList we)+                                                     (fromList wr)+                                                     (fromList din)++tests :: TestTree+tests = testGroup "BlockRam"+  [ testCase "Address strictness" addrNotTooStrict+  , testCase "Undefined enable" $ primRamAssertion undefEn+  ]
+ tests/Clash/Tests/BlockRam/Blob.hs view
@@ -0,0 +1,36 @@+module Clash.Tests.BlockRam.Blob where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Functor.Identity+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Numeric.Natural+import Test.Tasty+import Test.Tasty.Hedgehog.Extra++import Clash.Explicit.BlockRam.Internal (packAsNats, unpackNats)++roundTripProperty :: Property+roundTripProperty = property $ do+  len <- forAll $ Gen.integral $ Range.linear 0 256+  width <- forAll $ Gen.integral $ Range.linear 1 128+  es <- forAll $ Gen.list (Range.singleton len) $+    Gen.integral_ $ Range.constant 0 (2 ^ width - 1)+  tripping (len, width, es) encode decode+ where+  encode :: (Int, Int, [Natural]) -> (Int, Int, B.ByteString, B.ByteString)+  encode (len, width, es) = let (runs, ends) = packAsNats width id es+                            in (len, width, L.toStrict runs, L.toStrict ends)+  decode :: (Int, Int, B.ByteString, B.ByteString)+         -> Identity (Int, Int, [Natural])+  decode (len, width, runs, ends) =+    let es = take 300 $ unpackNats len width runs ends+    in Identity (len, width, es)++tests :: TestTree+tests = testGroup "BlockRam"+  [ testGroup "Blob"+    [ testPropertyXXX "Round trip" roundTripProperty ]+  ]
+ tests/Clash/Tests/Clocks.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Clash.Tests.Clocks(tests) where++import qualified Prelude as P++import Test.Tasty+import Test.Tasty.HUnit++import Clash.Explicit.Prelude+import Clash.Intel.ClockGen (unsafeAltpll)++-- Ratio of clock periods in 'createDomain' and 'resetLen' are chosen, rest is+-- derived from that++createDomain vSystem{vName="ClocksSlow", vPeriod=3 * vPeriod vSystem}++resetLen :: SNat 10+resetLen = SNat++lockResampled :: Assertion+lockResampled =+  unlockedLenSeen @?= unlockedLen+ where+  pll ::+    Clock ClocksSlow ->+    Reset ClocksSlow ->+    (Clock System, Signal System Bool)+  pll = unsafeAltpll++  unlockedLenSeen =+    P.length . P.takeWhile not .+    -- Arbitrary cut-off so simulation always ends+    sampleN (unlockedLen + 100) .+    snd $ pll clockGen (resetGenN resetLen)++clockRatio :: Int+clockRatio = fromIntegral $ snatToNatural (clockPeriod @ClocksSlow) `div`+                            snatToNatural (clockPeriod @System)++unlockedLen :: Int+unlockedLen = snatToNum resetLen * clockRatio - clockRatio + 1++tests :: TestTree+tests =+  testGroup "Clocks class"+    [ testCase "Lock is resampled from reset" lockResampled ]
+ tests/Clash/Tests/Counter.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NumericUnderscores #-}++module Clash.Tests.Counter where++import qualified Prelude as P++import Clash.Class.Counter+import Clash.Prelude+import Data.Proxy+import Data.Typeable++import qualified Hedgehog as H+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import           Test.Tasty+import qualified Test.Tasty.Hedgehog.Extra as H+import           Test.Tasty.HUnit++genUnsigned :: SNat n -> H.Gen (Unsigned n)+genUnsigned SNat = Gen.frequency+  [ (80, Gen.integral (Range.linear minBound maxBound))+  , (20, pure maxBound) ]++packTest2 ::+  forall a b.+  (KnownNat a, KnownNat b, KnownNat (a + b)) =>+  (Unsigned (a + b) -> Unsigned (a + b)) ->+  ((Unsigned a, Unsigned b) -> (Unsigned a, Unsigned b)) ->+  H.Property+packTest2 f1 f2 = H.property $ do+  a <- H.forAll (genUnsigned (SNat @a))+  b <- H.forAll (genUnsigned (SNat @b))+  let ab = unpack @(Unsigned (a + b)) (pack (a, b))+  f1 ab H.=== unpack (pack (f2 (a, b)))++packSuccTest2 ::+  forall a b.+  (KnownNat a, KnownNat b, KnownNat (a + b)) =>+  Proxy a ->+  Proxy b ->+  H.Property+packSuccTest2 _ _ = packTest2 (satSucc SatWrap) (countSucc @(Unsigned a, Unsigned b))++packPredTest2 ::+  forall a b.+  (KnownNat a, KnownNat b, KnownNat (a + b)) =>+  Proxy a ->+  Proxy b ->+  H.Property+packPredTest2 _ _ = packTest2 (satPred SatWrap) (countPred @(Unsigned a, Unsigned b))++-- | Counting /down/ from 'countMin' should yield 'countMin' at some point+predShouldWrapAround :: forall a. (Eq a, Counter a, Show a) => Proxy a -> Assertion+predShouldWrapAround Proxy =+  let counter = P.take 100_0000 (P.drop 1 (P.iterate countPred countMin)) in+  assertBool "Pred should wrap-around" (countMin @a `P.elem` counter)++-- | Counting /up/ from 'countMin' should yield 'countMin' at some point+succShouldWrapAround :: forall a. (Eq a, Counter a, Show a) => Proxy a -> Assertion+succShouldWrapAround Proxy =+  let counter = P.take 100_000 (P.drop 1 (P.iterate countSucc countMin)) in+  assertBool "Succ should wrap-around" (countMin @a `P.elem` counter)++-- | Counting /down/ from 'countMax' should yield 'countMin' at some point+predShouldSeeCountMin :: forall a. (Eq a, Counter a, Show a) => Proxy a -> Assertion+predShouldSeeCountMin Proxy =+  let counter = P.take 100_0000 (P.drop 1 (P.iterate countPred countMax)) in+  assertBool "Pred should see countMin" (countMin @a `P.elem` counter)++-- | Counting /up/ from 'countMin' should yield 'countMax' at some point+succShouldSeeCountMax :: forall a. (Eq a, Counter a, Show a) => Proxy a -> Assertion+succShouldSeeCountMax Proxy =+  let counter = P.take 100_000 (P.drop 1 (P.iterate countSucc countMin)) in+  assertBool "Succ should see countMax" (countMax @a `P.elem` counter)++quadTest :: forall a. (Eq a, Counter a, Typeable a, Show a) => Proxy a -> TestTree+quadTest proxy = testGroup (show (typeRep proxy))+  [ testCase "succShouldWrapAround" (succShouldWrapAround proxy)+  , testCase "predShouldWrapAround" (predShouldWrapAround proxy)+  , testCase "succShouldSeeCountMax" (succShouldSeeCountMax proxy)+  , testCase "predShouldSeeCountMin" (predShouldSeeCountMin proxy)+  ]++tests :: TestTree+tests = testGroup "All"+  [ H.testPropertyXXX "packSuccTest @2 @2"    (packSuccTest2 @2   @2 Proxy Proxy)+  , H.testPropertyXXX "packSuccTest @3 @2"    (packSuccTest2 @3   @2 Proxy Proxy)+  , H.testPropertyXXX "packSuccTest2 @129 @5" (packSuccTest2 @129 @5 Proxy Proxy)+  , H.testPropertyXXX "packPredTest @2 @2"    (packPredTest2 @2   @2 Proxy Proxy)+  , H.testPropertyXXX "packPredTest @3 @2"    (packPredTest2 @3   @2 Proxy Proxy)+  , H.testPropertyXXX "packPredTest2 @129 @5" (packPredTest2 @129 @5 Proxy Proxy)++  , quadTest (Proxy @(Signed 5))+  , quadTest (Proxy @(Signed 5, Signed 5))+  , quadTest (Proxy @(Signed 2, Signed 2, Unsigned 7))+  , quadTest (Proxy @(Either (Signed 5) (Index 5)))+  ]+++-- Run with:+--+--    ./repld p:tests -T Clash.Tests.Counter.main+--+-- Add -W if you want to run tests in spite of warnings+--+main :: IO ()+main = defaultMain tests
tests/Clash/Tests/DerivingDataRepr.hs view
@@ -1,10 +1,7 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE BinaryLiterals #-}  module Clash.Tests.DerivingDataRepr where @@ -13,17 +10,17 @@ import Prelude ((=<<), ($)) import Clash.Annotations.BitRepresentation import Clash.Annotations.BitRepresentation.Deriving-import Clash.Tests.DerivingDataReprTypes (Train(..), RGB(..))+import Clash.Tests.DerivingDataReprTypes (Train(..), RGB(..), Headphones(..), EarCup(..)) import Data.Maybe (Maybe(..))  --------------------------------------------------------- ------------ DERIVING SIMPLE REPRESENTATIONS ------------ ----------------------------------------------------------oneHotOverlapRepr :: DataReprAnn-oneHotOverlapRepr = $( (simpleDerivator OneHot OverlapL) =<< [t| Train |] )+oneHotOverlapLRepr :: DataReprAnn+oneHotOverlapLRepr = $( (simpleDerivator OneHot OverlapL) =<< [t| Train |] ) -oneHotOverlapRepr' :: DataReprAnn-oneHotOverlapRepr' =+oneHotOverlapLRepr' :: DataReprAnn+oneHotOverlapLRepr' =   DataReprAnn     $(liftQ [t| Train |])     8@@ -33,6 +30,43 @@     , ConstrRepr 'Toy         128 128 []     ] +oneHotOverlapRRepr :: DataReprAnn+oneHotOverlapRRepr = $( (simpleDerivator OneHot OverlapR) =<< [t| Train |] )++oneHotOverlapRRepr' :: DataReprAnn+oneHotOverlapRRepr' =+  DataReprAnn+    $(liftQ [t| Train |])+    8+    [ ConstrRepr 'Passenger   16  16  [0b0011]+    , ConstrRepr 'Freight     32  32  [0b1100, 0b0011]+    , ConstrRepr 'Maintenance 64  64  []+    , ConstrRepr 'Toy         128 128 []+    ]++oneHotOverlapReprRec :: DataReprAnn+oneHotOverlapReprRec = $( (simpleDerivator OneHot OverlapL) =<< [t| Headphones |] )++oneHotOverlapReprRec' :: DataReprAnn+oneHotOverlapReprRec' =+  DataReprAnn+    $(liftQ [t| Headphones |])+    4+    [ ConstrRepr 'InEar   4  4  [0b10]+    , ConstrRepr 'OverEar 8  8  [0b11]+    ]++oneHotOverlapReprInfix :: DataReprAnn+oneHotOverlapReprInfix = $( (simpleDerivator OneHot OverlapL) =<< [t| EarCup |] )++oneHotOverlapReprInfix' :: DataReprAnn+oneHotOverlapReprInfix' =+  DataReprAnn+    $(liftQ [t| EarCup |])+    5+    [ ConstrRepr '(:<>:) 16  16  [0b1100,0b0011] ]++ oneHotWideRepr :: DataReprAnn oneHotWideRepr = $( (simpleDerivator OneHot Wide) =<< [t| Train |] ) @@ -112,10 +146,13 @@ -- MAIN tests :: TestTree tests = testGroup "DerivingDataRepr"-  [ testCase "OneHotOverlap" $ oneHotOverlapRepr @?= oneHotOverlapRepr'-  , testCase "OneHotWide"    $ oneHotWideRepr    @?= oneHotWideRepr'-  , testCase "BinaryOverlap" $ countOverlapRepr  @?= countOverlapRepr'-  , testCase "BinaryWide"    $ countWideRepr     @?= countWideRepr'-  , testCase "Packed"        $ packedRepr        @?= packedRepr'-  , testCase "PackedMaybe"   $ packedMaybeRGB    @?= packedMaybeRGB'+  [ testCase "OneHotOverlapL"     $ oneHotOverlapLRepr     @?= oneHotOverlapLRepr'+  , testCase "OneHotOverlapR"     $ oneHotOverlapRRepr     @?= oneHotOverlapRRepr'+  , testCase "OneHotOverlapRec"   $ oneHotOverlapReprRec   @?= oneHotOverlapReprRec'+  , testCase "OneHotOverlapInfix" $ oneHotOverlapReprInfix @?= oneHotOverlapReprInfix'+  , testCase "OneHotWide"         $ oneHotWideRepr         @?= oneHotWideRepr'+  , testCase "BinaryOverlap"      $ countOverlapRepr       @?= countOverlapRepr'+  , testCase "BinaryWide"         $ countWideRepr          @?= countWideRepr'+  , testCase "Packed"             $ packedRepr             @?= packedRepr'+  , testCase "PackedMaybe"        $ packedMaybeRGB         @?= packedMaybeRGB'   ]
tests/Clash/Tests/DerivingDataReprTypes.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}  module Clash.Tests.DerivingDataReprTypes where@@ -31,3 +29,11 @@  deriveDefaultAnnotation [t| RGB |] deriveBitPack [t| RGB |]++data Headphones+  = InEar+      { _wireless :: Bool }+  | OverEar+      { _impedance :: SmallInt }++data EarCup = SmallInt :<>: SmallInt
+ tests/Clash/Tests/DumpVCD.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Clash.Tests.DumpVCD where++import Control.Monad (foldM)+import Control.Monad.Morph (generalize, hoist)+import Data.Binary (encode)+import Data.Map.Strict (Map)+import Data.Maybe (isJust)+import GHC.Stack (HasCallStack, withFrozenCallStack)+import Test.Tasty+import Test.Tasty.Hedgehog (testPropertyNamed)+import Type.Reflection (typeRep)++import Clash.Signal.Trace+import Clash.Sized.BitVector (BitVector, size#)+import Hedgehog.Extra (LockstepWalk (..), combinations, lockstepWalk)++import qualified Data.List as L+import qualified Data.Map.Strict as Map+import qualified Hedgehog as H+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++type SignalData = BitVector 32++failWithMsg :: (H.MonadTest m, HasCallStack) => String -> m a+failWithMsg msg = withFrozenCallStack $ H.annotate msg >> H.failure++data Metadata+  = Metadata+  { timeScale :: VCDTime+  , nameMap :: Map String IDCode+  }+  deriving (Show)++parseMetadata ::+  [DeclarationCommand] ->+  Either String Metadata+parseMetadata dcs = go Nothing Nothing dcs+ where+  go Nothing m (TimeScale t u : dcs0) = do+    let+      scale u0 =+        case u0 of+          S -> (* 1000) <$> scale MS+          MS -> (* 1000) <$> scale US+          US -> (* 1000) <$> scale NS+          NS -> (* 1000) <$> scale PS+          PS -> Right t+          FS -> Left "$timescale fs unsupported; raw time in ps"+    t0 <- scale u+    go (Just t0) m dcs0+  go ts Nothing (Vars vs : dcs0) = do+    map0 <- goVars Map.empty vs+    go ts (Just map0) dcs0+  go (Just ts) (Just m) [] = Right $ Metadata ts m+  go Nothing _ [] = Left "No $timescale in declarations"+  go _ Nothing [] = Left "No $scope section in declarations"+  go _ _ (TimeScale _ _ : _) = Left "Multiple $timescale sections in declarations"+  go _ _ (Vars _ : _) =+    -- This is not an error in VCD files, but we don't emit it so we don't handle it.+    Left "Don't know what to do with multiple $scope sections in declarations"++  goVars map0 [] = Right map0+  goVars map0 (Var{..} : vs)+    | Map.member varReference map0 =+        Left $ "Duplicate $var section for variable named " <> show varReference+    | otherwise = goVars (Map.insert varReference varIDCode map0) vs++-- Are time stamps in order? Do they start at 0? Is every time stamp followed by actual+-- data?+--+-- We exploit knowledge about how @dumpVCD@ formats the resulting file. The @fixedStart@+-- is not mandated by VCD, it's just what @dumpVCD@ currently outputs.+saneTimestamps ::+  (H.MonadTest m) =>+  LockstepWalk m SimulationCommand+saneTimestamps = LockstepWalk $ fixedStart (0 :: Int) []+ where+  fixedStart 3 [SimulationTime t0, DumpVars _, SimulationTime t1] end sc = do+    H.diff t1 (>=) 0+    H.diff t0 (<) t1+    go True t1 end sc+  fixedStart 3 starts _ _ =+    failWithMsg $+      "Simulation doesn't start with proper $dumpvars\n\n"+        <> "The simulation starts with:\n"+        <> show starts+  fixedStart n starts False sc = pure $ LockstepWalk $ fixedStart (n + 1) (starts ++ [sc])+  fixedStart _ _ True _ = failWithMsg "Simulation ends prematurely"++  go _ t0 _ (SimulationValueChange _) = pure $ LockstepWalk $ go False t0+  go False t0 False (SimulationTime t1) = H.diff t0 (<) t1 >> pure (LockstepWalk $ go True t1)+  go True t0 _ (SimulationTime _) =+    failWithMsg $ "At time " <> show t0 <> ": Timestamp without change data"+  go _ _ True sc@(SimulationTime _) =+    -- A simulation can't end with a timestamp, a timestamp is always followed by values.+    failWithMsg $ "The final simulation command is " <> show sc+  go _ _ _ (DumpVars _) =+    -- This is not an error in VCD files, but we don't emit it so we don't handle it.+    failWithMsg $ "Don't know what to do with multiple $dumpvars sections"++-- The signal changes every period. Are all the samples there, and are there no extra+-- samples?+signalCorrect ::+  forall m.+  (H.MonadTest m, HasCallStack) =>+  String ->+  IDCode ->+  VCDTime ->+  VCDTime ->+  [Value] ->+  LockstepWalk m SimulationCommand+signalCorrect name idCode period end es = LockstepWalk initF+ where+  initF _ (SimulationTime t) =+    pure $ LockstepWalk $ go t (zip (-1 : [0, period .. end]) es)+  initF _ sc =+    failWithMsg $ "First simulation command is not SimulationTime but " <> show sc++  go t es0 lastC (SimulationValueChange (ValueChange _ idCode0 v))+    | idCode /= idCode0 = checkFinal lastC es0 >> pure (LockstepWalk $ go t es0)+    | otherwise = do+        es1 <- parseChange t es0 idCode0 v+        checkFinal lastC es1+        pure $ LockstepWalk $ go t es1+  go _ es0 _ (SimulationTime t) = pure $ LockstepWalk $ go t es0+  go t es0 _ (DumpVars vars) = do+    es2 <-+      foldM+        (\es1 (ValueChange _ idCode0 val) -> parseChange t es1 idCode0 val)+        es0+        vars+    pure $ LockstepWalk $ go t es2++  checkFinal False _ = pure ()+  checkFinal True ((t, _) : _) = do+    annotateSignal+    failWithMsg $ "Sample at time " <> show t <> " never came"+  checkFinal True _ = pure ()++  parseChange _ es0 idCode0 _+    | idCode /= idCode0 = pure es0+  parseChange t (e : es1) _ v+    | (t, v) == e = pure es1+    | otherwise = do+        annotateSignal+        (t, v) H.=== e+        H.failure+  parseChange _ [] _ _ = do+    annotateSignal+    failWithMsg $ "Too many samples in VCD file"++  annotateSignal :: (HasCallStack) => m ()+  annotateSignal =+    withFrozenCallStack $+      H.annotate $+        "Signal name: "+          <> show name+          <> "\n"+          <> "Signal identifier code: "+          <> show idCode++{- | Check timing of individual signals when tracing multiple domains++If we have multiple signals, each with their own period, that change every sample, does+the resulting VCD contain all the samples at the right times, and do timestamps and value+changes strictly alternate?++This test would have caught the issue that PR #3076 fixed, and serves as a good+basic sanity check of VCD generation.+-}+multiDomainTrace :: H.Property+multiDomainTrace =+  H.property $+    -- By default, property tests run in @PropertyT IO@. But we do a /lot/ of binds, and+    -- I'm unsure whether binds have an inherent cost in 'IO'. It doesn't seem like it,+    -- but running in 'IO' also doesn't give us anything.+    -- So we run in @PropertyT Identity@ instead.+    hoist generalize $ do+      -- It seems silly to test a single signal, but we do want it as a shrink option just+      -- in case the error occurs even for a single signal.+      k <-+        H.forAll $+          Gen.shrink (\x -> if x > 1 then [1] else []) $+            Gen.int $+              Range.linear 2 4+      -- @common@ scales all periods by a common power of ten factor+      common <- H.forAll $ fmap (10 ^) $ Gen.integral_ $ Range.constant (0 :: Int) 4+      -- Interesting behavior of multiple signals is captured by the relation between them.+      -- The relation is defined by the ratios between the periods, which depends only on+      -- the prime factors they do not share. Hence, primes are excellent candidates. It+      -- feels prudent to also include 1 as the other extreme, where for /every/ sample of+      -- a slower signal, there is also a new sample of the fastest signal.+      periodFactors <- H.forAll $ combinations [1, 2, 3, 5, 7, 11, 13, 17, 19, 23] k+      -- Maybe add one more signal in one of the domains+      duplSignal <- H.forAll $ Gen.maybe $ Gen.integral_ $ Range.constant 0 (k - 1)+      let+        -- After @product periods@ time, the timing starts to repeat, so this seems a good+        -- time to stop.+        --+        -- Maximum duration is about 10,000 samples with the list of primes above. That+        -- does make the test run pretty long, though. It seems unlikely that an anomaly+        -- would show up only after 1,000 samples.+        --+        -- The end of sampling is defined pretty weirdly in 'dumpVCD' currently, but with+        -- this definition of @sampleDuration@, we should have enough samples and not+        -- oversample too much.+        sampleDuration = min 1000 $ product periodFactors + 10+        signalNames =+          take k ["a", "b", "c", "d"] ++ if isJust duplSignal then ["e"] else []+        periods = map (* common) periodFactors+        periods0+          | Just i <- duplSignal = periods ++ [periods !! i]+          | otherwise = periods+        traceMap = Map.fromAscList $ zipWith (\n p -> (n, oneTrace p)) signalNames periods0+      VCDFile vcdDecs vcdSims <- H.evalEither $ dumpVCD1# (0, sampleDuration) traceMap+      Metadata{..} <- H.evalEither $ parseMetadata vcdDecs+      Map.keysSet nameMap H.=== Map.keysSet traceMap+      -- 'dumpVCD' currently outputs timestamp 0 twice: once for $dumpvars and again for+      -- the first real value changes. But this is probably a bug; the standard doesn't+      -- say, and GTKWave and Surfer accept it, but it sounds like it's not well-formed.+      -- For now, we alter the timestamp for $dumpvars. The timestamp -1 is not valid in a+      -- VCD file, but we can match on it in our tests.+      vcdSims0 <-+        case L.uncons vcdSims of+          Just (sc, vcdSims1) ->+            sc H.=== SimulationTime 0 >> pure (SimulationTime (-1) : vcdSims1)+          Nothing ->+            failWithMsg "VCDFile has no SimulationCommands"+      let+        -- The end of sampling is defined pretty weirdly in 'dumpVCD' currently+        end = sampleDuration - 2+        signalCorrects =+          map+            ( \(name, (idCode, period, vs)) ->+                signalCorrect name idCode (period `div` timeScale) end vs+            )+            $ Map.assocs+            $ Map.intersectionWith+              (\idCode (_, period, _, vs) -> (idCode, period, vs))+              nameMap+              traceMap+      lockstepWalk (saneTimestamps : signalCorrects) vcdSims0+ where+  oneTrace period =+    ( encode (typeRep @SignalData)+    , period+    , size# (0 :: SignalData)+    , map (0,) [0 ..]+    )++tests :: TestTree+tests =+  testGroup+    "DumpVCD"+    [ testPropertyNamed "multiDomainTrace" "multiDomainTrace" $ multiDomainTrace+    ]
+ tests/Clash/Tests/Fixed.hs view
@@ -0,0 +1,500 @@+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}++module Clash.Tests.Fixed (tests) where++import Data.Bits (isSigned)+import Data.Proxy (Proxy(..))++import Test.Tasty+import Test.Tasty.Hedgehog.Extra++import Clash.Class.Num+import Clash.Sized.Fixed (Fixed(..), FracFixedC, NumFixedC, SFixed, UFixed)+import Clash.XException (errorX)++import GHC.TypeLits (KnownNat)++import Hedgehog+import Hedgehog.Extra (throwsException)+import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)+import qualified Hedgehog.Range as Range+import qualified Hedgehog.Gen as Gen++-- Saturate a number to be within certain bounds according to SaturationMode.+saturate+  :: RealFrac a+  => a  -- minBound+  -> a  -- maxBound+  -> a  -- repInt: the repetition interval of wrapping behaviour.+  -> SaturationMode+  -> a -> a+saturate minB _ repInt SatWrap x =+  let offs = x - minB+      offsW = minB + (offs - repInt * fromIntegral (floor @_ @Integer+                (offs / repInt)))+  in offsW+saturate minB maxB _ SatBound x+  | x < minB  = minB+  | x > maxB  = maxB+  | otherwise = x+saturate minB maxB _ SatZero x+  | x < minB  = 0+  | x > maxB  = 0+  | otherwise = x+saturate minB maxB _ SatSymmetric x+  | x < minB  = if minB < 0 then (-maxB) else minB+  | x > maxB  = maxB+  | otherwise = x+saturate minB maxB _ SatError x+  | x < minB  = errorX "saturate: underflow"+  | x > maxB  = errorX "saturate: overflow"+  | otherwise = x++-- Saturate to bounds of type b.+--+-- It assumes the following values for the repetition interval:+--   - 2*(-minBound) when minBound < 0+--   - floor maxBound + 1 otherwise+-- This is correct for at least:+-- - Unsigned: maxBound @(Unsigned 4) == 15, behaves as modulo 16+-- - Signed: minBound @(Signed 4) == -8, behaves as shifted modulo 16+-- - UFixed: maxBound @(UFixed 4 2) == 15.75, behaves as modulo 16+-- - SFixed: minBound @(SFixed 4 m) == -8.0, behaves as shifted modulo 16+saturateToBounded+  :: forall b+   . (Bounded b, Real b)+  => Proxy b+  -> SaturationMode+  -> Rational+  -> Rational+saturateToBounded Proxy satMode x =+  let repInt = if (minBound @b) < 0+               then 2 * negate (toRational (minBound @b))+               else 1 + toRational (floor @_ @Integer $ toRational $+                                      maxBound @b)+  in saturate (toRational (minBound @b)) (toRational (maxBound @b)) repInt+       satMode x+++satSuccProperty+  :: forall a+   . (SaturatingNum a, Real a, Show a)+  => Gen a+  -> Property+satSuccProperty genA = property $ do+  satMode <- forAll Gen.enumBounded+  a <- forAll genA++  case satMode of+    SatError+      | toRational (maxBound @a) - 1 < toRational a+      , toRational a <= toRational (maxBound @a)+      -> throwsException (satSucc satMode a)++    _ ->+      toRational (satSucc satMode a) ===+        saturateToBounded (Proxy @a) satMode (toRational a + 1)++satPredProperty+  :: forall a+   . (SaturatingNum a, Real a, Show a)+  => Gen a+  -> Property+satPredProperty genA = property $ do+  satMode <- forAll Gen.enumBounded+  a <- forAll genA++  case satMode of+    SatError+      | toRational (minBound @a) <= toRational a+      , toRational a < toRational (minBound @a) + 1+      -> throwsException (satPred satMode a)++    _ ->+      toRational (satPred satMode a) ===+        saturateToBounded (Proxy @a) satMode (toRational a - 1)++saturatingNumLaws+  :: (SaturatingNum a, Real a, Show a)+  => Gen a+  -> [TestTree]+saturatingNumLaws genA =+  [ testPropertyXXX "satSucc" $ satSuccProperty genA+  , testPropertyXXX "satPred" $ satPredProperty genA+  ]++testSaturationLaws+  :: (SaturatingNum a, Real a, Show a)+  => String+  -> Gen a+  -> TestTree+testSaturationLaws typeName genA = testGroup typeName (saturatingNumLaws genA)++-- Generates a random Fixed number in the given [inclusive,inclusive] range.+--+-- When the generator tries to shrink, it will shrink towards the origin of the+-- specified Range.+genFixed+  :: ( MonadGen m+     , NumFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Range f+  -> m f+genFixed range = fmap Fixed $ Gen.integral $ fmap unFixed range++-- Note that the ranges defined in Hedgehog.Range for Fractional do not interact+-- correctly with a datatype that is also Bounded, hence these variants.+rangeLinearFixed+  :: ( NumFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => f+  -> f+  -> Range f+rangeLinearFixed x y = fmap Fixed $ Range.linear (unFixed x) (unFixed y)++rangeLinearFixedBounded+  :: NumFixedC rep int frac+  => Range (Fixed rep int frac)+rangeLinearFixedBounded = fmap Fixed Range.linearBounded++-- | Generates a Fixed number with a bias towards extreme values:+--+--     10%: uniform [minBound, minBound + 1]+--     10%: uniform [maxBound - 1, maxBound]+--      5%: 0+--     75%: uniform [minBound, maxBound]+genBoundBiased+  :: forall f rep int frac+   . ( NumFixedC rep int frac+     , f ~ Fixed rep int frac+     )+   => Gen f+genBoundBiased = Gen.frequency+  [ (10, genFixed $ rangeLinearFixed (minBound + 1) minBound)+  , (10, genFixed $ rangeLinearFixed (maxBound - 1) (maxBound))+  , ( 5, pure 0)+  , (75, genFixed $ rangeLinearFixedBounded)]++genBoundBiasedS :: forall a b. (KnownNat a, KnownNat b) => Gen (SFixed a b)+genBoundBiasedS = genBoundBiased++genBoundBiasedU :: forall a b. (KnownNat a, KnownNat b) => Gen (UFixed a b)+genBoundBiasedU = genBoundBiased++saturationTests :: TestTree+saturationTests = testGroup "SaturatingNum"+  [ testSaturationLaws "SFixed 0 0" (genBoundBiasedS @0 @0)+  , testSaturationLaws "SFixed 0 1" (genBoundBiasedS @0 @1)+  , testSaturationLaws "SFixed 1 0" (genBoundBiasedS @1 @0)+  , testSaturationLaws "SFixed 0 2" (genBoundBiasedS @0 @2)+  , testSaturationLaws "SFixed 1 1" (genBoundBiasedS @1 @1)+  , testSaturationLaws "SFixed 2 0" (genBoundBiasedS @2 @0)+  , testSaturationLaws "SFixed 1 2" (genBoundBiasedS @1 @2)+  , testSaturationLaws "SFixed 2 1" (genBoundBiasedS @2 @1)+  , testSaturationLaws "SFixed 2 2" (genBoundBiasedS @2 @2)+  , testSaturationLaws "SFixed 7 7" (genBoundBiasedS @7 @7)+  , testSaturationLaws "SFixed 121 121" (genBoundBiasedS @121 @121)+  , testSaturationLaws "SFixed 128 128" (genBoundBiasedS @128 @128)++  , testSaturationLaws "UFixed 0 0" (genBoundBiasedU @0 @0)+  , testSaturationLaws "UFixed 0 1" (genBoundBiasedU @0 @1)+  , testSaturationLaws "UFixed 1 0" (genBoundBiasedU @1 @0)+  , testSaturationLaws "UFixed 0 2" (genBoundBiasedU @0 @2)+  , testSaturationLaws "UFixed 1 1" (genBoundBiasedU @1 @1)+  , testSaturationLaws "UFixed 2 0" (genBoundBiasedU @2 @0)+  , testSaturationLaws "UFixed 1 2" (genBoundBiasedU @1 @2)+  , testSaturationLaws "UFixed 2 1" (genBoundBiasedU @2 @1)+  , testSaturationLaws "UFixed 2 2" (genBoundBiasedU @2 @2)+  , testSaturationLaws "UFixed 7 7" (genBoundBiasedU @7 @7)+  , testSaturationLaws "UFixed 121 121" (genBoundBiasedU @121 @121)+  , testSaturationLaws "UFixed 128 128" (genBoundBiasedU @128 @128)+  ]++-- | Test pred for Fixed+--+-- Edges where behavior changes are picked explicitly:+--  2 % minBound+--  2 % highest value that causes an exception+--  2 % minBound + 1+--  2 % maxBound+-- 41 % uniform [minBound, minBound + 1)+-- 41 % uniform [minBound + 1, maxBound]+--+--  Note that for types with many integral bits, the two uniform ranges have+--  vastly different sizes. The range that causes exceptions is included+--  separately so numbers in that range will be part of a test run.+predProperty+  :: forall f rep int frac+   . ( NumFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Proxy f+  -> Property+predProperty Proxy = property $ do+  let excHi = Fixed $ satPred SatBound $ unFixed valLo+      valLo = satSucc SatBound minBound+  x :: f <- forAll $ Gen.frequency+                     [ (2, pure minBound)+                     , (2, pure excHi)+                     , (2, pure valLo)+                     , (2, pure maxBound)+                     , (41, genFixed $ rangeLinearFixed excHi minBound)+                     , (41, genFixed $ rangeLinearFixed valLo maxBound)]+  if toRational x - 1 < toRational (minBound @f) then do+    throwsException (pred x)+  else do+    toRational (pred x) === toRational x - 1++-- | Test succ for Fixed+--+-- Edges where behaviour changes are picked explicitly:+--  2 % minBound+--  2 % maxBound - 1+--  2 % lowest value that causes an exception+--  2 % maxBound+-- 41 % uniform (maxBound - 1, maxBound]+-- 41 % uniform [minBound, maxBound - 1]+--+--  Note that for types with many integral bits, the two uniform ranges have+--  vastly different sizes. The range that causes exceptions is included+--  separately so numbers in that range will be part of a test run.+succProperty+  :: forall f rep int frac+   . ( NumFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Proxy f+  -> Property+succProperty Proxy = property $ do+  let valHi = satPred SatBound maxBound+      excLo = Fixed $ satSucc SatBound $ unFixed valHi+  x :: f <- forAll $ Gen.frequency+                     [ (2, pure minBound)+                     , (2, pure valHi)+                     , (2, pure excLo)+                     , (2, pure maxBound)+                     , (41, genFixed $ rangeLinearFixed excLo maxBound)+                     , (41, genFixed $ rangeLinearFixed valHi minBound)]+  if toRational x + 1 > toRational (maxBound @f) then do+    throwsException (succ x)+  else do+    toRational (succ x) === toRational x + 1++-- The maximum length of lists we generate as test cases.+--+-- Property tests might overshoot this by a small amount, but no more than that.+maxLength :: Num n => n+maxLength = 1000++-- Verify generated list is as expected+--+-- Filters those rs that cannot and therefore should not occur in fs.+--+-- Also asserts the length is within reasonable bounds. Property tests might+-- overshoot `maxLength` by a small amount, but not more than that. But if some+-- change broke our candidate number generation in the property tests, we might+-- end up generating really long lists, which might take really long or possibly+-- a (practically) infinite amount of time to compute. While the bug or change+-- is probably not in the verified property itself, it still is an indication+-- something broke or needs to be adjusted, hence unittest failure is+-- reasonable.+listsEqual+  :: forall f rep int frac m+   . ( NumFixedC rep int frac+     , f ~ Fixed rep int frac+     , MonadTest m+     , HasCallStack+     )+  => [f]+  -> [Rational]+  -> m ()+listsEqual fs rs0 = withFrozenCallStack $ do+  let limit = 2 * maxLength+      minVal = toRational $ minBound @f+      maxVal = toRational $ maxBound @f+      rs = take limit $ takeWhile (\r -> r >= minVal && r <= maxVal) rs0+  assert (length rs < limit)+  take limit (map toRational fs) === rs++-- Round fromRational towards specific value+--+-- fromRational for Fixed rounds towards negative infinity.+-- fromRationalTowards to x rounds x towards to.+fromRationalTowards+  :: forall rep int frac+   . FracFixedC rep int frac+  => Fixed rep int frac+  -> Rational+  -> Fixed rep int frac+fromRationalTowards to x+  | toRational to < x = fromRational x+  | isSigned to       = negate $ fromRational $ negate x+  | otherwise         = let mb = maxBound :: Fixed rep int frac+                        in mb - fromRational (toRational mb - x)++enumFromProperty+  :: forall f rep int frac+   . ( FracFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Proxy f+  -> Property+enumFromProperty Proxy = property $ do+  let minVal = if toRational (maxBound @f) < maxLength then+                 minBound+               else+                 maxBound - maxLength+  x1 :: f <- forAll $ genFixed $ rangeLinearFixed minVal maxBound+  footnote $ "x1 = Fixed " ++ show (toInteger $ unFixed x1)+  listsEqual (enumFrom x1) (enumFrom (toRational x1))++enumFromThenProperty+  :: forall f rep int frac+   . ( FracFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Proxy f+  -> Property+enumFromThenProperty Proxy = property $ do+  x1 :: f <- forAll $ genFixed rangeLinearFixedBounded+  footnote $ "x1 = Fixed " ++ show (toInteger $ unFixed x1)+  approxLen <- forAll $ Gen.int $ Range.linear 0 maxLength+  footnote $ "approxLen = " ++ show approxLen+  let x2Range y = ( if approxLen <= 1 then+                      y+                    else+                      fromRational+                        $ toRational x1 +   (toRational y - toRational x1)+                                          / (toRational approxLen - 1)+                  , fromRational+                      $ toRational x1 +   (toRational y - toRational x1)+                                        / (toRational approxLen + 1))+  x2 :: f <- forAll $ Gen.choice+                      [ genFixed $ uncurry Range.constant $ x2Range minBound+                      , genFixed $ uncurry Range.constant $ x2Range maxBound+                      ]+  footnote $ "x2 = Fixed " ++ show (toInteger $ unFixed x2)+  let fs = enumFromThen x1 x2+      rs = enumFromThen (toRational x1) (toRational x2)+  if (x1 == x2) then do+    take 10 (map toRational fs) === take 10 rs+  else do+    listsEqual fs rs++enumFromToProperty+  :: forall f rep int frac+   . ( FracFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Proxy f+  -> Property+enumFromToProperty Proxy = property $ do+  x1 :: f <- forAll $ genFixed rangeLinearFixedBounded+  footnote $ "x1 = Fixed " ++ show (toInteger $ unFixed x1)+  let (minVal, maxVal) = if toRational (maxBound @f) < maxLength then+                           (minBound, maxBound)+                         else+                           (x1 - maxLength, x1 + maxLength)+  y :: f <- forAll $ genFixed $ rangeLinearFixed minVal maxVal+  footnote $ "y = Fixed " ++ show (toInteger $ unFixed y)+  listsEqual (enumFromTo x1 y) (enumFromTo (toRational x1) (toRational y))++enumFromThenToProperty+  :: forall f rep int frac+   . ( FracFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Proxy f+  -> Property+enumFromThenToProperty Proxy = property $ do+  x1 :: f <- forAll $ genFixed rangeLinearFixedBounded+  footnote $ "x1 = Fixed " ++ show (toInteger $ unFixed x1)+  let closeToMin =+        minBound @f ++        fromRational ((toRational x1 - toRational (minBound @f)) / 4)+      closeToMax =+        maxBound @f -+        fromRational ((toRational (maxBound @f) - toRational x1) / 4)+  y :: f <- forAll $ Gen.frequency+                       [ (10, genFixed $ rangeLinearFixed closeToMin minBound)+                       , (10, genFixed $ rangeLinearFixed closeToMax maxBound)+                       , (80, genFixed $ rangeLinearFixedBounded)]+  footnote $ "y = Fixed " ++ show (toInteger $ unFixed y)+  approxLen <- forAll $ Gen.int $ Range.linear 0 maxLength+  footnote $ "approxLen = " ++ show approxLen+  let (revBound, fwdBound) = if y < x1 then+                               (maxBound @f, minBound @f)+                             else+                               (minBound, maxBound)+      minX2 = if approxLen <= 1 then+                y+              else+                fromRationalTowards y+                  (toRational x1 +   (toRational y - toRational x1)+                                   / (toRational approxLen - 1))+      maxX2 = fromRationalTowards y+                  (toRational x1 +  (toRational y - toRational x1)+                                  / (toRational approxLen + 1))+  x2 :: f <- forAll $ Gen.frequency+                      [ (2, pure x1)+                      , (2, genFixed $ rangeLinearFixed x1 revBound)+                      , (2, genFixed $ rangeLinearFixed y fwdBound)+                      , (94, genFixed $ Range.constant minX2 maxX2)]+  footnote $ "x2 = Fixed " ++ show (toInteger $ unFixed x2)+  let fs = enumFromThenTo x1 x2 y+      rs = enumFromThenTo (toRational x1) (toRational x2) (toRational y)+  if (x1 == x2) then do+    take 10 (map toRational fs) === take 10 rs+  else do+    listsEqual fs rs++enumProperties+  :: forall f rep int frac+   . ( FracFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Proxy f+  -> [TestTree]+enumProperties pf =+  [ testPropertyXXX "pred" $ predProperty pf+  , testPropertyXXX "succ" $ succProperty pf+  , testPropertyXXX "enumFrom" $ enumFromProperty pf+  , testPropertyXXX "enumFromThen" $ enumFromThenProperty pf+  , testPropertyXXX "enumFromTo" $ enumFromToProperty pf+  , testPropertyXXX "enumFromThenTo" $ enumFromThenToProperty pf+  ]++testEnumProperties+  :: forall f rep int frac+   . ( FracFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => String+  -> Proxy f+  -> TestTree+testEnumProperties typeName pf = testGroup typeName (enumProperties pf)++-- Small types are tested exhaustively in Clash.Tests.FixedExhaustive+enumTests :: TestTree+enumTests =+  testGroup "Enum"+    [ testEnumProperties "SFixed 7 7" (Proxy @(SFixed 7 7))+    , testEnumProperties "SFixed 121 121" (Proxy @(SFixed 121 121))+    , testEnumProperties "SFixed 128 128" (Proxy @(SFixed 128 128))+    , testEnumProperties "UFixed 7 7" (Proxy @(UFixed 7 7))+    , testEnumProperties "UFixed 121 121" (Proxy @(UFixed 121 121))+    , testEnumProperties "UFixed 128 128" (Proxy @(UFixed 128 128))+    ]++tests :: TestTree+tests =+  testGroup "Fixed"+    [ saturationTests+    , enumTests+    ]
+ tests/Clash/Tests/FixedExhaustive.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}++module Clash.Tests.FixedExhaustive (tests) where++import Data.Proxy (Proxy(..))+import Data.Typeable (typeRep)++import Test.Tasty+import Test.Tasty.HUnit++import Clash.Sized.Fixed (Fixed(..), FracFixedC, SFixed, UFixed)++listsEqual+  :: forall f rep int frac+   . ( FracFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => String+  -> [f]+  -> [Rational]+  -> Assertion+listsEqual prefix fs0 rs0 = do+  let limit = 1000+      minVal = toRational $ minBound @f+      maxVal = toRational $ maxBound @f+      fs = take limit (map toRational fs0)+      rs = take limit $ takeWhile (\r -> r >= minVal && r <= maxVal) rs0+  assertBool (prefix ++ "length rs > maxLength") (length rs < limit)+  assertBool (prefix ++ show fs ++ "\n/=\n" ++ show rs) (fs == rs)++forAllEnumFrom+  :: forall f rep int frac+   . ( FracFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Proxy f+  -> Assertion+forAllEnumFrom Proxy = sequence_+  [ listsEqual ("x1 = Fixed " ++ show (toInteger $ unFixed x1))+               (enumFrom x1)+               (enumFrom (toRational x1))+  | x1 :: f <- map Fixed [minBound..]]++forAllEnumFromThen+  :: forall f rep int frac+   . ( FracFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Proxy f+  -> Assertion+forAllEnumFromThen Proxy = sequence_+  [ let fs = enumFromThen x1 x2+        rs = enumFromThen (toRational x1) (toRational x2)+        prefix = unlines [ "x1 = Fixed " ++ show (toInteger $ unFixed x1)+                         , "x2 = Fixed " ++ show (toInteger $ unFixed x2)]+    in if (x1 == x2) then+         listsEqual prefix (take 10 fs) (take 10 rs)+       else+         listsEqual prefix fs rs+  | x1 :: f <- map Fixed [minBound..]+  , x2 <- map Fixed [minBound..]]++forAllEnumFromTo+  :: forall f rep int frac+   . ( FracFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Proxy f+  -> Assertion+forAllEnumFromTo Proxy = sequence_+  [ listsEqual (unlines [ "x1 = Fixed " ++ show (toInteger $ unFixed x1)+                        , "y = Fixed " ++ show (toInteger $ unFixed y)])+               (enumFromTo x1 y)+               (enumFromTo (toRational x1) (toRational y))+  | x1 :: f <- map Fixed [minBound..]+  , y <- map Fixed [minBound..]]++forAllEnumFromThenTo+  :: forall f rep int frac+   . ( FracFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Proxy f+  -> Assertion+forAllEnumFromThenTo Proxy = sequence_+  [ let fs = enumFromThenTo x1 x2 y+        rs = enumFromThenTo (toRational x1) (toRational x2) (toRational y)+        prefix = unlines [ "x1 = Fixed " ++ show (toInteger $ unFixed x1)+                         , "x2 = Fixed " ++ show (toInteger $ unFixed x2)+                         , "y = Fixed " ++ show (toInteger $ unFixed y)]+    in if (x1 == x2) then+         listsEqual prefix (take 10 fs) (take 10 rs)+       else+         listsEqual prefix fs rs+  | x1 :: f <- map Fixed [minBound..]+  , x2 <- map Fixed [minBound..]+  , y <- map Fixed [minBound..]]++enumTests+  :: forall f rep int frac+   . ( FracFixedC rep int frac+     , f ~ Fixed rep int frac+     )+  => Proxy f+  -> TestTree+enumTests pf =+  testGroup (show $ typeRep pf)+    [ testCase "enumFrom" $ forAllEnumFrom pf+    , testCase "enumFromThen" $ forAllEnumFromThen pf+    , testCase "enumFromTo" $ forAllEnumFromTo pf+    , testCase "enumFromThenTo" $ forAllEnumFromThenTo pf ]++tests :: TestTree+tests =+  testGroup "FixedExhaustive"+    [ enumTests (Proxy @(SFixed 0 0))+    , enumTests (Proxy @(SFixed 0 1))+    , enumTests (Proxy @(SFixed 1 0))+    , enumTests (Proxy @(SFixed 0 2))+    , enumTests (Proxy @(SFixed 1 1))+    , enumTests (Proxy @(SFixed 2 0))+    , enumTests (Proxy @(SFixed 0 3))+    , enumTests (Proxy @(SFixed 1 2))+    , enumTests (Proxy @(SFixed 2 1))+    , enumTests (Proxy @(SFixed 3 0))+    , enumTests (Proxy @(SFixed 0 4))+    , enumTests (Proxy @(SFixed 1 3))+    , enumTests (Proxy @(SFixed 2 2))+    , enumTests (Proxy @(SFixed 3 1))+    , enumTests (Proxy @(SFixed 4 0))+    , enumTests (Proxy @(UFixed 0 0))+    , enumTests (Proxy @(UFixed 0 1))+    , enumTests (Proxy @(UFixed 1 0))+    , enumTests (Proxy @(UFixed 0 2))+    , enumTests (Proxy @(UFixed 1 1))+    , enumTests (Proxy @(UFixed 2 0))+    , enumTests (Proxy @(UFixed 0 3))+    , enumTests (Proxy @(UFixed 1 2))+    , enumTests (Proxy @(UFixed 2 1))+    , enumTests (Proxy @(UFixed 3 0))+    , enumTests (Proxy @(UFixed 0 4))+    , enumTests (Proxy @(UFixed 1 3))+    , enumTests (Proxy @(UFixed 2 2))+    , enumTests (Proxy @(UFixed 3 1))+    , enumTests (Proxy @(UFixed 4 0))+    ]
+ tests/Clash/Tests/Index.hs view
@@ -0,0 +1,25 @@+module Clash.Tests.Index (tests) where++import Data.Bits (Bits(shiftR))+import Test.Tasty+import Test.Tasty.HUnit++import Clash.Sized.Internal.Index (Index)++import Test.Tasty.HUnit.Extra (expectException)++tests :: TestTree+tests = testGroup "Index"+  [ testGroup "shiftR"+    [ testCase "shiftR 5 0 == 5" $+        shiftR (5 :: Index 128) 0 @?= 5+    , testCase "returns 0 when n == bitSize" $+        shiftR (127 :: Index 128) 7 @?= 0+    , testCase "returns 0 when n > bitSize" $+        shiftR (127 :: Index 128) (7 + 1) @?= 0+    , testCase "returns 0 when n >> bitSize" $+        shiftR (127 :: Index 128) (7 + 1000) @?= 0+    , testCase "undefined when n < 0" $+        expectException (shiftR (1 :: Index 128) (-1))+    ]+  ]
+ tests/Clash/Tests/Laws/Enum.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE RankNTypes #-}++module Clash.Tests.Laws.Enum (tests) where++import Control.DeepSeq (NFData)+import Data.Proxy+import Test.Tasty+import Test.Tasty.HUnit++import Clash.Sized.Index (Index)+import Clash.Sized.Signed (Signed)+import Clash.Sized.Unsigned (Unsigned)++import Test.Tasty.HUnit.Extra++succMaxBoundLaw ::+  forall a .+  (NFData a, Show a, Enum a, Bounded a) =>+  Proxy a ->+  Assertion+succMaxBoundLaw Proxy = expectException (succ @a maxBound)++predMinBoundLaw ::+  forall a .+  (NFData a, Show a, Enum a, Bounded a) =>+  Proxy a ->+  Assertion+predMinBoundLaw Proxy = expectException (pred @a minBound)++enumLaws ::+  (NFData a, Show a, Enum a, Bounded a) =>+  Proxy a ->+  [TestTree]+enumLaws proxy =+  [ testCase "succ maxBound ~ _|_" (succMaxBoundLaw proxy)+  , testCase "pred minBound ~ _|_" (predMinBoundLaw proxy)+  ]++testEnumLaws ::+  (NFData a, Show a, Enum a, Bounded a) =>+  String ->+  Proxy a ->+  TestTree+testEnumLaws typeName proxy = testGroup typeName (enumLaws proxy)++tests :: TestTree+tests = testGroup "Enum"+  [ testEnumLaws "Index 1" (Proxy @(Index 1))+  , testEnumLaws "Index 2" (Proxy @(Index 2))+  , testEnumLaws "Index 128" (Proxy @(Index 128))++  , testEnumLaws "Unsigned 0" (Proxy @(Unsigned 0))+  , testEnumLaws "Unsigned 1" (Proxy @(Unsigned 1))+  , testEnumLaws "Unsigned 32" (Proxy @(Unsigned 32))+  , testEnumLaws "Unsigned 127" (Proxy @(Unsigned 127))+  , testEnumLaws "Unsigned 128" (Proxy @(Unsigned 128))++  , testEnumLaws "Signed 0" (Proxy @(Signed 0))+  , testEnumLaws "Signed 1" (Proxy @(Signed 1))+  , testEnumLaws "Signed 32" (Proxy @(Signed 32))+  , testEnumLaws "Signed 127" (Proxy @(Signed 127))+  , testEnumLaws "Signed 128" (Proxy @(Signed 128))++  -- Note Fixed is tested elsewhere.+  ]
+ tests/Clash/Tests/Laws/Num.hs view
@@ -0,0 +1,51 @@+module Clash.Tests.Laws.Num (tests) where++import Clash.Tests.Laws.SaturatingNum+  ( genBoundedIntegral+  , genUnsigned+  )++import Test.Tasty+import Test.Tasty.Hedgehog.Extra++import Clash.Sized.BitVector (Bit, BitVector)++import Control.DeepSeq (NFData)+import GHC.TypeLits (KnownNat)++import Hedgehog++genBit :: Gen Bit+genBit = genBoundedIntegral++genBitVector :: forall n. KnownNat n => Gen (BitVector n)+genBitVector = genBoundedIntegral++additiveInverse :: (Num a, Show a, Eq a) => Gen a -> TestTree+additiveInverse genA = testPropertyXXX "x + negate x == 0" $ property $ do+  a <- forAll genA+  a + negate a === 0++testAdditiveInverse :: (NFData a, Ord a, Show a, Eq a, Num a) => String -> Gen a -> TestTree+testAdditiveInverse typeName genA =+  testGroup typeName [testGroup "additiveInverse" [additiveInverse genA]]++tests :: TestTree+tests = testGroup "Num"+  [ testAdditiveInverse "Bit" genBit++  , testAdditiveInverse "Unsigned 0" (genUnsigned @0)+  , testAdditiveInverse "Unsigned 1" (genUnsigned @1)+  , testAdditiveInverse "Unsigned 32" (genUnsigned @32)+  , testAdditiveInverse "Unsigned 127" (genUnsigned @127)+  , testAdditiveInverse "Unsigned 128" (genUnsigned @128)++  , testAdditiveInverse "BitVector 0" (genBitVector @0)+  , testAdditiveInverse "BitVector 1" (genBitVector @1)+  , testAdditiveInverse "BitVector 32" (genBitVector @32)+  , testAdditiveInverse "BitVector 127" (genBitVector @127)+  , testAdditiveInverse "BitVector 128" (genBitVector @128)++  -- TODO: Index, Signed, UFixed, SFixed. See discussion in+  --       https://github.com/clash-lang/clash-compiler/issues/3015+  ]
+ tests/Clash/Tests/Laws/SaturatingNum.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE RankNTypes #-}++{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}++module Clash.Tests.Laws.SaturatingNum+  ( tests++  , genBoundedIntegral+  , genIndex+  , genSFixed+  , genSigned+  , genUFixed+  , genUnsigned+  ) where++import Test.Tasty+import Test.Tasty.Hedgehog.Extra+import Test.Tasty.HUnit+import Test.Tasty.HUnit.Extra++import Clash.Class.Num+import Clash.Sized.Index (Index)+import Clash.Sized.Signed (Signed)+import Clash.Sized.Fixed (SFixed, UFixed)+import Clash.Sized.Unsigned (Unsigned)++import Control.DeepSeq (NFData)+import GHC.TypeLits (KnownNat)++import Hedgehog+import qualified Hedgehog.Range as Range+import qualified Hedgehog.Gen as Gen++type TestWrap = Bool++type SaturationLaw a =+  (Ord a, Show a, Eq a, SaturatingNum a) =>+  Gen a ->+  Assertion++-- Check that all modes apart from SatError are total. SatError cannot be total+-- as it throws an XException on overflow/underflow.+isTotal ::+  forall a.+  (NFData a, Show a, Eq a) =>+  (SaturationMode -> a -> a -> a) ->+  Gen a ->+  Property+isTotal f genA = property $ do+  satMode <- forAll Gen.enumBounded+  a <- forAll genA+  b <- forAll genA++  if isTotalMode satMode+     then evalNF (f satMode a b) *> success+     else success+ where+  isTotalMode SatError = False+  isTotalMode _ = True++satWrapOverflowLaw :: forall a. SaturationLaw a+satWrapOverflowLaw _ = satSucc @a SatWrap maxBound @?= minBound++satWrapUnderflowLaw :: forall a. SaturationLaw a+satWrapUnderflowLaw _ = satPred @a SatWrap minBound @?= maxBound++satBoundOverflowLaw :: forall a. SaturationLaw a+satBoundOverflowLaw _ = satSucc @a SatBound maxBound @?= maxBound++satBoundUnderflowLaw :: forall a. SaturationLaw a+satBoundUnderflowLaw _ = satPred @a SatBound minBound @?= minBound++satZeroOverflowLaw :: forall a. SaturationLaw a+satZeroOverflowLaw _ = satSucc @a SatZero maxBound @?= 0++satZeroUnderflowLaw :: forall a. SaturationLaw a+satZeroUnderflowLaw _ = satPred @a SatZero minBound @?= 0++satErrorOverflowLaw :: forall a. SaturationLaw a+satErrorOverflowLaw _ = expectXException (satSucc @a SatError maxBound)++satErrorUnderflowLaw :: forall a. SaturationLaw a+satErrorUnderflowLaw _ = expectXException (satPred @a SatError minBound)++satSymmetricOverflow :: forall a. SaturationLaw a+satSymmetricOverflow _ = satSucc @a SatSymmetric maxBound @?= maxBound++satSymmetricUnderflow :: forall a. SaturationLaw a+satSymmetricUnderflow _ =+  if minBound @a < 0 then+    -- Signed number+    satPred @a SatSymmetric minBound @?= satSucc SatWrap minBound+  else+    -- Unsigned number (or zero-width)+    satPred @a SatSymmetric minBound @?= minBound++saturatingNumLaws ::+  (NFData a, Ord a, Show a, Eq a, SaturatingNum a) =>+  TestWrap ->+  Gen a ->+  [TestTree]+saturatingNumLaws testEnum genA =+  (if testEnum then+    [ testCase "SatWrap: Wrap around on overflow" (satWrapOverflowLaw genA)+    , testCase "SatWrap: Wrap around on underflow" (satWrapUnderflowLaw genA)+    , testCase "SatSymmetric: Become maxBound on overflow"+               (satSymmetricOverflow genA)+    , testCase "SatSymmetric: Become minBound or minBound+1 on underflow"+               (satSymmetricUnderflow genA)+    , testCase "SatBound: Become maxBound on overflow"+               (satBoundOverflowLaw genA)+    , testCase "SatBound: Become minBound on underflow"+               (satBoundUnderflowLaw genA)+    , testCase "SatZero: Become 0 on overflow" (satZeroOverflowLaw genA)+    , testCase "SatZero: Become 0 on underflow" (satZeroUnderflowLaw genA)+    , testCase "SatError: Error on overflow" (satErrorOverflowLaw genA)+    , testCase "SatError: Error on underflow" (satErrorUnderflowLaw genA)+    ]+  else+    []) <>+  [ testPropertyXXX "satAddTotal" (isTotal satAdd genA)+  , testPropertyXXX "satSubTotal" (isTotal satSub genA)+  , testPropertyXXX "satMulTotal" (isTotal satMul genA)+  ]++testSaturationLaws ::+  (NFData a, Ord a, Show a, Eq a, SaturatingNum a) =>+  TestWrap ->+  String ->+  Gen a ->+  TestTree+testSaturationLaws testEnum typeName genA =+  testGroup typeName (saturatingNumLaws testEnum genA)++-- | Generates a bounded integral with a bias towards extreme values:+--+--      5%: minBound+--      5%: maxBound+--      5%: 0+--     85%: uniform [minBound, maxBound]+--+genBoundedIntegral :: (Integral a, Bounded a) => Gen a+genBoundedIntegral = Gen.frequency+  [ (5,  pure minBound)+  , (5,  pure maxBound)+  , (5,  pure 0)+  , (85, Gen.integral (Range.linear minBound maxBound)) ]++genIndex :: forall n. KnownNat n => Gen (Index n)+genIndex = genBoundedIntegral++genUnsigned :: forall n. KnownNat n => Gen (Unsigned n)+genUnsigned = genBoundedIntegral++genSigned :: forall n. KnownNat n => Gen (Signed n)+genSigned = genBoundedIntegral++-- | Generates a bounded fractional with a bias towards extreme values:+--+--      5%: minBound+--      5%: maxBound+--      5%: 0.0+--     85%: uniform [minBound, maxBound]+--+genBoundedFractional :: forall a. (Real a, Fractional a, Bounded a) => Gen a+genBoundedFractional = Gen.frequency+  [ (5,  pure minBound)+  , (5,  pure maxBound)+  , (5,  pure 0.0)+  , (85,   fmap (fromRational . toRational)+         $ Gen.double+         $ fmap fromRational+         $ Range.linearFrac+             (toRational (minBound @a))+             (toRational (maxBound @a))) ]++genSFixed :: forall a b. (KnownNat a, KnownNat b) => Gen (SFixed a b)+genSFixed = genBoundedFractional++genUFixed :: forall a b. (KnownNat a, KnownNat b) => Gen (UFixed a b)+genUFixed = genBoundedFractional++tests :: TestTree+tests = testGroup "SaturatingNum"+  [ testSaturationLaws True "Index 1" (genIndex @1)+  , testSaturationLaws True "Index 2" (genIndex @2)+  , testSaturationLaws True "Index 128" (genIndex @128)++  , testSaturationLaws True "Unsigned 0" (genUnsigned @0)+  , testSaturationLaws True "Unsigned 1" (genUnsigned @1)+  , testSaturationLaws True "Unsigned 32" (genUnsigned @32)+  , testSaturationLaws True "Unsigned 127" (genUnsigned @127)+  , testSaturationLaws True "Unsigned 128" (genUnsigned @128)++  , testSaturationLaws True "Signed 0" (genSigned @0)+  , testSaturationLaws True "Signed 1" (genSigned @1)+  , testSaturationLaws True "Signed 32" (genSigned @32)+  , testSaturationLaws True "Signed 127" (genSigned @127)+  , testSaturationLaws True "Signed 128" (genSigned @128)++  , testSaturationLaws False "SFixed 0 0" (genSFixed @0 @0)+  , testSaturationLaws False "SFixed 0 1" (genSFixed @0 @1)+  , testSaturationLaws False "SFixed 1 0" (genSFixed @1 @0)+  , testSaturationLaws False "SFixed 0 2" (genSFixed @0 @2)+  , testSaturationLaws False "SFixed 1 1" (genSFixed @1 @1)+  , testSaturationLaws False "SFixed 2 0" (genSFixed @2 @0)+  , testSaturationLaws False "SFixed 1 2" (genSFixed @1 @2)+  , testSaturationLaws False "SFixed 2 1" (genSFixed @2 @1)+  , testSaturationLaws False "SFixed 2 2" (genSFixed @2 @2)+  , testSaturationLaws False "SFixed 7 7" (genSFixed @7 @7)+  , testSaturationLaws False "SFixed 121 121" (genSFixed @121 @121)+  , testSaturationLaws False "SFixed 128 128" (genSFixed @128 @128)++  , testSaturationLaws False "UFixed 0 0" (genUFixed @0 @0)+  , testSaturationLaws False "UFixed 0 1" (genUFixed @0 @1)+  , testSaturationLaws False "UFixed 1 0" (genUFixed @1 @0)+  , testSaturationLaws False "UFixed 0 2" (genUFixed @0 @2)+  , testSaturationLaws False "UFixed 1 1" (genUFixed @1 @1)+  , testSaturationLaws False "UFixed 2 0" (genUFixed @2 @0)+  , testSaturationLaws False "UFixed 1 2" (genUFixed @1 @2)+  , testSaturationLaws False "UFixed 2 1" (genUFixed @2 @1)+  , testSaturationLaws False "UFixed 2 2" (genUFixed @2 @2)+  , testSaturationLaws False "UFixed 7 7" (genUFixed @7 @7)+  , testSaturationLaws False "UFixed 121 121" (genUFixed @121 @121)+  , testSaturationLaws False "UFixed 128 128" (genUFixed @128 @128)+  ]
+ tests/Clash/Tests/MaybeNumConvert.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}++{- |+Copyright  :  (C) 2025     , Martijn Bastiaan+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Test generation of 'MaybeNumConvert' instances:++> for a in ["Index", "Unsigned", "Signed", "BitVector"]:+>     for b in ["Index", "Unsigned", "Signed", "BitVector"]:+>          ia_max = "indexMax" if a == "Index" else "otherMax"+>          ib_max = "indexMax" if b == "Index" else "otherMax"+>          n = "(n + 1)" if a == "Index" else "n"+>          m = "(m + 1)" if b == "Index" else "m"+>          print(f"""case_maybeConvert{a}{b} :: Assertion+> case_maybeConvert{a}{b} =+>   forM_ [0 .. {ia_max}] $ \\n ->+>     forM_ [0 .. {ib_max}] $ \\m ->+>       withSomeSNat n $ \(SNat :: SNat n) ->+>         withSomeSNat m $ \(SNat :: SNat m) ->+>           forM_ [minBound .. maxBound] $ \(i :: {a} {n}) -> do+>             assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @({b} {m})) i)+>             assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @({b} {m})) i)+>             assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @({b} {m})) i)+>             assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @({b} {m})) i)+>  """)+-}+module Clash.Tests.MaybeNumConvert where++import Control.Monad (forM_)+import Data.Data (Proxy (..))+import Data.Int (Int64)+import Data.Maybe (fromMaybe, isJust)+import Data.Word (Word64)+import GHC.TypeNats (someNatVal)+import Test.Tasty (TestTree, defaultMain)+import Test.Tasty.HUnit (Assertion, assertBool, testCase)+import Test.Tasty.TH (testGroupGenerator)++import Clash.Prelude hiding (someNatVal, withSomeSNat)++import qualified Data.List as L++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = $(testGroupGenerator)++-- Tests for maybeNumConvert (conversions that can fail)++case_MaybeInt64Word64 :: Assertion+case_MaybeInt64Word64 = do+  -- Successful conversions (non-negative values)+  assertBool "0" $ maybeNumConvert (0 :: Int64) == Just (0 :: Word64)+  assertBool "1" $ maybeNumConvert (1 :: Int64) == Just (1 :: Word64)+  assertBool "42" $ maybeNumConvert (42 :: Int64) == Just (42 :: Word64)+  assertBool "maxBound" $ maybeNumConvert (maxBound :: Int64) == Just (9223372036854775807 :: Word64)+  -- Failed conversions (negative values)+  assertBool "-1" $ maybeNumConvert (-1 :: Int64) == (Nothing :: Maybe Word64)+  assertBool "-42" $ maybeNumConvert (-42 :: Int64) == (Nothing :: Maybe Word64)+  assertBool "minBound" $ maybeNumConvert (minBound :: Int64) == (Nothing :: Maybe Word64)++case_MaybeWord64Unsigned32 :: Assertion+case_MaybeWord64Unsigned32 = do+  -- Successful conversions (small values)+  assertBool "0" $ maybeNumConvert (0 :: Word64) == Just (0 :: Unsigned 32)+  assertBool "1" $ maybeNumConvert (1 :: Word64) == Just (1 :: Unsigned 32)+  assertBool "42" $ maybeNumConvert (42 :: Word64) == Just (42 :: Unsigned 32)+  assertBool "maxBound32" $ maybeNumConvert (4294967295 :: Word64) == Just (maxBound :: Unsigned 32)+  -- Failed conversions (values too large)+  assertBool "overflow1" $ maybeNumConvert (4294967296 :: Word64) == (Nothing :: Maybe (Unsigned 32))+  assertBool "overflow2" $ maybeNumConvert (5000000000 :: Word64) == (Nothing :: Maybe (Unsigned 32))+  assertBool "maxBound64" $ maybeNumConvert (maxBound :: Word64) == (Nothing :: Maybe (Unsigned 32))++withSomeSNat :: Natural -> (forall (n :: Nat). SNat n -> r) -> r+withSomeSNat n f = case someNatVal n of+  SomeNat (_ :: Proxy n) -> f (SNat @n)++maybeConvertLaw1 ::+  forall a b.+  (Eq a, MaybeNumConvert a b, MaybeNumConvert b a) =>+  Proxy b ->+  a ->+  Bool+maybeConvertLaw1 Proxy x =+  x == fromMaybe x (maybeNumConvert @_ @b x >>= maybeNumConvert)++maybeConvertLaw2 ::+  forall a b.+  (MaybeNumConvert a b, MaybeNumConvert b a, Integral b, Integral a) =>+  Proxy b ->+  a ->+  Bool+maybeConvertLaw2 Proxy x =+  toInteger x == fromMaybe (toInteger x) (toInteger <$> maybeNumConvert @_ @b x)++maybeConvertLaw3 ::+  forall a b.+  (MaybeNumConvert a b, MaybeNumConvert b a, Integral b, Integral a) =>+  Proxy b ->+  a ->+  Bool+maybeConvertLaw3 Proxy x =+  isJust (maybeNumConvert @_ @b x) `implies` isJust (maybeNumConvert @_ @a =<< maybeNumConvert @_ @b x)+ where+  implies :: Bool -> Bool -> Bool+  implies True False = False+  implies _ _ = True++maybeConvertLaw4 ::+  forall a b.+  (MaybeNumConvert a b, MaybeNumConvert b a, Integral b, Integral a, Bounded b, Bounded a) =>+  Proxy b ->+  a ->+  Bool+maybeConvertLaw4 Proxy x =+  isJust (maybeNumConvert @_ @b x) == (i x >= i (minBound @b) && i x <= i (maxBound @b))+ where+  i :: (Integral c) => c -> Integer+  i = toInteger++-- | Checks whether an 'XException' in, means an 'XException' out+convertXException :: forall a b. (MaybeNumConvert a b) => Proxy a -> Proxy b -> Bool+convertXException _ _ = case isX $ maybeNumConvert @a @b (errorX "BOO" :: a) of+  Left s -> "BOO" `L.isInfixOf` s+  Right _ -> False++indexMax :: Natural+indexMax = 128++otherMax :: Natural+otherMax = 8++case_maybeConvertIndexIndex :: Assertion+case_maybeConvertIndexIndex =+  forM_ [0 .. indexMax] $ \n ->+    forM_ [0 .. indexMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(Index (n + 1))) (Proxy @(Index (m + 1))))+          forM_ [minBound .. maxBound] $ \(i :: Index (n + 1)) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(Index (m + 1))) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(Index (m + 1))) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(Index (m + 1))) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(Index (m + 1))) i)++case_maybeConvertIndexUnsigned :: Assertion+case_maybeConvertIndexUnsigned =+  forM_ [0 .. indexMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(Index (n + 1))) (Proxy @(Unsigned m)))+          forM_ [minBound .. maxBound] $ \(i :: Index (n + 1)) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(Unsigned m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(Unsigned m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(Unsigned m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(Unsigned m)) i)++case_maybeConvertIndexSigned :: Assertion+case_maybeConvertIndexSigned =+  forM_ [0 .. indexMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(Index (n + 1))) (Proxy @(Signed m)))+          forM_ [minBound .. maxBound] $ \(i :: Index (n + 1)) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(Signed m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(Signed m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(Signed m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(Signed m)) i)++case_maybeConvertIndexBitVector :: Assertion+case_maybeConvertIndexBitVector =+  forM_ [0 .. indexMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(Index (n + 1))) (Proxy @(BitVector m)))+          forM_ [minBound .. maxBound] $ \(i :: Index (n + 1)) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(BitVector m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(BitVector m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(BitVector m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(BitVector m)) i)++case_maybeConvertUnsignedIndex :: Assertion+case_maybeConvertUnsignedIndex =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. indexMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(Unsigned n)) (Proxy @(Index (m + 1))))+          forM_ [minBound .. maxBound] $ \(i :: Unsigned n) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(Index (m + 1))) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(Index (m + 1))) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(Index (m + 1))) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(Index (m + 1))) i)++case_maybeConvertUnsignedUnsigned :: Assertion+case_maybeConvertUnsignedUnsigned =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(Unsigned n)) (Proxy @(Unsigned m)))+          forM_ [minBound .. maxBound] $ \(i :: Unsigned n) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(Unsigned m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(Unsigned m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(Unsigned m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(Unsigned m)) i)++case_maybeConvertUnsignedSigned :: Assertion+case_maybeConvertUnsignedSigned =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(Unsigned n)) (Proxy @(Signed m)))+          forM_ [minBound .. maxBound] $ \(i :: Unsigned n) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(Signed m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(Signed m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(Signed m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(Signed m)) i)++case_maybeConvertUnsignedBitVector :: Assertion+case_maybeConvertUnsignedBitVector =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(Unsigned n)) (Proxy @(BitVector m)))+          forM_ [minBound .. maxBound] $ \(i :: Unsigned n) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(BitVector m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(BitVector m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(BitVector m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(BitVector m)) i)++case_maybeConvertSignedIndex :: Assertion+case_maybeConvertSignedIndex =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. indexMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(Signed n)) (Proxy @(Index (m + 1))))+          forM_ [minBound .. maxBound] $ \(i :: Signed n) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(Index (m + 1))) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(Index (m + 1))) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(Index (m + 1))) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(Index (m + 1))) i)++case_maybeConvertSignedUnsigned :: Assertion+case_maybeConvertSignedUnsigned =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(Signed n)) (Proxy @(Unsigned m)))+          forM_ [minBound .. maxBound] $ \(i :: Signed n) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(Unsigned m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(Unsigned m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(Unsigned m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(Unsigned m)) i)++case_maybeConvertSignedSigned :: Assertion+case_maybeConvertSignedSigned =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(Signed n)) (Proxy @(Signed m)))+          forM_ [minBound .. maxBound] $ \(i :: Signed n) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(Signed m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(Signed m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(Signed m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(Signed m)) i)++case_maybeConvertSignedBitVector :: Assertion+case_maybeConvertSignedBitVector =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(Signed n)) (Proxy @(BitVector m)))+          forM_ [minBound .. maxBound] $ \(i :: Signed n) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(BitVector m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(BitVector m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(BitVector m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(BitVector m)) i)++case_maybeConvertBitVectorIndex :: Assertion+case_maybeConvertBitVectorIndex =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. indexMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(BitVector n)) (Proxy @(Index (m + 1))))+          forM_ [minBound .. maxBound] $ \(i :: BitVector n) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(Index (m + 1))) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(Index (m + 1))) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(Index (m + 1))) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(Index (m + 1))) i)++case_maybeConvertBitVectorUnsigned :: Assertion+case_maybeConvertBitVectorUnsigned =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(BitVector n)) (Proxy @(Unsigned m)))+          forM_ [minBound .. maxBound] $ \(i :: BitVector n) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(Unsigned m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(Unsigned m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(Unsigned m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(Unsigned m)) i)++case_maybeConvertBitVectorSigned :: Assertion+case_maybeConvertBitVectorSigned =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(BitVector n)) (Proxy @(Signed m)))+          forM_ [minBound .. maxBound] $ \(i :: BitVector n) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(Signed m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(Signed m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(Signed m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(Signed m)) i)++case_maybeConvertBitVectorBitVector :: Assertion+case_maybeConvertBitVectorBitVector =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) -> do+          assertBool (show (n, m)) (convertXException (Proxy @(BitVector n)) (Proxy @(BitVector m)))+          forM_ [minBound .. maxBound] $ \(i :: BitVector n) -> do+            assertBool (show (n, m, i)) (maybeConvertLaw1 (Proxy @(BitVector m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw2 (Proxy @(BitVector m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw3 (Proxy @(BitVector m)) i)+            assertBool (show (n, m, i)) (maybeConvertLaw4 (Proxy @(BitVector m)) i)
+ tests/Clash/Tests/MaybeX.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Tests.MaybeX where++import Clash.XException (errorX)+import Clash.XException.MaybeX (MaybeX(IsX, IsDefined), toMaybeX)++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.TH++data ABC = A | B Int deriving Show++x :: MaybeX a+x = errorX "X"++isX :: MaybeX a -> Bool+isX = \case+  IsDefined {} -> False+  IsX {} -> True++isDefined :: MaybeX a -> Bool+isDefined = not . isX++case_showNoParens :: Assertion+case_showNoParens = show (toMaybeX A) @?= "IsDefined A"++case_showParens :: Assertion+case_showParens = show (toMaybeX (B 0)) @?= "IsDefined (B 0)"++case_pureDefined :: Assertion+case_pureDefined = assertBool "defined value resolves to IsDefined" (isDefined (pure 'a'))++case_pureX :: Assertion+case_pureX = assertBool "pure catches X" (isX (pure x))++case_Fmap :: Assertion+case_Fmap = assertBool "fmap" (isDefined (const () <$> pure 'a'))++case_strictFmap :: Assertion+case_strictFmap = assertBool "fmap is strict in X" (isX (const () <$> pure x))++case_liftA2 :: Assertion+case_liftA2 = assertBool "liftA2"  (isDefined (liftA2 (\_ _ -> ()) (pure 'a') (pure 'b')))++case_strictLiftA2 :: Assertion+case_strictLiftA2 = do+  assertBool "liftA2 is strict in X (left)"  (isX (liftA2 (\_ _ -> ()) (pure x) (pure 'b')))+  assertBool "liftA2 is strict in X (right)" (isX (liftA2 (\_ _ -> ()) (pure 'a') (pure x)))+  assertBool "liftA2 is strict in X (both)"  (isX (liftA2 (\_ _ -> ()) (pure x) (pure x)))++tests :: TestTree+tests = $(testGroupGenerator)
tests/Clash/Tests/NFDataX.hs view
@@ -1,28 +1,38 @@-{-# LANGUAGE CPP            #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric  #-}-{-# LANGUAGE MagicHash      #-} +{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}+ module Clash.Tests.NFDataX where  import           Test.Tasty import           Test.Tasty.HUnit  import           GHC.Generics         (Generic)-import           Clash.XException     (NFDataX(rnfX), errorX)+import           Clash.Class.BitPack  (pack)+import           Clash.Sized.Vector   (Vec(..))+import           Clash.XException+  (NFDataX(rnfX, hasUndefined, deepErrorX), errorX, ensureSpine) import           Data.Ord             (Down (Down)) -data Void                                  deriving (Generic, NFDataX)-data Unit    = Unit                        deriving (Generic, NFDataX)-data Wrapper = Wrapper Int                 deriving (Generic, NFDataX)-data Sum     = SumTypeA | SumTypeB         deriving (Generic, NFDataX)-data BigSum  = BS1 | BS2 | BS3 | BS4 | BS5 deriving (Generic, NFDataX)-data Product = Product Int Int             deriving (Generic, NFDataX)-data SP      = S Int Int | P Int           deriving (Generic, NFDataX)-data Rec0    = Rec0 {  }                   deriving (Generic, NFDataX)-data Rec1    = Rec1 { a :: Int }           deriving (Generic, NFDataX)-data Rec2    = Rec2 { b :: Int, c :: Int } deriving (Generic, NFDataX)+data Void                                     deriving (Generic, NFDataX)+data Unit       = Unit                        deriving (Generic, NFDataX)+data Wrapper    = Wrapper Int                 deriving (Generic, NFDataX)+data Sum        = SumTypeA | SumTypeB         deriving (Generic, NFDataX)+data BigSum     = BS1 | BS2 | BS3 | BS4 | BS5 deriving (Generic, NFDataX)+data Product    = Product Int Int             deriving (Generic, NFDataX)+data SP         = S Int Int | P Int           deriving (Generic, NFDataX)+data Rec0       = Rec0 {  }                   deriving (Generic, NFDataX)+data Rec1       = Rec1 { a :: Int }           deriving (Generic, NFDataX)+data Rec2       = Rec2 { b :: Int, c :: Int } deriving (Generic, NFDataX)+data ProductRec = ProductRec Rec1 (Unit, Sum) deriving (Generic, NFDataX) +sundef :: NFDataX a => a+sundef = ensureSpine undef++dundef :: NFDataX a => a+dundef = deepErrorX "!"+ undef :: a undef = errorX "!" {-# NOINLINE undef #-}@@ -32,7 +42,7 @@   testGroup     "NFDataX"     [ testGroup-        "Generic"+        "GenericRnf"         [ testCase "Unit"     $ rnfX (undef :: Unit)                  @?= ()         , testCase "Wrapper1" $ rnfX (undef :: Wrapper)               @?= ()         , testCase "Wrapper2" $ rnfX (Wrapper undef)                  @?= ()@@ -53,11 +63,40 @@         , testCase "Rec2_1"   $ rnfX (undef :: Rec2)                  @?= ()         , testCase "Rec2_2"   $ rnfX (Rec2 3 undef)                   @?= ()         , testCase "Rec2_3"   $ rnfX (Rec2 undef 5)                   @?= ()---          Test case broken on 8.2.2:---        , testCase "Void"     $ rnfX (undef :: Void)                  @?= ()+        , testCase "Void"     $ rnfX (undef :: Void)                  @?= ()         ]     , testGroup-        "Manual"+        "Tuples"+        [ -- Test Template Haskell generated hasUndefined instance for tuples+          testCase "HU1"  $ hasUndefined (undef :: (Int, Int))                  @?= True+        , testCase "HU3"  $ hasUndefined ((undef, undef) :: (Int, Int))         @?= True+        , testCase "HU2"  $ hasUndefined ((undef, 1) :: (Int, Int))             @?= True+        , testCase "HU4"  $ hasUndefined ((1, undef) :: (Int, Int))             @?= True+        , testCase "HU4"  $ hasUndefined ((1, 2) :: (Int, Int))                 @?= False+        , testCase "HU5"  $ hasUndefined ((undef, 1) :: (Rec2, Int))            @?= True+        , testCase "HU6"  $ hasUndefined ((Rec2 undef undef, 1) :: (Rec2, Int)) @?= True+        , testCase "HU7"  $ hasUndefined ((Rec2 1 undef, 1) :: (Rec2, Int))     @?= True+        , testCase "HU8"  $ hasUndefined ((Rec2 1 1, 1) :: (Rec2, Int))         @?= False++          -- Test Template Haskell generated rnfX instance for tuples+        , testCase "RnfX1"  $ rnfX (undef :: (Int, Int))                  @?= ()+        , testCase "RnfX3"  $ rnfX ((undef, undef) :: (Int, Int))         @?= ()+        , testCase "RnfX2"  $ rnfX ((undef, 1) :: (Int, Int))             @?= ()+        , testCase "RnfX4"  $ rnfX ((1, undef) :: (Int, Int))             @?= ()+        , testCase "RnfX4"  $ rnfX ((1, 2) :: (Int, Int))                 @?= ()+        , testCase "RnfX5"  $ rnfX ((undef, 1) :: (Rec2, Int))            @?= ()+        , testCase "RnfX6"  $ rnfX ((Rec2 undef undef, 1) :: (Rec2, Int)) @?= ()+        , testCase "RnfX7"  $ rnfX ((Rec2 1 undef, 1) :: (Rec2, Int))     @?= ()+        , testCase "RnfX8"  $ rnfX ((Rec2 1 1, 1) :: (Rec2, Int))         @?= ()++          -- Test Template Haskell generated deepErrorX/ensureSpine instance for tuples+        , testCase "DU" $ case dundef @(Unit, Unit) of (Unit, Unit) -> () @?= ()+        , testCase "ES1" $ case ensureSpine undef of () -> () @?= ()+        , testCase "ES1" $ case ensureSpine undef of ((), ()) -> () @?= ()+        , testCase "ES2" $ case ensureSpine @(Unit, Unit) undef of (Unit, Unit) -> () @?= ()+        ]+    , testGroup+        "ManualRnf"         [ testCase "List1"     $ rnfX (undef :: [Int])                @?= ()         , testCase "List2"     $ rnfX ([undef] :: [Int])              @?= ()         , testCase "Maybe1"    $ rnfX (undef :: Maybe Int)            @?= ()@@ -68,5 +107,70 @@         , testCase "Down1"     $ rnfX (Down undef :: Down Int)        @?= ()         , testCase "Down2"     $ rnfX (undef :: Down Int)             @?= ()         ]+    , testGroup+        "GenericHasUndefinedTrue"+        [ testCase "Unit"     $ hasUndefined (undef :: Unit)                  @?= True+        , testCase "Wrapper1" $ hasUndefined (undef :: Wrapper)               @?= True+        , testCase "Wrapper2" $ hasUndefined (Wrapper undef)                  @?= True+        , testCase "Sum"      $ hasUndefined (undef :: Sum)                   @?= True+        , testCase "BigSum"   $ hasUndefined (undef :: BigSum)                @?= True+        , testCase "Product1" $ hasUndefined (undef :: Product)               @?= True+        , testCase "Product2" $ hasUndefined (Product undef undef :: Product) @?= True+        , testCase "Product3" $ hasUndefined (Product 3 undef :: Product)     @?= True+        , testCase "Product4" $ hasUndefined (Product undef 5 :: Product)     @?= True+        , testCase "SP1"      $ hasUndefined (undef :: SP)                    @?= True+        , testCase "SP2"      $ hasUndefined (S undef undef :: SP)            @?= True+        , testCase "SP3"      $ hasUndefined (S 3 undef :: SP)                @?= True+        , testCase "SP3"      $ hasUndefined (S undef 5 :: SP)                @?= True+        , testCase "SP4"      $ hasUndefined (P undef :: SP)                  @?= True+        , testCase "Rec0"     $ hasUndefined (undef :: Rec0)                  @?= True+        , testCase "Rec1_1"   $ hasUndefined (undef :: Rec1)                  @?= True+        , testCase "Rec1_2"   $ hasUndefined (Rec1 undef)                     @?= True+        , testCase "Rec2_1"   $ hasUndefined (undef :: Rec2)                  @?= True+        , testCase "Rec2_2"   $ hasUndefined (Rec2 3 undef)                   @?= True+        , testCase "Rec2_3"   $ hasUndefined (Rec2 undef 5)                   @?= True+        , testCase "Void"     $ hasUndefined (undef :: Void)                  @?= True+        ]+    , testGroup+        "GenericHasUndefinedFalse"+        [ testCase "Unit"     $ hasUndefined ()                               @?= False+        , testCase "Wrapper"  $ hasUndefined (Wrapper 0:: Wrapper)            @?= False+        , testCase "SumA"     $ hasUndefined (SumTypeA :: Sum)                @?= False+        , testCase "SumB"     $ hasUndefined (SumTypeB :: Sum)                @?= False+        , testCase "BigSum1"  $ hasUndefined (BS1 :: BigSum)                  @?= False+        , testCase "BigSum2"  $ hasUndefined (BS2 :: BigSum)                  @?= False+        , testCase "BigSum3"  $ hasUndefined (BS3 :: BigSum)                  @?= False+        , testCase "BigSum4"  $ hasUndefined (BS4 :: BigSum)                  @?= False+        , testCase "BigSum5"  $ hasUndefined (BS5 :: BigSum)                  @?= False+        , testCase "Product"  $ hasUndefined (Product 3 5 :: Product)         @?= False+        , testCase "SP1"      $ hasUndefined (S 3 5 :: SP)                    @?= False+        , testCase "SP2"      $ hasUndefined (P 5 :: SP)                      @?= False+        , testCase "Rec2_3"   $ hasUndefined (Rec2 3 5)                       @?= False+        ]+    , testGroup+        "ManualHasUndefined"+        [ testCase "Vec1"       $ hasUndefined (3 :> errorX "X" :: Vec 5 Int)   @?= True+        , testCase "Vec2"       $ hasUndefined (errorX "X" :: Vec 5 Int)        @?= True+        , testCase "Maybe"      $ hasUndefined (Nothing :: Maybe Bool)          @?= False+        , testCase "BitVector1" $ hasUndefined (pack (Nothing :: Maybe Bool))   @?= True+        , testCase "BitVector2" $ hasUndefined (pack (Just True:: Maybe Bool))  @?= False+        ]+    , testGroup+        "GenericDeepErrorX"+        [ testCase "Unit"       $ case dundef @Unit of Unit -> ()           @?= ()+        , testCase "Wrapper1"   $ case dundef @Wrapper of Wrapper _ -> ()   @?= ()+        , testCase "Product1"   $ case dundef @Product of Product _ _ -> () @?= ()+        , testCase "Rec1_1"     $ case dundef @Rec1 of Rec1 {} -> ()        @?= ()+        , testCase "Rec2_1"     $ case dundef @Rec2 of Rec2 {} -> ()        @?= ()+        , testCase "ProductRec" $ case dundef @ProductRec of ProductRec (Rec1 _) (Unit, _) -> () @?= ()+        ]+    , testGroup+        "GenericEnsureSpine"+        [ testCase "Unit"       $ case sundef @Unit of Unit -> ()           @?= ()+        , testCase "Wrapper1"   $ case sundef @Wrapper of Wrapper _ -> ()   @?= ()+        , testCase "Product1"   $ case sundef @Product of Product _ _ -> () @?= ()+        , testCase "Rec1_1"     $ case sundef @Rec1 of Rec1 {} -> ()        @?= ()+        , testCase "Rec2_1"     $ case sundef @Rec2 of Rec2 {} -> ()        @?= ()+        , testCase "ProductRec" $ case sundef @ProductRec of ProductRec (Rec1 _) (Unit, _) -> () @?= ()+        ]     ]-
+ tests/Clash/Tests/NumConvert.hs view
@@ -0,0 +1,403 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}++{- |+Copyright  :  (C) 2025     , Martijn Bastiaan+                  2025-2026, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Test generation of 'NumConvert' instances:++> constraints = {+>     ("Index",     "Index")     : (False, "SNat @{n}              `compareSNat` SNat @{m}"),+>     ("Index",     "Unsigned")  : (False, "SNat @{n}              `compareSNat` SNat @(2 ^ {m})"),+>     ("Index",     "Signed")    : (True,  "SNat @(CLog 2 {n} + 1) `compareSNat` SNat @{m}"),+>     ("Index",     "BitVector") : (False, "SNat @{n}              `compareSNat` SNat @(2 ^ {m})"),+>     ("Unsigned",  "Index")     : (False, "SNat @(2^{n})          `compareSNat` SNat @{m}"),+>     ("Unsigned",  "Unsigned")  : (False, "SNat @{n}              `compareSNat` SNat @{m}"),+>     ("Unsigned",  "Signed")    : (True,  "SNat @({n} + 1)        `compareSNat` SNat @{m}"),+>     ("Unsigned",  "BitVector") : (False, "SNat @{n}              `compareSNat` SNat @{m}"),+>     ("Signed",    "Signed")    : (False, "SNat @{n}              `compareSNat` SNat @{m}"),+>     ("BitVector", "Index")     : (False, "SNat @(2^{n})          `compareSNat` SNat @{m}"),+>     ("BitVector", "Unsigned")  : (False, "SNat @{n}              `compareSNat` SNat @{m}"),+>     ("BitVector", "Signed")    : (True,  "SNat @({n} + 1)        `compareSNat` SNat @{m}"),+>     ("BitVector", "BitVector") : (False, "SNat @{n}              `compareSNat` SNat @{m}"),+> }+>+> for a in ["Index", "Unsigned", "Signed", "BitVector"]:+>     for b in ["Index", "Unsigned", "Signed", "BitVector"]:+>         ia_max = "indexMax" if a == "Index" else "otherMax"+>         ib_max = "indexMax" if b == "Index" else "otherMax"+>         n = "(n + 1)" if a == "Index" else "n"+>         m = "(m + 1)" if b == "Index" else "m"+>         if (a, b) not in constraints:+>             continue+>         print(f"""case_convert{a}{b} :: Assertion+> case_convert{a}{b} =+>   forM_ [0 .. {ia_max}] $ \\n ->+>     forM_ [0 .. {ib_max}] $ \\m ->+>       withSomeSNat n $ \\(SNat :: SNat n) ->+>         withSomeSNat m $ \\(SNat :: SNat m) ->+>           case {constraints[(a, b)][1].format(n=n, m=m)} of+>             SNatLE -> do+>               assertBool (show (n, m)) (convertXException (Proxy @({a} {n})) (Proxy @({b} {m})))+>               forM_ [minBound .. maxBound] $ \\(i :: {a} {n}) -> do+>                 assertBool (show (n, m, i)) (convertLaw1 (Proxy @({b} {m})) i)+>                 assertBool (show (n, m, i)) (convertLaw2 (Proxy @({b} {m})) i)+>             _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+>             _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @({a} {n})) (Proxy @({b} {m})))+>  where+>   zeroWidthSkip = {constraints[(a, b)][0]}+>  """)+-}+module Clash.Tests.NumConvert where++import Control.Monad (forM_)+import Data.Data (Proxy (..))+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Maybe (isNothing)+import Data.Word (Word16, Word32, Word64, Word8)+import GHC.TypeNats (someNatVal)+import Test.Tasty (TestTree, defaultMain)+import Test.Tasty.HUnit (Assertion, assertBool, testCase)+import Test.Tasty.TH (testGroupGenerator)++import qualified Data.List as L++import Clash.Prelude hiding (someNatVal, withSomeSNat)++convertLaw1 :: forall a b. (NumConvert a b, MaybeNumConvert b a, Eq a) => Proxy b -> a -> Bool+convertLaw1 _ x = Just x == maybeNumConvert (numConvert @a @b x)++convertLaw2 :: forall a b. (NumConvert a b, Eq a, Integral b, Integral a) => Proxy b -> a -> Bool+convertLaw2 _ x = toInteger x == toInteger (numConvert @a @b x)++{- | Tightness law: this law is tested for if there is _no_ instance of+'NumConvert'. If this is the case, 'MaybeNumConvert' should at least return a 'Nothing'+once when converting the domain of @a@ to @b@. If all conversions are possible,+the constraints of the instances should be relaxed. If the domain of @a@ is+empty, this law is considered satisfied too.+-}+convertLaw3 :: forall a b. (MaybeNumConvert a b, Bounded a, Enum a) => Proxy a -> Proxy b -> Bool+convertLaw3 _ _ = L.any isNothing results+ where+  results = L.map (maybeNumConvert @a @b) [minBound ..]++-- | Checks whether an 'XException' in, means an 'XException' out+convertXException :: forall a b. (NumConvert a b) => Proxy a -> Proxy b -> Bool+convertXException _ _ = case isX $ numConvert @a @b (errorX "BOO" :: a) of+  Left s -> "BOO" `L.isInfixOf` s+  Right _ -> False++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = $(testGroupGenerator)++-- Tests for numConvert (Word-to-Word conversions)++case_Word8Word16 :: Assertion+case_Word8Word16 = do+  assertBool "0" $ numConvert (0 :: Word8) == (0 :: Word16)+  assertBool "1" $ numConvert (1 :: Word8) == (1 :: Word16)+  assertBool "42" $ numConvert (42 :: Word8) == (42 :: Word16)+  assertBool "maxBound" $ numConvert (maxBound :: Word8) == (255 :: Word16)++case_Word8Word32 :: Assertion+case_Word8Word32 = do+  assertBool "0" $ numConvert (0 :: Word8) == (0 :: Word32)+  assertBool "1" $ numConvert (1 :: Word8) == (1 :: Word32)+  assertBool "42" $ numConvert (42 :: Word8) == (42 :: Word32)+  assertBool "maxBound" $ numConvert (maxBound :: Word8) == (255 :: Word32)++case_Word16Word32 :: Assertion+case_Word16Word32 = do+  assertBool "0" $ numConvert (0 :: Word16) == (0 :: Word32)+  assertBool "1" $ numConvert (1 :: Word16) == (1 :: Word32)+  assertBool "42" $ numConvert (42 :: Word16) == (42 :: Word32)+  assertBool "maxBound" $ numConvert (maxBound :: Word16) == (65535 :: Word32)++case_Word32Word64 :: Assertion+case_Word32Word64 = do+  assertBool "0" $ numConvert (0 :: Word32) == (0 :: Word64)+  assertBool "1" $ numConvert (1 :: Word32) == (1 :: Word64)+  assertBool "42" $ numConvert (42 :: Word32) == (42 :: Word64)+  assertBool "maxBound" $ numConvert (maxBound :: Word32) == (4294967295 :: Word64)++-- Tests for numConvert (Int-to-Int conversions)++case_Int8Int16 :: Assertion+case_Int8Int16 = do+  assertBool "0" $ numConvert (0 :: Int8) == (0 :: Int16)+  assertBool "1" $ numConvert (1 :: Int8) == (1 :: Int16)+  assertBool "42" $ numConvert (42 :: Int8) == (42 :: Int16)+  assertBool "-1" $ numConvert (-1 :: Int8) == (-1 :: Int16)+  assertBool "-42" $ numConvert (-42 :: Int8) == (-42 :: Int16)+  assertBool "minBound" $ numConvert (minBound :: Int8) == (-128 :: Int16)+  assertBool "maxBound" $ numConvert (maxBound :: Int8) == (127 :: Int16)++case_Int32Int64 :: Assertion+case_Int32Int64 = do+  assertBool "0" $ numConvert (0 :: Int32) == (0 :: Int64)+  assertBool "1" $ numConvert (1 :: Int32) == (1 :: Int64)+  assertBool "42" $ numConvert (42 :: Int32) == (42 :: Int64)+  assertBool "-1" $ numConvert (-1 :: Int32) == (-1 :: Int64)+  assertBool "-42" $ numConvert (-42 :: Int32) == (-42 :: Int64)+  assertBool "minBound" $ numConvert (minBound :: Int32) == (-2147483648 :: Int64)+  assertBool "maxBound" $ numConvert (maxBound :: Int32) == (2147483647 :: Int64)++-- Tests for mixed conversions (cross Haskell/Clash boundary)++case_Word32Unsigned64 :: Assertion+case_Word32Unsigned64 = do+  assertBool "0" $ numConvert (0 :: Word32) == (0 :: Unsigned 64)+  assertBool "1" $ numConvert (1 :: Word32) == (1 :: Unsigned 64)+  assertBool "42" $ numConvert (42 :: Word32) == (42 :: Unsigned 64)+  assertBool "maxBound" $ numConvert (maxBound :: Word32) == (4294967295 :: Unsigned 64)++case_Unsigned32Word64 :: Assertion+case_Unsigned32Word64 = do+  assertBool "0" $ numConvert (0 :: Unsigned 32) == (0 :: Word64)+  assertBool "1" $ numConvert (1 :: Unsigned 32) == (1 :: Word64)+  assertBool "42" $ numConvert (42 :: Unsigned 32) == (42 :: Word64)+  assertBool "maxBound" $ numConvert (maxBound :: Unsigned 32) == (4294967295 :: Word64)++withSomeSNat :: Natural -> (forall (n :: Nat). SNat n -> r) -> r+withSomeSNat n f = case someNatVal n of+  SomeNat (_ :: Proxy n) -> f (SNat @n)++indexMax :: Natural+indexMax = 128++otherMax :: Natural+otherMax = 8++case_convertIndexIndex :: Assertion+case_convertIndexIndex =+  forM_ [0 .. indexMax] $ \n ->+    forM_ [0 .. indexMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @(n + 1) `compareSNat` SNat @(m + 1) of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(Index (n + 1))) (Proxy @(Index (m + 1))))+              forM_ [minBound .. maxBound] $ \(i :: Index (n + 1)) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(Index (m + 1))) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(Index (m + 1))) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(Index (n + 1))) (Proxy @(Index (m + 1))))+ where+  zeroWidthSkip = False++case_convertIndexUnsigned :: Assertion+case_convertIndexUnsigned =+  forM_ [0 .. indexMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @(n + 1) `compareSNat` SNat @(2 ^ m) of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(Index (n + 1))) (Proxy @(Unsigned m)))+              forM_ [minBound .. maxBound] $ \(i :: Index (n + 1)) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(Unsigned m)) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(Unsigned m)) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(Index (n + 1))) (Proxy @(Unsigned m)))+ where+  zeroWidthSkip = False++case_convertIndexSigned :: Assertion+case_convertIndexSigned =+  forM_ [0 .. indexMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @(CLogWZ 2 (n + 1) 0 + 1) `compareSNat` SNat @m of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(Index (n + 1))) (Proxy @(Signed m)))+              forM_ [minBound .. maxBound] $ \(i :: Index (n + 1)) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(Signed m)) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(Signed m)) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(Index (n + 1))) (Proxy @(Signed m)))+ where+  zeroWidthSkip = True++case_convertIndexBitVector :: Assertion+case_convertIndexBitVector =+  forM_ [0 .. indexMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @(n + 1) `compareSNat` SNat @(2 ^ m) of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(Index (n + 1))) (Proxy @(BitVector m)))+              forM_ [minBound .. maxBound] $ \(i :: Index (n + 1)) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(BitVector m)) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(BitVector m)) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(Index (n + 1))) (Proxy @(BitVector m)))+ where+  zeroWidthSkip = False++case_convertUnsignedIndex :: Assertion+case_convertUnsignedIndex =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. indexMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @(2 ^ n) `compareSNat` SNat @(m + 1) of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(Unsigned n)) (Proxy @(Index (m + 1))))+              forM_ [minBound .. maxBound] $ \(i :: Unsigned n) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(Index (m + 1))) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(Index (m + 1))) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(Unsigned n)) (Proxy @(Index (m + 1))))+ where+  zeroWidthSkip = False++case_convertUnsignedUnsigned :: Assertion+case_convertUnsignedUnsigned =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @n `compareSNat` SNat @m of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(Unsigned n)) (Proxy @(Unsigned m)))+              forM_ [minBound .. maxBound] $ \(i :: Unsigned n) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(Unsigned m)) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(Unsigned m)) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(Unsigned n)) (Proxy @(Unsigned m)))+ where+  zeroWidthSkip = False++case_convertUnsignedSigned :: Assertion+case_convertUnsignedSigned =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @(n + 1) `compareSNat` SNat @m of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(Unsigned n)) (Proxy @(Signed m)))+              forM_ [minBound .. maxBound] $ \(i :: Unsigned n) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(Signed m)) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(Signed m)) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(Unsigned n)) (Proxy @(Signed m)))+ where+  zeroWidthSkip = True++case_convertUnsignedBitVector :: Assertion+case_convertUnsignedBitVector =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @n `compareSNat` SNat @m of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(Unsigned n)) (Proxy @(BitVector m)))+              forM_ [minBound .. maxBound] $ \(i :: Unsigned n) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(BitVector m)) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(BitVector m)) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(Unsigned n)) (Proxy @(BitVector m)))+ where+  zeroWidthSkip = False++case_convertSignedSigned :: Assertion+case_convertSignedSigned =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @n `compareSNat` SNat @m of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(Signed n)) (Proxy @(Signed m)))+              forM_ [minBound .. maxBound] $ \(i :: Signed n) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(Signed m)) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(Signed m)) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(Signed n)) (Proxy @(Signed m)))+ where+  zeroWidthSkip = False++case_convertBitVectorIndex :: Assertion+case_convertBitVectorIndex =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. indexMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @(2 ^ n) `compareSNat` SNat @(m + 1) of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(BitVector n)) (Proxy @(Index (m + 1))))+              forM_ [minBound .. maxBound] $ \(i :: BitVector n) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(Index (m + 1))) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(Index (m + 1))) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(BitVector n)) (Proxy @(Index (m + 1))))+ where+  zeroWidthSkip = False++case_convertBitVectorUnsigned :: Assertion+case_convertBitVectorUnsigned =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @n `compareSNat` SNat @m of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(BitVector n)) (Proxy @(Unsigned m)))+              forM_ [minBound .. maxBound] $ \(i :: BitVector n) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(Unsigned m)) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(Unsigned m)) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(BitVector n)) (Proxy @(Unsigned m)))+ where+  zeroWidthSkip = False++case_convertBitVectorSigned :: Assertion+case_convertBitVectorSigned =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @(n + 1) `compareSNat` SNat @m of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(BitVector n)) (Proxy @(Signed m)))+              forM_ [minBound .. maxBound] $ \(i :: BitVector n) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(Signed m)) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(Signed m)) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(BitVector n)) (Proxy @(Signed m)))+ where+  zeroWidthSkip = True++case_convertBitVectorBitVector :: Assertion+case_convertBitVectorBitVector =+  forM_ [0 .. otherMax] $ \n ->+    forM_ [0 .. otherMax] $ \m ->+      withSomeSNat n $ \(SNat :: SNat n) ->+        withSomeSNat m $ \(SNat :: SNat m) ->+          case SNat @n `compareSNat` SNat @m of+            SNatLE -> do+              assertBool (show (n, m)) (convertXException (Proxy @(BitVector n)) (Proxy @(BitVector m)))+              forM_ [minBound .. maxBound] $ \(i :: BitVector n) -> do+                assertBool (show (n, m, i)) (convertLaw1 (Proxy @(BitVector m)) i)+                assertBool (show (n, m, i)) (convertLaw2 (Proxy @(BitVector m)) i)+            _ | (n == 0 && m == 0 && zeroWidthSkip) -> pure ()+            _ -> assertBool (show (n, m)) (convertLaw3 (Proxy @(BitVector n)) (Proxy @(BitVector m)))+ where+  zeroWidthSkip = False
+ tests/Clash/Tests/NumNewtypes.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}++module Clash.Tests.NumNewtypes (tests) where++import Control.DeepSeq (NFData, force)+import Data.Kind (Type)+import Data.Proxy (Proxy(..))+import GHC.TypeLits (KnownNat)+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Hedgehog.Extra+import Hedgehog.Internal.Exception (tryEvaluate)+import Test.Tasty+import Test.Tasty.Hedgehog.Extra++import Clash.Class.Num+import Clash.Num.Erroring+import Clash.Num.Overflowing+import Clash.Num.Saturating+import Clash.Num.Wrapping+import Clash.Num.Zeroing+import Clash.Sized.Index (Index)+import Clash.Sized.Signed (Signed)+import Clash.Sized.Unsigned (Unsigned)++tests :: TestTree+tests = testGroup "Numeric Newtypes"+  [ testGroup "Erroring"+      [ testIntegral "Index 4" Error (genErroring (genIndex @4))+      , testIntegral "Signed 4" Error (genErroring (genSigned @4))+      , testIntegral "Unsigned 4" Error (genErroring (genUnsigned @4))+      ]+  , testGroup "Overflowing"+      [ testIntegral "Index 4" Over (genOverflowing (genIndex @4))+      , testIntegral "Signed 4" Over (genOverflowing (genSigned @4))+      , testIntegral "Unsigned 4" Over (genOverflowing (genUnsigned @4))+      ]+  , testGroup "Saturating"+      [ testIntegral "Index 4" Sat (genSaturating (genIndex @4))+      , testIntegral "Signed 4" Sat (genSaturating (genSigned @4))+      , testIntegral "Unsigned 4" Sat (genSaturating (genUnsigned @4))+      ]+  , testGroup "Wrapping"+      [ testIntegral "Index 4" Wrap (genWrapping (genIndex @4))+      , testIntegral "Signed 4" Wrap (genWrapping (genSigned @4))+      , testIntegral "Unsigned 4" Wrap (genWrapping (genUnsigned @4))+      ]+  , testGroup "Zeroing"+      [ testIntegral "Index 4" Zero (genZeroing (genIndex @4))+      , testIntegral "Signed 4" Zero (genZeroing (genSigned @4))+      , testIntegral "Unsigned 4" Zero (genZeroing (genUnsigned @4))+      ]+  ]++testIntegral+  :: (Bounded (f a), Integral (f a), Show (f a), NFData (f a))+  => TestName+  -> Mode f+  -> Gen (f a)+  -> TestTree+testIntegral name mode gen =+  testGroup name+    [ testPropertyXXX "Addition" $ checkIntegral2 mode gen (+)+    , testPropertyXXX "Subtraction" $ checkIntegral2 mode gen (-)+    , testPropertyXXX "Multiplication" $ checkIntegral2 mode gen (*)+    , testPropertyXXX "Negation" $ checkIntegral mode gen negate+    , testPropertyXXX "Absolute" $ checkIntegral mode gen abs+    , testPropertyXXX "Successor" $ checkIntegral mode gen succ+    , testPropertyXXX "Predecessor" $ checkIntegral mode gen pred+    , testPropertyXXX "Division" $ checkIntegral2 mode gen div+    , testPropertyXXX "Modulo" $ checkIntegral2 mode gen mod+    , testPropertyXXX "Quotient" $ checkIntegral2 mode gen quot+    , testPropertyXXX "Remainder" $ checkIntegral2 mode gen rem+    ]++data Mode :: (Type -> Type) -> Type where+  Error :: Mode Erroring+  Over  :: Mode Overflowing+  Sat   :: Mode Saturating+  Wrap  :: Mode Wrapping+  Zero  :: Mode Zeroing++data BoundsCheck+  = Overflow | Underflow+  deriving (Show)++boundsIntegral+  :: forall a+   . (Bounded a, Integral a)+  => Proxy a+  -> Maybe Integer+  -> Maybe BoundsCheck+boundsIntegral Proxy (Just x)+  | toInteger (maxBound @a) < x = Just Overflow+  | x < toInteger (minBound @a) = Just Underflow+  | otherwise = Nothing++boundsIntegral Proxy Nothing = Just Overflow++tryArithmetic :: (Show a, NFData a) => a -> PropertyT IO (Maybe a)+tryArithmetic x =+  case tryEvaluate (force x) of+    Left err -> do+      footnoteShow err+      pure Nothing++    Right res ->+      pure (Just res)++-- fromInteger wraps for most types, but not Index. So we need this to get the+-- wrapping behaviour we expect.+wrapIntegral+  :: forall a+   . (Bounded a, Integral a)+  => Integer+  -> a+wrapIntegral x =+  let minB = toInteger (minBound @a)+      maxB = toInteger (maxBound @a) + 1+   in fromInteger $! minB + (x - minB) `mod` (maxB - minB)++checkIntegral+  :: forall f a+   . (Bounded (f a), Integral (f a), Show (f a), NFData (f a))+  => Mode f+  -> Gen (f a)+  -> (forall b. Integral b => b -> b)+  -> Property+checkIntegral mode gen op =+  property $ do+    x <- forAll gen+    result <- tryArithmetic (op (toInteger x))++    case boundsIntegral (Proxy @(f a)) result of+      Nothing -> do+        label "InBounds"+        goInBounds result x++      Just info -> do+        collect info+        goOutBounds info result x+ where+  goInBounds mInteger x+    | Over <- mode+    , Just i <- mInteger+    = do let result = op x+         assert (not (hasOverflowed result))+         fromInteger i === result++    | Just i <- mInteger+    = fromInteger i === op x++    | otherwise+    -- If we reach here, the operation which should be in bounds and valid+    -- resulted in an exception being thrown.+    = error "checkIntegral.goInBounds: mInteger should not be Nothing"++  goOutBounds info mInteger x+    | Nothing <- mInteger+    = throwsDeepException (op x)++    | Error <- mode+    = throwsDeepException (op x)++    | Over <- mode+    , Just i <- mInteger+    = do let result = op x+         assert (hasOverflowed result)+         wrapIntegral i === result++    | Sat <- mode+    , Overflow <- info+    = maxBound === op x++    | Sat <- mode+    , Underflow <- info+    = minBound === op x++    | Wrap <- mode+    , Just i <- mInteger+    = wrapIntegral i === op x++    | Zero <- mode+    = 0 === op x++checkIntegral2+  :: forall f a+   . (Bounded (f a), Integral (f a), Show (f a), NFData (f a))+  => Mode f+  -> Gen (f a)+  -> (forall b. Integral b => b -> b -> b)+  -> Property+checkIntegral2 mode gen op =+  property $ do+    x <- forAll gen+    y <- forAll gen+    result <- tryArithmetic (op (toInteger x) (toInteger y))+    footnote ("result: " <> show result)++    case boundsIntegral (Proxy @(f a)) result of+      Nothing -> do+        label "InBounds"+        footnote "InBounds"+        goInBounds result x y++      Just info -> do+        collect info+        footnoteShow info+        goOutBounds info result x y+ where+  goInBounds mInteger x y+    | Over <- mode+    , Just i <- mInteger+    = do let result = op x y+         assert (not (hasOverflowed result))+         fromInteger i === result++    | Just i <- mInteger+    = fromInteger i === op x y++    | otherwise+    = error "checkIntegral2.goInBounds: mInteger should not be Nothing"++  goOutBounds info mInteger x y+    | Nothing <- mInteger+    = throwsDeepException (op x y)++    | Error <- mode+    = throwsDeepException (op x y)++    | Over <- mode+    , Just i <- mInteger+    = do let result = op x y+         assert (hasOverflowed result)+         wrapIntegral i === result++    | Sat <- mode+    , Overflow <- info+    = maxBound === op x y++    | Sat <- mode+    , Underflow <- info+    = minBound === op x y++    | Wrap <- mode+    , Just i <- mInteger+    = wrapIntegral i === op x y++    | Zero <- mode+    = 0 === op x y++genErroring :: forall a. (SaturatingNum a) => Gen a -> Gen (Erroring a)+genErroring = fmap toErroring++genOverflowing :: forall a. (SaturatingNum a) => Gen a -> Gen (Overflowing a)+genOverflowing = fmap toOverflowing++genSaturating :: forall a. (SaturatingNum a) => Gen a -> Gen (Saturating a)+genSaturating = fmap toSaturating++genWrapping :: forall a. (SaturatingNum a) => Gen a -> Gen (Wrapping a)+genWrapping = fmap toWrapping++genZeroing :: forall a. (SaturatingNum a) => Gen a -> Gen (Zeroing a)+genZeroing = fmap toZeroing++genBoundedIntegral :: forall a. (Bounded a, Integral a) => Gen a+genBoundedIntegral = Gen.frequency+  [ (10, pure minBound)+  , (10, pure 0)+  , (40, Gen.integral (Range.linear minBound maxBound))+  , (40, pure maxBound)+  ]++genIndex :: forall n. (KnownNat n) => Gen (Index n)+genIndex = genBoundedIntegral++genSigned :: forall n. (KnownNat n) => Gen (Signed n)+genSigned = genBoundedIntegral++genUnsigned :: forall n. (KnownNat n) => Gen (Unsigned n)+genUnsigned = genBoundedIntegral
+ tests/Clash/Tests/Ram.hs view
@@ -0,0 +1,130 @@+-- Assert correct behavior:+--+-- Undefined enable:+--    The written-to address should read 'undefined', but other addresses+--    should still have their data.+--+-- Undefined write address:+--    All addresses should read 'undefined'.+--+-- OOB write address+--    All addresses should read 'undefined.+--+-- Undefined write data:+--    The written-to address should read 'undefined', but other addresses+--    should still have their data.+--+-- Deasserted enable+--    It shouldn't matter that other write inputs are 'undefined'.+--+-- Deasserted enable, OOB address+--    It shouldn't matter that it is out of bounds.+--+-- OOB read address+--    The sample should be undefined, nothing more.+--+-- Read address strictness+--    If the read result is not used, out-of-bounds read address shouldn't+--    matter (equivalent to issue #1458).++{-# LANGUAGE NoImplicitPrelude #-}++module Clash.Tests.Ram (tests) where++import qualified Data.List as L+import Test.Tasty+import Test.Tasty.HUnit++import Clash.Explicit.Prelude+import Clash.Explicit.RAM++type Ram = (   Signal System Int+            -> Signal System Bool+            -> Signal System Int+            -> Signal System Int+            -> Signal System (Maybe Int)+           )++ram :: Ram+ram rd we wr din =+  maybeIsX <$> asyncRam# clockGen clockGen enableGen d2 rd we wr din++maskOobRead :: Ram+maskOobRead rd we wr din =+  maybeIsX <$> mux (rd .< 2) ram0 (pure 4)+ where+  ram0 = asyncRam# clockGen clockGen enableGen d2 rd we wr din++type Samples = [(Int, Bool, Int, Int, Maybe Int)]++initMem, undefEn, undefWAddr, oobWAddr, undefWData, enFalse, enFalseOobWAddr,+  oobRAddr, oobRAddrStrict+  :: Samples++--                               rd  enable     waddr      wdata      dout+initMem =                     [ ( 0, True     , 0        , 0        , Nothing)+                              , ( 0, True     , 1        , 1        , Just 0 )+                              ]++undefEn = initMem <>          [ ( 0, undefined, 0        , 2        , Just 0 )+                              , ( 0, False    , 0        , 3        , Nothing)+                              , ( 1, False    , 0        , 3        , Just 1 )+                              ]++undefWAddr = initMem <>       [ ( 0, True     , undefined, 2        , Just 0 )+                              , ( 0, False    , 0        , 3        , Nothing)+                              , ( 1, False    , 0        , 3        , Nothing)+                              ]++oobWAddr = initMem <>         [ ( 0, True     , 3        , 2        , Just 0 )+                              , ( 0, False    , 0        , 3        , Nothing)+                              , ( 1, False    , 0        , 3        , Nothing)+                              ]++undefWData = initMem <>       [ ( 0, True     , 0        , undefined, Just 0 )+                              , ( 0, False    , 0        , 3        , Nothing)+                              , ( 1, False    , 0        , 3        , Just 1 )+                              ]++enFalse = initMem <>          [ ( 0, False    , undefined, undefined, Just 0)+                              , ( 0, False    , undefined, undefined, Just 0)+                              , ( 1, False    , undefined, undefined, Just 1)+                              ]++enFalseOobWAddr = initMem <>  [ ( 0, False    , 255      , 2        , Just 0 )+                              , ( 0, False    , 0        , 3        , Just 0 )+                              , ( 1, False    , 0        , 3        , Just 1 )+                              ]++oobRAddr = initMem <>         [ ( 2, False    , 0        , 3        , Nothing)+                              , ( 0, False    , 0        , 3        , Just 0 )+                              , ( 1, False    , 0        , 3        , Just 1 )+                              ]++oobRAddrStrict = initMem <>   [ ( 1, False    , 0        , 3        , Just 1 )+                              , ( 2, False    , 0        , 3        , Just 4 )+                              , ( 0, False    , 0        , 3        , Just 0 )+                              ]++ramAssertion+  :: Ram+  -> Samples+  -> Assertion+ramAssertion ram0 samples = actual @?= expectedOutput+ where+  (rd, we, wr, din, expectedOutput) = L.unzip5 samples+  actual = sampleN (L.length samples) $ ram0 (fromList rd)+                                             (fromList we)+                                             (fromList wr)+                                             (fromList din)+tests :: TestTree+tests = testGroup "Ram"+  [ testCase "Undefined enable" $ ramAssertion ram undefEn+  , testCase "Undefined write address" $ ramAssertion ram undefWAddr+  , testCase "OOB write address" $ ramAssertion ram oobWAddr+  , testCase "Undefined write data" $ ramAssertion ram undefWData+  , testCase "Deasserted enable" $ ramAssertion ram enFalse+  , testCase "Deasserted enable, OOB address" $ ramAssertion ram enFalseOobWAddr+  , testCase "OOB read address" $ ramAssertion ram oobRAddr+  , testCase "Read address strictness" $ ramAssertion maskOobRead oobRAddrStrict+  ]
+ tests/Clash/Tests/Reset.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Clash.Tests.Reset where++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.TH+import Clash.Explicit.Prelude++import qualified Prelude as P++-- Testing with explicit declaration of the Low type alias+type Low = ("Low" :: Domain)+createDomain vSystem{vName="Low", vResetPolarity=ActiveLow}++sampleResetN :: KnownDomain dom => Int -> Reset dom -> [Bool]+sampleResetN n = sampleN n . unsafeToActiveHigh++resetFromList :: KnownDomain dom => [Bool] -> Reset dom+resetFromList = unsafeFromActiveHigh . fromList++onePeriodGlitchReset :: KnownDomain dom => Reset dom+onePeriodGlitchReset =+  resetFromList [True,True,False,False,True,False,False,True,True,False,False,False]++-- | Introduce a glitch of one period, and see if it's filtered out+--+-- Note that since 'System' is a domain with asynchronous resets,+-- 'resetGlitchFilter' first synchronizes the incoming reset. This leads to an+-- additional delay of two cycles with respect to the output.+case_onePeriodGlitch :: Assertion+case_onePeriodGlitch =+      [True,True,True,True,True,True,False,False,False,False,False,True,True,False]+  @=? sampleResetN 14 (resetGlitchFilter d2 systemClockGen onePeriodGlitchReset)++-- | Same as 'case_onePeriodGlitch' but on a domain with active low resets+case_onePeriodGlitch_LowPolarity :: Assertion+case_onePeriodGlitch_LowPolarity =+      [True,True,True,True,True,True,False,False,False,False,False,True,True,False]+  @=? sampleResetN 14 (resetGlitchFilter d2 (clockGen @Low) onePeriodGlitchReset)++-- Check that the meaning of @Reset@ is maintained when converting from+-- active-low to active-high.+case_convertReset_polarity_change :: Assertion+case_convertReset_polarity_change =+      -- In domains with synchronous resets and defined initial values,+      -- @resetSynchronizer@ will start with an asserted reset.+      True : True : P.replicate 8 False+  @=? sampleResetN 10 (convertReset (clockGen @Low) (clockGen @System)+                                    (resetFromList $ P.repeat False))++tests :: TestTree+tests = testGroup "Reset"+  [ $(testGroupGenerator)+  ]++main :: IO ()+main = defaultMain tests
+ tests/Clash/Tests/Resize.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}++module Clash.Tests.Resize (tests, main) where++import Clash.Prelude (Unsigned, Signed, BitVector, Index)+import Clash.Promoted.Nat (SNat(..))+import Clash.XException (XException)+import Control.DeepSeq (NFData)+import Control.Exception (SomeException, try, evaluate)+import Data.Either (isLeft)+import Data.Proxy (Proxy(Proxy))+import GHC.TypeNats (KnownNat, SomeNat(..), type (<=), type (+), Nat, someNatVal)+import Hedgehog ((===))+import Numeric.Natural (Natural)+import Test.Tasty (TestTree, testGroup, defaultMain)+import Test.Tasty.Hedgehog (testPropertyNamed)+import Test.Tasty.QuickCheck (testProperty, discard, ioProperty, counterexample)++import qualified Clash.Class.Resize as Resize+import qualified Hedgehog as H+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import qualified Test.Tasty.QuickCheck as Q++withSomeSNat :: Natural -> (forall (n :: Nat). SNat n -> r) -> r+withSomeSNat n f = case someNatVal n of+  SomeNat (_ :: Proxy n) -> f (SNat @n)++-- | Anything that's in bounds should not cause an error+indexProp ::+  forall a b.+  ((a <= b), KnownNat a, KnownNat b) =>+  Proxy b -> Index a -> Bool+indexProp Proxy v =+  Resize.resize v == Resize.checkedResize @a @b v++-- | Anything that's out of bounds should cause an error+indexFailProp ::+  forall a b.+  ((b <= a), KnownNat a, KnownNat b) =>+  Proxy b -> Index a -> Q.Property+indexFailProp Proxy v =+  let checked = Resize.checkedResize @a @b v in+  if toInteger v > toInteger (maxBound @(Index b)) then+    expectExceptionNoX checked+  else+    discard++maybeResizePropT ::+  forall f a b .+  ( Integral (f a)+  , Bounded (f a)+  , Show (f a)+  , Integral (f b)+  , Bounded (f b)+  , Show (f b)+  , Resize.Resize f+  , KnownNat a+  , KnownNat b+  ) =>+  Proxy (f a) ->+  Proxy (f b) ->+  H.PropertyT IO ()+maybeResizePropT _ _ = do+  let+    minFa = fromIntegral (minBound @(f a)) :: Integer+    maxFa = fromIntegral (maxBound @(f a)) :: Integer+    minFb = fromIntegral (minBound @(f b)) :: Integer+    maxFb = fromIntegral (maxBound @(f b)) :: Integer++  H.footnote $ "minFa: " <> show minFa+  H.footnote $ "maxFa: " <> show maxFa+  H.footnote $ "minFb: " <> show minFb+  H.footnote $ "maxFb: " <> show maxFb++  input <- H.forAll $ Gen.integral (Range.constant minFa maxFa)+  let output = Resize.maybeResize @a @b @f (fromIntegral input)+  if minFb <= input && input <= maxFb+  then output === Just (fromIntegral input)+  else output === Nothing++maybeResizeUnsignedProp :: H.Property+maybeResizeUnsignedProp = H.property $ do+  a <- H.forAll $ Gen.integral (Range.linear 0 100)+  b <- H.forAll $ Gen.integral (Range.linear 0 100)+  withSomeSNat a $ \(SNat :: SNat a) -> do+    withSomeSNat b $ \(SNat :: SNat b) -> do+      maybeResizePropT @Unsigned @a @b Proxy Proxy++maybeResizeSignedProp :: H.Property+maybeResizeSignedProp = H.property $ do+  a <- H.forAll $ Gen.integral (Range.linear 0 100)+  b <- H.forAll $ Gen.integral (Range.linear 0 100)+  withSomeSNat a $ \(SNat :: SNat a) -> do+    withSomeSNat b $ \(SNat :: SNat b) -> do+      maybeResizePropT @Signed @a @b Proxy Proxy++maybeResizeIndexProp :: H.Property+maybeResizeIndexProp = H.property $ do+  a <- H.forAll $ Gen.integral (Range.linear 1 (2^(128::Natural)))+  b <- H.forAll $ Gen.integral (Range.linear 1 (2^(128::Natural)))+  withSomeSNat a $ \(SNat :: SNat a) -> do+    withSomeSNat b $ \(SNat :: SNat b) -> do+      maybeResizePropT @Index @a @b Proxy Proxy++maybeResizeBitVectorProp :: H.Property+maybeResizeBitVectorProp = H.property $ do+  a <- H.forAll $ Gen.integral (Range.linear 0 100)+  b <- H.forAll $ Gen.integral (Range.linear 0 100)+  withSomeSNat a $ \(SNat :: SNat a) -> do+    withSomeSNat b $ \(SNat :: SNat b) -> do+      maybeResizePropT @BitVector @a @b Proxy Proxy++maybeTruncatePropT ::+  forall f a b .+  ( Integral (f a)+  , Bounded (f a)+  , Show (f a)+  , Integral (f (a + b))+  , Bounded (f (a + b))+  , Show (f (a + b))+  , Resize.Resize f+  , KnownNat a+  , KnownNat b+  ) =>+  Proxy (f a) ->+  Proxy (f (a + b)) ->+  H.PropertyT IO ()+maybeTruncatePropT _ _ = do+  let+    minFa = fromIntegral (minBound @(f a)) :: Integer+    maxFa = fromIntegral (maxBound @(f a)) :: Integer+    minFab = fromIntegral (minBound @(f (a + b))) :: Integer+    maxFab = fromIntegral (maxBound @(f (a + b))) :: Integer++  H.footnote $ "minFa: " <> show minFa+  H.footnote $ "maxFa: " <> show maxFa+  H.footnote $ "minFab: " <> show minFab+  H.footnote $ "maxFab: " <> show maxFab++  input <- H.forAll $ Gen.integral (Range.constant minFa maxFa)+  let output = Resize.maybeTruncateB @a @b @f (fromIntegral input)+  if minFab <= input && input <= maxFab+  then output === Just (fromIntegral input)+  else output === Nothing++maybeTruncateUnsignedProp :: H.Property+maybeTruncateUnsignedProp = H.property $ do+  a <- H.forAll $ Gen.integral (Range.linear 0 100)+  b <- H.forAll $ Gen.integral (Range.linear 0 100)+  withSomeSNat a $ \(SNat :: SNat a) -> do+    withSomeSNat b $ \(SNat :: SNat b) -> do+      maybeTruncatePropT @Unsigned @a @b Proxy Proxy++maybeTruncateSignedProp :: H.Property+maybeTruncateSignedProp = H.property $ do+  a <- H.forAll $ Gen.integral (Range.linear 0 100)+  b <- H.forAll $ Gen.integral (Range.linear 0 100)+  withSomeSNat a $ \(SNat :: SNat a) -> do+    withSomeSNat b $ \(SNat :: SNat b) -> do+      maybeTruncatePropT @Signed @a @b Proxy Proxy++maybeTruncateIndexProp :: H.Property+maybeTruncateIndexProp = H.property $ do+  a <- H.forAll $ Gen.integral (Range.linear 1 (2^(128::Natural)))+  b <- H.forAll $ Gen.integral (Range.linear 1 (2^(128::Natural)))+  withSomeSNat a $ \(SNat :: SNat a) -> do+    withSomeSNat b $ \(SNat :: SNat b) -> do+      maybeTruncatePropT @Index @a @b Proxy Proxy++maybeTruncateBitVectorProp :: H.Property+maybeTruncateBitVectorProp = H.property $ do+  a <- H.forAll $ Gen.integral (Range.linear 0 100)+  b <- H.forAll $ Gen.integral (Range.linear 0 100)+  withSomeSNat a $ \(SNat :: SNat a) -> do+    withSomeSNat b $ \(SNat :: SNat b) -> do+      maybeTruncatePropT @BitVector @a @b Proxy Proxy++-- | Succeed if evaluating leads to a non-XException Exception+expectExceptionNoX :: (Show a, NFData a) => a -> Q.Property+expectExceptionNoX a0 = ioProperty $ do+  a1 <- try @SomeException (try @XException (evaluate a0))+  pure $+    counterexample+      ("Expected non-XException Exception, got: " <> show a1)+      (isLeft a1)++tests :: TestTree+tests = testGroup "Resize"+  [ testGroup "checkedResize"+    [ testProperty "indexProp @17 @19" (indexProp @17 @19 Proxy)+    , testProperty "indexProp @19 @19" (indexProp @19 @19 Proxy)+    , testProperty "indexFailProp @37 @7" (indexFailProp @37 @7 Proxy)+    , testPropertyNamed "maybeResizeUnsignedProp" "maybeResizeUnsignedProp" maybeResizeUnsignedProp+    , testPropertyNamed "maybeResizeSignedProp" "maybeResizeSignedProp" maybeResizeSignedProp+    , testPropertyNamed "maybeResizeIndexProp" "maybeResizeIndexProp" maybeResizeIndexProp+    , testPropertyNamed "maybeResizeBitVectorProp" "maybeResizeBitVectorProp" maybeResizeBitVectorProp+    , testPropertyNamed "maybeTruncateUnsignedProp" "maybeTruncateUnsignedProp" maybeTruncateUnsignedProp+    , testPropertyNamed "maybeTruncateSignedProp" "maybeTruncateSignedProp" maybeTruncateSignedProp+    , testPropertyNamed "maybeTruncateIndexProp" "maybeTruncateIndexProp" maybeTruncateIndexProp+    , testPropertyNamed "maybeTruncateBitVectorProp" "maybeTruncateBitVectorProp" maybeTruncateBitVectorProp+    ]+  ]++main :: IO ()+main = defaultMain+  -- $ adjustOption (\_ -> HedgehogTestLimit (Just 1_000_000))+  $ tests
tests/Clash/Tests/Signal.hs view
@@ -1,92 +1,45 @@ {-| Copyright  :  (C) 2019, Myrtle Software Ltd+                  2022, Google Inc.+                  2023, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# LANGUAGE CPP                       #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE TypeApplications          #-}-{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-orphans #-}  module Clash.Tests.Signal where -import           Clash.Signal+import qualified Prelude as P+import           Prelude hiding (undefined) -import           Data.List                      (isInfixOf)-import           Test.Tasty-import           Test.Tasty.HUnit+import qualified Clash.Explicit.Prelude         as E+import           Clash.Prelude                  hiding (sample) -import qualified Language.Haskell.Interpreter   as Hint-import           Language.Haskell.Interpreter   (OptionVal((:=)))+import           Clash.Signal.Internal+  (Femtoseconds(..), dynamicClockGen, sample, head#) -customTypeMark :: String-customTypeMark = "You tried to apply an explicitly routed clock, reset, or enable line"+import           Control.Exception              (evaluate)+import           Test.Tasty+import           Test.Tasty.HUnit -typeCheck-  :: String-  -> IO (Either Hint.InterpreterError ())-typeCheck expr =-  Hint.runInterpreter $ do-    Hint.setImports ["Clash.Prelude"]-    Hint.set [Hint.languageExtensions := [Hint.RankNTypes, Hint.TypeApplications]]-    mapM_ Hint.runStmt [test0s, test1s, test2s, test3s, test4s]-    Hint.interpret expr (Hint.as :: ())+createDomain vSystem{vName="H11", vPeriod=hzToPeriod 11}+createDomain vSystem{vName="H77", vPeriod=hzToPeriod 77} -assertCustomTypeError :: String -> String -> Assertion-assertCustomTypeError expectedErr expr = do-  result <- typeCheck expr-  case result of-    Left err ->-      if expectedErr `isInfixOf` show err then-        pure ()-      else-        assertFailure $-             "Expression failed to typecheck as expected, but did not contain "-          ++ "expected type error. Instead it contained: " ++ show err-    Right () ->-      assertFailure "Expression should have failed to typecheck, but succeeded."+createDomain vSystem{vName="F1", vPeriod=20}+createDomain vSystem{vName="F6", vPeriod=250}  main :: IO () main = defaultMain tests -test0s, test1s, test2s, test3s :: String-test0s = "let test0 = undefined :: Signal dom1 a -> Signal dom2 Int"-test1s = "let test1 = undefined :: Int -> Char -> Int"-test2s = "let test2 = undefined :: Signal System a -> Signal XilinxSystem Int"-test3s = "let test3 = () :: ()"-test4s = "let test4 = undefined :: ((Signal dom1 a, Signal dom2 a), Signal dom3 a)"-test5s = "let test5 = undefined :: ((Char, Signal dom1 a), Signal dom2 a)"--test0 :: forall dom1 dom2. Signal dom1 Int -> Signal dom2 Int-test0 = undefined--test1 :: Int -> Char -> Int-test1 = undefined--test2 :: Signal System a -> Signal XilinxSystem Int-test2 = undefined--test3 :: ()-test3 = ()--test4-  :: forall dom1 dom2 dom3 dom4 a-   . ((Signal dom1 a, Signal dom2 a), Signal dom3 a)-  -> Signal dom4 a-test4 = undefined--test5-  :: forall dom1 dom2 a b-   . ((b, Signal dom1 a), Signal dom2 a)-test5 = undefined--acte :: String -> Assertion-acte = assertCustomTypeError customTypeMark- tests :: TestTree tests =   testGroup@@ -95,84 +48,169 @@         "Implicit"         [ -- See: https://github.com/clash-lang/clash-compiler/pull/655           let rst0 = fromList [True, True, False, False, True, True]-              rst1 = unsafeFromHighPolarity rst0+              rst1 = unsafeFromActiveHigh rst0               reg  = register 'a' (pure 'b')-#ifdef CLASH_MULTIPLE_HIDDEN-              sig = withReset rst1 reg-#else               sig = withReset @System rst1 reg-#endif           in  testCase "withReset behavior" (sampleN @System 6 sig @?= "aaabaa") -#ifdef CLASH_MULTIPLE_HIDDEN-          -- See: https://github.com/clash-lang/clash-compiler/pull/669-        , testCase "test0nok_0" (acte "withReset resetGen test0")-        , testCase "test0nok_1" (acte "withReset (resetGen @System) test0")-        , testCase "test0nok_2" (acte "withReset @System (resetGen @System) test0")-        , testCase-            "test0nok_3"-            (acte-              (unwords-                [ "withReset", "@System", "(resetGen @System)"-                , "(test0 :: Signal System a -> Signal dom Int)"-                ]))+        , testCase "T1521" $+            let+              f (_, b) = (b, b)+              s = f <$> liftA2 (,) (fst <$> s) (pure 'a')+              a = fst (head# s)+            in+              evaluate a >> pure ()+        ]+    , testGroup "SaturatingNum"+      [ testCase "satSucc SatWrap" case_satSuccSatWrap+      , testCase "satSucc SatBound" case_satSuccSatBound+      , testCase "satPred SatWrap" case_satPredSatWrap+      , testCase "satPred SatBound" case_satPredSatBound+      ]+    , testGroup "unsafeSynchronizer"+      [ testCase "case_dynamicStaticEq" case_dynamicStaticEq+      , testCase "case_dynamicHasEffect" case_dynamicHasEffect+      , testCase "case_changingDynamicClocks" case_changingDynamicClocks+      , testCase "case_F1_F6" case_F1_F6+      , testCase "case_F6_F1" case_F6_F1+      ]+    ] -        , testCase "test0nok_4" (acte "withSpecificReset resetGen test0")-        , testCase "test0nok_5" (acte "withSpecificReset (resetGen @System) test0")+-- | Asserts that static clocks behave the same as dynamic clocks with a static+-- period signal passed into it.+case_dynamicStaticEq :: Assertion+case_dynamicStaticEq = do+  let+    sampleMagicN = P.take 500 . sample -        , testCase "test1nok_0" (acte "withReset resetGen test1")-        , testCase "test1nok_1" (acte "withReset (resetGen @System) test1")-        , testCase "test1nok_2" (acte "withSpecificReset resetGen test1")-        , testCase "test1nok_3" (acte "withSpecificReset (resetGen @System) test1")+    clk11 = clockGen @H11+    clk77 = clockGen @H77 -        , testCase "test2nok_0" (acte "withReset resetGen test2")-        , testCase "test2nok_1" (acte "withReset (resetGen @System) test2")-        , testCase "test2nok_2" (acte "withSpecificReset resetGen test2")+    -- We construct periods in a roundabout way (i.e., using 'hzToPeriod' instead+    -- of using 'hzToFs'), to prevent rounding errors between periods of the+    -- static clocks and the periods of the dynamic clocks.+    fs11 = Femtoseconds (1000 * hzToPeriod 11)+    fs77 = Femtoseconds (1000 * hzToPeriod 77) -        , testCase "test3nok_0" (acte "withReset resetGen test3")-        , testCase "test3nok_1" (acte "withReset (resetGen @System) test3")-        , testCase "test3nok_2" (acte "withSpecificReset resetGen test3")-        , testCase "test3nok_3" (acte "withSpecificReset (resetGen @System) test3")+    dclk11 = dynamicClockGen @H11 (pure fs11)+    dclk77 = dynamicClockGen @H77 (pure fs77) -        , testCase "test4nok_0" (acte $-             "withSpecificReset resetGen (test4 :: "-          ++ "((Signal System a, Signal dom2 a), Signal dom3 a)"-          ++ "-> Signal dom4 a)" )+    counter :: forall dom. Signal dom Int+    counter = fromList [0..] -        , testCase "test4nok_1" (acte $-             "withSpecificReset resetGen (test4 :: "-          ++ "((Signal dom1 a, Signal System a), Signal dom3 a)"-          ++ "-> Signal dom4 a)" )+  assertEqual+    "clk11+clk77 == dclk11+dclk77"+    (sampleMagicN (E.unsafeSynchronizer clk11 clk77 counter))+    (sampleMagicN (E.unsafeSynchronizer dclk11 dclk77 counter)) -        , testCase "test4nok_2" (acte $-             "withReset resetGen (test4 :: "-          ++ "((Signal System a, Signal dom2 a), Signal dom3 a)"-          ++ "-> Signal dom4 a)" )+  assertEqual+    "clk11+dclk77 == dclk11+clk77"+    (sampleMagicN (E.unsafeSynchronizer clk11 dclk77 counter))+    (sampleMagicN (E.unsafeSynchronizer dclk11 clk77 counter)) -        , testCase "test4nok_3" (acte $-             "withReset resetGen (test4 :: "-          ++ "((Signal dom1 a, Signal System a), Signal dom3 a)"-          ++ "-> Signal dom4 a)" )+-- | Asserts that "lying" about a clock's frequency has effect.+case_dynamicHasEffect :: Assertion+case_dynamicHasEffect = do+  let+    sampleMagicN = P.take 500 . sample -        , testCase "test5nok_0" (acte "withSpecificReset resetGen test5")-#endif-        ]+    -- We construct periods in a roundabout way (i.e., using 'hzToPeriod' instead+    -- of using 'hzToFs'), to prevent rounding errors between periods of the+    -- static clocks and the periods of the dynamic clocks.+    fs11 = Femtoseconds (1000 * hzToPeriod 11)+    fs77lying = Femtoseconds (1000 * hzToPeriod 78)++    clk11 = clockGen @H11+    clk77 = clockGen @H77+    dclk11 = dynamicClockGen @H11 (pure fs11)+    dclk77lying = dynamicClockGen @H77 (pure fs77lying)++    counter :: forall dom. Signal dom Int+    counter = fromList [0..]++  assertBool "clk11+clk77 /= dclk11+dclk77lying" $+       (sampleMagicN (E.unsafeSynchronizer clk11 clk77 counter))+    /= (sampleMagicN (E.unsafeSynchronizer dclk11 dclk77lying counter))++-- | Regression test+case_changingDynamicClocks :: Assertion+case_changingDynamicClocks = do+  let+    dclk11 = dynamicClockGen @H11 $ fromList $ cycle $ fmap Femtoseconds+      [10, 20, 30, 40, 50, 60, 70, 80, 90]+    dclk77 = dynamicClockGen @H77 $ fromList $ cycle $ fmap Femtoseconds+      [90, 80, 70, 60, 50, 40, 30, 20, 10]++    counter = fromList [(0 :: Int)..]+    actual = P.take 70 (sample (E.unsafeSynchronizer dclk11 dclk77 counter))++  assertEqual "unsafeSynchronizer produced hardcoded results" actual+    [ 0, 4, 6, 7, 8, 8, 9, 9, 9, 9, 13, 15, 16, 17, 17, 18, 18, 18, 18, 22, 24+    , 25, 26, 26, 27, 27, 27, 27, 31, 33, 34, 35, 35, 36, 36, 36, 36, 40, 42+    , 43, 44, 44, 45, 45, 45, 45, 49, 51, 52, 53, 53, 54, 54, 54, 54, 58, 60+    , 61, 62, 62, 63, 63, 63, 63, 67, 69, 70, 71, 71, 72     ] --- Tests below should survive compilation:-test0ok_0 = withReset @System (resetGen @System) (test0 @System @System)-#ifdef CLASH_MULTIPLE_HIDDEN-test0ok_1 = withReset resetGen (test0 @System @System)-test0ok_2 = withSpecificReset (resetGen @System) (test0 @System)-test0ok_3 = withSpecificReset (resetGen @System) (test0 @_ @System)+-- | Regression test+case_F1_F6 :: Assertion+case_F1_F6 = do+  let+    clk1 = clockGen @F1+    clk6 = clockGen @F6 -test2ok_0 = withSpecificReset (resetGen @System) test2-test2ok_1 = withSpecificReset @System resetGen test2+    counter = fromList [(0 :: Int)..] -test4ok_0 = withReset resetGen (test4 @System @System @System @System)-test4ok_1 = withSpecificReset (resetGen @System) (test4 @System @_ @_ @_)-test4ok_2 = withSpecificReset (resetGen @System) (test4 @_ @System @_ @_)-test4ok_3 = withSpecificReset (resetGen @System) (test4 @_ @_ @System @_)+    actual = P.take 70 (sample (E.unsafeSynchronizer clk1 clk6 counter)) -test5ok_0 = withSpecificReset (resetGen @System) (test5 @System @_)-#endif+  assertEqual "unsafeSynchronizer produced hardcoded results" actual+    [ 0, 13, 25, 38, 50, 63, 75, 88, 100, 113, 125, 138, 150, 163, 175, 188, 200+    , 213, 225, 238, 250, 263, 275, 288, 300, 313, 325, 338, 350, 363, 375, 388+    , 400, 413, 425, 438, 450, 463, 475, 488, 500, 513, 525, 538, 550, 563, 575+    , 588, 600, 613, 625, 638, 650, 663, 675, 688, 700, 713, 725, 738, 750, 763+    , 775, 788, 800, 813, 825, 838, 850, 863+    ]++-- | Regression test+case_F6_F1 :: Assertion+case_F6_F1 = do+  let+    clk1 = clockGen @F1+    clk6 = clockGen @F6++    counter = fromList [(0 :: Int)..]++    actual = P.take 70 (sample (E.unsafeSynchronizer clk6 clk1 counter))++  assertEqual "unsafeSynchronizer produced hardcoded results" actual+    [ 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2+    , 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4+    , 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 6, 6, 6, 6, 6, 6, 6+    ]++-- | Test that satSucc SatWrap works on signals+case_satSuccSatWrap :: Assertion+case_satSuccSatWrap = do+  let s = fromList [255, 254] :: Signal System (Unsigned 8)+      result = satSucc SatWrap s+  sampleN @System 2 result @?= [0, 255]++-- | Test that satSucc SatBound works on signals+case_satSuccSatBound :: Assertion+case_satSuccSatBound = do+  let s = fromList [255, 254] :: Signal System (Unsigned 8)+      result = satSucc SatBound s+  sampleN @System 2 result @?= [255, 255]++-- | Test that satPred SatWrap works on signals+case_satPredSatWrap :: Assertion+case_satPredSatWrap = do+  let s = fromList [0, 1] :: Signal System (Unsigned 8)+      result = satPred SatWrap s+  sampleN @System 2 result @?= [255, 0]++-- | Test that satPred SatBound works on signals+case_satPredSatBound :: Assertion+case_satPredSatBound = do+  let s = fromList [0, 1] :: Signal System (Unsigned 8)+      result = satPred SatBound s+  sampleN @System 2 result @?= [0, 0]
+ tests/Clash/Tests/Signed.hs view
@@ -0,0 +1,77 @@+module Clash.Tests.Signed (tests) where++import Data.Proxy+import GHC.TypeNats (KnownNat, SomeNat (..), natVal, someNatVal)+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import Data.Bits (Bits(shiftR))++import Clash.Sized.Internal.Signed+import Clash.Tests.SizedNum++import Test.Tasty.HUnit.Extra (expectException)++tests :: TestTree+tests = localOption (QuickCheckMaxRatio 2) $ testGroup "All"+  [ testGroup "Signed 1" $+      testProperty "fromInteger"+        (fromIntegerProp (Proxy :: Proxy 1)) :+      map lawsToTest (laws1 (Proxy :: Proxy (Signed 1)))+  , testGroup "Signed 21" $+      testProperty "fromInteger"+        (fromIntegerProp (Proxy :: Proxy 21)) :+      map lawsToTest (laws (Proxy :: Proxy (Signed 21)))+  , testGroup "Signed 83" $+      testProperty "fromInteger"+        (fromIntegerProp (Proxy :: Proxy 83)) :+      map lawsToTest (laws (Proxy :: Proxy (Signed 83)))+  , testGroup "Random Signed"+    [ testProperty "fromInteger" fromIntegerRandomProp  ]+  , testGroup "Enum"+    [ testCase "[3,2..]" $ [3,2..] @?= [3,2,1,0,-1,-2,-3,-4 :: Signed 3]+    , testCase "[3,1..]" $ [3,1..] @?= [3,1,-1,-3,-5,-7 :: Signed 4]+    , testCase "take 5 [4,4..]" $ take 5 [4,4..] @?= [4,4,4,4,4 :: Signed 4]+    , testCase "[2,4..]" $ [2,4..] @?= [2,4,6 :: Signed 4]+    , testCase "[3,4..]" $ [3,4..] @?= [3,4,5,6,7 :: Signed 4]+    ]+  , testGroup "Bounds"+    [ testCase "maxBound :: Signed 0" $ maxBound @(Signed 0) @?= 0+    , testCase "minBound :: Signed 0" $ minBound @(Signed 0) @?= 0+    ]+  , testGroup "shiftR"+    [ testCase "shiftR 5 0 == 5" $+        shiftR (5 :: Signed 8) 0 @?= 5+    , testCase "returns 0 when non-negative and n == bitSize" $+        shiftR (0x7F :: Signed 8) 8 @?= 0+    , testCase "returns 0 when non-negative and n > bitSize" $+        shiftR (0x7F :: Signed 8) (8 + 1) @?= 0+    , testCase "returns 0 when non-negative and n >> bitSize" $+        shiftR (0x7F :: Signed 8) (8 + 1000) @?= 0+    , testCase "returns -1 when negative and n == bitSize" $+        shiftR (-1 :: Signed 8) 8 @?= (-1)+    , testCase "returns -1 when negative and n > bitSize" $+        shiftR (-50 :: Signed 8) (8 + 1) @?= (-1)+    , testCase "returns -1 when negative and n >> bitSize" $+        shiftR (-1 :: Signed 8) (8 + 1000) @?= (-1)+    , testCase "undefined when n < 0" $+        expectException (shiftR (1 :: Signed 8) (-1))+    ]+  ]+++fromIntegerProp :: forall m. KnownNat m => Proxy m -> Integer -> Property+fromIntegerProp p n = unsafeToInteger m === fromInteger i+  where+    m :: Signed m+    m = fromInteger n++    mb = 2 ^ (toInteger (natVal p) - 1)+    i = case divMod n mb of+          (d,r) | even d    -> r+                | otherwise -> r - mb++fromIntegerRandomProp :: Positive Integer -> Integer -> Property+fromIntegerRandomProp (Positive m) n = m > 1 ==> case someNatVal (fromInteger m) of+  SomeNat p -> fromIntegerProp p n
+ tests/Clash/Tests/SizedNum.hs view
@@ -0,0 +1,24 @@+module Clash.Tests.SizedNum where++import Data.Bits+import Data.Proxy+import Test.QuickCheck.Classes.Base+import Test.Tasty+import Test.Tasty.QuickCheck++laws1 :: (Eq a, Ord a, Show a, Num a, Arbitrary a, Integral a, FiniteBits a) => Proxy a -> [Laws]+laws1 p =+    [ eqLaws          p+    , ordLaws         p+    , numLaws         p+    , showLaws        p+    , integralLaws    p+    , bitsLaws        p+    ]++laws :: (Eq a, Ord a, Show a, Num a, Enum a, Bounded a, Arbitrary a, Integral a, FiniteBits a) => Proxy a -> [Laws]+laws p = boundedEnumLaws p : laws1 p++lawsToTest :: Laws -> TestTree+lawsToTest (Laws name props) =+  testGroup name $ map (uncurry testProperty) props
+ tests/Clash/Tests/TopEntityGeneration.hs view
@@ -0,0 +1,364 @@+{-# OPTIONS_GHC -Wwarn #-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Clash.Tests.TopEntityGeneration where++import Language.Haskell.TH.Syntax (unTypeQ)++import Test.Tasty+import Test.Tasty.HUnit++import Clash.Prelude hiding (undefined)+import Clash.Annotations.TH++type Pair a = ("left" ::: a, "right" ::: a)++data Unnamed = Unnamed Int+data Simple = Simple ("simple1" ::: Int) ("simple2" ::: Bool)+data Named+  = Named+  { name1 :: "named1" ::: BitVector 3+  , name2 :: "named2" ::: BitVector 5+  }+data Embedded+  = Embedded+  { name3 :: "embedded1" ::: Simple+  , name4 :: "embedded2" ::: Bool+  }+data OneSide+  = OneSide+  { name5 :: "embedded1" ::: Simple+  , name6 :: Bool+  }+newtype Single = Single ("s" ::: Int)++data Gadt x where+  Gadt :: ("gadt" ::: Int) -> Gadt Int++type family CF x y z where+  CF Int Int Int = ("cfiii" ::: Single)+  CF Bool Int Int = ("cfbii" ::: Single)++type family OrderedCF b f a where+    OrderedCF 'True f a = f a+    OrderedCF b f a = ()++type family OF x y z+type instance OF Int Int Int = ("ofiii" ::: Single)+type instance OF Bool Int Int = ("ofbii" ::: Single)++data family X x y z+data instance X Int Int Int = X1 ("xiii" ::: Int) ("xiii2" ::: Bool)+newtype instance X Bool Int Int = X2 ("xbii" ::: Int)++data Impossible = L ("left" ::: Int) | R ("right" ::: Bool)++data FailureTy1 = TwoF1 ("one" ::: Int) Int+data SuccessTy = TwoS ("one" ::: Int) Single++data Passthrough a b = Passthrough a b++data HKD f = HKD+    { fd1 :: OrderedCF 'True f  ("fd1" ::: Int)+    , fd2 :: OrderedCF 'True f  ("fd2" ::: Bool)+    }++data RecordWithSimOnlyField = RecordWithSimOnlyField+  { simOnlyField1 :: "a" ::: SimOnly (Signal System ("foo" ::: Int))+  , simOnlyField3 :: "b" ::: Signal System (SimOnly ("bar" ::: Int))+  , someOtherField :: "c" ::: Signal System ("wobble" ::: Int)+  }+++topEntity1 :: "in1" ::: Signal System Int+           -> "in2" ::: Signal System Bool+           -> "out" ::: Signal System Int+topEntity1 = undefined+makeTopEntity 'topEntity1++expectedTopEntity1 :: TopEntity+expectedTopEntity1 =+ Synthesize "topEntity1"+    [PortName "in1", PortName "in2"]+    (PortName "out")++topEntity2 :: "int"      ::: Signal System Int+           -> "tuple"    ::: ( "tup1" ::: Signal System (BitVector 7)+                             , "tup2" ::: Signal System (BitVector 9))+           -> "simple"   ::: Signal System Simple+           -> "named"    ::: Signal System Named+           -> "embedded" ::: Signal System Embedded+           -> "out"      ::: Signal System Bool+topEntity2 = undefined+makeTopEntity 'topEntity2++expectedTopEntity2 :: TopEntity+expectedTopEntity2 =+  Synthesize "topEntity2"+    [ PortName "int"+    , PortProduct "tuple" [PortName "tup1",PortName "tup2"]+    , PortProduct "simple" [PortName "simple1",PortName "simple2"]+    , PortProduct "named" [PortName "named1",PortName "named2"]+    , PortProduct "embedded"+      [ PortProduct "embedded1"+        [ PortName "simple1"+        , PortName "simple2"]+      , PortName "embedded2"]+    ]+    (PortName "out")++topEntity3 :: "clk" ::: Clock System+           -> "rst" ::: Reset System+           -> "en"  ::: Enable System+           -> "tup1" ::: Signal System (Int, Bool)+           -> "tup2" ::: (Signal System Int, Signal System Bool)+           -> "tup3" ::: Signal System ("int":::Int, "bool":::Bool)+           -> "tup4" ::: ("int":::Signal System Int, "bool":::Signal System Bool)+           -> "custom" ::: Signal System Named+           -> "outTup" ::: Signal System ("outint":::Int, "outbool":::Bool)+topEntity3 = undefined+makeTopEntity 'topEntity3++expectedTopEntity3 :: TopEntity+expectedTopEntity3 =+  Synthesize "topEntity3"+    [ PortName "clk"+    , PortName "rst"+    , PortName "en"+    , PortName "tup1"+    , PortName "tup2"+    , PortProduct "tup3" [PortName "int",PortName "bool"]+    , PortProduct "tup4" [PortName "int",PortName "bool"]+    , PortProduct "custom" [PortName "named1",PortName "named2"]+    ]+    (PortProduct "outTup" [PortName "outint",PortName "outbool"])++topEntity4 :: Signal System (Gadt Int)+           -> Signal System Single+           -> Signal System (CF Int Int Int)+           -> Signal System (CF Bool Int Int)+           -> Signal System (OF Int Int Int)+           -> Signal System (OF Bool Int Int)+           -> Signal System (X Int Int Int)+           -> Signal System (X Bool Int Int)+           -> "hkd" ::: HKD (Signal System)+           -> Signal System Single+topEntity4 = undefined+makeTopEntity 'topEntity4++expectedTopEntity4 :: TopEntity+expectedTopEntity4 =+  Synthesize "topEntity4"+    [ PortName "gadt"+    , PortName "s"+    , PortName "cfiii_s"+    , PortName "cfbii_s"+    , PortName "ofiii_s"+    , PortName "ofbii_s"+    , PortProduct "" [PortName "xiii", PortName "xiii2"]+    , PortName "xbii"+    , PortProduct "hkd" [PortName "fd1", PortName "fd2"]+    ]+    (PortName "s")++topEntity5 :: "in1" ::: Signal System SuccessTy+           -> "ab"     ::: Signal System (Passthrough (Passthrough Simple Simple) Simple)+           -> "out" ::: Signal System Int+topEntity5 = undefined+makeTopEntity 'topEntity5++expectedTopEntity5 :: TopEntity+expectedTopEntity5 =+ Synthesize "topEntity5"+    [ PortProduct "in1" [PortName "one", PortName "s"]+    , PortProduct "ab" [PortProduct "" [PortProduct "" [PortName "simple1",PortName "simple2"]+                                       ,PortProduct "" [PortName "simple1",PortName "simple2"]]+                       ,PortProduct "" [PortName "simple1",PortName "simple2"]]+    ]+    (PortName "out")++topEntity6 :: (HiddenClockResetEnable System)+           => (1~1, Eq Int)+           => (Ord Int)+           => "in1" ::: Signal System SuccessTy+           -> "out" ::: Signal System Int+topEntity6 = undefined+makeTopEntity 'topEntity6++expectedTopEntity6 :: TopEntity+expectedTopEntity6 =+ Synthesize "topEntity6"+    [ PortProduct "" [ PortName "clk", PortName "rst", PortName "en"]+    , PortProduct "in1" [PortName "one", PortName "s"]]+    (PortName "out")+++topEntity7 :: (HiddenClockResetEnable System)+           => "in1" ::: Signal System (Vec 3 Int)+           -> "in2" ::: Signal System (Vec 3 Simple)+           -> "passthrough" ::: Signal System (Passthrough Single Single)+           -> "out" ::: Signal System Int+topEntity7 = undefined+makeTopEntity 'topEntity7++expectedTopEntity7 :: TopEntity+expectedTopEntity7 =+ Synthesize "topEntity7"+    [ PortProduct "" [PortName "clk", PortName "rst", PortName "en"]+    , PortName "in1"+    , PortName "in2"+    , PortProduct "passthrough" [PortName "s", PortName "s"]+    ]+    (PortName "out")++topEntity8 :: (HiddenClockResetEnable System)+           => "pair" ::: Signal System (Pair Bool)+           -> "pair" ::: Signal System (Pair Single)+           -> "out" ::: Signal System Int+topEntity8 = undefined+makeTopEntity 'topEntity8++expectedTopEntity8 :: TopEntity+expectedTopEntity8 =+ Synthesize "topEntity8"+    [ PortProduct "" [PortName "clk", PortName "rst", PortName "en"]+    , PortProduct "pair" [PortName "left", PortName "right"]+    , PortProduct "pair" [PortName "left_s", PortName "right_s"]+    ]+    (PortName "out")++topEntity9 :: (HiddenClockResetEnable System)+           => "pair" ::: SimOnly (Signal System (Pair Bool))+           -> "pair" ::: Signal System (SimOnly (Pair Single))+           -> "out" ::: Signal System Int+topEntity9 = undefined+makeTopEntity 'topEntity9++expectedTopEntity9 :: TopEntity+expectedTopEntity9 =+ Synthesize "topEntity9"+    [ PortProduct "" [PortName "clk", PortName "rst", PortName "en"]+    , PortName "pair"+    , PortName "pair"+    ]+    (PortName "out")++topEntity10 :: (HiddenClockResetEnable System)+           => "record" ::: Signal System RecordWithSimOnlyField+           -> "out" ::: Signal System Int+topEntity10 = undefined+makeTopEntity 'topEntity10++expectedTopEntity10 :: TopEntity+expectedTopEntity10 =+ Synthesize "topEntity10"+    [ PortProduct "" [PortName "clk", PortName "rst", PortName "en"]+    , PortProduct "record" [PortName "a",PortName "b",PortName "c_wobble"]+    ]+    (PortName "out")++topEntityFailure1+  :: "int"     ::: Signal System Int+  -> "tuple"   ::: ("tup1" ::: Signal System (BitVector 7), "tup2" ::: Signal System (BitVector 9))+  -> "simple"  ::: Signal System Simple+  -> "named"   ::: Signal System Named+  -> Signal System OneSide+  -> "out"     ::: Signal System Bool+topEntityFailure1 = undefined++topEntityFailure2+  :: "int"     ::: Signal System Int+  -> "tuple"   ::: ("tup1" ::: Signal System (BitVector 7), "tup2" ::: Signal System (BitVector 9))+  -> "simple"  ::: Signal System Simple+  -> "named"   ::: Signal System Named+  -> Signal System Int+  -> "out"     ::: Signal System Bool+topEntityFailure2 = undefined++topEntityFailure3+  :: "int"     ::: Signal System Impossible+  -> "out"     ::: Signal System Bool+topEntityFailure3 = undefined++topEntityFailure4+  :: "int"     ::: Signal System FailureTy1+  -> "out"     ::: Signal System Bool+topEntityFailure4 = undefined++topEntityFailure5+  :: "int"     ::: Signal System (Passthrough (Passthrough Simple Int) Simple)+  -> "out"     ::: Signal System Bool+topEntityFailure5 = undefined++topEntityFailure6+  :: "int"     ::: Signal System a+  -> "out"     ::: Signal System Bool+topEntityFailure6 = undefined++topEntityFailure8+  :: "int"     ::: Signal System (Passthrough Int Simple)+  -> "out"     ::: Signal System Bool+topEntityFailure8 = undefined++-- This splice is needed to make sure TH.names are in the type environment+-- during reify for the expected failure cases.+$( return [] )++tests :: TestTree+tests =+  testGroup "TopEntityGeneration"+    [ testGroup "Expected successes"+      [ testCase "topEntity1" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity1)+          @?= Just expectedTopEntity1+      , testCase "topEntity2" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity2)+          @?= Just expectedTopEntity2+      , testCase "topEntity3" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity3)+          @?= Just expectedTopEntity3+      , testCase "topEntity4" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity4)+          @?= Just expectedTopEntity4+      , testCase "topEntity5" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity5)+          @?= Just expectedTopEntity5+      , testCase "topEntity6" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity6)+          @?= Just expectedTopEntity6+      , testCase "topEntity7" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity7)+          @?= Just expectedTopEntity7+      , testCase "topEntity8" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity8)+          @?= Just expectedTopEntity8+      , testCase "topEntity9" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity9)+          @?= Just expectedTopEntity9+      , testCase "topEntity10" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity10)+          @?= Just expectedTopEntity10+      ]+    , testGroup "Expected failures"+      [ testCase "topEntityFailure1" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure1) @?= failed+      , testCase "topEntityFailure2" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure2) @?= failed+      , testCase "topEntityFailure3" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure3) @?= failed+      , testCase "topEntityFailure4" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure4) @?= failed+      , testCase "topEntityFailure5" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure5) @?= failed+      , testCase "topEntityFailure6" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure6) @?= failed+      , testCase "topEntityFailure8" $+          $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure8) @?= failed+      ]+    ]+ where+  failed = Nothing :: Maybe TopEntity
+ tests/Clash/Tests/Unsigned.hs view
@@ -0,0 +1,65 @@+module Clash.Tests.Unsigned (tests) where++import Data.Proxy+import GHC.TypeNats (KnownNat, SomeNat (..), natVal, someNatVal)+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import Data.Bits (Bits(shiftR))++import Clash.Sized.Internal.Unsigned+import Clash.Tests.SizedNum++import Test.Tasty.HUnit.Extra (expectException)++tests :: TestTree+tests = localOption (QuickCheckMaxRatio 2) $ testGroup "All"+  [ testGroup "Unsigned 1" $+      testProperty "fromInteger"+        (fromIntegerProp (Proxy :: Proxy 1)) :+      map lawsToTest (laws1 (Proxy :: Proxy (Unsigned 1)))+  , testGroup "Unsigned 21" $+      testProperty "fromInteger"+        (fromIntegerProp (Proxy :: Proxy 21)) :+      map lawsToTest (laws (Proxy :: Proxy (Unsigned 21)))+  , testGroup "Unsigned 83" $+      testProperty "fromInteger"+        (fromIntegerProp (Proxy :: Proxy 83)) :+      map lawsToTest (laws (Proxy :: Proxy (Unsigned 83)))+  , testGroup "Random Unsigned"+    [ testProperty "fromInteger" fromIntegerRandomProp ]+  , testGroup "Enum"+    [ testCase "[4,3..]" $ [4,3..] @?= [4,3,2,1,0 :: Unsigned 8]+    , testCase "[4,2..]" $ [4,2..] @?= [4,2,0 :: Unsigned 8]+    , testCase "take 5 [4,4..]" $ take 5 [4,4..] @?= [4,4,4,4,4 :: Unsigned 8]+    , testCase "[2,4..]" $ [2,4..] @?= [2,4,6 :: Unsigned 3]+    , testCase "[3,4..]" $ [3,4..] @?= [3,4,5,6,7 :: Unsigned 3]+    ]+  , testGroup "Bounds"+    [ testCase "maxBound :: Unsigned 0" $ maxBound @(Unsigned 0) @?= 0+    , testCase "minBound :: Unsigned 0" $ minBound @(Unsigned 0) @?= 0+    ]+  , testGroup "shiftR"+    [ testCase "shiftR 5 0 == 5" $+        shiftR (5 :: Unsigned 8) 0 @?= 5+    , testCase "returns 0 when n == bitSize" $+        shiftR (0xFF :: Unsigned 8) 8 @?= 0+    , testCase "returns 0 when n > bitSize" $+        shiftR (0xFF :: Unsigned 8) (8 + 1) @?= 0+    , testCase "returns 0 when n >> bitSize" $+        shiftR (0xFF :: Unsigned 8) (8 + 1000) @?= 0+    , testCase "undefined when n < 0" $+        expectException (shiftR (1 :: Unsigned 8) (-1))+    ]+  ]++fromIntegerProp :: forall m. KnownNat m => Proxy m -> Integer -> Property+fromIntegerProp p n = unsafeToNatural m === fromInteger (n `mod` (2 ^ toInteger (natVal p)))+  where+    m :: Unsigned m+    m = fromInteger n++fromIntegerRandomProp :: Positive Integer -> Integer -> Property+fromIntegerRandomProp (Positive m) n = m > 1 ==> case someNatVal (fromInteger m) of+  SomeNat p -> fromIntegerProp p n
+ tests/Clash/Tests/Vector.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TemplateHaskell #-}++module Clash.Tests.Vector where++import           Clash.Sized.Vector (Vec((:>), Nil))+import           Clash.XException++import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.TH++i :: Int -> Int+i = id++case_showXVector :: Assertion+case_showXVector = "1 :> 2 :> undefined" @=? showX (1 :> i 2 :> errorX "def")++case_showX2DVector :: Assertion+case_showX2DVector =+      "(1 :> undefined) :> (3 :> 5 :> Nil) :> Nil"+  @=? showX ((1 :> errorX "def") :> (3 :> i 5 :> Nil) :> Nil)++case_showX2DVectorInList :: Assertion+case_showX2DVectorInList =+      "[1 :> undefined,3 :> 5 :> Nil]"+  @=? showX [(1 :> errorX "def"), (3 :> i 5 :> Nil)]++case_showVector :: Assertion+case_showVector = "1 :> 2 :> 3 :> Nil" @=? show (1 :> 2 :> i 3 :> Nil)++case_show2DVector :: Assertion+case_show2DVector =+  "(1 :> 2 :> 3 :> Nil) :> Nil" @=? show ((1 :> 2 :> i 3 :> Nil) :> Nil)++case_showVectorInList :: Assertion+case_showVectorInList =+  "[1 :> 2 :> Nil,3 :> 4 :> Nil]" @=? show [1 :> 2 :> Nil, 3 :> i 4 :> Nil]++tests :: TestTree+tests = $(testGroupGenerator)++-- Run with:+--+--    ./repld p:tests -T Clash.Tests.Vector.main+--+-- Add -W if you want to run tests in spite of warnings+--+main :: IO ()+main = defaultMain tests
+ tests/Clash/Tests/XException.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TemplateHaskell #-}++module Clash.Tests.XException where++import Clash.XException++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.HUnit.Extra+import Test.Tasty.TH++expectLeft :: HasCallStack => Either a b -> Assertion+expectLeft (Left _) = pure ()+expectLeft (Right _) = assertFailure "Expected Left, got Right"++expectRight :: HasCallStack => Either a b -> Assertion+expectRight (Right _) = pure ()+expectRight (Left _) = assertFailure "Expected Right, got Left"++case_hasX :: Assertion+case_hasX = do+  expectRight        $ hasX @(Int, Int) (1, 2)+  expectLeft         $ hasX @(Int, Int) (x, 2)+  expectLeft         $ hasX @(Int, Int) (1, x)+  expectLeft         $ hasX @(Int, Int) (x, x)+  expectLeft         $ hasX @(Int, Int) x+  expectExceptionNoX $ hasX @(Int, Int) (e, 2)+  expectExceptionNoX $ hasX @(Int, Int) (1, e)+  expectExceptionNoX $ hasX @(Int, Int) (e, e)+  expectExceptionNoX $ hasX @(Int, Int) (x, e)+  expectExceptionNoX $ hasX @(Int, Int) (e, x)+  expectExceptionNoX $ hasX @(Int, Int) e+ where+  x = errorX "X"+  e = error "E"++tests :: TestTree+tests = $(testGroupGenerator)++-- Run with:+--+--    ./repld p:tests -T Clash.Tests.XException.main+--+-- Add -W if you want to run tests in spite of warnings+--+main :: IO ()+main = defaultMain tests
+ tests/Hedgehog/Extra.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE TypeApplications #-}++module Hedgehog.Extra+  ( throwsException+  , throwsDeepException+  , LockstepWalk(..)+  , lockstepWalk+  , combinations+  ) where++import Control.DeepSeq (NFData, force)++import Hedgehog (failure, MonadGen, MonadTest, success)+import Hedgehog.Internal.Exception (tryEvaluate)+import Hedgehog.Internal.Source (HasCallStack, withFrozenCallStack)++import qualified Hedgehog.Gen as Gen++throwsException+  :: ( MonadTest m+     , HasCallStack+     )+  => a+  -> m ()+throwsException x =+  case (tryEvaluate x) of+    Left _  -> success+    Right _ -> withFrozenCallStack failure++throwsDeepException+  :: ( MonadTest m+     , NFData a+     , HasCallStack+     )+  => a+  -> m ()+throwsDeepException =+  throwsException . force++{- | Test individual samples of a list through 'lockstepWalk'++@m@ is expected to be a 'MonadTest' monad.++The function gets a boolean indicating if this is the last sample in the list, plus the+current sample. It should return the function to test the next sample with.+-}+newtype LockstepWalk m a+  = LockstepWalk {unLockstepWalk :: Bool -> a -> m (LockstepWalk m a)}++{- | Walk a lazy list testing multiple properties++For each sample, multiple properties are tested. This way multiple tests can share a+walk of the list instead of the usual order where the first test would evaluate the+list fully even before the second test runs.+-}+lockstepWalk ::+  forall m a.+  (MonadTest m) =>+  [LockstepWalk m a] ->+  [a] ->+  m ()+lockstepWalk _ [] = pure ()+lockstepWalk ts (a : as) = do+  ts0 <- sequence $ map (\t -> unLockstepWalk t (null as) a) ts+  lockstepWalk ts0 as++{- | Generate combinations of k elements from a list++The generator shrinks towards the start of the list.+-}++{-+To generate combinations, if we consider the first element, we note that we can either+pick it or skip it. From the n choose k combinations, there are (n-1) choose (k-1)+combinations where we picked the element, and (n-1) choose k combinations where we skipped+the element. So let's define++pick = (n-1) choose (k-1)+skip = (n-1) choose k++We only need to know the ratio pick:skip. Working out the binomial coefficients, we come+to the following equivalent ratio:++pick' = k+skip' = n-k+-}+combinations ::+  (MonadGen m) =>+  [a] ->+  Int ->+  m [a]+combinations es k+  | k < 0 = error $ "combinations: impossible, k < 0. k = " <> show k+  | otherwise = combinations0 n k es+ where+  n = length es+  combinations0 _ 0 _ = pure []+  combinations0 n0 k0 es0 | n0 == k0 = pure es0+  combinations0 n0 k0 (e : es0) =+    Gen.frequency+      [ (k0, (e :) <$> combinations0 (n0 - 1) (k0 - 1) es0)+      , (n0 - k0, combinations0 (n0 - 1) k0 es0)+      ]+  combinations0 _ _ [] =+    error $ "combinations: impossible, k > n. k = " <> show k <> ", n = " <> show n
+ tests/Test/QuickCheck/Extra.hs view
@@ -0,0 +1,39 @@+module Test.QuickCheck.Extra+  ( expectException+  , expectXException+  , expectExceptionNoX+  ) where++import Test.Tasty.QuickCheck+import Control.DeepSeq (NFData)+import Control.Exception (SomeException, try, evaluate)+import Data.Either (isLeft)++import Clash.XException (XException)++-- | Succeed if evaluating leads to an XException+expectXException :: (Show a, NFData a) => a -> Property+expectXException a0 = ioProperty $ do+  a1 <- try @XException (evaluate a0)+  pure $+    counterexample+      ("Expected Exception, got: " <> show a1)+      (isLeft a1)++-- | Succeed if evaluating leads to an Exception+expectException :: (Show a, NFData a) => a -> Property+expectException a0 = ioProperty $ do+  a1 <- try @SomeException (evaluate a0)+  pure $+    counterexample+      ("Expected Exception, got: " <> show a1)+      (isLeft a1)++-- | Succeed if evaluating leads to a non-XException Exception+expectExceptionNoX :: (Show a, NFData a) => a -> Property+expectExceptionNoX a0 = ioProperty $ do+  a1 <- try @SomeException (try @XException (evaluate a0))+  pure $+    counterexample+      ("Expected non-XException Exception, got: " <> show a1)+      (isLeft a1)
+ tests/Test/Tasty/HUnit/Extra.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE LambdaCase #-}++module Test.Tasty.HUnit.Extra+  ( expectException+  , expectXException+  , expectExceptionNoX+  ) where++import Control.Exception (SomeException, try, evaluate)+import Test.Tasty.HUnit++import Clash.XException (XException)++-- | Succeed if evaluating leads to an XException+expectXException :: (Show a) => a -> Assertion+expectXException a0 =+  try @XException (evaluate a0) >>= \case+    Left _ -> pure ()+    Right a -> assertFailure ("Expected Exception, got: " <> show a)++-- | Succeed if evaluating leads to an Exception+expectException :: Show a => a -> Assertion+expectException a0 =+  try @SomeException (evaluate a0) >>= \case+    Left _ -> pure ()+    Right a -> assertFailure ("Expected Exception, got: " <> show a)++-- | Succeed if evaluating leads to a non-XException Exception+expectExceptionNoX :: Show a => a -> Assertion+expectExceptionNoX a0 =+  try @SomeException (try @XException (evaluate a0)) >>= \case+    Left _ -> pure ()+    Right a -> assertFailure ("Expected Exception, got: " <> show a)
+ tests/Test/Tasty/Hedgehog/Extra.hs view
@@ -0,0 +1,20 @@+{-|+Copyright  :  (C) 2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Convenience functions \"missing\" in "Test.Tasty.Hedgehog"+-}++module Test.Tasty.Hedgehog.Extra (testPropertyXXX) where++import Data.String (IsString(fromString))+import Hedgehog (Property)+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog (testPropertyNamed)++-- | 'Test.Tasty.Hedgehog.testProperty' has been deprecated in favor of+-- 'testPropertyNamed', but we've written our test cases in such a way that using+-- it correctly is hard. To prevent deprecation warnings, we apply this workaround.+testPropertyXXX :: TestName -> Property -> TestTree+testPropertyXXX nm prop = testPropertyNamed nm (fromString nm) prop
tests/doctests.hs view
@@ -1,17 +1,8 @@ {-# LANGUAGE CPP #-} module Main where -import Test.DocTest (doctest)+import Test.DocTest (mainFromCabal)+import System.Environment (getArgs)  main :: IO ()-main = doctest (docTestOpts ++ ["-isrc","src/Clash/Prelude.hs"-                               ,"src/Clash/Tutorial.hs"-                               ,"src/Clash/Examples.hs"])--docTestOpts :: [String]-docTestOpts =-#if __GLASGOW_HASKELL__ >= 802-  ["-fdiagnostics-color=never"]-#else-  []-#endif+main = mainFromCabal "clash-prelude" =<< getArgs
tests/unittests.hs view
@@ -2,19 +2,72 @@  import Test.Tasty +import qualified Clash.Tests.AsyncFIFOSynchronizer+import qualified Clash.Tests.AutoReg import qualified Clash.Tests.BitPack import qualified Clash.Tests.BitVector+import qualified Clash.Tests.BlockRam+import qualified Clash.Tests.BlockRam.Blob+import qualified Clash.Tests.Clocks+import qualified Clash.Tests.Counter import qualified Clash.Tests.DerivingDataRepr-import qualified Clash.Tests.Signal+import qualified Clash.Tests.DumpVCD+import qualified Clash.Tests.Fixed+import qualified Clash.Tests.FixedExhaustive+import qualified Clash.Tests.Index+import qualified Clash.Tests.MaybeNumConvert+import qualified Clash.Tests.MaybeX import qualified Clash.Tests.NFDataX+import qualified Clash.Tests.NumConvert+import qualified Clash.Tests.NumNewtypes+import qualified Clash.Tests.Ram+import qualified Clash.Tests.Reset+import qualified Clash.Tests.Resize+import qualified Clash.Tests.Signal+import qualified Clash.Tests.Signed+import qualified Clash.Tests.TopEntityGeneration+import qualified Clash.Tests.Unsigned+import qualified Clash.Tests.Vector+import qualified Clash.Tests.XException +import qualified Clash.Tests.Laws.Enum+import qualified Clash.Tests.Laws.Num+import qualified Clash.Tests.Laws.SaturatingNum+ tests :: TestTree tests = testGroup "Unittests"-  [ Clash.Tests.BitPack.tests+  [ Clash.Tests.AsyncFIFOSynchronizer.tests+  , Clash.Tests.AutoReg.tests+  , Clash.Tests.BitPack.tests   , Clash.Tests.BitVector.tests+  , Clash.Tests.BlockRam.Blob.tests+  , Clash.Tests.BlockRam.tests+  , Clash.Tests.Clocks.tests+  , Clash.Tests.Counter.tests   , Clash.Tests.DerivingDataRepr.tests-  , Clash.Tests.Signal.tests+  , Clash.Tests.DumpVCD.tests+  , Clash.Tests.Fixed.tests+  , Clash.Tests.FixedExhaustive.tests+  , Clash.Tests.Index.tests+  , Clash.Tests.MaybeNumConvert.tests+  , Clash.Tests.MaybeX.tests   , Clash.Tests.NFDataX.tests+  , Clash.Tests.NumConvert.tests+  , Clash.Tests.NumNewtypes.tests+  , Clash.Tests.Ram.tests+  , Clash.Tests.Reset.tests+  , Clash.Tests.Resize.tests+  , Clash.Tests.Signal.tests+  , Clash.Tests.Signed.tests+  , Clash.Tests.TopEntityGeneration.tests+  , Clash.Tests.Unsigned.tests+  , Clash.Tests.Vector.tests+  , Clash.Tests.XException.tests+  , testGroup "Laws"+    [ Clash.Tests.Laws.Enum.tests+    , Clash.Tests.Laws.Num.tests+    , Clash.Tests.Laws.SaturatingNum.tests+    ]   ]  main :: IO ()