packages feed

clash-prelude 0.11.2 → 1.10.0

raw patch · 229 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,285 +1,1070 @@-# Changelog for [`clash-prelude` package](http://hackage.haskell.org/package/clash-prelude)--## 0.11.2 *April 25th 2017*-* 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 *April 10th 2017*-* 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 *January 16th 2017*-* New features:-  * `CLaSH.XException`: a module defining an exception representing uninitialised values. Additionally adds the `ShowX` class which has methods that print 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,5 +1,6 @@ Copyright (c) 2013-2016, University of Twente,-              2017, QBayLogic+              2016-2019, Myrtle Software Ltd,+              2017-2025, QBayLogic B.V., Google Inc. All rights reserved.  Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,18 +1,14 @@-# CλaSH - A functional hardware description language+# Clash - A functional hardware description language -[![Build Status](https://travis-ci.org/clash-lang/clash-prelude.svg?branch=master)](https://travis-ci.org/clash-lang/clash-prelude)+[![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) -__WARNING__-Only works with GHC-8.0.* (http://www.haskell.org/ghc/download_ghc_8_0_2)!--CλaSH (pronounced ‘clash’) is a functional hardware description language that-borrows both its syntax and semantics from the functional programming language-Haskell. The CλaSH compiler transforms these high-level descriptions to+Clash is a functional hardware description language that borrows both+its syntax and semantics from the functional programming language+Haskell. The Clash compiler transforms these high-level descriptions to low-level synthesizable VHDL, Verilog, or SystemVerilog. -Features of CλaSH:+Features of Clash:    * Strongly typed, yet with a very high degree of type inference, enabling both     safe and fast prototyping using concise descriptions.@@ -28,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 CLaSH.Class.Num+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) -boundedPlusBench :: Benchmark-boundedPlusBench = env setup $ \m ->-  bench "boundedPlus WORD_SIZE_IN_BITS" $ nf (uncurry (boundedPlus)) m+boundedAddBench :: Benchmark+boundedAddBench = env setup $ \m ->+  bench "boundedAdd WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedAdd) m   where     setup = return (smallValue1,smallValue2) -boundedMinBench :: Benchmark-boundedMinBench = env setup $ \m ->-  bench "boundedMin WORD_SIZE_IN_BITS" $ nf (uncurry (boundedMin)) m+boundedSubBench :: Benchmark+boundedSubBench = env setup $ \m ->+  bench "boundedSub WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedSub) m   where     setup = return (smallValue1,smallValue2) -boundedMultBench :: Benchmark-boundedMultBench = env setup $ \m ->-  bench "boundedMult WORD_SIZE_IN_BITS" $ nf (uncurry (boundedMult)) m+boundedMulBench :: Benchmark+boundedMulBench = env setup $ \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,14 +4,23 @@  #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 Clash.Class.Num+import Clash.Sized.Fixed+import Clash.Sized.Unsigned+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)) {-# INLINE smallValueR_pos #-}@@ -50,6 +59,6 @@  multBench_wrap :: Benchmark multBench_wrap = env setup $ \m ->-  bench "satMult SatWrap" $ nf (uncurry (satMult SatWrap)) m+  bench "satMult SatWrap" $ nf (uncurry (satMul SatWrap)) m   where     setup = return (smallValueU1,smallValueU2)
+ 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 CLaSH.Sized.BitVector-import CLaSH.Sized.Internal.Signed-import Criterion                   (Benchmark, env, bench, nf)+import Data.Bits+import Clash.Class.Num+import Clash.Class.BitPack+import Clash.Sized.BitVector+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.boundedPlusBench-        , BV.boundedMinBench-        , BV.boundedMultBench-        , 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,13 +1,14 @@+Cabal-version:        2.2 Name:                 clash-prelude-Version:              0.11.2-Synopsis:             CAES Language for Synchronous Hardware - Prelude library+Version:              1.10.0+Synopsis:             Clash: a functional hardware description language - Prelude library Description:-  CλaSH (pronounced ‘clash’) is a functional hardware description language that-  borrows both its syntax and semantics from the functional programming language-  Haskell. The CλaSH compiler transforms these high-level descriptions to-  low-level synthesizable VHDL, Verilog, or SystemVerilog.+  Clash is a functional hardware description language that borrows both its+  syntax and semantics from the functional programming language Haskell. The+  Clash compiler transforms these high-level descriptions to low-level+  synthesizable VHDL, Verilog, or SystemVerilog.   .-  Features of CλaSH:+  Features of Clash:   .   * Strongly typed, but with a very high degree of type inference, enabling both     safe and fast prototyping using concise descriptions.@@ -30,24 +31,34 @@   .   To use the library:   .-  * Import "CLaSH.Prelude"+  * Import "Clash.Prelude"   .-  * Additionally import "CLaSH.Prelude.Explicit" if you want to design-    explicitly clocked circuits in a multi-clock setting+  * Alternatively, if you want to explicitly route clock and reset ports,+    for more straightforward multi-clock designs, you can import the+    "Clash.Explicit.Prelude" module. Note that you should not import+    "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-prelude/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:               Christiaan Baaij-Maintainer:           Christiaan Baaij <christiaan.baaij@gmail.com>+Author:               The Clash Authors+Maintainer:           QBayLogic B.V. <devops@qbaylogic.com> Copyright:            Copyright © 2013-2016, University of Twente,-                                  2017, QBayLogic+                                  2016-2017, Myrtle Software Ltd,+                                  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@@ -55,158 +66,405 @@  extra-doc-files:      doc/*.svg -Cabal-version:        >=1.10- 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+    help to eliminate space leaks when using lazy data structures in+    registers-like constructs. This potentially slows down Clash hardware+    simulation.+  default: False+  manual: True++flag strict-mapSignal+  description:+    Use `seqX` in 'mapSignal#'. This can help to eliminate space leaks in long+    running simulations.+  default: False+  manual: True+ flag doctests   description:     You can disable testing with doctests using `-f-doctests`.   default: True   manual: True +flag unittests+  description:+    You can disable testing with unittests using `-f-unittests`.+  default: True+  manual: True+ flag benchmarks   description:     You can disable testing with benchmarks using `-f-benchmarks`.   default: True   manual: True -flag doclinks+flag workaround-ghc-mmap-crash   description:-    Create hyperlinks to non-dependent packages using `-fdoclinks`.+    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+  ghc-options:        -Wall -Wcompat -fexpose-all-unfoldings -fno-worker-wrapper+  CPP-Options:        -DCABAL -  Exposed-modules:    CLaSH.Annotations.TopEntity-                      CLaSH.Annotations.Primitive+  if flag(large-tuples)+    CPP-Options: -DLARGE_TUPLES -                      CLaSH.Class.BitPack-                      CLaSH.Class.Num-                      CLaSH.Class.Resize+  if flag(super-strict)+    CPP-Options: -DCLASH_SUPER_STRICT -                      CLaSH.NamedTypes+  if flag(strict-mapSignal)+    CPP-Options: -DCLASH_STRICT_MAPSIGNAL -                      CLaSH.Prelude-                      CLaSH.Prelude.BitIndex-                      CLaSH.Prelude.BitReduction-                      CLaSH.Prelude.BlockRam-                      CLaSH.Prelude.BlockRam.File-                      CLaSH.Prelude.DataFlow-                      CLaSH.Prelude.Explicit-                      CLaSH.Prelude.Explicit.Safe-                      CLaSH.Prelude.Mealy-                      CLaSH.Prelude.Moore-                      CLaSH.Prelude.RAM-                      CLaSH.Prelude.ROM-                      CLaSH.Prelude.ROM.File-                      CLaSH.Prelude.Safe-                      CLaSH.Prelude.Synchronizer-                      CLaSH.Prelude.Testbench+  Autogen-Modules:    Paths_clash_prelude -                      CLaSH.Promoted.Nat-                      CLaSH.Promoted.Nat.Literals-                      CLaSH.Promoted.Nat.TH-                      CLaSH.Promoted.Nat.Unsafe-                      CLaSH.Promoted.Symbol+  Exposed-modules:    Clash.Annotations.TopEntity+                      Clash.Annotations.Primitive+                      Clash.Annotations.BitRepresentation+                      Clash.Annotations.BitRepresentation.Deriving+                      Clash.Annotations.BitRepresentation.Internal+                      Clash.Annotations.BitRepresentation.Util+                      Clash.Annotations.SynthesisAttributes+                      Clash.Annotations.TH -                      CLaSH.Signal-                      CLaSH.Signal.Bundle-                      CLaSH.Signal.Delayed-                      CLaSH.Signal.Delayed.Explicit-                      CLaSH.Signal.Explicit-                      CLaSH.Signal.Internal+                      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+                      Clash.Class.HasDomain.HasSpecificDomain+                      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.Sized.BitVector-                      CLaSH.Sized.Fixed-                      CLaSH.Sized.Index-                      CLaSH.Sized.RTree-                      CLaSH.Sized.Signed-                      CLaSH.Sized.Unsigned-                      CLaSH.Sized.Vector+                      Clash.Clocks -                      CLaSH.Sized.Internal.BitVector-                      CLaSH.Sized.Internal.Index-                      CLaSH.Sized.Internal.Signed-                      CLaSH.Sized.Internal.Unsigned+                      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.XException+                      Clash.HaskellPrelude -                      CLaSH.Tutorial-                      CLaSH.Examples+                      Clash.Hidden +                      Clash.Intel.ClockGen+                      Clash.Intel.DDR++                      Clash.Magic++                      Clash.Num.Erroring+                      Clash.Num.Overflowing+                      Clash.Num.Saturating+                      Clash.Num.Wrapping+                      Clash.Num.Zeroing++                      Clash.NamedTypes++                      Clash.Prelude+                      Clash.Prelude.BlockRam+                      Clash.Prelude.BlockRam.Blob+                      Clash.Prelude.BlockRam.File+                      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++                      Clash.Promoted.Nat+                      Clash.Promoted.Nat.Literals+                      Clash.Promoted.Nat.TH+                      Clash.Promoted.Nat.Unsafe+                      Clash.Promoted.Symbol++                      Clash.Signal+                      Clash.Signal.Bundle+                      Clash.Signal.BiSignal+                      Clash.Signal.Delayed+                      Clash.Signal.Delayed.Internal+                      Clash.Signal.Delayed.Bundle+                      Clash.Signal.Internal+                      Clash.Signal.Internal.Ambiguous+                      Clash.Signal.Trace++                      Clash.Sized.BitVector+                      Clash.Sized.Fixed+                      Clash.Sized.Index+                      Clash.Sized.RTree+                      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.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.8.0.0 && < 5,-                      constraints               >= 0.8     && < 1.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.13,+                      constraints               >= 0.9     && < 1.0,+                      containers                >= 0.4.0   && < 0.9,                       data-binary-ieee754       >= 0.4.4   && < 0.6,-                      data-default              >= 0.5.3   && < 0.8,-                      integer-gmp               >= 0.5.1.0 && < 1.1,-                      deepseq                   >= 1.4.1.0 && < 1.5,-                      ghc-prim                  >= 0.3.1.0 && < 0.6,-                      ghc-typelits-extra        >= 0.2.1   && < 0.3,-                      ghc-typelits-knownnat     >= 0.2.2   && < 0.3,-                      ghc-typelits-natnormalise >= 0.4.2   && < 0.6,+                      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.16,-                      QuickCheck                >= 2.7     && < 2.10,+                      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.9.0.0 && < 2.12,-                      vector                    >= 0.11    && < 1.0--  if flag(doclinks)-    CPP-Options:      -DDOCLINKS-    build-depends:    transformers              >= 0.4.2.0+                      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 && < 2.2,+                      time                      >= 1.8     && < 1.15,+                      transformers              >= 0.5.2.0 && < 0.7,+                      type-errors               >= 0.2.0.0 && < 0.3,+                      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+  ghc-options:      -Wall -Wcompat -threaded   hs-source-dirs:   tests    if !flag(doctests)     buildable: False   else     build-depends:-      base    >= 4     && < 5,-      doctest >= 0.9.1 && < 0.12+      base,+      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+  main-is:          unittests.hs+  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)+    buildable: False+  else+    build-depends:+      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,+      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.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.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@@ -214,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              >= 4       && < 5,+      base,       clash-prelude,-      criterion         >= 1.1.1.0 && < 1.2,-      deepseq           >= 1.4.0.1 && < 1.5,-      template-haskell  >= 2.9.0.0 && < 2.12+      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/Primitive.hs 
@@ -1,25 +0,0 @@-{-|-Copyright  :  (C) 2017, QBayLogic-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE DeriveDataTypeable #-}--{-# LANGUAGE Safe #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Annotations.Primitive where--import Data.Data--data HDL-  = SystemVerilog-  | Verilog-  | VHDL-  deriving (Eq, Show, Read, Data)--data Primitive-  = Primitive HDL FilePath-  deriving (Show, Read, Data)
− src/CLaSH/Annotations/TopEntity.hs 
@@ -1,443 +0,0 @@-{-|-Copyright  :  (C) 2015-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--The 'TopEntity' annotations described in this module make it easier to put your-design on an FPGA.--We can exert some control how the top level function is created by the CλaSH-compiler by annotating the @topEntity@ function with a 'TopEntity' annotation.-You apply these annotations using the @ANN@ pragma like so:--@-{\-\# ANN topEntity (TopEntity {t_name = ..., ...  }) \#-\}-topEntity x = ...-@--For example, given the following specification:--@-topEntity :: Signal Bit -> Signal (BitVector 8)-topEntity key1 = leds-  where-    key1R = isRising 1 key1-    leds  = mealy blinkerT (1,False,0) key1R--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-@--The CλaSH compiler will normally generate the following @topEntity.vhdl@ file:--@--- Automatically generated VHDL-library IEEE;-use IEEE.STD_LOGIC_1164.ALL;-use IEEE.NUMERIC_STD.ALL;-use IEEE.MATH_REAL.ALL;-use work.all;-use work.types.all;--entity topEntity is-  port(input_0         : in std_logic_vector(0 downto 0);-       -- clock-       system1000      : in std_logic;-       -- asynchronous reset: active low-       system1000_rstn : in std_logic;-       output_0        : out std_logic_vector(7 downto 0));-end;--architecture structural of topEntity is-begin-  topEntity_0_inst : entity topEntity_0-    port map-      (key1_i1         => input_0-      ,system1000      => system1000-      ,system1000_rstn => system1000_rstn-      ,topLet_o        => output_0);-end;-@--However, if we add the following 'TopEntity' annotation in the file:--@-{\-\# ANN topEntity-  ('defTop'-    { t_name     = "blinker"-    , t_inputs   = [\"KEY1\"]-    , t_outputs  = [\"LED\"]-    , t_extraIn  = [ (\"CLOCK_50\", 1)-                   , (\"KEY0\"    , 1)-                   ]-    , t_clocks   = [ 'altpll' "altpll50" "CLOCK_50(0)" "not KEY0(0)" ]-    }) \#-\}-@--The CλaSH compiler will generate the following @blinker.vhdl@ file instead:--@--- Automatically generated VHDL-library IEEE;-use IEEE.STD_LOGIC_1164.ALL;-use IEEE.NUMERIC_STD.ALL;-use IEEE.MATH_REAL.ALL;-use work.all;-use work.types.all;--entity blinker is-  port(KEY1     : in std_logic_vector(0 downto 0);-       CLOCK_50 : in std_logic_vector(0 downto 0);-       KEY0     : in std_logic_vector(0 downto 0);-       LED      : out std_logic_vector(7 downto 0));-end;--architecture structural of blinker is-  signal system1000      : std_logic;-  signal system1000_rstn : std_logic;-  signal altpll50_locked : std_logic;-begin-  altpll50_inst : entity altpll50-    port map-      (inclk0 => CLOCK_50(0)-      ,c0     => system1000-      ,areset => not KEY0(0)-      ,locked => altpll50_locked);--  -- reset system1000_rstn is asynchronously asserted, but synchronously de-asserted-  resetSync_n_0 : block-    signal n_1 : std_logic;-    signal n_2 : std_logic;-  begin-    process(system1000,altpll50_locked)-    begin-      if altpll50_locked = '0' then-        n_1 <= '0';-        n_2 <= '0';-      elsif rising_edge(system1000) then-        n_1 <= '1';-        n_2 <= n_1;-      end if;-    end process;--    system1000_rstn <= n_2;-  end block;--  topEntity_0_inst : entity topEntity_0-    port map-      (key1_i1         => KEY1-      ,system1000      => system1000-      ,system1000_rstn => system1000_rstn-      ,topLet_o        => LED);-end;-@--Where we now have:--* A top-level component that is called @blinker@.-* Inputs and outputs that have a /user/-chosen name: @KEY1@, @LED@, etc.-* An instantiated <https://www.altera.com/literature/ug/ug_altpll.pdf PLL>-  component providing a stable clock signal from the free-running clock pin-  @CLOCK_50@.-* A reset that is /asynchronously/ asserted by the @lock@ signal originating from-  the PLL, meaning that your design is kept in reset until the PLL is-  providing a stable clock.-  The reset is additionally /synchronously/ de-asserted to prevent-  <http://en.wikipedia.org/wiki/Metastability_in_electronics metastability>-  of your design due to unlucky timing of the de-assertion of the reset.--See the documentation of 'TopEntity' for the meaning of all its fields.--}--{-# LANGUAGE DeriveDataTypeable #-}--{-# LANGUAGE Safe #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Annotations.TopEntity-  ( -- * Data types-    TopEntity (..)-  , ClockSource (..)-    -- * Convenience functions-  , defTop-    -- ** Altera clock sources-  , altpll-  , alteraPll-    -- ** Xilinx clock sources-  , clockWizard-  , clockWizardDifferential-  )-where--import Data.Data-import CLaSH.Signal.Explicit (systemClock)---- | TopEntity annotation-data TopEntity-  = TopEntity-  { t_name     :: String         -- ^ The name the top-level component should-                                 -- have, put in a correspondingly named file.-  , t_inputs   :: [String]       -- ^ List of names that are assigned in-order-                                 -- to the inputs of the component.-  , t_outputs  :: [String]       -- ^ List of names that are assigned in-order-                                 -- to the outputs of the component.-  , t_extraIn  :: [(String,Int)]-  -- ^ Extra input ports, where every tuple holds the name of the input port and-  -- the number of  bits are used for that input port.-  ---  -- So given a bit-width @n@, the port has type:-  ---  -- * __VHDL__: @std_logic_vector (n-1 downto 0)@-  -- * __Verilog__: @[n-1:0]@-  -- * __SystemVerilog__: @logic [n-1:0]@-  , t_extraOut :: [(String,Int)]-  -- ^ Extra output ports, where every tuple holds the name of the output port-  -- and the number of bits are used for that output port.-  ---  -- So given a bit-width @n@, the port has type:-  ---  -- * __VHDL__: @std_logic_vector (n-1 downto 0)@-  -- * __Verilog__: @[n-1:0]@-  -- * __SystemVerilog__: @logic [n-1:0]@-  , t_clocks   :: [ClockSource]  -- ^ List of clock sources-  }-  deriving (Data,Show,Read)---- | A clock source-data ClockSource-  = ClockSource-  { c_name  :: String                -- ^ Component name-  , c_inp   :: [(String,String)]     -- ^ Zero..two times: @(Input port, clock pin/expression)@-  , c_outp  :: [(String,String)]-  -- ^ List of @(Output port, clock)@-  ---  -- The best way to create the 'String' representing the name of the clock is-  -- to 'show' the corresponding singleton clock ('CLaSH.Signal.Explicit.sclock').-  ---  -- So given that you your design is synchronised to the 'CLaSH.Signal.Explicit.SystemClock'-  -- and some another clock @ClkA@-  ---  -- > type ClkA = 'Clk "clkA" 2000-  ---  -- the best way to connect output clock ports is by doing:-  ---  -- > ClockSource { ..-  -- >             , c_outp = [("c0", show (sclock :: SClock SystemClock))-  -- >                        ,("c1", show (sclock :: SClock ClkA))-  -- >                        ]-  -- >             , ..-  -- >             }-  , c_reset :: Maybe (String,String) -- ^ optional: @(Reset port, reset pin/expression)@-  , c_lock  :: String                -- ^ Output port name of the clock source-                                     -- component indicating that the clock signal-                                     -- is stable.-  , c_sync  :: Bool-  -- ^ Indicates whether the components synchronised by the clocks generated by-  -- this clock source are pulled out of reset simultaneously.-  ---  -- The recommended setting if 'False'.-  ---  -- When 'c_sync' is set to 'False', the compiler generates reset synchronisers-  -- which ensure that each component is synchronously pulled out of reset,-  -- preventing <http://en.wikipedia.org/wiki/Metastability_in_electronics metastability>-  -- introduced by unlucky timing of the reset de-assertion.-  ---  -- When 'c_sync' is set to 'True' those reset synchronisers are not generated-  -- and there is change for reset-induced metastability.-  }-  deriving (Data,Show,Read)---- | Default 'TopEntity' which has no clocks, and no specified names for the--- input and output ports. Also has no clock sources:------ >>> defTop--- TopEntity {t_name = "topentity", t_inputs = [], t_outputs = [], t_extraIn = [], t_extraOut = [], t_clocks = []}-defTop :: TopEntity-defTop = TopEntity-  { t_name     = "topentity"-  , t_inputs   = []-  , t_outputs  = []-  , t_extraIn  = []-  , t_extraOut = []-  , t_clocks   = []-  }---- | A clock source that corresponds to the Altera/Quartus \"ALTPLL\" component--- with default settings to provide a stable 'systemClock'.------ >>> altpll "altpll50" "CLOCK(0)" "not KEY(0)"--- ClockSource {c_name = "altpll50", c_inp = [("inclk0","CLOCK(0)")], c_outp = [("c0","system1000")], c_reset = Just ("areset","not KEY(0)"), c_lock = "locked", c_sync = False}------ Will generate the following VHDL:------ > altpll50_inst : entity altpll50--- >   port map--- >     (inclk0 => CLOCK_50(0)--- >     ,c0     => system1000--- >     ,areset => not KEY0(0)--- >     ,locked => altpll50_locked);------ If you are however generating (System)Verilog you should write:------ >>> altpll "altpll50" "CLOCK[0]" "~ KEY[0]"--- ClockSource {c_name = "altpll50", c_inp = [("inclk0","CLOCK[0]")], c_outp = [("c0","system1000")], c_reset = Just ("areset","~ KEY[0]"), c_lock = "locked", c_sync = False}------ so that the following (System)Verilog is created:------ > altpll50 altpll50_inst--- > (.inclk0 (CLOCK_50[0])--- > ,.c0 (system1000)--- > ,.areset (~ KEY0[0])--- > ,.locked (altpll50_locked));-altpll :: String -- ^ Name of the component.-       -> String -- ^ Clock Pin/Expression of the free running clock.-       -> String -- ^ Reset Pin/Expression controlling the reset of the PLL.-       -> ClockSource-altpll pllName clkExpr resExpr = ClockSource-  { c_name  = pllName-  , c_inp   = pure ("inclk0",clkExpr)-  , c_outp  = [("c0",show systemClock)]-  , c_reset = Just ("areset",resExpr)-  , c_lock  = "locked"-  , c_sync  = False-  }---- | A clock source that corresponds to the Altera \"Altera PLL\" component--- with default settings to provide a stable 'systemClock'.------ >>> alteraPll "alteraPll50" "CLOCK(0)" "not KEY(0)"--- ClockSource {c_name = "alteraPll50", c_inp = [("refclk","CLOCK(0)")], c_outp = [("outclk_0","system1000")], c_reset = Just ("rst","not KEY(0)"), c_lock = "locked", c_sync = False}------ Will generate the following VHDL:------ > alteraPll50_inst : entity alteraPll--- >   port map--- >     (refclk   => CLOCK_50(0)--- >     ,outclk_0 => system1000--- >     ,rst      => not KEY0(0)--- >     ,locked   => alteraPll50_locked);------ If you are however generating (System)Verilog you should write:------ >>> alteraPll "alteraPll50" "CLOCK[0]" "~ KEY[0]"--- ClockSource {c_name = "alteraPll50", c_inp = [("refclk","CLOCK[0]")], c_outp = [("outclk_0","system1000")], c_reset = Just ("rst","~ KEY[0]"), c_lock = "locked", c_sync = False}------ so that the following (System)Verilog is created:------ > alteraPll50 alteraPll50_inst--- > (.refclk (CLOCK_50[0])--- > ,.outclk_0 (system1000)--- > ,.rst (~ KEY0[0])--- > ,.locked (alteraPll50_locked));-alteraPll :: String -- ^ Name of the component.-          -> String -- ^ Clock Pin/Expression of the free running clock.-          -> String -- ^ Reset Pin/Expression controlling the reset of the PLL.-          -> ClockSource-alteraPll pllName clkExpr resExpr = ClockSource-  { c_name  = pllName-  , c_inp   = pure ("refclk",clkExpr)-  , c_outp  = [("outclk_0",show systemClock)]-  , c_reset = Just ("rst",resExpr)-  , c_lock  = "locked"-  , c_sync  = False-  }---- | A clock source that corresponds to the Xilinx PLL/MMCM component created--- with the \"Clock Wizard\", with settings to provide a stable 'systemClock'.------ >>> clockWizard "clkwiz50" "CLOCK(0)" "not KEY(0)"--- ClockSource {c_name = "clkwiz50", c_inp = [("CLK_IN1","CLOCK(0)")], c_outp = [("CLK_OUT1","system1000")], c_reset = Just ("RESET","not KEY(0)"), c_lock = "LOCKED", c_sync = False}------ Will generate the following VHDL:------ > clkwiz50_inst : entity clkwiz50--- >   port map--- >     (CLK_IN1  => CLOCK(0)--- >     ,CLK_OUT1 => system1000--- >     ,RESET    => not KEY(0)--- >     ,LOCKED   => clkwiz50_locked);------ If you are however generating (System)Verilog you should write:------ >>> clockWizard "clkwiz50" "CLOCK[0]" "~ KEY[0]"--- ClockSource {c_name = "clkwiz50", c_inp = [("CLK_IN1","CLOCK[0]")], c_outp = [("CLK_OUT1","system1000")], c_reset = Just ("RESET","~ KEY[0]"), c_lock = "LOCKED", c_sync = False}------ so that the following (System)Verilog is created:------ > clkwiz50 clkwiz50_inst--- > (.CLK_IN1 (CLOCK[0])--- > ,.CLK_OUT1 (system1000)--- > ,.RESET (~ KEY[0])--- > ,.LOCKED (clkwiz50_locked));-clockWizard :: String -- ^ Name of the component.-            -> String -- ^ Clock Pin/Expression of the free running clock.-            -> String -- ^ Reset Pin/Expression controlling the reset of the PLL.-            -> ClockSource-clockWizard pllName clkExpr resExpr = ClockSource-  { c_name  = pllName-  , c_inp   = pure ("CLK_IN1",clkExpr)-  , c_outp  = [("CLK_OUT1",show systemClock)]-  , c_reset = Just ("RESET",resExpr)-  , c_lock  = "LOCKED"-  , c_sync  = False-  }---- | A clock source that corresponds to the Xilinx PLL/MMCM component created--- with the \"Clock Wizard\", with settings to provide a stable 'systemClock'--- from differential free-running inputs.------ >>> clockWizardDifferential "clkwiz50" "CLOCK(0)" "CLOCK(1)" "not KEY(0)"--- ClockSource {c_name = "clkwiz50", c_inp = [("CLK_IN1_D_clk_n","CLOCK(0)"),("CLK_IN1_D_clk_p","CLOCK(1)")], c_outp = [("CLK_OUT1","system1000")], c_reset = Just ("RESET","not KEY(0)"), c_lock = "LOCKED", c_sync = False}------ Will generate the following VHDL:------ > clkwiz50_inst : entity clkwiz50--- >   port map--- >     (CLK_IN1_D_clk_n  => CLOCK(0)--- >     ,CLK_IN1_D_clk_p  => CLOCK(1)--- >     ,CLK_OUT1 => system1000--- >     ,RESET    => not KEY(0)--- >     ,LOCKED   => clkwiz50_locked);------ If you are however generating (System)Verilog you should write:------ >>> clockWizardDifferential "clkwiz50" "CLOCK[0]" "CLOCK[1]" "~ KEY[0]"--- ClockSource {c_name = "clkwiz50", c_inp = [("CLK_IN1_D_clk_n","CLOCK[0]"),("CLK_IN1_D_clk_p","CLOCK[1]")], c_outp = [("CLK_OUT1","system1000")], c_reset = Just ("RESET","~ KEY[0]"), c_lock = "LOCKED", c_sync = False}------ so that the following (System)Verilog is created:------ > clkwiz50 clkwiz50_inst--- > (.CLK_IN1_D_clk_n (CLOCK[0])--- > ,.CLK_IN1_D_clk_p (CLOCK[1])--- > ,.CLK_OUT1 (system1000)--- > ,.RESET (~ KEY[0])--- > ,.LOCKED (clkwiz50_locked));-clockWizardDifferential :: String -- ^ Name of the component.-                        -> String -- ^ Clock Pin/Expression of the differential free running clock, negative phase.-                        -> String -- ^ Clock Pin/Expression of the differential free running clock, positive phase.-                        -> String -- ^ Reset Pin/Expression controlling the reset of the PLL.-                        -> ClockSource-clockWizardDifferential pllName clkExpr_n clkExpr_p resExpr = ClockSource-  { c_name  = pllName-  , c_inp   = [ ("CLK_IN1_D_clk_n",clkExpr_n)-              , ("CLK_IN1_D_clk_p",clkExpr_p)-              ]-  , c_outp  = [("CLK_OUT1",show systemClock)]-  , c_reset = Just ("RESET",resExpr)-  , c_lock  = "LOCKED"-  , c_sync  = False-  }
− src/CLaSH/Class/BitPack.hs 
@@ -1,249 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE CPP                  #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE MagicHash            #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns         #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}--#include "MachDeps.h"--module CLaSH.Class.BitPack-  ( BitPack (..)-  , bitCoerce-  , boolToBV-  )-where--import Data.Binary.IEEE754            (doubleToWord, floatToWord, wordToDouble,-                                       wordToFloat)-import Data.Int-import Data.Word-import Foreign.C.Types                (CUShort)-import GHC.TypeLits                   (KnownNat, Nat, type (+))-import Numeric.Half                   (Half (..))-import Prelude                        hiding (map)--import CLaSH.Class.Resize             (zeroExtend)-import CLaSH.Sized.BitVector          (BitVector, (++#), high, low)-import CLaSH.Sized.Internal.BitVector (unsafeToInteger, split#)--{- $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@-  type BitSize a :: Nat-  -- | Convert element of type @a@ to a 'BitVector'-  ---  -- >>> pack (-5 :: Signed 6)-  -- 11_1011-  pack   :: a -> BitVector (BitSize 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--{-# 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 True  = high-  pack False = low--  unpack bv  = if bv == high then True else False--instance BitPack (BitVector n) where-  type BitSize (BitVector n) = n-  pack   v = v-  unpack v = v--instance BitPack Int where-  type BitSize Int = WORD_SIZE_IN_BITS-  pack   = fromIntegral-  unpack = fromIntegral--instance BitPack Int8 where-  type BitSize Int8 = 8-  pack   = fromIntegral-  unpack = fromIntegral--instance BitPack Int16 where-  type BitSize Int16 = 16-  pack   = fromIntegral-  unpack = fromIntegral--instance BitPack Int32 where-  type BitSize Int32 = 32-  pack   = fromIntegral-  unpack = fromIntegral--#if WORD_SIZE_IN_BITS >= 64-instance BitPack Int64 where-  type BitSize Int64 = 64-  pack   = fromIntegral-  unpack = fromIntegral-#endif--instance BitPack Word where-  type BitSize Word = WORD_SIZE_IN_BITS-  pack   = fromIntegral-  unpack = fromIntegral--instance BitPack Word8 where-  type BitSize Word8 = 8-  pack   = fromIntegral-  unpack = fromIntegral--instance BitPack Word16 where-  type BitSize Word16 = 16-  pack   = fromIntegral-  unpack = fromIntegral--instance BitPack Word32 where-  type BitSize Word32 = 32-  pack   = fromIntegral-  unpack = fromIntegral--#if WORD_SIZE_IN_BITS >= 64-instance BitPack Word64 where-  type BitSize Word64 = 64-  pack   = fromIntegral-  unpack = fromIntegral-#endif--instance BitPack Float where-  type BitSize Float = 32-  pack   = packFloat#-  unpack = 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   = packDouble#-  unpack = 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   = fromIntegral-  unpack = fromIntegral--instance BitPack Half where-  type BitSize Half = 16-  pack (Half x) = pack x-  unpack x      = Half (unpack x)--instance BitPack () where-  type BitSize () = 0-  pack   _ = minBound-  unpack _ = ()--instance (KnownNat (BitSize b), BitPack a, BitPack b) =>-    BitPack (a,b) where-  type BitSize (a,b) = BitSize a + BitSize b-  pack (a,b) = pack a ++# pack b-  unpack ab  = let (a,b) = split# ab in (unpack a, unpack b)--instance (KnownNat (BitSize c), BitPack (a,b), BitPack c) =>-    BitPack (a,b,c) where-  type BitSize (a,b,c) = BitSize (a,b) + BitSize c-  pack (a,b,c) = pack (a,b) ++# pack c-  unpack (unpack -> ((a,b), c)) = (a,b,c)--instance (KnownNat (BitSize d), BitPack (a,b,c), BitPack d) =>-    BitPack (a,b,c,d) where-  type BitSize (a,b,c,d) = BitSize (a,b,c) + BitSize d-  pack (a,b,c,d) = pack (a,b,c) ++# pack d-  unpack (unpack -> ((a,b,c), d)) = (a,b,c,d)--instance (KnownNat (BitSize e), BitPack (a,b,c,d), BitPack e) =>-    BitPack (a,b,c,d,e) where-  type BitSize (a,b,c,d,e) = BitSize (a,b,c,d) + BitSize e-  pack (a,b,c,d,e) = pack (a,b,c,d) ++# pack e-  unpack (unpack -> ((a,b,c,d), e)) = (a,b,c,d,e)--instance (KnownNat (BitSize f), BitPack (a,b,c,d,e), BitPack f) =>-    BitPack (a,b,c,d,e,f) where-  type BitSize (a,b,c,d,e,f) = BitSize (a,b,c,d,e) + BitSize f-  pack (a,b,c,d,e,f) = pack (a,b,c,d,e) ++# pack f-  unpack (unpack -> ((a,b,c,d,e), f)) = (a,b,c,d,e,f)--instance (KnownNat (BitSize g), BitPack (a,b,c,d,e,f), BitPack g) =>-    BitPack (a,b,c,d,e,f,g) where-  type BitSize (a,b,c,d,e,f,g) = BitSize (a,b,c,d,e,f) + BitSize g-  pack (a,b,c,d,e,f,g) = pack (a,b,c,d,e,f) ++# pack g-  unpack (unpack -> ((a,b,c,d,e,f), g)) = (a,b,c,d,e,f,g)--instance (KnownNat (BitSize h), BitPack (a,b,c,d,e,f,g), BitPack h) =>-    BitPack (a,b,c,d,e,f,g,h) where-  type BitSize (a,b,c,d,e,f,g,h) = BitSize (a,b,c,d,e,f,g) + BitSize h-  pack (a,b,c,d,e,f,g,h) = pack (a,b,c,d,e,f,g) ++# pack h-  unpack (unpack -> ((a,b,c,d,e,f,g), h)) = (a,b,c,d,e,f,g,h)--instance (BitPack a, KnownNat (BitSize a)) => BitPack (Maybe a) where-  type BitSize (Maybe a) = 1 + BitSize a-  pack Nothing  = low  ++# 0-  -- We cannot do `low ++# undefined`, because `BitVector`s underlying-  -- representation is `Integer`, so `low ++# undefined` would make the-  -- entire `BitVector` undefined.-  pack (Just x) = high ++# pack x-  unpack x = case split# x of-    (c,rest) | c == low  -> Nothing-             | otherwise -> Just (unpack rest)---- | 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
− src/CLaSH/Class/Num.hs 
@@ -1,83 +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 MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}--{-# LANGUAGE Safe #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Class.Num-  ( -- * Arithmetic functions for arguments and results of different precision-    ExtendingNum (..)-    -- * Saturating arithmetic functions-  , SaturationMode (..)-  , SaturatingNum (..)-  , boundedPlus-  , boundedMin-  , boundedMult-  )-where---- * Arithmetic functions for arguments and results of different precision---- | Adding, subtracting, and multiplying values of two different (sub-)types.-class ExtendingNum a b where-  -- | Type of the result of the addition or subtraction-  type AResult a b-  -- | Add values of different (sub-)types, return a value of a (sub-)type-  -- that is potentially different from either argument.-  plus  :: a -> b -> AResult a b-  -- | Subtract values of different (sub-)types, return a value of a (sub-)type-  -- that is potentially different from either argument.-  minus :: a -> b -> AResult a b-  -- | Type of the result of the multiplication-  type MResult a b-  -- | Multiply values of different (sub-)types, return a value of a (sub-)type-  -- that is potentially different from either argument.-  times :: a -> b -> MResult a b---- * Saturating arithmetic functions---- | Determine how overflow and underflow are handled by the functions in--- 'SaturatingNum'-data SaturationMode-  = SatWrap  -- ^ Wrap around on overflow and underflow-  | SatBound -- ^ Become 'maxBound' on overflow, and 'minBound' on underflow-  | SatZero  -- ^ Become @0@ on overflow and underflow-  | SatSymmetric -- ^ Become 'maxBound' on overflow, and (@'minBound' + 1@) on-                 -- underflow for signed numbers, and 'minBound' for unsigned-                 -- numbers.-  deriving Eq---- | 'Num' operators in which overflow and underflow behaviour can be specified--- using 'SaturationMode'.-class (Bounded a, Num a) => SaturatingNum a where-  -- | Addition with parametrisable over- and underflow behaviour-  satPlus :: SaturationMode -> a -> a -> a-  -- | Subtraction with parametrisable over- and underflow behaviour-  satMin  :: SaturationMode -> a -> a -> a-  -- | Multiplication with parametrisable over- and underflow behaviour-  satMult :: SaturationMode -> a -> a -> a--{-# INLINE boundedPlus #-}--- | Addition that clips to 'maxBound' on overflow, and 'minBound' on underflow-boundedPlus :: SaturatingNum a => a -> a -> a-boundedPlus = satPlus SatBound--{-# INLINE boundedMin #-}--- | Subtraction that clips to 'maxBound' on overflow, and 'minBound' on--- underflow-boundedMin  :: SaturatingNum a => a -> a -> a-boundedMin = satMin SatBound--{-# INLINE boundedMult #-}--- | Multiplication that clips to 'maxBound' on overflow, and 'minBound' on--- underflow-boundedMult :: SaturatingNum a => a -> a -> a-boundedMult = satMult SatBound
− src/CLaSH/Class/Resize.hs 
@@ -1,42 +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 KindSignatures #-}-{-# LANGUAGE TypeOperators  #-}--{-# LANGUAGE Safe #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Class.Resize where--import GHC.TypeLits (Nat, KnownNat, type (+))---- | Coerce a value to be represented by a different number of bits-class Resize (f :: Nat -> *) where-  -- | A sign-preserving resize operation-  ---  -- * For signed datatypes: Increasing the size of the number replicates the-  -- sign bit to the left. Truncating a number to length L keeps the sign bit-  -- and the rightmost L-1 bits.-  ---  -- * For unsigned datatypes: Increasing the size of the number extends with-  -- zeros to the left. Truncating a number of length N to a length L just-  -- removes the left (most significant) N-L bits.-  resize :: (KnownNat a, KnownNat b) => f a -> f b-  -- | Perform a 'zeroExtend' for unsigned datatypes, and 'signExtend' for a-  -- signed datatypes-  extend :: (KnownNat a, KnownNat b) => f a -> f (b + a)-  extend = resize-  -- | Add extra zero bits in front of the MSB-  zeroExtend :: (KnownNat a, KnownNat b) => f a -> f (b + a)-  -- | Add extra sign bits in front of the MSB-  signExtend :: (KnownNat a, KnownNat b) => f a -> f (b + a)-  signExtend = resize-  -- | Remove bits from the MSB-  truncateB :: KnownNat a => f (a + b) -> f a
− src/CLaSH/Examples.hs 
@@ -1,657 +0,0 @@-{-|-Copyright : © Christiaan Baaij, 2015-2016-Licence   : Creative Commons 4.0 (CC BY 4.0) (http://creativecommons.org/licenses/by/4.0/)--}--{-# LANGUAGE NoImplicitPrelude, CPP, TemplateHaskell, DataKinds #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# OPTIONS_GHC -fno-warn-unused-binds #-}--module CLaSH.Examples (-  -- * Decoders and Encoders-  -- $decoders_and_encoders--  -- * Counters-  -- $counters--  -- * Parity and CRC-  -- $parity_and_crc--  -- * UART model-  -- $uart-  )-where--import CLaSH.Prelude-import Control.Lens-import Control.Monad-import Test.QuickCheck--#ifdef DOCLINKS-import Control.Monad.Trans.State-#endif--{- $setup->>> :set -XDataKinds -XFlexibleContexts -XBinaryLiterals -XTypeFamilies -XTemplateHaskell -XRecordWildCards->>> :set -fplugin GHC.TypeLits.Normalise->>> import CLaSH.Prelude->>> import Test.QuickCheck->>> import Control.Lens->>> import Control.Monad.Trans.State->>> :{-let 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-:}-->>> :{-let decoderShift :: Bool -> BitVector 4 -> BitVector 16-    decoderShift enable binaryIn =-      if enable-         then 1 `shiftL` (fromIntegral binaryIn)-         else 0-:}-->>> :{-let 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-:}-->>> :{-let upCounter :: Signal Bool -> Signal (Unsigned 8)-    upCounter enable = s-      where-        s = register 0 (mux enable (s + 1) s)-:}-->>> :{-let upCounterLdT s (ld,en,dIn) = (s',s)-      where-        s' | ld        = dIn-           | en        = s + 1-           | otherwise = s-:}-->>> :{-let upCounterLd :: Signal (Bool,Bool,Unsigned 8) -> Signal (Unsigned 8)-    upCounterLd = mealy upCounterLdT 0-:}-->>> :{-let upDownCounter :: Signal Bool -> Signal (Unsigned 8)-    upDownCounter upDown = s-      where-        s = register 0 (mux upDown (s + 1) (s - 1))-:}-->>> :{-let lfsrF' :: BitVector 16 -> BitVector 16-    lfsrF' s = feedback ++# slice d15 d1 s-      where-        feedback = s!5 `xor` s!3 `xor` s!2 `xor` s!0-:}-->>> :{-let lfsrF :: BitVector 16 -> Signal Bit-    lfsrF seed = msb <$> r-      where r = register seed (lfsrF' <$> r)-:}-->>> :{-let lfsrGP taps regs = zipWith xorM taps (fb +>> regs)-      where-        fb = last regs-        xorM i x | i         =  x `xor` fb-                 | otherwise = x-:}-->>> :{-let lfsrG :: BitVector 16 -> Signal Bit-    lfsrG seed = last (unbundle r)-      where r = register (unpack seed) (lfsrGP (unpack 0b0011010000000000) <$> r)-:}-->>> :{-let grayCounter :: Signal Bool -> Signal (BitVector 8)-    grayCounter en = gray <$> upCounter en-      where gray xs = msb xs ++# xor (slice d7 d1 xs) (slice d6 d0 xs)-:}-->>> :{-let oneHotCounter :: Signal Bool -> Signal (BitVector 8)-    oneHotCounter enable = s-      where-        s = register 1 (mux enable (rotateL <$> s <*> 1) s)-:}-->>> :{-let parity :: Unsigned 8 -> Bit-    parity data_in = reduceXor data_in-:}-->>> :{-let 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-:}-->>> :{-let crc :: Signal Bool -> Signal Bool -> Signal Bit -> Signal (BitVector 16)-    crc enable ld dIn = s-      where-        s = register 0xFFFF (mux enable (mux ld 0xFFFF (crcT <$> s <*> dIn)) s)-:}-->>> :{-let 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-:}-->>> :{-let uartRX r@(RxReg {..}) rx_in uld_rx_data rx_enable = flip execState r $ do-      -- Synchronise 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-:}-->>> :{-let 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-                          }-:}--}--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-  }--makeLenses ''RxReg--data TxReg-  = TxReg-  { _tx_reg      :: BitVector 8-  , _tx_empty    :: Bool-  , _tx_over_run :: Bool-  , _tx_out      :: Bit-  , _tx_cnt      :: Unsigned 4-  }--makeLenses ''TxReg--{- $decoders_and_encoders-= Decoder--Using a @case@ statement:--@-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-@--Using the `shiftL` function:--@-decoderShift :: Bool -> BitVector 4 -> BitVector 16-decoderShift enable binaryIn =-  if enable-     then 1 ``shiftL`` ('fromIntegral' binaryIn)-     else 0-@--Examples:-->>> decoderCase True 3-0000_0000_0000_1000->>> decoderShift True 7-0000_0000_1000_0000--The following property holds:--prop> \enable binaryIn -> decoderShift enable binaryIn === decoderCase enable binaryIn--= Encoder--Using a @case@ statement:--@-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-@--The following property holds:--prop> \en decIn -> en ==> (encoderCase en (decoderCase en decIn) === decIn)--}--{- $counters-= 8-bit Simple Up Counter--Using `register`:--@-upCounter :: Signal Bool -> Signal (Unsigned 8)-upCounter enable = s-  where-    s = `register` 0 (`mux` enable (s + 1) s)-@--= 8-bit Up Counter With Load--Using `mealy`:--@-upCounterLd :: Signal (Bool,Bool,Unsigned 8) -> Unsigned 8-upCounterLd = `mealy` upCounterLdT 0--upCounterLdT s (ld,en,dIn) = (s',s)-  where-    s' | ld        = dIn-       | en        = s + 1-       | otherwise = s-@--= 8-bit Up-Down counter--Using `register` and `mux`:--@-upDownCounter :: Signal Bool -> Signal (Unsigned 8)-upDownCounter upDown = s-  where-    s = `register` 0 (`mux` upDown (s + 1) (s - 1))-@--The following property holds:--prop> \en -> en ==> testFor 1000 (upCounter (signal en) .==. upDownCounter (signal en))--= LFSR--External/Fibonacci LFSR, for @n=16@ and using the primitive polynominal @1 + x^11 + x^13 + x^14 + x^16@--@-lfsrF' :: BitVector 16 -> BitVector 16-lfsrF' s = feedback '++#' 'slice' d15 d1 s-  where-    feedback = s'!'5 ``xor`` s'!'3 ``xor`` s'!'2 ``xor`` s'!'0--lfsrF :: BitVector 16 -> Signal Bit-lfsrF seed = 'msb' '<$>' r-  where r = 'register' seed (lfsrF' '<$>' r)-@--We can also build a internal/Galois LFSR which has better timing characteristics.-We first define a Galois LFSR parametrizable in its filter taps:--@-lfsrGP taps regs = 'zipWith' xorM taps (fb '+>>' regs)-  where-    fb  = 'last' regs-    xorM i x | i         = x ``xor`` fb-             | otherwise = x-@--Then we can instantiate a 16-bit LFSR as follows:--@-lfsrG :: BitVector 16 -> Signal Bit-lfsrG seed = 'last' ('unbundle' r)-  where r = 'register' ('unpack' seed) (lfsrGP ('unpack' 0b0011010000000000) '<$>' r)-@--The following property holds:--prop> testFor 100 (lfsrF 0xACE1 .==. lfsrG 0x4645)--= Gray counter--Using the previously defined @upCounter@:--@-grayCounter :: Signal Bool -> Signal (BitVector 8)-grayCounter en = gray '<$>' upCounter en-  where gray xs = 'msb' xs '++#' 'xor' ('slice' d7 d1 xs) ('slice' d6 d0 xs)-@--= One-hot counter--Basically a barrel-shifter:--@-oneHotCounter :: Signal Bool -> Signal (BitVector 8)-oneHotCounter enable = s-  where-    s = 'register' 1 ('mux' enable ('rotateL' '<$>' s '<*>' 1) s)-@--}--{- $parity_and_crc-= Parity--Just 'reduceXor':--@-parity :: Unsigned 8 -> Bit-parity data_in = `reduceXor` data_in-@--= Serial CRC--* Width = 16 bits-* Truncated polynomial = 0x1021-* Initial value = 0xFFFF-* Input data is NOT reflected-* Output CRC is NOT reflected-* No XOR is performed on the output CRC--@-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 :: Signal Bool -> Signal Bool -> Signal Bit -> Signal (BitVector 16)-crc enable ld dIn = s-  where-    s = 'register' 0xFFFF ('mux' enable ('mux' ld 0xFFFF (crcT '<$>' s '<*>' dIn)) s)-@--}--{- $uart-@-{\-\# LANGUAGE RecordWildCards \#-\}-module UART (uart) where--import CLaSH.Prelude-import Control.Lens-import Control.Monad-import Control.Monad.Trans.State---- UART RX Logic-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-  }--makeLenses ''RxReg--uartRX r\@(RxReg {..}) rx_in uld_rx_data rx_enable = 'flip' 'execState' r $ do-  -- Synchronise 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 TX Logic-data TxReg-  = TxReg-  { _tx_reg      :: BitVector 8-  , _tx_empty    :: Bool-  , _tx_over_run :: Bool-  , _tx_out      :: Bit-  , _tx_cnt      :: Unsigned 4-  }--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---- Combine RX and TX logic-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/NamedTypes.hs 
@@ -1,65 +0,0 @@-{- |-Copyright  :  (C) 2017, QBayLogic-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--Add inline documentation to types:--@-fifo-  :: SClock clk-  -> SNat addrSize-  -> "read request" ::: Signal' clk Bool-  -> "write request" ::: Signal' clk (Maybe (BitVector dataSize))-  -> ( "q"     ::: Signal' clk (BitVector dataSize)-     , "full"  ::: Signal' clk Bool-     , "empty" ::: Signal' clk Bool-     )-@--which can subsequently be inspected in the interactive environment:-->>> :t fifo systemClock-fifo systemClock-  :: SNat addrSize-     -> "read request" ::: Signal' SystemClock Bool-     -> "write request"-        ::: Signal' SystemClock (Maybe (BitVector dataSize))-     -> ("q" ::: Signal' SystemClock (BitVector dataSize),-         "full" ::: Signal' SystemClock Bool,-         "empty" ::: Signal' SystemClock Bool)---}--{-# LANGUAGE PolyKinds     #-}-{-# LANGUAGE TypeOperators #-}--{-# LANGUAGE Safe #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.NamedTypes-  ((:::))-where--type (name :: k) ::: a = a--- ^ Annotate a type with a name--{- $setup->>> :set -XDataKinds -XTypeOperators -XNoImplicitPrelude->>> import CLaSH.Prelude->>> import CLaSH.Prelude.Explicit->>> :{-let fifo-      :: SClock clk-      -> SNat addrSize-      -> "read request" ::: Signal' clk Bool-      -> "write request" ::: Signal' clk (Maybe (BitVector dataSize))-      -> ( "q"     ::: Signal' clk (BitVector dataSize)-         , "full"  ::: Signal' clk Bool-         , "empty" ::: Signal' clk Bool-         )-    fifo = CLaSH.Prelude.undefined-:}---}
− src/CLaSH/Prelude.hs 
@@ -1,213 +0,0 @@-{-|-  Copyright   :  (C) 2013-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  CλaSH (pronounced ‘clash’) is a functional hardware description language that-  borrows both its syntax and semantics from the functional programming language-  Haskell. The merits of using a functional language to describe hardware comes-  from the fact that combinational circuits can be directly modeled as-  mathematical functions and that functional languages lend themselves very well-  at describing and (de-)composing mathematical functions.--  This package provides:--  * Prelude library containing datatypes and functions for circuit design--  To use the library:--  * Import "CLaSH.Prelude"-  * Additionally import "CLaSH.Prelude.Explicit" if you want to design-    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".--}--{-# LANGUAGE CPP              #-}-{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators    #-}--{-# LANGUAGE Unsafe #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Prelude-  ( -- * Creating synchronous sequential circuits-    mealy-  , mealyB-  , (<^>)-  , moore-  , mooreB-  , registerB-    -- * ROMs-  , asyncRom-  , asyncRomPow2-  , rom-  , romPow2-    -- ** ROMs initialised with a data file-  , asyncRomFile-  , asyncRomFilePow2-  , romFile-  , romFilePow2-    -- * RAM primitives with a combinational read port-  , asyncRam-  , asyncRamPow2-    -- * BlockRAM primitives-  , blockRam-  , blockRamPow2-    -- ** BlockRAM primitives initialised with a data file-  , blockRamFile-  , blockRamFilePow2-    -- * BlockRAM read/write conflict resolution-  , readNew-  , readNew'-    -- * Utility functions-  , window-  , windowD-  , isRising-  , isFalling-    -- * Testbench functions-  , assert-  , stimuliGenerator-  , outputVerifier-    -- * Exported modules-    -- ** 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-  , module CLaSH.Sized.Index-    -- *** Fixed point numbers-  , module CLaSH.Sized.Fixed-    -- *** Fixed size vectors-  , module CLaSH.Sized.Vector-    -- *** Perfect depth trees-  , module CLaSH.Sized.RTree-    -- ** Annotations-  , module CLaSH.Annotations.TopEntity-    -- ** Type-level natural numbers-  , module GHC.TypeLits-  , module GHC.TypeLits.Extra-  , module CLaSH.Promoted.Nat-  , module CLaSH.Promoted.Nat.Literals-  , module CLaSH.Promoted.Nat.TH-    -- ** Template Haskell-  , Lift (..)-    -- ** Type classes-    -- *** CLaSH-  , module CLaSH.Class.BitPack-  , module CLaSH.Class.Num-  , module CLaSH.Class.Resize-    -- *** Other-  , module Control.Applicative-  , module Data.Bits-  , module Data.Default-    -- ** Exceptions-  , module CLaSH.XException-  , undefined-    -- ** Named types-  , module CLaSH.NamedTypes-    -- ** Haskell Prelude-    -- $hiding-  , module Prelude-  )-where--import Control.Applicative-import Data.Bits-import Data.Default-import GHC.TypeLits-import GHC.TypeLits.Extra-import Language.Haskell.TH.Syntax  (Lift(..))-import Prelude                     hiding ((++), (!!), 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,-                                           undefined)--import CLaSH.Annotations.TopEntity-import CLaSH.Class.BitPack-import CLaSH.Class.Num-import CLaSH.Class.Resize-import CLaSH.NamedTypes-import CLaSH.Prelude.BitIndex-import CLaSH.Prelude.BitReduction-import CLaSH.Prelude.BlockRam.File (blockRamFile, blockRamFilePow2)-import CLaSH.Prelude.DataFlow-import CLaSH.Prelude.Explicit      (window', windowD')-import CLaSH.Prelude.ROM.File      (asyncRomFile,asyncRomFilePow2,romFile,-                                    romFilePow2)-import CLaSH.Prelude.Safe-import CLaSH.Prelude.Testbench     (assert, stimuliGenerator, outputVerifier)-import CLaSH.Promoted.Nat-import CLaSH.Promoted.Nat.TH-import CLaSH.Promoted.Nat.Literals-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-import CLaSH.Signal-import CLaSH.Signal.Delayed-import CLaSH.Signal.Explicit       (systemClock)-import CLaSH.XException--{- $setup->>> :set -XDataKinds->>> let window4 = window :: Signal Int -> Vec 4 (Signal Int)->>> let windowD3 = windowD :: Signal Int -> Vec 3 (Signal Int)->>> 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".--}--{-# INLINE window #-}--- | Give a window over a 'Signal'------ > window4 :: Signal Int -> Vec 4 (Signal Int)--- > window4 = window------ >>> simulateB 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>...--- ...-window :: (KnownNat n, Default a)-       => Signal a                -- ^ Signal to create a window over-       -> Vec (n + 1) (Signal a)  -- ^ Window of at least size 1-window = window' systemClock--{-# INLINE windowD #-}--- | Give a delayed window over a 'Signal'------ > windowD3 :: Signal Int -> Vec 3 (Signal Int)--- > windowD3 = windowD------ >>> simulateB windowD3 [1::Int,2,3,4] :: [Vec 3 Int]--- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>...--- ...-windowD :: (KnownNat n, Default a)-        => Signal a               -- ^ Signal to create a window over-        -> Vec (n + 1) (Signal a) -- ^ Window of at least size 1-windowD = windowD' systemClock
− 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,70 +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-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-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)--- 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-reduceXor :: BitPack a => a -> Bit-reduceXor v = reduceXor# (pack v)
− src/CLaSH/Prelude/BlockRam.hs 
@@ -1,820 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-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 CλaSH.--We start with the definition of the Instructions, Register names and machine-codes:--@-{\-\# LANGUAGE RecordWildCards, TupleSections \#-\}-module CPU where--import CLaSH.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 :: Signal MemAddr                 -- ^ Read address-        -> Signal (Maybe (MemAddr,Value)) -- ^ (write address, data in)-        -> Signal Value                   -- ^ data out-dataMem rd wrM = 'CLaSH.Prelude.Mealy.mealy' dataMemT ('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 :: KnownNat n => Vec n Instruction -> Signal 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-@--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 31 $ system prog-[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 :: KnownNat n => Vec n Instruction -> Signal 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-@--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 31 $ system2 prog-[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 behaviour 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 :: KnownNat n => Vec n Instruction -> Signal 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-@--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 33 $ system3 prog2-[X,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 MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# 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.Prelude.BlockRam-  ( -- * BlockRAM synchronised to the system clock-    blockRam-  , blockRamPow2-    -- * BlockRAM synchronised to an arbitrary clock-  , blockRam'-  , blockRamPow2'-    -- * Read/Write conflict resolution-  , readNew-  , readNew'-    -- * Internal-  , blockRam#-  )-where--import Data.Maybe             (fromJust, isJust)-import qualified Data.Vector  as V-import GHC.TypeLits           (KnownNat, type (^))-import Prelude                hiding (length)--import CLaSH.Signal           (Signal, mux)-import CLaSH.Signal.Explicit  (SClock, register', systemClock)-import CLaSH.Signal.Internal  (Signal' (..))-import CLaSH.Signal.Bundle    (unbundle)-import CLaSH.Sized.Unsigned   (Unsigned)-import CLaSH.Sized.Vector     (Vec, toList)-import CLaSH.XException       (errorX)--{- $setup->>> import CLaSH.Prelude as C->>> import qualified Data.List as L->>> :set -XDataKinds -XRecordWildCards -XTupleSections->>> 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)-:}-->>> :{-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 :: Signal MemAddr-        -> Signal (Maybe (MemAddr,Value))-        -> Signal Value-dataMem rd wrM = mealy 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 :: KnownNat n => Vec n Instruction -> Signal Value-system instrs = memOut-  where-    memOut = dataMem rdAddr dout-    (rdAddr,dout,ipntr) = mealyB 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 :: KnownNat n => Vec n Instruction -> Signal 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-:}-->>> :{-system3 :: KnownNat n => Vec n Instruction -> Signal 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-:}-->>> :{-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-:}---}--{-# INLINE blockRam #-}--- | Create a blockRAM with space for @n@ elements.------ * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'------ @--- bram40 :: 'Signal' ('Unsigned' 6)---        -> 'Signal' (Maybe ('Unsigned' 6, 'CLaSH.Sized.BitVector.Bit'))---        -> 'Signal' '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 :: Enum addr-         => Vec n a     -- ^ Initial content of the BRAM, also-                        -- determines the size, @n@, of the BRAM.-                        ---                        -- __NB__: __MUST__ be a constant.-         -> Signal addr -- ^ Read address @r@-         -> Signal (Maybe (addr, a))-          -- ^ (write address @w@, value to write)-         -> Signal a-         -- ^ Value of the @blockRAM@ at address @r@ from the previous clock-         -- cycle-blockRam = blockRam' systemClock--{-# INLINE blockRamPow2 #-}--- | Create a blockRAM with space for 2^@n@ elements------ * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'------ @--- bram32 :: 'Signal' ('Unsigned' 5)---        -> 'Signal' (Maybe ('Unsigned' 5, 'CLaSH.Sized.BitVector.Bit'))---        -> 'Signal' '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 :: KnownNat n-             => Vec (2^n) a         -- ^ Initial content of the BRAM, also-                                    -- determines the size, @2^n@, of the BRAM.-                                    ---                                    -- __NB__: __MUST__ be a constant.-             -> Signal (Unsigned n) -- ^ Read address @r@-             -> Signal (Maybe (Unsigned n, a))-             -- ^ (write address @w@, value to write)-             -> Signal a-             -- ^ Value of the @blockRAM@ at address @r@ from the previous clock-             -- cycle-blockRamPow2 = blockRamPow2' systemClock--{-# INLINE blockRam' #-}--- | Create a blockRAM with space for @n@ elements------ * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'------ @--- type ClkA = Clk \"A\" 100------ clkA100 :: SClock ClkA--- clkA100 = 'CLaSH.Signal.Explicit.sclock'------ bram40 :: 'Signal'' ClkA ('Unsigned' 6)---        -> 'Signal'' ClkA (Maybe ('Unsigned' 6, 'CLaSH.Sized.BitVector.Bit'))---        -> 'Signal'' ClkA 'CLaSH.Sized.BitVector.Bit'--- bram40 = 'blockRam'' clkA100 ('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' clk (blockRam' clk inits) rd wrM@.-blockRam' :: Enum addr-          => SClock clk       -- ^ 'Clock' to synchronize to-          -> Vec n a          -- ^ Initial content of the BRAM, also-                              -- determines the size, @n@, of the BRAM.-                              ---                              -- __NB__: __MUST__ be a constant.-          -> Signal' clk addr -- ^ Read address @r@-          -> Signal' clk (Maybe (addr, a))-          -- ^ (write address @w@, value to write)-          -> Signal' clk a-          -- ^ Value of the @blockRAM@ at address @r@ from the previous clock-          -- cycle-blockRam' clk content rd wrM =-  let en       = isJust <$> wrM-      (wr,din) = unbundle (fromJust <$> wrM)-  in  blockRam# clk content (fromEnum <$> rd) en (fromEnum <$> wr) din--{-# INLINE blockRamPow2' #-}--- | Create a blockRAM with space for 2^@n@ elements------ * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'------ @--- type ClkA = Clk \"A\" 100------ clkA100 :: SClock ClkA--- clkA100 = 'CLaSH.Signal.Explicit.sclock'------ bram32 :: 'Signal'' ClkA ('Unsigned' 5)---        -> 'Signal'' ClkA (Maybe ('Unsigned' 5, 'CLaSH.Sized.BitVector.Bit'))---        -> 'Signal'' ClkA 'CLaSH.Sized.BitVector.Bit'--- bram32 = 'blockRamPow2'' clkA100 ('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 (blockRamPow2' clk inits) rd wrM@.-blockRamPow2' :: KnownNat n-              => SClock clk               -- ^ 'Clock' to synchronize to-              -> Vec (2^n) a              -- ^ Initial content of the BRAM, also-                                          -- determines the size, @2^n@, of-                                          -- the BRAM.-                                          ---                                          -- __NB__: __MUST__ be a constant.-              -> Signal' clk (Unsigned n) -- ^ Read address @r@-              -> Signal' clk (Maybe (Unsigned n, a))-              -- ^ (Write address @w@, value to write)-              -> Signal' clk a-              -- ^ Value of the @blockRAM@ at address @r@ from the previous-              -- clock cycle-blockRamPow2' = blockRam'---- | blockRAM primitive-blockRam# :: SClock clk       -- ^ 'Clock' to synchronize to-          -> Vec n a          -- ^ Initial content of the BRAM, also-                              -- determines the size, @n@, of the BRAM.-                              ---                              -- __NB__: __MUST__ be a constant.-          -> Signal' clk Int  -- ^ Read address @r@-          -> Signal' clk Bool -- ^ Write enable-          -> Signal' clk Int  -- ^ Write address @w@-          -> Signal' clk a    -- ^ Value to write (at address @w@)-          -> Signal' clk a-          -- ^ Value of the @blockRAM@ at address @r@ from the previous clock-          -- cycle-blockRam# _clk content =-    go (V.fromList (toList content)) (errorX "blockRam#: intial value undefined")-  where-    go !ram o (r :- rs) (e :- en) (w :- wr) (d :- din) =-      let ram' = upd ram e w d-          o'   = ram V.! r-      in  o :- go ram' o' rs en wr din--    upd ram True  addr d = ram V.// [(addr,d)]-    upd ram False _    _ = ram-{-# NOINLINE blockRam# #-}---- | Create read-after-write blockRAM from a read-before-write one (synchronised to specified clock)----readNew' :: Eq addr-         => SClock clk-         -> (Signal' clk addr -> Signal' clk (Maybe (addr, a)) -> Signal' clk a)-         -- ^ The @ram@ component-         -> Signal' clk addr              -- ^ Read address @r@-         -> Signal' clk (Maybe (addr, a)) -- ^ (Write address @w@, value to write)-         -> Signal' clk a-         -- ^ Value of the @ram@ at address @r@ from the previous clock-         -- cycle-readNew' clk 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 (False,undefined)-                                                       (readNewT <$> rdAddr <*> wrM))---- | Create read-after-write blockRAM from a read-before-write one (synchronised to system clock)------ >>> import CLaSH.Prelude--- >>> :t readNew (blockRam (0 :> 1 :> Nil))--- readNew (blockRam (0 :> 1 :> Nil))---   :: ... =>---      Signal addr -> Signal (Maybe (addr, a)) -> Signal a-readNew :: Eq addr-        => (Signal addr -> Signal (Maybe (addr, a)) -> Signal a)-        -- ^ The @ram@ component-        -> Signal addr              -- ^ Read address @r@-        -> Signal (Maybe (addr, a)) -- ^ (Write address @w@, value to write)-        -> Signal a-        -- ^ Value of the @ram@ at address @r@ from the previous clock-        -- cycle-readNew = readNew' systemClock
− src/CLaSH/Prelude/BlockRam/File.hs 
@@ -1,306 +0,0 @@-{-|-Copyright  :  (C) 2015-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--= Initialising a BlockRAM with a data file #usingramfiles#--BlockRAM primitives that can be initialised with a data file. The BNF grammar-for this data file is simple:--@-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-@7@ to @13@ looks like:--@-000000111-000001000-000001001-000001010-000001011-000001100-000001101-@--We can instantiate a BlockRAM using the content of the above file like so:--@-topEntity :: Signal (Unsigned 3) -> Signal (Unsigned 9)-topEntity rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" rd (signal Nothing)-@--In the example above, we basically treat the BlockRAM as an synchronous ROM.-We can see that it works as expected:--@-__>>> import qualified Data.List as L__-__>>> L.tail $ sampleN 4 $ topEntity (fromList [3..5])__-[10,11,12]-@--However, we can also interpret the same data as a tuple of a 6-bit unsigned-number, and a 3-bit signed number:--@-topEntity2 :: Signal (Unsigned 3) -> Signal (Unsigned 6,Signed 3)-topEntity2 rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" rd (signal Nothing)-@--And then we would see:--@-__>>> import qualified Data.List as L__-__>>> L.tail $ sampleN 4 $ topEntity2 (fromList [3..5])__-[(1,2),(1,3)(1,-4)]-@---}--{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeOperators       #-}--{-# LANGUAGE Unsafe #-}--{-# 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.Prelude.BlockRam.File-  ( -- * BlockRAM synchronised to the system clock-    blockRamFile-  , blockRamFilePow2-    -- * BlockRAM synchronised to an arbitrary clock-  , blockRamFile'-  , blockRamFilePow2'-    -- * Internal-  , blockRamFile#-  , initMem-  )-where--import Data.Char                    (digitToInt)-import Data.Maybe                   (fromJust, isJust, listToMaybe)-import qualified Data.Vector        as V-import GHC.TypeLits                 (KnownNat)-import Numeric                      (readInt)-import System.IO.Unsafe             (unsafePerformIO)--import CLaSH.Promoted.Nat    (SNat (..), pow2SNat)-import CLaSH.Sized.BitVector (BitVector)-import CLaSH.Signal          (Signal)-import CLaSH.Signal.Explicit (SClock, systemClock)-import CLaSH.Signal.Internal (Signal' (..))-import CLaSH.Signal.Bundle   (unbundle)-import CLaSH.Sized.Unsigned  (Unsigned)-import CLaSH.XException      (errorX)--{-# INLINE blockRamFile #-}--- | Create a blockRAM with space for @n@ elements------ * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'--- * __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      |---     ===============+==========+==========+===============+---     @------ 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 (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.--- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your--- own data files.-blockRamFile :: (KnownNat m, Enum addr)-             => SNat n               -- ^ Size of the blockRAM-             -> FilePath             -- ^ File describing the initial content-                                     -- of the blockRAM-             -> Signal addr          -- ^ Read address @r@-             -> Signal (Maybe (addr, BitVector m))-             -- ^ (write address @w@, value to write)-             -> Signal (BitVector m)-             -- ^ Value of the @blockRAM@ at address @r@ from the previous clock-             -- cycle-blockRamFile = blockRamFile' systemClock--{-# INLINE blockRamFilePow2 #-}--- | Create a blockRAM with space for 2^@n@ elements------ * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'--- * __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      |---     ===============+==========+==========+===============+---     @------ 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 (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.--- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your--- own data files.-blockRamFilePow2 :: (KnownNat m, KnownNat n)-                 => FilePath             -- ^ File describing the initial-                                         -- content of the blockRAM-                 -> Signal (Unsigned n) -- ^ Read address @r@-                 -> Signal (Maybe (Unsigned n, BitVector m))-                 -- ^ (write address @w@, value to write)-                 -> Signal (BitVector m)-                 -- ^ Value of the @blockRAM@ at address @r@ from the previous-                 -- clock cycle-blockRamFilePow2 = blockRamFilePow2' systemClock--{-# INLINE blockRamFilePow2' #-}--- | Create a blockRAM with space for 2^@n@ elements------ * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'--- * __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      |---     ===============+==========+==========+===============+---     @------ 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 (blockRamFilePow2' clk 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.--- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your--- own data files.-blockRamFilePow2' :: forall clk n m . (KnownNat m, KnownNat n)-                  => SClock clk                -- ^ 'Clock' to synchronize to-                  -> FilePath                  -- ^ File describing the initial-                                               -- content of the blockRAM-                  -> Signal' clk (Unsigned n)  -- ^ Read address @r@-                  -> Signal' clk (Maybe (Unsigned n, BitVector m))-                  -- ^ (write address @w@, value to write)-                  -> Signal' clk (BitVector m)-                  -- ^ Value of the @blockRAM@ at address @r@ from the previous-                  -- clock cycle-blockRamFilePow2' clk = blockRamFile' clk (pow2SNat (SNat @ n))--{-# INLINE blockRamFile' #-}--- | Create a blockRAM with space for @n@ elements------ * __NB__: Read value is delayed by 1 cycle--- * __NB__: Initial output value is 'undefined'--- * __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      |---     ===============+==========+==========+===============+---     @------ 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 (blockRamFile' clk 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.--- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your--- own data files.-blockRamFile' :: (KnownNat m, Enum addr)-              => SClock clk                -- ^ 'Clock' to synchronize to-              -> SNat n                    -- ^ Size of the blockRAM-              -> FilePath                  -- ^ File describing the initial-                                           -- content of the blockRAM-              -> Signal' clk addr          -- ^ Read address @r@-              -> Signal' clk (Maybe (addr, BitVector m))-              -- ^ (write address @w@, value to write)-              -> Signal' clk (BitVector m)-              -- ^ Value of the @blockRAM@ at address @r@ from the previous-              -- clock cycle-blockRamFile' clk sz file rd wrM =-  let en       = isJust <$> wrM-      (wr,din) = unbundle (fromJust <$> wrM)-  in  blockRamFile# clk sz file (fromEnum <$> rd) en (fromEnum <$> wr) din---- | blockRamFile primitive-blockRamFile# :: KnownNat m-              => SClock clk                -- ^ 'Clock' to synchronize to-              -> SNat n                    -- ^ Size of the blockRAM-              -> FilePath                  -- ^ File describing the initial-                                           -- content of the blockRAM-              -> Signal' clk Int           -- ^ Read address @r@-              -> Signal' clk Bool          -- ^ Write enable-              -> Signal' clk Int           -- ^ Write address @w@-              -> Signal' clk (BitVector m) -- ^ Value to write (at address @w@)-              -> Signal' clk (BitVector m)-              -- ^ Value of the @blockRAM@ at address @r@ from the previous-              -- clock cycle-blockRamFile# _clk _sz file =-    go ramI (errorX "blockRamFile#: intial value undefined")-  where-    go !ram o (r :- rs) (e :- en) (w :- wr) (d :- din) =-      let ram' = upd ram e w d-          o'   = ram V.! r-      in  o :- go ram' o' rs en wr din--    upd ram True  addr d = ram V.// [(addr,d)]-    upd ram False _    _ = ram--    content = unsafePerformIO (initMem file)-    ramI    = V.fromList content-{-# NOINLINE blockRamFile# #-}--{-# NOINLINE initMem #-}--- | __NB:__ Not synthesisable-initMem :: KnownNat n => FilePath -> IO [BitVector n]-initMem = fmap (map parseBV . lines) . readFile-  where-    parseBV s = case parseBV' s of-                  Just i  -> fromInteger i-                  Nothing -> error ("Failed to parse: " ++ s)-    parseBV' = fmap fst . listToMaybe . readInt 2 (`elem` "01") digitToInt
− src/CLaSH/Prelude/DataFlow.hs 
@@ -1,539 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--Self-synchronising circuits based on data-flow principles.--}--{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MagicHash             #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Prelude.DataFlow-  ( -- * Data types-    DataFlow-  , 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, KnownSymbol, 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.Prelude.Mealy    (mealyB')-import CLaSH.Promoted.Nat     (SNat)-import CLaSH.Signal           ((.&&.), unbundle)-import CLaSH.Signal.Bundle    (Bundle (..))-import CLaSH.Signal.Internal  (regEn#)-import CLaSH.Signal.Explicit  (Clock (..), Signal', SystemClock, sclock)-import CLaSH.Sized.BitVector  (BitVector)-import CLaSH.Sized.Vector--{- | Dataflow circuit with bidirectional synchronisation 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' clk iEn oEn i o-  = DF-  { df :: 'Signal'' clk i     -- Incoming data-       -> 'Signal'' clk iEn   -- Flagged with /valid/ bits @iEn@.-       -> 'Signal'' clk oEn   -- Incoming back-pressure, /ready/ edge.-       -> ( 'Signal'' clk o   -- Outgoing data.-          , 'Signal'' clk oEn -- Flagged with /valid/ bits @oEn@.-          , 'Signal'' clk iEn -- Outgoing back-pressure, /ready/ edge.-          )-  }-@--where:-- * @clk@ is the clock to which the circuit is synchronised.- * @iEn@ is the type of the bidirectional incoming synchronisation channel.- * @oEn@ is the type of the bidirectional outgoing synchronisation 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-parametrise in the types of the synchronisation channels.--}-newtype DataFlow' clk iEn oEn i o-  = DF-  { -- | Create an ordinary circuit from a 'DataFlow' circuit-    df :: Signal' clk i     -- Incoming data-       -> Signal' clk iEn   -- Flagged with /valid/ bits @iEn@.-       -> Signal' clk oEn   -- Incoming back-pressure, /ready/ edge.-       -> ( Signal' clk o   -- Outgoing data.-          , Signal' clk oEn -- Flagged with /valid/ bits @oEn@.-          , Signal' clk iEn -- Outgoing back-pressure, /ready/ edge.-          )-  }---- | Dataflow circuit synchronised to the 'SystemClock'.-type DataFlow iEn oEn i o = DataFlow' SystemClock iEn oEn i o---- | Create a 'DataFlow' circuit from a circuit description with the appropriate--- type:------ @--- 'Signal'' clk i        -- Incoming data.--- -> 'Signal'' clk Bool  -- Flagged with a single /valid/ bit.--- -> 'Signal'' clk Bool  -- Incoming back-pressure, /ready/ bit.--- -> ( 'Signal'' clk o   -- Outgoing data.---    , 'Signal'' clk oEn -- Flagged with a single /valid/ bit.---    , 'Signal'' clk 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' clk i -> Signal' clk Bool -> Signal' clk Bool-                         -> (Signal' clk o, Signal' clk Bool, Signal' clk Bool))-       -> DataFlow' clk Bool Bool i o-liftDF = DF---- | Create a 'DataFlow' circuit where the given function @f@ operates on the--- data, and the synchronisation channels are passed unaltered.-pureDF :: (i -> o)-       -> DataFlow' clk 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 :: (KnownSymbol nm, KnownNat rate)-        => (s -> i -> (s,o))-        -> s-        -> DataFlow' ('Clk nm rate) Bool Bool i o-mealyDF f iS = DF (\i iV oR -> let en     = iV .&&. oR-                                   (s',o) = unbundle (f <$> s <*> i)-                                   s      = regEn# sclock iS en s'-                               in  (o,iV,oR))---- | Create a 'DataFlow' circuit from a Moore machine description as those of--- "CLaSH.Prelude.Moore"-mooreDF :: (KnownSymbol nm, KnownNat rate)-        => (s -> i -> s)-        -> (s -> o)-        -> s-        -> DataFlow' ('Clk nm rate) Bool Bool i o-mooreDF ft fo iS = DF (\i iV oR -> let en  = iV .&&. oR-                                       s'  = ft <$> s <*> i-                                       s   = regEn# sclock iS en 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 nm rate .-     (KnownNat addrSize, KnownNat n, KnownNat m, (m + n) ~ (2 ^ addrSize),-     KnownSymbol nm, KnownNat rate)-  => 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 initialised with 'undefined'.-  -> DataFlow' ('Clk nm rate) Bool Bool a a-fifoDF _ iS = DF $ \i iV oR ->-  let clk            = sclock-      initRdPtr      = 0-      initWrPtr      = fromIntegral (length iS)-      initMem        = iS ++ repeat undefined :: Vec (m + n) a-      initS          = (initMem,initRdPtr,initWrPtr)-      (o,empty,full) = mealyB' clk fifoDF_mealy initS (i,iV,oR)-  in  (o,not <$> empty, not <$> full)---- | Identity circuit------ <<doc/idDF.svg>>-idDF :: DataFlow' clk en en a a-idDF = DF (\a val rdy -> (a,val,rdy))---- | Sequential composition of two 'DataFlow' circuits.------ <<doc/seqDF.svg>>-seqDF :: DataFlow' clk aEn bEn a b-      -> DataFlow' clk bEn cEn b c-      -> DataFlow' clk 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' clk aEn bEn a b-        -> DataFlow' clk (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' clk (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' clk aEn bEn a b-         -> DataFlow' clk (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' clk aEn bEn a b-      -> DataFlow' clk cEn dEn c d-      -> DataFlow' clk (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' clk aEn bEn a b)-       -> DataFlow' clk-                    (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 synchronisation channels:------ @--- __h__ :: 'DataFlow' (Bool,Bool) (Bool,Bool) (a,d) (b,d)--- @------ Feeding back the /d/ part (including its synchronisation channels) results--- in:------ @--- 'loopDF' d4 Nil h--- @------ <<doc/loopDF.svg>>------ When you have a circuit @h'@, with only a single synchronisation 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 synchronisation 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 :: (KnownNat m, KnownNat n, KnownNat addrSize, KnownNat rate-          ,KnownSymbol nm,(m+n) ~ (2^addrSize))-       => 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 initialised with-                  -- 'undefined'.-       -> DataFlow' ('Clk nm rate) (Bool,Bool) (Bool,Bool) (a,d) (b,d)-       -> DataFlow' ('Clk nm rate) Bool Bool   a           b-loopDF 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 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' clk (Bool,Bool) (Bool,Bool) (a,d) (b,d)-             -> DataFlow' clk 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 synchronisation granularity of parallel compositions.-class LockStep a b where-  -- | Reduce the synchronisation 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 synchronisation 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 synchronisation signals are-  -- properly connected:-  ---  -- @-  -- (f \`@'parDF'@\` g) \`@'seqDF'@\` 'lockStep' \`@'seqDF'@\` h-  -- @-  ---  -- <<doc/lockStep.svg>>-  ---  -- __Note 1__: ensure that the components that you are synchronising 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' clk a Bool b b--  -- | Extend the synchronisation 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 synchronisation 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 synchronisation signals are-  -- properly connected:-  ---  -- @-  -- h \`@'seqDF'@\` 'stepLock' \`@'seqDF'@\` (f \`@'parDF'@\` g)-  -- @-  ---  -- <<doc/stepLock.svg>>-  ---  -- __Note 1__: ensure that the components that you are synchronising 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' clk 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/Explicit.hs 
@@ -1,136 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--This module defines the explicitly clocked counterparts of the functions-defined in "CLaSH.Prelude".--This module uses the explicitly clocked 'Signal'' synchronous signals, as-opposed to the implicitly clocked 'Signal' used in "CLaSH.Prelude". Take a-look at "CLaSH.Signal.Explicit" to see how you can make multi-clock designs-using explicitly clocked signals.--}--{-# LANGUAGE DataKinds     #-}-{-# LANGUAGE TypeOperators #-}--{-# LANGUAGE Unsafe #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Prelude.Explicit-  ( -- * Creating synchronous sequential circuits-    mealy'-  , mealyB'-  , moore'-  , mooreB'-  , registerB'-    -- * Synchronizer circuits for safe clock domain crossings-  , dualFlipFlopSynchronizer-  , asyncFIFOSynchronizer-    -- * ROMs-  , rom'-  , romPow2'-    -- ** ROMs initialised with a data file-  , romFile'-  , romFilePow2'-    -- * RAM primitives with a combinational read port-  , asyncRam'-  , asyncRamPow2'-    -- * BlockRAM primitives-  , blockRam'-  , blockRamPow2'-    -- ** BlockRAM primitives initialised with a data file-  , blockRamFile'-  , blockRamFilePow2'-    -- * Utility functions-  , window'-  , windowD'-  , isRising'-  , isFalling'-    -- * Testbench functions-  , assert'-  , stimuliGenerator'-  , outputVerifier'-    -- * Exported modules-    -- ** Explicitly clocked synchronous signals-  , module CLaSH.Signal.Explicit-  )-where--import Data.Default                 (Default (..))-import GHC.TypeLits                 (KnownNat, type (+), natVal)-import Prelude                      hiding (repeat)--import CLaSH.Prelude.Explicit.Safe-import CLaSH.Prelude.BlockRam.File (blockRamFile', blockRamFilePow2')-import CLaSH.Prelude.ROM.File      (romFile', romFilePow2')-import CLaSH.Prelude.Testbench     (assert', stimuliGenerator', outputVerifier')-import CLaSH.Signal.Explicit-import CLaSH.Sized.Vector          (Vec (..), (+>>), asNatProxy, repeat)--{- $setup->>> :set -XDataKinds->>> import CLaSH.Prelude->>> type ClkA = Clk "A" 100->>> let clkA = sclock :: SClock ClkA->>> let window4 = window' clkA :: Signal' ClkA Int -> Vec 4 (Signal' ClkA Int)->>> let windowD3 = windowD' clkA :: Signal' ClkA Int -> Vec 3 (Signal' ClkA Int)--}--{-# INLINABLE window' #-}--- | Give a window over a 'Signal''------ @--- type ClkA = 'Clk' \"A\" 100------ clkA :: 'SClock' ClkA--- clkA = 'sclock'------ window4 :: 'Signal'' ClkA Int -> 'Vec' 4 ('Signal'' ClkA Int)--- window4 = 'window'' clkA--- @------ >>> simulateB 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>...--- ...-window' :: (KnownNat n, Default a)-        => SClock clk                  -- ^ Clock to which the incoming-                                       -- signal is synchronized-        -> Signal' clk a               -- ^ Signal to create a window over-        -> Vec (n + 1) (Signal' clk a) -- ^ Window of at least size 1-window' clk x = res-  where-    res  = x :> prev-    prev = case natVal (asNatProxy prev) of-             0 -> repeat def-             _ -> let next = x +>> prev-                  in  registerB' clk (repeat def) next--{-# INLINABLE windowD' #-}--- | Give a delayed window over a 'Signal''------ @--- type ClkA = 'Clk' \"A\" 100------ clkA :: 'SClock' ClkA--- clkA = 'sclock'------ windowD3 :: 'Signal'' ClkA Int -> 'Vec' 3 ('Signal'' ClkA Int)--- windowD3 = 'windowD'' clkA--- @------ >>> simulateB windowD3 [1::Int,2,3,4] :: [Vec 3 Int]--- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>...--- ...-windowD' :: (KnownNat n, Default a)-         => SClock clk                   -- ^ Clock to which the incoming signal-                                         -- is synchronized-         -> Signal' clk a                -- ^ Signal to create a window over-         -> Vec (n + 1) (Signal' clk a)  -- ^ Window of at least size 1-windowD' clk x =-  let prev = registerB' clk (repeat def) next-      next = x +>> prev-  in  prev
− src/CLaSH/Prelude/Explicit/Safe.hs 
@@ -1,148 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--__This is the <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/safe-haskell.html Safe> API only of "CLaSH.Prelude.Explicit"__--This module defines the explicitly clocked counterparts of the functions-defined in "CLaSH.Prelude".--This module uses the explicitly clocked 'Signal'' synchronous signals, as-opposed to the implicitly clocked 'Signal' used in "CLaSH.Prelude". Take a-look at "CLaSH.Signal.Explicit" to see how you can make multi-clock designs-using explicitly clocked signals.--}--{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# LANGUAGE Safe #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Prelude.Explicit.Safe-  ( -- * Creating synchronous sequential circuits-    mealy'-  , mealyB'-  , moore'-  , mooreB'-  , registerB'-    -- * Synchronizer circuits for safe clock domain crossing-  , dualFlipFlopSynchronizer-  , asyncFIFOSynchronizer-    -- * ROMs-  , rom'-  , romPow2'-    -- * RAM primitives with a combinational read port-  , asyncRam'-  , asyncRamPow2'-    -- * BlockRAM primitives-  , blockRam'-  , blockRamPow2'-    -- * Utility functions-  , isRising'-  , isFalling'-  , riseEvery'-  , oscillate'-    -- * Exported modules-    -- ** Explicitly clocked synchronous signals-  , module CLaSH.Signal.Explicit-  )-where--import GHC.TypeLits-import Control.Applicative        (liftA2)-import Prelude                    hiding (repeat)--import CLaSH.Prelude.BlockRam     (blockRam', blockRamPow2')-import CLaSH.Prelude.Mealy        (mealy', mealyB')-import CLaSH.Prelude.Moore        (moore', mooreB')-import CLaSH.Prelude.RAM          (asyncRam',asyncRamPow2')-import CLaSH.Prelude.ROM          (rom', romPow2')-import CLaSH.Prelude.Synchronizer (dualFlipFlopSynchronizer,-                                   asyncFIFOSynchronizer)-import CLaSH.Promoted.Nat         (SNat(..))-import CLaSH.Sized.Index          (Index)-import CLaSH.Signal.Bundle        (Bundle(..), Unbundled')-import CLaSH.Signal.Explicit-import CLaSH.Sized.Unsigned---{- $setup->>> :set -XDataKinds->>> import CLaSH.Prelude->>> type ClkA = Clk "A" 100->>> let clkA = sclock :: SClock ClkA->>> let rP = registerB' clkA (8::Int,8::Int)--}--{-# INLINE registerB' #-}--- | Create a 'register' function for product-type like signals (e.g.--- @('Signal' a, 'Signal' b)@)------ @--- type ClkA = 'Clk' \"A\" 100------ clkA :: 'SClock' ClkA--- clkA = 'sclock'------ rP :: ('Signal'' ClkA Int, 'Signal'' ClkA Int) -> ('Signal'' ClkA Int, 'Signal'' ClkA Int)--- rP = 'registerB'' clkA (8,8)--- @------ >>> simulateB rP [(1,1),(2,2),(3,3)] :: [(Int,Int)]--- [(8,8),(1,1),(2,2),(3,3)...--- ...-registerB' :: Bundle a => SClock clk -> a -> Unbundled' clk a -> Unbundled' clk a-registerB' clk i = unbundle Prelude.. register' clk i Prelude.. bundle--{-# INLINABLE isRising' #-}--- | Give a pulse when the 'Signal'' goes from 'minBound' to 'maxBound'-isRising' :: (Bounded a, Eq a)-          => SClock clk-          -> a -- ^ Starting value-          -> Signal' clk a-          -> Signal' clk Bool-isRising' clk is s = liftA2 edgeDetect prev s-  where-    prev = register' clk is s-    edgeDetect old new = old == minBound && new == maxBound--{-# INLINABLE isFalling' #-}--- | Give a pulse when the 'Signal'' goes from 'maxBound' to 'minBound'-isFalling' :: (Bounded a, Eq a)-           => SClock clk-           -> a -- ^ Starting value-           -> Signal' clk a-           -> Signal' clk Bool-isFalling' clk is s = liftA2 edgeDetect prev s-  where-    prev = register' clk is s-    edgeDetect old new = old == maxBound && new == minBound--{-# INLINEABLE riseEvery' #-}--- | Give a pulse every @n@ clock cycles. This is a useful helper function when--- combined with functions like @'CLaSH.Signal.regEn'@ or @'CLaSH.Signal.mux'@,--- in order to delay a register by a known amount.-riseEvery' :: forall clk n. KnownNat n => SClock clk -> SNat n -> Signal' clk Bool-riseEvery' clk SNat = moore' clk transfer output 0 (pure ())-  where-    output :: Index n -> Bool-    output = (== maxBound)--    transfer :: Index n -> () -> Index n-    transfer s _ = if (s == maxBound) then 0 else s+1--{-# INLINEABLE oscillate' #-}--- | Oscillate a @'Bool'@ for a given number of cycles, given the starting state.-oscillate' :: forall clk n. KnownNat n => SClock clk -> Bool -> SNat n -> Signal' clk Bool-oscillate' clk begin SNat = moore' clk transfer snd (0, begin) (pure ())-  where-    transfer :: (Index n, Bool) -> () -> (Index n, Bool)-    transfer (s, i) _ =-      if s == maxBound-        then (0,   not i) -- reset state and oscillate output-        else (s+1, i)     -- hold current output
− src/CLaSH/Prelude/Mealy.hs 
@@ -1,222 +0,0 @@-{-|-  Copyright  :  (C) 2013-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Whereas the output of a Moore machine depends on the /previous state/, the-  outputof a Mealy machine depends on /current transition/.--  Mealy machines are strictly more expressive, but may impose stricter timing-  requirements.--}--{-# LANGUAGE Safe #-}--module CLaSH.Prelude.Mealy-  ( -- * Mealy machine synchronised to the system clock-    mealy-  , mealyB-  , (<^>)-    -- * Mealy machine synchronised to an arbitrary clock-  , mealy'-  , mealyB'-  )-where--import CLaSH.Signal          (Signal, Unbundled)-import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock)-import CLaSH.Signal.Bundle   (Bundle (..), Unbundled')--{- $setup->>> :set -XDataKinds->>> import CLaSH.Prelude->>> :{-let mac s (x,y) = (s',s)-      where-        s' = x * y + s-    topEntity = mealy mac 0-:}-->>> import CLaSH.Prelude.Explicit->>> type ClkA = Clk "A" 100->>> let clkA = sclock :: SClock ClkA->>> :{-let mac s (x,y) = (s',s)-      where-        s' = x * y + s-:}-->>> let topEntity = mealy' clkA mac 0--}--{-# INLINE mealy #-}--- | Create a synchronous function from a combinational function describing--- a mealy machine------ @--- mac :: Int        -- Current state---     -> (Int,Int)  -- Input---     -> (Int,Int)  -- (Updated state, output)--- mac s (x,y) = (s',s)---   where---     s' = x * y + s------ topEntity :: 'Signal' (Int, Int) -> 'Signal' Int--- topEntity = 'mealy' mac 0--- @------ >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)]--- [0,1,5,14...--- ...------ Synchronous sequential functions can be composed just like their--- combinational counterpart:------ @--- dualMac :: ('Signal' Int, 'Signal' Int)---         -> ('Signal' Int, 'Signal' Int)---         -> 'Signal' 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))--- @-mealy :: (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form:-                           -- @state -> input -> (newstate,output)@-      -> s                 -- ^ Initial state-      -> (Signal i -> Signal o)-      -- ^ Synchronous sequential function with input and output matching that-      -- of the mealy machine-mealy = mealy' systemClock--{-# INLINE mealyB #-}--- | A version of 'mealy' that does automatic 'Bundle'ing------ 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) = 'CLaSH.Signal.unbundle' ('mealy' f 0 ('CLaSH.Signal.bundle' (a,b)))---     (i2,b2) = 'CLaSH.Signal.unbundle' ('mealy' f 3 ('CLaSH.Signal.bundle' (i1,c)))--- @------ Using 'mealyB' however we can write:------ @--- g a b c = (b1,b2,i2)---   where---     (i1,b1) = 'mealyB' f 0 (a,b)---     (i2,b2) = 'mealyB' f 3 (i1,c)--- @-mealyB :: (Bundle i, Bundle o)-       => (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form:-                            -- @state -> input -> (newstate,output)@-       -> s                 -- ^ Initial state-       -> (Unbundled i -> Unbundled o)-       -- ^ Synchronous sequential function with input and output matching that-       -- of the mealy machine-mealyB = mealyB' systemClock--{-# INLINE (<^>) #-}--- | Infix version of 'mealyB'-(<^>) :: (Bundle i, Bundle o)-      => (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form:-                           -- @state -> input -> (newstate,output)@-      -> s                 -- ^ Initial state-      -> (Unbundled i -> Unbundled o)-      -- ^ Synchronous sequential function with input and output matching that-      -- of the mealy machine-(<^>) = mealyB--{-# INLINABLE mealy' #-}--- | Create a synchronous function from a combinational function describing--- a mealy machine------ @--- mac :: Int        -- Current state---     -> (Int,Int)  -- Input---     -> (Int,Int)  -- (Updated state, output)--- mac s (x,y) = (s',s)---   where---     s' = x * y + s------ type ClkA = 'CLaSH.Signal.Explicit.Clk' \"A\" 100------ clkA :: 'SClock' ClkA--- clkA = 'CLaSH.Signal.Explicit.sclock'------ topEntity :: 'Signal'' ClkA (Int, Int) -> 'Signal'' ClkA Int--- topEntity = 'mealy'' clkA mac 0--- @------ >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)]--- [0,1,5,14...--- ...------ Synchronous sequential functions can be composed just like their--- combinational counterpart:------ @--- dualMac :: ('Signal'' clkA100 Int, 'Signal'' clkA100 Int)---         -> ('Signal'' clkA100 Int, 'Signal'' clkA100 Int)---         -> 'Signal'' clkA100 Int--- dualMac (a,b) (x,y) = s1 + s2---   where---     s1 = 'mealy'' clkA100 mac 0 ('CLaSH.Signal.Explicit.bundle'' clkA100 (a,x))---     s2 = 'mealy'' clkA100 mac 0 ('CLaSH.Signal.Explicit.bundle'' clkA100 (b,y))--- @-mealy' :: SClock clk        -- ^ 'Clock' to synchronize to-       -> (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form:-                            -- @state -> input -> (newstate,output)@-       -> s                 -- ^ Initial state-       -> (Signal' clk i -> Signal' clk o)-       -- ^ Synchronous sequential function with input and output matching that-       -- of the mealy machine-mealy' clk f iS = \i -> let (s',o) = unbundle $ f <$> s <*> i-                            s      = register' clk iS s'-                        in  o--{-# INLINE mealyB' #-}--- | A version of 'mealy'' that does automatic 'Bundle'ing------ 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 clk a b c = (b1,b2,i2)---   where---     (i1,b1) = 'CLaSH.Signal.Explicit.unbundle'' clk (mealy' clk f 0 ('CLaSH.Signal.Explicit.bundle'' clk (a,b)))---     (i2,b2) = 'CLaSH.Signal.Explicit.unbundle'' clk (mealy' clk f 3 ('CLaSH.Signal.Explicit.bundle'' clk (i1,c)))--- @------ Using 'mealyB'' however we can write:------ @--- g clk a b c = (b1,b2,i2)---   where---     (i1,b1) = 'mealyB'' clk f 0 (a,b)---     (i2,b2) = 'mealyB'' clk f 3 (i1,c)--- @-mealyB' :: (Bundle i, Bundle o)-        => SClock clk-        -> (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form:-                     -- @state -> input -> (newstate,output)@-        -> s                 -- ^ Initial state-        -> (Unbundled' clk i -> Unbundled' clk o)-        -- ^ Synchronous sequential function with input and output matching that-        -- of the mealy machine-mealyB' clk f iS i = unbundle (mealy' clk f iS (bundle i))
− src/CLaSH/Prelude/Moore.hs 
@@ -1,236 +0,0 @@-{-|-  Copyright  :  (C) 2013-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Whereas the output of a Mealy machine depends on /current transition/, the-  output of a Moore machine depends on the /previous state/.--  Moore machines are strictly less expressive, but may impose laxer timing-  requirements.--}--{-# LANGUAGE Safe #-}--module CLaSH.Prelude.Moore-  ( -- * Moore machine synchronised to the system clock-    moore-  , mooreB-  , medvedev-  , medvedevB-    -- * Moore machine synchronised to an arbitrary clock-  , moore'-  , mooreB'-  , medvedev'-  , medvedevB'-  )-where--import CLaSH.Signal          (Signal, Unbundled)-import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock)-import CLaSH.Signal.Bundle   (Bundle (..), Unbundled')--{- $setup->>> :set -XDataKinds->>> import CLaSH.Prelude->>> :{-let mac s (x,y) = x * y + s-    topEntity = moore mac id 0-:}-->>> import CLaSH.Prelude.Explicit->>> type ClkA = Clk "A" 100->>> let clkA = sclock :: SClock ClkA->>> let mac s (x,y) = x * y + s-->>> let topEntity = moore' clkA mac id 0--}--{-# INLINE moore #-}--- | Create a synchronous function from a combinational function describing--- a moore machine------ @--- mac :: Int        -- Current state---     -> (Int,Int)  -- Input---     -> Int        -- Updated state--- mac s (x,y) = x * y + s------ topEntity :: 'Signal' (Int, Int) -> 'Signal' Int--- topEntity = 'moore' mac id 0--- @------ >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)]--- [0,1,5,14...--- ...------ Synchronous sequential functions can be composed just like their--- combinational counterpart:------ @--- dualMac :: ('Signal' Int, 'Signal' Int)---         -> ('Signal' Int, 'Signal' Int)---         -> 'Signal' 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))--- @-moore :: (s -> i -> s) -- ^ Transfer function in moore machine form:-                       -- @state -> input -> newstate@-      -> (s -> o)      -- ^ Output function in moore machine form:-                       -- @state -> output@-      -> s             -- ^ Initial state-      -> (Signal i -> Signal o)-      -- ^ Synchronous sequential function with input and output matching that-      -- of the moore machine-moore = moore' systemClock--{-# INLINE medvedev #-}--- | Create a synchronous function from a combinational function describing--- a moore machine without any output logic-medvedev :: (s -> i -> s) -> s -> Signal i -> Signal s-medvedev tr st = moore tr id st--{-# INLINE mooreB #-}--- | A version of 'moore' that does automatic 'Bundle'ing------ Given a functions @t@ and @o@ of types:------ @--- __t__ :: Int -> (Bool, Int) -> Int--- __o__ :: Int -> (Int, Bool)--- @------ When we want to make compositions of @t@ and @o@ in @g@ using 'moore', we have to--- write:------ @--- g a b c = (b1,b2,i2)---   where---     (i1,b1) = 'CLaSH.Signal.unbundle' ('moore' t o 0 ('CLaSH.Signal.bundle' (a,b)))---     (i2,b2) = 'CLaSH.Signal.unbundle' ('moore' t o 3 ('CLaSH.Signal.bundle' (i1,c)))--- @------ Using 'mooreB' however we can write:------ @--- g a b c = (b1,b2,i2)---   where---     (i1,b1) = 'mooreB' t o 0 (a,b)---     (i2,b2) = 'mooreB' t o 3 (i1,c)--- @-mooreB :: (Bundle i, Bundle o)-      => (s -> i -> s) -- ^ Transfer function in moore machine form:-                       -- @state -> input -> newstate@-      -> (s -> o)      -- ^ Output function in moore machine form:-                       -- @state -> output@-      -> s             -- ^ Initial state-      -> (Unbundled i -> Unbundled o)-       -- ^ Synchronous sequential function with input and output matching that-       -- of the moore machine-mooreB = mooreB' systemClock--{-# INLINE medvedevB #-}--- | A version of 'medvedev' that does automatic 'Bundle'ing-medvedevB :: (Bundle i, Bundle s) => (s -> i -> s) -> s -> Unbundled i -> Unbundled s-medvedevB tr st = mooreB tr id st--{-# INLINABLE moore' #-}--- | Create a synchronous function from a combinational function describing--- a moore machine------ @--- mac :: Int        -- Current state---     -> (Int,Int)  -- Input---     -> (Int,Int)  -- Updated state--- mac s (x,y) = x * y + s------ type ClkA = 'CLaSH.Signal.Explicit.Clk' \"A\" 100------ clkA :: 'SClock' ClkA--- clkA = 'CLaSH.Signal.Explicit.sclock'------ topEntity :: 'Signal'' ClkA (Int, Int) -> 'Signal'' ClkA Int--- topEntity = 'moore'' clkA mac id 0--- @------ >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)]--- [0,1,5,14...--- ...------ Synchronous sequential functions can be composed just like their--- combinational counterpart:------ @--- dualMac :: ('Signal'' clkA Int, 'Signal'' clkA Int)---         -> ('Signal'' clkA Int, 'Signal'' clkA Int)---         -> 'Signal'' clkA Int--- dualMac (a,b) (x,y) = s1 + s2---   where---     s1 = 'moore'' clkA mac id 0 ('CLaSH.Signal.Explicit.bundle'' clkA (a,x))---     s2 = 'moore'' clkA mac id 0 ('CLaSH.Signal.Explicit.bundle'' clkA (b,y))--- @-moore' :: SClock clk    -- ^ 'Clock' to synchronize to-       -> (s -> i -> s) -- ^ Transfer function in moore machine form:-                        -- @state -> input -> newstate@-       -> (s -> o)      -- ^ Output function in moore machine form:-                        -- @state -> output@-       -> s             -- ^ Initial state-       -> (Signal' clk i -> Signal' clk o)-       -- ^ Synchronous sequential function with input and output matching that-       -- of the moore machine-moore' clk ft fo iS = \i -> let s' = ft <$> s <*> i-                                s  = register' clk iS s'-                        in fo <$> s--{-# INLINE medvedev' #-}--- | Create a synchronous function from a combinational function describing--- a moore machine without any output logic-medvedev' :: SClock clk -> (s -> i -> s) -> s -> (Signal' clk i -> Signal' clk s)-medvedev' clk tr st = moore' clk tr id st--{-# INLINE mooreB' #-}--- | A version of 'moore'' that does automatic 'Bundle'ing------ Given a functions @t@ and @o@ of types:------ @--- __t__ :: Int -> (Bool, Int) -> Int--- __o__ :: Int -> (Int, Bool)--- @------ When we want to make compositions of @t@ and @o@ in @g@ using 'moore'', we have to--- write:------ @--- g clk a b c = (b1,b2,i2)---   where---     (i1,b1) = 'CLaSH.Signal.Explicit.unbundle'' clk (moore' clk t o 0 ('CLaSH.Signal.Explicit.bundle'' clk (a,b)))---     (i2,b2) = 'CLaSH.Signal.Explicit.unbundle'' clk (moore' clk t o 3 ('CLaSH.Signal.Explicit.bundle'' clk (i1,c)))--- @------ Using 'mooreB'' however we can write:------ @--- g clk a b c = (b1,b2,i2)---   where---     (i1,b1) = 'mooreB'' clk t o 0 (a,b)---     (i2,b2) = 'mooreB'' clk to 3 (i1,c)--- @-mooreB' :: (Bundle i, Bundle o)-        => SClock clk-        -> (s -> i -> s) -- ^ Transfer function in moore machine form:-                         -- @state -> input -> newstate@-        -> (s -> o)      -- ^ Output function in moore machine form:-                         -- @state -> output@-        -> s             -- ^ Initial state-        -> (Unbundled' clk i -> Unbundled' clk o)-        -- ^ Synchronous sequential function with input and output matching that-        -- of the moore machine-mooreB' clk ft fo iS i = unbundle (moore' clk ft fo iS (bundle i))--{-# INLINE medvedevB' #-}--- | A version of 'medvedev'' that does automatic 'Bundle'ing-medvedevB' :: (Bundle i, Bundle s) => SClock clk -> (s -> i -> s) -> s -> Unbundled' clk i -> Unbundled' clk s-medvedevB' clk tr st = mooreB' clk tr id st
− src/CLaSH/Prelude/RAM.hs 
@@ -1,157 +0,0 @@-{-|-Copyright  :  (C) 2015-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.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 Trustworthy #-}---- 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 #-}--module CLaSH.Prelude.RAM-  ( -- * RAM synchronised to the system clock-    asyncRam-  , asyncRamPow2-    -- * RAM synchronised to an arbitrary clock-  , asyncRam'-  , asyncRamPow2'-    -- * Internal-  , asyncRam#-  )-where--import Data.Maybe             (fromJust, isJust)-import GHC.TypeLits           (KnownNat)-import qualified Data.Vector  as V--import CLaSH.Promoted.Nat     (SNat (..), snatToNum, pow2SNat)-import CLaSH.Signal           (Signal)-import CLaSH.Signal.Bundle    (unbundle)-import CLaSH.Signal.Explicit  (SClock, systemClock, unsafeSynchronizer)-import CLaSH.Signal.Internal  (Signal' (..))-import CLaSH.Sized.Unsigned   (Unsigned)-import CLaSH.XException       (errorX)--{-# INLINE asyncRam #-}--- | Create a RAM with space for @n@ elements.------ * __NB__: Initial content of the RAM is 'undefined'------ Additional helpful information:------ * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a--- RAM.-asyncRam :: Enum addr-         => SNat n      -- ^ Size @n@ of the RAM-         -> Signal addr -- ^ Read address @r@-         -> Signal (Maybe (addr, a))-          -- ^ (write address @w@, value to write)-         -> Signal a    -- ^ Value of the @RAM@ at address @r@-asyncRam = asyncRam' systemClock systemClock--{-# INLINE asyncRamPow2 #-}--- | Create a RAM with space for 2^@n@ elements------ * __NB__: Initial content of the RAM is 'undefined'------ Additional helpful information:------ * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a--- RAM.-asyncRamPow2 :: KnownNat n-             => Signal (Unsigned n) -- ^ Read address @r@-             -> Signal (Maybe (Unsigned n, a))-             -- ^ (write address @w@, value to write)-             -> Signal a            -- ^ Value of the @RAM@ at address @r@-asyncRamPow2 = asyncRamPow2' systemClock systemClock--{-# INLINE asyncRamPow2' #-}--- | Create a RAM with space for 2^@n@ elements------ * __NB__: Initial content of the RAM is 'undefined'------ Additional helpful information:------ * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a--- RAM.-asyncRamPow2' :: forall wclk rclk n a .-                 KnownNat n-              => SClock wclk               -- ^ 'Clock' to which to synchronise-                                           -- the write port of the RAM-              -> SClock rclk               -- ^ 'Clock' to which the read-                                           -- address signal, @r@, is-                                           -- synchronised-              -> Signal' rclk (Unsigned n) -- ^ Read address @r@-              -> Signal' wclk (Maybe (Unsigned n, a))-              -- ^ (write address @w@, value to write)-                  -> Signal' rclk a-              -- ^ Value of the @RAM@ at address @r@-asyncRamPow2' wclk rclk = asyncRam' wclk rclk (pow2SNat (SNat @ n))--{-# INLINE asyncRam' #-}--- | Create a RAM with space for @n@ elements------ * __NB__: Initial content of the RAM is 'undefined'------ Additional helpful information:------ * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a--- RAM.-asyncRam' :: Enum addr-          => SClock wclk       -- ^ 'Clock' to which to synchronise the write-                               -- port of the RAM-          -> SClock rclk       -- ^ 'Clock' to which the read address signal,-                               -- @r@, is synchronised-          -> SNat n            -- ^ Size @n@ of the RAM-          -> Signal' rclk addr -- ^ Read address @r@-          -> Signal' wclk (Maybe (addr, a))-          -- ^ (write address @w@, value to write)-          -> Signal' rclk a    -- ^ Value of the @RAM@ at address @r@-asyncRam' wclk rclk sz rd wrM =-  let en       = isJust <$> wrM-      (wr,din) = unbundle (fromJust <$> wrM)-  in  asyncRam# wclk rclk sz (fromEnum <$> rd) en (fromEnum <$> wr) din---- | RAM primitive-asyncRam# :: SClock wclk       -- ^ 'Clock' to which to synchronise the write-                               -- port of the RAM-          -> SClock rclk       -- ^ 'Clock' to which the read address signal,-                               -- @r@, is synchronised-          -> SNat n            -- ^ Size @n@ of the RAM-          -> Signal' rclk Int  -- ^ Read address @r@-          -> Signal' wclk Bool -- ^ Write enable-          -> Signal' wclk Int  -- ^ Write address @w@-          -> Signal' wclk a    -- ^ Value to write (at address @w@)-          -> Signal' rclk a    -- ^ Value of the @RAM@ at address @r@-asyncRam# wclk rclk sz rd en wr din = unsafeSynchronizer wclk rclk dout-  where-    rd'  = unsafeSynchronizer rclk wclk rd-    ramI = V.replicate (snatToNum sz) (errorX "asyncRam#: initial value undefined")-    dout = go ramI rd' en wr din--    go :: V.Vector a -> Signal' wclk Int -> Signal' wclk Bool-       -> Signal' wclk Int -> Signal' wclk a -> Signal' wclk a-    go !ram (r :- rs) (e :- es) (w :- ws) (d :- ds) =-      let ram' = upd ram e w d-          o    = ram V.! r-      in  o :- go ram' rs es ws ds--    upd ram True  addr d = ram V.// [(addr,d)]-    upd ram False _    _ = ram-{-# NOINLINE asyncRam# #-}
− src/CLaSH/Prelude/ROM.hs 
@@ -1,176 +0,0 @@-{-|-Copyright  :  (C) 2015-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--ROMs--}--{-# LANGUAGE DataKinds     #-}-{-# LANGUAGE MagicHash     #-}-{-# LANGUAGE TypeOperators #-}--{-# LANGUAGE Safe #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Prelude.ROM-  ( -- * Asynchronous ROM-    asyncRom-  , asyncRomPow2-    -- * Synchronous ROM synchronised to the system clock-  , rom-  , romPow2-    -- * Synchronous ROM synchronised to an arbitrary clock-  , rom'-  , romPow2'-    -- * Internal-  , asyncRom#-  , rom#-  )-where--import Data.Array             ((!),listArray)-import GHC.TypeLits           (KnownNat, type (^))-import Prelude hiding         (length)--import CLaSH.Signal           (Signal)-import CLaSH.Signal.Explicit  (Signal', SClock, systemClock)-import CLaSH.Sized.Unsigned   (Unsigned)-import CLaSH.Signal.Explicit  (register')-import CLaSH.Sized.Vector     (Vec, length, toList)-import CLaSH.XException       (errorX)--{-# INLINE asyncRom #-}--- | An asynchronous/combinational ROM with space for @n@ elements------ Additional helpful information:------ * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams"--- for ideas on how to use ROMs and RAMs-asyncRom :: (KnownNat n, Enum addr)-         => Vec n a -- ^ ROM content-                    ---                    -- __NB:__ must be a constant-         -> addr    -- ^ Read address @rd@-         -> a       -- ^ The value of the ROM at address @rd@-asyncRom content rd = asyncRom# content (fromEnum rd)--{-# INLINE asyncRomPow2 #-}--- | An asynchronous/combinational ROM with space for 2^@n@ elements------ Additional helpful information:------ * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams"--- for ideas on how to use ROMs and RAMs-asyncRomPow2 :: KnownNat n-             => Vec (2^n) a -- ^ ROM content-                            ---                            -- __NB:__ must be a constant-             -> Unsigned n  -- ^ Read address @rd@-             -> a           -- ^ The value of the ROM at address @rd@-asyncRomPow2 = asyncRom--{-# NOINLINE asyncRom# #-}--- | asyncROM primitive-asyncRom# :: KnownNat n-          => Vec n a  -- ^ ROM content-                      ---                      -- __NB:__ must be a constant-          -> Int      -- ^ Read address @rd@-          -> a        -- ^ The value of the ROM at address @rd@-asyncRom# content rd = arr ! rd-  where-    szI = length content-    arr = listArray (0,szI-1) (toList content)--{-# INLINE rom #-}--- | 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'------ Additional helpful information:------ * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams"--- for ideas on how to use ROMs and RAMs-rom :: (KnownNat n, KnownNat m)-    => Vec n a               -- ^ ROM content-                             ---                             -- __NB:__ must be a constant-    -> Signal (Unsigned m)   -- ^ Read address @rd@-    -> Signal a              -- ^ The value of the ROM at address @rd@-rom = rom' systemClock--{-# INLINE romPow2 #-}--- | 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'------ Additional helpful information:------ * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams"--- for ideas on how to use ROMs and RAMs-romPow2 :: KnownNat n-        => Vec (2^n) a         -- ^ ROM content-                               ---                               -- __NB:__ must be a constant-        -> Signal (Unsigned n) -- ^ Read address @rd@-        -> Signal a            -- ^ The value of the ROM at address @rd@-romPow2 = romPow2' systemClock--{-# INLINE romPow2' #-}--- | 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'------ Additional helpful information:------ * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams"--- for ideas on how to use ROMs and RAMs-romPow2' :: KnownNat n-         => SClock clk               -- ^ 'Clock' to synchronize to-         -> Vec (2^n) a              -- ^ ROM content-                                     ---                                     -- __NB:__ must be a constant-         -> Signal' clk (Unsigned n) -- ^ Read address @rd@-         -> Signal' clk a            -- ^ The value of the ROM at address @rd@-romPow2' = rom'--{-# INLINE rom' #-}--- | 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'------ Additional helpful information:------ * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams"--- for ideas on how to use ROMs and RAMs-rom' :: (KnownNat n, Enum addr)-     => SClock clk       -- ^ 'Clock' to synchronize to-     -> Vec n a          -- ^ ROM content-                         ---                         -- __NB:__ must be a constant-     -> Signal' clk addr -- ^ Read address @rd@-     -> Signal' clk a-     -- ^ The value of the ROM at address @rd@ from the previous clock cycle-rom' clk content rd = rom# clk content (fromEnum <$> rd)--{-# NOINLINE rom# #-}--- | ROM primitive-rom# :: KnownNat n-     => SClock clk      -- ^ 'Clock' to synchronize to-     -> Vec n a         -- ^ ROM content-                        ---                        -- __NB:__ must be a constant-     -> Signal' clk Int -- ^ Read address @rd@-     -> Signal' clk a-     -- ^ The value of the ROM at address @rd@ from the previous clock cycle-rom# clk content rd = register' clk (errorX "rom#: initial value undefined") ((arr !) <$> rd)-  where-    szI = length content-    arr = listArray (0,szI-1) (toList content)
− src/CLaSH/Prelude/ROM/File.hs 
@@ -1,382 +0,0 @@-{-|-Copyright  :  (C) 2015-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--= Initialising a ROM with a data file #usingromfiles#--ROMs initialised with a data file. The BNF grammar for this data file is simple:--@-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-@7@ to @13@ looks like:--@-000000111-000001000-000001001-000001010-000001011-000001100-000001101-@--We can instantiate a synchronous ROM using the content of the above file like-so:--@-topEntity :: Signal (Unsigned 3) -> Signal (Unsigned 9)-topEntity rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'romFile' d7 \"memory.bin\" rd-@--And see that it works as expected:--@-__>>> import qualified Data.List as L__-__>>> L.tail $ sampleN 4 $ topEntity (fromList [3..5])__-[10,11,12]-@--However, we can also interpret the same data as a tuple of a 6-bit unsigned-number, and a 3-bit signed number:--@-topEntity2 :: Signal (Unsigned 3) -> Signal (Unsigned 6,Signed 3)-topEntity2 rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'romFile' d7 \"memory.bin\" rd-@--And then we would see:--@-__>>> import qualified Data.List as L__-__>>> L.tail $ sampleN 4 $ topEntity2 (fromList [3..5])__-[(1,2),(1,3)(1,-4)]-@--}--{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE TypeOperators       #-}--{-# LANGUAGE Unsafe #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Prelude.ROM.File-  ( -- * Asynchronous ROM-    asyncRomFile-  , asyncRomFilePow2-    -- * Synchronous ROM synchronised to the system clock-  , romFile-  , romFilePow2-    -- * Synchronous ROM synchronised to an arbitrary clock-  , romFile'-  , romFilePow2'-    -- * Internal-  , asyncRomFile#-  , romFile#-  )-where--import Data.Array                  (listArray,(!))-import GHC.TypeLits                (KnownNat)-import System.IO.Unsafe            (unsafePerformIO)--import CLaSH.Prelude.BlockRam.File (initMem)-import CLaSH.Promoted.Nat          (SNat (..), pow2SNat, snatToNum)-import CLaSH.Sized.BitVector       (BitVector)-import CLaSH.Signal                (Signal)-import CLaSH.Signal.Explicit       (Signal', SClock, register', systemClock)-import CLaSH.Sized.Unsigned        (Unsigned)-import CLaSH.XException            (errorX)--{-# INLINE asyncRomFile #-}--- | An asynchronous/combinational ROM with space for @n@ elements------ * __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      |---     ===============+==========+==========+===============+---     @------ Additional helpful information:------ * See "CLaSH.Prelude.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.--- * When you notice that 'asyncRomFile' is significantly slowing down your--- simulation, give it a /monomorphic/ type signature. So instead of leaving--- the type to be inferred:------     @---     myRomData = asyncRomFile d512 "memory.bin"---     @------     or giving it a /polymorphic/ type signature:------     @---     myRomData :: Enum addr => addr -> BitVector 16---     myRomData = asyncRomFile d512 "memory.bin"---     @------     you __should__ give it a /monomorphic/ type signature:------     @---     myRomData :: Unsigned 9 -> BitVector 16---     myRomData = asyncRomFile d512 "memory.bin"---     @-asyncRomFile :: (KnownNat m, Enum addr)-             => SNat n      -- ^ Size of the ROM-             -> FilePath    -- ^ File describing the content of the ROM-             -> addr        -- ^ Read address @rd@-             -> BitVector m -- ^ The value of the ROM at address @rd@-asyncRomFile sz file = asyncRomFile# sz file . fromEnum--- Leave 'asyncRom' eta-reduced, see Note [Eta-reduction and unsafePerformIO initMem]---- Note [Eta-reduction and unsafePerformIO initMem]------ The 'initMem' function initializes a @[BitVector n]@ from file. Ideally,--- we want this IO action to happen only once. When we call 'unsafePerformIO'--- on @initMem file@, it becomes a thunk in that function, so is hence evaluated--- only once. However, me must ensure that any code calling using of the--- @unsafePerformIO (initMem file)@ thunk also becomes a thunk. We do this by--- eta-reducing function where needed so that a thunk is returned.------ For example, instead of writing:------ > asyncRomFile# sz file rd = (content ! rd)--- >   where--- >     mem = unsafePerformIO (initMem file)--- >     content = listArray (0,szI-1) mem--- >     szI     = snatToNum sz------ We write:------ > asyncRomFile# sz file = (content !)--- >   where--- >     mem     = unsafePerformIO (initMem file)--- >     content = listArray (0,szI-1) mem--- >     szI     = snatToNum sz------ Where instead of returning the BitVector defined by @(content ! rd)@, we--- return the function (thunk) @(content !)@.--{-# INLINE asyncRomFilePow2 #-}--- | An asynchronous/combinational ROM with space for 2^@n@ elements------ * __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      |---     ===============+==========+==========+===============+---     @------ Additional helpful information:------ * See "CLaSH.Prelude.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.--- * When you notice that 'asyncRomFilePow2' is significantly slowing down your--- simulation, give it a /monomorphic/ type signature. So instead of leaving the--- type to be inferred:------     @---     myRomData = asyncRomFilePow2 "memory.bin"---     @------     you __should__ give it a /monomorphic/ type signature:------     @---     myRomData :: Unsigned 9 -> BitVector 16---     myRomData = asyncRomFilePow2 "memory.bin"---     @-asyncRomFilePow2 :: forall n m . (KnownNat m, KnownNat n)-                 => FilePath    -- ^ File describing the content of the ROM-                 -> Unsigned n  -- ^ Read address @rd@-                 -> BitVector m -- ^ The value of the ROM at address @rd@-asyncRomFilePow2 = asyncRomFile (pow2SNat (SNat @ n))--{-# NOINLINE asyncRomFile# #-}--- | asyncROMFile primitive-asyncRomFile# :: KnownNat m-              => SNat n       -- ^ Size of the ROM-              -> FilePath     -- ^ File describing the content of the ROM-              -> Int          -- ^ Read address @rd@-              -> BitVector m  -- ^ The value of the ROM at address @rd@-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--{-# INLINE romFile #-}--- | 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__: 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      |---     ===============+==========+==========+===============+---     @------ Additional helpful information:------ * See "CLaSH.Prelude.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.-romFile :: (KnownNat m, KnownNat n)-        => SNat n               -- ^ Size of the ROM-        -> FilePath             -- ^ File describing the content of the ROM-        -> Signal (Unsigned n)  -- ^ Read address @rd@-        -> Signal (BitVector m)-        -- ^ The value of the ROM at address @rd@ from the previous clock cycle-romFile = romFile' systemClock--{-# INLINE romFilePow2 #-}--- | 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__: 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      |---     ===============+==========+==========+===============+---     @------ Additional helpful information:------ * See "CLaSH.Prelude.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.-romFilePow2 :: forall n m . (KnownNat m, KnownNat n)-            => FilePath             -- ^ File describing the content of the ROM-            -> Signal (Unsigned n)  -- ^ Read address @rd@-            -> Signal (BitVector m)-            -- ^ The value of the ROM at address @rd@ from the previous clock cycle-romFilePow2 = romFilePow2' systemClock--{-# INLINE romFilePow2' #-}--- | 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__: 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      |---     ===============+==========+==========+===============+---     @------ Additional helpful information:------ * See "CLaSH.Prelude.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.-romFilePow2' :: forall clk n m . (KnownNat m, KnownNat n)-             => SClock clk                -- ^ 'Clock' to synchronize to-             -> FilePath                  -- ^ File describing the content of-                                          -- the ROM-             -> Signal' clk (Unsigned n)  -- ^ Read address @rd@-             -> Signal' clk (BitVector m)-             -- ^ The value of the ROM at address @rd@ from the previous clock-             -- cycle-romFilePow2' clk = romFile' clk (pow2SNat (SNat @ n))--{-# INLINE romFile' #-}--- | 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__: 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      |---     ===============+==========+==========+===============+---     @------ Additional helpful information:------ * See "CLaSH.Prelude.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.-romFile' :: (KnownNat m, Enum addr)-         => SClock clk                -- ^ 'Clock' to synchronize to-         -> SNat n                    -- ^ Size of the ROM-         -> FilePath                  -- ^ File describing the content of the-                                      -- ROM-         -> Signal' clk addr          -- ^ Read address @rd@-         -> Signal' clk (BitVector m)-         -- ^ The value of the ROM at address @rd@ from the previous clock cycle-romFile' clk sz file rd = romFile# clk sz file (fromEnum <$> rd)--{-# NOINLINE romFile# #-}--- | romFile primitive-romFile# :: KnownNat m-         => SClock clk                -- ^ 'Clock' to synchronize to-         -> SNat n                    -- ^ Size of the ROM-         -> FilePath                  -- ^ File describing the content of the-                                      -- ROM-         -> Signal' clk Int           -- ^ Read address @rd@-         -> Signal' clk (BitVector m)-         -- ^ The value of the ROM at address @rd@ from the previous clock cycle-romFile# clk sz file rd = register' clk (errorX "romFile#: initial value undefined") ((content !) <$> rd)-  where-    mem     = unsafePerformIO (initMem file)-    content = listArray (0,szI-1) mem-    szI     = snatToNum sz
− src/CLaSH/Prelude/Safe.hs 
@@ -1,246 +0,0 @@-{-|-  Copyright   :  (C) 2013-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  __This is the <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/safe-haskell.html Safe> API only of "CLaSH.Prelude"__--  CλaSH (pronounced ‘clash’) is a functional hardware description language that-  borrows both its syntax and semantics from the functional programming language-  Haskell. The merits of using a functional language to describe hardware comes-  from the fact that combinational circuits can be directly modeled as-  mathematical functions and that functional languages lend themselves very well-  at describing and (de-)composing mathematical functions.--  This package provides:--  * Prelude library containing datatypes and functions for circuit design--  To use the library:--  * Import "CLaSH.Prelude"-  * Additionally import "CLaSH.Prelude.Explicit" if you want to design-    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".--}--{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE TypeOperators       #-}--{-# LANGUAGE Safe #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Prelude.Safe-  ( -- * Creating synchronous sequential circuits-    mealy-  , mealyB-  , (<^>)-  , moore-  , mooreB-  , registerB-    -- * ROMs-  , asyncRom-  , asyncRomPow2-  , rom-  , romPow2-    -- * RAM primitives with a combinational read port-  , asyncRam-  , asyncRamPow2-    -- * BlockRAM primitives-  , blockRam-  , blockRamPow2-    -- * BlockRAM read/write conflict resolution-  , readNew-  , readNew'-    -- * Utility functions-  , isRising-  , isFalling-  , riseEvery-  , oscillate-    -- * Exported modules-    -- ** 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-  , module CLaSH.Sized.Index-    -- *** Fixed point numbers-  , module CLaSH.Sized.Fixed-    -- *** Fixed size vectors-  , module CLaSH.Sized.Vector-    -- *** Perfect depth trees-  , module CLaSH.Sized.RTree-    -- ** Annotations-  , module CLaSH.Annotations.TopEntity-    -- ** Type-level natural numbers-  , module GHC.TypeLits-  , module GHC.TypeLits.Extra-  , module CLaSH.Promoted.Nat-  , module CLaSH.Promoted.Nat.Literals-  , module CLaSH.Promoted.Nat.TH-    -- ** Type classes-    -- *** CLaSH-  , module CLaSH.Class.BitPack-  , module CLaSH.Class.Num-  , module CLaSH.Class.Resize-    -- *** Other-  , module Control.Applicative-  , module Data.Bits-      -- ** Exceptions-  , module CLaSH.XException-  , undefined-    -- ** Named types-  , module CLaSH.NamedTypes-    -- ** Haskell Prelude-    -- $hiding-  , module Prelude-  )-where--import Control.Applicative-import Data.Bits-import GHC.Stack-import GHC.TypeLits-import GHC.TypeLits.Extra-import Prelude                     hiding ((++), (!!), 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,-                                           undefined)--import CLaSH.Annotations.TopEntity-import CLaSH.Class.BitPack-import CLaSH.Class.Num-import CLaSH.Class.Resize-import CLaSH.NamedTypes-import CLaSH.Prelude.BitIndex-import CLaSH.Prelude.BitReduction-import CLaSH.Prelude.BlockRam      (blockRam, blockRamPow2, readNew, readNew')-import CLaSH.Prelude.Explicit.Safe (registerB', isRising', isFalling',-                                    oscillate', riseEvery')-import CLaSH.Prelude.Mealy         (mealy, mealyB, (<^>))-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.Promoted.Nat-import CLaSH.Promoted.Nat.TH-import CLaSH.Promoted.Nat.Literals-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-import CLaSH.Signal-import CLaSH.Signal.Delayed-import CLaSH.Signal.Explicit       (systemClock)-import CLaSH.XException--{- $setup->>> 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".--}--{-# INLINE registerB #-}--- | Create a 'register' function for product-type like signals (e.g. '(Signal a, Signal b)')------ > rP :: (Signal Int,Signal Int) -> (Signal Int, Signal Int)--- > rP = registerB (8,8)------ >>> simulateB rP [(1,1),(2,2),(3,3)] :: [(Int,Int)]--- [(8,8),(1,1),(2,2),(3,3)...--- ...-registerB :: Bundle a => a -> Unbundled a -> Unbundled a-registerB = registerB' systemClock-infixr 3 `registerB`--{-# INLINE isRising #-}--- | Give a pulse when the 'Signal' goes from 'minBound' to 'maxBound'-isRising :: (Bounded a, Eq a)-         => a -- ^ Starting value-         -> Signal a-         -> Signal Bool-isRising = isRising' systemClock--{-# INLINE isFalling #-}--- | Give a pulse when the 'Signal' goes from 'maxBound' to 'minBound'-isFalling :: (Bounded a, Eq a)-          => a -- ^ Starting value-          -> Signal a-          -> Signal Bool-isFalling = isFalling' systemClock--{-# INLINE riseEvery #-}--- | Give a pulse every @n@ clock cycles. This is a useful helper function when--- combined with functions like @'CLaSH.Signal.regEn'@ or @'CLaSH.Signal.mux'@,--- in order to delay a register by a known amount.------ To be precise: the given signal will be @'False'@ for the next @n-1@ cycles,--- followed by a single @'True'@ value:------ >>> Prelude.last (sampleN 1024 (riseEvery d1024)) == True--- True--- >>> Prelude.or (sampleN 1023 (riseEvery d1024)) == False--- True------ For example, to update a counter once every 10 million cycles:------ @--- counter = 'CLaSH.Signal.regEn' 0 ('riseEvery' ('SNat' :: 'SNat' 10000000)) (counter + 1)--- @-riseEvery :: KnownNat n => SNat n -> Signal Bool-riseEvery = riseEvery' systemClock--{-# INLINE oscillate #-}--- | Oscillate a @'Bool'@ for a given number of cycles. This is a convenient--- function when combined with something like @'regEn'@, as it allows you to--- easily hold a register value for a given number of cycles. The input @'Bool'@--- determines what the initial value is.------ To oscillate on an interval of 5 cycles:------ >>> sampleN 10 (oscillate False d5)--- [False,False,False,False,False,True,True,True,True,True]------ To oscillate between @'True'@ and @'False'@:------ >>> sampleN 10 (oscillate False d1)--- [False,True,False,True,False,True,False,True,False,True]------ An alternative definition for the above could be:------ >>> let osc' = register False (not <$> osc')--- >>> let sample' = sampleN 200--- >>> sample' (oscillate False d1) == sample' osc'--- True-oscillate :: KnownNat n => Bool -> SNat n -> Signal Bool-oscillate = oscillate' systemClock--undefined :: HasCallStack => a-undefined = errorX "undefined"
− src/CLaSH/Prelude/Synchronizer.hs 
@@ -1,176 +0,0 @@-{-|-Copyright   :  (C) 2015-2016, University of Twente-License     :  BSD2 (see the file LICENSE)-Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--Synchronizer circuits for safe clock domain crossings--}--{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE AllowAmbiguousTypes   #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}-{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Prelude.Synchronizer-  ( -- * Bit-synchronizers-    dualFlipFlopSynchronizer-    -- * Word-synchronizers-  , asyncFIFOSynchronizer-  )-where--import Control.Applicative         (liftA2)-import Data.Bits                   (complement, shiftR, xor)-import Data.Constraint             ((:-)(..), Dict (..))-#if MIN_VERSION_constraints(0,9,0)-import Data.Constraint.Nat         (leTrans)-#else-import Unsafe.Coerce-#endif-import Data.Maybe                  (isJust)-import GHC.TypeLits                (type (+), type (-), type (<=))--import CLaSH.Class.BitPack         (boolToBV)-import CLaSH.Class.Resize          (truncateB)-import CLaSH.Prelude.BitIndex      (slice)-import CLaSH.Prelude.Mealy         (mealyB')-import CLaSH.Prelude.RAM           (asyncRam')-import CLaSH.Promoted.Nat          (SNat (..), pow2SNat)-import CLaSH.Promoted.Nat.Literals (d0)-import CLaSH.Signal                (mux)-import CLaSH.Signal.Explicit       (Signal', SClock, register',-                                    unsafeSynchronizer)-import CLaSH.Sized.BitVector       (BitVector, (++#))---- * Dual flip-flop synchronizer---- | Synchroniser based on two sequentially connected flip-flops.------  * __NB__: This synchroniser can be used for __bit__-synchronization.------  * __NB__: Although this synchroniser does reduce metastability, it does---  not guarantee the proper synchronisation 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__-synchronisation use---      'asyncFIFOSynchronizer'.-dualFlipFlopSynchronizer :: SClock clk1    -- ^ 'Clock' to which the incoming-                                           -- data is synchronised-                         -> SClock clk2    -- ^ 'Clock' to which the outgoing-                                           -- data is synchronised-                         -> a              -- ^ Initial value of the two-                                           -- synchronisation registers-                         -> Signal' clk1 a -- ^ Incoming data-                         -> Signal' clk2 a -- ^ Outgoing, synchronised, data-dualFlipFlopSynchronizer clk1 clk2 i = register' clk2 i-                                     . register' clk2 i-                                     . unsafeSynchronizer clk1 clk2---- * Asynchronous FIFO synchronizer--fifoMem ::-     SClock wclk-  -> SClock rclk-  -> SNat addrSize-  -> Signal' wclk Bool-  -> Signal' rclk (BitVector addrSize)-  -> Signal' wclk (Maybe (BitVector addrSize, a))-  -> Signal' rclk a-fifoMem wclk rclk addrSize@SNat full raddr writeM =-  asyncRam' wclk rclk-            (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 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 full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1: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)---- | Synchroniser 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 synchroniser can be used for __word__-synchronization.-asyncFIFOSynchronizer-  :: (2 <= addrSize)-  => SNat addrSize           -- ^ Size of the internally used addresses, the-                             -- FIFO contains @2^addrSize@ elements.-  -> SClock wclk             -- ^ 'Clock' to which the write port is synchronised-  -> SClock rclk             -- ^ 'Clock' to which the read port is synchronised-  -> Signal' rclk Bool       -- ^ Read request-  -> Signal' wclk (Maybe a)  -- ^ Element to insert-  -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool)-  -- ^ (Oldest element in the FIFO, @empty@ flag, @full@ flag)-asyncFIFOSynchronizer addrSize@SNat wclk rclk rinc wdataM = (rdata,rempty,wfull)-  where-    s_rptr = dualFlipFlopSynchronizer rclk wclk 0 rptr-    s_wptr = dualFlipFlopSynchronizer wclk rclk 0 wptr--    rdata = fifoMem wclk rclk addrSize wfull raddr-              (liftA2 (,) <$> (pure <$> waddr) <*> wdataM)--    (rempty,raddr,rptr) = mealyB' rclk (ptrCompareT addrSize (==)) (0,0,True)-                                  (s_wptr,rinc)--    (wfull,waddr,wptr)  = mealyB' wclk (ptrCompareT addrSize (isFull addrSize))-                                  (0,0,False) (s_rptr,isJust <$> wdataM)--#if !MIN_VERSION_constraints(0,9,0)-axiom :: forall a b . Dict (a ~ b)-axiom = unsafeCoerce (Dict :: Dict (a ~ a))--axiomLe :: forall a b. Dict (a <= b)-axiomLe = axiom--leTrans :: forall a b c. (b <= c, a <= b) :- (a <= c)-leTrans = Sub (axiomLe @a @c)-#endif
− src/CLaSH/Prelude/Testbench.hs 
@@ -1,246 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE ScopedTypeVariables #-}--{-# LANGUAGE Unsafe #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Prelude.Testbench-  ( -- * Testbench functions for circuits synchronised to the system slock-    assert-  , stimuliGenerator-  , outputVerifier-    -- * Testbench functions for circuits synchronised to arbitrary clocks-  , assert'-  , stimuliGenerator'-  , outputVerifier'-  )-where--import Debug.Trace           (trace)-import GHC.TypeLits          (KnownNat)-import Prelude               hiding ((!!), length)--import CLaSH.Signal          (Signal, fromList)-import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock)-import CLaSH.Signal.Bundle   (unbundle)-import CLaSH.Sized.Index     (Index)-import CLaSH.Sized.Vector    (Vec, (!!), length)--{- $setup->>> :set -XTemplateHaskell->>> :set -XDataKinds->>> import CLaSH.Prelude->>> let testInput = stimuliGenerator $(listToVecTH [(1::Int),3..21])->>> let expectedOutput = outputVerifier $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int]))->>> import CLaSH.Prelude.Explicit->>> type ClkA = Clk "A" 100->>> let clkA = sclock :: SClock ClkA->>> let testInput' = stimuliGenerator' clkA $(listToVecTH [(1::Int),3..21])->>> let expectedOutput' = outputVerifier' clkA $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int]))--}--{-# INLINE assert #-}--- | Compares the first two 'Signal's for equality and logs a warning when they--- are not equal. The second 'Signal' is considered the expected value. This--- function simply returns the third 'Signal' unaltered as its result. This--- function is used by 'outputVerifier'.--------- __NB__: This function /can/ be used in synthesizable designs.-assert :: (Eq a,Show a)-       => String   -- ^ Additional message-       -> Signal a -- ^ Checked value-       -> Signal a -- ^ Expected value-       -> Signal b -- ^ Return value-       -> Signal b-assert = assert' systemClock--{-# INLINE stimuliGenerator #-}--- | To be used as one of the functions to create the \"magical\" 'testInput'--- value, which the CλaSH compiler looks for to create the stimulus generator--- for the generated VHDL testbench.------ Example:------ @--- testInput :: 'Signal' Int--- 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]-stimuliGenerator :: forall l a . KnownNat l-                 => Vec l a  -- ^ Samples to generate-                 -> Signal a -- ^ Signal of given samples-stimuliGenerator = stimuliGenerator' systemClock--{-# INLINE outputVerifier #-}--- | To be used as one of the functions to generate the \"magical\" 'expectedOutput'--- function, which the CλaSH compiler looks for to create the signal verifier--- for the generated VHDL testbench.------ Example:------ @--- expectedOutput :: 'Signal' Int -> 'Signal' Bool--- expectedOutput = 'outputVerifier' $('CLaSH.Sized.Vector.listToVecTH' ([70,99,2,3,4,5,7,8,9,10]::[Int]))--- @------ >>> import qualified Data.List as List--- >>> sampleN 12 (expectedOutput (fromList ([0..10] List.++ [10,10,10])))--- <BLANKLINE>--- cycle(system1000): 0, outputVerifier--- expected value: 70, not equal to actual value: 0--- [False--- cycle(system1000): 1, outputVerifier--- expected value: 99, not equal to actual value: 1--- ,False,False,False,False,False--- cycle(system1000): 6, outputVerifier--- expected value: 7, not equal to actual value: 6--- ,False--- cycle(system1000): 7, outputVerifier--- expected value: 8, not equal to actual value: 7--- ,False--- cycle(system1000): 8, outputVerifier--- expected value: 9, not equal to actual value: 8--- ,False--- cycle(system1000): 9, outputVerifier--- expected value: 10, not equal to actual value: 9--- ,False,True,True]-outputVerifier :: forall l a . (KnownNat l, Eq a, Show a)-               => Vec l a     -- ^ Samples to compare with-               -> Signal a    -- ^ Signal to verify-               -> Signal Bool -- ^ Indicator that all samples are verified-outputVerifier = outputVerifier' systemClock--{-# NOINLINE assert' #-}--- | Compares the first two 'Signal''s for equality and logs a warning when they--- are not equal. The second 'Signal'' is considered the expected value. This--- function simply returns the third 'Signal'' unaltered as its result. This--- function is used by 'outputVerifier''.--------- __NB__: This function /can/ be used in synthesizable designs.-assert' :: (Eq a,Show a)-        => SClock t-        -> String      -- ^ Additional message-        -> Signal' t a -- ^ Checked value-        -> Signal' t a -- ^ Expected value-        -> Signal' t b -- ^ Return value-        -> Signal' t b-assert' clk msg checked expected returned =-  (\c e cnt r ->-      if c == e then r-                else trace (concat [ "\ncycle(" ++ show clk ++ "): "-                                   , show cnt-                                   , ", "-                                   , msg-                                   , "\nexpected value: "-                                   , show e-                                   , ", not equal to actual value: "-                                   , show c-                                   ]) r)-  <$> checked <*> expected <*> fromList [(0::Integer)..] <*> returned--{-# INLINABLE stimuliGenerator' #-}--- | To be used as one of the functions to create the \"magical\" 'testInput'--- value, which the CλaSH compiler looks for to create the stimulus generator--- for the generated VHDL testbench.------ Example:------ @--- type ClkA = 'CLaSH.Signal.Explicit.Clk' \"A\" 100------ clkA :: 'SClock' ClkA--- clkA = 'CLaSH.Signal.Explicit.sclock'------ testInput' :: 'Signal'' clkA Int--- testInput' = 'stimuliGenerator'' clkA $('CLaSH.Sized.Vector.listToVecTH' [(1::Int),3..21])--- @------ >>> sampleN 13 testInput'--- [1,3,5,7,9,11,13,15,17,19,21,21,21]-stimuliGenerator' :: forall l clk a . KnownNat l-                  => SClock clk     -- ^ Clock to which to synchronize the-                                    -- output signal-                  -> Vec l a        -- ^ Samples to generate-                  -> Signal' clk a  -- ^ Signal of given samples-stimuliGenerator' clk samples =-    let (r,o) = unbundle (genT <$> register' clk 0 r)-    in  o-  where-    genT :: Index l -> (Index l,a)-    genT s = (s',samples !! s)-      where-        maxI = toEnum (length samples - 1)--        s' = if s < maxI-                then s + 1-                else s--{-# INLINABLE outputVerifier' #-}--- | To be used as one of the functions to generate the \"magical\" 'expectedOutput'--- function, which the CλaSH compiler looks for to create the signal verifier--- for the generated VHDL testbench.------ Example:------ @--- type ClkA = 'CLaSH.Signal.Explicit.Clk' \"A\" 100------ clkA :: 'SClock' ClkA--- clkA = 'CLaSH.Signal.Explicit.sclock'------ expectedOutput' :: 'Signal'' ClkA Int -> 'Signal'' ClkA Bool--- expectedOutput' = 'outputVerifier'' clkA $('CLaSH.Sized.Vector.listToVecTH' ([70,99,2,3,4,5,7,8,9,10]::[Int]))--- @------ >>> import qualified Data.List as List--- >>> sampleN 12 (expectedOutput' (fromList ([0..10] List.++ [10,10,10])))--- <BLANKLINE>--- cycle(A100): 0, outputVerifier--- expected value: 70, not equal to actual value: 0--- [False--- cycle(A100): 1, outputVerifier--- expected value: 99, not equal to actual value: 1--- ,False,False,False,False,False--- cycle(A100): 6, outputVerifier--- expected value: 7, not equal to actual value: 6--- ,False--- cycle(A100): 7, outputVerifier--- expected value: 8, not equal to actual value: 7--- ,False--- cycle(A100): 8, outputVerifier--- expected value: 9, not equal to actual value: 8--- ,False--- cycle(A100): 9, outputVerifier--- expected value: 10, not equal to actual value: 9--- ,False,True,True]-outputVerifier' :: forall l clk a . (KnownNat l, Eq a, Show a)-                => SClock clk       -- ^ Clock to which the input signal is-                                    -- synchronized to-                -> Vec l a          -- ^ Samples to compare with-                -> Signal' clk a    -- ^ Signal to verify-                -> Signal' clk Bool -- ^ Indicator that all samples are verified-outputVerifier' clk samples i =-    let (s,o) = unbundle (genT <$> register' clk 0 s)-        (e,f) = unbundle o-    in  assert' clk "outputVerifier" i e (register' clk False 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
− src/CLaSH/Promoted/Nat.hs 
@@ -1,422 +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 GADTs          #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash      #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators  #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Promoted.Nat-  ( -- * Singleton natural numbers-    -- ** Data type-    SNat (..)-    -- ** Construction-  , snatProxy-  , withSNat-  , snat-    -- ** Conversion-  , snatToInteger, snatToNum-    -- ** Arithmetic-  , addSNat, mulSNat, powSNat-    -- *** Partial-  , subSNat, divSNat, modSNat, flogBaseSNat, clogBaseSNat, logBaseSNat-    -- *** Specialised-  , pow2SNat-    -- * Unary/Peano-encoded natural numbers-    -- ** Data type-  , UNat (..)-    -- ** Construction-  , toUNat-    -- ** Conversion-  , fromUNat-    -- ** Arithmetic-  , addUNat, mulUNat, powUNat-    -- *** Partial-  , predUNat, subUNat-    -- * Base-2 encoded natural numbers-    -- ** Data type-  , BNat (..)-    -- ** Construction-  , toBNat-    -- ** Conversion-  , fromBNat-    -- ** Pretty printing base-2 encoded natural numbers-  , showBNat-    -- ** Arithmetic-  , succBNat, addBNat, mulBNat, powBNat-    -- *** Partial-  , predBNat, div2BNat, div2Sub1BNat, log2BNat-    -- ** Normalisation-  , stripZeros-  )-where--import GHC.TypeLits       (KnownNat, Nat, type (+), type (-), type (*),-                           type (^), type (<=), natVal)-import GHC.TypeLits.Extra (CLog, FLog, Div, Log, Mod)-import Language.Haskell.TH (appT, conT, litT, numTyLit, sigE)-import Language.Haskell.TH.Syntax (Lift (..))-import Unsafe.Coerce      (unsafeCoerce)-import CLaSH.XException   (ShowX (..), showsPrecXWith)--{- $setup->>> :set -XBinaryLiterals->>> import CLaSH.Promoted.Nat.Literals (d789)--}---- | 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---   'SNat' literals-data SNat (n :: Nat) where-  SNat :: KnownNat n => SNat n--instance Lift (SNat n) where-  lift s = sigE [| SNat |]-                (appT (conT ''SNat) (litT $ numTyLit (snatToInteger s)))---- | Create a singleton literal for a type-level natural number-snat :: KnownNat n => SNat n-snat = SNat-{-# DEPRECATED snat "Use 'SNat' instead of 'snat'" #-}---- | 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 (natVal p)--instance ShowX (SNat n) where-  showsPrecX = showsPrecXWith showsPrec--{-# INLINE withSNat #-}--- | Supply a function with a singleton natural 'n' according to the context-withSNat :: KnownNat n => (SNat n -> a) -> a-withSNat f = f SNat--{-# INLINE snatToInteger #-}--- | Reify the type-level 'Nat' @n@ to it's term-level 'Integer' representation.-snatToInteger :: SNat n -> Integer-snatToInteger p@SNat = natVal p---- | Reify the type-level 'Nat' @n@ to it's term-level 'Num'ber.-snatToNum :: Num a => SNat n -> a-snatToNum p@SNat = fromInteger (natVal p)-{-# INLINE snatToNum #-}---- | Unary representation of a type-level natural------ __NB__: Not synthesisable-data UNat :: Nat -> * where-  UZero :: UNat 0-  USucc :: UNat n -> UNat (n + 1)--instance KnownNat n => Show (UNat n) where-  show x = 'u':show (natVal x)--instance KnownNat n => ShowX (UNat n) where-  showsPrecX = showsPrecXWith showsPrec---- | Convert a singleton natural number to its unary representation------ __NB__: Not synthesisable-toUNat :: SNat n -> UNat n-toUNat p@SNat = fromI (natVal p)-  where-    fromI :: Integer -> UNat m-    fromI 0 = unsafeCoerce UZero-    fromI n = unsafeCoerce (USucc (fromI (n - 1)))---- | Convert a unary-encoded natural number to its singleton representation------ __NB__: Not synthesisable-fromUNat :: UNat n -> SNat n-fromUNat UZero     = SNat :: SNat 0-fromUNat (USucc x) = addSNat (fromUNat x) (SNat :: SNat 1)---- | Add two unary-encoded natural numbers------ __NB__: Not synthesisable-addUNat :: UNat n -> UNat m -> UNat (n + m)-addUNat UZero     y     = y-addUNat x         UZero = x-addUNat (USucc x) y     = USucc (addUNat x y)---- | Multiply two unary-encoded natural numbers------ __NB__: Not synthesisable-mulUNat :: UNat n -> UNat m -> UNat (n * m)-mulUNat UZero      _     = UZero-mulUNat _          UZero = UZero-mulUNat (USucc x) y      = addUNat y (mulUNat x y)---- | Power of two unary-encoded natural numbers------ __NB__: Not synthesisable-powUNat :: UNat n -> UNat m -> UNat (n ^ m)-powUNat _ UZero     = USucc UZero-powUNat x (USucc y) = mulUNat x (powUNat x y)---- | Predecessor of a unary-encoded natural number------ __NB__: Not synthesisable-predUNat :: UNat (n+1) -> UNat n-predUNat (USucc x) = x---- | Subtract two unary-encoded natural numbers------ __NB__: Not synthesisable-subUNat :: UNat (m+n) -> UNat n -> UNat m-subUNat x         UZero     = x-subUNat (USucc x) (USucc y) = subUNat x y-subUNat UZero     _         = error "impossible: 0 + (n + 1) ~ 0"---- | Add two singleton natural numbers-addSNat :: SNat a -> SNat b -> SNat (a+b)-addSNat SNat SNat = SNat-{-# INLINE addSNat #-}---- | Subtract two singleton natural numbers-subSNat :: SNat (a+b) -> SNat b -> SNat a-subSNat SNat SNat = SNat-{-# INLINE subSNat #-}---- | Multiply two singleton natural numbers-mulSNat :: SNat a -> SNat b -> SNat (a*b)-mulSNat SNat SNat = SNat-{-# INLINE mulSNat #-}---- | Power of two singleton natural numbers-powSNat :: SNat a -> SNat b -> SNat (a^b)-powSNat SNat SNat = SNat-{-# NOINLINE powSNat #-}---- | Division of two singleton natural numbers-divSNat :: (1 <= b) => SNat a -> SNat b -> SNat (Div a b)-divSNat SNat SNat = SNat-{-# INLINE divSNat #-}---- | Modulo of two singleton natural numbers-modSNat :: (1 <= b) => SNat a -> SNat b -> SNat (Mod a b)-modSNat SNat SNat = SNat-{-# INLINE modSNat #-}---- | Floor of the logarithm of a natural number-flogBaseSNat :: (2 <= base, 1 <= x)-             => SNat base -- ^ Base-             -> SNat x-             -> SNat (FLog base x)-flogBaseSNat SNat SNat = SNat-{-# NOINLINE flogBaseSNat #-}---- | Ceiling of the logarithm of a natural number-clogBaseSNat :: (2 <= base, 1 <= x)-             => SNat base -- ^ Base-             -> SNat x-             -> SNat (CLog base x)-clogBaseSNat SNat SNat = SNat-{-# NOINLINE clogBaseSNat #-}---- | Exact integer logarithm of a natural number------ __NB__: Only works when the argument is a power of the base-logBaseSNat :: (FLog base x ~ CLog base x)-            => SNat base -- ^ Base-            -> SNat x-            -> SNat (Log base x)-logBaseSNat SNat SNat = SNat-{-# NOINLINE logBaseSNat #-}---- | Power of two of a singleton natural number-pow2SNat :: SNat a -> SNat (2^a)-pow2SNat SNat = SNat-{-# INLINE pow2SNat #-}---- | Base-2 encoded natural number------    * __NB__: The LSB is the left/outer-most constructor:---    * __NB__: Not synthesisable------ >>> B0 (B1 (B1 BT))--- b6------ == Constructors------ * Starting/Terminating element:------      @---      __BT__ :: 'BNat' 0---      @------ * Append a zero (/0/):------      @---      __B0__ :: 'BNat' n -> 'BNat' (2 '*' n)---      @------ * Append a one (/1/):------      @---      __B1__ :: 'BNat' n -> 'BNat' ((2 '*' n) '+' 1)---      @-data BNat :: Nat -> * where-  BT :: BNat 0-  B0 :: BNat n -> BNat (2*n)-  B1 :: BNat n -> BNat ((2*n) + 1)--instance KnownNat n => Show (BNat n) where-  show x = 'b':show (natVal x)--instance KnownNat n => ShowX (BNat n) where-  showsPrecX = showsPrecXWith showsPrec---- | Show a base-2 encoded natural as a binary literal------ __NB__: The LSB is shown as the right-most bit------ >>> d789--- d789--- >>> toBNat d789--- b789--- >>> showBNat (toBNat d789)--- "0b1100010101"--- >>> 0b1100010101 :: Integer--- 789-showBNat :: BNat n -> String-showBNat = go []-  where-    go :: String -> BNat m -> String-    go xs BT  = "0b" ++ xs-    go xs (B0 x) = go ('0':xs) x-    go xs (B1 x) = go ('1':xs) x---- | Convert a singleton natural number to its base-2 representation------ __NB__: Not synthesisable-toBNat :: SNat n -> BNat n-toBNat s@SNat = toBNat' (natVal 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'))---- | Convert a base-2 encoded natural number to its singleton representation------ __NB__: Not synthesisable-fromBNat :: BNat n -> SNat n-fromBNat BT     = SNat :: SNat 0-fromBNat (B0 x) = mulSNat (SNat :: SNat 2) (fromBNat x)-fromBNat (B1 x) = addSNat (mulSNat (SNat :: SNat 2) (fromBNat x))-                          (SNat :: SNat 1)---- | Add two base-2 encoded natural numbers------ __NB__: Not synthesisable-addBNat :: BNat n -> BNat m -> BNat (n+m)-addBNat (B0 a) (B0 b) = B0 (addBNat a b)-addBNat (B0 a) (B1 b) = B1 (addBNat a b)-addBNat (B1 a) (B0 b) = B1 (addBNat a b)-addBNat (B1 a) (B1 b) = B0 (succBNat (addBNat a b))-addBNat BT     b      = b-addBNat a      BT     = a---- | Multiply two base-2 encoded natural numbers------ __NB__: Not synthesisable-mulBNat :: BNat n -> BNat m -> BNat (n*m)-mulBNat BT      _  = BT-mulBNat _       BT = BT-mulBNat (B0 a)  b  = B0 (mulBNat a b)-mulBNat (B1 a)  b  = addBNat (B0 (mulBNat a b)) b---- | Power of two base-2 encoded natural numbers------ __NB__: Not synthesisable-powBNat :: BNat n -> BNat m -> BNat (n^m)-powBNat _  BT      = B1 BT-powBNat a  (B0 b)  = let z = powBNat a b-                     in  mulBNat z z-powBNat a  (B1 b)  = let z = powBNat a b-                     in  mulBNat a (mulBNat z z)---- | Successor of a base-2 encoded natural number------ __NB__: Not synthesisable-succBNat :: BNat n -> BNat (n+1)-succBNat BT     = B1 BT-succBNat (B0 a) = B1 a-succBNat (B1 a) = B0 (succBNat a)---- | Predecessor of a base-2 encoded natural number------ __NB__: Not synthesisable-predBNat :: BNat (n+1) -> (BNat n)-predBNat (B1 a) = case stripZeros a of-  BT -> BT-  a' -> B0 a'-predBNat (B0 x)  = B1 (go x)-  where-    go :: BNat m -> BNat (m-1)-    go (B1 a) = case stripZeros a of-      BT -> BT-      a' -> B0 a'-    go (B0 a)  = B1 (go a)-    go BT      = error "impossible: 0 ~ 0 - 1"---- | Divide a base-2 encoded natural number by 2------ __NB__: Not synthesisable-div2BNat :: BNat (2*n) -> BNat n-div2BNat BT     = BT-div2BNat (B0 x) = x-div2BNat (B1 _) = error "impossible: 2*n ~ 2*n+1"---- | Subtract 1 and divide a base-2 encoded natural number by 2------ __NB__: Not synthesisable-div2Sub1BNat :: BNat (2*n+1) -> BNat n-div2Sub1BNat (B1 x) = x-div2Sub1BNat _      = error "impossible: 2*n+1 ~ 2*n"---- | Get the log2 of a base-2 encoded natural number------ __NB__: Not synthesisable-log2BNat :: BNat (2^n) -> BNat n-log2BNat (B1 x) = case stripZeros x of-  BT -> BT-  _  -> error "impossible: 2^n ~ 2x+1"-log2BNat (B0 x) = succBNat (log2BNat x)---- | Strip non-contributing zero's from a base-2 encoded natural number------ >>> B1 (B0 (B0 (B0 BT)))--- b1--- >>> showBNat (B1 (B0 (B0 (B0 BT))))--- "0b0001"--- >>> showBNat (stripZeros (B1 (B0 (B0 (B0 BT)))))--- "0b1"--- >>> stripZeros (B1 (B0 (B0 (B0 BT))))--- b1------ __NB__: Not synthesisable-stripZeros :: BNat n -> BNat n-stripZeros BT      = BT-stripZeros (B1 x)  = B1 (stripZeros x)-stripZeros (B0 BT) = BT-stripZeros (B0 x)  = case stripZeros x of-  BT -> BT-  k  -> B0 k
− src/CLaSH/Promoted/Nat/Literals.hs 
@@ -1,32 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--Predefined 'SNat' singleton literals in the range [0 .. 1024]--Defines:--@-d0 = SNat :: SNat 0-d1 = SNat :: SNat 1-d2 = SNat :: SNat 2-...-d1024 = SNat :: SNat 1024-@--You can generate more 'SNat' literals using 'decLiteralsD' from "CLaSH.Promoted.Nat.TH"--}--{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DataKinds       #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Promoted.Nat.Literals where--import CLaSH.Promoted.Nat.TH--$(decLiteralsD 0 1024)
− src/CLaSH/Promoted/Nat/TH.hs 
@@ -1,63 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE TemplateHaskell #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Promoted.Nat.TH-  ( -- * Declare a single @d\<N\>@ literal-    decLiteralD-    -- * Declare ranges of @d\<N\>@ literals-  , decLiteralsD-  )-where--import Language.Haskell.TH-import CLaSH.Promoted.Nat--{- $setup->>> :set -XDataKinds->>> let d1111 = SNat :: SNat 1111->>> let d1200 = SNat :: SNat 1200->>> let d1201 = SNat :: SNat 1201->>> let d1202 = SNat :: SNat 1202--}---- | Create an 'SNat' literal------ > $(decLiteralD 1111)------ >>> :t d1111--- d1111 :: SNat 1111----decLiteralD :: Integer-            -> Q [Dec]-decLiteralD n = do-  let suffix  = if n < 0 then error ("Can't make negative SNat: " ++ show n) else show n-      valName = mkName $ 'd':suffix-  sig   <- sigD valName (appT (conT ''SNat) (litT (numTyLit n)))-  val   <- valD (varP valName) (normalB [| SNat |]) []-  return [ sig, val ]---- | Create a range of 'SNat' literals------ > $(decLiteralsD 1200 1202)------ >>> :t d1200--- d1200 :: SNat 1200--- >>> :t d1201--- d1201 :: SNat 1201--- >>> :t d1202--- d1202 :: SNat 1202----decLiteralsD :: Integer-             -> Integer-             -> Q [Dec]-decLiteralsD from to =-    fmap concat $ sequence $ [ decLiteralD n | n <- [from..to] ]
− src/CLaSH/Promoted/Nat/Unsafe.hs 
@@ -1,21 +0,0 @@-{-|-Copyright  :  (C) 2015-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE Unsafe #-}--module CLaSH.Promoted.Nat.Unsafe-  (unsafeSNat)-where--import Data.Reflection    (reifyNat)-import Unsafe.Coerce      (unsafeCoerce)--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 #-}
− src/CLaSH/Promoted/Symbol.hs 
@@ -1,38 +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 GADTs          #-}-{-# LANGUAGE KindSignatures #-}--{-# LANGUAGE Safe #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Promoted.Symbol-  (SSymbol (..), ssymbolProxy, ssymbolToString)-where--import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)---- | Singleton value for a type-level string @s@-data SSymbol (s :: Symbol) where-  SSymbol :: KnownSymbol s => SSymbol s--instance Show (SSymbol s) where-  show s@SSymbol = symbolVal s--{-# INLINE ssymbolProxy #-}--- | Create a singleton symbol literal @'SSymbol' s@ from a proxy for--- /s/-ssymbolProxy :: KnownSymbol s => proxy s -> SSymbol s-ssymbolProxy _ = SSymbol--{-# INLINE ssymbolToString #-}--- | Reify the type-level 'Symbol' @s@ to it's term-level 'String'--- representation.-ssymbolToString :: SSymbol s -> String-ssymbolToString s@SSymbol = symbolVal s
− src/CLaSH/Signal.hs 
@@ -1,158 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE MagicHash #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Signal-  ( -- * Implicitly clocked synchronous signal-    Signal-    -- * Basic circuit functions-  , signal-  , register-  , registerMaybe-  , regEn-  , mux-    -- * Boolean connectives-  , (.&&.), (.||.), not1-    -- * Product/Signal isomorphism-  , Bundle(..)-  , Unbundled-    -- * Simulation functions (not synthesisable)-  , simulate-  , simulateB-    -- ** lazy versions-  , simulate_lazy-  , simulateB_lazy-    -- * List \<-\> Signal conversion (not synthesisable)-  , sample-  , sampleN-  , fromList-    -- ** lazy versions-  , sample_lazy-  , sampleN_lazy-  , fromList_lazy-    -- * QuickCheck combinators-  , testFor-    -- * Type classes-    -- ** 'Eq'-like-  , (.==.), (./=.)-    -- ** 'Ord'-like-  , compare1, (.<.), (.<=.), (.>=.), (.>.)-    -- ** 'Enum'-like-  , fromEnum1-    -- ** 'Rational'-like-  , toRational1-    -- ** 'Integral'-like-  , toInteger1-    -- ** 'Bits'-like-  , testBit1-  , popCount1-  , shift1-  , rotate1-  , setBit1-  , clearBit1-  , shiftL1-  , unsafeShiftL1-  , shiftR1-  , unsafeShiftR1-  , rotateL1-  , rotateR1-  )-where--import Control.DeepSeq       (NFData)-import Data.Bits             (Bits) -- Haddock only-import Data.Maybe            (isJust, fromJust)--import CLaSH.Signal.Internal (Signal', register#, regEn#, (.==.), (./=.),-                              compare1, (.<.), (.<=.), (.>=.), (.>.), fromEnum1,-                              toRational1, toInteger1, testBit1, popCount1,-                              shift1, rotate1, setBit1, clearBit1, shiftL1,-                              unsafeShiftL1, shiftR1, unsafeShiftR1, rotateL1,-                              rotateR1, (.||.), (.&&.), not1, mux, sample,-                              sampleN, fromList, simulate, signal, testFor,-                              sample_lazy, sampleN_lazy, simulate_lazy,-                              fromList_lazy)-import CLaSH.Signal.Explicit (SystemClock, systemClock)-import CLaSH.Signal.Bundle   (Bundle (..), Unbundled')--{- $setup->>> let oscillate = register False (not <$> oscillate)->>> let count = regEn 0 oscillate (count + 1)--}---- * Implicitly clocked synchronous signal---- | Signal synchronised to the \"system\" clock, which has a period of 1000.-type Signal a = Signal' SystemClock a---- * Basic circuit functions--{-# INLINE register #-}--- | 'register' @i s@ delays the values in 'Signal' @s@ for one cycle, and sets--- the value at time 0 to @i@------ >>> sampleN 3 (register 8 (fromList [1,2,3,4]))--- [8,1,2]-register :: a -> Signal a -> Signal a-register = register# systemClock-infixr 3 `register`--registerMaybe :: a -> Signal (Maybe a) -> Signal a-registerMaybe initial i = regEn# systemClock initial (fmap isJust i) (fmap fromJust i)-{-# INLINE registerMaybe #-}-infixr 3 `registerMaybe`--{-# INLINE regEn #-}--- | Version of 'register' that only updates its content when its second argument--- is asserted. So given:------ @--- oscillate = 'register' False ('not1' '<$>' oscillate)--- count     = 'regEn' 0 oscillate (count + 1)--- @------ We get:------ >>> sampleN 8 oscillate--- [False,True,False,True,False,True,False,True]--- >>> sampleN 8 count--- [0,0,1,1,2,2,3,3]-regEn :: a -> Signal Bool -> Signal a -> Signal a-regEn = regEn# systemClock---- * Product/Signal isomorphism---- | Isomorphism between a 'Signal' of a product type (e.g. a tuple) and a--- product type of 'Signal's.-type Unbundled a = Unbundled' SystemClock a---- | Simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a list of--- samples of type @a@------ >>> simulateB (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 synthesisable-simulateB :: (Bundle a, Bundle b, NFData a, NFData b) => (Unbundled' clk1 a -> Unbundled' clk2 b) -> [a] -> [b]-simulateB f = simulate (bundle . f . unbundle)---- | Simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a list of--- samples of type @a@------ >>> simulateB (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 synthesisable-simulateB_lazy :: (Bundle a, Bundle b) => (Unbundled' clk1 a -> Unbundled' clk2 b) -> [a] -> [b]-simulateB_lazy f = simulate_lazy (bundle . f . unbundle)
− src/CLaSH/Signal/Bundle.hs 
@@ -1,226 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--The Product/Signal isomorphism--}--{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE DefaultSignatures      #-}-{-# LANGUAGE KindSignatures         #-}-{-# LANGUAGE MagicHash              #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE TypeOperators          #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Signal.Bundle-  ( Bundle (..)-  )-where--import Control.Applicative   (liftA2)-import GHC.TypeLits          (KnownNat)-import Prelude               hiding (head, map, tail)--import CLaSH.NamedTypes      ((:::))-import CLaSH.Signal.Internal (Clock, Signal' (..))-import CLaSH.Sized.BitVector (BitVector)-import CLaSH.Sized.Fixed     (Fixed)-import CLaSH.Sized.Index     (Index)-import CLaSH.Sized.Signed    (Signed)-import CLaSH.Sized.Unsigned  (Unsigned)-import CLaSH.Sized.Vector    (Vec, traverse#, lazyV)-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.------ Instances of 'bundle must satisfy the following laws:------ @--- 'bundle' . 'unbundle' = 'id'--- 'unbundle' . 'bundle' = 'id'--- @------ By default, 'bundle' and 'unbundle', are defined as the identity, that is,--- writing:------ @--- data D = A | B------ instance 'bundle D--- @------ is the same as:------ @--- data D = A | B------ instance 'bundle D where---   type 'Unbundled'' clk D = 'Signal'' clk D---   'bundle'   _ s = s---   'unbundle' _ s = s--- @----class Bundle a where-  type Unbundled' (clk :: Clock) a = res | res -> clk-  type Unbundled' clk a = Signal' clk a-  -- | Example:-  ---  -- @-  -- __bundle__ :: ('Signal'' clk a, 'Signal'' clk b) -> 'Signal'' clk (a,b)-  -- @-  ---  -- However:-  ---  -- @-  -- __bundle__ :: 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -> 'Signal'' clk 'CLaSH.Sized.BitVector.Bit'-  -- @-  bundle :: Unbundled' clk a -> Signal' clk a--  {-# INLINE bundle #-}-  default bundle :: Signal' clk a -> Signal' clk a-  bundle s = s-  -- | Example:-  ---  -- @-  -- __unbundle__ :: 'Signal'' clk (a,b) -> ('Signal'' clk a, 'Signal'' clk b)-  -- @-  ---  -- However:-  ---  -- @-  -- __unbundle__ :: 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -> 'Signal'' clk 'CLaSH.Sized.BitVector.Bit'-  -- @-  unbundle :: Signal' clk a -> Unbundled' clk a--  {-# INLINE unbundle #-}-  default unbundle :: Signal' clk a -> Signal' clk a-  unbundle s = s--instance Bundle Bool-instance Bundle Integer-instance Bundle Int-instance Bundle Float-instance Bundle Double-instance Bundle (Maybe a)-instance Bundle (Either a b)--instance Bundle (BitVector n)-instance Bundle (Index n)-instance Bundle (Fixed rep int frac)-instance Bundle (Signed n)-instance Bundle (Unsigned n)---- | Note that:------ > bundle   :: () -> Signal' clk ()--- > unbundle :: Signal' clk () -> ()-instance Bundle () where-  type Unbundled' t () = t ::: ()-  -- ^ This is just to satisfy the injectivity annotation-  bundle   u = pure u-  unbundle _ = ()--instance Bundle (a,b) where-  type Unbundled' t (a,b) = (Signal' t a, Signal' t b)-  bundle       = uncurry (liftA2 (,))-  unbundle tup = (fmap fst tup, fmap snd tup)--instance Bundle (a,b,c) where-  type Unbundled' t (a,b,c) = (Signal' t a, Signal' t b, Signal' t c)-  bundle   (a,b,c) = (,,) <$> a <*> b <*> c-  unbundle tup     = (fmap (\(x,_,_) -> x) tup-                     ,fmap (\(_,x,_) -> x) tup-                     ,fmap (\(_,_,x) -> x) tup-                     )--instance Bundle (a,b,c,d) where-  type Unbundled' t (a,b,c,d) = ( Signal' t a, Signal' t b, Signal' t c-                                , Signal' t d-                                )-  bundle   (a,b,c,d) = (,,,) <$> a <*> b <*> c <*> d-  unbundle tup       = (fmap (\(x,_,_,_) -> x) tup-                       ,fmap (\(_,x,_,_) -> x) tup-                       ,fmap (\(_,_,x,_) -> x) tup-                       ,fmap (\(_,_,_,x) -> x) tup-                       )--instance Bundle (a,b,c,d,e) where-  type Unbundled' t (a,b,c,d,e) = ( Signal' t a, Signal' t b, Signal' t c-                                  , Signal' t d, Signal' t e-                                  )-  bundle   (a,b,c,d,e) = (,,,,) <$> a <*> b <*> c <*> d <*> e-  unbundle tup         = (fmap (\(x,_,_,_,_) -> x) tup-                         ,fmap (\(_,x,_,_,_) -> x) tup-                         ,fmap (\(_,_,x,_,_) -> x) tup-                         ,fmap (\(_,_,_,x,_) -> x) tup-                         ,fmap (\(_,_,_,_,x) -> x) tup-                         )--instance Bundle (a,b,c,d,e,f) where-  type Unbundled' t (a,b,c,d,e,f) = ( Signal' t a, Signal' t b, Signal' t c-                                    , Signal' t d, Signal' t e, Signal' t f-                                    )-  bundle   (a,b,c,d,e,f) = (,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f-  unbundle tup           = (fmap (\(x,_,_,_,_,_) -> x) tup-                           ,fmap (\(_,x,_,_,_,_) -> x) tup-                           ,fmap (\(_,_,x,_,_,_) -> x) tup-                           ,fmap (\(_,_,_,x,_,_) -> x) tup-                           ,fmap (\(_,_,_,_,x,_) -> x) tup-                           ,fmap (\(_,_,_,_,_,x) -> x) tup-                           )--instance Bundle (a,b,c,d,e,f,g) where-  type Unbundled' t (a,b,c,d,e,f,g) = ( Signal' t a, Signal' t b, Signal' t c-                                      , Signal' t d, Signal' t e, Signal' t f-                                      , Signal' t g-                                      )-  bundle   (a,b,c,d,e,f,g) = (,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f-                                      <*> g-  unbundle tup             = (fmap (\(x,_,_,_,_,_,_) -> x) tup-                             ,fmap (\(_,x,_,_,_,_,_) -> x) tup-                             ,fmap (\(_,_,x,_,_,_,_) -> x) tup-                             ,fmap (\(_,_,_,x,_,_,_) -> x) tup-                             ,fmap (\(_,_,_,_,x,_,_) -> x) tup-                             ,fmap (\(_,_,_,_,_,x,_) -> x) tup-                             ,fmap (\(_,_,_,_,_,_,x) -> x) tup-                             )--instance Bundle (a,b,c,d,e,f,g,h) where-  type Unbundled' t (a,b,c,d,e,f,g,h) = ( Signal' t a, Signal' t b, Signal' t c-                                        , Signal' t d, Signal' t e, Signal' t f-                                        , Signal' t g, Signal' t h-                                        )-  bundle   (a,b,c,d,e,f,g,h) = (,,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f-                                         <*> g <*> h-  unbundle tup               = (fmap (\(x,_,_,_,_,_,_,_) -> x) tup-                               ,fmap (\(_,x,_,_,_,_,_,_) -> x) tup-                               ,fmap (\(_,_,x,_,_,_,_,_) -> x) tup-                               ,fmap (\(_,_,_,x,_,_,_,_) -> x) tup-                               ,fmap (\(_,_,_,_,x,_,_,_) -> x) tup-                               ,fmap (\(_,_,_,_,_,x,_,_) -> x) tup-                               ,fmap (\(_,_,_,_,_,_,x,_) -> x) tup-                               ,fmap (\(_,_,_,_,_,_,_,x) -> x) tup-                               )--instance KnownNat n => Bundle (Vec n a) where-  type Unbundled' t (Vec n a) = Vec n (Signal' t a)-  -- The 'Traversable' instance of 'Vec' is not synthesisable, so we must-  -- define 'bundle' as a primitive.-  bundle   = vecBundle#-  unbundle = sequenceA . fmap lazyV--{-# NOINLINE vecBundle# #-}-vecBundle# :: Vec n (Signal' t a) -> Signal' t (Vec n a)-vecBundle# = traverse# id--instance KnownNat d => Bundle (RTree d a) where-  type Unbundled' t (RTree d a) = RTree d (Signal' t a)-  bundle   = sequenceA-  unbundle = sequenceA . fmap lazyT
− src/CLaSH/Signal/Delayed.hs 
@@ -1,97 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeOperators              #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Signal.Delayed-  ( -- * Delay-annotated synchronous signals-    DSignal-  , delay-  , delayI-  , feedback-    -- * Signal \<-\> DSignal conversion-  , fromSignal-  , toSignal-    -- * List \<-\> DSignal conversion (not synthesisable)-  , dfromList-    -- ** lazy versions-  , dfromList_lazy-    -- * Experimental-  , unsafeFromSignal-  , antiDelay-  )-where--import Data.Default                  (Default(..))-import GHC.TypeLits                  (KnownNat, Nat, type (+))-import Prelude                       hiding (head, length, repeat)--import CLaSH.Sized.Vector            (Vec)-import CLaSH.Signal.Explicit         (SystemClock, systemClock)-import CLaSH.Signal.Delayed.Explicit (DSignal', dfromList, dfromList_lazy,-                                      delay', delayI', feedback, fromSignal,-                                      toSignal, unsafeFromSignal, antiDelay)--{- $setup->>> :set -XDataKinds->>> :set -XTypeOperators->>> import CLaSH.Prelude->>> let delay3 = delay (0 :> 0 :> 0 :> Nil)->>> let delay2 = delayI :: DSignal n Int -> DSignal (n + 2) Int->>> :{-let mac :: DSignal 0 Int -> DSignal 0 Int -> DSignal 0 Int-    mac x y = feedback (mac' x y)-      where-        mac' :: DSignal 0 Int -> DSignal 0 Int -> DSignal 0 Int-             -> (DSignal 0 Int, DSignal 1 Int)-        mac' a b acc = let acc' = a * b + acc-                       in  (acc, delay (singleton 0) acc')-:}---}---- | A synchronized signal with samples of type @a@, synchronized to \"system\"--- clock (period 1000), that has accumulated @delay@ amount of samples delay--- along its path.-type DSignal (delay :: Nat) a = DSignal' SystemClock delay a---- | Delay a 'DSignal' for @d@ periods.------ @--- delay3 :: 'DSignal' n Int -> 'DSignal' (n + 3) Int--- delay3 = 'delay' (0 ':>' 0 ':>' 0 ':>' 'Nil')--- @------ >>> sampleN 6 (delay3 (dfromList [1..]))--- [0,0,0,1,2,3]-delay :: forall a n d . KnownNat d-      => Vec d a-      -> DSignal n a-      -> DSignal (n + d) a-delay = delay' systemClock---- | Delay a 'DSignal' for @m@ periods, where @m@ is derived from the context.------ @--- delay2 :: 'DSignal' n Int -> 'DSignal' (n + 2) Int--- delay2 = 'delayI'--- @------ >>> sampleN 6 (delay2 (dfromList [1..]))--- [0,0,1,2,3,4]-delayI :: (Default a, KnownNat d)-       => DSignal n a-       -> DSignal (n + d) a-delayI = delayI' systemClock
− src/CLaSH/Signal/Delayed/Explicit.hs 
@@ -1,196 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveLift                 #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Signal.Delayed.Explicit-  ( -- * Delay-annotated synchronous signals-    DSignal'-  , delay'-  , delayI'-  , feedback-    -- * Signal \<-\> DSignal conversion-  , fromSignal-  , toSignal-    -- * List \<-\> DSignal conversion (not synthesisable)-  , dfromList-    -- ** lazy versions-  , dfromList_lazy-    -- * Experimental-  , unsafeFromSignal-  , antiDelay-  )-where--import Control.DeepSeq            (NFData)-import Data.Coerce                (coerce)-import Data.Default               (Default(..))-import GHC.TypeLits               (KnownNat, Nat, type (+))-import Language.Haskell.TH.Syntax (Lift)-import Prelude                    hiding (head, length, repeat)-import Test.QuickCheck            (Arbitrary, CoArbitrary)--import CLaSH.Promoted.Nat         (SNat)-import CLaSH.Sized.Vector         (Vec, head, length, repeat, shiftInAt0,-                                   singleton)-import CLaSH.Signal               (fromList, fromList_lazy, bundle, unbundle)-import CLaSH.Signal.Explicit      (Signal', Clock, SClock, register')--{- $setup->>> :set -XDataKinds->>> :set -XTypeOperators->>> import CLaSH.Prelude->>> import CLaSH.Signal.Explicit (SystemClock, systemClock)->>> let delay3 = delay' systemClock (0 :> 0 :> 0 :> Nil)->>> let delay2 = delayI' systemClock :: DSignal' SystemClock n Int -> DSignal' SystemClock (n + 2) Int->>> :{-let mac :: DSignal' SystemClock 0 Int -> DSignal' SystemClock 0 Int-        -> DSignal' SystemClock 0 Int-    mac x y = feedback (mac' x y)-      where-        mac' :: DSignal' SystemClock 0 Int -> DSignal' SystemClock 0 Int-             -> DSignal' SystemClock 0 Int-             -> (DSignal' SystemClock 0 Int, DSignal' SystemClock 1 Int)-        mac' a b acc = let acc' = a * b + acc-                       in  (acc, delay' systemClock (singleton 0) acc')-:}---}---- | A synchronized signal with samples of type @a@, synchronized to clock--- @clk@, that has accumulated @delay@ amount of samples delay along its path.-newtype DSignal' (clk :: Clock) (delay :: Nat) a =-    DSignal' { -- | Strip a 'DSignal' from its delay information.-               toSignal :: Signal' clk a-             }-  deriving (Show,Default,Functor,Applicative,Num,Fractional,-            Foldable,Traversable,Arbitrary,CoArbitrary,Lift)---- | Create a 'DSignal'' from a list------ 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])--- [1,2]------ __NB__: This function is not synthesisable-dfromList :: NFData a => [a] -> DSignal' clk 0 a-dfromList = coerce . fromList---- | Create a 'DSignal' from a list------ 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])--- [1,2]------ __NB__: This function is not synthesisable-dfromList_lazy :: [a] -> DSignal' clk 0 a-dfromList_lazy = coerce . fromList_lazy---- | Delay a 'DSignal'' for @d@ periods.------ @--- delay3 :: 'DSignal'' clk n Int -> 'DSignal'' clk (n + 3) Int--- delay3 = 'delay' (0 ':>' 0 ':>' 0 ':>' 'Nil')--- @------ >>> sampleN 6 (delay3 (dfromList [1..]))--- [0,0,0,1,2,3]-delay' :: forall clk a n d . KnownNat d-       => SClock clk-       -> Vec d a-       -> DSignal' clk n a-       -> DSignal' clk (n + d) a-delay' clk m ds = coerce (delaySignal (coerce ds))-  where-    delaySignal :: Signal' clk a -> Signal' clk a-    delaySignal s = case length m of-      0 -> s-      _ -> let (r',o) = shiftInAt0 (unbundle r) (singleton s)-               r      = register' clk m (bundle r')-           in  head o---- | Delay a 'DSignal' clk' for @m@ periods, where @m@ is derived from the--- context.------ @--- delay2 :: 'DSignal'' clk n Int -> 'DSignal'' clk (n + 2) Int--- delay2 = 'delayI'--- @------ >>> sampleN 6 (delay2 (dfromList [1..]))--- [0,0,1,2,3,4]-delayI' :: (Default a, KnownNat d)-        => SClock clk-        -> DSignal' clk n a-        -> DSignal' clk (n + d) a-delayI' clk = delay' clk (repeat def)---- | Feed the delayed result of a function back to its input:------ @--- mac :: 'DSignal'' clk 0 Int -> 'DSignal'' clk 0 Int -> 'DSignal'' clk 0 Int--- mac x y = 'feedback' (mac' x y)---   where---     mac' :: 'DSignal'' clk 0 Int -> 'DSignal'' clk 0 Int -> 'DSignal'' clk 0 Int---          -> ('DSignal'' clk 0 Int, 'DSignal'' clk 1 Int)---     mac' a b acc = let acc' = a * b + acc---                    in  (acc, 'delay' ('singleton' 0) acc')--- @------ >>> sampleN 6 (mac (dfromList [1..]) (dfromList [1..]))--- [0,1,5,14,30,55]-feedback :: (DSignal' clk n a -> (DSignal' clk n a,DSignal' clk (n + m + 1) a))-         -> DSignal' clk n a-feedback f = let (o,r) = f (coerce r) in o---- | 'Signal's are not delayed------ > sample s == dsample (fromSignal s)-fromSignal :: Signal' clk a -> DSignal' clk 0 a-fromSignal = coerce---- | __EXPERIMENTAL__------ __Unsafely__ convert a 'Signal' to /any/ 'DSignal' clk'.------ __NB__: Should only be used to interface with functions specified in terms of--- 'Signal'.-unsafeFromSignal :: Signal' clk a -> DSignal' clk n a-unsafeFromSignal = DSignal'---- | __EXPERIMENTAL__------ Access a /delayed/ signal in the present.------ @--- mac :: 'DSignal' clk' 0 Int -> 'DSignal' clk' 0 Int -> 'DSignal' clk' 0 Int--- mac x y = acc'---   where---     acc' = (x * y) + 'antiDelay' d1 acc---     acc  = 'delay' ('singleton' 0) acc'--- @-antiDelay :: SNat d -> DSignal' clk (n + d) a -> DSignal' clk n a-antiDelay _ = coerce
− src/CLaSH/Signal/Explicit.hs 
@@ -1,328 +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 GADTs     #-}-{-# LANGUAGE MagicHash #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Signal.Explicit-  ( -- * Explicitly clocked synchronous signal-    -- $relativeclocks-    Signal'-    -- * Clock domain crossing-    -- ** Clock-  , Clock (..)-  , SClock (..)-  , sclock-  , withSClock-  , SystemClock-  , systemClock-  , freqCalc-    -- ** Synchronisation primitive-  , unsafeSynchronizer-    -- * Basic circuit functions-  , register'-  , registerMaybe'-  , regEn'-  )-where--import Data.Maybe             (isJust, fromJust)-import GHC.TypeLits           (KnownNat, KnownSymbol)--import CLaSH.Promoted.Nat     (SNat (..), snatToNum)-import CLaSH.Promoted.Symbol  (SSymbol (..))-import CLaSH.Signal.Internal  (Signal' (..), Clock (..), SClock (..), register#,-                               regEn#)--{- $setup->>> :set -XDataKinds->>> import CLaSH.Prelude->>> type Clk2 = Clk "clk2" 2->>> type Clk7 = Clk "clk7" 7->>> let clk2 = sclock :: SClock Clk2->>> let clk7 = sclock :: SClock Clk7->>> let oversampling = register' clk2 99 . unsafeSynchronizer clk7 clk2 . register' clk7 50->>> let almostId = register' clk7 70 . unsafeSynchronizer clk2 clk7 . register' clk2 99 . unsafeSynchronizer clk7 clk2 . register' clk7 50->>> type ClkA = Clk "A" 100->>> let clkA = sclock :: SClock ClkA->>> let oscillate = register' clkA False (CLaSH.Signal.not1 oscillate)->>> let count = regEn' clkA 0 oscillate (count + 1)--}--{- $relativeclocks #relativeclocks#-CλaSH supports explicitly clocked 'CLaSH.Signal's in the form of:--@-'Signal'' (clk :: 'Clock') a-@--Where @a@ is the type of the elements, and @clk@ is the clock to which the-signal is synchronised. The type-parameter, @clk@, is of the kind 'Clock' which-has types of the following shape:--@-Clk \{\- name :: \-\} 'GHC.TypeLits.Symbol' \{\- period :: \-\} 'GHC.TypeLits.Nat'-@--Where @name@ is a type-level string ('GHC.TypeLits.Symbol') representing the the-name of the clock, and @period@ is a type-level natural number ('GHC.TypeLits.Nat')-representing the clock period. Two concrete instances of a 'Clk' could be:--> type ClkA500  = Clk "A500" 500-> type ClkB3250 = Clk "B3250" 3250--The periods of these clocks are however dimension-less, they do not refer to any-explicit time-scale (e.g. nano-seconds). The reason for the lack of an explicit-time-scale is that the CλaSH compiler would not be able guarantee that the-circuit can run at the specified frequency. The clock periods are just there to-indicate relative frequency differences between two different clocks. That is, a-signal:--@-'Signal'' ClkA500 a-@--is synchronized to a clock that runs 6.5 times faster than the clock to which-the signal:--@-'Signal'' ClkB3250 a-@--is synchronized to.--* __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!--}---- * Clock domain crossing---- ** Clock--{-# INLINE sclock #-}--- | Create a singleton clock------ @--- type ClkA = 'Clk' \"A\" 100------ clkA :: 'SClock' ClkA--- clkA = 'sclock'--- @-sclock :: (KnownSymbol name, KnownNat period)-       => SClock ('Clk name period)-sclock = SClock SSymbol SNat--{-# INLINE withSClock #-}--- | Supply a function with a singleton clock @clk@ according to the context-withSClock :: (KnownSymbol name, KnownNat period)-           => (SClock ('Clk name period) -> a)-           -> a-withSClock f = f (SClock SSymbol SNat)---- | The standard system clock with a period of 1000-type SystemClock = 'Clk "system" 1000--{-# INLINE systemClock #-}--- | The singleton clock for 'SystemClock'-systemClock :: SClock SystemClock-systemClock = sclock---- | Calculate relative periods given a list of frequencies.------ So for example, you have one part of your design connected to an ADC running--- at 20 MHz, one part of your design connected to a DAC running at 36 MHz, and--- the rest of your system is running at 50 MHz. What are the relative--- (integer) clock periods in CλaSH, such that their ratios correspond to the--- ratios between the actual clock frequencies.------ For this we use 'freqCalc':------ >>> freqCalc [20,36,50]--- [45,25,18]------ So that we create the proper clocks:------ @--- type ADC20 = 'Clk' \"ADC\" 45--- type DAC36 = 'Clk' \"DAC\" 25--- type Sys50 = 'Clk' \"Sys\" 18------ sys50 :: SClock Sys50--- sys50 = 'sclock'------ adc20 :: SClock ADC20--- adc20 = 'sclock'------ dac36 :: SClock DAC36--- dac36 = 'sclock'--- @------ __NB__: This function is /not/ synthesisable-freqCalc :: [Integer] -> [Integer]-freqCalc xs = map (`div` g) ys-  where-    p  = product xs-    ys = map (p `div`) xs-    g  = foldr1 gcd ys---- ** Synchronisation primitive-{-# NOINLINE unsafeSynchronizer #-}--- | The 'unsafeSynchronizer' function is a primitive that must be used to--- connect one clock domain to the other, and will be synthesised to a (bundle--- of) wire(s) in the eventual circuit. This function should only be used as--- part of a proper synchronisation component, such as the following dual--- flip-flop synchronizer:------ @--- dualFlipFlop :: SClock clkA -> SClock clkB---              -> Signal' clkA Bit -> Signal' clkB Bit--- dualFlipFlop clkA clkB = 'register'' clkB low . 'register'' clkB low---                        . 'unsafeSynchronizer' clkA clkB--- @------ The 'unsafeSynchronizer' works in such a way that, given 2 clocks:------ @--- type Clk7 = 'Clk' \"clk7\" 7------ clk7 :: 'SClock' Clk7--- clk7 = 'sclock'--- @------ and------ @--- type Clk2 = 'Clk' \"clk2\" 2------ clk2 :: 'SClock' Clk2--- clk2 = 'sclock'--- @------ Oversampling followed by compression is the identity function plus 2 initial--- values:------ @--- 'register'' clk7 i $--- 'unsafeSynchronizer' clk2 clk7 $--- 'register'' clk2 j $--- 'unsafeSynchronizer' clk7 clk2 $--- 'register'' clk7 k s------ ==------ i :- j :- s--- @------ Something we can easily observe:------ @--- oversampling = 'register'' clk2 99 . 'unsafeSynchronizer' clk7 clk2---              . 'register'' clk7 50--- almostId     = 'register'' clk7 70 . 'unsafeSynchronizer' clk2 clk7---              . 'register'' clk2 99 . 'unsafeSynchronizer' clk7 clk2---              . 'register'' clk7 50--- @------ >>> sampleN 37 (oversampling (fromList [1..10]))--- [99,50,1,1,1,2,2,2,2,3,3,3,4,4,4,4,5,5,5,6,6,6,6,7,7,7,8,8,8,8,9,9,9,10,10,10,10]--- >>> sampleN 12 (almostId (fromList [1..10]))--- [70,99,1,2,3,4,5,6,7,8,9,10]-unsafeSynchronizer :: SClock clk1 -- ^ 'Clock' of the incoming signal-                   -> SClock clk2 -- ^ 'Clock' of the outgoing signal-                   -> Signal' clk1 a-                   -> Signal' clk2 a-unsafeSynchronizer (SClock _ period1) (SClock _ period2) s = s'-  where-    t1    = snatToNum period1-    t2    = snatToNum period2-    s' | t1 < t2   = compress   t2 t1 s-       | t1 > t2   = oversample t1 t2 s-       | otherwise = same s--same :: Signal' clk1 a -> Signal' clk2 a-same (s :- ss) = s :- same ss--oversample :: Int -> Int -> Signal' clk1 a -> Signal' clk2 a-oversample high low (s :- ss) = s :- oversampleS (reverse (repSchedule high low)) ss--oversampleS :: [Int] -> Signal' clk1 a -> Signal' clk2 a-oversampleS sched = oversample' sched-  where-    oversample' []     s       = oversampleS sched s-    oversample' (d:ds) (s:-ss) = prefixN d s (oversample' ds ss)--    prefixN 0 _ s = s-    prefixN n x s = x :- prefixN (n-1) x s--compress :: Int -> Int -> Signal' clk1 a -> Signal' clk2 a-compress high low s = compressS (repSchedule high low) s--compressS :: [Int] -> Signal' clk1 a -> Signal' clk2 a-compressS sched = compress' sched-  where-    compress' []     s           = compressS sched s-    compress' (d:ds) ss@(s :- _) = s :- compress' ds (dropS d ss)--    dropS 0 s         = s-    dropS n (_ :- ss) = dropS (n-1) ss--repSchedule :: Int -> Int -> [Int]-repSchedule high low = take low $ repSchedule' low high 1-  where-    repSchedule' cnt th rep-      | cnt < th  = repSchedule' (cnt+low) th (rep + 1)-      | otherwise = rep : repSchedule' (cnt + low) (th + high) 1---- * Basic circuit functions--{-# INLINE register' #-}--- | \"@'register'' i s@\" delays the values in 'Signal'' @s@ for one cycle,--- and sets the value at time 0 to @i@------ @--- type ClkA = 'Clk' \"A\" 100------ clkA :: 'SClock' ClkA--- clkA = 'sclock'--- @------ >>> sampleN 3 (register' clkA 8 (fromList [1,2,3,4]))--- [8,1,2]-register' :: SClock clk -> a -> Signal' clk a -> Signal' clk a-register' = register#--registerMaybe' :: SClock clk -> a -> Signal' clk (Maybe a) -> Signal' clk a-registerMaybe' clk initial i = regEn# clk initial (fmap isJust i) (fmap fromJust i)-{-# INLINE registerMaybe' #-}--{-# INLINE regEn' #-}--- | Version of 'register'' that only updates its content when its third--- argument is asserted. So given:------ @--- type ClkA = 'Clk' \"A\" 100--- clkA :: 'SClock' ClkA--- clkA = 'sclock'------ oscillate = 'register'' clkA False ('CLaSH.Signal.not1' oscillate)--- count     = 'regEn'' clkA 0 oscillate (count + 1)--- @------ We get:------ >>> sampleN 8 oscillate--- [False,True,False,True,False,True,False,True]--- >>> sampleN 8 count--- [0,0,1,1,2,2,3,3]-regEn' :: SClock clk -> a -> Signal' clk Bool -> Signal' clk a -> Signal' clk a-regEn' = regEn#
− src/CLaSH/Signal/Internal.hs 
@@ -1,710 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE MagicHash             #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TypeFamilies          #-}--{-# LANGUAGE Unsafe #-}---- 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 #-}--module CLaSH.Signal.Internal-  ( -- * Datatypes-    Clock (..)-  , SClock (..)-  , Signal' (..)-    -- * Basic circuits-  , register#-  , regEn#-  , mux-  , signal-    -- * Boolean connectives-  , (.&&.), (.||.), not1-    -- * Simulation functions (not synthesisable)-  , simulate-    -- ** lazy version-  , simulate_lazy-    -- * List \<-\> Signal conversion (not synthesisable)-  , sample-  , sampleN-  , fromList-    -- ** lazy versions-  , sample_lazy-  , sampleN_lazy-  , fromList_lazy-    -- * QuickCheck combinators-  , testFor-    -- * Type classes-    -- ** 'Eq'-like-  , (.==.), (./=.)-    -- ** 'Ord'-like-  , compare1, (.<.), (.<=.), (.>=.), (.>.)-    -- ** 'Functor'-  , mapSignal#-    -- ** 'Applicative'-  , signal#-  , appSignal#-    -- ** 'Foldable'-  , foldr#-    -- ** 'Traversable'-  , traverse#-    -- ** 'Enum'-like-  , fromEnum1-    -- ** 'Rational'-like-  , toRational1-    -- ** 'Integral'-like-  , toInteger1-    -- ** 'Bits'-like-  , testBit1-  , popCount1-  , shift1-  , rotate1-  , setBit1-  , clearBit1-  , shiftL1-  , unsafeShiftL1-  , shiftR1-  , unsafeShiftR1-  , rotateL1-  , rotateR1-  -- * EXTREMELY EXPERIMENTAL-  , joinSignal#-  )-where--import Control.Applicative        (liftA2, liftA3)-import Control.DeepSeq            (NFData, force)-import Control.Exception          (catch, evaluate, throw)-import Data.Bits                  (Bits (..))-import Data.Default               (Default (..))-import GHC.TypeLits               (Nat, Symbol)-import Language.Haskell.TH.Syntax (Lift (..))-import System.IO.Unsafe           (unsafeDupablePerformIO)-import Test.QuickCheck            (Arbitrary (..), CoArbitrary(..), Property,-                                   property)--import CLaSH.Promoted.Nat         (SNat, snatToInteger)-import CLaSH.Promoted.Symbol      (SSymbol, ssymbolToString)-import CLaSH.XException           (XException, errorX, seqX)--{- $setup->>> :set -XDataKinds->>> :set -XMagicHash->>> import CLaSH.Promoted.Nat->>> import CLaSH.Promoted.Symbol->>> type SystemClock = Clk "System" 1000->>> type Signal a = Signal' SystemClock a->>> let register = register# (SClock SSymbol SNat :: SClock SystemClock)--}---- | A clock with a name ('Symbol') and period ('Nat')-data Clock = Clk Symbol Nat---- | Singleton value for a type-level 'Clock' with the given @name@ and @period@-data SClock (clk :: Clock)-  where-    SClock :: SSymbol name -> SNat period -> SClock ('Clk name period)--instance Show (SClock clk) where-  show (SClock nm r) = ssymbolToString nm ++ show (snatToInteger r)--infixr 5 :---- | A synchronized signal with samples of type @a@, explicitly synchronized to--- a clock @clk@------ __NB__: The constructor, @(':-')@, is __not__ synthesisable.-data Signal' (clk :: Clock) a = a :- Signal' clk a--instance Show a => Show (Signal' clk a) where-  show (x :- xs) = show x ++ " " ++ show xs--instance Lift a => Lift (Signal' clk a) where-  lift ~(x :- _) = [| signal# x |]--instance Default a => Default (Signal' clk a) where-  def = signal# def--instance Functor (Signal' clk) where-  fmap = mapSignal#--{-# NOINLINE mapSignal# #-}-mapSignal# :: (a -> b) -> Signal' clk a -> Signal' clk b-mapSignal# f (a :- as) = f a :- mapSignal# f as--instance Applicative (Signal' clk) where-  pure  = signal#-  (<*>) = appSignal#--{-# NOINLINE signal# #-}-signal# :: a -> Signal' clk a-signal# a = let s = a :- s in s--{-# NOINLINE appSignal# #-}-appSignal# :: Signal' clk (a -> b) -> Signal' clk a -> Signal' clk b-appSignal# (f :- fs) xs@(~(a :- as)) = f a :- (xs `seq` appSignal# fs as) -- See [NOTE: Lazy ap]--{- 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.--}---{-# NOINLINE joinSignal# #-}--- | __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' clk (Signal' clk a) -> Signal' clk a-joinSignal# ~(xs :- xss) = head# xs :- joinSignal# (mapSignal# tail# xss)-  where-    head# (x' :- _ )  = x'-    tail# (_  :- xs') = xs'--instance Num a => Num (Signal' clk a) where-  (+)         = liftA2 (+)-  (-)         = liftA2 (-)-  (*)         = liftA2 (*)-  negate      = fmap negate-  abs         = fmap abs-  signum      = fmap signum-  fromInteger = signal# . fromInteger---- | __NB__: Not synthesisable------ __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' clk) where-  foldr = foldr#--{-# NOINLINE foldr# #-}--- | __NB__: Not synthesisable------ __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' clk a -> b-foldr# f z (a :- s) = a `f` (foldr# f z s)--instance Traversable (Signal' clk) where-  traverse = traverse#--{-# NOINLINE traverse# #-}-traverse# :: Applicative f => (a -> f b) -> Signal' clk a -> f (Signal' clk b)-traverse# f (a :- s) = (:-) <$> f a <*> traverse# f s--infixr 2 .||.--- | The above type is a generalisation 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 generalisation 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 (&&)---- | The above type is a generalisation for:------ @--- __not1__ :: 'CLaSH.Signal.Signal' 'Bool' -> 'CLaSH.Signal.Signal' 'Bool'--- @------ It is a version of 'not' that operates on 'CLaSH.Signal.Signal's of 'Bool'-not1 :: Functor f => f Bool -> f Bool-not1 = fmap not-{-# DEPRECATED not1 "'not1' will be removed in clash-prelude-1.0, use \"fmap not\" instead." #-}--{-# NOINLINE register# #-}-register# :: SClock clk -> a -> Signal' clk a -> Signal' clk a-register# _ i s = i :- s--{-# NOINLINE regEn# #-}-regEn# :: SClock clk -> a -> Signal' clk Bool -> Signal' clk a -> Signal' clk a-regEn# _ = go-  where-    -- 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.-    go o ~(e :- es) as@(~(x :- xs)) =-      o `seqX` o :- (as `seq` if e then go x es xs else go o es xs)--{-# INLINE mux #-}--- | The above type is a generalisation 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 signal #-}--- | The above type is a generalisation for:------ @--- __signal__ :: a -> 'CLaSH.Signal.Signal' a--- @------ Create a constant 'CLaSH.Signal.Signal' from a combinational value------ >>> sampleN 5 (signal 4 :: Signal Int)--- [4,4,4,4,4]-signal :: Applicative f => a -> f a-signal = pure--infix 4 .==.--- | The above type is a generalisation 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 generalisation 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 (/=)---- | The above type is a generalisation for:------ @--- __compare1__ :: 'Ord' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Ordering'--- @------ It is a version of 'compare' that returns a 'CLaSH.Signal.Signal' of 'Ordering'-compare1 :: (Ord a, Applicative f) => f a -> f a -> f Ordering-compare1 = liftA2 compare-{-# DEPRECATED compare1 "'compare1' will be removed in clash-prelude-1.0, use \"liftA2 compare\" instead." #-}--infix 4 .<.--- | The above type is a generalisation 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 generalisation 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 generalisation 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 generalisation 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 (>=)---- | The above type is a generalisation for:------ @--- __fromEnum1__ :: 'Enum' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int'--- @------ It is a version of 'fromEnum' that returns a CLaSH.Signal.Signal' of 'Int'-fromEnum1 :: (Enum a, Functor f) => f a -> f Int-fromEnum1 = fmap fromEnum-{-# DEPRECATED fromEnum1 "'fromEnum1' will be removed in clash-prelude-1.0, use \"fmap fromEnum\" instead." #-}---- | The above type is a generalisation for:------ @--- __toRational1__ :: 'Real' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Rational'--- @------ It is a version of 'toRational' that returns a 'CLaSH.Signal.Signal' of 'Rational'-toRational1 :: (Real a, Functor f) => f a -> f Rational-toRational1 = fmap toRational-{-# DEPRECATED toRational1 "'toRational1' will be removed in clash-prelude-1.0, use \"fmap toRational\" instead." #-}---- | The above type is a generalisation for:------ @--- __toInteger1__ :: 'Integral' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Integer'--- @------ It is a version of 'toRational' that returns a 'CLaSH.Signal.Signal' of 'Integer'-toInteger1 :: (Integral a, Functor f) => f a -> f Integer-toInteger1 = fmap toInteger-{-# DEPRECATED toInteger1 "'toInteger1' will be removed in clash-prelude-1.0, use \"fmap toInteger\" instead." #-}---- | The above type is a generalisation for:------ @--- __testBit1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'Bool'--- @------ It is a version of 'testBit' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing--- argument, and a result of 'CLaSH.Signal.Signal' of 'Bool'-testBit1 :: (Bits a, Applicative f) => f a -> f Int -> f Bool-testBit1 = liftA2 testBit-{-# DEPRECATED testBit1 "'testBit1' will be removed in clash-prelude-1.0, use \"liftA2 testBit\" instead." #-}---- | The above type is a generalisation for:------ @--- __popCount1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int'--- @------  It is a version of 'popCount' that returns a 'CLaSH.Signal.Signal' of 'Int'-popCount1 :: (Bits a, Functor f) => f a -> f Int-popCount1 = fmap popCount-{-# DEPRECATED popCount1 "'popCount1' will be removed in clash-prelude-1.0, use \"fmap popCount\" instead." #-}---- | The above type is a generalisation for:------ @--- __shift1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a'--- @------ It is a version of 'shift' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument-shift1 :: (Bits a, Applicative f) => f a -> f Int -> f a-shift1 = liftA2 shift-{-# DEPRECATED shift1 "'shift1' will be removed in clash-prelude-1.0, use \"liftA2 shift\" instead." #-}---- | The above type is a generalisation for:------ @--- __rotate1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a'--- @------ It is a version of 'rotate' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument-rotate1 :: (Bits a, Applicative f) => f a -> f Int -> f a-rotate1 = liftA2 rotate-{-# DEPRECATED rotate1 "'rotate1' will be removed in clash-prelude-1.0, use \"liftA2 rotate\" instead." #-}---- | The above type is a generalisation for:------ @--- __setBit1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a'--- @------ It is a version of 'setBit' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument-setBit1 :: (Bits a, Applicative f) => f a -> f Int -> f a-setBit1 = liftA2 setBit-{-# DEPRECATED setBit1 "'setBit1' will be removed in clash-prelude-1.0, use \"liftA2 setBit\" instead." #-}---- | The above type is a generalisation for:------ @--- __clearBit1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a'--- @------ It is a version of 'clearBit' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument-clearBit1 :: (Bits a, Applicative f) => f a -> f Int -> f a-clearBit1 = liftA2 clearBit-{-# DEPRECATED clearBit1 "'clearBit1' will be removed in clash-prelude-1.0, use \"liftA2 clearBit\" instead." #-}---- | The above type is a generalisation for:------ @--- __shiftL1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a'--- @------ It is a version of 'shiftL' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument-shiftL1 :: (Bits a, Applicative f) => f a -> f Int -> f a-shiftL1 = liftA2 shiftL-{-# DEPRECATED shiftL1 "'shiftL1' will be removed in clash-prelude-1.0, use \"liftA2 shiftL\" instead." #-}---- | The above type is a generalisation for:------ @--- __unsafeShiftL1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a'--- @------ It is a version of 'unsafeShiftL' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument-unsafeShiftL1 :: (Bits a, Applicative f) => f a -> f Int -> f a-unsafeShiftL1 = liftA2 unsafeShiftL-{-# DEPRECATED unsafeShiftL1 "'unsafeShiftL1' will be removed in clash-prelude-1.0, use \"liftA2 unsafeShiftL\" instead." #-}---- | The above type is a generalisation for:------ @--- __shiftR1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a'--- @------ It is a version of 'shiftR' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument-shiftR1 :: (Bits a, Applicative f) => f a -> f Int -> f a-shiftR1 = liftA2 shiftR-{-# DEPRECATED shiftR1 "'shiftR1' will be removed in clash-prelude-1.0, use \"liftA2 shiftR\" instead." #-}---- | The above type is a generalisation for:------ @--- __unsafeShiftR1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a'--- @------ It is a version of 'unsafeShiftR' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument-unsafeShiftR1 :: (Bits a, Applicative f) => f a -> f Int -> f a-unsafeShiftR1 = liftA2 unsafeShiftR-{-# DEPRECATED unsafeShiftR1 "'unsafeShiftR1' will be removed in clash-prelude-1.0, use \"liftA2 unsafeShiftR\" instead." #-}---- | The above type is a generalisation for:------ @--- __rotateL1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a'--- @------ It is a version of 'rotateL' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument-rotateL1 :: (Bits a, Applicative f) => f a -> f Int -> f a-rotateL1 = liftA2 rotateL-{-# DEPRECATED rotateL1 "'rotateL1' will be removed in clash-prelude-1.0, use \"liftA2 rotateL\" instead." #-}---- | The above type is a generalisation for:------ @--- __rotateR1__ :: 'Bits' a => 'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' 'Int' -> 'CLaSH.Signal.Signal' 'a'--- @------ It is a version of 'rotateR' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument-rotateR1 :: (Bits a, Applicative f) => f a -> f Int -> f a-rotateR1 = liftA2 rotateR-{-# DEPRECATED rotateR1 "'rotateR1' will be removed in clash-prelude-1.0, use \"liftA2 rotateR\" instead." #-}--instance Fractional a => Fractional (Signal' clk a) where-  (/)          = liftA2 (/)-  recip        = fmap recip-  fromRational = signal# . fromRational--instance Arbitrary a => Arbitrary (Signal' clk a) where-  arbitrary = liftA2 (:-) arbitrary arbitrary--instance CoArbitrary a => CoArbitrary (Signal' clk a) where-  coarbitrary xs gen = do-    n <- arbitrary-    coarbitrary (take (abs n) (sample_lazy xs)) gen---- | The above type is a generalisation for:------ @--- __testFor__ :: 'Int' -> 'CLaSH.Signal.Signal' Bool -> 'Property'--- @------ @testFor n s@ tests the signal @s@ for @n@ cycles.-testFor :: Foldable f => Int -> f Bool -> Property-testFor n = property . and . take n . sample---- * List \<-\> Signal conversion (not synthesisable)---- | A 'force' that lazily returns exceptions-forceNoException :: NFData a => a -> IO a-forceNoException x = catch (evaluate (force x)) (\(e :: XException) -> return (throw e))--headStrictCons :: NFData a => a -> [a] -> [a]-headStrictCons x xs = unsafeDupablePerformIO ((:) <$> forceNoException x <*> pure xs)--headStrictSignal :: NFData a => a -> Signal' clk a -> Signal' clk a-headStrictSignal x xs = unsafeDupablePerformIO ((:-) <$> forceNoException x <*> pure xs)---- | The above type is a generalisation 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 synthesisable-sample :: (Foldable f, NFData a) => f a -> [a]-sample = foldr headStrictCons []---- | The above type is a generalisation 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 synthesisable-sampleN :: (Foldable f, NFData 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 synthesisable-fromList :: NFData a => [a] -> Signal' clk a-fromList = Prelude.foldr headStrictSignal (errorX "finite list")---- * Simulation functions (not synthesisable)---- | Simulate a (@'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' b@) function--- given a list of samples of type @a@------ >>> simulate (register 8) [1, 2, 3]--- [8,1,2,3...--- ...------ __NB__: This function is not synthesisable-simulate :: (NFData a, NFData b) => (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b]-simulate f = sample . f . fromList---- | The above type is a generalisation 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 synthesisable-sample_lazy :: Foldable f => f a -> [a]-sample_lazy = foldr (:) []---- | The above type is a generalisation 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 synthesisable-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])--- [1,2]------ __NB__: This function is not synthesisable-fromList_lazy :: [a] -> Signal' clk a-fromList_lazy = Prelude.foldr (:-) (error "finite list")---- * Simulation functions (not synthesisable)---- | Simulate a (@'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' b@) function--- given a list of samples of type @a@------ >>> simulate (register 8) [1, 2, 3]--- [8,1,2,3...--- ...------ __NB__: This function is not synthesisable-simulate_lazy :: (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b]-simulate_lazy f = sample_lazy . f . fromList_lazy
− src/CLaSH/Sized/BitVector.hs 
@@ -1,31 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE MagicHash #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Sized.BitVector-  ( -- * Datatypes-    BitVector-  , Bit-    -- * Accessors-    -- ** Length information-  , size#-  , maxIndex#-    -- * Construction-    -- ** Initialisation-  , high-  , low-  , bLit-    -- ** Concatenation-  , (++#)-  )-where--import CLaSH.Sized.Internal.BitVector
− src/CLaSH/Sized/Fixed.hs 
@@ -1,963 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--Fixed point numbers--* The 'Num' operators for the given types saturate on overflow,-  and use truncation as the rounding method.-* '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'.-* 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 introduces a sign bias!--* Truncation for positive numbers effectively results in: round towards zero.-* Truncation for negative numbers effectively results in: round towards -infinity.--}--{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Sized.Fixed-  ( -- * 'SFixed': 'Signed' 'Fixed' point numbers-    SFixed, sf, unSF-    -- * 'UFixed': 'Unsigned' 'Fixed' point numbers-  , UFixed, uf, unUF-      -- * Division-  , divide-    -- * Compile-time 'Double' conversion-  , fLit-    -- * Run-time 'Double' conversion (not synthesisable)-  , fLitR-    -- * 'Fixed' point wrapper-  , Fixed (..), resizeF, fracShift-    -- * Constraint synonyms-    -- $constraintsynonyms--    -- ** Constraint synonyms for 'SFixed'-  , NumSFixedC, ENumSFixedC, FracSFixedC, ResizeSFC, DivideSC-    -- ** Constraint synonyms for 'UFixed'-  , NumUFixedC, ENumUFixedC, FracUFixedC, ResizeUFC, DivideUC-    -- ** Constraint synonyms for 'Fixed' wrapper-  , NumFixedC, ENumFixedC, FracFixedC, ResizeFC, DivideC-    -- * Proxy-  , asRepProxy, asIntProxy-  )-where--import Control.DeepSeq            (NFData)-import Control.Arrow              ((***), second)-import Data.Bits                  (Bits (..), FiniteBits)-import Data.Data                  (Data)-import Data.Default               (Default (..))-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 GHC.TypeLits               (KnownNat, Nat, type (+), natVal)-import GHC.TypeLits.Extra         (Max)-import Language.Haskell.TH        (Q, TExp, TypeQ, appT, conT, litT, mkName,-                                   numTyLit, sigE)-import Language.Haskell.TH.Syntax (Lift(..))-import Test.QuickCheck            (Arbitrary, CoArbitrary)--import CLaSH.Class.BitPack        (BitPack (..))-import CLaSH.Class.Num            (ExtendingNum (..), SaturatingNum (..),-                                   SaturationMode (..), boundedPlus, boundedMin,-                                   boundedMult)-import CLaSH.Class.Resize         (Resize (..))-import CLaSH.Promoted.Nat         (SNat)-import CLaSH.Prelude.BitIndex     (msb, split)-import CLaSH.Prelude.BitReduction (reduceAnd, reduceOr)-import CLaSH.Sized.BitVector      (BitVector, (++#))-import CLaSH.Sized.Signed         (Signed)-import CLaSH.Sized.Unsigned       (Unsigned)-import CLaSH.XException           (ShowX (..), showsPrecXWith)--{- $setup->>> :set -XDataKinds->>> :set -XTemplateHaskell->>> import CLaSH.Prelude->>> let n = $$(fLit pi) :: SFixed 4 4--}---- | 'Fixed'-point number------ Where:------ * @rep@ is the underlying representation------ * @int@ is the number of bits used to represent the integer part------ * @frac@ is the number of bits used to represent the fractional part------ 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 { unFixed :: rep (int + frac) }--deriving instance NFData (rep (int + frac)) => NFData (Fixed rep int frac)-deriving instance (Typeable rep, Typeable int, Typeable frac-                  , 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)-deriving instance CoArbitrary (rep (int + frac)) => CoArbitrary (Fixed rep int frac)-deriving instance FiniteBits (rep (int + frac)) => FiniteBits (Fixed rep int frac)---- | Instance functions do not saturate.--- Meaning that \"@`'shiftL'` 1 == 'satMult' 'SatWrap' 2'@\""-deriving instance Bits (rep (int + frac)) => Bits (Fixed rep int frac)---- | Signed 'Fixed'-point number, with @int@ integer bits (including sign-bit)--- and @frac@ fractional bits.------ * The range 'SFixed' @int@ @frac@ numbers is: [-(2^(@int@ -1)) ..--- 2^(@int@-1) - 2^-@frac@ ]--- * The resolution of 'SFixed' @int@ @frac@ numbers is: 2^@frac@--- * The 'Num' operators for this type saturate on overflow,---   and use truncation as the rounding method.------ >>>  maxBound :: SFixed 3 4--- 3.9375--- >>> minBound :: SFixed 3 4--- -4.0--- >>> read (show (maxBound :: SFixed 3 4)) :: SFixed 3 4--- 3.9375--- >>> 1 + 2 :: SFixed 3 4--- 3.0--- >>> 2 + 3 :: SFixed 3 4--- 3.9375--- >>> (-2) + (-3) :: SFixed 3 4--- -4.0--- >>> 1.375 * (-0.8125) :: SFixed 3 4--- -1.125--- >>> (1.375 :: SFixed 3 4) `times` (-0.8125 :: SFixed 3 4) :: SFixed 6 8--- -1.1171875--- >>> (2 :: SFixed 3 4) `plus` (3 :: SFixed 3 4) :: SFixed 4 4--- 5.0--- >>> (-2 :: SFixed 3 4) `plus` (-3 :: SFixed 3 4) :: SFixed 4 4--- -5.0-type SFixed = Fixed Signed---- | Unsigned 'Fixed'-point number, with @int@ integer bits and @frac@--- fractional bits------ * The range 'UFixed' @int@ @frac@ numbers is: [0 .. 2^@int@ - 2^-@frac@ ]--- * The resolution of 'UFixed' @int@ @frac@ numbers is: 2^@frac@--- * The 'Num' operators for this type saturate on overflow,---   and use truncation as the rounding method.------ >>> maxBound :: UFixed 3 4--- 7.9375--- >>> minBound :: UFixed 3 4--- 0.0--- >>> 1 + 2 :: UFixed 3 4--- 3.0--- >>> 2 + 6 :: UFixed 3 4--- 7.9375--- >>> 1 - 3 :: UFixed 3 4--- 0.0--- >>> 1.375 * 0.8125 :: UFixed 3 4--- 1.0625--- >>> (1.375 :: UFixed 3 4) `times` (0.8125 :: UFixed 3 4) :: UFixed 6 8--- 1.1171875--- >>> (2 :: UFixed 3 4) `plus` (6 :: UFixed 3 4) :: UFixed 4 4--- 8.0------ However, 'minus' does not saturate to 'minBound' on underflow:------ >>> (1 :: UFixed 3 4) `minus` (3 :: UFixed 3 4) :: UFixed 4 4--- 14.0-type UFixed = Fixed Unsigned--{-# INLINE sf #-}--- | Treat a 'Signed' integer as a @Signed@ 'Fixed'-@point@ integer------ >>> sf d4 (-22 :: Signed 7)--- -1.375-sf :: SNat frac           -- ^ Position of the virtual @point@-   -> Signed (int + frac) -- ^ The 'Signed' integer-   -> SFixed int frac-sf _ fRep = Fixed fRep--{-# INLINE unSF #-}--- | See the underlying representation of a Signed Fixed-point integer-unSF :: SFixed int frac-     -> Signed (int + frac)-unSF (Fixed fRep) = fRep--{-# INLINE uf #-}--- | Treat an 'Unsigned' integer as a @Unsigned@ 'Fixed'-@point@ number------ >>> uf d4 (92 :: Unsigned 7)--- 5.75-uf :: SNat frac             -- ^ Position of the virtual @point@-   -> Unsigned (int + frac) -- ^ The 'Unsigned' integer-   -> UFixed int frac-uf _ fRep = Fixed fRep--{-# INLINE unUF #-}--- | See the underlying representation of an Unsigned Fixed-point integer-unUF :: UFixed int frac-     -> Unsigned (int + frac)-unUF (Fixed fRep) = fRep--{-# INLINE asRepProxy #-}--- | 'Fixed' as a 'Proxy' for it's representation type @rep@-asRepProxy :: Fixed rep int frac -> Proxy rep-asRepProxy _ = Proxy--{-# INLINE asIntProxy #-}--- | 'Fixed' as a 'Proxy' for the number of integer bits @int@-asIntProxy :: Fixed rep int frac -> Proxy int-asIntProxy _ = Proxy---- | Get the position of the virtual @point@ of a 'Fixed'-@point@ number-fracShift :: KnownNat frac => Fixed rep int frac -> Int-fracShift fx = fromInteger (natVal fx)--instance ( size ~ (int + frac), KnownNat frac, Integral (rep size)-         ) => Show (Fixed rep int frac) where-  show f@(Fixed fRep) =-      i ++ "." ++ (uncurry pad . second (show . numerator) .-                   fromJust . find ((==1) . denominator . snd) .-                   iterate (succ *** (*10)) . (,) 0 $ (nom % denom))-    where-      pad n str = replicate (n - length str) '0' ++ str--      nF        = fracShift f-      fRepI     = toInteger fRep-      fRepI_abs = abs fRepI-      i         = if fRepI < 0 then '-' : show (fRepI_abs `shiftR` nF)-                               else show (fRepI `shiftR` nF)-      nom       = if fRepI < 0 then fRepI_abs .&. ((2 ^ nF) - 1)-                               else fRepI .&. ((2 ^ nF) - 1)-      denom     = 2 ^ nF--instance ( size ~ (int + frac), KnownNat frac, Integral (rep size)-         ) => ShowX (Fixed rep int frac) where-  showsPrecX = showsPrecXWith showsPrec---- | None of the 'Read' class' methods are synthesisable.-instance (size ~ (int + frac), KnownNat frac, Bounded (rep size), Integral (rep size))-      => Read (Fixed rep int frac) where-  readPrec = fLitR <$> readPrec--{- $constraintsynonyms #constraintsynonyms#-Writing polymorphic functions over fixed point numbers can be a potentially-verbose due to the many class constraints induced by the functions and operators-of this module.--Writing a simple multiply-and-accumulate function can already give rise to many-lines of constraints:--@-mac :: ( 'GHC.TypeLits.KnownNat' frac-       , 'GHC.TypeLits.KnownNat' (frac + frac)-       , 'GHC.TypeLits.KnownNat' (int + frac)-       , 'GHC.TypeLits.KnownNat' (1 + (int + frac))-       , 'GHC.TypeLits.KnownNat' ((int + frac) + (int + frac))-       , ((int + int) + (frac + frac)) ~ ((int + frac) + (int + frac))-       )-    => 'SFixed' int frac-    -> 'SFixed' int frac-    -> 'SFixed' int frac-    -> 'SFixed' int frac-mac s x y = s + (x * y)-@--But with constraint synonyms, you can write the type signature like this:--@-mac1 :: 'NumSFixedC' int frac-    => 'SFixed' int frac-    -> 'SFixed' int frac-    -> 'SFixed' int frac-    -> 'SFixed' int frac-mac1 s x y = s + (x * y)-@--Where 'NumSFixedC' refers to the @Constraints@ needed by the operators of-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-really want to use constraint kinds:--@-mac2 :: ( 'GHC.TypeLits.KnownNat' frac1-        , 'GHC.TypeLits.KnownNat' frac2-        , 'GHC.TypeLits.KnownNat' frac3-        , 'GHC.TypeLits.KnownNat' (Max frac1 frac2)-        , 'GHC.TypeLits.KnownNat' (int1 + frac1)-        , 'GHC.TypeLits.KnownNat' (int2 + frac2)-        , 'GHC.TypeLits.KnownNat' (int3 + frac3)-        , 'GHC.TypeLits.KnownNat' (frac1 + frac2)-        , 'GHC.TypeLits.KnownNat' (Max (frac1 + frac2) frac3)-        , 'GHC.TypeLits.KnownNat' (((int1 + int2) + (frac1 + frac2)) + (int3 + frac3))-        , 'GHC.TypeLits.KnownNat' ((int1 + int2) + (frac1 + frac2))-        , 'GHC.TypeLits.KnownNat' (1 + Max (int1 + frac1) (int2 + frac2))-        , 'GHC.TypeLits.KnownNat' (1 + Max (int1 + int2) int3 + Max (frac1 + frac2) frac3)-        , 'GHC.TypeLits.KnownNat' ((1 + Max int1 int2) + Max frac1 frac2)-        , 'GHC.TypeLits.KnownNat' ((1 + Max ((int1 + int2) + (frac1 + frac2)) (int3 + frac3)))-        , ((int1 + frac1) + (int2 + frac2)) ~ ((int1 + int2) + (frac1 + frac2))-        , (((int1 + int2) + int3) + ((frac1 + frac2) + frac3)) ~ (((int1 + int2) + (frac1 + frac2)) + (int3 + frac3))-        )-     => 'SFixed' int1 frac1-     -> 'SFixed' int2 frac2-     -> 'SFixed' int3 frac3-     -> 'SFixed' (1 + Max (int1 + int2) int3) (Max (frac1 + frac2) frac3)-mac2 x y s = (x \`times\` y) \`plus\` s-@--Which, with the proper constraint kinds can be reduced to:--@-mac3 :: ( 'ENumSFixedC' int1 frac1 int2 frac2-        , 'ENumSFixedC' (int1 + int2) (frac1 + frac2) int3 frac3-        )-     => 'SFixed' int1 frac1-     -> 'SFixed' int2 frac2-     -> 'SFixed' int3 frac3-     -> 'SFixed' (1 + Max (int1 + int2) int3) (Max (frac1 + frac2) frac3)-mac3 x y s = (x \`times\` y) \`plus\` s-@--}---- | Constraint for the 'ExtendingNum' instance of 'Fixed'-type ENumFixedC rep int1 frac1 int2 frac2-  = ( Bounded  (rep ((1 + Max int1 int2) + Max frac1 frac2))-    , Num      (rep ((1 + Max int1 int2) + Max frac1 frac2))-    , Bits     (rep ((1 + Max int1 int2) + Max frac1 frac2))-    , ExtendingNum (rep (int1 + frac1)) (rep (int2 + frac2))-    , MResult (rep (int1 + frac1)) (rep (int2 + frac2)) ~-              rep ((int1 + int2) + (frac1 + frac2))-    , KnownNat int1-    , KnownNat int2-    , KnownNat frac1-    , KnownNat frac2-    , Resize   rep-    )---- | Constraint for the 'ExtendingNum' instance of 'SFixed'-type ENumSFixedC int1 frac1 int2 frac2-  = ( KnownNat (int2 + frac2)-    , KnownNat (1 + Max int1 int2 + Max frac1 frac2)-    , KnownNat (Max frac1 frac2)-    , KnownNat (1 + Max int1 int2)-    , KnownNat (int1 + frac1)-    , KnownNat frac2-    , KnownNat int2-    , KnownNat frac1-    , KnownNat int1-    )---- | Constraint for the 'ExtendingNum' instance of 'UFixed'-type ENumUFixedC int1 frac1 int2 frac2 =-     ENumSFixedC int1 frac1 int2 frac2---- | When used in a polymorphic setting, use the following--- <CLaSH-Sized-Fixed.html#constraintsynonyms Constraint synonyms> for less--- verbose type signatures:------ * @'ENumFixedC'  rep frac1 frac2 size1 size2@ for: 'Fixed'--- * @'ENumSFixedC' int1 frac1 int2 frac2@       for: 'SFixed'--- * @'ENumUFixedC' int1 frac1 int2 frac2@       for: 'UFixed'-instance ENumFixedC rep int1 frac1 int2 frac2 =>-  ExtendingNum (Fixed rep int1 frac1) (Fixed rep int2 frac2) where-  type AResult (Fixed rep int1 frac1) (Fixed rep int2 frac2) =-               Fixed rep (1 + Max int1 int2) (Max frac1 frac2)-  plus (Fixed f1) (Fixed f2) =-    let sh1 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @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-        f2R = shiftL (resize f2) sh2 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))-    in  Fixed (f1R + f2R)-  minus (Fixed f1) (Fixed f2) =-    let sh1 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @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-        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) =-               Fixed rep (int1 + int2) (frac1 + frac2)-  times (Fixed fRep1) (Fixed fRep2) = Fixed (times fRep1 fRep2)---- | Constraint for the 'Num' instance of 'Fixed'-type NumFixedC rep int frac-  = ( SaturatingNum (rep (int + frac))-    , ExtendingNum (rep (int + frac)) (rep (int + frac))-    , MResult (rep (int + frac)) (rep (int + frac)) ~-              rep ((int + int) + (frac + frac))-    , BitSize (rep ((int + int) + (frac + frac))) ~-              (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))-    , Resize  rep-    , KnownNat int-    , KnownNat frac-    )---- | Constraint for the 'Num' instance of 'SFixed'-type NumSFixedC int frac =-  ( KnownNat ((int + int) + (frac + frac))-  , KnownNat (frac + frac)-  , KnownNat (int + int)-  , KnownNat (int + frac)-  , KnownNat frac-  , KnownNat int-  )---- | Constraint for the 'Num' instance of 'UFixed'-type NumUFixedC int frac =-     NumSFixedC int frac---- | The operators of this instance saturate on overflow, and use truncation as--- the rounding method.------ When used in a polymorphic setting, use the following--- <CLaSH-Sized-Fixed.html#constraintsynonyms Constraint synonyms> for less--- verbose type signatures:------ * @'NumFixedC' frac rep size@ for: @'Fixed' frac rep size@--- * @'NumSFixedC' int frac@     for: @'SFixed' int frac@--- * @'NumUFixedC' int frac@     for: @'UFixed' int frac@-instance (NumFixedC rep int frac) => Num (Fixed rep int frac) where-  (+)              = boundedPlus-  (*)              = boundedMult-  (-)              = boundedMin-  negate (Fixed a) = Fixed (negate a)-  abs    (Fixed a) = Fixed (abs a)-  signum (Fixed a) = Fixed (signum a)-  fromInteger i    = let fSH = fromInteger (natVal (Proxy @frac))-                         res = Fixed (fromInteger i `shiftL` fSH)-                     in  res--instance (BitPack (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)--instance (Lift (rep (int + frac)), KnownNat frac, KnownNat int, Typeable rep) =>-  Lift (Fixed rep int frac) where-  lift f@(Fixed fRep) = sigE [| Fixed fRep |]-                          (decFixed (typeRep (asRepProxy f))-                                    (natVal (asIntProxy f))-                                    (natVal f))--decFixed :: TypeRep -> Integer -> Integer -> TypeQ-decFixed r i f = do-  foldl appT (conT ''Fixed) [ conT (mkName (show r))-                            , litT (numTyLit i)-                            , litT (numTyLit f)-                            ]---- | Constraint for the 'resizeF' function-type ResizeFC rep int1 frac1 int2 frac2-  = ( Resize   rep-    , Ord      (rep (int1 + frac1))-    , Num      (rep (int1 + frac1))-    , Bits     (rep (int1 + frac1))-    , Bits     (rep (int2 + frac2))-    , Bounded  (rep (int2 + frac2))-    , KnownNat int1-    , KnownNat frac1-    , KnownNat int2-    , KnownNat frac2-    )---- | Constraint for the 'resizeF' function, specialized for 'SFixed'-type ResizeSFC int1 frac1 int2 frac2-  = ( KnownNat int1-    , KnownNat frac1-    , KnownNat int2-    , KnownNat frac2-    , KnownNat (int2 + frac2)-    , KnownNat (int1 + frac1)-    )---- | Constraint for the 'resizeF' function, specialized for 'UFixed'-type ResizeUFC int1 frac1 int2 frac2 =-     ResizeSFC int1 frac1 int2 frac2--{-# INLINE resizeF #-}--- | Saturating resize operation, truncates for rounding------ >>> 0.8125 :: SFixed 3 4--- 0.8125--- >>> resizeF (0.8125 :: SFixed 3 4) :: SFixed 2 3--- 0.75--- >>> 3.4 :: SFixed 3 4--- 3.375--- >>> resizeF (3.4 :: SFixed 3 4) :: SFixed 2 3--- 1.875--- >>> maxBound :: SFixed 2 3--- 1.875------ When used in a polymorphic setting, use the following--- <#constraintsynonyms Constraint synonyms> for less verbose type signatures:------ * @'ResizeFC' rep int1 frac1 int2 frac2@ for:---   @'Fixed' rep int1 frac1 -> 'Fixed' rep int2 frac2@------ * @'ResizeSFC' int1 frac1 int2 frac2@ for:---   @'SFixed' int1 frac1 -> 'SFixed' int2 frac2@------ * @'ResizeUFC' rep int1 frac1 int2 frac2@ for:---   @'UFixed' int1 frac1 -> 'UFixed' int2 frac2@-resizeF :: forall rep int1 frac1 int2 frac2 . ResizeFC rep int1 frac1 int2 frac2-        => Fixed rep int1 frac1-        -> Fixed rep int2 frac2-resizeF (Fixed fRep) = Fixed sat-  where-    fMin  = minBound :: rep (int2 + frac2)-    fMax  = maxBound :: rep (int2 + frac2)-    argSZ = natVal (Proxy @(int1 + frac1))-    resSZ = natVal (Proxy @(int2 + frac2))--    argFracSZ = fromInteger (natVal (Proxy @frac1))-    resFracSZ = fromInteger (natVal (Proxy @frac2))--    -- All size and frac comparisons and related if-then-else statements should-    -- be optimized away by the compiler-    sat = if argSZ <= resSZ-            -- if the argument is smaller than the result, resize before shift-            then if argFracSZ <= resFracSZ-                    then resize fRep `shiftL` (resFracSZ - argFracSZ)-                    else resize fRep `shiftR` (argFracSZ - resFracSZ)-            -- if the argument is bigger than the result, shift before resize-            else let mask = complement (resize fMax) :: rep (int1 + frac1)-                 in if argFracSZ <= resFracSZ-                       then let shiftedL         = fRep `shiftL`-                                                   (resFracSZ - argFracSZ)-                                shiftedL_masked  = shiftedL .&. mask-                                shiftedL_resized = resize shiftedL-                            in if fRep >= 0-                                  then if shiftedL_masked == 0-                                          then shiftedL_resized-                                          else fMax-                                  else if shiftedL_masked == mask-                                          then shiftedL_resized-                                          else fMin-                       else let shiftedR         = fRep `shiftR`-                                                   (argFracSZ - resFracSZ)-                                shiftedR_masked  = shiftedR .&. mask-                                shiftedR_resized = resize shiftedR-                            in if fRep >= 0-                                  then if shiftedR_masked == 0-                                          then shiftedR_resized-                                          else fMax-                                  else if shiftedR_masked == mask-                                          then shiftedR_resized-                                          else fMin---- | Convert, at compile-time, a 'Double' /constant/ to a 'Fixed'-point /literal/.--- The conversion saturates on overflow, and uses truncation as its rounding--- method.------ So when you type:------ @--- n = $$('fLit' pi) :: 'SFixed' 4 4--- @------ The compiler sees:------ @--- n = 'Fixed' (fromInteger 50) :: 'SFixed' 4 4--- @------ Upon evaluation you see that the value is rounded / truncated in accordance--- to the fixed point representation:------ >>> n--- 3.125------ Further examples:------ >>> sin 0.5 :: Double--- 0.479425538604203--- >>> $$(fLit (sin 0.5)) :: SFixed 1 8--- 0.4765625--- >>> atan 0.2 :: Double--- 0.19739555984988078--- >>> $$(fLit (atan 0.2)) :: SFixed 1 8--- 0.1953125--- >>> $$(fLit (atan 0.2)) :: SFixed 1 20--- 0.19739532470703125-fLit :: forall rep int frac size .-        ( size ~ (int + frac), KnownNat frac, Bounded (rep size)-        , Integral (rep size))-     => Double-     -> Q (TExp (Fixed rep int frac))-fLit a = [|| Fixed (fromInteger sat) ||]-  where-    rMax      = toInteger (maxBound :: rep size)-    rMin      = toInteger (minBound :: rep size)-    sat       = if truncated > rMax-                   then rMax-                   else if truncated < rMin-                           then rMin-                           else truncated-    truncated = truncate shifted :: Integer-    shifted   = a * (2 ^ (natVal (Proxy @frac)))---- | Convert, at run-time, a 'Double' to a 'Fixed'-point.------ __NB__: this functions is /not/ synthesisable------ = 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 synthesisable function like 'CLaSH.Prelude.ROM.File.asyncRomFile'.--- For example, given a file @Data.txt@ containing:------ @--- 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,--- @createRomFile@, which uses 'fLitR':------ @createRomFile.hs@:------ @--- module Main where------ import CLaSH.Prelude--- import System.Environment--- import qualified Data.List as L------ createRomFile :: KnownNat n => (Double -> BitVector n)---               -> 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)------ toSFixed8_8 :: Double -> SFixed 8 8--- toSFixed8_8 = 'fLitR'------ main :: IO ()--- main = do---   [fileR,fileW] <- getArgs---   createRomFile ('pack' . toSFixed8_8) fileR fileW--- @------ We then compile this to an executable:------ @--- \$ 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--- binary data:------ @--- \$ ./createRomFile \"Data.txt\" \"Data.bin\"--- @------ Which results in a @Data.bin@ file containing:------ @--- 0000000100110011--- 0000001000000000--- 0000001100000000--- 0000010000000000--- 1111111100000000--- 1111111000000000--- 1111110010000000--- 1111110000000000--- @------ We can then use this @Data.bin@ file in for our ROM:------ @--- romF :: Unsigned 3 -> Unsigned 3 -> SFixed 8 8--- romF rowAddr colAddr = 'unpack'---                      $ 'CLaSH.Prelude.ROM.File.asyncRomFile' d8 "Data.bin" ((rowAddr * 4) + colAddr)--- @------ And see that it works as expected:------ @--- __>>> romF 1 2__--- -3.5--- __>>> romF 0 0__--- 1.19921875--- @------ == Using Template Haskell------ 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/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 Language.Haskell.TH.Syntax (qRunIO)------ createRomFile :: KnownNat n => (Double -> BitVector n)---               -> 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)------ romDataFromFile :: KnownNat n => (Double -> BitVector n) -> String -> ExpQ--- romDataFromFile convert fileR = do---   let fileW = fileR L.++ ".bin"---   bvF <- qRunIO (createRomFile convert fileR fileW)---   litE (stringL fileW)--- @------ Instead of first converting @Data.txt@ to @Data.bin@, we will now use the--- @romDataFromFile@ function to convert @Data.txt@ to a new file in the proper--- format at compile-time of our new @romF'@ function:------ @--- 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---                ((rowAddr * 4) + colAddr)--- @------ And see that it works just like the @romF@ function from earlier:------ @--- __>>> romF' 1 2__--- -3.5--- __>>> romF' 0 0__--- 1.19921875--- @-fLitR :: forall rep int frac size .-         ( size ~ (int + frac), KnownNat frac, Bounded (rep size)-         , Integral (rep size))-      => Double-      -> Fixed rep int frac-fLitR a = Fixed (fromInteger sat)-  where-    rMax      = toInteger (maxBound :: rep size)-    rMin      = toInteger (minBound :: rep size)-    sat       = if truncated > rMax-                   then rMax-                   else if truncated < rMin-                           then rMin-                           else truncated-    truncated = truncate shifted :: Integer-    shifted   = a * (2 ^ (natVal (Proxy @frac)))--instance NumFixedC rep int frac => SaturatingNum (Fixed rep int frac) where-  satPlus w (Fixed a) (Fixed b) = Fixed (satPlus w a b)-  satMin  w (Fixed a) (Fixed b) = Fixed (satMin w a b)--  satMult SatWrap (Fixed a) (Fixed b) =-    let res  = a `times` b-        sh   = fromInteger (natVal (Proxy @frac))-        res' = shiftR res sh-    in  Fixed (resize res')--  satMult SatBound (Fixed a) (Fixed b) =-    let res     = a `times` b-        sh      = fromInteger (natVal (Proxy @frac))-        (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac))-    in  case isSigned a of-          True  -> let overflow = complement (reduceOr (msb rR ++# pack rL)) .|.-                                             reduceAnd (msb rR ++# pack rL)-                   in  case overflow of-                         1 -> unpack (resize (shiftR rR sh))-                         _ -> case msb rL of-                                0 -> maxBound-                                _ -> minBound-          False -> case rL of-                     0 -> unpack (resize (shiftR rR sh))-                     _ -> maxBound--  satMult SatZero (Fixed a) (Fixed b) =-    let res     = a `times` b-        sh      = fromInteger (natVal (Proxy @frac))-        (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac))-    in  case isSigned a of-          True  -> let overflow = complement (reduceOr (msb rR ++# pack rL)) .|.-                                             reduceAnd (msb rR ++# pack rL)-                   in  case overflow of-                         1 -> unpack (resize (shiftR rR sh))-                         _ -> 0-          False -> case rL of-                     0 -> unpack (resize (shiftR rR sh))-                     _ -> 0--  satMult SatSymmetric (Fixed a) (Fixed b) =-    let res     = a `times` b-        sh      = fromInteger (natVal (Proxy @frac))-        (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac))-    in  case isSigned a of-          True  -> let overflow = complement (reduceOr (msb rR ++# pack rL)) .|.-                                             reduceAnd (msb rR ++# pack rL)-                   in  case overflow of-                         1 -> unpack (resize (shiftR rR sh))-                         _ -> case msb rL of-                                0 -> maxBound-                                _ -> succ minBound-          False -> case rL of-                     0 -> unpack (resize (shiftR rR sh))-                     _ -> maxBound---- | Constraint for the 'divide' function-type DivideC rep int1 frac1 int2 frac2-  = ( Resize   rep-    , Integral (rep (((int1 + frac2) + 1) + (int2 + frac1)))-    , Bits     (rep (((int1 + frac2) + 1) + (int2 + frac1)))-    , KnownNat int1-    , KnownNat frac1-    , KnownNat int2-    , KnownNat frac2-    )---- | Constraint for the 'divide' function, specialized for 'SFixed'-type DivideSC int1 frac1 int2 frac2-  = ( KnownNat (((int1 + frac2) + 1) + (int2 + frac1))-    , KnownNat frac2-    , KnownNat int2-    , KnownNat frac1-    , KnownNat int1-    )---- | Constraint for the 'divide' function, specialized for 'UFixed'-type DivideUC int1 frac1 int2 frac2 =-     DivideSC int1 frac1 int2 frac2---- | Fixed point division------ When used in a polymorphic setting, use the following--- <#constraintsynonyms Constraint synonyms> for less verbose type signatures:------ * @'DivideC' rep int1 frac1 int2 frac2@ for:---   @'Fixed' rep int1 frac1 -> 'Fixed' rep int2 frac2 -> 'Fixed' rep (int1 + frac2 + 1) (int2 + frac1)@------ * @'DivideSC' rep int1 frac1 int2 frac2@ for:---   @'SFixed' int1 frac1 -> 'SFixed' int2 frac2 -> 'SFixed' (int1 + frac2 + 1) (int2 + frac1)@------ * @'DivideUC' rep int1 frac1 int2 frac2@ for:---   @'UFixed' int1 frac1 -> 'UFixed' int2 frac2 -> 'UFixed' (int1 + frac2 + 1) (int2 + frac1)@-divide :: DivideC rep int1 frac1 int2 frac2-       => Fixed rep int1 frac1-       -> Fixed rep int2 frac2-       -> Fixed rep (int1 + frac2 + 1) (int2 + frac1)-divide (Fixed fr1) fx2@(Fixed fr2) =-  let int2  = fromInteger (natVal (asIntProxy fx2))-      frac2 = fromInteger (natVal fx2)-      fr1'  = resize fr1-      fr2'  = resize fr2-      fr1SH = shiftL fr1' ((int2 + frac2))-      res   = fr1SH `quot` fr2'-  in  Fixed res---- | Constraint for the 'Fractional' instance of 'Fixed'-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'-type FracSFixedC int frac-  = ( NumSFixedC int frac-    , KnownNat ((int + frac + 1) + (int + frac))-    )---- | Constraint for the 'Fractional' instance of 'UFixed'-type FracUFixedC int frac-  = FracSFixedC int frac---- | The operators of this instance saturate on overflow, and use truncation as--- the rounding method.------ When used in a polymorphic setting, use the following--- <CLaSH-Sized-Fixed.html#constraintsynonyms Constraint synonyms> for less--- verbose type signatures:------ * @'FracFixedC' frac rep size@ for: @'Fixed' frac rep size@--- * @'FracSFixedC' int frac@     for: @'SFixed' int frac@--- * @'FracUFixedC' int frac@     for: @'UFixed' int frac@-instance FracFixedC rep int frac => Fractional (Fixed rep int frac) where-  f1 / f2        = resizeF (divide f1 f2)-  recip fx       = resizeF (divide (1 :: Fixed rep int frac) fx)-  fromRational r = res-    where-      res  = Fixed (fromInteger sat)-      sat  = if res' > rMax-                then rMax-                else if res' < rMin then rMin else res'--      rMax = toInteger (maxBound :: rep (int + frac))-      rMin = toInteger (minBound :: rep (int + frac))-      res' = n `div` d--      frac = fromInteger (natVal res)-      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-  toRational f@(Fixed fRep) = nom % denom-   where-     nF        = fracShift f-     denom     = 1 `shiftL` nF-     nom       = toInteger fRep
− src/CLaSH/Sized/Index.hs 
@@ -1,46 +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 MagicHash     #-}-{-# LANGUAGE TypeOperators #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Sized.Index-  (Index, bv2i)-where--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.Index---- | An alternative implementation of 'CLaSH.Class.BitPack.unpack' for the--- 'Index' data type; for when you know the size of the 'BitVector' and want--- to determine the size of the 'Index'.------ That is, the type of 'CLaSH.Class.BitPack.unpack' is:------ @--- __unpack__ :: 'BitVector' ('CLog' 2 n) -> 'Index' n--- @------ And is useful when you know the size of the 'Index', and want to get a value--- from a 'BitVector' that is large enough (@CLog 2 n@) enough to hold an--- 'Index'. Note that 'CLaSH.Class.BitPack.unpack' can fail at /run-time/ when--- the value inside the 'BitVector' is higher than 'n-1'.------ 'bv2i' on the other hand will /never/ fail at run-time, because the--- 'BitVector' argument determines the size.-bv2i :: KnownNat n => BitVector n -> Index (2^n)-bv2i = unpack#
− src/CLaSH/Sized/Internal/BitVector.hs 
@@ -1,650 +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 DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE UndecidableInstances       #-}--{-# LANGUAGE Unsafe #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Sized.Internal.BitVector-  ( -- * Datatypes-    BitVector (..)-  , Bit-    -- * Accessors-    -- ** Length information-  , size#-  , maxIndex#-    -- * Construction-    -- ** Initialisation-  , high-  , low-  , bLit-    -- ** Concatenation-  , (++#)-    -- * Reduction-  , reduceAnd#-  , reduceOr#-  , reduceXor#-    -- * Indexing-  , index#-  , replaceBit#-  , setSlice#-  , slice#-  , split#-  , msb#-  , lsb#-    -- * Type classes-    -- ** Eq-  , eq#-  , neq#-    -- ** Ord-  , lt#-  , ge#-  , gt#-  , le#-    -- ** Enum (not synthesisable)-  , enumFrom#-  , enumFromThen#-  , enumFromTo#-  , enumFromThenTo#-    -- ** Bounded-  , minBound#-  , maxBound#-    -- ** Num-  , (+#)-  , (-#)-  , (*#)-  , negate#-  , fromInteger#-    -- ** ExtendingNum-  , plus#-  , minus#-  , times#-    -- ** Integral-  , quot#-  , rem#-  , toInteger#-    -- ** Bits-  , and#-  , or#-  , xor#-  , complement#-  , shiftL#-  , shiftR#-  , rotateL#-  , rotateR#-  , popCountBV-    -- ** FiniteBits-  , countLeadingZerosBV-  , countTrailingZerosBV-    -- ** Resize-  , resize#-    -- ** QuickCheck-  , shrinkSizedUnsigned-  )-where--import Control.DeepSeq            (NFData (..))-import Control.Lens               (Index, Ixed (..), IxValue)-import Data.Bits                  (Bits (..), FiniteBits (..))-import Data.Char                  (digitToInt)-import Data.Data                  (Data)-import Data.Default               (Default (..))-import Data.Maybe                 (listToMaybe)-import Data.Proxy                 (Proxy (..))-import GHC.Integer                (smallInteger)-import GHC.Prim                   (dataToTag#)-import GHC.TypeLits               (KnownNat, Nat, type (+), type (-), natVal)-import GHC.TypeLits.Extra         (Max)-import Language.Haskell.TH        (Q, TExp, TypeQ, appT, conT, litT, numTyLit, sigE)-import Language.Haskell.TH.Syntax (Lift(..))-import Numeric                    (readInt)-import Test.QuickCheck.Arbitrary  (Arbitrary (..), CoArbitrary (..),-                                   arbitraryBoundedIntegral,-                                   coarbitraryIntegral, shrinkIntegral)--import CLaSH.Class.Num            (ExtendingNum (..), SaturatingNum (..),-                                   SaturationMode (..))-import CLaSH.Class.Resize         (Resize (..))-import CLaSH.Promoted.Nat         (SNat, snatToInteger, snatToNum)-import CLaSH.XException           (ShowX (..), showsPrecXWith)--import {-# SOURCE #-} qualified CLaSH.Sized.Vector         as V-import {-# SOURCE #-} qualified CLaSH.Sized.Internal.Index as I--{- $setup->>> :set -XTemplateHaskell->>> :set -XBinaryLiterals--}---- * Type definitions---- | A vector of bits.------ * Bit indices are descending--- * 'Num' instance performs /unsigned/ arithmetic.-newtype BitVector (n :: Nat) =-    -- | The constructor, 'BV', and  the field, 'unsafeToInteger', are not-    -- synthesisable.-    BV { unsafeToInteger :: Integer}-  deriving (Data)---- | 'Bit': a 'BitVector' of length 1-type Bit = BitVector 1---- * Instances-instance NFData (BitVector n) where-  rnf (BV i) = rnf i `seq` ()-  {-# NOINLINE rnf #-}-  -- NOINLINE is needed so that CLaSH doesn't trip on the "BitVector ~# Integer"-  -- coercion--instance KnownNat n => Show (BitVector n) where-  show bv@(BV i) = reverse . underScore . reverse $ showBV (natVal bv) i []-    where-      showBV 0 _ s = s-      showBV n v s = let (a,b) = divMod v 2-                     in  case b of-                           1 -> showBV (n - 1) a ('1':s)-                           _ -> showBV (n - 1) a ('0':s)--      underScore xs = case splitAt 5 xs of-                        ([a,b,c,d,e],rest) -> [a,b,c,d,'_'] ++ underScore (e:rest)-                        (rest,_)               -> rest-  {-# NOINLINE show #-}--instance KnownNat n => ShowX (BitVector n) where-  showsPrecX = showsPrecXWith showsPrec---- | Create a binary literal------ >>> $$(bLit "1001") :: BitVector 4--- 1001--- >>> $$(bLit "1001") :: BitVector 3--- 001------ __NB__: You can also just write:------ >>> 0b1001 :: BitVector 4--- 1001------ 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 :: KnownNat n => String -> Q (TExp (BitVector n))-bLit s = [|| fromInteger# i' ||]-  where-    i :: Maybe Integer-    i = fmap fst . listToMaybe . (readInt 2 (`elem` "01") digitToInt) $ filter (/= '_') s--    i' :: Integer-    i' = case i of-           Just j -> j-           _      -> error "Failed to parse: " s--instance Eq (BitVector n) where-  (==) = eq#-  (/=) = neq#--{-# NOINLINE eq# #-}-eq# :: BitVector n -> BitVector n -> Bool-eq# (BV v1) (BV v2) = v1 == v2--{-# NOINLINE neq# #-}-neq# :: BitVector n -> BitVector n -> Bool-neq# (BV v1) (BV v2) = v1 /= v2--instance Ord (BitVector n) where-  (<)  = lt#-  (>=) = ge#-  (>)  = gt#-  (<=) = le#--lt#,ge#,gt#,le# :: BitVector n -> BitVector n -> Bool-{-# NOINLINE lt# #-}-lt# (BV n) (BV m) = n < m-{-# NOINLINE ge# #-}-ge# (BV n) (BV m) = n >= m-{-# NOINLINE gt# #-}-gt# (BV n) (BV m) = n > m-{-# NOINLINE le# #-}-le# (BV n) (BV m) = n <= m---- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and--- 'enumFromThenTo', are not synthesisable.-instance KnownNat n => Enum (BitVector n) where-  succ           = (+# fromInteger# 1)-  pred           = (-# fromInteger# 1)-  toEnum         = fromInteger# . toInteger-  fromEnum       = fromEnum . toInteger#-  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#     :: BitVector n -> BitVector n -> [BitVector n]-enumFromThenTo# :: BitVector n -> BitVector n -> BitVector n -> [BitVector n]-enumFrom# x             = map fromInteger_INLINE [unsafeToInteger x ..]-enumFromThen# x y       = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..]-enumFromTo# x y         = map BV [unsafeToInteger x .. unsafeToInteger y]-enumFromThenTo# x1 x2 y = map BV [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y]--instance KnownNat n => Bounded (BitVector n) where-  minBound = minBound#-  maxBound = maxBound#--{-# NOINLINE minBound# #-}-minBound# :: BitVector n-minBound# = BV 0--{-# NOINLINE maxBound# #-}-maxBound# :: forall n . KnownNat n => BitVector n-maxBound# = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))-            in  BV (m-1)--instance KnownNat n => Num (BitVector n) where-  (+)         = (+#)-  (-)         = (-#)-  (*)         = (*#)-  negate      = negate#-  abs         = id-  signum bv   = resize# (reduceOr# bv)-  fromInteger = fromInteger#--(+#),(-#),(*#) :: forall n . KnownNat n => BitVector n -> BitVector n -> BitVector n-{-# NOINLINE (+#) #-}-(+#) (BV i) (BV j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))-                         z = i + j-                     in  if z >= m then BV (z - m) else BV z--{-# NOINLINE (-#) #-}-(-#) (BV i) (BV j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))-                         z = i - j-                     in  if z < 0 then BV (m + z) else BV z--{-# NOINLINE (*#) #-}-(*#) (BV i) (BV j) = fromInteger_INLINE (i * j)--{-# NOINLINE negate# #-}-negate# :: forall n . KnownNat n => BitVector n -> BitVector n-negate# (BV 0) = BV 0-negate# (BV i) = BV (sz - i)-  where-    sz = 1 `shiftL` fromInteger (natVal (Proxy @n))--{-# NOINLINE fromInteger# #-}-fromInteger# :: KnownNat n => Integer -> BitVector n-fromInteger# = fromInteger_INLINE--{-# INLINE fromInteger_INLINE #-}-fromInteger_INLINE :: forall n . KnownNat n => Integer -> BitVector n-fromInteger_INLINE i = sz `seq` BV (i `mod` sz)-  where-    sz = 1 `shiftL` fromInteger (natVal (Proxy @n))--instance (KnownNat m, KnownNat n) => ExtendingNum (BitVector m) (BitVector n) where-  type AResult (BitVector m) (BitVector n) = BitVector (Max m n + 1)-  plus  = plus#-  minus = minus#-  type MResult (BitVector m) (BitVector n) = BitVector (m + n)-  times = times#--{-# NOINLINE plus# #-}-plus# :: BitVector m -> BitVector n -> BitVector (Max m n + 1)-plus# (BV a) (BV b) = BV (a + b)--{-# NOINLINE minus# #-}-minus# :: forall m n . (KnownNat m, KnownNat n) => BitVector m -> BitVector n-                                                -> BitVector (Max m n + 1)-minus# (BV a) (BV b) =-  let sz   = fromInteger (natVal (Proxy @(Max m n + 1)))-      mask = 1 `shiftL` sz-      z    = a - b-  in  if z < 0 then BV (mask + z) else BV z--{-# NOINLINE times# #-}-times# :: BitVector m -> BitVector n -> BitVector (m + n)-times# (BV a) (BV b) = BV (a * b)--instance KnownNat n => Real (BitVector n) where-  toRational = toRational . toInteger#--instance KnownNat n => Integral (BitVector n) where-  quot        = quot#-  rem         = rem#-  div         = quot#-  mod         = rem#-  quotRem n d = (n `quot#` d,n `rem#` d)-  divMod  n d = (n `quot#` d,n `rem#` d)-  toInteger   = toInteger#--quot#,rem# :: BitVector n -> BitVector n -> BitVector n-{-# NOINLINE quot# #-}-quot# (BV i) (BV j) = BV (i `quot` j)-{-# NOINLINE rem# #-}-rem# (BV i) (BV j) = BV (i `rem` j)--{-# NOINLINE toInteger# #-}-toInteger# :: BitVector n -> Integer-toInteger# (BV i) = i--instance KnownNat n => Bits (BitVector n) where-  (.&.)             = and#-  (.|.)             = or#-  xor               = xor#-  complement        = complement#-  zeroBits          = 0-  bit i             = replaceBit# 0 i high-  setBit v i        = replaceBit# v i high-  clearBit v i      = replaceBit# v i low-  complementBit v i = replaceBit# v i (complement# (index# v i))-  testBit v i       = eq# (index# v i) high-  bitSizeMaybe v    = Just (size# v)-  bitSize           = size#-  isSigned _        = False-  shiftL v i        = shiftL# v i-  shiftR v i        = shiftR# v i-  rotateL v i       = rotateL# v i-  rotateR v i       = rotateR# v i-  popCount bv       = fromInteger (I.toInteger# (popCountBV (bv ++# (0 :: Bit))))--instance KnownNat n => FiniteBits (BitVector n) where-  finiteBitSize       = size#-  countLeadingZeros   = fromInteger . I.toInteger# . countLeadingZerosBV-  countTrailingZeros  = fromInteger . I.toInteger# . countTrailingZerosBV--countLeadingZerosBV :: KnownNat n => BitVector n -> I.Index (n+1)-countLeadingZerosBV = V.foldr (\l r -> if eq# l low then 1 + r else 0) 0 . V.bv2v-{-# INLINE countLeadingZerosBV #-}--countTrailingZerosBV :: KnownNat n => BitVector n -> I.Index (n+1)-countTrailingZerosBV = V.foldl (\l r -> if eq# r low then 1 + l else 0) 0 . V.bv2v-{-# INLINE countTrailingZerosBV #-}--{-# NOINLINE reduceAnd# #-}-reduceAnd# :: KnownNat n => BitVector n -> BitVector 1-reduceAnd# bv@(BV i) = BV (smallInteger (dataToTag# check))-  where-    check = i == maxI--    sz    = natVal bv-    maxI  = (2 ^ sz) - 1--{-# NOINLINE reduceOr# #-}-reduceOr# :: BitVector n -> BitVector 1-reduceOr# (BV i) = BV (smallInteger (dataToTag# check))-  where-    check = i /= 0--{-# NOINLINE reduceXor# #-}-reduceXor# :: BitVector n -> BitVector 1-reduceXor# (BV i) = BV (toInteger (popCount i `mod` 2))--instance Default (BitVector n) where-  def = minBound#---- * Accessors--- ** Length information-{-# NOINLINE size# #-}-size# :: KnownNat n => BitVector n -> Int-size# bv = fromInteger (natVal bv)--{-# NOINLINE maxIndex# #-}-maxIndex# :: KnownNat n => BitVector n -> Int-maxIndex# bv = fromInteger (natVal bv) - 1---- ** Indexing-{-# NOINLINE index# #-}-index# :: KnownNat n => BitVector n -> Int -> Bit-index# bv@(BV v) i-    | i >= 0 && i < sz = BV (smallInteger-                            (dataToTag#-                            (testBit v i)))-    | otherwise        = err-  where-    sz  = fromInteger (natVal bv)-    err = error $ concat [ "(!): "-                         , show i-                         , " is out of range ["-                         , show (sz - 1)-                         , "..0]"-                         ]--{-# NOINLINE msb# #-}--- | MSB-msb# :: forall n . KnownNat n => BitVector n -> Bit-msb# (BV v)-  = let i = fromInteger (natVal (Proxy @n) - 1)-    in  BV (smallInteger (dataToTag# (testBit v i)))--{-# NOINLINE lsb# #-}--- | LSB-lsb# :: BitVector n -> Bit-lsb# (BV v) = BV (smallInteger (dataToTag# (testBit v 0)))--{-# NOINLINE slice# #-}-slice# :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n)-slice# (BV i) m n = BV (shiftR (i .&. mask) n')-  where-    m' = snatToInteger m-    n' = snatToNum n--    mask = 2 ^ (m' + 1) - 1---- * Constructions--- ** Initialisation-{-# NOINLINE high #-}--- | logic '1'-high :: Bit-high = BV 1--{-# NOINLINE low #-}--- | logic '0'-low :: Bit-low = BV 0---- ** Concatenation-{-# NOINLINE (++#) #-}--- | Concatenate two 'BitVector's-(++#) :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m)-(BV v1) ++# bv2@(BV v2) = BV (v1' + v2)-  where-    v1' = shiftL v1 (fromInteger (natVal bv2))---- * Modifying BitVectors-{-# NOINLINE replaceBit# #-}-replaceBit# :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n-replaceBit# bv@(BV v) i (BV b)-    | i >= 0 && i < sz = BV (if b == 1 then setBit v i else clearBit v i)-    | otherwise        = err-  where-    sz   = fromInteger (natVal bv)-    err  = error $ concat [ "replaceBit: "-                          , show i-                          , " is out of range ["-                          , show (sz - 1)-                          , "..0]"-                          ]--{-# NOINLINE setSlice# #-}-setSlice# :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n)-          -> BitVector (m + 1 + i)-setSlice# (BV i) m n (BV j) = BV ((i .&. mask) .|. j')-  where-    m' = snatToInteger m-    n' = snatToInteger n--    j'   = shiftL j (fromInteger n')-    mask = complement ((2 ^ (m' + 1) - 1) `xor` (2 ^ n' - 1))--{-# NOINLINE split# #-}-split# :: forall n m . KnownNat n-       => BitVector (m + n) -> (BitVector m, BitVector n)-split# (BV i) = (BV l, BV 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-    l    = i `shiftR` n--and#, or#, xor# :: BitVector n -> BitVector n -> BitVector n-{-# NOINLINE and# #-}-and# (BV v1) (BV v2) = BV (v1 .&. v2)--{-# NOINLINE or# #-}-or# (BV v1) (BV v2) = BV (v1 .|. v2)--{-# NOINLINE xor# #-}-xor# (BV v1) (BV v2) = BV (v1 `xor` v2)--{-# NOINLINE complement# #-}-complement# :: KnownNat n => BitVector n -> BitVector n-complement# (BV v1) = fromInteger_INLINE (complement v1)--shiftL#, rotateL#, rotateR# :: KnownNat n-                            => BitVector n -> Int -> BitVector n--{-# NOINLINE shiftL# #-}-shiftL# (BV v) i-  | i < 0     = error-              $ "'shiftL undefined for negative number: " ++ show i-  | otherwise = fromInteger_INLINE (shiftL v i)--{-# NOINLINE shiftR# #-}-shiftR# :: BitVector n -> Int -> BitVector n-shiftR# (BV v) i-  | i < 0     = error-              $ "'shiftR undefined for negative number: " ++ show i-  | otherwise = BV (shiftR v i)--{-# NOINLINE rotateL# #-}-rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers"-rotateL# bv@(BV n) b   = fromInteger_INLINE (l .|. r)-  where-    l    = shiftL n b'-    r    = shiftR n b''--    b'   = b `mod` sz-    b''  = sz - b'-    sz   = fromInteger (natVal bv)--{-# NOINLINE rotateR# #-}-rotateR# _ b | b < 0 = error "'shiftR undefined for negative numbers"-rotateR# bv@(BV n) b   = fromInteger_INLINE (l .|. r)-  where-    l   = shiftR n b'-    r   = shiftL n b''--    b'  = b `mod` sz-    b'' = sz - b'-    sz  = fromInteger (natVal bv)--popCountBV :: forall n . KnownNat n => BitVector (n+1) -> I.Index (n+2)-popCountBV bv =-  let v = V.bv2v bv-  in  sum (V.map fromIntegral v)-{-# INLINE popCountBV #-}--instance Resize BitVector where-  resize     = resize#-  zeroExtend = extend-  signExtend = \ bv -> (case msb# bv of 0 -> id-                                        1 -> complement) 0 ++# bv-  truncateB  = resize#--{-# NOINLINE resize# #-}-resize# :: forall n m . KnownNat m => BitVector n -> BitVector m-resize# (BV i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @m))-                 in  if i >= m then fromInteger_INLINE i else BV i--instance KnownNat n => Lift (BitVector n) where-  lift bv@(BV i) = sigE [| fromInteger# i |] (decBitVector (natVal bv))-  {-# NOINLINE lift #-}--decBitVector :: Integer -> TypeQ-decBitVector n = appT (conT ''BitVector) (litT $ numTyLit n)--instance KnownNat n => SaturatingNum (BitVector n) where-  satPlus SatWrap a b = a +# b-  satPlus SatZero a b =-    let r = plus# a b-    in  case msb# r of-          0 -> resize# r-          _ -> minBound#-  satPlus _ a b =-    let r  = plus# a b-    in  case msb# r of-          0 -> resize# r-          _ -> maxBound#--  satMin SatWrap a b = a -# b-  satMin _ a b =-    let r = minus# a b-    in  case msb# r of-          0 -> resize# r-          _ -> minBound#--  satMult SatWrap a b = a *# b-  satMult SatZero a b =-    let r       = times# a b-        (rL,rR) = split# r-    in  case rL of-          0 -> rR-          _ -> minBound#-  satMult _ a b =-    let r       = times# a b-        (rL,rR) = split# r-    in  case rL of-          0 -> rR-          _ -> maxBound#--instance KnownNat n => Arbitrary (BitVector n) where-  arbitrary = arbitraryBoundedIntegral-  shrink    = shrinkSizedUnsigned---- | 'shrink' for sized unsigned types-shrinkSizedUnsigned :: (KnownNat n, Integral (p n)) => p n -> [p n]-shrinkSizedUnsigned x | natVal x < 2 = case toInteger x of-                                         1 -> [0]-                                         _ -> []-                      -- 'shrinkIntegral' uses "`quot` 2", which for sized types-                      -- less than 2 bits wide results in a division by zero.-                      ---                      -- See: https://github.com/clash-lang/clash-compiler/issues/153-                      | otherwise    = shrinkIntegral x-{-# INLINE shrinkSizedUnsigned #-}--instance KnownNat n => CoArbitrary (BitVector n) where-  coarbitrary = coarbitraryIntegral--type instance Index   (BitVector n) = Int-type instance IxValue (BitVector n) = Bit-instance KnownNat n => Ixed (BitVector n) where-  ix i f bv = replaceBit# bv i <$> f (index# bv i)
− src/CLaSH/Sized/Internal/BitVector.hs-boot 
@@ -1,16 +0,0 @@-{-|-Copyright  :  (C) 2015-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE DataKinds       #-}-{-# LANGUAGE KindSignatures  #-}-{-# LANGUAGE RoleAnnotations #-}-module CLaSH.Sized.Internal.BitVector where--import GHC.TypeLits (Nat)--type role BitVector phantom-data BitVector :: Nat -> *-type Bit = BitVector 1
− src/CLaSH/Sized/Internal/Index.hs 
@@ -1,357 +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 DeriveDataTypeable    #-}-{-# LANGUAGE KindSignatures        #-}-{-# LANGUAGE MagicHash             #-}-{-# LANGUAGE ScopedTypeVariables   #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TypeApplications      #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE UndecidableInstances  #-}--{-# LANGUAGE Unsafe #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Sized.Internal.Index-  ( -- * Datatypes-    Index (..)-    -- * Construction-  , fromSNat-    -- * Type classes-    -- ** BitConvert-  , pack#-  , unpack#-    -- ** Eq-  , eq#-  , neq#-    -- ** Ord-  , lt#-  , ge#-  , gt#-  , le#-    -- ** Enum (not synthesisable)-  , enumFrom#-  , enumFromThen#-  , enumFromTo#-  , enumFromThenTo#-    -- ** Bounded-  , maxBound#-    -- ** Num-  , (+#)-  , (-#)-  , (*#)-  , fromInteger#-    -- ** ExtendingNum-  , plus#-  , minus#-  , times#-    -- ** Integral-  , quot#-  , rem#-  , toInteger#-    -- ** Resize-  , resize#-  )-where--import Control.DeepSeq            (NFData (..))-import Data.Data                  (Data)-import Data.Default               (Default (..))-import Data.Proxy                 (Proxy (..))-import Text.Read                  (Read (..), ReadPrec)-import Language.Haskell.TH        (TypeQ, appT, conT, litT, numTyLit, sigE)-import Language.Haskell.TH.Syntax (Lift(..))-import GHC.TypeLits               (CmpNat, KnownNat, Nat, type (+), type (-),-                                   type (*), type (<=), type (^), natVal)-import GHC.TypeLits.Extra         (CLog)-import Test.QuickCheck.Arbitrary  (Arbitrary (..), CoArbitrary (..),-                                   arbitraryBoundedIntegral,-                                   coarbitraryIntegral, shrinkIntegral)--import CLaSH.Class.BitPack        (BitPack (..))-import CLaSH.Class.Num            (ExtendingNum (..), SaturatingNum (..),-                                   SaturationMode (..))-import CLaSH.Class.Resize         (Resize (..))-import {-# SOURCE #-} CLaSH.Sized.Internal.BitVector (BitVector (BV))-import CLaSH.Promoted.Nat         (SNat, snatToNum)-import CLaSH.XException           (ShowX (..), showsPrecXWith)---- | Arbitrary-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]------ >>> maxBound :: Index 8--- 7--- >>> minBound :: Index 8--- 0--- >>> read (show (maxBound :: Index 8)) :: Index 8--- 7--- >>> 1 + 2 :: Index 8--- 3--- >>> 2 + 6 :: Index 8--- *** Exception: CLaSH.Sized.Index: result 8 is out of bounds: [0..7]--- ...--- >>> 1 - 3 :: Index 8--- *** Exception: CLaSH.Sized.Index: result -2 is out of bounds: [0..7]--- ...--- >>> 2 * 3 :: Index 8--- 6--- >>> 2 * 4 :: Index 8--- *** Exception: CLaSH.Sized.Index: result 8 is out of bounds: [0..7]--- ...-newtype Index (n :: Nat) =-    -- | The constructor, 'I', and the field, 'unsafeToInteger', are not-    -- synthesisable.-    I { unsafeToInteger :: Integer }-  deriving Data--instance NFData (Index n) where-  rnf (I i) = rnf i `seq` ()-  {-# NOINLINE rnf #-}-  -- NOINLINE is needed so that CLaSH doesn't trip on the "Index ~# Integer"-  -- coercion--instance KnownNat n => BitPack (Index n) where-  type BitSize (Index n) = CLog 2 n-  pack   = pack#-  unpack = unpack#---- | Safely convert an `SNat` value to an `Index`-fromSNat :: (KnownNat m, CmpNat n m ~ 'LT) => SNat n -> Index m-fromSNat = snatToNum--{-# NOINLINE pack# #-}-pack# :: Index n -> BitVector (CLog 2 n)-pack# (I i) = BV i--{-# NOINLINE unpack# #-}-unpack# :: KnownNat n => BitVector (CLog 2 n) -> Index n-unpack# (BV i) = fromInteger_INLINE i--instance Eq (Index n) where-  (==) = eq#-  (/=) = neq#--{-# NOINLINE eq# #-}-eq# :: (Index n) -> (Index n) -> Bool-(I n) `eq#` (I m) = n == m--{-# NOINLINE neq# #-}-neq# :: (Index n) -> (Index n) -> Bool-(I n) `neq#` (I m) = n /= m--instance Ord (Index n) where-  (<)  = lt#-  (>=) = ge#-  (>)  = gt#-  (<=) = le#--lt#,ge#,gt#,le# :: Index n -> Index n -> Bool-{-# NOINLINE lt# #-}-lt# (I n) (I m) = n < m-{-# NOINLINE ge# #-}-ge# (I n) (I m) = n >= m-{-# NOINLINE gt# #-}-gt# (I n) (I m) = n > m-{-# NOINLINE le# #-}-le# (I n) (I m) = n <= m---- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and--- 'enumFromThenTo', are not synthesisable.-instance KnownNat n => Enum (Index n) where-  succ           = (+# fromInteger# 1)-  pred           = (-# fromInteger# 1)-  toEnum         = fromInteger# . toInteger-  fromEnum       = fromEnum . toInteger#-  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]-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]--instance KnownNat n => Bounded (Index n) where-  minBound = fromInteger# 0-  maxBound = maxBound#--{-# NOINLINE maxBound# #-}-maxBound# :: KnownNat n => Index n-maxBound# = let res = I (natVal res - 1) in res---- | Operators report an error on overflow and underflow-instance KnownNat n => Num (Index n) where-  (+)         = (+#)-  (-)         = (-#)-  (*)         = (*#)-  negate      = (maxBound# -#)-  abs         = id-  signum i    = if i == 0 then 0 else 1-  fromInteger = fromInteger#--(+#),(-#),(*#) :: KnownNat n => Index n -> Index n -> Index n-{-# NOINLINE (+#) #-}-(+#) (I a) (I b) = fromInteger_INLINE $ a + b--{-# NOINLINE (-#) #-}-(-#) (I a) (I b) = fromInteger_INLINE $ a - b--{-# NOINLINE (*#) #-}-(*#) (I a) (I b) = fromInteger_INLINE $ a * b--fromInteger# :: KnownNat n => Integer -> Index n-{-# NOINLINE fromInteger# #-}-fromInteger# = fromInteger_INLINE-{-# INLINE fromInteger_INLINE #-}-fromInteger_INLINE :: forall n . 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)-    err   = error ("CLaSH.Sized.Index: result " ++ show i ++-                   " is out of bounds: [0.." ++ show (bound - 1) ++ "]")--instance ExtendingNum (Index m) (Index n) where-  type AResult (Index m) (Index n) = Index (m + n - 1)-  plus  = plus#-  minus = minus#-  type MResult (Index m) (Index n) = Index (((m - 1) * (n - 1)) + 1)-  times = times#--plus#, minus# :: Index m -> Index n -> Index (m + n - 1)-{-# NOINLINE plus# #-}-plus# (I a) (I b) = I (a + b)--{-# NOINLINE minus# #-}-minus# (I a) (I b) =-  let z   = a - b-      err = error ("CLaSH.Sized.Index.minus: result " ++ show z ++-                   " is smaller than 0")-      res = if z < 0 then err else I z-  in  res--{-# NOINLINE times# #-}-times# :: Index m -> Index n -> Index (((m - 1) * (n - 1)) + 1)-times# (I a) (I b) = I (a * b)--instance (KnownNat n, 1 <= (n*2), (n*2) <= (n^2)) => SaturatingNum (Index n) where-  satPlus SatWrap a b = case plus# a b of-    z | let m = fromInteger# (natVal (Proxy @ n))-      , z >= m -> resize# (z - m)-    z -> resize# z-  satPlus SatZero a b = case plus# a b of-    z | let m = fromInteger# (natVal (Proxy @ n))-      , z >= m -> fromInteger# 0-    z -> resize# z-  satPlus _ a b = case plus# a b of-    z | let m = fromInteger# (natVal (Proxy @ n))-      , z >= m -> maxBound#-    z -> resize# z--  satMin SatWrap a b =-    if lt# a b-       then maxBound -# (b -# a) +# 1-       else a -# b--  satMin _ a b =-    if lt# a b-       then fromInteger# 0-       else a -# b--  satMult SatWrap a b = case times# a b of-    z | let m = fromInteger# (natVal (Proxy @ n))-      , z >= m -> resize# (z - m)-    z -> resize# z-  satMult SatZero a b = case times# a b of-    z | let m = fromInteger# (natVal (Proxy @ n))-      , z >= m -> fromInteger# 0-    z -> resize# z-  satMult _ a b = case times# a b of-    z | let m = fromInteger# (natVal (Proxy @ n))-      , z >= m -> maxBound#-    z -> resize# z--instance KnownNat n => Real (Index n) where-  toRational = toRational . toInteger#--instance KnownNat n => Integral (Index n) where-  quot        = quot#-  rem         = rem#-  div         = quot#-  mod         = rem#-  quotRem n d = (n `quot#` d,n `rem#` d)-  divMod  n d = (n `quot#` d,n `rem#` d)-  toInteger   = toInteger#--quot#,rem# :: Index n -> Index n -> Index n-{-# NOINLINE quot# #-}-(I a) `quot#` (I b) = I (a `div` b)-{-# NOINLINE rem# #-}-(I a) `rem#` (I b) = I (a `rem` b)--{-# NOINLINE toInteger# #-}-toInteger# :: Index n -> Integer-toInteger# (I n) = n--instance Resize Index where-  resize     = resize#-  zeroExtend = extend-  truncateB  = resize#--resize# :: KnownNat m => Index n -> Index m-resize# (I i) = fromInteger_INLINE i-{-# NOINLINE resize# #-}--instance KnownNat n => Lift (Index n) where-  lift u@(I i) = sigE [| fromInteger# i |] (decIndex (natVal u))-  {-# NOINLINE lift #-}--decIndex :: Integer -> TypeQ-decIndex n = appT (conT ''Index) (litT $ numTyLit n)--instance Show (Index n) where-  show (I i) = show i-  {-# NOINLINE show #-}--instance ShowX (Index n) where-  showsPrecX = showsPrecXWith showsPrec---- | None of the 'Read' class' methods are synthesisable.-instance KnownNat n => Read (Index n) where-  readPrec = fromIntegral <$> (readPrec :: ReadPrec Word)--instance KnownNat n => Default (Index n) where-  def = fromInteger# 0--instance KnownNat n => Arbitrary (Index n) where-  arbitrary = arbitraryBoundedIntegral-  shrink    = shrinkIndex--shrinkIndex :: KnownNat n => Index n -> [Index n]-shrinkIndex x | natVal x < 3 = case toInteger x of-                                 1 -> [0]-                                 _ -> []-              -- 'shrinkIntegral' uses "`quot` 2", which for 'Index' types with-              -- an upper bound less than 2 results in an error.-              | otherwise    = shrinkIntegral x--instance KnownNat n => CoArbitrary (Index n) where-  coarbitrary = coarbitraryIntegral
− src/CLaSH/Sized/Internal/Index.hs-boot 
@@ -1,19 +0,0 @@-{-|-Copyright  :  (C) 2015-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE DataKinds       #-}-{-# LANGUAGE KindSignatures  #-}-{-# LANGUAGE MagicHash       #-}-{-# LANGUAGE RoleAnnotations #-}-module CLaSH.Sized.Internal.Index where--import GHC.TypeLits (KnownNat, Nat)--type role Index phantom-data Index :: Nat -> *--instance KnownNat n => Num (Index n)-toInteger# :: Index n -> Integer
− src/CLaSH/Sized/Internal/Signed.hs 
@@ -1,557 +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 DeriveDataTypeable         #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE UndecidableInstances       #-}--{-# LANGUAGE Unsafe #-}--{-# OPTIONS_HADDOCK show-extensions #-}-{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}-{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}--module CLaSH.Sized.Internal.Signed-  ( -- * Datatypes-    Signed (..)-    -- * Accessors-    -- ** Length information-  , size#-    -- * Type classes-    -- ** BitConvert-  , pack#-  , unpack#-    -- Eq-  , eq#-  , neq#-    -- ** Ord-  , lt#-  , ge#-  , gt#-  , le#-    -- ** Enum (not synthesisable)-  , enumFrom#-  , enumFromThen#-  , enumFromTo#-  , enumFromThenTo#-    -- ** Bounded-  , minBound#-  , maxBound#-    -- ** Num-  , (+#)-  , (-#)-  , (*#)-  , negate#-  , abs#-  , fromInteger#-    -- ** ExtendingNum-  , plus#-  , minus#-  , times#-    -- ** Integral-  , quot#-  , rem#-  , div#-  , mod#-  , toInteger#-    -- ** Bits-  , and#-  , or#-  , xor#-  , complement#-  , shiftL#-  , shiftR#-  , rotateL#-  , rotateR#-    -- ** Resize-  , resize#-  , truncateB#-    -- ** SaturatingNum-  , minBoundSym#-  )-where--import Control.DeepSeq                (NFData (..))-import Control.Lens                   (Index, Ixed (..), IxValue)-import Data.Bits                      (Bits (..), FiniteBits (..))-import Data.Data                      (Data)-import Data.Default                   (Default (..))-import Data.Proxy                     (Proxy (..))-import Text.Read                      (Read (..), ReadPrec)-import GHC.TypeLits                   (KnownNat, Nat, type (+), natVal)-import GHC.TypeLits.Extra             (Max)-import Language.Haskell.TH            (TypeQ, appT, conT, litT, numTyLit, sigE)-import Language.Haskell.TH.Syntax     (Lift(..))-import Test.QuickCheck.Arbitrary      (Arbitrary (..), CoArbitrary (..),-                                       arbitraryBoundedIntegral,-                                       coarbitraryIntegral, shrinkIntegral)--import CLaSH.Class.BitPack            (BitPack (..))-import CLaSH.Class.Num                (ExtendingNum (..), SaturatingNum (..),-                                       SaturationMode (..))-import CLaSH.Class.Resize             (Resize (..))-import CLaSH.Prelude.BitIndex         ((!), msb, replaceBit, split)-import CLaSH.Prelude.BitReduction     (reduceAnd, reduceOr)-import CLaSH.Sized.Internal.BitVector (BitVector (BV), Bit, (++#), high, low)-import qualified CLaSH.Sized.Internal.BitVector as BV-import CLaSH.XException               (ShowX (..), showsPrecXWith)---- | Arbitrary-width signed integer represented by @n@ bits, including the sign--- 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]------ __NB__: The 'Num' operators perform @wrap-around@ on overflow. If you want--- saturation on overflow, check out the 'SaturatingNum' class.------ >>>  maxBound :: Signed 3--- 3--- >>> minBound :: Signed 3--- -4--- >>> read (show (minBound :: Signed 3)) :: Signed 3--- -4--- >>> 1 + 2 :: Signed 3--- 3--- >>> 2 + 3 :: Signed 3--- -3--- >>> (-2) + (-3) :: Signed 3--- 3--- >>> 2 * 3 :: Signed 4--- 6--- >>> 2 * 4 :: Signed 4--- -8--- >>> (2 :: Signed 3) `times` (4 :: Signed 4) :: Signed 7--- 8--- >>> (2 :: Signed 3) `plus` (3 :: Signed 3) :: Signed 4--- 5--- >>> (-2 :: Signed 3) `plus` (-3 :: Signed 3) :: Signed 4--- -5--- >>> satPlus SatSymmetric 2 3 :: Signed 3--- 3--- >>> satPlus SatSymmetric (-2) (-3) :: Signed 3--- -3-newtype Signed (n :: Nat) =-    -- | The constructor, 'S', and the field, 'unsafeToInteger', are not-    -- synthesisable.-    S { unsafeToInteger :: Integer}-  deriving (Data)--{-# NOINLINE size# #-}-size# :: KnownNat n => Signed n -> Int-size# bv = fromInteger (natVal bv)--instance NFData (Signed n) where-  rnf (S i) = rnf i `seq` ()-  {-# NOINLINE rnf #-}-  -- NOINLINE is needed so that CLaSH doesn't trip on the "Signed ~# Integer"-  -- coercion--instance Show (Signed n) where-  show (S i) = show i-  {-# NOINLINE show #-}--instance ShowX (Signed n) where-  showsPrecX = showsPrecXWith showsPrec---- | None of the 'Read' class' methods are synthesisable.-instance KnownNat n => Read (Signed n) where-  readPrec = fromIntegral <$> (readPrec :: ReadPrec Int)--instance KnownNat n => BitPack (Signed n) where-  type BitSize (Signed n) = n-  pack   = pack#-  unpack = unpack#--{-# NOINLINE pack# #-}-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 (m + i) else BV i--{-# NOINLINE unpack# #-}-unpack# :: forall n . KnownNat n => BitVector n -> Signed n-unpack# (BV i) =-  let m = 1 `shiftL` fromInteger (natVal (Proxy @n) - 1)-  in  if i >= m then S (i-2*m) else S i--instance Eq (Signed n) where-  (==) = eq#-  (/=) = neq#--{-# NOINLINE eq# #-}-eq# :: Signed n -> Signed n -> Bool-eq# (S v1) (S v2) = v1 == v2--{-# NOINLINE neq# #-}-neq# :: Signed n -> Signed n -> Bool-neq# (S v1) (S v2) = v1 /= v2--instance Ord (Signed n) where-  (<)  = lt#-  (>=) = ge#-  (>)  = gt#-  (<=) = le#--lt#,ge#,gt#,le# :: Signed n -> Signed n -> Bool-{-# NOINLINE lt# #-}-lt# (S n) (S m) = n < m-{-# NOINLINE ge# #-}-ge# (S n) (S m) = n >= m-{-# NOINLINE gt# #-}-gt# (S n) (S m) = n > m-{-# NOINLINE le# #-}-le# (S n) (S m) = n <= m---- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and--- 'enumFromThenTo', are not synthesisable.-instance KnownNat n => Enum (Signed n) where-  succ           = (+# fromInteger# 1)-  pred           = (-# fromInteger# 1)-  toEnum         = fromInteger# . toInteger-  fromEnum       = fromEnum . toInteger#-  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]---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---- | Operators do @wrap-around@ on overflow-instance KnownNat n => Num (Signed n) where-  (+)         = (+#)-  (-)         = (-#)-  (*)         = (*#)-  negate      = negate#-  abs         = abs#-  signum s    = if s < 0 then (-1) else-                   if s > 0 then 1 else 0-  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--{-# 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--{-# NOINLINE (*#) #-}-(S a) *# (S b) = fromInteger_INLINE (a * b)--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--{-# 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--{-# NOINLINE fromInteger# #-}-fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat)-fromInteger# = fromInteger_INLINE--{-# INLINE fromInteger_INLINE #-}-fromInteger_INLINE :: forall n . KnownNat n => Integer -> Signed n-fromInteger_INLINE i = mask `seq` 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--instance ExtendingNum (Signed m) (Signed n) where-  type AResult (Signed m) (Signed n) = Signed (Max m n + 1)-  plus  = plus#-  minus = minus#-  type MResult (Signed m) (Signed n) = Signed (m + n)-  times = times#--plus#, minus# :: Signed m -> Signed n -> Signed (Max m n + 1)-{-# NOINLINE plus# #-}-plus# (S a) (S b) = S (a + b)--{-# NOINLINE minus# #-}-minus# (S a) (S b) = S (a - b)--{-# NOINLINE times# #-}-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#--instance KnownNat n => Integral (Signed n) where-  quot        = quot#-  rem         = rem#-  div         = div#-  mod         = mod#-  quotRem n d = (n `quot#` d,n `rem#` d)-  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# #-}-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# #-}-mod# (S a) (S b) = S (a `mod` b)--{-# NOINLINE toInteger# #-}-toInteger# :: Signed n -> Integer-toInteger# (S n) = n--instance KnownNat n => Bits (Signed n) where-  (.&.)             = and#-  (.|.)             = or#-  xor               = xor#-  complement        = complement#-  zeroBits          = 0-  bit i             = replaceBit i high 0-  setBit v i        = replaceBit i high v-  clearBit v i      = replaceBit i low  v-  complementBit v i = replaceBit i (BV.complement# (v ! i)) v-  testBit v i       = v ! i == 1-  bitSizeMaybe v    = Just (size# v)-  bitSize           = size#-  isSigned _        = True-  shiftL v i        = shiftL# v i-  shiftR v i        = shiftR# v i-  rotateL v i       = rotateL# v i-  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)--{-# NOINLINE complement# #-}-complement# :: KnownNat n => Signed n -> Signed n-complement# (S a) = fromInteger_INLINE (complement a)--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--    b'   = b `mod` sz-    b''  = sz - b'-    sz   = fromInteger (natVal s)--{-# 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--    b'  = b `mod` sz-    b'' = sz - b'-    sz  = fromInteger (natVal s)--instance KnownNat n => FiniteBits (Signed n) where-  finiteBitSize        = size#-  countLeadingZeros  s = countLeadingZeros  (pack# s)-  countTrailingZeros s = countTrailingZeros (pack# s)--instance Resize Signed where-  resize       = resize#-  zeroExtend s = unpack# (0 ++# pack s)-  truncateB    = truncateB#--{-# NOINLINE resize# #-}-resize# :: forall m n . (KnownNat n, KnownNat m) => Signed n -> Signed m-resize# s@(S i) | n' <= m'  = extended-                | otherwise = truncated-  where-    n  = fromInteger (natVal s)-    n' = shiftL 1 n-    m' = shiftL mask 1-    extended = S i--    mask      = 1 `shiftL` fromInteger (natVal (Proxy @m) -1)-    i'        = i `mod` mask-    truncated = if testBit i (n-1)-                   then S (i' - mask)-                   else S i'--{-# NOINLINE truncateB# #-}-truncateB# :: KnownNat m => Signed (m + n) -> Signed m-truncateB# (S n) = fromInteger_INLINE n--instance KnownNat n => Default (Signed n) where-  def = fromInteger# 0--instance KnownNat n => Lift (Signed n) where-  lift s@(S i) = sigE [| fromInteger# i |] (decSigned (natVal s))-  {-# NOINLINE lift #-}--decSigned :: Integer -> TypeQ-decSigned n = appT (conT ''Signed) (litT $ numTyLit n)--instance KnownNat n => SaturatingNum (Signed n) where-  satPlus SatWrap  a b = a +# b-  satPlus SatBound a b =-    let r      = plus# a b-        (_,r') = split r-    in  case msb r `xor` msb r' of-          0 -> unpack# r'-          _ -> case msb a .&. msb b of-            0 -> maxBound#-            _ -> minBound#-  satPlus SatZero a b =-    let r      = plus# a b-        (_,r') = split r-    in  case msb r `xor` msb r' of-          0 -> unpack# r'-          _ -> fromInteger# 0-  satPlus SatSymmetric a b =-    let r      = plus# a b-        (_,r') = split r-    in  case msb r `xor` msb r' of-          0 -> unpack# r'-          _ -> case msb a .&. msb b of-            0 -> maxBound#-            _ -> minBoundSym#--  satMin SatWrap a b = a -# b-  satMin SatBound a b =-    let r      = minus# a b-        (_,r') = split r-    in  case msb r `xor` msb r' of-          0 -> unpack# r'-          _ -> case msb a ++# msb b of-            2 -> minBound#-            _ -> maxBound#-  satMin SatZero a b =-    let r      = minus# a b-        (_,r') = split r-    in  case msb r `xor` msb r' of-          0 -> unpack# r'-          _ -> fromInteger# 0-  satMin SatSymmetric a b =-    let r      = minus# a b-        (_,r') = split r-    in  case msb r `xor` msb r' of-          0 -> unpack# r'-          _ -> case msb a ++# msb b of-            2 -> minBoundSym#-            _ -> maxBound#--  satMult SatWrap a b = a *# b-  satMult SatBound a b =-    let r        = times# a b-        (rL,rR)  = split r-        overflow = complement (reduceOr (msb rR ++# pack rL)) .|.-                              reduceAnd (msb rR ++# pack rL)-    in  case overflow of-          1 -> unpack# rR-          _ -> case msb rL of-            0 -> maxBound#-            _ -> minBound#-  satMult SatZero a b =-    let r        = times# a b-        (rL,rR)  = split r-        overflow = complement (reduceOr (msb rR ++# pack rL)) .|.-                              reduceAnd (msb rR ++# pack rL)-    in  case overflow of-          1 -> unpack# rR-          _ -> fromInteger# 0-  satMult SatSymmetric a b =-    let r        = times# a b-        (rL,rR)  = split r-        overflow = complement (reduceOr (msb rR ++# pack rL)) .|.-                              reduceAnd (msb rR ++# pack rL)-    in  case overflow of-          1 -> unpack# rR-          _ -> case msb rL of-            0 -> maxBound#-            _ -> minBoundSym#--minBoundSym# :: KnownNat n => Signed n-minBoundSym# = minBound# +# fromInteger# 1--instance KnownNat n => Arbitrary (Signed n) where-  arbitrary = arbitraryBoundedIntegral-  shrink    = shrinkSizedSigned--shrinkSizedSigned :: (KnownNat n, Integral (p n)) => p n -> [p n]-shrinkSizedSigned x | natVal x < 2 = case toInteger x of-                                       0 -> []-                                       _ -> [0]-                    -- 'shrinkIntegral' uses "`quot` 2", which for sized types-                    -- less than 2 bits wide results in a division by zero.-                    ---                    -- See: https://github.com/clash-lang/clash-compiler/issues/153-                    | otherwise    = shrinkIntegral x-{-# INLINE shrinkSizedSigned #-}--instance KnownNat n => CoArbitrary (Signed n) where-  coarbitrary = coarbitraryIntegral--type instance Index   (Signed n) = Int-type instance IxValue (Signed n) = Bit-instance KnownNat n => Ixed (Signed n) where-  ix i f s = unpack# <$> BV.replaceBit# (pack# s) i-                     <$> f (BV.index# (pack# s) i)
− src/CLaSH/Sized/Internal/Unsigned.hs 
@@ -1,467 +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 DeriveDataTypeable         #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeApplications           #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeOperators              #-}-{-# LANGUAGE UndecidableInstances       #-}--{-# LANGUAGE Unsafe #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Sized.Internal.Unsigned-  ( -- * Datatypes-    Unsigned (..)-    -- * Accessors-    -- ** Length information-  , size#-    -- * Type classes-    -- ** BitConvert-  , pack#-  , unpack#-    -- ** Eq-  , eq#-  , neq#-    -- ** Ord-  , lt#-  , ge#-  , gt#-  , le#-    -- ** Enum (not synthesisable)-  , enumFrom#-  , enumFromThen#-  , enumFromTo#-  , enumFromThenTo#-    -- ** Bounded-  , minBound#-  , maxBound#-    -- ** Num-  , (+#)-  , (-#)-  , (*#)-  , negate#-  , fromInteger#-    -- ** ExtendingNum-  , plus#-  , minus#-  , times#-    -- ** Integral-  , quot#-  , rem#-  , toInteger#-    -- ** Bits-  , and#-  , or#-  , xor#-  , complement#-  , shiftL#-  , shiftR#-  , rotateL#-  , rotateR#-    -- ** Resize-  , resize#-  )-where--import Control.DeepSeq                (NFData (..))-import Control.Lens                   (Index, Ixed (..), IxValue)-import Data.Bits                      (Bits (..), FiniteBits (..))-import Data.Data                      (Data)-import Data.Default                   (Default (..))-import Data.Proxy                     (Proxy (..))-import Text.Read                      (Read (..), ReadPrec)-import GHC.TypeLits                   (KnownNat, Nat, type (+), natVal)-import GHC.TypeLits.Extra             (Max)-import Language.Haskell.TH            (TypeQ, appT, conT, litT, numTyLit, sigE)-import Language.Haskell.TH.Syntax     (Lift(..))-import Test.QuickCheck.Arbitrary      (Arbitrary (..), CoArbitrary (..),-                                       arbitraryBoundedIntegral,-                                       coarbitraryIntegral)--import CLaSH.Class.BitPack            (BitPack (..))-import CLaSH.Class.Num                (ExtendingNum (..), SaturatingNum (..),-                                       SaturationMode (..))-import CLaSH.Class.Resize             (Resize (..))-import CLaSH.Prelude.BitIndex         ((!), msb, replaceBit, split)-import CLaSH.Prelude.BitReduction     (reduceOr)-import CLaSH.Sized.Internal.BitVector (BitVector (BV), Bit, high, low)-import qualified CLaSH.Sized.Internal.BitVector as BV-import CLaSH.XException               (ShowX (..), showsPrecXWith)---- | 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--- saturation on overflow, check out the 'SaturatingNum' class.------ >>> maxBound :: Unsigned 3--- 7--- >>> minBound :: Unsigned 3--- 0--- >>> read (show (maxBound :: Unsigned 3)) :: Unsigned 3--- 7--- >>> 1 + 2 :: Unsigned 3--- 3--- >>> 2 + 6 :: Unsigned 3--- 0--- >>> 1 - 3 :: Unsigned 3--- 6--- >>> 2 * 3 :: Unsigned 3--- 6--- >>> 2 * 4 :: Unsigned 3--- 0--- >>> (2 :: Unsigned 3) `times` (4 :: Unsigned 3) :: Unsigned 6--- 8--- >>> (2 :: Unsigned 3) `plus` (6 :: Unsigned 3) :: Unsigned 4--- 8--- >>> satPlus SatSymmetric 2 6 :: Unsigned 3--- 7--- >>> satMin SatSymmetric 2 3 :: Unsigned 3--- 0-newtype Unsigned (n :: Nat) =-    -- | The constructor, 'U', and the field, 'unsafeToInteger', are not-    -- synthesisable.-    U { unsafeToInteger :: Integer }-  deriving Data--{-# NOINLINE size# #-}-size# :: KnownNat n => Unsigned n -> Int-size# u = fromInteger (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"-  -- coercion--instance Show (Unsigned n) where-  show (U i) = show i-  {-# NOINLINE show #-}--instance ShowX (Unsigned n) where-  showsPrecX = showsPrecXWith showsPrec---- | None of the 'Read' class' methods are synthesisable.-instance KnownNat n => Read (Unsigned n) where-  readPrec = fromIntegral <$> (readPrec :: ReadPrec Word)--instance BitPack (Unsigned n) where-  type BitSize (Unsigned n) = n-  pack   = pack#-  unpack = unpack#--{-# NOINLINE pack# #-}-pack# :: Unsigned n -> BitVector n-pack# (U i) = BV i--{-# NOINLINE unpack# #-}-unpack# :: BitVector n -> Unsigned n-unpack# (BV i) = U i--instance Eq (Unsigned n) where-  (==) = eq#-  (/=) = neq#--{-# NOINLINE eq# #-}-eq# :: Unsigned n -> Unsigned n -> Bool-eq# (U v1) (U v2) = v1 == v2--{-# NOINLINE neq# #-}-neq# :: Unsigned n -> Unsigned n -> Bool-neq# (U v1) (U v2) = v1 /= v2--instance Ord (Unsigned n) where-  (<)  = lt#-  (>=) = ge#-  (>)  = gt#-  (<=) = le#--lt#,ge#,gt#,le# :: Unsigned n -> Unsigned n -> Bool-{-# NOINLINE lt# #-}-lt# (U n) (U m) = n < m-{-# NOINLINE ge# #-}-ge# (U n) (U m) = n >= m-{-# NOINLINE gt# #-}-gt# (U n) (U m) = n > m-{-# NOINLINE le# #-}-le# (U n) (U m) = n <= m---- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and--- 'enumFromThenTo', are not synthesisable.-instance KnownNat n => Enum (Unsigned n) where-  succ           = (+# fromInteger# 1)-  pred           = (-# fromInteger# 1)-  toEnum         = fromInteger# . toInteger-  fromEnum       = fromEnum . toInteger#-  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]--instance KnownNat n => Bounded (Unsigned n) where-  minBound = minBound#-  maxBound = maxBound#--{-# NOINLINE minBound# #-}-minBound# :: Unsigned n-minBound# = U 0--{-# NOINLINE maxBound# #-}-maxBound# :: forall n .KnownNat n => Unsigned n-maxBound# = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))-            in  U (m - 1)--instance KnownNat n => Num (Unsigned n) where-  (+)         = (+#)-  (-)         = (-#)-  (*)         = (*#)-  negate      = negate#-  abs         = id-  signum bv   = resize# (unpack# (reduceOr bv))-  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--{-# 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--{-# NOINLINE (*#) #-}-(*#) (U i) (U j) = fromInteger_INLINE (i * j)--{-# NOINLINE negate# #-}-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--{-# 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))--instance (KnownNat m, KnownNat n) => ExtendingNum (Unsigned m) (Unsigned n) where-  type AResult (Unsigned m) (Unsigned n) = Unsigned (Max m n + 1)-  plus  = plus#-  minus = minus#-  type MResult (Unsigned m) (Unsigned n) = Unsigned (m + n)-  times = times#--{-# NOINLINE plus# #-}-plus# :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1)-plus# (U a) (U b) = U (a + b)--{-# NOINLINE minus# #-}-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--{-# NOINLINE times# #-}-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#--instance KnownNat n => Integral (Unsigned n) where-  quot        = quot#-  rem         = rem#-  div         = quot#-  mod         = rem#-  quotRem n d = (n `quot#` d,n `rem#` d)-  divMod  n d = (n `quot#` d,n `rem#` d)-  toInteger   = toInteger#--quot#,rem# :: Unsigned n -> Unsigned n -> Unsigned n-{-# NOINLINE quot# #-}-quot# (U i) (U j) = U (i `quot` j)-{-# NOINLINE rem# #-}-rem# (U i) (U j) = U (i `rem` j)--{-# NOINLINE toInteger# #-}-toInteger# :: Unsigned n -> Integer-toInteger# (U i) = i--instance KnownNat n => Bits (Unsigned n) where-  (.&.)             = and#-  (.|.)             = or#-  xor               = xor#-  complement        = complement#-  zeroBits          = 0-  bit i             = replaceBit i high 0-  setBit v i        = replaceBit i high v-  clearBit v i      = replaceBit i low  v-  complementBit v i = replaceBit i (BV.complement# (v ! i)) v-  testBit v i       = v ! i == high-  bitSizeMaybe v    = Just (size# v)-  bitSize           = size#-  isSigned _        = False-  shiftL v i        = shiftL# v i-  shiftR v i        = shiftR# v i-  rotateL v i       = rotateL# v i-  rotateR v i       = rotateR# v i-  popCount u        = popCount (pack# u)--{-# NOINLINE and# #-}-and# :: Unsigned n -> Unsigned n -> Unsigned n-and# (U v1) (U v2) = U (v1 .&. v2)--{-# NOINLINE or# #-}-or# :: Unsigned n -> Unsigned n -> Unsigned n-or# (U v1) (U v2) = U (v1 .|. v2)--{-# NOINLINE xor# #-}-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)--shiftL#, 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)--{-# NOINLINE shiftR# #-}-shiftR# :: Unsigned n -> Int -> Unsigned n-shiftR# (U v) i-  | i < 0     = error-              $ "'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)-  where-    l    = shiftL n b'-    r    = shiftR n b''--    b'   = b `mod` sz-    b''  = sz - b'-    sz   = fromInteger (natVal bv)--{-# NOINLINE rotateR# #-}-rotateR# _ b | b < 0 = error "'shiftR undefined for negative numbers"-rotateR# bv@(U n) b   = fromInteger_INLINE (l .|. r)-  where-    l   = shiftR n b'-    r   = shiftL n b''--    b'  = b `mod` sz-    b'' = sz - b'-    sz  = fromInteger (natVal bv)--instance KnownNat n => FiniteBits (Unsigned n) where-  finiteBitSize        = size#-  countLeadingZeros  u = countLeadingZeros  (pack# u)-  countTrailingZeros u = countTrailingZeros (pack# u)--instance Resize Unsigned where-  resize     = resize#-  zeroExtend = extend-  truncateB  = resize#--{-# NOINLINE resize# #-}-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--instance Default (Unsigned n) where-  def = minBound#--instance KnownNat n => Lift (Unsigned n) where-  lift u@(U i) = sigE [| fromInteger# i |] (decUnsigned (natVal u))-  {-# NOINLINE lift #-}--decUnsigned :: Integer -> TypeQ-decUnsigned n = appT (conT ''Unsigned) (litT $ numTyLit n)--instance KnownNat n => SaturatingNum (Unsigned n) where-  satPlus SatWrap a b = a +# b-  satPlus SatZero a b =-    let r = plus# a b-    in  case msb r of-          0 -> resize# r-          _ -> minBound#-  satPlus _ a b =-    let r  = plus# a b-    in  case msb r of-          0 -> resize# r-          _ -> maxBound#--  satMin SatWrap a b = a -# b-  satMin _ a b =-    let r = minus# a b-    in  case msb r of-          0 -> resize# r-          _ -> minBound#--  satMult SatWrap a b = a *# b-  satMult SatZero a b =-    let r       = times# a b-        (rL,rR) = split r-    in  case rL of-          0 -> unpack# rR-          _ -> minBound#-  satMult _ a b =-    let r       = times# a b-        (rL,rR) = split r-    in  case rL of-          0 -> unpack# rR-          _ -> maxBound#--instance KnownNat n => Arbitrary (Unsigned n) where-  arbitrary = arbitraryBoundedIntegral-  shrink    = BV.shrinkSizedUnsigned--instance KnownNat n => CoArbitrary (Unsigned n) where-  coarbitrary = coarbitraryIntegral--type instance Index   (Unsigned n) = Int-type instance IxValue (Unsigned n) = Bit-instance KnownNat n => Ixed (Unsigned n) where-  ix i f s = unpack# <$> BV.replaceBit# (pack# s) i-                     <$> f (BV.index# (pack# s) i)
− src/CLaSH/Sized/RTree.hs 
@@ -1,478 +0,0 @@-{-|-Copyright  :  (C) 2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# 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 UndecidableInstances #-}-{-# LANGUAGE ViewPatterns         #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-}--module CLaSH.Sized.RTree-  ( -- * 'RTree' data type-    RTree (LR, BR)-    -- * Construction-  , treplicate-  , trepeat-    -- * Accessors-    -- ** Indexing-  , indexTree-  , tindices-    -- * Modifying trees-  , replaceTree-    -- * Element-wise operations-    -- ** Mapping-  , tmap-  , tzipWith-    -- ** Zipping-  , tzip-    -- ** Unzipping-  , tunzip-    -- * Folding-  , tfold-    -- ** Specialised folds-  , tdfold-    -- * Conversions-  , v2t-  , t2v-    -- * Misc-  , lazyT-  )-where--import Control.Applicative         (liftA2)-import qualified Control.Lens      as Lens-import Data.Default                (Default (..))-import Data.Foldable               (toList)-import Data.Singletons.Prelude     (Apply, TyFun, type (@@))-import Data.Proxy                  (Proxy (..))-import GHC.TypeLits                (KnownNat, Nat, type (+), type (^), type (*))-import Language.Haskell.TH.Syntax  (Lift(..))-import qualified Prelude           as P-import Prelude                     hiding ((++), (!!))-import Test.QuickCheck             (Arbitrary (..), CoArbitrary (..))--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)-import CLaSH.XException            (ShowX (..), showsX, showsPrecXWith)--{- $setup->>> :set -XDataKinds->>> :set -XTypeFamilies->>> :set -XTypeOperators->>> :set -XTemplateHaskell->>> :set -XFlexibleContexts->>> :set -XTypeApplications->>> :set -fplugin GHC.TypeLits.Normalise->>> :set -XUndecidableInstances->>> import CLaSH.Prelude->>> data IIndex (f :: TyFun Nat *) :: *->>> 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 = tdfold (Proxy @IIndex)-                                 fromIntegral-                                 (\_ x y -> plus x y)-                                 (v2t (bv2v bv))-:}--}---- | Perfect depth binary tree.------ * Only has elements at the leaf of the tree--- * A tree of depth /d/ has /2^d/ elements.-data RTree :: Nat -> * -> * where-  LR_ :: a -> RTree 0 a-  BR_ :: RTree d a -> RTree d a -> RTree (d+1) a--textract :: RTree 0 a -> a-textract (LR_ x) = x-{-# NOINLINE textract #-}--tsplit :: RTree (d+1) a -> (RTree d a,RTree d a)-tsplit (BR_ l r) = (l,r)-{-# NOINLINE tsplit #-}---- | Leaf of a perfect depth tree------ >>> LR 1--- 1--- >>> let x = LR 1--- >>> :t x--- x :: Num a => RTree 0 a------ Can be used as a pattern:------ >>> let f (LR a) (LR b) = a + b--- >>> :t f--- f :: Num a => RTree 0 a -> RTree 0 a -> a--- >>> f (LR 1) (LR 2)--- 3-pattern LR :: a -> RTree 0 a-pattern LR x <- (textract -> x)-  where-    LR x = LR_ x---- | Branch of a perfect depth tree------ >>> BR (LR 1) (LR 2)--- <1,2>--- >>> let x = BR (LR 1) (LR 2)--- >>> :t x--- x :: Num a => RTree 1 a------ Case be used a pattern:------ >>> let f (BR (LR a) (LR b)) = LR (a + b)--- >>> :t f--- f :: Num a => RTree 1 a -> RTree 0 a--- >>> f (BR (LR 1) (LR 2))--- 3-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--instance (KnownNat d, Eq a) => Eq (RTree d a) where-  (==) t1 t2 = (==) (t2v t1) (t2v t2)--instance (KnownNat d, Ord a) => Ord (RTree d a) where-  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))--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))--instance KnownNat d => Functor (RTree d) where-  fmap = tmap--instance KnownNat d => Applicative (RTree d) where-  pure  = trepeat-  (<*>) = tzipWith ($)--instance KnownNat d => Foldable (RTree d) where-  foldMap f = tfold f mappend--data TraversableTree (g :: * -> *) (a :: *) (f :: TyFun Nat *) :: *-type instance Apply (TraversableTree f a) d = f (RTree d a)--instance KnownNat d => Traversable (RTree d) where-  traverse :: forall f a b . Applicative f => (a -> f b) -> RTree d a -> f (RTree d b)-  traverse f = tdfold (Proxy @(TraversableTree f b))-                      (fmap LR . f)-                      (const (liftA2 BR))--instance (KnownNat d, KnownNat (BitSize a), BitPack a) =>-  BitPack (RTree d a) where-  type BitSize (RTree d a) = (2^d) * (BitSize a)-  pack   = pack . t2v-  unpack = v2t . unpack--type instance Lens.Index   (RTree d a) = Int-type instance Lens.IxValue (RTree d a) = a-instance KnownNat d => Lens.Ixed (RTree d a) where-  ix i f t = replaceTree i <$> f (indexTree t i) <*> pure t--instance (KnownNat d, Default a) => Default (RTree d a) where-  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) |]--instance (KnownNat d, Arbitrary a) => Arbitrary (RTree d a) where-  arbitrary = sequenceA (trepeat arbitrary)-  shrink    = sequenceA . fmap shrink--instance (KnownNat d, CoArbitrary a) => CoArbitrary (RTree d a) where-  coarbitrary = coarbitrary . toList---- | 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.plus' 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.plus'es:------ >>> :{--- let populationCount' :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1))---                      => BitVector (2^d) -> Index (2^d+1)---     populationCount' = tfold fromIntegral plus . 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 ‘plus’---       In the first argument of ‘(.)’, namely ‘tfold fromIntegral plus’---       In the expression: tfold fromIntegral plus . 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.plus', where the--- result is larger than the arguments, we must use a dependently typed fold in--- the 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.plus' 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 * -> *) -- ^ 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.-       -> 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-                      in  g sn' (go sn' l) (go sn' r)-{-# NOINLINE tdfold #-}--data TfoldTree (a :: *) (f :: TyFun Nat *) :: *-type instance Apply (TfoldTree a) d = a---- | Reduce a tree to a single element-tfold :: forall d a b .-         KnownNat d-      => (a -> b) -- ^ Function to apply to the leaves-      -> (b -> b -> b) -- ^ Function to combine the results of the reduction-                       -- of two branches-      -> RTree d a -- ^ Tree to fold reduce-      -> b-tfold f g = tdfold (Proxy @(TfoldTree b)) f (const g)---- | \"'treplicate' @d a@\" returns a tree of depth /d/, and has /2^d/ copies--- of /a/.------ >>> treplicate (SNat :: SNat 3) 6--- <<<6,6>,<6,6>>,<<6,6>,<6,6>>>--- >>> treplicate d3 6--- <<<6,6>,<6,6>>,<<6,6>,<6,6>>>-treplicate :: forall d a . SNat d -> a -> RTree d a-treplicate sn a = go (toUNat sn)-  where-    go :: UNat n -> RTree n a-    go UZero      = LR a-    go (USucc un) = BR (go un) (go un)-{-# NOINLINE treplicate #-}---- | \"'trepeat' @a@\" creates a tree with as many copies of /a/ as demanded by--- the context.------ >>> trepeat 6 :: RTree 2 Int--- <<6,6>,<6,6>>-trepeat :: KnownNat d => a -> RTree d a-trepeat = treplicate SNat--data MapTree (a :: *) (f :: TyFun Nat *) :: *-type instance Apply (MapTree a) d = RTree d a---- | \"'tmap' @f t@\" is the tree obtained by apply /f/ to each element of /t/,--- i.e.,------ > tmap f (BR (LR a) (LR b)) == BR (LR (f a)) (LR (f b))-tmap :: forall d a b . KnownNat d => (a -> b) -> RTree d a -> RTree d b-tmap f = tdfold (Proxy @(MapTree b)) (LR . f) (\_ l r -> BR l r)---- | Generate a tree of indices, where the depth of the tree is determined by--- the context.------ >>> tindices :: RTree 3 (Index 8)--- <<<0,1>,<2,3>>,<<4,5>,<6,7>>>-tindices :: forall d . KnownNat d => RTree d (Index (2^d))-tindices =-  tdfold (Proxy @(MapTree (Index (2^d)))) LR-         (\s@SNat l r -> BR l (tmap (+(snatToNum (pow2SNat s))) r))-         (treplicate SNat 0)--data V2TTree (a :: *) (f :: TyFun Nat *) :: *-type instance Apply (V2TTree a) d = RTree d a---- | 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)--- <<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)--data T2VTree (a :: *) (f :: TyFun Nat *) :: *-type instance Apply (T2VTree a) d = Vec (2^d) a---- | Convert a tree of depth /d/ to a vector of /2^d/ elements------ >>> (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>-t2v :: forall d a . KnownNat d => RTree d a -> Vec (2^d) a-t2v = tdfold (Proxy @(T2VTree a)) (:> Nil) (\_ l r -> l ++ r)---- | \"'indexTree' @t n@\" returns the /n/'th element of /t/.------ The bottom-left leaf had index /0/, and the bottom-right leaf has index--- /2^d-1/, where /d/ is the depth of the tree------ >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 0--- 1--- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 2--- 3--- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 14--- *** Exception: CLaSH.Sized.Vector.(!!): index 14 is larger than maximum index 3--- ...-indexTree :: (KnownNat d, Enum i) => RTree d a -> i -> a-indexTree t i = (t2v t) !! i---- | \"'replaceTree' @n a t@\" returns the tree /t/ where the /n/'th element is--- replaced by /a/.------ The bottom-left leaf had index /0/, and the bottom-right leaf has index--- /2^d-1/, where /d/ is the depth of the tree------ >>> replaceTree 0 5 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4)))--- <<5,2>,<3,4>>--- >>> 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--- ...-replaceTree :: (KnownNat d, Enum i) => i -> a -> RTree d a -> RTree d a-replaceTree i a = v2t . replace i a . t2v--data ZipWithTree (b :: *) (c :: *) (f :: TyFun Nat *) :: *-type instance Apply (ZipWithTree b c) d = RTree d b -> RTree d c---- | 'tzipWith' generalises 'tzip' by zipping with the function given as the--- first argument, instead of a tupling function. For example, "tzipWith (+)"--- applied to two trees produces the tree of corresponding sums.------ > tzipWith f (BR (LR a1) (LR b1)) (BR (LR a2) (LR b2)) == BR (LR (f a1 a2)) (LR (f b1 b2))-tzipWith :: forall a b c d . KnownNat d => (a -> b -> c) -> RTree d a -> RTree d b -> RTree d c-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"--    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"---- | '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 (,)--data UnzipTree (a :: *) (b :: *) (f :: TyFun Nat *) :: *-type instance Apply (UnzipTree a b) d = (RTree d a, RTree d b)---- | 'tunzip' transforms a tree of pairs into a tree of first components and a--- tree of second components.-tunzip :: forall d a b . KnownNat d => RTree d (a,b) -> (RTree d a,RTree d b)-tunzip = tdfold (Proxy @(UnzipTree a b)) lr br-  where-    lr   (a,b) = (LR a,LR b)--    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--- 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)
− src/CLaSH/Sized/Signed.hs 
@@ -1,14 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE Trustworthy #-}--module CLaSH.Sized.Signed-  ( Signed-  )-where--import CLaSH.Sized.Internal.Signed
− src/CLaSH/Sized/Unsigned.hs 
@@ -1,13 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE Trustworthy #-}--module CLaSH.Sized.Unsigned-  (Unsigned)-where--import CLaSH.Sized.Internal.Unsigned
− src/CLaSH/Sized/Vector.hs 
@@ -1,1992 +0,0 @@-{-|-Copyright  :  (C) 2013-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE BangPatterns         #-}-{-# LANGUAGE DataKinds            #-}-{-# 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         #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-redundant-constraints #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Sized.Vector-  ( -- * 'Vec'tor data type-    Vec(Nil,(:>),(:<))-    -- * Accessors-    -- ** Length information-  , length, maxIndex, 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, replicateI, repeat-  , iterate, iterateI, generate, generateI-    -- *** Initialisation from a list-  , listToVecTH, v-    -- ** Concatenation-  , (++), (+>>), (<<+), concat-  , 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-  , zip, zip3-  , izipWith-    -- ** Unzipping-  , unzip, unzip3-    -- * 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-    -- * Primitives-    -- ** 'Traversable' instance-  , traverse#-    -- ** 'BitPack' instance-  , concatBitVector#-  , unconcatBitVector#-  )-where--import Control.DeepSeq            (NFData (..))-import qualified Control.Lens     as Lens hiding (pattern (:>), pattern (:<))-import Data.Default               (Default (..))-import qualified Data.Foldable    as F-import Data.Proxy                 (Proxy (..))-import Data.Singletons.Prelude    (TyFun,Apply,type (@@))-import GHC.TypeLits               (CmpNat, KnownNat, Nat, type (+), type (-), type (*),-                                   type (^), natVal)-import GHC.Base                   (Int(I#),Int#,isTrue#)-import GHC.Prim                   ((==#),(<#),(-#))-import Language.Haskell.TH        (ExpQ)-import Language.Haskell.TH.Syntax (Lift(..))-import Prelude                    hiding ((++), (!!), 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)-import qualified Prelude          as P-import Test.QuickCheck            (Arbitrary (..), CoArbitrary (..))-import Unsafe.Coerce              (unsafeCoerce)--import CLaSH.Promoted.Nat         (SNat (..), UNat (..), 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 (BitPack (..))-import CLaSH.XException    (ShowX (..), showsX, showsPrecXWith)--{- $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 -> plus 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 -> * -> * where-  Nil  :: Vec 0 a-  Cons :: a -> Vec n a -> Vec (n + 1) a--instance NFData a => NFData (Vec n a) where-  rnf Nil         = ()-  rnf (Cons x xs) = rnf x `seq` rnf xs---- | 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-  (==) v1 v2-    | length v1 == 0 = True-    | otherwise      = fold @Bool @n (&&) (unsafeCoerce (zipWith (==) v1 v2))-  -- FIXME: the `unsafeCoerce` is a hack because the CLaSH compiler cannot deal-  -- with the existential length of the 'xs' in "Cons x xs".-  ---  -- Ideally we would write:-  ---  -- (==) Nil           _  = True-  -- (==) v1@(Cons _ _) v2 = fold (&&) (zipWith (==) v1 v2)-  ---  -- But the CLaSH compiler currently fails on that definition.--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 m, m ~ (n+1)) => F.Foldable (Vec m) where-  fold      = fold mappend-  foldMap f = fold mappend . map f-  foldr     = foldr-  foldl     = foldl-  foldr1    = foldr1-  foldl1    = foldl1-  toList    = toList-  null _    = False-  length    = length-  maximum   = fold (\x y -> if x >= y then x else y)-  minimum   = fold (\x y -> if x <= y then x else y)-  sum       = fold (+)-  product   = fold (*)--instance Functor (Vec n) where-  fmap = map--instance (KnownNat m, m ~ (n+1)) => Traversable (Vec m) 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--{-# 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 #-}---- | 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: 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: 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' generalises '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' generalises '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 #-}---- | '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 #-}---- | 'zip' 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 #-}---- | '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 #-}--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 index (subscript) of the last element in a 'Vec'tor as an 'Int'--- value.-maxIndex :: KnownNat n => Vec n a -> Int-maxIndex = subtract 1 . length-{-# NOINLINE maxIndex #-}-{-# DEPRECATED maxIndex "'maxIndex' will be removed in clash-prelude-1.0, use 'length xs - 1' instead." #-}---- | 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>:...---     • Couldn't match expected type ‘2’ with actual 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---- | \"'replicateI' @a@\" creates a vector with as many copies of /a/ as--- demanded by the context.------ >>> replicateI 6 :: Vec 5 Int--- <BLANKLINE>--- <interactive>:...---     In the use of ‘replicateI’---     (imported from CLaSH.Prelude, but defined in CLaSH.Sized.Vector):---     Deprecated: "Use 'repeat' instead of 'replicateI'"--- <6,6,6,6,6>-replicateI :: KnownNat n => a -> Vec n a-replicateI = withSNat replicate-{-# INLINE replicateI #-}-{-# DEPRECATED replicateI "Use 'repeat' instead of 'replicateI'" #-}---- | \"'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>------ \"'interate' @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>------ \"'interateI' @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 initialised 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) |]--v :: Lift a => [a] -> ExpQ-v = listToVecTH-{-# DEPRECATED v "'v' will be removed in clash-prelude-1.0, use 'listToVecTH'" #-}---- | '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--- <BLANKLINE>--- <interactive>:...---     • Occurs check: cannot construct the infinite type: t ~ t + 1---       Expected type: a -> Vec t a -> Vec t a---         Actual type: a -> Vec t a -> Vec (t + 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 t a (bound at ...)---         append' :: Vec n a -> Vec t a -> Vec t 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 * -> *) -- ^ 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.plus' 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.plus'es:------ >>> :{--- let populationCount' :: (KnownNat (n+1), KnownNat (n+2))---                      => BitVector (n+1) -> Index (n+2)---     populationCount' = fold plus . 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 ‘plus’---       In the first argument of ‘(.)’, namely ‘fold plus’---       In the expression: fold plus . 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.plus', where the--- result is larger than the arguments, we must use a dependently typed fold in--- the 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.plus' 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 * -> *) -- ^ 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 =-      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 :: *) (f :: TyFun Nat *) :: *-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   = concatBitVector# . map pack-  unpack = map unpack . unconcatBitVector#--concatBitVector# :: KnownNat m-                 => Vec n (BitVector m)-                 -> BitVector (n * m)-concatBitVector# = concatBitVector' . reverse-  where-    concatBitVector' :: KnownNat m-                     => Vec n (BitVector m)-                     -> BitVector (n * m)-    concatBitVector' Nil           = 0-    concatBitVector' (x `Cons` xs) = concatBitVector' xs ++# x-{-# NOINLINE concatBitVector# #-}--unconcatBitVector# :: (KnownNat n, KnownNat m)-                   => BitVector (n * m)-                   -> Vec n (BitVector m)-unconcatBitVector# bv = withSNat (\s -> ucBV (toUNat s) bv)-{-# NOINLINE unconcatBitVector# #-}--ucBV :: forall n m . KnownNat m-     => UNat n -> BitVector (n * m) -> Vec n (BitVector m)-ucBV UZero     _  = Nil-ucBV (USucc n) bv = let (bv',x :: BitVector m) = split# bv-                    in  ucBV n bv' :< x-{-# INLINE ucBV #-}---- | 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--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))
− src/CLaSH/Sized/Vector.hs-boot 
@@ -1,25 +0,0 @@-{-|-Copyright  :  (C) 2015-2016, University of Twente-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE DataKinds       #-}-{-# LANGUAGE GADTs           #-}-{-# LANGUAGE KindSignatures  #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeOperators   #-}-module CLaSH.Sized.Vector where--import GHC.TypeLits  (KnownNat, Nat, type (+))-import {-# SOURCE #-} CLaSH.Sized.Internal.BitVector (BitVector, Bit)--type role Vec nominal representational-data Vec :: Nat -> * -> *--instance (KnownNat m, (~) m ((+) n 1)) => Foldable (Vec m)--bv2v  :: KnownNat n => BitVector n -> Vec n Bit-map   :: (a -> b) -> Vec n a -> Vec n b-foldr :: (a -> b -> b) -> b -> Vec n a -> b-foldl :: (b -> a -> b) -> b -> Vec n a -> b
− src/CLaSH/Tutorial.hs 
@@ -1,2019 +0,0 @@-{-|-Copyright : © 2014-2016, Christiaan Baaij, 2017, QBayLogic-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--  -- * Installation-  -- $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--  -- * TopEntity 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 CλaSH-  -- $limitations--  -- * CλaSH vs Lava-  -- $vslava-  )-where--import CLaSH.Prelude-import CLaSH.Prelude.Explicit-import CLaSH.Prelude.BlockRam-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--{- $setup->>> :set -XTemplateHaskell->>> :set -XDataKinds->>> let ma acc (x,y) = acc + x * y->>> :{-let 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->>> let topEntity = mac :: Signal (Signed 9, Signed 9) -> Signal (Signed 9)->>> let testInput = stimuliGenerator $(listToVecTH [(1,1) :: (Signed 9,Signed 9),(2,2),(3,3),(4,4)])->>> let expectedOutput = outputVerifier $(listToVecTH [0 :: Signed 9,1,5,14])->>> :{-let fibR :: Unsigned 64 -> Unsigned 64-    fibR 0 = 0-    fibR 1 = 1-    fibR n = fibR (n-1) + fibR (n-2)-:}-->>> :{-let fibS :: Signal (Unsigned 64)-    fibS = r-      where r = register 0 r + register 0 (register 1 r)-:}---}--{- $introduction-CλaSH (pronounced ‘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 CλaSH compiler transforms these-high-level descriptions to low-level synthesizable VHDL, Verilog, or-SystemVerilog.--Features of CλaSH:--  * 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 CλaSH borrows the semantics of Haskell, that statement-should be taken with a grain of salt. What we mean to say is that the CλaSH-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 CλaSH>).--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 CλaSH 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 CλaSH and building-our first circuit.--}--{- $installation-The CλaSH compiler and Prelude library for circuit design only work with the-<http://haskell.org/ghc GHC> Haskell compiler version 8.0 (lower versions of-GHC are not supported).--  (1) Install __GHC 8.0__--      * Download and install <https://www.haskell.org/ghc/download_ghc_8_0_2 GHC for your platform>.-        Unix user can use @./configure prefix=\<LOCATION\>@ to set the installation-        location.--      * Make sure that the @bin@ directory of __GHC__ is in your @PATH@.--    In case you cannot find what you are looking for on <https://www.haskell.org/ghc/download_ghc_8_0_2>,-    you can, /alternatively/, use the following instructions:--      * Ubuntu:--          * Run: @sudo add-apt-repository -y ppa:hvr/ghc@-          * Run: @sudo apt-get update@-          * Run: @sudo apt-get install cabal-install-1.24 ghc-8.0.2 libtinfo-dev@-          * Update your @PATH@ with: @\/opt\/ghc\/8.0.2\/bin@, @\/opt\/cabal\/1.24/bin@, and @\$HOME\/.cabal\/bin@-          * Run: @cabal update@-          * Skip step 2.--      * OS X:--          * Follow the instructions on: <https://www.haskell.org/platform/mac.html Haskell Platform Mac OS X>-            to install the /minimal/ Haskell platform-          * Run: @cabal update@-          * Skip step 2.--      * Windows:--          * Follow the instructions on: <https://www.haskell.org/platform/windows.html Haskell Platform Windows>-            to install the /minimal/ Haskell platform-          * Run: @cabal update@-          * Skip step 2.--  (2) Install __Cabal (version 1.24 or higher)__--      * Binary, when available:--          * Download the binary for <http://www.haskell.org/cabal/download.html cabal-install>-          * Put the binary in a location mentioned in your @PATH@-          * Add @cabal@'s @bin@ directory to your @PATH@:--              * Windows: @%appdata%\\cabal\\bin@-              * Unix: @\$HOME\/.cabal\/bin@--      * Source:--          * Download the sources for <http://hackage.haskell.org/package/cabal-install cabal-install>-          * Unpack (@tar xf@) the archive and @cd@ to the directory-          * Run: @sh bootstrap.sh@-          * Follow the instructions to add @cabal@ to your @PATH@--      * Run @cabal update@--  (2) Install __CλaSH__--      * Run:--          * /i386/ Linux: @cabal install clash-ghc --enable-documentation --enable-executable-dynamic@-          * Other: @cabal install clash-ghc --enable-documentation@--      * /This is going to take awhile, so have a refreshment/--  (4) Verify that everything is working by:--      * Downloading the <https://raw.githubusercontent.com/clash-lang/clash-compiler/049e6e2eacb9b3b5ae8664b9b79979c321b322d9/examples/FIR.hs Fir.hs> example-      * Run: @clash --interactive FIR.hs@-      * Execute, in the interpreter, the @:vhdl@ command-      * Execute, in the interpreter, the @:verilog@ command-      * Execute, in the interpreter, the @:systemverilog@ command-      * Exit the interpreter using @:q@-      * Examine the VHDL code in the @vhdl@ directory-      * Examine the Verilog code in the @verilog@ directory-      * Examine the SystemVerilog code in the @systemverilog@ directory---}--{- $working-This tutorial can be followed best whilst having the CλaSH interpreter running-at the same time. If you followed the installation instructions, you already-know how to start the CλaSH compiler in interpretive mode:--@-clash --interactive-@--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 CλaSH 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 CλaSH 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-@--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--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 type of one of the sequential primitives, the @'register'@ function:--@-register :: a -> 'Signal' a -> 'Signal' 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' a@. All (synchronous)-sequential circuits work on values of type @'Signal' a@. Combinational-circuits always work on values of, well, not of type @'Signal' 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-CλaSH, 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 @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 4 (register 0 (signal 8))-[0,8,8,8]--Where we see that the initial value of the signal is the specified 0 value,-followed by 8's.--}--{- $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 CλaSH 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 t => t -> (t, t) -> (t, t)--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 :: (s -> i -> (s,o))-      -> s-      -> ('Signal' i -> 'Signal' 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 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 :: 'Signal' ('Signed' 9, 'Signed' 9) -> 'Signal' ('Signed' 9)-topEntity = 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 :: 'Signal' ('Signed' 9, 'Signed' 9) -> 'Signal' ('Signed' 9)-topEntity = mac-@--The 'topEntity' function is the starting point for the CλaSH compiler to-transform your circuit description into a VHDL netlist. It must meet the-following restrictions in order for the CλaSH compiler to work:--  * It must be completely monomorphic-  * It must be completely first-order--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 might you want to create a so-called-/testbench/ for the VHDL:--  * You want to compare post-synthesis / post-place&route behaviour to that of-    the behaviour of the original VHDL.-  * Need representative stimuli for your dynamic power calculations-  * Verify that the VHDL output of the CλaSH compiler has the same behaviour as-    the Haskell / CλaSH specification.--For these purposes, you can have CλaSH compiler generate a @MAC_testbench.vhdl@-file which contains a stimulus generator and an expected output verifier. The-CλaSH compiler looks for the following functions to generate these to aspects:--  1. @testInput@ for the stimulus generator.-  2. @expectedOutput@ for the output verification.--Given a @topEntity@ with the type:--@-__topEntity__ :: 'Signal' a -> 'Signal' b-@--Where @a@ and @b@ are placeholders for monomorphic types: the 'topEntity' is-not allowed to be polymorphic. So given the above type for the 'topEntity', the-type of 'testInput' should be:--@-__testInput__ :: 'Signal' a-@--And the type of @expectedOutput@ should be:--@-__expectedOutput__ :: 'Signal' b -> 'Signal' Bool-@--Where the 'expectedOutput' function should assert to 'True' once it has verified-all expected values. The "CLaSH.Prelude" module contains two standard functions-to serve the above purpose, but a user is free to use any CλaSH specification-to describe these two functions. For this tutorial we will be using the-functions specified in the "CLaSH.Prelude" module, which are @'stimuliGenerator'@-and @'outputVerifier'@:--@-testInput :: 'Signal' ('Signed' 9,'Signed' 9)-testInput = 'stimuliGenerator' $('listToVecTH' [(1,1) :: ('Signed' 9,'Signed' 9),(2,2),(3,3),(4,4)])--expectedOutput :: 'Signal' ('Signed' 9) -> 'Signal' Bool-expectedOutput = 'outputVerifier' $('listToVecTH' [0 :: 'Signed' 9,1,5,14])-@--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 behaviour of the /testbench/:-->>> sampleN 7 $ expectedOutput (topEntity testInput)-[False,False,False,False-cycle(system1000): 4, outputVerifier-expected value: 14, not equal to actual value: 30-,True-cycle(system1000): 5, outputVerifier-expected value: 14, not equal to actual value: 46-,True-cycle(system1000): 6, outputVerifier-expected value: 14, not equal to actual value: 62-,True]--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 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. After it is finished you-can load all the files in your favourite VHDL simulation tool. Once all files-are loaded into the VHDL simulator, run the simulation on the @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 to generate VHDL, the CλaSH 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 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 :: (i -> 'Control.Monad.State.Lazy.State' s o)-             -> s-             -> ('Signal' i -> 'Signal' 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 :: 'Signal' ('Signed' 16) -> 'Signal' ('Signed' 16)-topEntity = fir (0 ':>' 1 ':>' 2 ':>' 3 ':>' 'Nil')-@--Here we can see that, although the CλaSH 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' (i1,c)))-@--Why do we need these 'bundle', and 'unbundle' functions you might ask? When we-look at the type of 'mealy':--@-__mealy__ :: (s -> i -> (s,o))-      -> s-      -> ('Signal' i -> 'Signal' 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' (Bool,Int)@ and @('Signal' Bool, 'Signal' 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' Bool, 'Signal' Int) -> 'Signal' (Bool,Int)-@--and 'unbundle':--@-__unbundle__ :: 'Signal' (Int,Bool) -> ('Signal' Int, 'Signal' Bool)-@--The /true/ types of these two functions are, however:--@-__bundle__   :: 'Bundle' a => 'Unbundled' a -> 'Signal' a-__unbundle__ :: 'Bundle' a => 'Signal' a -> 'Unbundled' a-@--'Unbundled' is an <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-families.html#assoc-decl 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 until and including 8-tuples-  * 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'' clk (a,b) = ('Signal'' clk a, 'Signal'' clk 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' i -> 'Unbundled' 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 (i1,c)-@--The general rule of thumb is: always use 'mealy', unless you do pattern matching-or construction of product types, then use 'mealyB'.--}--{- $annotations-The 'TopEntity' annotations described in this section make it easier to put your-CλaSH design on an FPGA.--We can exert some control how the top level function is created by the CλaSH-compiler by annotating the @topEntity@ function with a 'TopEntity' annotation.-You apply these annotations using the @ANN@ pragma like so:--@-{\-\# ANN topEntity (TopEntity {t_name = ..., ...  }) \#-\}-topEntity x = ...-@--For example, given the following specification:--@-topEntity :: Signal Bit -> Signal (BitVector 8)-topEntity key1 = leds-  where-    key1R = isRising 1 key1-    leds  = mealy blinkerT (1,False,0) key1R--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-@--The CλaSH compiler will normally generate the following @Blinker_topEntity.vhdl@ file:--@--- Automatically generated VHDL-library IEEE;-use IEEE.STD_LOGIC_1164.ALL;-use IEEE.NUMERIC_STD.ALL;-use IEEE.MATH_REAL.ALL;-use work.all;-use work.Blinker_types.all;--entity Blinker_topEntity is-  port(input_0         : in std_logic_vector(0 downto 0);-       -- clock-       system1000      : in std_logic;-       -- asynchronous reset: active low-       system1000_rstn : in std_logic;-       output_0        : out std_logic_vector(7 downto 0));-end;--architecture structural of Blinker_topEntity is-begin-  Blinker_topEntity_0_inst : entity Blinker_topEntity_0-    port map-      (key1_i1         => input_0-      ,system1000      => system1000-      ,system1000_rstn => system1000_rstn-      ,topLet_o        => output_0);-end;-@--However, if we add the following 'TopEntity' annotation in the file:--@-{\-\# ANN topEntity-  ('defTop'-    { t_name     = "blinker"-    , t_inputs   = [\"KEY1\"]-    , t_outputs  = [\"LED\"]-    , t_extraIn  = [ (\"CLOCK_50\", 1)-                   , (\"KEY0\"    , 1)-                   ]-    , t_clocks   = [ 'altpll' "altpll50" "CLOCK_50(0)" "not KEY0(0)" ]-    }) \#-\}-@--The CλaSH compiler will generate the following @blinker.vhdl@ file instead:--@--- Automatically generated VHDL-library IEEE;-use IEEE.STD_LOGIC_1164.ALL;-use IEEE.NUMERIC_STD.ALL;-use IEEE.MATH_REAL.ALL;-use work.all;-use work.Blinker_types.all;--entity blinker is-  port(KEY1     : in std_logic_vector(0 downto 0);-       CLOCK_50 : in std_logic_vector(0 downto 0);-       KEY0     : in std_logic_vector(0 downto 0);-       LED      : out std_logic_vector(7 downto 0));-end;--architecture structural of blinker is-  signal system1000      : std_logic;-  signal system1000_rstn : std_logic;-  signal altpll50_locked : std_logic;-begin-  altpll50_inst : entity altpll50-    port map-      (inclk0 => CLOCK_50(0)-      ,c0     => system1000-      ,areset => not KEY0(0)-      ,locked => altpll50_locked);--  -- reset system1000_rstn is asynchronously asserted, but synchronously de-asserted-  resetSync_n_0 : block-    signal n_1 : std_logic;-    signal n_2 : std_logic;-  begin-    process(system1000,altpll50_locked)-    begin-      if altpll50_locked = '0' then-        n_1 <= '0';-        n_2 <= '0';-      elsif rising_edge(system1000) then-        n_1 <= '1';-        n_2 <= n_1;-      end if;-    end process;--    system1000_rstn <= n_2;-  end block;--  Blinker_topEntity_0_inst : entity Blinker_topEntity_0-    port map-      (key1_i1         => KEY1-      ,system1000      => system1000-      ,system1000_rstn => system1000_rstn-      ,topLet_o        => LED);-end;-@--Where we now have:--* A top-level component that is called @blinker@.-* Inputs and outputs that have a /user/-chosen name: @KEY1@, @LED@, etc.-* An instantiated <https://www.altera.com/literature/ug/ug_altpll.pdf PLL>-  component providing a stable clock signal from the free-running clock pin-  @CLOCK_50@.-* A reset that is /asynchronously/ asserted by the @lock@ signal originating from-  the PLL, meaning that your design is kept in reset until the PLL is-  providing a stable clock.-  The reset is additionally /synchronously/ de-asserted to prevent-  <http://en.wikipedia.org/wiki/Metastability_in_electronics metastability>-  of your design due to unlucky timing of the de-assertion of the reset.--See the documentation of 'TopEntity' for the meaning of all its fields.--}--{- $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 CλaSH 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-CλaSH compiler. You can take a look at the files in-<https://github.com/clash-lang/clash-compiler/tree/master/clash-vhdl/primitives>-(or <https://github.com/clash-lang/clash-compiler/tree/master/clash-verilog/primitives>-for the Verilog primitives or <https://github.com/clash-lang/clash-compiler/tree/master/clash-systemverilog/primitives>-for the SystemVerilog primitives) if you want to know which functions are defined-as \"regular\" primitives. The compiler looks for primitives in two locations:--* The official install location: e.g.-  * @$CABAL_DIR\/share\/\<GHC_VERSION\>\/clash-vhdl\-<VERSION\>\/primitives@-  * @$CABAL_DIR\/share\/\<GHC_VERSION\>\/clash-verilog\-<VERSION\>\/primitives@-  * @$CABAL_DIR\/share\/\<GHC_VERSION\>\/clash-systemverilog\-<VERSION\>\/primitives@-* The current directory (the location given by @pwd@)--Where redefined primitives in the current directory will overwrite those in-the official install location. For now, files containing primitive definitions-must end in the @.json@ file-extension.--CλaSH 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.*#"-  , "templateE" : "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 we define a @template__E__@ field. 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/CλaSH code is:--@--- | blockRAM primitive-blockRam# :: 'KnownNat' n-          => 'SClock' clk       -- ^ 'Clock' to synchronize to-          -> 'Vec' n a          -- ^ Initial content of the BRAM, also-                              -- determines the size, @n@, of the BRAM.-                              ---                              -- __NB__: __MUST__ be a constant.-          -> 'Signal'' clk Int  -- ^ Read address @r@-          -> 'Signal'' clk Bool -- ^ Write enable-          -> 'Signal'' clk Int  -- ^ Write address @w@-          -> 'Signal'' clk a    -- ^ Value to write (at address @w@)-          -> 'Signal'' clk a-          -- ^ Value of the @blockRAM@ at address @r@ from the previous clock-          -- cycle-blockRam# clk content rd en wr din =-    'register'' clk ('errorX' "blockRam#: intial value undefined") dout-  where-    szI  = 'length' content-    dout = runST $ do-      arr <- newListArray (0,szI-1) ('toList' content)-      traverse (ramT arr) ('bundle' (rd,en,wr,din))--    ramT :: STArray s Int e -> (Int,Bool,Int,e) -> ST s e-    ramT ram (r,e,w,d) = do-      -- reading from address using an 'X' exception results in an 'X' result-      r' <- unsafeIOToST $-               catch (evaluate r >>= (return . Right))-                     (\(err :: XException) -> return (Left (throw err)))-      d' <- case r' of-              Right r2 -> readArray ram r2-              Left err -> return err-      -- writing to an address using an 'X' exception makes everything 'X'-      when e (writeArray ram w d)-      return d'-{\-\# NOINLINE blockRam# \#-\}-@--And for which the /declaration/ primitive is:--@-{ \"BlackBox\" :-    { "name" : "CLaSH.Prelude.BlockRam.blockRam#"-    , "type" :-"blockRam# :: KnownNat n       -- ARG[0]-           => SClock clk       -- clk,  ARG[1]-           -> Vec n a          -- init, ARG[2]-           -> Signal' clk Int  -- rd,   ARG[3]-           -> Signal' clk Bool -- wren, ARG[4]-           -> Signal' clk Int  -- wr,   ARG[5]-           -> Signal' clk a    -- din,  ARG[6]-           -> Signal' clk a"-    , "templateD" :-"-- blockRam begin-~GENSYM[~COMPNAME_blockRam][0] : block-  signal ~GENSYM[RAM][1] : ~TYP[2] := ~LIT[2];~IF ~VIVADO ~THEN-  signal ~GENSYM[dout][2] : std_logic_vector(~SIZE[~TYP[6]]-1 downto 0);~ELSE-  signal ~SYM[2] : ~TYP[6];~FI-  signal ~GENSYM[rd][3] : integer range 0 to ~LIT[0] - 1;-  signal ~GENSYM[wr][4] : integer range 0 to ~LIT[0] - 1;-begin-  ~SYM[3] <= to_integer(~ARG[3])-  -- pragma translate_off-                mod ~LIT[0]-  -- pragma translate_on-                ;--  ~SYM[4] <= to_integer(~ARG[5])-  -- pragma translate_off-                mod ~LIT[0]-  -- pragma translate_on-                ;--  ~GENSYM[blockRam_sync][5] : process(~CLK[1])-  begin-    if rising_edge(~CLK[1]) then-      if ~ARG[4] then~IF ~VIVADO ~THEN-        ~SYM[1](~SYM[4]) <= ~TOBV[~ARG[6]][~TYP[6]];~ELSE-        ~SYM[1](~SYM[4]) <= ~ARG[6];~FI-      end if;-      ~SYM[2] <= ~SYM[1](~SYM[3]);-    end if;-  end process;~IF ~VIVADO ~THEN-  ~RESULT <= ~FROMBV[~SYM[2]][~TYPO];~ELSE-  ~RESULT <= ~SYM[2];~FI-end block;--- blockRam end"-    }-}-@--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 we define a @template__D__@ field. 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@: VHDL 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.-* @~CLK[N]@: Clock signal to which the @(N+1)@'th argument is synchronized to.-* @~CLKO@: Clock signal to which the result is synchronized to.-* @~RST[N]@: Asynchronous reset signal to the clock to which the @(N+1)@'th-  argument is synchronized to.-* @~RSTO@: Asynchronous reset signal to the clock to which the result is-  synchronized to.-* @~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: @TYPM[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: @TYPM[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: @TYPM[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\>]@, and @~VIVADO@.-* @~VIVADO@: /1/ when CλaSH compiler is invoked with the @-clash-xilinx@ or-  @-clash-vivado@ flag. To be used with in an @~IF .. ~THEN .. ~ElSE .. ~FI@-  statement.-* @~FROMBV[\<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\>]@.-* @~TOBV[\<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\>]@.--Some final remarks to end this section: VHDL primitives are there to instruct the-CλaSH 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 CλaSH 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 behaviour 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.*#"-  , "templateE" : "~ARG[1] * ~ARG[2]"-  }-}-@--and--@-{ \"BlackBox\" :-    { "name" : "CLaSH.Prelude.BlockRam.blockRam#"-    , "type" :-"blockRam# :: KnownNat n       -- ARG[0]-           => SClock clk       -- clk,  ARG[1]-           -> Vec n a          -- init, ARG[2]-           -> Signal' clk Int  -- rd,   ARG[3]-           -> Signal' clk Bool -- wren, ARG[4]-           -> Signal' clk Int  -- wr,   ARG[5]-           -> Signal' clk a    -- din,  ARG[6]-           -> Signal' clk a"-    , "templateD" :-"// blockRam begin-reg ~TYPO ~GENSYM[RAM][0] [0:~LIT[0]-1];-reg ~TYPO ~GENSYM[dout][1];--reg ~TYP[2] ~GENSYM[ram_init][2];-integer ~GENSYM[i][3];-initial begin-  ~SYM[2] = ~ARG[2];-  for (~SYM[3]=0; ~SYM[3] < ~LIT[0]; ~SYM[3] = ~SYM[3] + 1) begin-    ~SYM[0][~LIT[0]-1-~SYM[3]] = ~SYM[2][~SYM[3]*~SIZE[~TYPO]+:~SIZE[~TYPO]];-  end-end--always @(posedge ~CLK[1]) begin : ~GENSYM[~COMPNAME_blockRam][4]-  if (~ARG[4]) begin-    ~SYM[0][~ARG[5]] <= ~ARG[6];-  end-  ~SYM[1] <= ~SYM[0][~ARG[3]];-end--assign ~RESULT = ~SYM[1];-// blockRam end"-    }-}-@---}--{- $svprimitives-And the equivalent SystemVerilog primitives are:--@-{ \"BlackBox\" :-  { "name"      : "CLaSH.Sized.Internal.Signed.*#"-  , "templateE" : "~ARG[1] * ~ARG[2]"-  }-}-@--and--@-{ \"BlackBox\" :-    { "name" : "CLaSH.Prelude.BlockRam.blockRam#"-    , "type" :-"blockRam# :: KnownNat n       -- ARG[0]-           => SClock clk       -- clk,  ARG[1]-           -> Vec n a          -- init, ARG[2]-           -> Signal' clk Int  -- rd,   ARG[3]-           -> Signal' clk Bool -- wren, ARG[4]-           -> Signal' clk Int  -- wr,   ARG[5]-           -> Signal' clk a    -- din,  ARG[6]-           -> Signal' clk a"-    , "templateD" :-"// blockRam begin-~SIGD[~GENSYM[RAM][0]][2];-logic [~SIZE[~TYP[6]]-1:0] ~GENSYM[dout][1];-initial begin-  ~SYM[0] = ~LIT[2];-end-always @(posedge ~CLK[1]) begin : ~GENSYM[~COMPNAME_blockRam][2]-  if (~ARG[4]) begin-    ~SYM[0][~ARG[5]] <= ~TOBV[~ARG[6]][~TYP[6]];-  end-  ~SYM[1] <= ~SYM[0][~ARG[3]];-end-assign ~RESULT = ~FROMBV[~SYM[1]][~TYP[6]];-// blockRam end"-    }-  }-@---}--{- $multiclock #multiclock#-CλaSH supports multi-clock designs, though perhaps in a slightly limited form.-What is possible is:--* Explicitly assign clocks to memory primitives.-* Synchronise between differently-clocked parts of your design in a type-safe-  way.--What is /not/ possible is:--* Generate a clock signal in module A, and assign this clock signal to a memory-  primitive in module B.--What this means is that when CλaSH 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 synchroniser--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 synchroniser only works for bit-synchronisation and not-word-synchronisation.-The explicitly clocked versions of all synchronous functions and primitives can-be found in "CLaSH.Prelude.Explicit", 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 synchronised to different clocks. Below you can find-the code to build the FIFO synchroniser 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. We'll also import the standard "CLaSH.Prelude"-module, and the "CLaSH.Prelude.Explicit" module for our explicitly clocked-synchronous functions:--@-{\-\# LANGUAGE PartialTypeSignatures \#-\}-{\-\# OPTIONS_GHC -fno-warn-partial-type-signatures \#-\}-module MultiClockFifo where--import CLaSH.Prelude-import CLaSH.Prelude.Explicit-import Data.Maybe             (isJust)-@--Then we'll start with the /heart/ of the FIFO synchroniser, an asynchronous RAM-in the form of 'asyncRam''. It's called an asynchronous RAM because the read-port is not synchronised to any clock (though the write port is). Note that in-CλaSH we don't really have asynchronous logic, there is only combinational and-synchronous logic. As a consequence, we see in the type signature of 'asyncRam'':--@-__asyncRam'__-  :: _-  => SClock wclk                   -- ^ Clock to which to synchronise the write port of the RAM-  -> SClock rclk                   -- ^ Clock to which the read address signal __r__ is synchronised-  -> SNat n                        -- ^ Size __n__ of the RAM-  -> Signal' rclk addr             -- ^ Read address __r__-  -> Signal' wclk (Maybe (addr,a)) -- ^ (write address @w@, value to write)-  -> Signal' rclk a                -- ^ Value of the RAM at address __r__-@--that the signal containing the read address __r__ is synchronised to a different-clock. That is, there is __no__ such thing as an @AsyncSignal@ in CλaSH.--We continue by instantiating the 'asyncRam'':--@-fifoMem wclk rclk addrSize wfull raddr wdataM =-  'asyncRam'' wclk rclk-            ('pow2SNat' addrSize)-            raddr-            ('mux' (not \<$\> wfull)-                 wdataM-                 (pure Nothing))-@--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 $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 addrSize 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 = 'slice' (addrSize ``subSNat`` d1) d0 bin--    flag' = flagGen ptr' s_ptr-@--It is parametrised in both address size, @addrSize@, and status flag generator,-@flagGen@. It has two inputs, @s_ptr@, the synchronised 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 synchronised 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 addrSize ptr s_ptr =-    ptr == 'complement' ('slice' addrSize (addrSize ``subSNat`` d1) s_ptr) '++#'-                      'slice' (addrSize ``subSNat`` d2) d0  s_ptr--wptrFullInit        = (0,0,False)-@--We create a dual flip-flop synchroniser to be used to synchronise the-Gray-encoded pointers between the two clock domains:--@-ptrSync clk1 clk2 = 'register'' clk2 0-                  . 'register'' clk2 0-                  . 'unsafeSynchronizer' clk1 clk2-@--It uses the 'unsafeSynchroniser' 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-CλaSH compiler, so developers must ensure that it is only used as part of a-proper synchronizer.--Finally we combine all the component in:--@-fifo-  :: _-  => SNat (addrSize + 2)-  -> SClock wclk-  -> SClock rclk-  -> Signal' rclk Bool-  -> Signal' wclk (Maybe a)-  -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool)-fifo addrSize wclk rclk rinc wdataM = (rdata,rempty,wfull)-  where-    s_rptr = ptrSync rclk wclk rptr-    s_wptr = ptrSync wclk rclk wptr--    rdata = fifoMem wclk rclk addrSize wfull raddr-               (liftA2 (,) \<$\> (Just \<$\> waddr) \<*\> wdataM)--    (rempty,raddr,rptr) = 'mealyB'' rclk (ptrCompareT addrSize isEmpty) rptrEmptyInit-                                  (s_wptr,rinc)--    (wfull,waddr,wptr)  = 'mealyB'' wclk (ptrCompareT addrSize (isFull addrSize))-                                  wptrFullInit (s_rptr,isJust \<$\> wdataM)-@--where we first specify the synchronisation 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:--@-{\-\# LANGUAGE PartialTypeSignatures \#-\}-{\-\# OPTIONS_GHC -fno-warn-partial-type-signatures \#-\}-module MultiClockFifo where--import CLaSH.Prelude-import CLaSH.Prelude.Explicit-import Data.Maybe             (isJust)--fifoMem wclk rclk addrSize wfull raddr wdataM =-  'asyncRam'' wclk rclk-            ('pow2SNat' addrSize)-            raddr-            ('mux' (not \<$\> wfull)-                 wdataM-                 (pure Nothing))--ptrCompareT addrSize 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 = 'slice' (addrSize ``subSNat`` d1) d0 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 addrSize ptr s_ptr =-    ptr == 'complement' ('slice' addrSize (addrSize ``subSNat`` d1) s_ptr) '++#'-                      'slice' (addrSize ``subSNat`` d2) d0  s_ptr--wptrFullInit        = (0,0,False)---- Dual flip-flop synchroniser-ptrSync clk1 clk2 = 'register'' clk2 0-                  . 'register'' clk2 0-                  . 'unsafeSynchronizer' clk1 clk2---- Async FIFO synchroniser-fifo-  :: _-  => SNat (addrSize + 2)-  -> SClock wclk-  -> SClock rclk-  -> Signal' rclk Bool-  -> Signal' wclk (Maybe a)-  -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool)-fifo addrSize wclk rclk rinc wdataM = (rdata,rempty,wfull)-  where-    s_rptr = ptrSync rclk wclk rptr-    s_wptr = ptrSync wclk rclk wptr--    rdata = fifoMem wclk rclk addrSize wfull raddr-               (liftA2 (,) \<$\> (Just \<$\> waddr) \<*\> wdataM)--    (rempty,raddr,rptr) = 'mealyB'' rclk (ptrCompareT addrSize isEmpty) rptrEmptyInit-                                  (s_wptr,rinc)--    (wfull,waddr,wptr)  = 'mealyB'' wclk (ptrCompareT addrSize (isFull addrSize))-                                  wptrFullInit (s_rptr,isJust \<$\> wdataM)-@--== Instantiating a FIFO synchroniser--Having finished our FIFO synchroniser 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,-while the rest of our system runs at 50 MHz. What we want to do 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.--First, we must calculate the relative clock periods using 'freqCalc':-->>> freqCalc [20,9,50]-[45,100,18]--We can then create the clocks:--@-type ClkADC = 'Clk \"ADC\"    45-type ClkFFT = 'Clk \"FFT\"    100-type ClkSys = 'Clk \"System\" 18--clkADC :: SClock ClkADC-clkADC = sclock--clkFFT :: SClock ClkFFT-clkFFT = sclock--clkSys :: SClock ClkSys-clkSys = sclock-@--and subsequently a 256-space FIFO synchroniser that safely bridges the ADC clock-domain and to the FFT clock domain:--@-adcToFFT-  :: Signal' ClkFFT Bool-  -> Signal' ClkADC (Maybe (SFixed 8 8))-  -> (Signal' ClkFFT (SFixed 8 8), Signal' ClkFFT Bool, Signal' ClkADC Bool)-adcToFFT = fifo d8 clkADC clkFFT-@---}--{- $conclusion-For now, this is the end of this tutorial. We will be adding updates over time,-so check back from time to time. For now, we recommend that you continue with-exploring the "CLaSH.Prelude" module, and get a better understanding of the-capabilities of CλaSH in the process.--}--{- $errorsandsolutions-A list of often encountered errors and their solutions:--* __Type error: Couldn't match expected type @'Signal' (a,b)@ with actual type__-  __@('Signal' a, 'Signal' 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 until and including 8-tuples-    * The 'Vec'tor type--    NB: Use 'bundle'' when you are using explicitly clocked @'Signal''@s--* __Type error: Couldn't match expected type @('Signal' a, 'Signal' b)@ with__-  __ actual type @'Signal' (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 until and including 8-tuples-    * The 'Vec'tor type--    NB: Use 'unbundle'' when you are using explicitly clocked @'Signal''@s--* __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 :: 'Signal' ('Signed' 8) -> 'Signal' ('Signed' 8) -> 'Signal' ('Signed' 8)-    topEntity x y = acc-      where-        acc = 'register' 3 (acc + x * y)-    @--    Or, alternatively:--    @-    topEntity x y = acc-      where-        acc = 'register' (3 :: 'Signed' 8) (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.--* __Can't make testbench for: \<LONG_VERBATIM_COMPONENT_DESCRIPTION\>__:--    * Don't worry, it's actually only a warning.--    * The @topEntity@ function does __not__ have exactly 1 argument. If your-      @topEntity@ has no arguments, you're out of luck for now. If it has-      multiple arguments, consider bundling them in a tuple.--*  __\<*** 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 CλaSH 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 CλaSH compiler makes sense. Also, only certain types of-    recursion are considered non-synthesisable; recursively defined values are-    for example synthesisable: 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 CλaSH 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 /behavioural/ synthesis, something which the CλaSH-        compiler simply does not do. One reason that CλaSH 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 10 fibS-        [0,1,1,2,3,5,8,13,21,34]--        Unlike the @fibR@ function, the above @fibS@ function /is/ synthesisable-        by the CλaSH 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/ synthesisable.--    * __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 CλaSH compiler are very poor, and a user-defined function such as-        the @mapV@ function defined above, is /currently/ not synthesisable.-        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 CλaSH 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 CλaSH 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-    type that is currently supported by the CλaSH compiler is the 'Vec'tor type,-    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.--* __GADT pattern matching__--    While pattern matching for regular ADTs is supported, pattern matching for-    GADTs is __not__. The constructors 'Cons' and 'Nil' of the 'Vec'tor type,-    which is also a GADT, are __no__ exception! However, you can use the-    convenient ':>' pattern synonym.--* __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 @-clash-intwidth=32@ on a 64-bit machine)-        * 'Word'-        * 'Word8'-        * 'Word16'-        * 'Word32'-        * 'Word64' (not available when compiling with @-clash-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 CλaSH-            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 CλaSH compiler to use a specific bit-width for `Int` and-            `Word` using the @-clash-intwidth=N@ flag, where /N/ must either be-            /32/ or /64/.--        *   When you use the @-clash-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-            @-clash-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 CλaSH-            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 CλaSH compiler is running on, or-            the setting of the @-clash-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 CλaSH and Lava is that CλaSH 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 CλaSH 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 CλaSH and its static analysis approach is that CλaSH 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.--}
− src/CLaSH/XException.hs 
@@ -1,337 +0,0 @@-{-|-Copyright  :  (C) 2016, University of Twente, 2017, QBayLogic-License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--'X': An exception for uninitialized values-->>> show (errorX "undefined" :: Integer, 4 :: Int)-"(*** Exception: X: undefined-CallStack (from HasCallStack):-...->>> showX (errorX "undefined" :: Integer, 4 :: Int)-"(X,4)"--}--{-# LANGUAGE DefaultSignatures   #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE MagicHash           #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE TypeOperators       #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -Wno-orphans #-}--module CLaSH.XException-  ( -- * 'X': An exception for uninitialized values-    XException, errorX-    -- * Printing 'X' exceptions as \"X\"-  , ShowX (..), showsX, printX, showsPrecXWith-    -- * Strict evaluation-  , seqX-  )-where--import Control.Exception (Exception, catch, evaluate, throw)-import Data.Complex      (Complex)-import Data.Int          (Int8,Int16,Int32,Int64)-import Data.Ratio        (Ratio)-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.Show          (appPrec)-import GHC.Stack         (HasCallStack, callStack, prettyCallStack)-import System.IO.Unsafe  (unsafeDupablePerformIO)---- | An exception representing an \"uninitialised\" value.-newtype XException = XException String--instance Show XException where-  show (XException s) = s--instance Exception XException---- | Like 'error', but throwing an 'XException' instead of an 'ErrorCall'------ The 'ShowX' methods print these error-values as \"X\"; instead of error'ing--- out with an exception.-errorX :: HasCallStack => String -> a-errorX msg = throw (XException ("X: " ++ msg ++ "\n" ++ prettyCallStack callStack))---- | Like 'seq', however, whereas 'seq' will always do:------ > seq  _|_              b = _|_------ 'seqX' will do:------ > seqX (XException msg) b = b--- > seqX _|_              b = _|_-seqX :: a -> b -> b-seqX a b = unsafeDupablePerformIO-  (catch (evaluate a >> return b) (\(XException _) -> return b))-{-# NOINLINE seqX #-}-infixr 0 `seqX`--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---- | Like the 'Show' class, but values that normally throw an 'X' exception are--- converted to \"X\", instead of error'ing out with an exception.------ >>> show (errorX "undefined" :: Integer, 4 :: Int)--- "(*** Exception: X: undefined--- CallStack (from HasCallStack):--- ...--- >>> showX (errorX "undefined" :: Integer, 4 :: Int)--- "(X,4)"------ Can be derived using 'GHC.Generics':------ > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}--- >--- > import CLaSH.Prelude--- > import GHC.Generics--- >--- > 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.-  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.-  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.-  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--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)--instance {-# OVERLAPPABLE #-} ShowX a => ShowX [a] where-  showsPrecX _ = showListX--instance ShowX Bool--instance ShowX Double where-  showsPrecX = showsPrecXWith showsPrec--instance (ShowX a, ShowX b) => ShowX (Either a b)--instance ShowX Float where-  showsPrecX = showsPrecXWith showsPrec--instance ShowX Int where-  showsPrecX = showsPrecXWith showsPrec--instance ShowX Int8 where-  showsPrecX = showsPrecXWith showsPrec--instance ShowX Int16 where-  showsPrecX = showsPrecXWith showsPrec--instance ShowX Int32 where-  showsPrecX = showsPrecXWith showsPrec--instance ShowX Int64 where-  showsPrecX = showsPrecXWith showsPrec--instance ShowX Integer where-  showsPrecX = showsPrecXWith showsPrec--instance ShowX Word where-  showsPrecX = showsPrecXWith showsPrec--instance ShowX Word8 where-  showsPrecX = showsPrecXWith showsPrec--instance ShowX Word16 where-  showsPrecX = showsPrecXWith showsPrec--instance ShowX Word32 where-  showsPrecX = showsPrecXWith showsPrec--instance ShowX Word64 where-  showsPrecX = showsPrecXWith showsPrec--instance ShowX a => ShowX (Maybe a)--instance ShowX a => ShowX (Ratio a) where-  showsPrecX = showsPrecXWith showsPrecX--instance ShowX a => ShowX (Complex a)--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 "##"
+ src/Clash/Annotations/BitRepresentation.hs view
@@ -0,0 +1,138 @@+{-|+Copyright  :  (C) 2018, Google Inc.+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++Using /ANN/ pragma's you can tell the Clash compiler to use a custom+bit representation for a data type. See @DataReprAnn@ for documentation.++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Clash.Annotations.BitRepresentation+ (+ -- * Data structures to express a custom bit representation+   DataReprAnn(..)+ , ConstrRepr(..)+ -- * Convenience type synonyms for Integer+ , BitMask+ , Value+ , Size+ , FieldAnn++ -- * Functions+ , liftQ+ ) 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+import           GHC.Generics               (Generic)++type BitMask  = Integer+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+liftQ :: TH.Lift a => TH.Q a -> TH.Q TH.Exp+liftQ = (>>= TH.lift)++-- NOTE: The following instances are imported from Language.Haskell.TH.Lift.+-- This module also implements 'instance Lift Exp', which might make debugging+-- template haskell more difficult. Please uncomment these instances and the+-- import of TH.Lift whenever it suits you.+--+--deriving instance TH.Lift TH.Name+--deriving instance TH.Lift TH.OccName+--deriving instance TH.Lift TH.NameFlavour+--deriving instance TH.Lift TH.ModName+--deriving instance TH.Lift TH.NameSpace+--deriving instance TH.Lift TH.PkgName+++-- | Annotation for custom bit representations of data types+--+-- Using /ANN/ pragma's you can tell the Clash compiler to use a custom+-- bit-representation for a data type.+--+-- For example:+--+-- @+-- data Color = R | G | B+-- {-# ANN module ('DataReprAnn'+--                   $('liftQ' [t|Color|])+--                   2+--                   [ 'ConstrRepr' 'R 0b11 0b00 []+--                   , 'ConstrRepr' 'G 0b11 0b01 []+--                   , 'ConstrRepr' 'B 0b11 0b10 []+--                   ]) #-}+-- @+--+-- This specifies that @R@ should be encoded as 0b00, @G@ as 0b01, and+-- @B@ as 0b10. The first binary value in every @ConstrRepr@ in this example+-- is a mask, indicating which bits in the data type are relevant. In this case+-- all of the bits are.+--+-- Or if we want to annotate @Maybe Color@:+--+-- @+-- {-# ANN module ( 'DataReprAnn'+--                    $('liftQ' [t|Maybe Color|])+--                    2+--                    [ 'ConstrRepr' 'Nothing 0b11 0b11 []+--                    , 'ConstrRepr' 'Just 0b00 0b00 [0b11]+--                    ] ) #-}+-- @+--+-- By default, @Maybe Color@ is a data type which consumes 3 bits. A single bit+-- to indicate the constructor (either @Just@ or @Nothing@), and two bits to encode+-- the first field of @Just@. Notice that we saved a single bit by exploiting+-- the fact that @Color@ only uses three values (0, 1, 2), but takes two bits+-- to encode it. We can therefore use the last - unused - value (3), to encode+-- one of the constructors of @Maybe@. We indicate which bits encode the+-- 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:+    TH.Type+    -- Size of type:+    Size+    -- Constructors:+    [ConstrRepr]+      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.+data ConstrRepr =+  ConstrRepr+    -- Constructor name:+    TH.Name+    -- Bits relevant for this constructor:+    BitMask+    -- data & mask should be equal to..:+    Value+    -- Masks for fields. Indicates where fields are stored:+    [FieldAnn]+      deriving (Show, Data, Eq, Generic, TH.Lift)+#if __GLASGOW_HASKELL__ <= 910+      deriving Typeable+#endif
+ src/Clash/Annotations/BitRepresentation/Deriving.hs view
@@ -0,0 +1,1016 @@+{-|+Copyright  :  (C) 2018, Google Inc.,+                  2022, QBayLogic B.V.+                  2022, LUMI GUIDE FIETSDETECTIE B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++This module contains:++  * Template Haskell functions for deriving 'BitPack' instances given a+    custom bit representation as those defined in+    "Clash.Annotations.BitRepresentation".++  * Template Haskell functions for deriving custom bit representations,+    e.g. one-hot, for a data type.++-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Annotations.BitRepresentation.Deriving+  (+  -- * Derivation functions+    deriveAnnotation+  , deriveBitPack+  , deriveDefaultAnnotation+  , derivePackedAnnotation+  , derivePackedMaybeAnnotation+  , deriveBlueSpecAnnotation+  -- * Derivators+  , defaultDerivator+  , blueSpecDerivator+  , packedDerivator+  , packedMaybeDerivator+  , simpleDerivator+  -- * Util functions+  , dontApplyInHDL+  -- * Types associated with various functions+  , ConstructorType(..)+  , FieldsType(..)+  -- * Convenience type synonyms+  , Derivator+  , DataReprAnnExp+  ) where++import Clash.Annotations.BitRepresentation+  (DataReprAnn(..), ConstrRepr(..), BitMask, Value, Size, liftQ)+import Clash.Annotations.BitRepresentation.Internal+  (dataReprAnnToDataRepr', constrReprToConstrRepr', DataRepr'(..))+import Clash.Annotations.BitRepresentation.Util+  (bitOrigins, bitOrigins', BitOrigin(..), bitRanges, Bit)+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.Sized.Internal.BitVector (undefined#)+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.Containers.ListUtils    (nubOrd)+import           Data.List+  (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+  = External+  -- ^ Constructor bit should be stored externally+  | Embedded BitMask Value+  -- ^ Constructor bit should be stored in one of the constructor's fields+    deriving (Show, Data, Lift)+#if __GLASGOW_HASKELL__ < 912+    deriving (Typeable)+#endif++isExternal :: BitMaskOrigin -> Bool+isExternal External = True+isExternal _        = False++type ReprAnnCache = Map.Map Type DataReprAnn++type NameMap = Map.Map Name Type++-- | DataReprAnn as template haskell expression+type DataReprAnnExp = Exp++-- | A derivator derives a bit representation given a type+type Derivator = Type -> Q DataReprAnnExp++-- | Indicates how to pack constructor for simpleDerivator+data ConstructorType+  = Binary+  -- ^ First constructor will be encoded as 0b0, the second as 0b1, the third+  -- as 0b10, etc.+  | OneHot+  -- ^ Reserve a single bit for each constructor marker.++-- | Indicates how to pack (constructor) fields for simpleDerivator+data FieldsType+  = OverlapL+  -- ^ Store fields of different constructors at (possibly) overlapping bit+  -- positions. That is, a data type with two constructors with each two fields+  -- of each one bit will take /two/ bits for its whole representation (plus+  -- constructor bits). Overlap is left-biased, i.e. don't care bits are padded+  -- to the right.+  --+  -- This is the default behavior of Clash.+  | OverlapR+  -- ^ Store fields of different constructors at (possibly) overlapping bit+  -- positions. That is, a data type with two constructors with each two fields+  -- of each one bit will take /two/ bits for its whole representation (plus+  -- constructor bits). Overlap is right biased, i.e. don't care bits are padded+  -- between between the constructor bits and the field bits.+  | Wide+  -- ^ Store fields of different constructs at non-overlapping positions. That+  -- is, a data type with two constructors with each two fields of each one bit+  -- will take /four/ bits for its whole representation (plus constructor bits).++-- | Determine most significant bit set for given integer.+--+-- TODO: Current complexity is O(n). We could probably use machine instructions+-- for ~constant complexity.+msb :: Integer -> Int+msb 0 = error $ "Most significant bit does not exist for zero."+msb 1 = 0+msb n = 1 + msb (shiftR n 1)++mkReprAnnCache :: [DataReprAnn] -> ReprAnnCache+mkReprAnnCache anns =+  Map.fromList [(typ, rAnn) | rAnn@(DataReprAnn typ _ _) <- anns]++-- | Integer version of (ceil . log2). Can handle arguments up to 2^(2^WORDWIDTH).+integerLog2Ceil :: Integer -> Int+integerLog2Ceil n =+  let nlog2 = fromIntegral $ I# (integerLog2# n) in+  if n > 2^nlog2 then nlog2 + 1 else nlog2++-- | Determine number of bits needed to represent /n/ options. Alias for+-- integerLog2Ceil to increase readability of programmer intentention.+bitsNeeded :: Integer -> Int+bitsNeeded = integerLog2Ceil++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+resolve nmap (VarT n) = nmap Map.! n+resolve nmap (AppT t1 t2) = AppT (resolve nmap t1) (resolve nmap t2)+resolve _nmap t@(ConT _) = t+resolve _nmap t@(LitT _) = t+resolve _nmap t@(TupleT _) = t+resolve _nmap t = error $ "Unexpected type: " ++ show t++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++collectTypeArgs :: Type -> (Type, [Type])+collectTypeArgs t@(ConT _name) = (t, [])+collectTypeArgs (AppT t1 t2) =+  let (base, args) = collectTypeArgs t1 in+  (base, args ++ [t2])+collectTypeArgs t =+  error $ "Unexpected type: " ++ show t++-- | Returns size in number of bits of given type. Relies on the presence of a+-- BitSize implementation. Tries to recognize literal values and return a simple+-- expression.+typeSize :: Type -> Q Exp+typeSize typ = do+  bitSizeInstances <- reifyInstances ''BitSize [typ]+  case bitSizeInstances of+    [] ->+      fail $ unwords [+          "Could not find custom bit representation nor BitSize instance"+        , "for", show typ ++ "." ]+    [TySynInstD (TySynEqn _ _ (LitT (NumTyLit n)))] ->+      [| n |]+    [_impl] ->+      [| fromIntegral $ natVal (Proxy :: Proxy (BitSize $(return typ))) |]+    unexp ->+      fail $ "Unexpected result from reifyInstances: " ++ show unexp++-- | Generate bitmask from a given bit, with a certain size+bitmask+  :: Int+  -- ^ Bitmask starts at bit /n/+  -> Int+  -- ^ Bitmask has size /m/+  -> Integer+bitmask _start 0    = 0+bitmask start  size+  | start < 0        = error $ "Start cannot be <0. Was: " ++ show start+  | size < 0         = error $ "Size cannot be <0. Was: " ++ show size+  | start + 1 < size = error $ "Start + 1 (" ++ show start ++ " - 1) cannot be smaller than size (" ++ show size ++  ")."+  | otherwise        = shiftL (2^(toInteger size) - 1) (start - (size - 1))+++fieldTypes :: Con -> [Type]+fieldTypes (NormalC _nm bTys) =+  [ty | (_, ty) <- bTys]+fieldTypes (RecC _nm bTys) =+  [ty | (_, _, ty) <- bTys]+fieldTypes (InfixC (_, ty1) _nm (_, ty2)) =+  [ty1, ty2]+fieldTypes con =+  error $ "Unexpected constructor type: " ++ show con++conName :: Con -> Name+conName c = case c of+  NormalC nm _  -> nm+  RecC    nm _  -> nm+  InfixC _ nm _ -> nm+  _ -> error $ "No GADT support"++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 =+  let size' = size - 1 in+  if testBit i size' then+    complementInteger size' i+  else+    (.|.) (bit size') (complementInteger size' i)++deriveAnnotation :: Derivator -> Q Type -> Q [Dec]+deriveAnnotation deriv typ =+  return <$> pragAnnD ModuleAnnotation (deriv =<< typ)++--------------------------------------------+------------ SIMPLE DERIVATIONS ------------+--------------------------------------------+buildConstrRepr+  :: Q Exp+  -- ^ Data size (excluding constructor size)+  -> Name+  -- ^ Constr name+  -> [Q Exp]+  -- ^ Field masks+  -> BitMask+  -- ^ Constructor mask+  -> Value+  -- ^ Constructor value+  -> Q Exp+buildConstrRepr dataSize constrName fieldAnns constrMask constrValue = [|+  ConstrRepr+    constrName+    $mask+    $value+    $(listE fieldAnns)+  |]+  where+    mask  = [| shiftL constrMask  ($dataSize)|]+    value = [| shiftL constrValue ($dataSize)|]++countConstructor :: [Int] -> [(BitMask, Value)]+countConstructor ns = zip (repeat mask) (map toInteger ns)+  where+    maskSize = bitsNeeded $ toInteger $ maximum ns + 1+    mask = 2^maskSize - 1++oneHotConstructor :: [Int] -> [(BitMask, Value)]+oneHotConstructor ns = zip values values+  where+    values = [shiftL 1 n | n <- ns]++overlapFieldAnnsL :: [[Q Exp]] -> ([Q Dec], [[Q Exp]])+overlapFieldAnnsL fieldSizess = ([maxDecl],  resExp)+  where+    (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 |]))+        maxExp+        fieldsizes++overlapFieldAnnsR :: [[Q Exp]] -> ([Q Dec], [[Q Exp]])+overlapFieldAnnsR fieldSizess = (sumFieldDecl, resExp)+  where+    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 |]))+        [| $sumFieldsSize - 1 |]+        fieldSizes++wideFieldAnns :: [[Q Exp]] -> ([Q Dec], [[Q Exp]])+wideFieldAnns fieldSizess = (decs, resExp)+  where+    decs = (dataSizeDec:constrSizeDecs) ++ constrOffsetDecs+    resExp = zipWith id (map go constrOffsetsExps) fieldSizess+    nums = map show [(0 :: Int) ..]++    constrSizeExps :: [Q Exp]+    (constrSizeDecs, constrSizeExps)+      = unzip $ zipWith+          (\fs i -> mkLet ("_sumf" ++ i) [|sum @[] @Int $(listE fs)|])+          fieldSizess+          nums++    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 |]))+        [| $dataSizeExp - $offset |]+        fieldSizes++-- | Derive DataRepr' for a specific type.+deriveDataRepr+  :: ([Int] -> [(BitMask, Value)])+  -- ^ Constructor derivator+  -> ([[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 = map conName resolvedConstructors++      let+        (constrMasks, constrValues) =+          unzip $ constrDerivator [0..length dConstructors - 1]++      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 @[] @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 dataSizeExp)+                          constrNames+                          fieldAnnVars+                          constrMasks+                          constrValues++      resolvedType <- resolveTypeSynonyms typ++      letE decls [| DataReprAnn+          $(liftQ $ return resolvedType)+          ($dataSizeExp + constrSize)+          $(listE constrReprs) |]+    _ ->+      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.+simpleDerivator :: ConstructorType -> FieldsType -> Derivator+simpleDerivator ctype ftype = deriveDataRepr constrDerivator fieldsDerivator+  where+    constrDerivator =+      case ctype of+        Binary -> countConstructor+        OneHot -> oneHotConstructor++    fieldsDerivator =+      case ftype of+        OverlapL -> overlapFieldAnnsL+        OverlapR -> overlapFieldAnnsR+        Wide -> wideFieldAnns++-- | Derives bit representation corresponding to the default manner in which+-- Clash stores types.+defaultDerivator :: Derivator+defaultDerivator = simpleDerivator Binary OverlapL++-- | Derives bit representation corresponding to the default manner in which+-- BlueSpec stores types.+blueSpecDerivator :: Derivator+blueSpecDerivator = simpleDerivator Binary OverlapR++-- | Derives bit representation corresponding to the default manner in which+-- Clash stores types.+deriveDefaultAnnotation :: Q Type -> Q [Dec]+deriveDefaultAnnotation = deriveAnnotation defaultDerivator+++-- | Derives bit representation corresponding to the default manner in which+-- BlueSpec stores types.+deriveBlueSpecAnnotation :: Q Type -> Q [Dec]+deriveBlueSpecAnnotation = deriveAnnotation blueSpecDerivator++---------------------------------------------------------------+------------ DERIVING PACKED MAYBE REPRESENTATIONS ------------+---------------------------------------------------------------+toBits'+  :: Bits a+  => Size+  -> a+  -> [Bit']+toBits' 0 _ = []+toBits' size bits = bit' : toBits' (size - 1) bits+  where bit' = if testBit bits (size - 1) then H else L++bitsToInteger' :: (Bit' -> Bool) -> [Bit'] -> Integer+bitsToInteger' predFunc bits = foldl setBit 0 toSet+  where+    toSet = [n | (n, b) <- zip [0..] (reverse bits), predFunc b]++bitsToInteger :: [Bit'] -> Integer+bitsToInteger = bitsToInteger' (==H)++bitsToMask :: [Bit'] -> Integer+bitsToMask = bitsToInteger' (\b -> b == H || b == L)++data Bit'+  = X+  -- ^ Could be both 1 or 0+  | L+  -- ^ 0+  | H+  -- ^ 1+  | U+  -- ^ Unused+    deriving (Show, Eq, Generic, NFData)++-- | Given a number of possible values, construct a list of all complement values.+-- For example, Given a list:+--+-- @+-- [[HH, HH], [LL, LL]]+-- @+--+-- then:+--+-- @+-- [[HH, LL], [LL, HH]]+-- @+--+-- would be complements.+complementValues+  :: Size+  -> [[Bit']]+  -> [[Bit']]+complementValues 0 _ = []+complementValues 1 xs+  | X `elem` xs'                 = []+  | H `elem` xs' && L `elem` xs' = []+  | H `elem` xs'                 = [[L]]+  | otherwise                    = [[H]]+  where+    xs' = map (maybe (error "complementValues: expected at least 1 bit") fst . uncons) xs+complementValues size [] = [replicate size U]+complementValues size 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 (drop 1) lows))) +++        (map (H:) (recc (map (drop 1) highs')))+  where+    values'       = filter (any (/= U)) values+    recc          = complementValues (size - 1)+    (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+  :: ReprAnnCache+  -> Type+  -> Size+  -> Q [[Bit']]+possibleValues typeMap typ size =+  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+      case info of+        -- TODO: check if fields have custom bit representations+        (TyConI (DataD [] _constrName _vars _kind dConstructors _clauses)) ->+          let nConstrBits = bitsNeeded (toInteger $ length dConstructors) in+          let fieldBits = replicate (size - nConstrBits) X in+          let constrBits = [toBits' nConstrBits n | n <- [0..length dConstructors - 1]] in+          return $ zipWith (++) constrBits (repeat fieldBits)+        _ ->+          return [replicate size X]++    Just (dataReprAnnToDataRepr' -> dataRepr) ->+      -- TODO: check if fields have custom bit representations+      let (DataRepr' _name _size constrs) = dataRepr in+      forM constrs $ \constr -> do+        return $+          map+            (\case { Lit [Util.H] -> H;+                     Lit [Util.L] -> L;+                     Lit [Util.U] -> U;+                     Field _ _ _  -> X;+                     c -> error $ "possibleValues (2): unexpected: " ++ show c; })+            (bitOrigins' dataRepr constr)++packedMaybe :: Size -> Type -> Q (Maybe DataReprAnn)+packedMaybe size typ = do+  cache <- mkReprAnnCache <$> collectDataReprs+  values <- possibleValues cache typ size+  return $ case complementValues size values of+             (value:_) ->+               Just $ DataReprAnn+                        (AppT (ConT ''Maybe) typ)+                        size+                        [ ConstrRepr+                            'Nothing+                            (bitsToMask value)+                            (bitsToInteger value)+                            []+                        , ConstrRepr+                            'Just+                            0+                            0+                            [bitmask (size - 1) size] ]+             [] ->+               Nothing+++packedMaybeDerivator :: DataReprAnn -> Derivator+packedMaybeDerivator (DataReprAnn _ size _) typ =+  case maybeCon of+    ConT nm ->+      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?" ]+        packedM <- packedMaybe (size - 1)+                    (maybe (error "Maybe type without argument") fst (uncons maybeTyps))+        (fromMaybe (fail err) . fmap lift) packedM+      else+        fail $ unwords [ "You can only pass Maybe types to packedMaybeDerivator,"+                        , "not", show nm]+    unexpected ->+      fail $ "packedMaybeDerivator: unexpected constructor: " ++ show unexpected+  where+    (maybeCon, maybeTyps) = collectTypeArgs typ++-- | Derive a compactly represented version of @Maybe a@.+derivePackedMaybeAnnotation :: DataReprAnn -> Q [Dec]+derivePackedMaybeAnnotation defaultDataRepr@(DataReprAnn typ _ _) = do+  deriveAnnotation (packedMaybeDerivator defaultDataRepr) (return typ)++---------------------------------------------------------+------------ DERIVING PACKED REPRESENTATIONS ------------+---------------------------------------------------------+packedConstrRepr+  :: Int+  -- ^ Data width+  -> Int+  -- ^ External constructor width+  -> Int+  -- ^ nth External so far+  -> [(BitMaskOrigin, ConstrRepr)]+  -> [ConstrRepr]+packedConstrRepr _ _ _ [] = []+packedConstrRepr dataWidth constrWidth n ((External, ConstrRepr name _ _ anns) : constrs) =+  constr : packedConstrRepr dataWidth constrWidth (n+1) constrs+  where+    constr =+      ConstrRepr+        name+        (shiftL (2^constrWidth - 1) dataWidth)+        (shiftL (toInteger n) dataWidth)+        anns++packedConstrRepr dataWidth constrWidth n ((Embedded mask value, ConstrRepr name _ _ anns) : constrs) =+  constr : packedConstrRepr dataWidth constrWidth n constrs+  where+    constr =+      ConstrRepr+        name+        mask+        value+        anns++packedDataRepr+  :: Type+  -> Size+  -> [(BitMaskOrigin, ConstrRepr)]+  -> DataReprAnn+packedDataRepr typ dataWidth constrs =+  DataReprAnn+    typ+    (dataWidth + constrWidth)+    (packedConstrRepr dataWidth constrWidth 0 constrs)+  where+    external    = filter isExternal (map fst constrs)+    constrWidth = bitsNeeded $ toInteger $ min (length external + 1) (length constrs)++-- | Try to distribute constructor bits over fields+storeInFields+  :: Int+  -- ^ data width+  -> BitMask+  -- ^ Additional mask gathered so far+  -> [BitMask]+  -- ^ Repr bitmasks to try and pack+  -> [BitMaskOrigin]+storeInFields _dataWidth _additionalMask [] = []+storeInFields _dataWidth _additionalMask [_] =+  -- Last constructor is implict+  [Embedded 0 0]+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 constrRest+  else+    -- Hooray, we can store it somewhere.+    maskOrigins ++ (storeInFields dataWidth additionalMask' (drop storeSize constrs))++  where+    headMask   = constr+    commonMask = (.|.) headMask additionalMask++    -- Variables for the case that we can store something:+    storeMask       = complementInteger dataWidth commonMask+    additionalMask' = (.|.) additionalMask storeMask+    storeSize       = 2^(popCount storeMask) - 1+    maskOrigins     = [Embedded storeMask (toInteger n) | n <- [1..storeSize]]++    -- BitMask which spans the complete data size+    fullMask = 2^dataWidth - 1++derivePackedAnnotation' :: DataReprAnn -> DataReprAnn+derivePackedAnnotation' (DataReprAnn typ size constrs) =+  dataRepr+  where+    constrWidth = bitsNeeded $ toInteger $ length constrs+    dataWidth   = size - constrWidth+    fieldMasks  = [foldl (.|.) zeroBits anns | ConstrRepr _ _ _ anns <- constrs]++    -- Default annotation will overlap "to the left", so sorting on size will+    -- actually provide us with the 'fullest' constructors first and the+    -- 'empties' last.+    sortedMasks = reverse $ sortOn fst $ zip fieldMasks constrs+    origins     = storeInFields dataWidth zeroBits (map fst sortedMasks)+    constrs'    = zip origins $ map snd sortedMasks+    dataRepr    = packedDataRepr typ dataWidth constrs'++-- | This derivator tries to distribute its constructor bits over space left+-- by the difference in constructor sizes. Example:+--+-- @+-- type SmallInt = Unsigned 2+--+-- data Train+--    = Passenger SmallInt+--    | Freight SmallInt SmallInt+--    | Maintenance+--    | Toy+-- @+--+-- The packed representation of this data type needs only a single constructor+-- bit. The first bit discriminates between @Freight@ and non-@Freight@+-- constructors. All other constructors do not use their last two bits; the+-- packed representation will store the rest of the constructor bits there.+packedDerivator :: Derivator+packedDerivator typ =+  [| derivePackedAnnotation' $(defaultDerivator typ ) |]++derivePackedAnnotation :: Q Type -> Q [Dec]+derivePackedAnnotation = deriveAnnotation packedDerivator++----------------------------------------------------+------------ DERIVING BITPACK INSTANCES ------------+----------------------------------------------------++-- | Collect data reprs of current module+collectDataReprs :: Q [DataReprAnn]+collectDataReprs = do+  thisMod <- thisModule+  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+      | otherwise = do+          ModuleInfo newMods <- reifyModule x+          newAnns <- reifyAnnotations $ AnnLookupModule x+          go (newMods ++ xs) (x `Set.insert` visited) (newAnns ++ acc)++group :: [Bit] -> [(Int, Bit)]+group [] = []+group bs@(b:_) = (length head', b) : rest+  where+    tail' = dropWhile (==b) bs+    head' = takeWhile (==b) bs+    rest  = group tail'++bitToExpr' :: (Int, Bit) -> Q Exp -- BitVector n+bitToExpr' (0, _) = fail $ "Unexpected group length: 0"+bitToExpr' (numTyLit' -> n, Util.H) =+  [| complement (resize (pack low) :: BitVector $n) |]+bitToExpr' (numTyLit' -> n, Util.L) =+  [| resize (pack low) :: BitVector $n |]+bitToExpr' (numTyLit' -> n, _) =+  [| undefined# :: BitVector $n |]++bitsToExpr :: [Bit] -> Q Exp -- BitVector n+bitsToExpr [] = fail $ "Unexpected empty bit list"+bitsToExpr bits =+  foldl1+    (\v1 v2 -> [| $v1 ++# $v2 |])+    (map bitToExpr' $ group bits)++numTyLit' :: Integral a => a -> Q Type+numTyLit' n = LitT <$> (numTyLit $ toInteger n)++-- | Select a list of ranges from a bitvector expression+select'+  :: Exp+  -> [(Int, Int)]+  -> Q Exp+select' _vec [] =+  fail $ "Unexpected empty list of intervals"+select' vec ranges =+  foldl1 (\v1 v2 -> [| $v1 ++# $v2 |]) $ map (return . select'') ranges+    where+      select'' :: (Int, Int) -> Exp+      select'' (from, downto) =+        let size = from - downto + 1 in+        let+          shifted+            | downto == 0 =+                vec+            | otherwise =+                AppE+                  (AppE (VarE 'shiftR) vec)+                  (LitE $ IntegerL $ toInteger downto) in++        SigE+          -- Select from whole vector+          (AppE (VarE 'resize) shifted)+          -- Type signature:+          (AppT (ConT ''BitVector) (LitT $ NumTyLit $ toInteger size))++-- | Select a range (bitorigin) from a bitvector+select+  :: [Exp]+  -- ^ BitVectors of fields+  -> BitOrigin+  -- ^ Select bits+  -> Q Exp+select _fields (Lit []) =+  fail $ "Unexpected empty literal."+select _fields (Lit lits) = do+  let size = length lits+  vec <- bitsToExpr lits+  return $ SigE+            -- Apply bLit to literal string+            vec+            -- Type signature:+            (AppT (ConT ''BitVector) (LitT $ NumTyLit $ toInteger size))++select fields (Field fieldn from downto) =+  select' (fields !! fieldn) [(from, downto)]++buildPackMatch+  :: DataReprAnn+  -> ConstrRepr+  -> Q Match+buildPackMatch dataRepr cRepr@(ConstrRepr name _ _ fieldanns) = do+  fieldNames <-+    mapM (\n -> newName $ "field" ++ show n) [0..length fieldanns-1]+  fieldPackedNames <-+    mapM (\n -> newName $ "fieldPacked" ++ show n) [0..length fieldanns-1]++  let packed fName = AppE (VarE 'pack) (VarE fName)+  let pack' pName fName = ValD (VarP pName) (NormalB $ packed fName) []+  let fieldPackedDecls = zipWith pack' fieldPackedNames fieldNames+  let origins = bitOrigins+                  (dataReprAnnToDataRepr' dataRepr)+                  (constrReprToConstrRepr' undefined cRepr)++  vec <- foldl1+              (\v1 v2 -> [| $v1 ++# $v2 |])+              (map (select $ map VarE fieldPackedNames) origins)++  return $ Match (ConP name [] (VarP <$> fieldNames)) (NormalB vec) fieldPackedDecls++-- | Build a /pack/ function corresponding to given DataRepr+buildPack+  :: DataReprAnn+  -> Q [Dec]+buildPack dataRepr@(DataReprAnn _name _size constrs) = do+  argNameIn    <- newName "toBePackedIn"+  argName      <- newName "toBePacked"+  constrs'     <- mapM (buildPackMatch dataRepr) constrs+  let packBody    = CaseE (VarE argName) constrs'+  let packLambda  = LamE [VarP argName] packBody+  let packApplied = (VarE 'dontApplyInHDL) `AppE` (VarE 'packXWith `AppE` packLambda) `AppE` (VarE argNameIn)+  let func        = FunD 'pack [Clause [VarP argNameIn] (NormalB packApplied) []]+  return [func]+++-- | In Haskell apply the first argument to the second argument,+--   in HDL just return the second argument.+--+-- This is used in the generated pack/unpack to not do anything in HDL.+dontApplyInHDL :: (a -> b) -> a -> b+dontApplyInHDL f a = f a+{-# OPAQUE dontApplyInHDL #-}+{-# ANN dontApplyInHDL hasBlackBox #-}++buildUnpackField+  :: Name+  -> Integer+  -> Q Exp+buildUnpackField valueName mask =+  let ranges = bitRanges mask in+  let vec = select' (VarE valueName) ranges in+  [| unpack $vec |]++buildUnpackIfE+  :: Name+  -> ConstrRepr+  -> Q (Guard, Exp)+buildUnpackIfE valueName (ConstrRepr name mask value fieldanns) = do+  let valueName' = return $ VarE valueName+  guard  <- NormalG <$> [| ((.&.) $valueName' mask) == value |]+  fields <- mapM (buildUnpackField valueName) fieldanns+  return (guard, foldl AppE (ConE name) fields)++-- | Build an /unpack/ function corresponding to given DataRepr+buildUnpack+  :: DataReprAnn+  -> Q [Dec]+buildUnpack (DataReprAnn _name _size constrs) = do+  argNameIn   <- newName "toBeUnpackedIn"+  argName     <- newName "toBeUnpacked"+  matches     <- mapM (buildUnpackIfE argName) constrs+  let fallThroughLast []      = []+      fallThroughLast [(_,e)] = [(NormalG (ConE 'True), e)]+      fallThroughLast (x:xs)  = x:fallThroughLast xs++  let unpackBody    = MultiIfE (fallThroughLast matches)+  let unpackLambda  = LamE [VarP argName] unpackBody+  let unpackApplied = (VarE 'dontApplyInHDL) `AppE` unpackLambda `AppE` (VarE argNameIn)+  let func          = FunD 'unpack [Clause [VarP argNameIn] (NormalB unpackApplied) []]+  return [func]++-- | Derives BitPack instances for given type. Will account for custom bit+-- representation annotations in the module where the splice is ran. Note that+-- 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++  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++  let (DataReprAnn _name dataSize _constrs) = ann++  let bitSizeInst = mkTySynInstD ''BitSize [typ] (LitT (NumTyLit $ toInteger dataSize))++  let bpInst = [ InstanceD+                   (Just Overlapping)+                   -- Overlap+                   []+                   -- Context+                   (AppT (ConT ''BitPack) typ)+                   -- Type+                   (bitSizeInst : packFunc ++ unpackFunc)+                   -- Declarations+               ]+  alreadyIsInstance <- isInstance ''BitPack [typ]+  if alreadyIsInstance then+    fail $ show typ ++ " already has a BitPack instance."+  else+    return bpInst
+ src/Clash/Annotations/BitRepresentation/Internal.hs view
@@ -0,0 +1,146 @@+{-|+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 CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Clash.Annotations.BitRepresentation.Internal+  ( buildCustomReprs+  , dataReprAnnToDataRepr'+  , constrReprToConstrRepr'+  , getConstrRepr+  , uncheckedGetConstrRepr+  , getDataRepr+  , thTypeToType'+  , ConstrRepr'(..)+  , DataRepr'(..)+  , Type'(..)+  , CustomReprs+  ) where++import           Clash.Annotations.BitRepresentation+  (BitMask, Value, Size, FieldAnn, DataReprAnn(..), ConstrRepr(..))+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.+data Type'+  = AppTy' Type' Type'+  -- ^ Type application+  | ConstTy' Text.Text+  -- ^ Qualified name of type+  | LitTy' Integer+  -- ^ Numeral literal (used in BitVector 10, for example)+  | 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'+  { 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'+  { 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) =+  ConstrRepr' (thToText name) n mask value (map fromIntegral fieldanns)++dataReprAnnToDataRepr' :: DataReprAnn -> DataRepr'+dataReprAnnToDataRepr' (DataReprAnn typ size constrs) =+  DataRepr' (thTypeToType' typ) size (zipWith constrReprToConstrRepr' [0..] constrs)++thToText :: TH.Name -> Text.Text+thToText (TH.Name (TH.OccName name') (TH.NameG _namespace _pkgName (TH.ModName modName))) =+  Text.pack $ modName ++ "." ++ name'+thToText name' = error $ "Unexpected pattern: " ++ show name'++-- | Convert template haskell type to simple representation of type+thTypeToType' :: TH.Type -> Type'+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+type CustomReprs =+  ( Map.Map Type' DataRepr'+  , Map.Map Text.Text ConstrRepr'+  )++-- | Lookup data type representation based on name+getDataRepr :: Type' -> CustomReprs -> Maybe DataRepr'+getDataRepr name (reprs, _) = Map.lookup name reprs++-- | Lookup constructor representation based on name+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+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 addCustomRepr (Map.empty, Map.empty)
+ src/Clash/Annotations/BitRepresentation/Util.hs view
@@ -0,0 +1,156 @@+{-|+Copyright  :  (C) 2018, Google Inc.+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++module Clash.Annotations.BitRepresentation.Util+  ( bitOrigins+  , bitOrigins'+  , bitRanges+  , isContinuousMask+  , BitOrigin(..)+  , Bit(..)+  ) where+++import Clash.Annotations.BitRepresentation.Internal+  (DataRepr'(..), ConstrRepr'(..))+import Data.Bits  (Bits, testBit, testBit, shiftR, (.|.))+import Data.List  (findIndex, group, mapAccumL, uncons)+import Data.Tuple (swap)++data Bit+  -- | High+  = H+  -- | Low+  | L+  -- | Undefined+  | U+    deriving (Show,Eq)++-- | Result of various utilty functions. Indicates the origin of a certain bit:+-- either a literal from the constructor (or an undefined bit), or from a+-- literal.+data BitOrigin+  -- | Literal (high, low, undefind)+  = Lit [Bit]+  -- | Bits originate from a field. Field /fieldnr/ /from/ /downto/.+  | Field+      Int+      -- Field number+      Int+      -- Start bit (from..)+      Int+      -- End bit (inclusive, ..downto)+        deriving (Show)++-- | Same as bitOrigins, but each item in result list represents a single bit.+bitOrigins'+  :: DataRepr'+  -> ConstrRepr'+  -> [BitOrigin]+bitOrigins' (DataRepr' _ size constrs) (ConstrRepr' _ _ mask value fields) =+  map bitOrigin (reverse [0..fromIntegral $ size - 1])+    where+      commonMask = foldl (.|.) 0 [m | ConstrRepr' _ _ m _ _ <- constrs]++      -- | Determine origin of single bit+      bitOrigin :: Int -> BitOrigin+      bitOrigin n =+        if testBit mask n then+          Lit [if testBit value n then H else L]+        else+          case findIndex (\fmask -> testBit fmask n) fields of+            Nothing ->+              if testBit commonMask n then+                -- This bit is not used in this constructor, nor is it part of+                -- a field. We cannot leave this value uninitialized though, as+                -- this would result in undefined behavior when matching other+                -- constructors. We therefore take a /default/ bit value.+                Lit [if testBit value n then H else L]+              else+                -- This bit is not used in this constructor, nor is it part of+                -- a field, nor is it used in other constructors. It is safe to+                -- leave this bit uninitialized.+                Lit [U]+            Just fieldn ->+              let fieldbitn = length $ filter id+                                     $ take n+                                     $ bitsToBools (fields !! fieldn) in+              Field fieldn fieldbitn fieldbitn++-- | Given a type size and one of its constructor this function will yield a+-- specification of which bits the whole type is made up of. I.e., a+-- construction plan on how to make the whole data structure, given its+-- individual constructor fields.+bitOrigins+  :: DataRepr'+  -> ConstrRepr'+  -> [BitOrigin]+bitOrigins dataRepr constrRepr =+  mergeOrigins (bitOrigins' dataRepr constrRepr)++-- | Merge consequtive Constructor and Field fields (if applicable).+mergeOrigins :: [BitOrigin] -> [BitOrigin]+mergeOrigins (Lit n : Lit n' : fs) =+  -- Literals can always be merged:+  mergeOrigins $ Lit (n ++ n') : fs+mergeOrigins (Field n s e : Field n' s' e' : fs)+  -- Consequtive fields with same field number merged:+  | n == n'   = mergeOrigins $ Field n s e' : fs+  -- No merge:+  | otherwise = Field n s e : mergeOrigins (Field n' s' e' : fs)+-- Base cases:+mergeOrigins (x:fs) = x : mergeOrigins fs+mergeOrigins []     = []++-- | Convert a number to a list of its bits+-- Output is ordered from least to most significant bit.+-- Only outputs bits until the highest set bit.+--+-- @+-- > 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.+bitsToBools :: (Num a, Bits a, Ord a) => a -> [Bool]+bitsToBools 0 = []+bitsToBools n | n < 0 = error "Can't deal with negative bitmasks/values"+              | otherwise = testBit n 0 : bitsToBools (n `shiftR` 1)+++offsets+  :: Int+  -- ^ Offset+  -> [Bool]+  -- ^ Group+  -> (Int, (Int, [Bool]))+offsets offset group' =+  (length group' + offset, (offset, group'))++-- | Determine consecutively set bits in word. Will produce ranges from high+-- to low. Examples:+--+--   bitRanges 0b10          == [(1,1)]+--   bitRanges 0b101         == [(2,2),(0,0)]+--   bitRanges 0b10011001111 == [(10,10),(7,6),(3,0)]+--+bitRanges :: Integer -> [(Int, Int)]+bitRanges word = reverse $ map swap ranges+  where+    ranges  = map (\(ofs, grp) -> (ofs, ofs+length grp-1)) groups'+    groups' = filter (maybe False fst . uncons . snd) groups+    groups  = snd $ mapAccumL offsets 0 (group bits)+    bits    = bitsToBools word++isContinuousMask :: Integer -> Bool+isContinuousMask word =+  -- Use case expression so we avoid calculating all groups+  case bitRanges word of+    -- At least two groups:+    (_:_:_) -> False+    -- Zero or one group:+    _       -> True
+ src/Clash/Annotations/Primitive.hs view
@@ -0,0 +1,319 @@+{-|+Copyright  :  (C) 2017-2019, Myrtle Software+                  2022,      QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++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 LambdaCase #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++{-# LANGUAGE Safe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Annotations.Primitive+  ( dontTranslate+  , hasBlackBox+  , warnNonSynthesizable+  , warnAlways+  , Primitive(..)+  , HDL(..)+  , PrimitiveGuard(..)+  , PrimitiveWarning(..)+  , extractPrim+  , extractWarnings+  ) where++import           Control.DeepSeq                          (NFData)+import           Data.Binary                              (Binary)+import           Data.Data+import           Data.Hashable                            (Hashable)+import           GHC.Generics                             (Generic)+++-- The commented code directly below this comment is affected by an old+-- 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.++{-++guard :: TH.Exp -> TH.Name -> TH.Q [TH.Dec]+guard guardExpr fName =+  pure+    [ TH.PragmaD (TH.InlineP fName TH.NoInline TH.FunLike TH.AllPhases)+    , TH.PragmaD (TH.AnnP (TH.ValueAnnotation fName) (TH.SigE guardExpr typ))+    ]+  where+    typ = TH.AppT (TH.ConT ''PrimitiveGuard) (TH.TupleT 0)++applyUnit :: TH.Exp -> TH.Exp+applyUnit e = TH.AppE e (TH.TupE [])++-- | Mark a function as having a primitive. Clash will yield an error if it+-- needs to translate this function, but no blackbox was loaded. Usage:+--+-- @+-- $(hasBlackBox 'f)+-- @+--+-- If you don't want to use TemplateHaskell, add these annotations:+--+-- @+-- {-# NOINLINE f #-}+-- {-# ANN f (HasBlackBox ()) #-}+-- @+--+hasBlackBox :: TH.Name -> TH.Q [TH.Dec]+hasBlackBox = guard (applyUnit (TH.ConE 'HasBlackBox))++-- | Mark a function as non translatable. Clash will yield an error if+-- it needs to translate this function. Usage:+--+-- @+-- $(dontTranslate 'f)+-- @+--+-- If you don't want to use TemplateHaskell, add these annotations:+--+-- @+-- {-# NOINLINE f #-}+-- {-# ANN f DontTranslate #-}+-- @+--+dontTranslate :: TH.Name -> TH.Q [TH.Dec]+dontTranslate = guard (TH.ConE 'DontTranslate)++-- | Mark a function as non synthesizable. Clash will emit the given warning+-- if instantiated outside of a testbench context. Usage:+--+-- @+-- $(warnNonSynthesizable 'f "Tread carefully, user!")+-- @+--+-- If you don't want to use TemplateHaskell, add these annotations:+--+-- @+-- {-# NOINLINE f #-}+-- {-# ANN f (WarnNonSynthesizable "Tread carefully, user!" ()) #-}+-- @+--+warnNotSynthesizable :: TH.Name -> String -> TH.Q [TH.Dec]+warnNotSynthesizable nm warning =+  guard+    (applyUnit+      (TH.AppE+        (TH.ConE 'WarnNonSynthesizable)+        (TH.LitE (TH.StringL warning))))+    nm++-- | Emit warning when translating this value.+--+-- @+-- $(warnAlways 'f "Tread carefully, user!")+-- @+--+-- If you don't want to use TemplateHaskell, add these annotations:+--+-- @+-- {-# NOINLINE f #-}+-- {-# ANN f (WarnAlways "Tread carefully, user!" ()) #-}+-- @+--+warnAlways :: TH.Name -> String -> TH.Q [TH.Dec]+warnAlways nm warning =+  guard+    (applyUnit+      (TH.AppE+        (TH.ConE 'WarnAlways)+        (TH.LitE (TH.StringL warning))))+    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 [] ()++-- | 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 = 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 = HasBlackBox [WarnAlways s] ()++-- | A compilation target HDL.+data HDL+  = SystemVerilog+  | Verilog+  | VHDL+  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+-- provides the HDL template inline. They are intended for the distribution of+-- new packages with primitive HDL templates.+--+-- === Example of 'Primitive'+--+-- You have some existing IP written in one of HDLs supported by Clash, and+-- you want to distribute some bindings so that the IP can be easily instantiated+-- from Clash.+--+-- You create a package which has a @myfancyip.cabal@ file with the following stanza:+--+-- > data-files: path/to/MyFancyIP.primitives+-- > cpp-options: -DCABAL+--+-- and a @MyFancyIP.hs@ module with the simulation definition and primitive.+--+-- @+-- module MyFancyIP where+--+-- import Clash.Prelude+--+-- myFancyIP :: ...+-- myFancyIP = ...+-- {\-\# NOINLINE myFancyIP \#-\}+-- @+--+-- The @NOINLINE@ pragma is needed so that GHC will never inline the definition.+--+-- Now you need to add the following imports and @ANN@ pragma:+--+-- @+-- \#ifdef CABAL+-- import           Clash.Annotations.Primitive+-- import           System.FilePath+-- import qualified Paths_myfancyip+-- import           System.IO.Unsafe+--+-- {\-\# 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 'InlineYamlPrimitive'+--+-- The following example shows off an inline HDL primitive template. It uses the+-- [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)+--+-- {\-\# 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 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)++-- | 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.+--+-- 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 [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.+  | 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'.+extractPrim+  :: PrimitiveGuard a+  -> Maybe a+extractPrim =+  \case+    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
@@ -0,0 +1,246 @@+{-|+  Copyright   :  (C) 2018,      Google Inc.,+                     2021-2025, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  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 CPP #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++module Clash.Annotations.SynthesisAttributes+  ( Attr(..)+  , Annotate+  , annotate+  , annotateReg+  , markDebug+  ) where++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 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";+--+-- 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+-- are used. An example of the same annotation:+--+-- @+-- import Clash.Annotations.SynthesisAttributes (Attr (..), Annotate )+--+-- myFunc+--     :: (Signal System Bool \`Annotate\` 'StringAttr "chip_pin" \"C4\")+--     -> (Signal System Int4 \`Annotate\` 'StringAttr "chip_pin" "D1, D2, D3, D4")+--     -> ...+-- myFunc sel data = ...+-- {\-\# NOINLINE myFunc \#-\}+-- @+--+-- To ensure this function will be rendered as its own module, do not forget a+-- NOINLINE pragma.+--+-- Multiple attributes for the /same/ argument can be specified by using a list.+-- For example:+--+-- @+-- Signal System Bool \`Annotate\`+--   [ 'StringAttr "chip_pin" \"C4\"+--   , 'BoolAttr "direct_enable" 'True+--   , 'IntegerAttr "max_depth" 512+--   , 'Attr "keep"+--   ]+-- @+--+-- For Verilog see:+--     <https://www.intel.com/content/www/us/en/programmable/quartushelp/current/index.htm#hdl/vlog/vlog_file_dir.htm>+--+-- For VHDL, see:+--     <https://www.intel.com/content/www/us/en/programmable/quartushelp/current/index.htm#hdl/vhdl/vhdl_file_dir.htm>+--+-- = 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>).+--+-- 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 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 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 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
@@ -0,0 +1,368 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente,+                  2017     , Google Inc.,+                  2021-2023, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+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.++=== 'Synthesize' annotation++The 'Synthesize' annotation allows 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 f (Synthesize {t_name = ..., ...  }) \#-\}+f x = ...+@++For example, given the following specification:++@+module Blinker where++import Clash.Prelude+import Clash.Intel.ClockGen++-- 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 DomInput+  -> Reset DomInput+  -> Enable Dom50+  -> Signal Dom50 Bit+  -> Signal Dom50 (BitVector 8)+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)+    -- 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+@++The Clash compiler would normally generate the following+@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_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:++@+{\-\# ANN topEntity+  ('Synthesize'+    { t_name   = "blinker"+    , t_inputs = [ PortName \"CLOCK_50\"+                 , PortName \"KEY0\"+                 , 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 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@, @KEY2@, @LED@, etc.++See the documentation of 'Synthesize' for the meaning of all its fields.++=== 'TestBench' annotation++Tell what binder is the test bench for a 'Synthesize'-annotated binder.++@+entityBeingTested :: ...+entityBeingTested = ...+{\-\# NOINLINE entityBeingTested \#-\}+{\-\# ANN entityBeingTested (defSyn "entityBeingTested") \#-\}+++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 CPP #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++{-# LANGUAGE Safe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Annotations.TopEntity+  ( -- * Data types+    TopEntity (..)+  , PortName (..)+    -- * Convenience functions+  , defSyn+  )+where++import           GHC.Generics+import qualified Language.Haskell.TH        as TH+import           Language.Haskell.TH.Syntax (Lift(..))+import           Language.Haskell.TH.Compat+import           Data.Data++-- | TopEntity annotation+data TopEntity+  -- | Instruct the Clash compiler to use this top-level function as a separately+  -- synthesizable component.+  = Synthesize+  { t_name    :: String+  -- ^ The name the top-level component should have, put in a correspondingly+  -- named file.+  , t_inputs  :: [PortName]+  -- ^ List of names that are assigned in-order to the inputs of the component.+  , t_output  :: PortName+  -- ^ Name assigned in-order to the outputs of the component. As a Haskell+  -- function can only truly return a single value -- with multiple values+  -- \"wrapped\" by a tuple -- this field is not a list, but a single+  -- @'PortName'@. Use @'PortProduct'@ to give names to the individual components+  -- of the output tuple.+  }+  -- | Tell what binder is the 'TestBench' for a 'Synthesize'-annotated binder.+  --+  -- @+  -- {\-\# NOINLINE myTestBench \#-\}+  -- {\-\# ANN myTestBench (TestBench \'entityBeingTested) \#-\}+  -- @+  | TestBench TH.Name+  deriving (Eq,Data,Show,Generic)++instance Lift TopEntity where+  lift (Synthesize name inputs output) =+    TH.appsE+      [ TH.conE 'Synthesize+      , lift name+      , lift inputs+      , lift output+      ]+  lift (TestBench _) = error "Cannot lift a TestBench"+  liftTyped = liftTypedFromUntyped++-- | Give port names for arguments/results.+--+-- Give a data type and function:+--+-- @+-- data T = MkT Int Bool+--+-- {\-\# ANN f (defSyn "f") \#-\}+-- f :: Int -> T -> (T,Bool)+-- f a b = ...+-- @+--+-- Clash would normally generate the following VHDL entity:+--+-- > 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 f+--    (Synthesize+--       { t_name   = "f"+--       , t_inputs = [ PortName \"a\"+--                    , PortName \"b\" ]+--       , t_output = PortName \"res\" }) \#-\}+-- f :: Int -> T -> (T,Bool)+-- f a b = ...+-- @+--+-- we get:+--+-- > 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 f+--    (Synthesize+--       { t_name   = "f"+--       , t_inputs = [ PortName \"a\"+--                    , PortProduct \"\" [ PortName \"b\", PortName \"c\" ] ]+--       , t_output = PortProduct \"res\" [PortName \"q\"] }) \#-\}+-- f :: Int -> T -> (T,Bool)+-- f a b = ...+-- @+--+-- So that we get:+--+-- > 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.+data PortName+  = 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.+  | PortProduct String [PortName]+  -- ^ You want to assign ports to fields of a product argument\/type+  --+  -- The first argument of 'PortProduct' is the name of:+  --+  -- 1. The signal/wire to which the individual ports are aggregated.+  --+  -- 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 (Eq,Data,Show,Generic,Lift)++-- | Default 'Synthesize' annotation which has no specified names for the input+-- and output ports.+--+-- >>> defSyn "foo"+-- Synthesize {t_name = "foo", t_inputs = [], t_output = PortName ""}+defSyn :: String -> TopEntity+defSyn name = Synthesize+  { t_name   = name+  , t_inputs = []+  , t_output = PortName ""+  }
+ src/Clash/CPP.hs view
@@ -0,0 +1,62 @@+{-|+Copyright  :  (C) 2019     , Myrtle Software Ltd,+                  2023     , QBayLogic B.V.,+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}++{-# 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
@@ -0,0 +1,41 @@++{-|+Copyright  :  (C) 2013-2016, University of Twente+                  2016-2017, Myrtle Software Ltd+                       2021, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE Safe #-}++module Clash.Class.BitPack+  ( BitPack (..)+  , isLike+  , bitCoerce+  , bitCoerceMap+  , boolToBV+  , boolToBit+  , bitToBool+  , packXWith++  -- * Bit Indexing+  , (!)+  , slice+  , split+  , replaceBit+  , setSlice+  , msb+  , lsb++  -- * Bit Reduction+  , reduceAnd+  , reduceOr+  , reduceXor+  )+where++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
@@ -0,0 +1,619 @@+{-|+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 :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# 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"++module Clash.Class.BitPack.Internal where++import Prelude                        hiding (map)++import Data.Binary.IEEE754            (doubleToWord, floatToWord, wordToDouble,+                                       wordToFloat)++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 (..))++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)++{- $setup+>>> :m -Prelude+>>> :set -XDataKinds+>>> import Clash.Prelude+>>> import Data.Proxy+-}++-- | 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
@@ -0,0 +1,99 @@+{-|+Copyright  :  (C) 2019, Myrtle Software Ltd+                  2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++module Clash.Class.Exp+  ( Exp+  , ExpResult+  , (^)++  -- | * Internal+  , expIndex#+  , expSigned#+  , expUnsigned#+  ) where++import qualified Prelude                       as P+import           Prelude                       hiding ((^))++import           Clash.Annotations.Primitive   (hasBlackBox)+import           Clash.Promoted.Nat            (SNat(..), snatToInteger)+import           Clash.Sized.Internal.Index    (Index)+import           Clash.Sized.Internal.Signed   (Signed)+import           Clash.Sized.Internal.Unsigned (Unsigned)++import           GHC.TypeLits+  (KnownNat, Nat, type (^), type (*))+import           GHC.TypeLits.Extra            (Max)++-- | Type class implementing exponentiation with explicitly resizing results.+class Exp a where+  type ExpResult a (n :: Nat)++  -- | Exponentiation with known exponent.+  (^)+    :: a+    -- ^ Base+    -> SNat n+    -- ^ Exponent+    -> 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 (Max 2 (m ^ n))++  (^) = expIndex#+  {-# INLINE (^) #-}++instance KnownNat m => Exp (Signed m) where+  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 (Max 1 (m * n))++  (^) = expUnsigned#+  {-# INLINE (^) #-}++expIndex#+  :: KnownNat m+  => Index m+  -> SNat n+  -> Index (Max 2 (m ^ n))+expIndex# b e@SNat =+  fromInteger (toInteger b P.^ snatToInteger e)+{-# OPAQUE expIndex# #-}+{-# ANN expIndex# hasBlackBox #-}++expSigned#+  :: KnownNat m+  => Signed m+  -> SNat n+  -> Signed (Max 2 (m * n))+expSigned# b e@SNat =+  fromInteger (toInteger b P.^ snatToInteger e)+{-# OPAQUE expSigned# #-}+{-# ANN expSigned# hasBlackBox #-}++expUnsigned#+  :: KnownNat m+  => Unsigned m+  -> SNat n+  -> Unsigned (Max 1 (m * n))+expUnsigned# b e@SNat =+  fromInteger (toInteger b P.^ snatToInteger e)+{-# OPAQUE expUnsigned# #-}+{-# ANN expUnsigned# hasBlackBox #-}
+ src/Clash/Class/HasDomain.hs view
@@ -0,0 +1,15 @@+{-# 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+import Clash.Class.HasDomain.HasSingleDomain+import Clash.Class.HasDomain.HasSpecificDomain
+ src/Clash/Class/HasDomain/CodeGen.hs view
@@ -0,0 +1,67 @@+{-|+Copyright  :  (C) 2019, Myrtle Software Ltd+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++module Clash.Class.HasDomain.CodeGen+  ( mkTryDomainTuples+  , mkHasDomainTuples+  ) where++import           Language.Haskell.TH.Syntax+import           Clash.CPP                    (maxTupleSize)+import           Language.Haskell.TH.Compat   (mkTySynInstD)+++mkTup :: [Type] -> Type+mkTup names@(length -> n) =+  foldl AppT (TupleT n) names++-- | Creates an instance of the form:+--+--  type instance TryDomain t (a, b, c, d, e) = Merge t a (b, c, d, e)+--+-- With /n/ number of variables on the LHS.+mkTryDomainTupleInstance :: Name -> Name -> Int -> Dec+mkTryDomainTupleInstance tryDomainName mergeName n =+  mkTySynInstD tryDomainName [t, tupPat] tupBody+ where+  bcde = map (VarT . mkName . ("a"++) . show) [1..n-1]+  a    = VarT (mkName "a0")+  t    = VarT (mkName "t")++  -- Merge t a (b, c, d, e)+  tupBody = ConT mergeName `AppT` t `AppT` a `AppT` (mkTup bcde)++  -- (a, b, c, d, e)+  tupPat = mkTup (a : bcde)++mkTryDomainTuples :: Name -> Name -> Q [Dec]+mkTryDomainTuples tryDomainName mergeName =+  pure (map (mkTryDomainTupleInstance tryDomainName mergeName) [3..maxTupleSize])+++-- | Creates an instance of the form:+--+--  type instance HasDomain' dom (a, b, c, d, e) =+--    Merge' (HasDomain' dom a) (HasDomain' dom (b, c, d, e))+--+-- With /n/ number of variables on the LHS.+mkHasDomainTupleInstance :: Name -> Name -> Int -> Dec+mkHasDomainTupleInstance hasDomainName mergeName n =+  mkTySynInstD hasDomainName [dom, tupPat] merge+ where+  bcde = map (VarT . mkName . ("a"++) . show) [1..n-1]+  a    = VarT (mkName "a0")+  dom  = VarT (mkName "dom")++  -- Merge dom a (b, c, d, e)+  merge = ConT mergeName `AppT` dom `AppT` a `AppT` mkTup bcde++  -- (a, b, c, d, e)+  tupPat = mkTup (a : bcde)++mkHasDomainTuples :: Name -> Name -> Q [Dec]+mkHasDomainTuples hasDomainName mergeName =+  pure (map (mkHasDomainTupleInstance hasDomainName mergeName) [3..maxTupleSize])
+ src/Clash/Class/HasDomain/Common.hs view
@@ -0,0 +1,46 @@+{-|+Copyright  :  (C) 2019, Myrtle Software Ltd+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE TypeFamilies #-}++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)+import           Type.Errors+  (ErrorMessage(Text, ShowType, (:<>:), (:$$:)))++type family ToEM (k :: t) :: ErrorMessage where+  ToEM (k :: Symbol)       = 'Text k+  ToEM (k :: ErrorMessage) = k+  ToEM (k :: t)            = 'ShowType k++infixl 5 :<<>>:+type (:<<>>:) (k1 :: t1) (k2 :: t2) = ToEM k1 ':<>: ToEM k2++infixl 4 :$$$:+type (:$$$:) (k1 :: t1) (k2 :: t2) = ToEM k1 ':$$: ToEM k2+++{- | Combine multiple lines with line break. Type-level version of the @unlines@+function but for ErrorMessage. -}+type family Unlines (ln :: [k]) :: ErrorMessage where+  Unlines '[] = 'Text ""+  Unlines ((x :: Symbol) ': xs) = 'Text x ':$$: Unlines xs+  Unlines ((x :: ErrorMessage) ': xs) = x ':$$: Unlines xs++infixl 4 :++:+type family (:++:) (as :: [k]) (bs :: [k]) :: [k] where+  (:++:) a '[] = a+  (:++:) '[] b = b+  (:++:) (a ': as) bs = a ': (as :++: bs)
+ src/Clash/Class/HasDomain/HasSingleDomain.hs view
@@ -0,0 +1,190 @@+{-|+Copyright  :  (C) 2019, Myrtle Software Ltd+                  2022-2025, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Internals for "Clash.Class.HasDomain"+-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-missing-methods -Wno-deprecations #-}+{-# OPTIONS_HADDOCK not-home #-}++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)++type MissingInstance =+        "This might happen if an instance for TryDomain is missing. Try to determine"+  :$$$: "which of the types miss an instance, and add them. Example implementations:"+  :$$$: ""+  :$$$: " * type instance TryDomain t (MyVector n a)    = TryDomain t a"+  :$$$: " * type instance TryDomain t (MyCircuit dom a) = Found dom"+  :$$$: " * type instance TryDomain t Terminal          = NotFound"+  :$$$: ""+  :$$$: "Alternatively, use one of the withSpecific* functions."++type Outro =+         ""+   :$$$: "------"+   :$$$: ""+   :$$$: "You tried to apply an explicitly routed clock, reset, or enable line"+   :$$$: "to a construct with, possibly, an implicitly routed one. Clash failed to"+   :$$$: "unambigously determine a single domain and could therefore not route it."+   :$$$: "You possibly used one of these sets of functions:"+   :$$$: ""+   :$$$: " * with{ClockResetEnable,Clock,Reset,Enable}"+   :$$$: " * expose{ClockResetEnable,Clock,Reset,Enable}"+   :$$$: ""+   :$$$: "These functions are suitable for components defined over a single domain"+   :$$$: "only. If you want to use multiple domains, use the following instead:"+   :$$$: ""+   :$$$: " * withSpecific{ClockResetEnable,Clock,Reset,Enable}"+   :$$$: " * exposeSpecific{ClockResetEnable,Clock,Reset,Enable}"+   :$$$: ""++type NotFoundError (t :: Type) =+       "Could not find a non-ambiguous domain in the following type:"+  :$$$: ""+  :$$$: "  " :<<>>: t+  :$$$: ""+  :$$$: MissingInstance+  :$$$: Outro++type AmbiguousError (t :: Type) (dom1 :: Domain) (dom2 :: Domain) =+        "Could not determine that the domain '" :<<>>: dom1 :<<>>: "'"+  :$$$: "was equal to the domain '" :<<>>: dom2 :<<>>: "' in the type:"+  :$$$: ""+  :$$$: "  " :<<>>: t+  :$$$: ""+  :$$$: "This is usually resolved by adding explicit type signatures."+  :$$$: Outro++type StuckErrorMsg (orig :: Type) (n :: Type) =+        "Could not determine whether the following type contained a non-ambiguous domain:"+  :$$$: ""+  :$$$: "  " :<<>>: n+  :$$$: ""+  :$$$: "In the full type:"+  :$$$: ""+  :$$$: "  " :<<>>: orig+  :$$$: ""+  :$$$: "Does it contain one?"+  :$$$: ""+  :$$$: "------"+  :$$$: ""+  :$$$: MissingInstance+  :$$$: Outro++-- | Type that forces /dom/ to be the same in all subtypes of /r/ that might+-- contain a domain. If given a polymorphic domain not tied to /r/, GHC will+-- be allowed to infer that that domain is equal to the one in /r/ on the+-- condition that /r/ contains just a single domain.+type WithSingleDomain dom r =+  (HasSingleDomain r, dom ~ GetDomain r)++data TryDomainResult+  = NotFound+  | Ambiguous Domain Domain+  | Found Domain++-- | Type family to resolve type conflicts (if any)+type family Merge' (n :: TryDomainResult) (m :: TryDomainResult) :: TryDomainResult where+  Merge' 'NotFound              b                      = b+  Merge' ('Ambiguous dom1 dom2) b                      = 'Ambiguous dom1 dom2+  Merge' a                      'NotFound              = a+  Merge' a                      ('Ambiguous dom1 dom2) = 'Ambiguous dom1 dom2+  Merge' ('Found dom)           ('Found dom)           = 'Found dom+  Merge' ('Found dom1)          ('Found dom2)          = 'Ambiguous dom1 dom2++-- | Same as Merge', but will insert a type error if Merge' got stuck.+type family Merge (orig :: Type) (n :: Type) (m :: Type) :: TryDomainResult where+  Merge orig n m =+    IfStuck+      (TryDomain orig n)+      (DelayError (StuckErrorMsg orig n))+      (Pure+        (IfStuck+          (TryDomain orig m)+          (DelayError (StuckErrorMsg orig m))+          (Pure (Merge' (TryDomain orig n) (TryDomain orig m)))+         ))++type family ErrOnConflict (t :: Type) (n :: TryDomainResult) :: Domain where+  ErrOnConflict t 'NotFound              = TypeError (NotFoundError t)+  ErrOnConflict t ('Ambiguous dom1 dom2) = TypeError (AmbiguousError t dom1 dom2)+  ErrOnConflict t ('Found dom)           = dom++type family TryDomain (orig :: Type) (n :: Type) :: TryDomainResult++type instance TryDomain t (DSignal dom delay a) = 'Found dom+type instance TryDomain t (Signal dom a)        = 'Found dom+type instance TryDomain t (Clock dom)           = 'Found dom+type instance TryDomain t (Reset dom)           = 'Found dom+type instance TryDomain t (Enable dom)          = 'Found dom+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++-- | Type family that searches a type and checks whether all subtypes that can+-- contain a domain (for example, Signal) contain the /same/ domain. Its+-- associated type, GetDomain, will yield a type error if that doesn't hold OR+-- if it can't check it.+class HasSingleDomain (r :: Type) where+  type GetDomain r :: Domain+  type GetDomain r =+    -- Handle types not in TryDomain type family+    IfStuck+      (TryDomain r r)+      (DelayError (StuckErrorMsg r r))+      (Pure (ErrOnConflict r (TryDomain r r)))++instance HasSingleDomain a++mkTryDomainTuples ''TryDomain ''Merge
+ src/Clash/Class/HasDomain/HasSpecificDomain.hs view
@@ -0,0 +1,144 @@+{-|+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 FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-missing-methods -Wno-deprecations #-}+{-# OPTIONS_HADDOCK not-home #-}++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++import           Clash.Sized.Vector             (Vec)+import           Clash.Signal.Internal+  (Signal, Domain, Clock, Reset, Enable)+import           Clash.Signal.Delayed.Internal  (DSignal)++import           Data.Proxy                     (Proxy)+import           Data.Kind                      (Type)+import           Type.Errors+  (IfStuck, DelayError, Pure, ErrorMessage(ShowType))++type Outro =+         ""+   :$$$: "------"+   :$$$: ""+   :$$$: "You tried to apply an explicitly routed clock, reset, or enable line"+   :$$$: "to a construct with, possibly, an implicitly routed one. Clash failed to"+   :$$$: "unambigously link the given domain (by passing in a 'Clock', 'Reset', or"+   :$$$: "'Enable') to the component passed in."+   :$$$: ""++type NotFoundError (dom :: Domain) (t :: Type) =+       "Could not find domain '" :<<>>: 'ShowType dom :<<>>: "' in the following type:"+  :$$$: ""+  :$$$: "  " :<<>>: t+  :$$$: ""+  :$$$: "If that type contains that domain anyway, you might need to provide an"+  :$$$: "additional type instance of HasDomain. Example implementations:"+  :$$$: ""+  :$$$: " * type instance HasDomain dom  (MyVector n a)     = HasDomain dom a"+  :$$$: " * type instance HasDomain dom1 (MyCircuit dom2 a) = DomEq dom1 dom2"+  :$$$: " * type instance HasDomain dom1 (MyTuple a b)      = Merge dom a b"+  :$$$: ""+  :$$$: Outro++-- | Type that forces /dom/ to be present in /r/ at least once. Will resolve to+-- a type error if it doesn't. It will always fail if given /dom/ is completely+-- polymorphic and can't be tied to /r/ in any way.+type WithSpecificDomain dom r =+  (HasSpecificDomain dom r, dom ~ GetDomain dom r)++-- TODO: Extend HasDomainWrapperResult such that it keeps track of what it found /+-- TODO: which types are stuck, so that we can report better errors.+data HasDomainWrapperResult+  = NotFound+  -- ^ No domain found+  | Found+  -- ^ Found the specific domain caller was looking for++-- | Merge two 'HasDomainWrapperResult's according to the semantics of 'HasDomain.+type family MergeWorker (n :: HasDomainWrapperResult) (m :: HasDomainWrapperResult) :: HasDomainWrapperResult where+  MergeWorker 'Found b = 'Found+  MergeWorker a 'Found = 'Found+  MergeWorker 'NotFound 'NotFound = 'NotFound++type Merge (dom :: Domain) (n :: Type) (m :: Type) =+  MergeWorker (HasDomainWrapper dom n) (HasDomainWrapper dom m)++type family DomEqWorker (n :: Domain) (m :: Domain) :: HasDomainWrapperResult where+  DomEqWorker n n = 'Found+  DomEqWorker n m = 'NotFound++-- | 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.+type DomEq (n :: Domain) (m :: Domain) =+  IfStuck (DomEqWorker n m) ('NotFound) (Pure (DomEqWorker n m))++-- | Type family that searches a type and checks whether a specific domain is+-- present. Will result in either "domain not found, and no others either",+-- "domain not found, but found another", or "found domain".+type family HasDomain (dom :: Domain) (n :: Type) :: HasDomainWrapperResult++type instance HasDomain dom1 (Proxy dom2)           = DomEq dom1 dom2+type instance HasDomain dom1 (Signal dom2 a)        = DomEq dom1 dom2+type instance HasDomain dom1 (DSignal dom2 delay a) = DomEq dom1 dom2+type instance HasDomain dom1 (Clock dom2)           = DomEq dom1 dom2+type instance HasDomain dom1 (Reset dom2)           = DomEq dom1 dom2+type instance HasDomain dom1 (Enable dom2)          = DomEq dom1 dom2+type instance HasDomain dom (Vec n a)               = HasDomain dom a+type instance HasDomain dom (a, b)                  = Merge dom a b+type instance HasDomain dom (a -> b)                = Merge dom a b++type family ErrOnNotFound (dom :: Domain) (n :: HasDomainWrapperResult) (t :: Type) :: Domain where+  ErrOnNotFound dom  'NotFound t = DelayError (NotFoundError dom t)+  ErrOnNotFound dom  'Found    t = dom++-- | Wrapper that checks for stuckness and returns @'NotFound@ if so+type family HasDomainWrapper (dom :: Domain) (n :: Type) :: HasDomainWrapperResult where+  HasDomainWrapper dom n =+    IfStuck+      (HasDomain dom n)+      ('NotFound)+      (Pure (HasDomain dom n))++-- | Helper function for HasSpecificDomain class (I don't really understand+-- why this one is necessary. HasDomainWrapper _should_ check for stuckness+-- and does so according to tests..+type family ResolveOrErr (dom :: Domain) (t :: Type) :: Domain where+  ResolveOrErr dom t =+    IfStuck+      (HasDomainWrapper dom t)+      (ErrOnNotFound dom 'NotFound t)+      (Pure (ErrOnNotFound dom (HasDomainWrapper dom t) t))++-- | 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+-- '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.+class HasSpecificDomain (dom :: Domain) (r :: Type) where+  type GetDomain dom r :: Domain+  type GetDomain dom r = ResolveOrErr dom r++instance HasSpecificDomain dom a++mkHasDomainTuples ''HasDomain ''Merge
+ src/Clash/Class/Num.hs view
@@ -0,0 +1,104 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente+                  2024,      Google LLC+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++{-# LANGUAGE Safe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Class.Num+  ( -- * Arithmetic functions for arguments and results of different precision+    ExtendingNum (..)+    -- * Saturating arithmetic functions+  , SaturationMode (..)+  , SaturatingNum (..)+  , boundedAdd+  , boundedSub+  , boundedMul+  )+where++-- * Arithmetic functions for arguments and results of different precision++-- | Adding, subtracting, and multiplying values of two different (sub-)types.+class ExtendingNum a b where+  -- | Type of the result of the addition or subtraction+  type AResult a b+  -- | Add values of different (sub-)types, return a value of a (sub-)type+  -- that is potentially different from either argument.+  add  :: a -> b -> AResult a b+  -- | Subtract values of different (sub-)types, return a value of a (sub-)type+  -- that is potentially different from either argument.+  sub :: a -> b -> AResult a b+  -- | Type of the result of the multiplication+  type MResult a b+  -- | Multiply values of different (sub-)types, return a value of a (sub-)type+  -- 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+-- 'SaturatingNum'+data SaturationMode+  = SatWrap  -- ^ Wrap around on overflow and underflow+  | SatBound -- ^ Become 'maxBound' on overflow, and 'minBound' on underflow+  | SatZero  -- ^ Become @0@ on overflow and underflow+  | SatSymmetric -- ^ Become 'maxBound' on overflow, and (@'minBound' + 1@) on+                 -- underflow for signed numbers, and 'minBound' for unsigned+                 -- numbers.+  | 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'.+class (Bounded a, Num a) => SaturatingNum a where+  -- | Addition with parameterizable over- and underflow behavior+  satAdd :: SaturationMode -> a -> a -> a+  -- | Subtraction with parameterizable over- and underflow behavior+  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 :: 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 #-}++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
@@ -0,0 +1,151 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente+                  2020,      Myrtle Software Ltd+                  2024,      QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE MonoLocalBinds #-}++{-# LANGUAGE Safe #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_HADDOCK show-extensions #-}++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 -> Type) where+  -- | A sign-preserving resize operation+  --+  -- * For signed datatypes: Increasing the size of the number replicates the+  -- sign bit to the left. Truncating a number to length L keeps the sign bit+  -- and the rightmost L-1 bits.+  --+  -- * For unsigned datatypes: Increasing the size of the number extends with+  -- zeros to the left. Truncating a number of length N to a length L just+  -- removes the left (most significant) N-L bits.+  resize :: (KnownNat a, KnownNat b) => f a -> f b+  -- | Perform a 'zeroExtend' for unsigned datatypes, and 'signExtend' for a+  -- signed datatypes+  extend :: (KnownNat a, KnownNat b) => f a -> f (b + a)+  extend = resize+  -- | Add extra zero bits in front of the MSB+  zeroExtend :: (KnownNat a, KnownNat b) => f a -> f (b + a)+  -- | Add extra sign bits in front of the MSB+  signExtend :: (KnownNat a, KnownNat b) => f a -> f (b + a)+  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
@@ -0,0 +1,43 @@+{-|+Copyright  :  (C) 2018, Google Inc+                  2019, Myrtle Software Ltd+                  2023,      QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Generic clock related utilities.+-}++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC "-Wno-orphans" #-}++module Clash.Clocks+  ( Clocks(..)+  , ClocksSync(..)+  , ClocksSyncCxt+  , NumOutClocksSync+  ) where++import Clash.Clocks.Internal+  (Clocks(..), ClocksSync(..), deriveClocksInstances, deriveClocksSyncInstances)+import Clash.Signal.Internal (Domain, KnownDomain)++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/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
@@ -0,0 +1,412 @@+{-|+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 NoImplicitPrelude #-}++{-# OPTIONS_GHC -Wno-unused-imports #-}++module Clash.Examples (+  -- * Decoders and Encoders+  -- $decoders_and_encoders++  -- * Counters+  -- $counters++  -- * Parity and CRC+  -- $parity_and_crc++  -- * UART model+  -- $uart+  )+where++import Clash.Prelude+import Control.Lens+import Control.Monad+import Control.Monad.Trans.State++{- $setup+>>> :set -XDataKinds+>>> import Clash.Prelude+>>> import Test.QuickCheck ((===))+>>> import Clash.Examples.Internal+-}++{- $decoders_and_encoders+= Decoder++Using a @case@ statement:++@+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+@++Using the `shiftL` function:++@+decoderShift :: Bool -> BitVector 4 -> BitVector 16+decoderShift enable binaryIn =+  if enable+     then 1 ``shiftL`` ('fromIntegral' binaryIn)+     else 0+@++Examples:++>>> decoderCase True 3+0b0000_0000_0000_1000+>>> decoderShift True 7+0b0000_0000_1000_0000++The following property holds:++prop> \enable binaryIn -> decoderShift enable binaryIn === decoderCase enable binaryIn++= Encoder++Using a @case@ statement:++@+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+@++The following property holds:++prop> \en decIn -> en ==> (encoderCase en (decoderCase en decIn) === decIn)+-}++{- $counters+= 8-bit Simple Up Counter++Using `register`:++@+upCounter+  :: HiddenClockResetEnable dom+  => Signal dom Bool+  -> Signal dom (Unsigned 8)+upCounter enable = s+  where+    s = `register` 0 (`mux` enable (s + 1) s)+@++= 8-bit Up Counter With Load++Using `mealy`:++@+upCounterLd+  :: HiddenClockResetEnable dom+  => Signal dom (Bool,Bool,Unsigned 8)+  -> Signal dom (Unsigned 8)+upCounterLd = `mealy` upCounterLdT 0++upCounterLdT s (ld,en,dIn) = (s',s)+  where+    s' | ld        = dIn+       | en        = s + 1+       | otherwise = s+@++= 8-bit Up-Down counter++Using `register` and `mux`:++@+upDownCounter+  :: HiddenClockResetEnable dom+  => Signal dom Bool+  -> Signal dom (Unsigned 8)+upDownCounter upDown = s+  where+    s = `register` 0 (`mux` upDown (s + 1) (s - 1))+@++The following property holds:++prop> \en -> en ==> testFor 1000 (upCounter (pure en) .==. upDownCounter (pure en) :: Signal "System" Bool)++= LFSR++External/Fibonacci LFSR, for @n=16@ and using the primitive polynominal @1 + x^11 + x^13 + x^14 + x^16@++@+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)+@++We can also build a internal/Galois LFSR which has better timing characteristics.+We first define a Galois LFSR parameterizable in its filter taps:++@+lfsrGP taps regs = 'zipWith' xorM taps (fb '+>>' regs)+  where+    fb  = 'last' regs+    xorM i x | i         = x ``xor`` fb+             | otherwise = x+@++Then we can instantiate a 16-bit LFSR as follows:++@+lfsrG :: HiddenClockResetEnable dom  => BitVector 16 -> Signal dom Bit+lfsrG seed = 'last' ('unbundle' r)+  where r = 'register' ('unpack' seed) (lfsrGP ('unpack' 0b0011010000000000) '<$>' r)+@++The following property holds:++prop> testFor 100 (lfsrF 0xACE1 .==. lfsrG 0x4645 :: Signal "System" Bool)++= Gray counter++Using the previously defined @upCounter@:++@+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)+@++= One-hot counter++Basically a barrel-shifter:++@+oneHotCounter+  :: HiddenClockResetEnable dom+  => Signal dom Bool+  -> Signal dom (BitVector 8)+oneHotCounter enable = s+  where+    s = 'register' 1 ('mux' enable ('rotateL' '<$>' s '<*>' 1) s)+@+-}++{- $parity_and_crc+= Parity++Just 'reduceXor':++@+parity :: Unsigned 8 -> Bit+parity data_in = `reduceXor` data_in+@++= Serial CRC++* Width = 16 bits+* Truncated polynomial = 0x1021+* Initial value = 0xFFFF+* Input data is NOT reflected+* Output CRC is NOT reflected+* No XOR is performed on the output CRC++@+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)+@+-}++{- $uart+@+{\-\# LANGUAGE RecordWildCards \#-\}++module UART (uart) where++import Clash.Prelude+import Control.Lens+import Control.Monad+import Control.Monad.Trans.State++-- UART RX Logic+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++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+    -- Start 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 TX Logic+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++-- Combine RX and TX logic+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/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
@@ -0,0 +1,1535 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2016-2017, Myrtle Software Ltd,+                  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
@@ -0,0 +1,437 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente,+                  2017     , Google Inc.,+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++= Initializing a block RAM with a data file #usingramfiles#++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'++Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@.+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':++@+writeFile "memory.bin" (memFile Nothing [7 :: Unsigned 9 .. 13])+@++We can instantiate a block RAM using the contents of the file above like so:++@+f :: KnownDomain dom+  => Clock  dom+  -> Enable dom+  -> Signal dom (Unsigned 3)+  -> Signal dom (Unsigned 9)+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 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 enableGen (fromList [3..5])__+[10,11,12]+@++However, we can also interpret the same data as a tuple of a 6-bit unsigned+number, and a 3-bit signed number:++@+g :: KnownDomain dom+  => Clock  dom+  -> Enable dom+  -> Signal dom (Unsigned 3)+  -> Signal dom (Unsigned 6,Signed 3)+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 enableGen (fromList [3..5])__+[(1,2),(1,3)(1,-4)]+@++-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}++{-# LANGUAGE Unsafe #-}++{-# 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.File+  ( -- * 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            (isJust, listToMaybe)+import GHC.Arr               (STArray, unsafeReadSTArray, unsafeWriteSTArray)+import GHC.Stack             (HasCallStack, withFrozenCallStack)+import GHC.TypeLits          (KnownNat)+import Numeric               (readInt)+import System.IO++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      (maybeIsX, seqX, fromJustX, NFDataX(..), XException (..))++-- start benchmark only+-- import GHC.Arr (unsafeFreezeSTArray, unsafeThawSTArray)+-- end benchmark only++-- $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/, 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      |+-- +----------------+----------+----------+---------------++--+-- === 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 (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 '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+  -- ^ 'Enable' line+  -> FilePath+  -- ^ 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 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)+{-# INLINE blockRamFilePow2 #-}++-- | 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'+-- * __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      |+-- +----------------+----------+----------+---------------++--+-- === See also:+--+-- * See "Clash.Explicit.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 ('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 '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, NFDataX addr, HasCallStack)+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> SNat n+  -- ^ Size of the BRAM+  -> FilePath+  -- ^ 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 BRAM at address @r@ from the previous clock cycle+blockRamFile = \clk gen sz file rd wrM ->+  let en       = isJust <$> 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+   . (KnownDomain dom, KnownNat m, HasCallStack)+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> SNat n+  -- ^ Size of the BRAM+  -> FilePath+  -- ^ File describing the initial content of the BRAM+  -> 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+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+    ramStart+    (withFrozenCallStack (deepErrorX "blockRamFile: intial value undefined"))+    (fromEnable ena)+    rd+    (fromEnable ena .&&. wen)+    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++  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))++  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 :: 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 #-}++  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+    parseBV s = case parseBV' s of+                  Just i  -> fromInteger i+                  Nothing -> error ("Failed to parse: " ++ s)+    parseBV' = fmap fst . listToMaybe . readInt 2 (`elem` "01") digitToInt+{-# 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
@@ -0,0 +1,342 @@+{-|+Copyright  :  (C) 2017, Google Inc+                  2019, Myrtle Software Ltd+                  2025, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+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 or consume DDR signals.++DDR signals are not meant to be used internally in a design,+but only to communicate with the outside world.++In some cases hardware specific DDR IN registers can be inferred by synthesis+tools from these generic primitives. But to be sure your design will synthesize+to dedicated hardware resources use the functions from "Clash.Intel.DDR"+or "Clash.Xilinx.DDR".+-}++{-# 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, 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.+--+-- 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+  :: 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 domDDR a+  -- ^ DDR input signal+  -> 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+++-- For details about all the seq's en seqX's+-- see the [Note: register strictness annotations] in Clash.Signal.Internal+ddrIn#+  :: 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 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"+        , deepErrorX "ddrIn: initial value 1 undefined"+        , deepErrorX "ddrIn: initial value 2 undefined" )+        hRst+        ena+    SSynchronous ->+      goSync+        ( deepErrorX "ddrIn: initial value 0 undefined"+        , deepErrorX "ddrIn: initial value 1 undefined"+        , deepErrorX "ddrIn: initial value 2 undefined" )+        hRst+        ena+  where+    goSync+      :: (a, 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)+           :- (rt `seq` as `seq` if e then goSync (o0',o1',o2') rs es xs+                                      else goSync (o0 ,o1 ,o2)  rs es xs)++    goAsync+      :: (a, 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)++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.+--+-- 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+  :: 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 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#+  :: forall a dom domDDR+   . HasCallStack+  => NFDataX a+  => KnownDomain dom+  => KnownDomain domDDR+  => DomainPeriod dom ~ (2 * DomainPeriod domDDR)+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> 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+    -- first input.+    --+    -- That is why we drop the first value of the stream.+    let (_ :- out) = zipSig xs' ys' in out+  where+    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+{-# 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
@@ -0,0 +1,274 @@+{-|+  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>++  Whereas the output of a Moore machine depends on the /previous state/, the+  output of a Mealy machine depends on /current transition/.++  Mealy machines are strictly more expressive, but may impose stricter timing+  requirements.+-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++{-# LANGUAGE Safe #-}++module Clash.Explicit.Mealy+  ( -- * Mealy machines with explicit clock and reset ports+    mealy+  , mealyS+  , mealyB+  , mealySB+  )+where++import           Clash.Explicit.Signal+  (KnownDomain, Bundle (..), Clock, Reset, Signal, Enable, register)+import           Clash.XException      (NFDataX)++import           Control.Monad.State.Strict+  (State, runState)++{- $setup+>>> :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+:}++>>> 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+-- a mealy machine+--+-- @+-- import qualified Data.List as L+--+-- macT+--   :: Int        -- Current state+--   -> (Int,Int)  -- Input+--   -> (Int,Int)  -- (Updated state, output)+-- macT s (x,y) = (s',s)+--   where+--     s' = x * y + s+--+-- mac+--   :: 'KnownDomain' dom+--   => 'Clock' dom+--   -> 'Reset' dom+--   -> 'Enable' dom+--   -> 'Signal' dom (Int, Int)+--   -> 'Signal' dom Int+-- mac clk rst en = 'mealy' clk rst en macT 0+-- @+--+-- >>> simulate (mac systemClockGen systemResetGen enableGen) [(0,0),(1,1),(2,2),(3,3),(4,4)]+-- [0,0,1,5,14...+-- ...+--+-- Synchronous sequential functions can be composed just like their+-- combinational counterpart:+--+-- @+-- dualMac+--   :: 'KnownDomain' dom+--   => 'Clock' dom+--   -> 'Reset' dom+--   -> 'Enable' dom+--   -> ('Signal' dom Int, 'Signal' dom Int)+--   -> ('Signal' dom Int, 'Signal' dom Int)+--   -> 'Signal' dom Int+-- dualMac clk rst en (a,b) (x,y) = s1 + s2+--   where+--     s1 = 'mealy' clk rst en macT 0 ('bundle' (a,x))+--     s2 = 'mealy' clk rst en macT 0 ('bundle' (b,y))+-- @+mealy+  :: ( KnownDomain dom+     , NFDataX s )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Reset dom+  -> Enable dom+  -- ^ Global enable+  -> (s -> i -> (s,o))+  -- ^ Transfer function in mealy machine form: @state -> input -> (newstate,output)@+  -> s+  -- ^ Initial state+  -> (Signal dom i -> Signal dom o)+  -- ^ Synchronous sequential function with input and output matching that+  -- of the mealy machine+mealy clk rst en f iS =+  \i -> let (s',o) = unbundle $ f <$> s <*> i+            s      = register clk rst en iS s'+        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:+--+-- @+-- __f__ :: Int -> (Bool,Int) -> (Int,(Int,Bool))+-- @+--+-- When we want to make compositions of @f@ in @g@ using 'mealy', we have to+-- write:+--+-- @+-- g clk rst en a b c = (b1,b2,i2)+--   where+--     (i1,b1) = 'unbundle' (mealy clk rst en f 0 ('bundle' (a,b)))+--     (i2,b2) = 'unbundle' (mealy clk rst en f 3 ('bundle' (c,i1)))+-- @+--+-- Using 'mealyB' however we can write:+--+-- @+-- g clk rst en a b c = (b1,b2,i2)+--   where+--     (i1,b1) = 'mealyB' clk rst en f 0 (a,b)+--     (i2,b2) = 'mealyB' clk rst en f 3 (c,i1)+-- @+mealyB+  :: ( KnownDomain dom+     , NFDataX s+     , Bundle i+     , Bundle o )+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> (s -> i -> (s,o))+  -- ^ Transfer function in mealy machine form: @state -> input -> (newstate,output)@+  -> s+  -- ^ Initial state+  -> (Unbundled dom i -> Unbundled dom o)+ -- ^ Synchronous sequential function with input and output matching that+ -- 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
@@ -0,0 +1,178 @@+{-|+  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>++  Whereas the output of a Mealy machine depends on /current transition/, the+  output of a Moore machine depends on the /previous state/.++  Moore machines are strictly less expressive, but may impose laxer timing+  requirements.+-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++{-# LANGUAGE Safe #-}++module Clash.Explicit.Moore+  ( -- * Moore machines with explicit clock and reset ports+    moore+  , mooreB+  , medvedev+  , medvedevB+  )+where++import           Clash.Explicit.Signal+  (KnownDomain, Bundle (..), Clock, Reset, Signal, Enable, register)+import           Clash.XException                 (NFDataX)++{- $setup+>>> :set -XDataKinds -XTypeApplications+>>> import Clash.Explicit.Prelude+>>> let macT s (x,y) = x * y + s+>>> let mac clk rst en = moore clk rst en macT id 0+-}++-- | Create a synchronous function from a combinational function describing+-- a moore machine+--+-- @+-- macT+--   :: Int        -- Current state+--   -> (Int,Int)  -- Input+--   -> (Int,Int)  -- Updated state+-- macT s (x,y) = x * y + s+--+-- mac+--   :: 'KnownDomain' dom+--   => 'Clock' dom+--   -> 'Reset' dom+--   -> 'Enable' dom+--   -> 'Signal' dom (Int, Int)+--   -> 'Signal' dom Int+-- mac clk rst en = 'moore' clk rst en macT id 0+-- @+--+-- >>> simulate (mac systemClockGen systemResetGen enableGen) [(0,0),(1,1),(2,2),(3,3),(4,4)]+-- [0,0,1,5,14...+-- ...+--+-- Synchronous sequential functions can be composed just like their+-- combinational counterpart:+--+-- @+-- dualMac+--   :: 'KnownDomain' dom+--   => 'Clock' dom+--   -> 'Reset' dom+--   -> 'Enable' dom+--   -> ('Signal' dom Int, 'Signal' dom Int)+--   -> ('Signal' dom Int, 'Signal' dom Int)+--   -> 'Signal' dom Int+-- dualMac clk rst en (a,b) (x,y) = s1 + s2+--   where+--     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+     , NFDataX s )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Reset dom+  -> Enable dom+  -> (s -> i -> s)+  -- ^ Transfer function in moore machine form: @state -> input -> newstate@+  -> (s -> o)+  -- ^ Output function in moore machine form: @state -> output@+  -> s+  -- ^ Initial state+  -> (Signal dom i -> Signal dom o)+  -- ^ Synchronous sequential function with input and output matching that+  -- of the moore machine+moore clk rst en ft fo iS =+  \i -> let s' = ft <$> s <*> i+            s  = register clk rst en iS s'+        in fo <$> s+{-# INLINABLE moore #-}++-- | Create a synchronous function from a combinational function describing+-- a moore machine without any output logic+medvedev+  :: ( KnownDomain dom+     , NFDataX s )+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> (s -> i -> s)+  -> s+  -> (Signal dom i -> Signal dom s)+medvedev clk rst en tr st = moore clk rst en tr id st+{-# INLINE medvedev #-}++-- | A version of 'moore' that does automatic 'Bundle'ing+--+-- Given a functions @t@ and @o@ of types:+--+-- @+-- __t__ :: Int -> (Bool, Int) -> Int+-- __o__ :: Int -> (Int, Bool)+-- @+--+-- When we want to make compositions of @t@ and @o@ in @g@ using 'moore', we have to+-- write:+--+-- @+-- g clk rst en a b c = (b1,b2,i2)+--   where+--     (i1,b1) = 'unbundle' (moore clk rst en t o 0 ('bundle' (a,b)))+--     (i2,b2) = 'unbundle' (moore clk rst en t o 3 ('bundle' (c,i1)))+-- @+--+-- Using 'mooreB' however we can write:+--+-- @+-- g clk rst en a b c = (b1,b2,i2)+--   where+--     (i1,b1) = 'mooreB' clk rst en t o 0 (a,b)+--     (i2,b2) = 'mooreB' clk rst en t o 3 (c,i1)+-- @+mooreB+  :: ( KnownDomain dom+     , NFDataX s+     , Bundle i+     , Bundle o )+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> (s -> i -> s)+  -- ^ Transfer function in moore machine form:+  -- @state -> input -> newstate@+  -> (s -> o)+  -- ^ Output function in moore machine form:+  -- @state -> output@+  -> s+  -- ^ Initial state+  -> (Unbundled dom i -> Unbundled dom o)+  -- ^ Synchronous sequential function with input and output matching that+  -- of the moore machine+mooreB clk rst en ft fo iS i = unbundle (moore clk rst en ft fo iS (bundle i))+{-# INLINE mooreB #-}++-- | A version of 'medvedev' that does automatic 'Bundle'ing+medvedevB+  :: ( KnownDomain dom+     , NFDataX s+     , Bundle i+     , Bundle s )+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> (s -> i -> s)+  -> s+  -> (Unbundled dom i -> Unbundled dom s)+medvedevB clk rst en tr st = mooreB clk rst en tr id st+{-# INLINE medvedevB #-}
+ src/Clash/Explicit/Prelude.hs view
@@ -0,0 +1,289 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2017     , Google Inc.+                  2019     , Myrtle Software Ltd,+                  2021-2025, QBayLogic B.V.,+                  2022     , Myrtle.ai,+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++This module defines the explicitly clocked counterparts of the functions+defined in "Clash.Prelude".+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE NoImplicitPrelude #-}++{-# LANGUAGE Unsafe #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_HADDOCK show-extensions, not-home #-}++module Clash.Explicit.Prelude+  ( -- * Creating synchronous sequential circuits+    mealy+  , mealyS+  , mealyB+  , mealySB+  , moore+  , mooreB+  , registerB+    -- * Synchronizer circuits for safe clock domain crossings+  , dualFlipFlopSynchronizer+  , asyncFIFOSynchronizer+    -- * ROMs+  , asyncRom+  , asyncRomPow2+  , rom+  , romPow2+    -- ** ROMs defined by a 'MemBlob'+  , asyncRomBlob+  , asyncRomBlobPow2+  , romBlob+  , romBlobPow2+    -- ** ROMs defined by a data file+  , asyncRomFile+  , asyncRomFilePow2+  , romFile+  , romFilePow2+    -- * RAM primitives with a combinational read port+  , asyncRam+  , asyncRamPow2+    -- * Block RAM primitives+  , blockRam+  , blockRamPow2+  , blockRamU+  , blockRam1+  , ResetStrategy(..)+    -- ** 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+  -- ** 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+  , outputVerifier'+    -- * Tracing+    -- ** Simple+  , traceSignal1+  , traceVecSignal1+    -- ** Tracing in a multi-clock environment+  , traceSignal+  , traceVecSignal+    -- ** VCD dump functions+  , dumpVCD+    -- * Exported modules+    -- ** Synchronous signals+  , module Clash.Explicit.Reset+  , module Clash.Explicit.Signal+  , module Clash.Explicit.Signal.Delayed+    -- ** Datatypes+    -- *** Bit vectors+  , module Clash.Sized.BitVector+    -- *** Arbitrary-width numbers+  , module Clash.Sized.Signed+  , module Clash.Sized.Unsigned+  , module Clash.Sized.Index+    -- *** Fixed point numbers+  , module Clash.Sized.Fixed+    -- *** Fixed size vectors+  , module Clash.Sized.Vector+    -- *** Perfect depth trees+  , module Clash.Sized.RTree+    -- ** Annotations+  , module Clash.Annotations.TopEntity+    -- ** Generics type-classes+  , Generic+  , Generic1+    -- ** Type-level natural numbers+  , module GHC.TypeLits+  , module GHC.TypeLits.Extra+  , module Clash.Promoted.Nat+  , module Clash.Promoted.Nat.Literals+  , module Clash.Promoted.Nat.TH+    -- ** Type-level strings+  , module Clash.Promoted.Symbol+    -- ** 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+  , module Clash.Class.Resize+    -- *** Other+  , module Control.Applicative+  , module Data.Bits+  , module Data.Default+    -- ** Exceptions+  , module Clash.XException+    -- ** Named types+  , module Clash.NamedTypes+    -- ** Magic+  , module Clash.Magic+    -- ** Haskell Prelude+    -- $hiding+  , module Clash.HaskellPrelude+  )+where++import Control.Applicative+import Data.Bits+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.ROM.File       (asyncRomFile, asyncRomFilePow2)+import Clash.Promoted.Nat+import Clash.Promoted.Nat.TH+import Clash.Promoted.Nat.Literals+import Clash.Promoted.Symbol+import Clash.Signal.Trace+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 hiding (fromList, unsafeFromList)+import Clash.XException++{- $setup+>>> :set -XDataKinds -XTypeApplications+>>> import Clash.Explicit.Prelude+>>> let window4 = window @3+>>> 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'+--+-- @+-- window4+---  :: Clock dom+--   -> Reset dom+--   -> Enable dom+--   -> 'Signal' dom Int+--   -> 'Vec' 4 ('Signal' dom Int)+-- window4 = 'window'+-- @+--+-- >>> simulateB (window4 systemClockGen systemResetGen enableGen) [1::Int,2,3,4,5] :: [Vec 4 Int]+-- [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+     , KnownDomain dom+     , NFDataX a+     , Default a+     )+  => Clock dom+  -- ^ Clock to the incoming signal is synchronized+  -> Reset dom+  -> Enable dom+  -> Signal dom a+  -- ^ Signal to create a window over+  -> Vec (n + 1) (Signal dom a)+  -- ^ Window of at least size 1+window clk rst en x = res+  where+    res  = x :> prev+    prev = case natVal (asNatProxy prev) of+             0 -> repeat def+             _ -> let next = x +>> prev+                  in  registerB clk rst en (repeat def) next+{-# INLINABLE window #-}++-- | Give a delayed window over a 'Signal'+--+-- @+-- windowD3+--   :: KnownDomain dom+--   -> Clock dom+--   -> Enable dom+--   -> Reset dom+--   -> 'Signal' dom Int+--   -> 'Vec' 3 ('Signal' dom Int)+-- windowD3 = 'windowD'+-- @+--+-- >>> simulateB (windowD3 systemClockGen resetGen enableGen) [1::Int,1,2,3,4] :: [Vec 3 Int]+-- [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+     , NFDataX a+     , Default a+     , KnownDomain dom )+  => Clock dom+  -- ^ Clock to which the incoming signal is synchronized+  -> Reset dom+  -> Enable dom+  -> Signal dom a+  -- ^ Signal to create a window over+  -> Vec (n + 1) (Signal dom a)+  -- ^ Window of at least size 1+windowD clk rst en x =+  let prev = registerB clk rst en (repeat def) next+      next = x +>> prev+  in  prev+{-# INLINABLE windowD #-}
+ src/Clash/Explicit/Prelude/Safe.hs view
@@ -0,0 +1,274 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2017     , Google Inc.+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++__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 CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}++{-# LANGUAGE Safe #-}++{-# OPTIONS_HADDOCK show-extensions, not-home #-}++module Clash.Explicit.Prelude.Safe+  ( -- * Creating synchronous sequential circuits+    mealy+  , mealyB+  , moore+  , mooreB+  , registerB+    -- * Synchronizer circuits for safe clock domain crossing+  , dualFlipFlopSynchronizer+  , asyncFIFOSynchronizer+    -- * ROMs+  , asyncRom+  , asyncRomPow2+  , rom+  , romPow2+    -- ** ROMs defined by a 'MemBlob'+  , asyncRomBlob+  , asyncRomBlobPow2+  , romBlob+  , romBlobPow2+    -- * RAM primitives with a combinational read port+  , asyncRam+  , asyncRamPow2+    -- * Block RAM primitives+  , blockRam+  , blockRamPow2+    -- ** 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+  , riseEvery+  , oscillate+    -- * Exported modules+    -- ** Synchronous signals+  , module Clash.Explicit.Signal+  , module Clash.Explicit.Signal.Delayed+    -- ** Datatypes+    -- *** Bit vectors+  , module Clash.Sized.BitVector+    -- *** Arbitrary-width numbers+  , module Clash.Sized.Signed+  , module Clash.Sized.Unsigned+  , module Clash.Sized.Index+    -- *** Fixed point numbers+  , module Clash.Sized.Fixed+    -- *** Fixed size vectors+  , module Clash.Sized.Vector+    -- *** Perfect depth trees+  , module Clash.Sized.RTree+    -- ** Annotations+  , module Clash.Annotations.TopEntity+    -- ** Generics type-classes+  , Generic+  , Generic1+    -- ** Type-level natural numbers+  , module GHC.TypeLits+  , module GHC.TypeLits.Extra+  , module Clash.Promoted.Nat+  , module Clash.Promoted.Nat.Literals+  , module Clash.Promoted.Nat.TH+    -- ** Type-level strings+  , module Clash.Promoted.Symbol+    -- ** Type classes+    -- *** Clash+  , module Clash.Class.BitPack+  , module Clash.Class.Num+  , module Clash.Class.Resize+    -- *** Other+  , module Control.Applicative+  , module Data.Bits+      -- ** Exceptions+  , module Clash.XException+    -- ** Named types+  , module Clash.NamedTypes+    -- ** Haskell Prelude+    -- $hiding+  , module Clash.HaskellPrelude+  )+where++import Control.Applicative+import Data.Bits+import GHC.Generics (Generic, Generic1)+import GHC.TypeLits+  hiding (SNat, SSymbol, fromSNat)+import GHC.TypeLits.Extra+import Clash.HaskellPrelude+import qualified Prelude++import Clash.Annotations.TopEntity+import Clash.Class.BitPack+import Clash.Class.Num+import Clash.Class.Resize+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.ROM.Blob (asyncRomBlob, asyncRomBlobPow2)+import Clash.Prelude.ROM             (asyncRom, asyncRomPow2)+import Clash.Promoted.Nat+import Clash.Promoted.Nat.TH+import Clash.Promoted.Nat.Literals+import Clash.Promoted.Symbol+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 hiding (fromList, unsafeFromList)+import Clash.XException++{- $setup+>>> :set -XDataKinds+>>> :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)@)+--+-- @+-- rP :: Clock dom -> Reset dom -> Enable dom+--    -> ('Signal' dom Int, 'Signal' dom Int)+--    -> ('Signal' dom Int, 'Signal' dom Int)+-- rP clk rst en = 'registerB' clk rst en (8,8)+-- @+--+-- >>> simulateB (rP systemClockGen systemResetGen enableGen) [(1,1),(1,1),(2,2),(3,3)] :: [(Int,Int)]+-- [(8,8),(8,8),(1,1),(2,2),(3,3)...+-- ...+registerB+  :: ( KnownDomain dom+     , NFDataX a+     , Bundle a )+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> a+  -> Unbundled dom a+  -> Unbundled dom a+registerB clk rst en i =+  unbundle Prelude.. register clk rst en i Prelude.. bundle+{-# INLINE registerB #-}++-- | Give a pulse when the 'Signal' goes from 'minBound' to 'maxBound'+isRising+  :: ( KnownDomain dom+     , NFDataX a+     , Bounded a+     , Eq a )+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> a -- ^ Starting value+  -> Signal dom a+  -> Signal dom Bool+isRising clk rst en is s = liftA2 edgeDetect prev s+  where+    prev = register clk rst en is s+    edgeDetect old new = old == minBound && new == maxBound+{-# INLINABLE isRising #-}++-- | Give a pulse when the 'Signal' goes from 'maxBound' to 'minBound'+isFalling+  :: ( KnownDomain dom+     , NFDataX a+     , Bounded a+     , Eq a )+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> a -- ^ Starting value+  -> Signal dom a+  -> Signal dom Bool+isFalling clk rst en is s = liftA2 edgeDetect prev s+  where+    prev = register clk rst en is s+    edgeDetect old new = old == maxBound && new == minBound+{-# INLINABLE isFalling #-}++-- | Give a pulse every @n@ clock cycles. This is a useful helper function when+-- combined with functions like @'Clash.Explicit.Signal.regEn'@ or+-- @'Clash.Explicit.Signal.mux'@, in order to delay a register by a known amount.+riseEvery+  :: forall dom  n+   . KnownDomain dom+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> SNat n+  -> Signal dom Bool+riseEvery clk rst en SNat = moore clk rst en transfer output 0 (pure ())+  where+    output :: Index n -> Bool+    output = (== maxBound)++    transfer :: Index n -> () -> Index n+    transfer s _ = if (s == maxBound) then 0 else s+1+{-# INLINEABLE riseEvery #-}++-- | Oscillate a @'Bool'@ for a given number of cycles, given the starting state.+oscillate+  :: forall dom  n+   . KnownDomain dom+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> Bool+  -> SNat n+  -> Signal dom Bool+oscillate clk rst en begin SNat =+  moore clk rst en transfer snd (0, begin) (pure ())+ where+  transfer :: (Index n, Bool) -> () -> (Index n, Bool)+  transfer (s, i) _ =+    if s == maxBound+      then (0,   not i) -- reset state and oscillate output+      else (s+1, i)     -- hold current output+{-# INLINEABLE oscillate #-}
+ src/Clash/Explicit/RAM.hs view
@@ -0,0 +1,216 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente,+                  2017     , Google Inc.+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++RAM primitives with a combinational read port.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-# LANGUAGE Trustworthy #-}++-- 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 #-}++module Clash.Explicit.RAM+  ( -- * RAM synchronized to an arbitrary clock+    asyncRam+  , asyncRamPow2+    -- * Internal+  , asyncRam#+  )+where++import Data.Maybe            (isJust)+import GHC.Stack             (HasCallStack, withFrozenCallStack)+import GHC.TypeLits          (KnownNat)+import qualified Data.Sequence as Seq++import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Explicit.Signal (unbundle, KnownDomain, andEnable)+import Clash.Promoted.Nat    (SNat (..), snatToNum, pow2SNat)+import Clash.Signal.Internal+  (Clock (..), ClockAB (..), Signal (..), Enable, fromEnable, clockTicks)+import Clash.Signal.Internal.Ambiguous (clockPeriod)+import Clash.Sized.Unsigned  (Unsigned)+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/, reading it will throw an+-- 'Clash.XException.XException'+--+-- === See also:+--+-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a+-- RAM.+asyncRamPow2+  :: forall wdom rdom n a+   . ( KnownNat n+     , HasCallStack+     , KnownDomain wdom+     , KnownDomain rdom+     , NFDataX a+     )+  => Clock wdom+   -- ^ 'Clock' to which the write port of the RAM is synchronized+  -> Clock rdom+   -- ^ 'Clock' to which the read address signal, @r@, is synchronized+  -> Enable wdom+  -- ^ '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@+asyncRamPow2 = \wclk rclk en rd wrM -> withFrozenCallStack+  (asyncRam wclk rclk en (pow2SNat (SNat @n)) rd wrM)+{-# INLINE asyncRamPow2 #-}+++-- | Create a RAM with space for @n@ elements+--+-- * __NB__: Initial content of the RAM is /undefined/, reading it will throw an+-- 'Clash.XException.XException'+--+-- === 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 the write port of the RAM is synchronized+  -> Clock rdom+   -- ^ 'Clock' to which the read address signal, @r@, is synchronized+  -> Enable wdom+  -- ^ 'Enable' line for the write port+  -> 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@+asyncRam = \wclk rclk gen sz rd wrM ->+  let en       = isJust <$> wrM+      (wr,din) = unbundle (fromJustX <$> wrM)+  in  withFrozenCallStack+      (asyncRam# wclk rclk gen sz (fromEnum <$> rd) en (fromEnum <$> wr) din)+{-# INLINE asyncRam #-}++-- | RAM primitive+asyncRam#+  :: forall wdom rdom n a+   . ( HasCallStack+     , KnownDomain wdom+     , KnownDomain rdom+     , NFDataX a+     )+  => Clock wdom+   -- ^ 'Clock' to which the write port of the RAM is synchronized+  -> Clock rdom+   -- ^ 'Clock' to which the read address signal, @r@, is synchronized+  -> Enable wdom+  -- ^ 'Enable' line for the write port+  -> SNat n+  -- ^ Size @n@ of the RAM+  -> Signal rdom Int+  -- ^ Read address @r@+  -> Signal wdom Bool+  -- ^ Write enable+  -> Signal wdom Int+  -- ^ Write address @w@+  -> 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 = dout+  where+    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++    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)++    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 -> -- 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 -> -- 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++    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
@@ -0,0 +1,144 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente,+                  2017     , Google Inc.+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++ROMs+-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Explicit.ROM+  ( -- * Synchronous ROM synchronized to an arbitrary clock+    rom+  , romPow2+    -- * Internal+  , rom#+  )+where++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)+import Clash.Sized.Vector     (Vec, length, toList)+import Clash.XException       (deepErrorX, seqX, NFDataX)++-- | 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.+-- * 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+  -- ^ 'Enable' line+  -> Vec (2^n) a+  -- ^ ROM content+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom (Unsigned n)+  -- ^ Read address @r@+  -> Signal dom a+  -- ^ 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/, 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.+-- * 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+  -- ^ 'Enable' line+  -> Vec n a+  -- ^ ROM content, also determines the size, @n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom a+  -- ^ 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 #-}++-- | ROM primitive+rom#+  :: forall dom n a+   . (KnownDomain dom, KnownNat n, NFDataX a)+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> Vec n a+  -- ^ ROM content, also determines the size, @n@, of the ROM+  --+  -- __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 =+  go+    (withFrozenCallStack (deepErrorX "rom: initial value undefined"))+    (fromEnable en)+ where+  szI = length content+  arr = listArray (0,szI-1) (toList 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 -> 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
@@ -0,0 +1,226 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente,+                  2017     , Google Inc.,+                  2019     , Myrtle Software Ltd.,+                  2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+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'++Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@.+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':++@+writeFile "memory.bin" (memFile Nothing [7 :: Unsigned 9 .. 13])+@++We can instantiate a synchronous ROM using the contents of the file above like+so:++@+f :: KnownDomain dom+  => Clock  dom+  -> Enable dom+  -> Signal dom (Unsigned 3)+  -> Signal dom (Unsigned 9)+f clk en rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' clk en d7 \"memory.bin\" rd+@++And see that it works as expected:++@+__>>> import qualified Data.List as L__+__>>> L.tail $ sampleN 4 $ f systemClockGen (fromList [3..5])__+[10,11,12]+@++However, we can also interpret the same data as a tuple of a 6-bit unsigned+number, and a 3-bit signed number:++@+g :: KnownDomain dom+  => Clock  dom+  -> Signal dom (Unsigned 3)+  -> Signal dom (Unsigned 6,Signed 3)+g clk en rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' clk en d7 \"memory.bin\" rd+@++And then we would see:++@+__>>> import qualified Data.List as L__+__>>> L.tail $ sampleN 4 $ g systemClockGen (fromList [3..5])__+[(1,2),(1,3)(1,-4)]+@+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++{-# LANGUAGE Unsafe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Explicit.ROM.File+  ( -- * Synchronous ROM synchronized to an arbitrary clock+    romFile+  , romFilePow2+    -- * Producing files+  , memFile+    -- * Internal+  , romFile#+  )+where++import Data.Array                   (listArray)+import Data.Array.Base              (unsafeAt)+import GHC.TypeLits                 (KnownNat)+import System.IO.Unsafe             (unsafePerformIO)++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)+import Clash.Sized.Unsigned         (Unsigned)+import Clash.XException             (NFDataX(deepErrorX))+++-- | 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'+-- * __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      |+-- +----------------+----------+----------+---------------++--+-- === 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 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+  -- ^ 'Enable' line+  -> FilePath+  -- ^ File describing the content of the ROM+  -> Signal dom (Unsigned n)+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ 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/, 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      |+-- +----------------+----------+----------+---------------++--+-- === 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+  :: (KnownNat m, Enum addr, KnownDomain dom)+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> SNat n+  -- ^ Size of the ROM+  -> FilePath+  -- ^ File describing the content of the ROM+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ 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#+  :: forall m dom n+   . (KnownNat m, KnownDomain dom)+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> SNat n+  -- ^ Size of the ROM+  -> FilePath+  -- ^ File describing the content of the ROM+  -> Signal dom Int+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ 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")+        (safeAt <$> rd)+ where+  mem     = unsafePerformIO (initMem file)+  content = listArray (0,szI-1) mem+  szI     = snatToNum sz++  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
@@ -0,0 +1,1035 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2016-2019, Myrtle Software,+                  2017-2022, Google Inc.+                  2020     , Ben Gamari,+                  2021-2025, 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 :: 'GHC.TypeLits.Symbol') 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:: 'GHC.TypeLits.Symbol'+  -- ^ Domain name+  , _period :: 'GHC.TypeLits.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 a standard implementation, called 'System', that is+configured as follows:++@+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/ (100 MHz). Memory elements update their state on the rising edge+of the clock, can be reset asynchronously with regards to the clock, 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__: 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!++=== Explicit clocks and resets, and meta-stability #metastability#++When using multiple clocks and/or reset lines there are ways to accidentally+introduce situations that are prone to+<https://en.wikipedia.org/wiki/Metastability_in_electronics metastability>.+These bugs are incredibly hard to debug as they often cannot be simulated, so+it's best to prevent them in the first place. This section outlines the+situations in which metastability arises and how to prevent it.++Two types of resets exist: synchronous and asynchronous resets. These reset+types are encoded in a synthesis domain. For the following examples we assume+the following exist:++@+'DomainConfiguration' \"SyncExample\" _period _edge 'Synchronous' _init+'DomainConfiguration' \"AsyncExample\" _period _edge 'Asynchronous' _init+@++See the previous section on how to use domains.++We now go over the clock and reset line combinations and explain when they+can potentially introduce situations prone to meta-stability:++    *   /Reset situation 1/:++        @+        f :: 'Reset' \"SyncExample\" -> 'Reset' \"SyncExample\" -> ..+        f x y = ..+        @++        There are no problems here, because although /x/ and /y/ can have+        different values, components to these reset lines are reset+        /synchronously/, and there is no metastability situation.++    *   /Reset situation 2/:++        @+        g :: 'Reset' \"AsyncExample\" -> 'Reset' \"AsyncExample\" -> ..+        g x y = ..+        @++        This situation can be prone to metastability, because although /x/ and+        /y/ belong to the same /domain/ according to their domain, there is no+        guarantee that they actually originate from the same source. This means+        that one component can enter its reset state asynchronously to another+        component, inducing metastability in the other component.++    *   /Clock situation/:++        @+        k :: 'Clock' dom -> 'Clock' dom -> ..+        k x y = ..+        @++        The situation above is potentially prone to metastability, because+        even though /x/ and /y/ belong to the same /domain/ according to their+        domain, there is no guarantee that they actually originate from the same+        source. They could hence be connected to completely unrelated clock+        sources, and components can then induce metastable states in others.++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# 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(..)+  , KnownConfiguration+  , ActiveEdge(..)+  , SActiveEdge(..)+  , InitBehavior(..)+  , SInitBehavior(..)+  , ResetKind(..)+  , SResetKind(..)+  , ResetPolarity(..)+  , SResetPolarity(..)+  , DomainConfiguration(..)+  , SDomainConfiguration(..)+  -- ** Configuration type families+  , DomainPeriod+  , DomainActiveEdge+  , 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+  , IntelSystem+  , vSystem+  , vIntelSystem+  , vXilinxSystem+    -- ** Domain utilities+  , VDomainConfiguration(..)+  , vDomain+  , createDomain+  , knownVDomain+  , clockPeriod+  , activeEdge+  , resetKind+  , initBehavior+  , resetPolarity+    -- ** Enabling+  , Enable+  , toEnable+  , fromEnable+  , enableGen+    -- * Clock+  , Clock+  , DiffClock+  , periodToHz+  , hzToPeriod+    -- ** Synchronization primitive+  , unsafeSynchronizer+  , veryUnsafeSynchronizer+    -- * Reset+  , Reset+  , unsafeToReset+  , unsafeFromReset+  , unsafeToActiveHigh+  , unsafeToActiveLow+  , unsafeFromActiveHigh+  , unsafeFromActiveLow+    -- * 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+  , 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++  -- * Deprecated+  , unsafeFromHighPolarity+  , unsafeFromLowPolarity+  , unsafeToHighPolarity+  , unsafeToLowPolarity+  )+where++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.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 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+>>> :{+instance KnownDomain "Dom2" where+  type KnownConf "Dom2" = 'DomainConfiguration "Dom2" 2 'Rising 'Asynchronous 'Defined 'ActiveHigh+  knownDomain = SDomainConfiguration SSymbol SNat SRising SAsynchronous SDefined SActiveHigh+:}++>>> :{+instance KnownDomain "Dom7" where+  type KnownConf "Dom7" = 'DomainConfiguration "Dom7" 7 'Rising 'Asynchronous 'Defined 'ActiveHigh+  knownDomain = SDomainConfiguration SSymbol SNat SRising SAsynchronous SDefined SActiveHigh+:}++>>> type Dom2 = "Dom2"+>>> type Dom7 = "Dom7"+>>> let clk2 = clockGen @Dom2+>>> let clk7 = clockGen @Dom7+>>> let en2 = enableGen @Dom2+>>> let en7 = enableGen @Dom7+>>> let oversampling clkA clkB enA enB dflt = delay clkB enB dflt . unsafeSynchronizer clkA clkB . delay clkA enA dflt+>>> let almostId clkA clkB enA enB dflt = delay clkB enB dflt . unsafeSynchronizer clkA clkB . delay clkA enA dflt . unsafeSynchronizer clkB clkA . delay clkB enB dflt+>>> let oscillate clk rst en = let s = register clk rst en False (not <$> s) in s+>>> let count clk rst en = let s = regEn clk rst en 0 (oscillate clk rst en) (s + 1) in s+>>> :{+sometimes1 clk rst en = s where+  s = register clk rst en Nothing (switch <$> s)+  switch Nothing = Just 1+  switch _       = Nothing+:}++>>> :{+countSometimes clk rst en = s where+  s = regMaybe clk rst en 0 (plusM (pure <$> s) (sometimes1 clk rst en))+  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+  , 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 'Clash.Explicit.Testbench.tbSystemClockGen'+systemClockGen+  :: Clock System+systemClockGen = clockGen++-- | Reset generator for use in simulation, for the 'System' clock domain.+-- Asserts the reset for a single cycle.+--+-- __NB__: While this can be used in the @testBench@ function, it cannot be+-- synthesized to hardware.+--+-- === __Example__+--+-- @+-- 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'+-- @+systemResetGen ::Reset System+systemResetGen = resetGen++-- ** 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+-- of) wire(s) in the eventual circuit. This function should only be used as+-- part of a proper synchronization component, such as the following dual+-- flip-flop synchronizer:+--+-- @+-- dualFlipFlop+--   :: Clock domA+--   -> Clock domB+--   -> Enable domA+--   -> Enable domB+--   -> Bit+--   -> Signal domA Bit+--   -> Signal domB Bit+-- dualFlipFlop clkA clkB enA enB dflt =+--   'delay' clkB enB dflt . 'delay' clkB enB dflt . 'unsafeSynchronizer' clkA clkB+-- @+--+-- The 'unsafeSynchronizer' works in such a way that, given 2 clocks:+--+-- @+-- createDomain vSystem{vName=\"Dom7\", vPeriod=7}+--+-- clk7 :: 'Clock' Dom7+-- clk7 = 'clockGen'+--+-- en7 :: 'Enable' Dom7+-- en7 = 'enableGen'+-- @+--+-- and+--+-- @+-- createDomain vSystem{vName=\"Dom2\", vPeriod=2}+--+-- clk2 :: 'Clock' Dom2+-- clk2 = 'clockGen'+--+-- en2 :: 'Enable' Dom2+-- en2 = 'enableGen'+-- @+--+-- Oversampling followed by compression is the identity function plus 2 initial+-- values:+--+-- @+-- 'delay' clkB enB dflt $+-- 'unsafeSynchronizer' clkA clkB $+-- 'delay' clkA enA dflt $+-- 'unsafeSynchronizer' clkB clkA $+-- 'delay' clkB enB s+--+-- ==+--+-- dflt :- dflt :- s+-- @+--+-- Something we can easily observe:+--+-- @+-- oversampling clkA clkB enA enB dflt =+--   'delay' clkB enB dflt+--     . 'unsafeSynchronizer' clkA clkB+--     . 'delay' clkA enA dflt+-- almostId clkA clkB enA enB dflt =+--   'delay' clkB enB dflt+--     . 'unsafeSynchronizer' clkA clkB+--     . 'delay' clkA enA dflt+--     . 'unsafeSynchronizer' clkB clkA+--     . 'delay' clkB enB dflt+-- @+--+-- >>> sampleN 37 (oversampling clk7 clk2 en7 en2 0 (fromList [(1::Int)..10]))+-- [0,0,1,1,1,2,2,2,2,3,3,3,4,4,4,4,5,5,5,6,6,6,6,7,7,7,8,8,8,8,9,9,9,10,10,10,10]+-- >>> sampleN 12 (almostId clk2 clk7 en2 en7 0 (fromList [(1::Int)..10]))+-- [0,0,1,2,3,4,5,6,7,8,9,10]+unsafeSynchronizer+  :: 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+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 behavior. For example,+--+-- @+-- 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+  :: 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 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 :: [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 by applying the boolean AND+-- operation.+andEnable+  :: Enable dom+  -> Signal dom Bool+  -> Enable dom+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.+dflipflop+  :: ( KnownDomain dom+     , NFDataX a )+  => Clock dom+  -> Signal dom a+  -> Signal dom a+dflipflop = \clk i ->+  delay#+    clk+    (toEnable (pure True))+    (deepErrorX "First value of dflipflop undefined")+    i+{-# INLINE dflipflop #-}++-- | \"@'delay' clk s@\" delays the values in 'Signal' /s/ for once cycle, the+-- value at time 0 is /dflt/.+--+-- >>> sampleN 3 (delay systemClockGen enableGen 0 (fromList [1,2,3,4]))+-- [0,1,2]+delay+  :: ( KnownDomain dom+     , NFDataX a )+  => Clock dom+  -- ^ Clock+  -> Enable dom+  -- ^ Global enable+  -> a+  -- ^ Initial value+  -> Signal dom a+  -> Signal dom a+delay = delay#+{-# INLINE delay #-}++-- | Version of 'delay' that only updates when its third argument is a 'Just'+-- value.+--+-- >>> let input = fromList [Just 1, Just 2, Nothing, Nothing, Just 5, Just 6, Just (7::Int)]+-- >>> sampleN 7 (delayMaybe systemClockGen enableGen 0 input)+-- [0,1,2,2,2,5,6]+delayMaybe+  :: ( KnownDomain dom+     , NFDataX a )+  => Clock dom+  -- ^ Clock+  -> Enable dom+  -- ^ Global enable+  -> a+  -- ^ Initial value+  -> Signal dom (Maybe a)+  -> Signal dom a+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.+--+-- >>> let input = fromList [1,2,3,4,5,6,7::Int]+-- >>> let enable = fromList [True,True,False,False,True,True,True]+-- >>> sampleN 7 (delayEn systemClockGen enableGen 0 enable input)+-- [0,1,2,2,2,5,6]+delayEn+  :: ( KnownDomain dom+     , NFDataX a )+  => Clock dom+  -- ^ Clock+  -> Enable dom+  -- ^ Global enable+  -> a+  -- ^ Initial value+  -> Signal dom Bool+  -- ^ Enable+  -> Signal dom a+  -> Signal dom a+delayEn = \clk gen dflt en i ->+  delay# clk (andEnable gen en) dflt i+{-# INLINE delayEn #-}++-- | \"@'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]))+-- [8,8,1,2,3]+register+  :: ( KnownDomain dom+     , NFDataX a )+  => Clock dom+  -- ^ clock+  -> Reset dom+  -- ^ Reset, 'register' outputs the reset value when the reset is active+  -> Enable dom+  -- ^ Global enable+  -> a+  -- ^ Reset value. If the domain has initial values enabled, the reset value+  -- will also be the initial value.+  -> Signal dom a+  -> Signal dom a+register = \clk rst gen initial i ->+  register# clk rst gen initial initial i+{-# INLINE register #-}++-- | Version of 'register' that only updates its content when its fourth+-- argument is a 'Just' value. So given:+--+-- @+-- sometimes1 clk rst en = s where+--   s = 'register' clk rst en Nothing (switch '<$>' s)+--+--   switch Nothing = Just 1+--   switch _       = Nothing+--+-- countSometimes clk rst en = s where+--   s     = 'regMaybe' clk rst en 0 (plusM ('pure' '<$>' s) (sometimes1 clk rst en))+--   plusM = liftA2 (liftA2 (+))+-- @+--+-- We get:+--+-- >>> sampleN 9 (sometimes1 systemClockGen resetGen enableGen)+-- [Nothing,Nothing,Just 1,Nothing,Just 1,Nothing,Just 1,Nothing,Just 1]+-- >>> sampleN 9 (count systemClockGen resetGen enableGen)+-- [0,0,0,1,1,2,2,3,3]+regMaybe+  :: ( KnownDomain dom+     , NFDataX a )+  => Clock dom+  -- ^ Clock+  -> Reset dom+  -- ^ Reset, 'regMaybe' outputs the reset value when the reset value is active+  -> Enable dom+  -- ^ Global enable+  -> a+  -- ^ Reset value. If the domain has initial values enabled, the reset value+  -- will also be the initial value.+  -> Signal dom (Maybe a)+  -> Signal dom a+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+-- argument is asserted. So given:+--+-- @+-- oscillate clk rst en = let s = 'register' clk rst en False (not \<$\> s) in s+-- count clk rst en     = let s = 'regEn clk rst en 0 (oscillate clk rst en) (s + 1) in s+-- @+--+-- We get:+--+-- >>> sampleN 9 (oscillate systemClockGen resetGen enableGen)+-- [False,False,True,False,True,False,True,False,True]+-- >>> sampleN 9 (count systemClockGen resetGen enableGen)+-- [0,0,0,1,1,2,2,3,3]+regEn+  :: ( KnownDomain dom+     , NFDataX a+     )+  => Clock dom+  -- ^ Clock+  -> Reset dom+  -- ^ Reset, 'regEn' outputs the reset value when the reset value is active+  -> Enable dom+  -- ^ Global enable+  -> a+  -- ^ Reset value. If the domain has initial values enabled, the reset value+  -- will also be the initial value.+  -> Signal dom Bool+  -- ^ Enable signal+  -> Signal dom a+  -> Signal dom a+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+-- to 'simulate', 'simulateWithReset' will drop the output values produced while+-- the reset is asserted. While the reset is asserted, the first value from+-- @[a]@ is fed 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+  -> ( KnownDomain dom+    => Clock dom+    -> Reset dom+    -> Enable dom+    -> Signal dom a+    -> Signal dom b )+  -- ^ Circuit to simulate+  -> [a]+  -> [b]+simulateWithReset m resetVal f as =+  drop (snatToNum m) out+ where+  inp = replicate (snatToNum m) resetVal ++ as+  rst = resetGenN @dom m+  clk = clockGen+  en  = enableGen+  out = simulate (f clk rst en) inp+{-# OPAQUE simulateWithReset #-}++-- | Same as 'simulateWithReset', but only sample the first /Int/ output values.+simulateWithResetN+  :: ( 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 cycle spent in reset)+  -> ( KnownDomain dom+    => Clock dom+    -> Reset dom+    -> Enable dom+    -> Signal dom a+    -> Signal dom b )+  -- ^ Circuit to simulate+  -> [a]+  -> [b]+simulateWithResetN nReset resetVal nSamples f as =+  take nSamples (simulateWithReset nReset resetVal f as)+{-# INLINE simulateWithResetN #-}++-- | Simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a list of+-- samples of type /a/+--+-- >>> simulateB (unbundle . register systemClockGen resetGen enableGen (8,8) . bundle) [(1,1), (1,1), (2,2), (3,3)] :: [(Int,Int)]+-- [(8,8),(8,8),(1,1),(2,2),(3,3)...+-- ...+--+-- __NB__: This function is not synthesizable+simulateB+  :: (Bundle a, Bundle b, NFDataX a, NFDataX b)+  => (Unbundled dom1 a -> Unbundled dom2 b)+  -- ^ The function we want to simulate+  -> [a]+  -- ^ Input samples+  -> [b]+simulateB f = simulate (bundle . f . unbundle)++-- | /Lazily/ simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a+-- list of samples of type /a/+--+-- >>> simulateB (unbundle . register systemClockGen resetGen enableGen (8,8) . bundle) [(1,1), (1,1), (2,2), (3,3)] :: [(Int,Int)]+-- [(8,8),(8,8),(1,1),(2,2),(3,3)...+-- ...+--+-- __NB__: This function is not synthesizable+simulateB_lazy+  :: (Bundle a, Bundle b)+  => (Unbundled dom1 a -> Unbundled dom2 b)+  -- ^ The function we want to simulate+  -> [a]+  -- ^ Input samples+  -> [b]+simulateB_lazy f = simulate_lazy (bundle . f . unbundle)+++-- | Like 'fromList', but resets on reset and has a defined reset value.+--+-- >>> 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']+--+-- __NB__: This function is not synthesizable+fromListWithReset+  :: forall dom a+   . (KnownDomain dom, NFDataX a)+  => Reset dom+  -> a+  -> [a]+  -> Signal dom a+fromListWithReset rst resetValue 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++-- | 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+  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
@@ -0,0 +1,274 @@+{-|+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 GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}+{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Explicit.Signal.Delayed+  ( DSignal+    -- * Delay-annotated synchronous signals+  , delayed+  , delayedI+  , delayN+  , delayI+  , delayedFold+  , feedback+    -- * Signal \<-\> DSignal conversion+  , fromSignal+  , toSignal+    -- * List \<-\> DSignal conversion (not synthesizable)+  , dfromList+    -- ** lazy versions+  , dfromList_lazy+    -- * Experimental+  , unsafeFromSignal+  , antiDelay+  , forward+  )+where++import Prelude                    ((.), (<$>), (<*>), id, Num(..))++import Data.Coerce                (coerce)+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+import Clash.Signal.Delayed.Internal+  (DSignal(..), dfromList, dfromList_lazy, fromSignal, toSignal,+   unsafeFromSignal, antiDelay, feedback, forward)++import Clash.Explicit.Signal+  (KnownDomain, Clock, Domain, Reset, Signal, Enable, register, delay, bundle, unbundle)+import Clash.Promoted.Nat         (SNat (..), snatToInteger)+import Clash.XException           (NFDataX)++{- $setup+>>> :set -XDataKinds+>>> :set -XTypeOperators+>>> 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+        -> Enable System+        -> DSignal System 0 Int -> DSignal System 0 Int+        -> DSignal System 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' a b acc = let acc' = a * b + acc+                       in  (acc, delayed clk rst en (singleton 0) acc')+:}++-}++-- TODO: Reimplement with dtfold+-- | Delay a 'DSignal' for @d@ periods.+--+-- @+-- delay3+--   :: KnownDomain dom+--   => Clock dom+--   -> Reset dom+--   -> Enable dom+--   -> 'DSignal' dom n Int+--   -> 'DSignal' dom (n + 3) Int+-- delay3 clk rst en = 'delayed' clk rst en (-1 ':>' -1 ':>' -1 ':>' 'Nil')+-- @+--+-- >>> sampleN 7 (delay3 systemClockGen resetGen enableGen (dfromList [0..]))+-- [-1,-1,-1,-1,1,2,3]+delayed+  :: forall dom  a n d+   . ( KnownDomain dom+     , KnownNat d+     , NFDataX a )+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> Vec d a+  -- ^ Initial values+  -> DSignal dom n a+  -> DSignal dom (n + d) a+delayed clk rst en m ds = coerce (delaySignal (coerce ds))+  where+    delaySignal :: Signal dom a -> Signal dom a+    delaySignal s = case length m of+      0 -> s+      _ -> let (r',o) = shiftInAt0 (unbundle r) (singleton s)+               r      = register clk rst en m (bundle r')+           in  head o++-- | Delay a 'DSignal' for @d@ periods, where @d@ is derived from the+-- context.+--+-- @+-- delay2+--   :: KnownDomain dom+--   => Clock dom+--   -> Reset dom+--   -> Enable dom+--   -> Int+--   -> 'DSignal' dom n Int+--   -> 'DSignal' dom (n + 2) Int+-- delay2 = 'delayedI'+-- @+--+-- >>> sampleN 7 (delay2 systemClockGen resetGen enableGen (-1) (dfromList ([0..])))+-- [-1,-1,-1,1,2,3,4]+--+-- @d@ can also be specified using type application:+--+-- >>> :t delayedI @3+-- delayedI @3+--   :: ... =>+--      Clock dom+--      -> Reset dom+--      -> Enable dom+--      -> a+--      -> DSignal dom n a+--      -> DSignal dom (n + 3) a+delayedI+  :: ( KnownNat d+     , KnownDomain dom+     , NFDataX a )+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> a+  -- ^ Initial value+  -> 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
@@ -0,0 +1,251 @@+{-|+Copyright   :  (C) 2015-2016, University of Twente,+                   2016-2019, Myrtle Software Ltd,+                   2017     , Google Inc.,+                   2021-2022, QBayLogic B.V.+License     :  BSD2 (see the file LICENSE)+Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++Synchronizer circuits for safe clock domain crossings+-}++{-# 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 #-}++module Clash.Explicit.Synchronizer+  ( -- * Bit-synchronizers+    dualFlipFlopSynchronizer+    -- * Word-synchronizers+  , asyncFIFOSynchronizer+  )+where++import Data.Bits                   (complement, shiftR, xor)+import Data.Constraint             ((:-)(Sub), Dict (..))+import Data.Constraint.Nat         (leTrans)+import Data.Maybe                  (isJust)+import GHC.TypeLits                (type (+), type (-), type (<=), type (^), KnownNat)++import Clash.Class.BitPack         (boolToBV, unpack)+import Clash.Class.Resize          (truncateB)+import Clash.Class.BitPack.BitIndex (slice)+import Clash.Explicit.Mealy        (mealyB)+import Clash.Explicit.BlockRam     (RamOp (..), trueDualPortBlockRam)+import Clash.Explicit.Signal+  (Clock, Reset, Signal, Enable, register, unsafeSynchronizer, fromEnable,+  (.&&.), mux, KnownDomain)+import Clash.Promoted.Nat          (SNat (..))+import Clash.Promoted.Nat.Literals (d0)+import Clash.Sized.BitVector       (BitVector, (++#))+import Clash.XException            (NFDataX, fromJustX)++-- * Dual flip-flop synchronizer++-- | 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+     , KnownDomain dom1+     , KnownDomain dom2 )+  => Clock dom1+  -- ^ 'Clock' to which the incoming  data is synchronized+  -> Clock dom2+  -- ^ 'Clock' to which the outgoing data is synchronized+  -> Reset dom2+  -- ^ 'Reset' for registers on the outgoing domain+  -> Enable dom2+  -- ^ 'Enable' for registers on the outgoing domain+  -> a+  -- ^ Initial value of the two synchronization registers+  -> Signal dom1 a+  -- ^ Incoming data+  -> Signal dom2 a+  -- ^ Outgoing, synchronized, data+dualFlipFlopSynchronizer clk1 clk2 rst en i =+  register clk2 rst en i+    . register clk2 rst en i+    . unsafeSynchronizer clk1 clk2++-- * Asynchronous FIFO synchronizer++fifoMem+  :: forall wdom rdom a addrSize+   . ( KnownDomain wdom+     , KnownDomain rdom+     , NFDataX a+     , KnownNat addrSize+     , 1 <= addrSize )+  => Clock wdom+  -> Clock rdom+  -> Enable wdom+  -> Enable rdom+  -> Signal wdom Bool+  -> Signal rdom (BitVector addrSize)+  -> Signal wdom (BitVector addrSize)+  -> Signal wdom (Maybe a)+  -> Signal rdom a+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)++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)+     , Bool )+  -> ( ( BitVector (addrSize + 1)+       , BitVector (addrSize + 1)+       , Bool )+     , ( Bool+       , BitVector addrSize+       , BitVector (addrSize + 1)+       )+     )+writePtrCompareT addrSize@SNat (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' = isFull addrSize ptr' s_ptr++-- 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)++-- | 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+     , NFDataX a )+  => 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 ren+      wfull raddr+      waddr wdataM++  (rempty, raddr, rptr) =+    mealyB+      rclk rrst ren+      readPtrCompareT+      (0, 0, True)+      (s_wptr, rinc)++  (wfull, waddr, wptr) =+    mealyB+      wclk wrst wen+      (writePtrCompareT addrSize)+      (0, 0, False)+      (s_rptr, isJust <$> wdataM)
+ src/Clash/Explicit/Testbench.hs view
@@ -0,0 +1,501 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2017-2022, Google Inc.+                  2019     , Myrtle Software Ltd,+                  2021-2023, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++{-# LANGUAGE Unsafe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}++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 (+), 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(..))+import Clash.Promoted.Symbol (SSymbol(..))+import Clash.Explicit.Signal+  (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#)+import Clash.Sized.Vector    (Vec, (!!), length)+import Clash.XException      (ShowX (..), XException)++-- Note that outputVerifier' is used in $setup, while the examples mention+-- outputVerifier. This is fine, as the examples have explicit type+-- signatures, turning 'outputVerifier' into 'outputVerifier''.++{- $setup+>>> :set -XTemplateHaskell -XDataKinds -XTypeFamilies+>>> import Clash.Explicit.Prelude+>>> let testInput clk rst = stimuliGenerator clk rst $(listToVecTH [(1::Int),3..21])+>>> let expectedOutput clk rst = outputVerifier' clk rst $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int]))+-}++-- | Compares the first two 'Signal's for equality and logs a warning when they+-- are not equal. The second 'Signal' is considered the expected value. This+-- 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)+  => Clock dom+  -> Reset dom+  -> String+  -- ^ Additional message+  -> Signal dom a+  -- ^ Checked value+  -> Signal dom a+  -- ^ Expected value+  -> Signal dom b+  -- ^ Return value+  -> Signal dom b+assert clk (Reset _) msg checked expected returned =+  (\c e cnt r ->+      if eqX c e+         then r+         else trace (concat [ "\ncycle(" ++ show clk ++ "): "+                            , show cnt+                            , ", "+                            , msg+                            , "\nexpected value: "+                            , showX e+                            , ", not equal to actual value: "+                            , showX c+                            ]) r)+  <$> checked <*> expected <*> fromList [(0::Integer)..] <*> returned+  where+    eqX a b = unsafeDupablePerformIO (catch (evaluate (a == b))+                                            (\(_ :: XException) -> return False))+{-# OPAQUE assert #-}+{-# ANN assert hasBlackBox #-}++-- | The same as 'assert', but can handle don't care bits in its expected value.+assertBitVector+  :: (KnownDomain dom, KnownNat n)+  => Clock dom+  -> Reset 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 clk (Reset _) msg checked expected returned =+  (\c e cnt r ->+      if eqX c e+         then r+         else trace (concat [ "\ncycle(" ++ show clk ++ "): "+                            , show cnt+                            , ", "+                            , msg+                            , "\nexpected value: "+                            , showX e+                            , ", not equal to actual value: "+                            , showX c+                            ]) r)+  <$> checked <*> expected <*> fromList [(0::Integer)..] <*> returned+  where+    eqX a b = unsafeDupablePerformIO (catch (evaluate (a `isLike#` b))+                                            (\(_ :: XException) -> return False))+{-# OPAQUE assertBitVector #-}+{-# ANN assertBitVector hasBlackBox #-}++++-- |+--+-- Example:+--+-- @+-- testInput+--   :: KnownDomain dom+--   => Clock dom+--   -> Reset dom+--   -> 'Signal' dom Int+-- testInput clk rst = 'stimuliGenerator' clk rst $('Clash.Sized.Vector.listToVecTH' [(1::Int),3..21])+-- @+--+-- >>> sampleN 14 (testInput systemClockGen resetGen)+-- [1,1,3,5,7,9,11,13,15,17,19,21,21,21]+stimuliGenerator+  :: forall l dom   a+   . ( KnownNat l+     , KnownDomain dom )+  => Clock dom+  -- ^ Clock to which to synchronize the output signal+  -> Reset dom+  -> Vec l a+  -- ^ Samples to generate+  -> Signal dom a+  -- ^ Signal of given samples+stimuliGenerator clk rst samples =+    let (r,o) = unbundle (genT <$> register clk rst (toEnable (pure True)) 0 r)+    in  o+  where+    genT :: Index l -> (Index l,a)+    genT s = (s',samples !! s)+      where+        maxI = toEnum (length samples - 1)++        s' = if s < maxI+                then s + 1+                else s+{-# INLINABLE stimuliGenerator #-}++-- | 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+     , Eq a+     , ShowX a+     , 1 <= l+     )+  => Clock dom+  -- ^ Clock to which the test bench is synchronized+  -> Reset dom+  -- ^ 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' 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. 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:+--+-- @+-- expectedOutput+--   :: Clock dom -> Reset dom+--   -> 'Signal' dom Int -> 'Signal' dom Bool+-- expectedOutput clk rst = 'outputVerifier' clk rst $('Clash.Sized.Vector.listToVecTH' ([70,99,2,3,4,5,7,8,9,10]::[Int]))+-- @+--+-- >>> import qualified Data.List as List+-- >>> sampleN 12 (expectedOutput systemClockGen resetGen (fromList (0:[0..10] List.++ [10,10,10])))+-- <BLANKLINE>+-- cycle(<Clock: System>): 0, outputVerifier+-- expected value: 70, not equal to actual value: 0+-- [False+-- 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(<Clock: System>): 7, outputVerifier+-- expected value: 7, not equal to actual value: 6+-- ,False+-- cycle(<Clock: System>): 8, outputVerifier+-- expected value: 8, not equal to actual value: 7+-- ,False+-- cycle(<Clock: System>): 9, outputVerifier+-- expected value: 9, not equal to actual value: 8+-- ,False+-- cycle(<Clock: System>): 10, outputVerifier+-- expected value: 10, not equal to actual value: 9+-- ,False,True]+--+-- 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+     , Eq a+     , ShowX a+     , 1 <= l+     )+  => 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+outputVerifier =+  outputVerifierWith (\clk rst -> assert clk rst "outputVerifier")+{-# INLINE outputVerifier #-}++-- | 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+     , 1 <= l+     )+  => Clock dom+  -- ^ Clock to which the input signal is synchronized+  -> Reset dom+  -> Vec l (BitVector n)+  -- ^ Samples to compare with+  -> Signal dom (BitVector n)+  -- ^ Signal to verify+  -> Signal dom Bool+  -- ^ Indicator that all samples are verified+outputVerifierBitVector' clk =+  outputVerifierBitVector @l @n clk clk+{-# INLINE outputVerifierBitVector' #-}++-- | Same as 'outputVerifier', but can handle don't care bits in its+-- expected values.+outputVerifierBitVector+  :: forall l n testDom circuitDom+   . ( KnownNat l+     , KnownNat n+     , KnownDomain testDom+     , KnownDomain circuitDom+     , 1 <= l+     )+  => 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 (BitVector n)+  -- ^ Samples to compare with+  -> Signal circuitDom (BitVector n)+  -- ^ Signal to verify+  -> Signal testDom Bool+  -- ^ Indicator that all samples are verified+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 clkTest rst en 0 s)+        (e,f) = unbundle o+        f'    = register clkTest rst en False f+        -- Only assert while not finished+    in  mux f' f' $ assertF clkTest rst i1 e f'+  where+    genT :: Index l -> (Index l,(a,Bool))+    genT s = (s',(samples !! s,finished))+      where+        s' = satSucc SatBound s+        finished = s == maxBound+{-# INLINABLE outputVerifierWith #-}++-- | Ignore signal for a number of cycles, while outputting a static value.+ignoreFor+  :: forall dom  n a+   . KnownDomain dom+  => Clock dom+  -> Reset dom+  -> Enable dom+  -> SNat n+  -- ^ Number of cycles to ignore incoming signal+  -> a+  -- ^ Value function produces when ignoring signal+  -> Signal dom a+  -- ^ Incoming signal+  -> Signal dom a+  -- ^ Either a passthrough of the incoming signal, or the static value+  -- provided as the second argument.+ignoreFor clk rst en SNat a i =+  mux ((==) <$> counter <*> (pure maxBound)) i (pure a)+ where+  counter :: Signal dom (Index (n+1))+  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 test circuit potentially operates+-- on a different clock than the device under test.+biTbClockGen+  :: forall testDom circuitDom+   . ( KnownDomain testDom+     , KnownDomain circuitDom+     )+  => Signal testDom Bool+  -> (Clock testDom, Clock circuitDom)+biTbClockGen done = (testClk, circuitClk)+ where+  testClk = tbClockGen done+  circuitClk = tbClockGen (unsafeSynchronizer testClk circuitClk done)++-- | 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)+{-# OPAQUE tbEnableGen #-}+{-# ANN tbEnableGen hasBlackBox #-}++-- | Clock generator for the 'System' clock domain.+--+-- __NB__: Can be used in the /testBench/ function+--+-- === __Example__+--+-- @+-- 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+-- @+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
@@ -0,0 +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 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, (&&), (||), not)+where++import Prelude hiding+  ((++), (!!), 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
@@ -0,0 +1,96 @@+{-|+Copyright  :  (C) 2018     , QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++Hidden arguments+-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++{-# LANGUAGE Trustworthy #-}++module Clash.Hidden+  ( Hidden+  , expose+  -- * OverloadedLabels+  , fromLabel+  )+where++import qualified GHC.Classes+import GHC.TypeLits+import Unsafe.Coerce++-- | A value reflected to, or /hiding/ at, the /Constraint/ level+--+-- e.g. a function:+--+-- @+-- f :: Hidden "foo" Int+--   => Bool+--   -> Int+-- f = ...+-- @+--+-- has a /normal/ argument of type @Bool@, and a /hidden/ argument called \"foo\"+-- of type @Int@. In order to apply the @Int@ argument we have to use the+-- 'expose' function, so that the /hidden/ argument becomes a normal argument+-- again.+--+-- === __Original implementation__+--+-- 'Hidden' used to be implemented by:+--+-- @+-- class Hidden (x :: Symbol) a | x -> a where+--   hidden :: a+-- @+--+-- which is equivalent to /IP/, except that /IP/ has magic inference rules+-- bestowed by GHC so that there's never any ambiguity. We need these magic+-- inference rules so we don't end up in type inference absurdity where asking+-- for the type of an type-annotated value results in a /no-instance-in-scope/+-- error.+type Hidden (x :: Symbol) a = GHC.Classes.IP x a++newtype Secret x a r = Secret (Hidden x a => r)++-- | Expose a 'Hidden' argument so that it can be applied normally, e.g.+--+-- @+-- f :: Hidden "foo" Int+--   => Bool+--   -> Int+-- f = ...+--+-- g :: Int -> Bool -> Int+-- g = 'expose' \@\"foo" f+-- @+expose+  :: forall x a r+   . (Hidden x a => r)+  -- ^ Function with a 'Hidden' argument+  -> (a -> r)+  -- ^ Function with the 'Hidden' argument exposed+expose k = unsafeCoerce (Secret @x @a @r k)+{-# INLINE expose #-}++-- | Using /-XOverloadedLabels/ and /-XRebindableSyntax/, we can turn any+-- value into a /hidden/ argument using the @#foo@ notation, e.g.:+--+-- @+-- f :: Int -> Bool -> Int+-- f = ...+--+-- g :: Hidden "foo" Bool+--   => Int -> Int+-- g i = f i #foo+-- @+fromLabel :: forall x a . Hidden x a => a+fromLabel = GHC.Classes.ip @x+{-# INLINE fromLabel #-}
+ src/Clash/Intel/ClockGen.hs view
@@ -0,0 +1,389 @@+{-|+Copyright  :  (C) 2017-2018, Google Inc+                  2019     , Myrtle Software+                  2022-2026, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++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 CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module Clash.Intel.ClockGen+  ( -- * 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 GHC.TypeLits (type (<=))++import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Clocks+  (Clocks(..), ClocksSync(..), ClocksSyncCxt, NumOutClocksSync)+import Clash.Signal.Internal+  (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.++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.+--+-- 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.+--+-- 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++-- | 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.+--+-- __NB__: Because the clock generator reacts asynchronously to the incoming+-- reset input, the signal __must__ be glitch-free.+--+-- 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.+--+-- 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.+--+-- 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.+--+-- __NB__: Because the clock generator reacts asynchronously to the incoming+-- reset input, the signal __must__ be glitch-free.+--+-- 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
@@ -0,0 +1,139 @@+{-|+Copyright  :  (C) 2017, Google Inc+                  2019, Myrtle Software Ltd+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++DDR primitives for Intel FPGAs using ALTDDIO primitives.++For general information about DDR primitives see "Clash.Explicit.DDR".++Note that a reset is only available on certain devices,+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 FlexibleContexts #-}+{-# 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)+import Clash.Explicit.Prelude+import Clash.Explicit.DDR++-- | 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+  :: 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 dom+  -> Reset dom+  -> Enable dom+  -> Signal domDDR a+  -- ^ DDR input signal+  -> 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+  :: 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 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 =+  fmap unpack . uncurry (withFrozenCallStack altddioOut# devFam clk rst en) .+    unbundle . fmap (bimap pack pack)++altddioOut#+  :: 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 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
@@ -0,0 +1,305 @@+{-|+  Copyright   :  (C) 2019-2023, Myrtle Software Ltd+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++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 CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE Trustworthy #-}++module Clash.Magic+  (+  -- ** Functions to control names of identifiers in HDL+    prefixName+  , suffixName+  , suffixNameP+  , suffixNameFromNat+  , suffixNameFromNatP+  , setName+  , nameHint++  -- ** 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+{-# OPAQUE prefixName #-}++-- | Suffix instance and register names with the given 'Symbol'+suffixName+  :: forall (name :: Symbol) a . a -> name ::: a+suffixName = id+{-# 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+-- 'setName' and instances and registers that are auto-named.+setName+  :: forall (name :: Symbol) a . a -> name ::: a+setName = id+{-# 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
@@ -0,0 +1,66 @@+{- |+Copyright  :  (C) 2017, Myrtle Software Ltd, QBayLogic, Google Inc.+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++Add inline documentation to types:++@+fifo+  :: Clock dom+  -> Reset dom+  -> SNat addrSize+  -> "read request" ::: Signal dom Bool+  -> "write request" ::: Signal dom (Maybe (BitVector dataSize))+  -> ( "q"     ::: Signal dom (BitVector dataSize)+     , "full"  ::: Signal dom Bool+     , "empty" ::: Signal dom Bool+     )+@++which can subsequently be inspected in the interactive environment:++>>> import Clash.Explicit.Prelude+>>> :t fifo @System+fifo @System+  :: Clock System+     -> Reset System+     -> SNat addrSize+     -> ("read request" ::: Signal System Bool)+     -> ("write request" ::: Signal System (Maybe (BitVector dataSize)))+     -> ("q" ::: Signal System (BitVector dataSize),+         "full" ::: Signal System Bool, "empty" ::: Signal System Bool)++-}++{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++{-# LANGUAGE Safe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.NamedTypes+  ((:::))+where++type (name :: k) ::: a = a+-- ^ Annotate a type with a name++{- $setup+>>> :set -XDataKinds -XTypeOperators -XNoImplicitPrelude+>>> import Clash.Explicit.Prelude+>>> :{+let fifo+      :: Clock dom+      -> Reset dom+      -> SNat addrSize+      -> "read request" ::: Signal dom Bool+      -> "write request" ::: Signal dom (Maybe (BitVector dataSize))+      -> ( "q"     ::: Signal dom (BitVector dataSize)+         , "full"  ::: Signal dom Bool+         , "empty" ::: Signal dom Bool+         )+    fifo = Clash.Explicit.Prelude.undefined+:}++-}
+ 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
@@ -0,0 +1,287 @@+{-|+  Copyright   :  (C) 2013-2016, University of Twente,+                     2017-2019, Myrtle Software Ltd+                     2017     , Google Inc.,+                     2021-2025, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  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+  merits of using a functional language to describe hardware comes from the fact+  that combinational circuits can be directly modeled as mathematical functions+  and that functional languages lend themselves very well at describing and+  (de-)composing mathematical functions.++  This package provides:++  * Prelude library containing datatypes and functions for circuit design++  To use the library:++  * Import "Clash.Prelude"; by default clock and reset lines are implicitly+    routed for all the components found in "Clash.Prelude". You can read more+    about implicit clock and reset lines in "Clash.Signal#implicitclockandreset"+  * Alternatively, if you want to explicitly route clock and reset ports,+    for more straightforward multi-clock designs, you can import the+    "Clash.Explicit.Prelude" module. Note that you should not import+    "Clash.Prelude" and "Clash.Explicit.Prelude" at the same time as they+    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 at+  https://docs.clash-lang.org/tutorial. Some circuit examples can be found in+  "Clash.Examples".+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE NoImplicitPrelude #-}++{-# LANGUAGE Unsafe #-}++{-# OPTIONS_HADDOCK show-extensions, not-home #-}++module Clash.Prelude+  ( -- * Creating synchronous sequential circuits+    mealy+  , mealyS+  , mealyB+  , mealySB+  , (<^>)+  , moore+  , mooreB+  , registerB+    -- * ROMs+  , asyncRom+  , asyncRomPow2+  , rom+  , romPow2+    -- ** ROMs defined by a 'MemBlob'+  , asyncRomBlob+  , asyncRomBlobPow2+  , romBlob+  , romBlobPow2+    -- ** ROMs defined by a data file+  , asyncRomFile+  , asyncRomFilePow2+  , romFile+  , romFilePow2+    -- * RAM primitives with a combinational read port+  , asyncRam+  , asyncRamPow2+    -- * Block RAM primitives+  , blockRam+  , blockRamPow2+  , blockRamU+  , blockRam1+  , E.ResetStrategy(..)+    -- ** 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+    -- ** Block RAM read/write conflict resolution+  , readNew+    -- ** True dual-port block RAM+  , trueDualPortBlockRam+  , RamOp(..)+    -- * Utility functions+  , window+  , windowD+  , isRising+  , isFalling+  , riseEvery+  , oscillate+    -- * Tracing+    -- ** Simple+  , traceSignal1+  , traceVecSignal1+    -- ** Tracing in a multi-clock environment+  , traceSignal+  , traceVecSignal+    -- ** VCD dump functions+  , dumpVCD+    -- * Exported modules+    -- ** Synchronous signals+  , module Clash.Signal+  , module Clash.Signal.Delayed+    -- ** Datatypes+    -- *** Bit vectors+  , module Clash.Sized.BitVector+    -- *** Arbitrary-width numbers+  , module Clash.Sized.Signed+  , module Clash.Sized.Unsigned+  , module Clash.Sized.Index+    -- *** Fixed point numbers+  , module Clash.Sized.Fixed+    -- *** Fixed size vectors+  , module Clash.Sized.Vector+    -- *** Perfect depth trees+  , module Clash.Sized.RTree+    -- ** Annotations+  , module Clash.Annotations.TopEntity+    -- ** Generics type-classes+  , Generic+  , Generic1+    -- ** Type-level natural numbers+  , module GHC.TypeLits+  , module GHC.TypeLits.Extra+  , module Clash.Promoted.Nat+  , module Clash.Promoted.Nat.Literals+  , module Clash.Promoted.Nat.TH+    -- ** Type-level strings+  , module Clash.Promoted.Symbol+    -- ** 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+  , module Data.Kind+    -- ** Exceptions+  , module Clash.XException+    -- ** Named types+  , module Clash.NamedTypes+    -- ** Hidden arguments+  , module Clash.Hidden+    -- ** Magic+  , module Clash.Magic+    -- ** Haskell Prelude+    -- $hiding+  , module Clash.HaskellPrelude+  )+where++import           Control.Applicative+import           Data.Bits+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.BlockRam+import           Clash.Prelude.BlockRam.Blob+import           Clash.Prelude.BlockRam.File+import           Clash.Prelude.ROM.Blob+import           Clash.Prelude.ROM.File+import           Clash.Prelude.Safe+import           Clash.Promoted.Nat+import           Clash.Promoted.Nat.TH+import           Clash.Promoted.Nat.Literals+import           Clash.Promoted.Symbol+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 hiding (fromList, unsafeFromList)+import           Clash.Signal hiding+  (HiddenClockName, HiddenResetName, HiddenEnableName)+import           Clash.Signal.Delayed+import           Clash.Signal.Trace+import           Clash.XException++{- $setup+>>> :set -XDataKinds -XFlexibleContexts -XTypeApplications+>>> let window4  = window  :: HiddenClockResetEnable dom  => Signal dom Int -> Vec 4 (Signal dom Int)+>>> let windowD3 = windowD :: HiddenClockResetEnable dom  => Signal dom Int -> Vec 3 (Signal dom Int)+-}++{- $hiding+"Clash.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'+--+-- > window4 :: HiddenClockResetEnable dom+-- >         => Signal dom Int -> Vec 4 (Signal dom Int)+-- > window4 = window+--+-- >>> simulateB @System window4 [1::Int,2,3,4,5] :: [Vec 4 Int]+-- [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+     , KnownNat n+     , Default a+     , NFDataX a )+  => Signal dom a+  -- ^ Signal to create a window over+  -> Vec (n + 1) (Signal dom a)+  -- ^ Window of at least size 1+window = hideClockResetEnable E.window+{-# INLINE window #-}++-- | Give a delayed window over a 'Signal'+--+-- > windowD3+-- >   :: HiddenClockResetEnable dom+-- >   => Signal dom Int+-- >   -> Vec 3 (Signal dom Int)+-- > windowD3 = windowD+--+-- >>> simulateB @System windowD3 [1::Int,2,3,4] :: [Vec 3 Int]+-- [0 :> 0 :> 0 :> Nil,1 :> 0 :> 0 :> Nil,2 :> 1 :> 0 :> Nil,3 :> 2 :> 1 :> Nil,4 :> 3 :> 2 :> Nil,...+-- ...+windowD+  :: ( HiddenClockResetEnable dom+     , KnownNat n+     , Default a+     , NFDataX a )+  => Signal dom a+  -- ^ Signal to create a window over+  -> Vec (n + 1) (Signal dom a)+  -- ^ 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/BlockRam.hs view
@@ -0,0 +1,892 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2016-2019, Myrtle Software Ltd,+                  2017     , Google Inc.,+                  2021-2026, QBayLogic B.V.+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 '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 \#-\}++module CPU where++import Clash.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) 'Prelude.<$>' 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+  :: HiddenClockResetEnable dom+  => Signal dom MemAddr+  -- ^ Read address+  -> Signal dom (Maybe (MemAddr,Value))+  -- ^ (write address, data in)+  -> Signal dom Value+  -- ^ data out+dataMem 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 'Clash.Sized.Vector.!!' rd+      mem' =+        case wrM of+          Just (wr,din) -> 'Clash.Sized.Vector.replace' wr din mem+          _             -> mem+@++And then connect everything:++@+system+  :: ( KnownNat n+     , HiddenClockResetEnable dom+     )+  => Vec n Instruction+  -> Signal dom Value+system instrs = memOut+ 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:++@+-- 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 @System 32 (system prog)+[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+  :: ( KnownNat n+     , HiddenClockResetEnable dom  )+  => Vec n Instruction+  -> Signal dom Value+system2 instrs = memOut+ 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+'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)+[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 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 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)+     )+cpu2 (regbank,ldRegD) (memOut,instr) =+  ((regbank', ldRegD'), (rdAddr, (,aluOut) 'Prelude.<$>' 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+  :: (KnownNat n+     , HiddenClockResetEnable dom  )+  => Vec n Instruction+  -> Signal dom Value+system3 instrs = memOut+ 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 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:++@+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 @System 34 (system3 prog2)+[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 FlexibleContexts #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# LANGUAGE Safe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Prelude.BlockRam+  ( -- * BlockRAM synchronized to the system clock+    blockRam+  , blockRamPow2+  , blockRamU+  , blockRam1+  , E.ResetStrategy(..)+    -- ** Read/Write conflict resolution+  , readNew+    -- * True dual-port block RAM+    -- $tdpbram+  , trueDualPortBlockRam+  , E.RamOp(..)+  )+where++import           Prelude                 (Enum, Maybe, Eq)++import           GHC.TypeLits            (KnownNat, type (^))+import           GHC.Stack               (HasCallStack, withFrozenCallStack)++import qualified Clash.Explicit.BlockRam as E+import           Clash.Promoted.Nat      (SNat)+import           Clash.Signal+import           Clash.Sized.Index       (Index)+import           Clash.Sized.Unsigned    (Unsigned)+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+>>> :set -XDataKinds -XRecordWildCards -XTupleSections -XTypeApplications -XFlexibleContexts+>>> :set -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+      :: 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)+          where+            dout = mem C.!! rd+            mem' = case wrM of+                     Just (wr,din) -> replace wr din mem+                     Nothing       -> mem+:}++>>> :{+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+:}++>>> :{+-- 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+      :: ( 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 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+      :: ( 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+:}++>>> :{+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+-- '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+--   => 'Signal' dom ('Unsigned' 6)+--   -> 'Signal' dom (Maybe ('Unsigned' 6, 'Clash.Sized.BitVector.Bit'))+--   -> 'Signal' dom 'Clash.Sized.BitVector.Bit'+-- bram40 = 'blockRam' ('Clash.Sized.Vector.replicate' d40 1)+-- @+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+  --+  -- __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 = \cnt rd wrM -> withFrozenCallStack+  (hideEnable (hideClock E.blockRam) cnt rd wrM)+{-# INLINE blockRam #-}++-- | 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+     , 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+  -> 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 =+  \rstStrategy cnt rd wrM -> withFrozenCallStack+    (hideClockResetEnable E.blockRamU) rstStrategy cnt rd wrM+{-# INLINE blockRamU #-}++-- | 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+     , 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+  -- ^ 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 =+  \rstStrategy cnt initValue rd wrM -> withFrozenCallStack+    (hideClockResetEnable E.blockRam1) rstStrategy cnt initValue rd wrM+{-# INLINE blockRam1 #-}++-- | 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 '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+--   => 'Signal' dom ('Unsigned' 5)+--   -> 'Signal' dom (Maybe ('Unsigned' 5, 'Clash.Sized.BitVector.Bit'))+--   -> 'Signal' dom 'Clash.Sized.BitVector.Bit'+-- bram32 = 'blockRamPow2' ('Clash.Sized.Vector.replicate' d32 1)+-- @+blockRamPow2+  :: ( HasCallStack+     , HiddenClock dom+     , HiddenEnable dom+     , NFDataX a+     , KnownNat n+     )+  => 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 @blockRAM@ at address @r@ from the previous clock+  -- cycle+blockRamPow2 = \cnt rd wrM -> withFrozenCallStack+  (hideEnable (hideClock E.blockRamPow2) cnt rd wrM)+{-# INLINE blockRamPow2 #-}++{- | 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 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 = 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
@@ -0,0 +1,197 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente,+                  2019     , Myrtle Software Ltd,+                  2017     , Google Inc.,+                  2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++= Initializing a block RAM with a data file #usingramfiles#++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'++Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@.+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':++@+writeFile "memory.bin" (memFile Nothing [7 :: Unsigned 9 .. 13])+@++We can instantiate a block RAM using the contents of the file above like so:++@+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 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 (fromList [3..5])__+[10,11,12]+@++However, we can also interpret the same data as a tuple of a 6-bit unsigned+number, and a 3-bit signed number:++@+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:++@+__>>> import qualified Data.List as L__+__>>> L.tail $ sampleN 4 $ g (fromList [3..5])__+[(1,2),(1,3)(1,-4)]+@++-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}++{-# LANGUAGE Unsafe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Prelude.BlockRam.File+  ( -- * Block RAM synchronized to an arbitrary clock+    blockRamFile+  , blockRamFilePow2+    -- * Producing files+  , E.memFile+  )+where++import GHC.TypeLits                           (KnownNat)+import GHC.Stack                              (HasCallStack, withFrozenCallStack)+++import qualified Clash.Explicit.BlockRam.File as E+import           Clash.Promoted.Nat           (SNat)+import           Clash.Signal+  (HiddenClock, HiddenEnable, Signal, hideClock, hideEnable)+import           Clash.Sized.BitVector        (BitVector)+import           Clash.Sized.Unsigned         (Unsigned)+import           Clash.XException             (NFDataX)++-- | 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'+-- * __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      |+-- +----------------+----------+----------+---------------++--+-- === 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' ('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.+-- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your+-- own data files.+blockRamFilePow2+  :: forall dom  n m+   . ( KnownNat m+     , KnownNat n+     , HiddenClock dom+     , HiddenEnable dom+     , HasCallStack )+  => FilePath+  -- ^ 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 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 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'+-- * __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      |+-- +----------------+----------+----------+---------------++--+-- === 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' ('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.+-- * 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 BRAM+  -> FilePath+  -- ^ 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 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/Mealy.hs view
@@ -0,0 +1,254 @@+{-|+  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>++  Whereas the output of a Moore machine depends on the /previous state/, the+  output of a Mealy machine depends on /current transition/.++  Mealy machines are strictly more expressive, but may impose stricter timing+  requirements.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++{-# LANGUAGE Safe #-}++module Clash.Prelude.Mealy+  ( -- * Mealy machine synchronized to the system clock+    mealy+  , mealyS+  , mealyB+  , mealySB+  , (<^>)+  )+where++import qualified Clash.Explicit.Mealy as E+import           Clash.Signal+import           Clash.XException           (NFDataX)++import           Control.Monad.State.Strict (State)++{- $setup+>>> :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+        s' = x * y + s+    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+-- a mealy machine+--+-- @+-- macT+--   :: Int        -- Current state+--   -> (Int,Int)  -- Input+--   -> (Int,Int)  -- (Updated state, output)+-- macT s (x,y) = (s',s)+--   where+--     s' = x * y + s+--+-- mac :: HiddenClockResetEnable dom  => 'Signal' dom (Int, Int) -> 'Signal' dom Int+-- mac = 'mealy' macT 0+-- @+--+-- >>> simulate @System mac [(0,0),(1,1),(2,2),(3,3),(4,4)]+-- [0,0,1,5,14...+-- ...+--+-- Synchronous sequential functions can be composed just like their+-- combinational counterpart:+--+-- @+-- dualMac+--   :: HiddenClockResetEnable dom+--   => ('Signal' dom Int, 'Signal' dom Int)+--   -> ('Signal' dom Int, 'Signal' dom Int)+--   -> 'Signal' dom Int+-- dualMac (a,b) (x,y) = s1 + s2+--   where+--     s1 = 'mealy' macT 0 ('Clash.Signal.bundle' (a,x))+--     s2 = 'mealy' macT 0 ('Clash.Signal.bundle' (b,y))+-- @+mealy+  :: ( HiddenClockResetEnable dom+     , NFDataX s )+  => (s -> i -> (s,o))+  -- ^ Transfer function in mealy machine form: @state -> input -> (newstate,output)@+  -> s+  -- ^ Initial state+  -> (Signal dom i -> Signal dom o)+  -- ^ Synchronous sequential function with input and output matching that+  -- of the mealy machine+mealy = hideClockResetEnable E.mealy+{-# INLINE mealy #-}++-- | A version of 'mealy' that does automatic 'Bundle'ing+--+-- 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) = 'Clash.Signal.unbundle' ('mealy' f 0 ('Clash.Signal.bundle' (a,b)))+--     (i2,b2) = 'Clash.Signal.unbundle' ('mealy' f 3 ('Clash.Signal.bundle' (c,i1)))+-- @+--+-- Using 'mealyB' however we can write:+--+-- @+-- g a b c = (b1,b2,i2)+--   where+--     (i1,b1) = 'mealyB' f 0 (a,b)+--     (i2,b2) = 'mealyB' f 3 (c,i1)+-- @+mealyB+  :: ( HiddenClockResetEnable dom+     , NFDataX s+     , Bundle i+     , Bundle o )+  => (s -> i -> (s,o))+  -- ^ Transfer function in mealy machine form: @state -> input -> (newstate,output)@+  -> s+  -- ^ Initial state+  -> (Unbundled dom i -> Unbundled dom o)+  -- ^ Synchronous sequential function with input and output matching that+  -- 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'+(<^>)+  :: ( HiddenClockResetEnable dom+     , NFDataX s+     , Bundle i+     , Bundle o )+  => (s -> i -> (s,o))+  -- ^ Transfer function in mealy machine form: @state -> input -> (newstate,output)@+  -> s+  -- ^ Initial state+ -> (Unbundled dom i -> Unbundled dom o)+ -- ^ Synchronous sequential function with input and output matching that+ -- of the mealy machine+(<^>) = mealyB+{-# INLINE (<^>) #-}
+ src/Clash/Prelude/Moore.hs view
@@ -0,0 +1,162 @@+{-|+  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>++  Whereas the output of a Mealy machine depends on /current transition/, the+  output of a Moore machine depends on the /previous state/.++  Moore machines are strictly less expressive, but may impose laxer timing+  requirements.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++{-# LANGUAGE Safe #-}++module Clash.Prelude.Moore+  ( -- * Moore machine+    moore+  , mooreB+  , medvedev+  , medvedevB+  )+where++import qualified Clash.Explicit.Moore as E+import           Clash.Signal+import           Clash.XException                     (NFDataX)++{- $setup+>>> :set -XDataKinds -XTypeApplications+>>> :m -Clash.Explicit.Prelude+>>> :m -Clash.Explicit.Prelude.Safe+>>> import Clash.Prelude+>>> :{+let macT s (x,y) = x * y + s+    mac = moore macT id 0+:}++-}+++-- | Create a synchronous function from a combinational function describing+-- a moore machine+--+-- @+-- macT+--   :: Int        -- Current state+--   -> (Int,Int)  -- Input+--   -> Int        -- Updated state+-- macT s (x,y) = x * y + s+--+-- mac+--   :: HiddenClockResetEnable dom+--   => 'Signal' dom (Int, Int)+--   -> 'Signal' dom Int+-- mac = 'moore' mac id 0+-- @+--+-- >>> simulate @System mac [(0,0),(1,1),(2,2),(3,3),(4,4)]+-- [0,0,1,5,14,30,...+-- ...+--+-- Synchronous sequential functions can be composed just like their+-- combinational counterpart:+--+-- @+-- dualMac+--   :: HiddenClockResetEnable dom+--   => ('Signal' dom Int, 'Signal' dom Int)+--   -> ('Signal' dom Int, 'Signal' dom Int)+--   -> 'Signal' dom Int+-- dualMac (a,b) (x,y) = s1 + s2+--   where+--     s1 = 'moore' macT id 0 ('Clash.Signal.bundle' (a,x))+--     s2 = 'moore' macT id 0 ('Clash.Signal.bundle' (b,y))+-- @+moore+  :: ( HiddenClockResetEnable dom+     , NFDataX s )+  => (s -> i -> s)+  -- ^ Transfer function in moore machine form: @state -> input -> newstate@+  -> (s -> o)+  -- ^ Output function in moore machine form: @state -> output@+  -> s+  -- ^ Initial state+  -> (Signal dom i -> Signal dom o)+  -- ^ Synchronous sequential function with input and output matching that+  -- of the moore machine+moore = hideClockResetEnable E.moore+{-# INLINE moore #-}+++-- | Create a synchronous function from a combinational function describing+-- a moore machine without any output logic+medvedev+  :: ( HiddenClockResetEnable dom+     , NFDataX s )+  => (s -> i -> s)+  -> s+  -> (Signal dom i -> Signal dom s)+medvedev tr st = moore tr id st+{-# INLINE medvedev #-}++-- | A version of 'moore' that does automatic 'Bundle'ing+--+-- Given a functions @t@ and @o@ of types:+--+-- @+-- __t__ :: Int -> (Bool, Int) -> Int+-- __o__ :: Int -> (Int, Bool)+-- @+--+-- When we want to make compositions of @t@ and @o@ in @g@ using 'moore', we have to+-- write:+--+-- @+-- g a b c = (b1,b2,i2)+--   where+--     (i1,b1) = 'Clash.Signal.unbundle' ('moore' t o 0 ('Clash.Signal.bundle' (a,b)))+--     (i2,b2) = 'Clash.Signal.unbundle' ('moore' t o 3 ('Clash.Signal.bundle' (c,i1)))+-- @+--+-- Using 'mooreB' however we can write:+--+-- @+-- g a b c = (b1,b2,i2)+--   where+--     (i1,b1) = 'mooreB' t o 0 (a,b)+--     (i2,b2) = 'mooreB' t o 3 (c,i1)+-- @+mooreB+  :: ( HiddenClockResetEnable dom+     , NFDataX s+     , Bundle i+     , Bundle o )+  => (s -> i -> s)+  -- ^ Transfer function in moore machine form: @state -> input -> newstate@+  -> (s -> o)+  -- ^ Output function in moore machine form: @state -> output@+  -> s+  -- ^ Initial state+  -> (Unbundled dom i -> Unbundled dom o)+   -- ^ Synchronous sequential function with input and output matching that+   -- of the moore machine+mooreB = hideClockResetEnable E.mooreB+{-# INLINE mooreB #-}++-- | A version of 'medvedev' that does automatic 'Bundle'ing+medvedevB+  :: ( HiddenClockResetEnable dom+     , NFDataX s+     , Bundle i+     , Bundle s )+  => (s -> i -> s)+  -> s+  -> (Unbundled dom i -> Unbundled dom s)+medvedevB tr st = mooreB tr id st+{-# INLINE medvedevB #-}
+ src/Clash/Prelude/RAM.hs view
@@ -0,0 +1,91 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente,+                  2017-2019, Myrtle Software Ltd+                  2017     , Google Inc.,+                  2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++RAM primitives with a combinational read port+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++{-# LANGUAGE Safe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Prelude.RAM+  ( -- * RAM synchronized to an arbitrary clock+    asyncRam+  , asyncRamPow2+  )+where++import           GHC.TypeLits         (KnownNat)+import           GHC.Stack            (HasCallStack, withFrozenCallStack)++import qualified Clash.Explicit.RAM   as E+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+--+-- * __NB__: Initial content of the RAM 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+-- RAM.+asyncRam+  :: ( Enum addr+     , NFDataX addr+     , HiddenClock dom+     , HiddenEnable dom+     , HasCallStack+     , NFDataX a+     )+  => SNat n+  -- ^ Size @n@ of the RAM+  -> 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@+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/, reading it will throw an+-- 'Clash.XException.XException'+--+-- === See also:+--+-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a+-- RAM.+asyncRamPow2+  :: ( KnownNat n+     , HiddenClock dom+     , HiddenEnable dom+     , 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@+asyncRamPow2 = \rd wrM -> withFrozenCallStack+  (hideEnable (\en -> (hideClock (\clk -> E.asyncRamPow2 clk clk en rd wrM))))+{-# INLINE asyncRamPow2 #-}
+ src/Clash/Prelude/ROM.hs view
@@ -0,0 +1,188 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente,+                  2017     , Google Inc.+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++ROMs+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Prelude.ROM+  ( -- * Asynchronous ROM+    asyncRom+  , asyncRomPow2+    -- * Synchronous ROM synchronized to an arbitrary clock+  , rom+  , romPow2+    -- * Internal+  , asyncRom#+  )+where++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, 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.+-- * 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+     , NFDataX a+     )+  => Vec n a+  -- ^ ROM content, also determines the size, @n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> addr+  -- ^ Read address @r@+  -> a+  -- ^ 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+--+-- === See also:+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Prelude.BlockRam#usingrams"+-- 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+     , NFDataX a+     )+  => Vec (2^n) a+  -- ^ ROM content+  --+  -- __NB__: __MUST__ be a constant+  -> Unsigned n+  -- ^ Read address @r@+  -> a+  -- ^ The value of the ROM at address @r@+asyncRomPow2 = asyncRom+{-# INLINE asyncRomPow2 #-}++-- | asyncRom primitive+asyncRom#+  :: forall n a+   . ( KnownNat n+     , NFDataX a+     )+  => Vec n a+  -- ^ ROM content, also determines the size, @n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Int+  -- ^ Read address @r@+  -> a+  -- ^ The value of the ROM at address @r@+asyncRom# content = safeAt+  where+    szI = length content+    arr = listArray (0,szI-1) (toList content)++    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/, reading it will throw an+-- 'Clash.XException.XException'+--+-- === See also:+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Prelude.BlockRam#usingrams"+-- 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+     , KnownNat n+     , KnownNat m+     , HiddenClock dom+     , HiddenEnable dom  )+  => Vec n a+  -- ^ ROM content, also determines the size, @n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom (Unsigned m)+  -- ^ Read address @r@+  -> Signal dom a+  -- ^ 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/, reading it will throw an+-- 'Clash.XException.XException'+--+-- === See also:+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Prelude.BlockRam#usingrams"+-- 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+     , NFDataX a+     , HiddenClock dom+     , HiddenEnable dom  )+  => Vec (2^n) a+  -- ^ ROM content+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom (Unsigned n)+  -- ^ Read address @r@+  -> Signal dom a+  -- ^ 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
@@ -0,0 +1,340 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente,+                  2017     , Google Inc.,+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+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'++Consecutive @LINE@s correspond to consecutive memory addresses starting at @0@.+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':++@+writeFile "memory.bin" (memFile Nothing [7 :: Unsigned 9 .. 13])+@++We can instantiate a synchronous ROM using the contents of the file above like+so:++@+f :: (HiddenClock dom, HiddenEnable dom)+   => Signal dom (Unsigned 3)+   -> Signal dom (Unsigned 9)+f rd = 'Clash.Class.BitPack.unpack' '<$>' 'romFile' d7 \"memory.bin\" rd+@++And see that it works as expected:++@+__>>> import qualified Data.List as L__+__>>> L.tail $ sampleN 4 $ f (fromList [3..5])__+[10,11,12]+@++However, we can also interpret the same data as a tuple of a 6-bit unsigned+number, and a 3-bit signed number:++@+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+@++And then we would see:++@+__>>> import qualified Data.List as L__+__>>> L.tail $ sampleN 4 $ g (fromList [3..5])__+[(1,2),(1,3)(1,-4)]+@+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++{-# LANGUAGE Unsafe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Prelude.ROM.File+  ( -- * Asynchronous ROM+    asyncRomFile+  , asyncRomFilePow2+    -- * Synchronous ROM synchronized to an arbitrary clock+  , romFile+  , romFilePow2+    -- * Producing files+  , memFile+    -- * Internal+  , asyncRomFile#+  )+where++import           Data.Array                   (listArray,(!))+import           GHC.TypeLits                 (KnownNat)+import           System.IO.Unsafe             (unsafePerformIO)++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+import           Clash.Sized.BitVector        (BitVector)+import           Clash.Sized.Unsigned         (Unsigned)++-- | An asynchronous/combinational ROM with space for @n@ elements+--+-- * __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      |+-- +----------------+----------+----------+---------------++--+-- === See also:+--+-- * See "Clash.Prelude.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.+-- * When you notice that 'asyncRomFile' is significantly slowing down your+-- simulation, give it a /monomorphic/ type signature. So instead of leaving+-- the type to be inferred:+--+--     @+--     myRomData = asyncRomFile d512 "memory.bin"+--     @+--+--     or giving it a /polymorphic/ type signature:+--+--     @+--     myRomData :: Enum addr => addr -> BitVector 16+--     myRomData = asyncRomFile d512 "memory.bin"+--     @+--+--     you __should__ give it a /monomorphic/ type signature:+--+--     @+--     myRomData :: Unsigned 9 -> BitVector 16+--     myRomData = asyncRomFile d512 "memory.bin"+--     @+asyncRomFile+  :: (KnownNat m, Enum addr)+  => SNat n+  -- ^ Size of the ROM+  -> FilePath+  -- ^ File describing the content of the ROM+  -> addr+  -- ^ Read address @r@+  -> BitVector m+  -- ^ The value of the ROM at address @r@+asyncRomFile sz file = asyncRomFile# sz file . fromEnum+-- Leave 'asyncRomFile#' eta-reduced, see Note [Eta-reduction and unsafePerformIO initMem]+{-# INLINE asyncRomFile #-}++-- Note [Eta-reduction and unsafePerformIO initMem]+--+-- The 'initMem' function initializes a @[BitVector n]@ from file. Ideally,+-- we want this IO action to happen only once. When we call 'unsafePerformIO'+-- on @initMem file@, it becomes a thunk in that function, so is hence evaluated+-- only once. However, me must ensure that any code calling using of the+-- @unsafePerformIO (initMem file)@ thunk also becomes a thunk. We do this by+-- eta-reducing function where needed so that a thunk is returned.+--+-- For example, instead of writing:+--+-- > asyncRomFile# sz file rd = (content ! rd)+-- >   where+-- >     mem = unsafePerformIO (initMem file)+-- >     content = listArray (0,szI-1) mem+-- >     szI     = snatToNum sz+--+-- We write:+--+-- > asyncRomFile# sz file = (content !)+-- >   where+-- >     mem     = unsafePerformIO (initMem file)+-- >     content = listArray (0,szI-1) mem+-- >     szI     = snatToNum sz+--+-- Where instead of returning the BitVector defined by @(content ! rd)@, we+-- return the function (thunk) @(content !)@.++-- | An asynchronous/combinational ROM with space for 2^@n@ elements+--+-- * __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      |+-- +----------------+----------+----------+---------------++--+-- === See also:+--+-- * See "Clash.Prelude.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.+-- * When you notice that 'asyncRomFilePow2' is significantly slowing down your+-- simulation, give it a /monomorphic/ type signature. So instead of leaving the+-- type to be inferred:+--+--     @+--     myRomData = asyncRomFilePow2 "memory.bin"+--     @+--+--     you __should__ give it a /monomorphic/ type signature:+--+--     @+--     myRomData :: Unsigned 9 -> BitVector 16+--     myRomData = asyncRomFilePow2 "memory.bin"+--     @+asyncRomFilePow2+  :: forall n m+   . (KnownNat m, KnownNat n)+  => FilePath+  -- ^ File describing the content of the ROM+  -> Unsigned n+  -- ^ Read address @r@+  -> BitVector m+  -- ^ The value of the ROM at address @r@+asyncRomFilePow2 = asyncRomFile (pow2SNat (SNat @n))+{-# INLINE asyncRomFilePow2 #-}++-- | asyncRomFile primitive+asyncRomFile#+  :: KnownNat m+  => SNat n+  -- ^ Size of the ROM+  -> FilePath+  -- ^ File describing the content of the ROM+  -> Int+  -- ^ Read address @r@+  -> BitVector m+  -- ^ 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+{-# 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/, 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      |+-- +----------------+----------+----------+---------------++--+-- === See also:+--+-- * See "Clash.Prelude.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.+romFile+  :: ( KnownNat m+     , KnownNat n+     , HiddenClock dom+     , HiddenEnable dom+     , Enum addr+     )+  => SNat n+  -- ^ Size of the ROM+  -> FilePath+  -- ^ File describing the content of the ROM+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ 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/, 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      |+-- +----------------+----------+----------+---------------++--+-- === See also:+--+-- * See "Clash.Prelude.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.+romFilePow2+  :: forall n m dom+   . ( KnownNat m+     , KnownNat n+     , HiddenClock dom+     , HiddenEnable dom+     )+  => FilePath+  -- ^ File describing the content of the ROM+  -> Signal dom (Unsigned n)+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ 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
@@ -0,0 +1,289 @@+{-|+  Copyright   :  (C) 2013-2016, University of Twente,+                     2017-2019, Myrtle Software Ltd+                     2017     , Google Inc.,+                     2021-2022, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  __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+  merits of using a functional language to describe hardware comes from the fact+  that combinational circuits can be directly modeled as mathematical functions+  and that functional languages lend themselves very well at describing and+  (de-)composing mathematical functions.++  This package provides:++  * Prelude library containing datatypes and functions for circuit design++  To use the library:++  * Import "Clash.Prelude"+  * Additionally import "Clash.Explicit.Prelude" if you want to design+    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 at+  https://docs.clash-lang.org/tutorial. Some circuit examples can be found in+  "Clash.Examples".+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}++{-# LANGUAGE Safe #-}++{-# OPTIONS_HADDOCK show-extensions, not-home #-}++module Clash.Prelude.Safe+  ( -- * Creating synchronous sequential circuits+    mealy+  , mealyS+  , mealyB+  , mealySB+  , (<^>)+  , moore+  , mooreB+  , registerB+    -- * ROMs+  , asyncRom+  , 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+  , riseEvery+  , oscillate+    -- * Exported modules+    -- ** Synchronous signals+  , module Clash.Signal+  , module Clash.Signal.Delayed+    -- ** Datatypes+    -- *** Bit vectors+  , module Clash.Sized.BitVector+    -- *** Arbitrary-width numbers+  , module Clash.Sized.Signed+  , module Clash.Sized.Unsigned+  , module Clash.Sized.Index+    -- *** Fixed point numbers+  , module Clash.Sized.Fixed+    -- *** Fixed size vectors+  , module Clash.Sized.Vector+    -- *** Perfect depth trees+  , module Clash.Sized.RTree+    -- ** Annotations+  , module Clash.Annotations.TopEntity+    -- ** Generics type-classes+  , Generic+  , Generic1+    -- ** Type-level natural numbers+  , module GHC.TypeLits+  , module GHC.TypeLits.Extra+  , module Clash.Promoted.Nat+  , module Clash.Promoted.Nat.Literals+  , module Clash.Promoted.Nat.TH+    -- ** Type-level strings+  , module Clash.Promoted.Symbol+    -- ** Type classes+    -- *** Clash+  , module Clash.Class.BitPack+  , module Clash.Class.Num+  , module Clash.Class.Resize+    -- *** Other+  , module Control.Applicative+  , module Data.Bits+      -- ** Exceptions+  , module Clash.XException+    -- ** Named types+  , module Clash.NamedTypes+    -- ** Hidden arguments+  , module Clash.Hidden+    -- ** Haskell Prelude+    -- $hiding+  , module Clash.HaskellPrelude+  )+where++import           Control.Applicative+import           Data.Bits+import           GHC.Generics (Generic, Generic1)++import           GHC.TypeLits+  hiding (SNat, SSymbol, fromSNat)+import           GHC.TypeLits.Extra+import           Clash.HaskellPrelude++import           Clash.Annotations.TopEntity+import           Clash.Class.BitPack+import           Clash.Class.Num+import           Clash.Class.Resize+import           Clash.Hidden+import           Clash.NamedTypes+import           Clash.Prelude.BlockRam+import           Clash.Prelude.BlockRam.Blob+import qualified Clash.Explicit.Prelude.Safe as E+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.ROM.Blob+import           Clash.Promoted.Nat+import           Clash.Promoted.Nat.TH+import           Clash.Promoted.Nat.Literals+import           Clash.Promoted.Symbol+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 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.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)')+--+-- > rP :: HiddenClockResetEnable dom+-- >    => (Signal dom Int, Signal dom Int)+-- >    -> (Signal dom Int, Signal dom Int)+-- > rP = registerB (8,8)+--+-- >>> simulateB @System rP [(1,1),(2,2),(3,3)] :: [(Int,Int)]+-- [(8,8),(1,1),(2,2),(3,3)...+-- ...+registerB+  :: ( HiddenClockResetEnable dom+     , NFDataX a+     , Bundle a )+  => a+  -> Unbundled dom a+  -> Unbundled dom a+registerB = hideClockResetEnable E.registerB+infixr 3 `registerB`+{-# INLINE registerB #-}++-- | Give a pulse when the 'Signal' goes from 'minBound' to 'maxBound'+isRising+  :: ( HiddenClockResetEnable dom+     , NFDataX a+     , Bounded a+     , Eq a )+  => a+  -- ^ Starting value+  -> Signal dom a+  -> Signal dom Bool+isRising = hideClockResetEnable E.isRising+{-# INLINE isRising #-}++-- | Give a pulse when the 'Signal' goes from 'maxBound' to 'minBound'+isFalling+  :: ( HiddenClockResetEnable dom+     , NFDataX a+     , Bounded a+     , Eq a )+  => a+  -- ^ Starting value+  -> Signal dom a+  -> Signal dom Bool+isFalling = hideClockResetEnable E.isFalling+{-# INLINE isFalling #-}++-- | Give a pulse every @n@ clock cycles. This is a useful helper function when+-- combined with functions like @'Clash.Signal.regEn'@ or @'Clash.Signal.mux'@,+-- in order to delay a register by a known amount.+--+-- To be precise: the given signal will be @'False'@ for the next @n-1@ cycles,+-- followed by a single @'True'@ value:+--+-- >>> Prelude.last (sampleN @System 1025 (riseEvery d1024)) == True+-- True+-- >>> Prelude.or (sampleN @System 1024 (riseEvery d1024)) == False+-- True+--+-- For example, to update a counter once every 10 million cycles:+--+-- @+-- counter = 'Clash.Signal.regEn' 0 ('riseEvery' ('SNat' :: 'SNat' 10000000)) (counter + 1)+-- @+riseEvery+  :: HiddenClockResetEnable dom+  => SNat n+  -> Signal dom Bool+riseEvery = hideClockResetEnable E.riseEvery+{-# INLINE riseEvery #-}++-- | Oscillate a @'Bool'@ for a given number of cycles. This is a convenient+-- function when combined with something like @'regEn'@, as it allows you to+-- easily hold a register value for a given number of cycles. The input @'Bool'@+-- determines what the initial value is.+--+-- To oscillate on an interval of 5 cycles:+--+-- >>> sampleN @System 11 (oscillate False d5)+-- [False,False,False,False,False,False,True,True,True,True,True]+--+-- To oscillate between @'True'@ and @'False'@:+--+-- >>> sampleN @System 11 (oscillate False d1)+-- [False,False,True,False,True,False,True,False,True,False,True]+--+-- An alternative definition for the above could be:+--+-- >>> let osc' = register False (not <$> osc')+-- >>> sampleN @System 200 (oscillate False d1) == sampleN @System 200 osc'+-- True+oscillate+  :: HiddenClockResetEnable dom+  => Bool+  -> SNat n+  -> Signal dom Bool+oscillate = hideClockResetEnable E.oscillate+{-# INLINE oscillate #-}
+ src/Clash/Prelude/Testbench.hs view
@@ -0,0 +1,215 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2017     , Google Inc.+                  2019     , Myrtle Software Ltd,+                  2021-2023, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-# LANGUAGE Unsafe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Prelude.Testbench+  ( -- * Testbench functions for circuits+    assert+  , assertBitVector+  , ignoreFor+  , outputVerifier'+  , outputVerifierBitVector'+  , stimuliGenerator++  , E.tbClockGen+  , E.tbEnableGen+  , E.tbSystemClockGen+  , E.clockToDiffClock+  )+where++import GHC.TypeLits                       (KnownNat, type (<=))++import qualified Clash.Explicit.Testbench as E+import           Clash.Signal+  (HiddenClock, HiddenReset, HiddenClockResetEnable, Signal,+  hideClock, hideReset, hideClockResetEnable)+import Clash.Promoted.Nat                 (SNat)+import Clash.Sized.BitVector              (BitVector)+import Clash.Sized.Vector                 (Vec)+import Clash.XException                   (ShowX)++{- $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]))+-}++-- | Compares the first two 'Signal's for equality and logs a warning when they+-- are not equal. The second 'Signal' is considered the expected value. This+-- 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 )+  => String+  -- ^ Additional message+  -> Signal dom a+  -- ^ Checked value+  -> Signal dom a+  -- ^ Expected value+  -> Signal dom b+  -- ^ Return value+  -> Signal dom b+assert msg actual expected ret =+  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:+--+-- @+-- testInput+--   :: HiddenClockResetEnable dom+--   => 'Signal' dom Int+-- testInput = 'stimuliGenerator' $('Clash.Sized.Vector.listToVecTH' [(1::Int),3..21])+-- @+--+-- >>> sampleN @System 13 testInput+-- [1,1,3,5,7,9,11,13,15,17,19,21,21]+stimuliGenerator+  :: ( KnownNat l+     , HiddenClock dom+     , HiddenReset dom  )+  => Vec l a+  -- ^ Samples to generate+  -> Signal dom a+  -- ^ Signal of given samples+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:+--+-- @+-- expectedOutput+--   :: HiddenClockResetEnable dom+--   -> 'Signal' dom Int -> 'Signal' dom Bool+-- expectedOutput = 'outputVerifier'' $('Clash.Sized.Vector.listToVecTH' ([70,99,2,3,4,5,7,8,9,10]::[Int]))+-- @+--+-- >>> import qualified Data.List as List+-- >>> sampleN @System 12 (expectedOutput (fromList (0:[0..10] List.++ [10,10,10])))+-- <BLANKLINE>+-- cycle(<Clock: System>): 0, outputVerifier+-- expected value: 70, not equal to actual value: 0+-- [False+-- 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(<Clock: System>): 7, outputVerifier+-- expected value: 7, not equal to actual value: 6+-- ,False+-- cycle(<Clock: System>): 8, outputVerifier+-- expected value: 8, not equal to actual value: 7+-- ,False+-- cycle(<Clock: System>): 9, outputVerifier+-- expected value: 9, not equal to actual value: 8+-- ,False+-- cycle(<Clock: System>): 10, outputVerifier+-- expected value: 10, not equal to actual value: 9+-- ,False,True]+--+-- If you're working with 'BitVector's containing don't care bits you should use 'outputVerifierBitVector''.+outputVerifier'+  :: ( KnownNat l+     , Eq a+     , ShowX a+     , HiddenClock dom+     , HiddenReset dom+     , 1 <= l+     )+  => Vec l a+  -- ^ Samples to compare with+  -> Signal dom a+  -- ^ Signal to verify+  -> Signal dom Bool+  -- ^ Indicator that all samples are verified+outputVerifier' = hideReset (hideClock E.outputVerifier')+{-# INLINE outputVerifier' #-}+++-- | Same as 'outputVerifier'',+-- but can handle don't care bits in its expected values.+outputVerifierBitVector'+  :: ( KnownNat l+     , KnownNat n+     , HiddenClock dom+     , HiddenReset dom+     , 1 <= l+     )+  => Vec l (BitVector n)+  -- ^ Samples to compare with+  -> Signal dom (BitVector n)+  -- ^ Signal to verify+  -> Signal dom Bool+  -- ^ Indicator that all samples are verified+outputVerifierBitVector' = hideReset (hideClock E.outputVerifierBitVector')+{-# INLINE outputVerifierBitVector' #-}++-- | Ignore signal for a number of cycles, while outputting a static value.+ignoreFor+  :: HiddenClockResetEnable dom+  => SNat n+  -- ^ Number of cycles to ignore incoming signal+  -> a+  -- ^ Value function produces when ignoring signal+  -> Signal dom a+  -- ^ Incoming signal+  -> Signal dom a+  -- ^ Either a passthrough of the incoming signal, or the static value+  -- provided as the second argument.+ignoreFor = hideClockResetEnable E.ignoreFor+{-# INLINE ignoreFor #-}
+ src/Clash/Promoted/Nat.hs view
@@ -0,0 +1,569 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2016     , Myrtle Software Ltd+                  2022-2025, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Promoted.Nat+  ( -- * Singleton natural numbers+    -- ** Data type+    SNat (..)+    -- ** Construction+  , snatProxy+  , withSNat+    -- ** Conversion+  , snatToInteger, snatToNatural, snatToNum+    -- ** Conversion (ambiguous types)+  , natToInteger, natToNatural, natToNum+    -- ** Arithmetic+  , addSNat, mulSNat, powSNat, minSNat, maxSNat, succSNat+    -- *** Partial+  , subSNat, divSNat, modSNat, flogBaseSNat, clogBaseSNat, logBaseSNat, predSNat+    -- *** Specialised+  , pow2SNat+    -- *** Comparison+  , SNatLE (..), compareSNat+    -- * Unary/Peano-encoded natural numbers+    -- ** Data type+  , UNat (..)+    -- ** Construction+  , toUNat+    -- ** Conversion+  , fromUNat+    -- ** Arithmetic+  , addUNat, mulUNat, powUNat+    -- *** Partial+  , predUNat, subUNat+    -- * Base-2 encoded natural numbers+    -- ** Data type+  , BNat (..)+    -- ** Construction+  , toBNat+    -- ** Conversion+  , fromBNat+    -- ** Pretty printing base-2 encoded natural numbers+  , showBNat+    -- ** Arithmetic+  , succBNat, addBNat, mulBNat, powBNat+    -- *** Partial+  , predBNat, div2BNat, div2Sub1BNat, log2BNat+    -- ** Normalisation+  , stripZeros+    -- * Constraints on natural numbers+  , leToPlus+  , leToPlusKN+  )+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 (<=),+                           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 Clash.Annotations.Primitive (hasBlackBox)+import Clash.XException   (ShowX (..), showsPrecXWith)++{- $setup+>>> :set -XBinaryLiterals+>>> import Clash.Promoted.Nat.Literals (d789)+-}++-- | 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+--   'SNat' literals+data SNat (n :: Nat) where+  SNat :: KnownNat n => SNat n++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+  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+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+snatToNum p@SNat = fromInteger (snatToInteger p)+{-# INLINE snatToNum #-}++-- | Unary representation of a type-level natural+--+-- __NB__: Not synthesizable+data UNat :: Nat -> Type where+  UZero :: UNat 0+  USucc :: UNat n -> UNat (n + 1)++instance KnownNat n => Show (UNat n) where+  show x = 'u':show (natVal x)++instance KnownNat n => ShowX (UNat n) where+  showsPrecX = showsPrecXWith showsPrec++-- | Convert a singleton natural number to its unary representation+--+-- __NB__: Not synthesizable+toUNat :: forall n . SNat n -> UNat n+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+--+-- __NB__: Not synthesizable+fromUNat :: UNat n -> SNat n+fromUNat UZero     = SNat :: SNat 0+fromUNat (USucc x) = addSNat (fromUNat x) (SNat :: SNat 1)++-- | Add two unary-encoded natural numbers+--+-- __NB__: Not synthesizable+addUNat :: UNat n -> UNat m -> UNat (n + m)+addUNat UZero     y     = y+addUNat x         UZero = x+addUNat (USucc x) y     = USucc (addUNat x y)++-- | Multiply two unary-encoded natural numbers+--+-- __NB__: Not synthesizable+mulUNat :: UNat n -> UNat m -> UNat (n * m)+mulUNat UZero      _     = UZero+mulUNat _          UZero = UZero+mulUNat (USucc x) y      = addUNat y (mulUNat x y)++-- | Power of two unary-encoded natural numbers+--+-- __NB__: Not synthesizable+powUNat :: UNat n -> UNat m -> UNat (n ^ m)+powUNat _ UZero     = USucc UZero+powUNat x (USucc y) = mulUNat x (powUNat x y)++-- | Predecessor of a unary-encoded natural number+--+-- __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+--+-- __NB__: Not synthesizable+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)+predSNat SNat = SNat+{-# INLINE predSNat #-}++-- | Successor of a singleton natural number+succSNat :: SNat a -> SNat (a+1)+succSNat SNat = SNat+{-# INLINE succSNat #-}++-- | Add two singleton natural numbers+addSNat :: SNat a -> SNat b -> SNat (a+b)+addSNat SNat SNat = SNat+{-# INLINE addSNat #-}+infixl 6 `addSNat`++-- | Subtract two singleton natural numbers+subSNat :: SNat (a+b) -> SNat b -> SNat a+subSNat SNat SNat = SNat+{-# INLINE subSNat #-}+infixl 6 `subSNat`++-- | Multiply two singleton natural numbers+mulSNat :: SNat a -> SNat b -> SNat (a*b)+mulSNat SNat SNat = SNat+{-# INLINE mulSNat #-}+infixl 7 `mulSNat`++-- | Power of two singleton natural numbers+powSNat :: SNat a -> SNat b -> SNat (a^b)+powSNat SNat SNat = SNat+{-# OPAQUE powSNat #-}+{-# ANN powSNat hasBlackBox #-}+infixr 8 `powSNat`++-- | Division of two singleton natural numbers+divSNat :: (1 <= b) => SNat a -> SNat b -> SNat (Div a b)+divSNat SNat SNat = SNat+{-# INLINE divSNat #-}+infixl 7 `divSNat`++-- | Modulo of two singleton natural numbers+modSNat :: (1 <= b) => SNat a -> SNat b -> SNat (Mod a b)+modSNat SNat SNat = SNat+{-# INLINE modSNat #-}+infixl 7 `modSNat`++minSNat :: SNat a -> SNat b -> SNat (Min a b)+minSNat SNat SNat = SNat++maxSNat :: SNat a -> SNat b -> SNat (Max a b)+maxSNat SNat SNat = SNat++-- | Floor of the logarithm of a natural number+flogBaseSNat :: (2 <= base, 1 <= x)+             => SNat base -- ^ Base+             -> SNat x+             -> SNat (FLog base x)+flogBaseSNat SNat SNat = SNat+{-# OPAQUE flogBaseSNat #-}+{-# ANN flogBaseSNat hasBlackBox #-}++-- | Ceiling of the logarithm of a natural number+clogBaseSNat :: (2 <= base, 1 <= x)+             => SNat base -- ^ Base+             -> SNat x+             -> SNat (CLog base x)+clogBaseSNat SNat SNat = SNat+{-# OPAQUE clogBaseSNat #-}+{-# ANN clogBaseSNat hasBlackBox #-}++-- | Exact integer logarithm of a natural number+--+-- __NB__: Only works when the argument is a power of the base+logBaseSNat :: (FLog base x ~ CLog base x)+            => SNat base -- ^ Base+            -> SNat x+            -> SNat (Log base x)+logBaseSNat SNat SNat = SNat+{-# OPAQUE logBaseSNat #-}+{-# ANN logBaseSNat hasBlackBox #-}++-- | Power of two of a singleton natural number+pow2SNat :: SNat a -> SNat (2^a)+pow2SNat SNat = SNat+{-# INLINE pow2SNat #-}++-- | Ordering relation between two Nats+data SNatLE a b where+  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@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+--+--    * __NB__: The LSB is the left/outer-most constructor:+--    * __NB__: Not synthesizable+--+-- >>> B0 (B1 (B1 BT))+-- b6+--+-- == Constructors+--+-- * Starting/Terminating element:+--+--      @+--      __BT__ :: 'BNat' 0+--      @+--+-- * Append a zero (/0/):+--+--      @+--      __B0__ :: 'BNat' n -> 'BNat' (2 'GHC.TypeNats.*' n)+--      @+--+-- * Append a one (/1/):+--+--      @+--      __B1__ :: 'BNat' n -> 'BNat' ((2 'GHC.TypeNats.*' n) 'GHC.TypeNats.+' 1)+--      @+data BNat :: Nat -> Type where+  BT :: BNat 0+  B0 :: BNat n -> BNat (2*n)+  B1 :: BNat n -> BNat ((2*n) + 1)++instance KnownNat n => Show (BNat n) where+  show x = 'b':show (natVal x)++instance KnownNat n => ShowX (BNat n) where+  showsPrecX = showsPrecXWith showsPrec++-- | Show a base-2 encoded natural as a binary literal+--+-- __NB__: The LSB is shown as the right-most bit+--+-- >>> d789+-- d789+-- >>> toBNat d789+-- b789+-- >>> showBNat (toBNat d789)+-- "0b1100010101"+-- >>> 0b1100010101 :: Integer+-- 789+showBNat :: BNat n -> String+showBNat = go []+  where+    go :: String -> BNat m -> String+    go xs BT  = "0b" ++ xs+    go xs (B0 x) = go ('0':xs) x+    go xs (B1 x) = go ('1':xs) x++-- | Convert a singleton natural number to its base-2 representation+--+-- __NB__: Not synthesizable+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+--+-- __NB__: Not synthesizable+fromBNat :: BNat n -> SNat n+fromBNat BT     = SNat :: SNat 0+fromBNat (B0 x) = mulSNat (SNat :: SNat 2) (fromBNat x)+fromBNat (B1 x) = addSNat (mulSNat (SNat :: SNat 2) (fromBNat x))+                          (SNat :: SNat 1)++-- | Add two base-2 encoded natural numbers+--+-- __NB__: Not synthesizable+addBNat :: BNat n -> BNat m -> BNat (n+m)+addBNat (B0 a) (B0 b) = B0 (addBNat a b)+addBNat (B0 a) (B1 b) = B1 (addBNat a b)+addBNat (B1 a) (B0 b) = B1 (addBNat a b)+addBNat (B1 a) (B1 b) = B0 (succBNat (addBNat a b))+addBNat BT     b      = b+addBNat a      BT     = a++-- | Multiply two base-2 encoded natural numbers+--+-- __NB__: Not synthesizable+mulBNat :: BNat n -> BNat m -> BNat (n*m)+mulBNat BT      _  = BT+mulBNat _       BT = BT+mulBNat (B0 a)  b  = B0 (mulBNat a b)+mulBNat (B1 a)  b  = addBNat (B0 (mulBNat a b)) b++-- | Power of two base-2 encoded natural numbers+--+-- __NB__: Not synthesizable+powBNat :: BNat n -> BNat m -> BNat (n^m)+powBNat _  BT      = B1 BT+powBNat a  (B0 b)  = let z = powBNat a b+                     in  mulBNat z z+powBNat a  (B1 b)  = let z = powBNat a b+                     in  mulBNat a (mulBNat z z)++-- | Successor of a base-2 encoded natural number+--+-- __NB__: Not synthesizable+succBNat :: BNat n -> BNat (n+1)+succBNat BT     = B1 BT+succBNat (B0 a) = B1 a+succBNat (B1 a) = B0 (succBNat a)++-- | Predecessor of a base-2 encoded natural number+--+-- __NB__: Not synthesizable+predBNat :: (1 <= n) => BNat n -> BNat (n-1)+predBNat (B1 a) = case stripZeros a of+  BT -> BT+  a' -> B0 a'+predBNat (B0 x) = B1 (predBNat x)++-- | Divide a base-2 encoded natural number by 2+--+-- __NB__: Not synthesizable+div2BNat :: BNat (2*n) -> BNat n+div2BNat BT     = BT+div2BNat (B0 x) = x+div2BNat (B1 _) = error "div2BNat: impossible: 2*n ~ 2*n+1"++-- | Subtract 1 and divide a base-2 encoded natural number by 2+--+-- __NB__: Not synthesizable+div2Sub1BNat :: BNat (2*n+1) -> BNat n+div2Sub1BNat (B1 x) = x+div2Sub1BNat _      = error "div2Sub1BNat: impossible: 2*n+1 ~ 2*n"++-- | Get the log2 of a base-2 encoded natural number+--+-- __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"+log2BNat (B0 x) = succBNat (log2BNat x)++-- | Strip non-contributing zero's from a base-2 encoded natural number+--+-- >>> B1 (B0 (B0 (B0 BT)))+-- b1+-- >>> showBNat (B1 (B0 (B0 (B0 BT))))+-- "0b0001"+-- >>> showBNat (stripZeros (B1 (B0 (B0 (B0 BT)))))+-- "0b1"+-- >>> stripZeros (B1 (B0 (B0 (B0 BT))))+-- b1+--+-- __NB__: Not synthesizable+stripZeros :: BNat n -> BNat n+stripZeros BT      = BT+stripZeros (B1 x)  = B1 (stripZeros x)+stripZeros (B0 BT) = BT+stripZeros (B0 x)  = case stripZeros x of+  BT -> BT+  k  -> B0 k++-- | Change a function that has an argument with an @(n ~ (k + m))@ constraint to a+-- function with an argument that has an @(k <= n)@ constraint.+--+-- === __Examples__+--+-- Example 1+--+-- @+-- f :: Index (n+1) -> Index (n + 1) -> Bool+--+-- g :: forall n. (1 'GHC.TypeNats.<=' n) => Index n -> Index n -> Bool+-- g a b = 'leToPlus' \@1 \@n (f a b)+-- @+--+-- Example 2+--+-- @+-- head :: Vec (n + 1) a -> a+--+-- head' :: forall n a. (1 'GHC.TypeNats.<=' n) => Vec n a -> a+-- head' = 'leToPlus' \@1 \@n head+-- @+leToPlus+  :: forall (k :: Nat) (n :: Nat) r+   . ( k <= n+     )+  => (forall m . (n ~ (k + m)) => r)+  -- ^ Context with the @(n ~ (k + m))@ constraint+  -> r+leToPlus r = r @(n - k)+{-# INLINE leToPlus #-}++-- | Same as 'leToPlus' with added 'KnownNat' constraints+leToPlusKN+  :: forall (k :: Nat) (n :: Nat) r+   . ( k <= n+     , KnownNat k+     , KnownNat n+     )+  => (forall m . (n ~ (k + m), KnownNat m) => r)+  -- ^ Context with the @(n ~ (k + m))@ constraint+  -> r+leToPlusKN r = r @(n - k)+{-# INLINE leToPlusKN #-}
+ src/Clash/Promoted/Nat/Literals.hs view
@@ -0,0 +1,38 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++Predefined 'Clash.Promoted.Nat.SNat' singleton literals in the range [0 .. 1024]++Defines:++@+d0 = SNat :: SNat 0+d1 = SNat :: SNat 1+d2 = SNat :: SNat 2+...+d1024 = SNat :: SNat 1024+@++You can generate more 'Clash.Promoted.Nat.SNat' literals using 'decLiteralsD'+from "Clash.Promoted.Nat.TH"+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_HADDOCK show-extensions, prune #-}++module Clash.Promoted.Nat.Literals where++import Clash.Promoted.Nat.TH++#ifdef HADDOCK_ONLY+-- Don't pollute docs with 1024 SNat literals+$(decLiteralsD 0 9)+#else+$(decLiteralsD 0 1024)+#endif
+ src/Clash/Promoted/Nat/TH.hs view
@@ -0,0 +1,65 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE TemplateHaskell #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Promoted.Nat.TH+  ( -- * Declare a single @d\<N\>@ literal+    decLiteralD+    -- * Declare ranges of @d\<N\>@ literals+  , decLiteralsD+  )+where++import Language.Haskell.TH+import Clash.Promoted.Nat++{- $setup+>>> :set -XDataKinds+>>> :m -Prelude+>>> import Clash.Prelude+>>> let d1111 = SNat :: SNat 1111+>>> let d1200 = SNat :: SNat 1200+>>> let d1201 = SNat :: SNat 1201+>>> let d1202 = SNat :: SNat 1202+-}++-- | Create an 'SNat' literal+--+-- > $(decLiteralD 1111)+--+-- >>> :t d1111+-- d1111 :: SNat 1111+--+decLiteralD :: Integer+            -> Q [Dec]+decLiteralD n = do+  let suffix  = if n < 0 then error ("Can't make negative SNat: " ++ show n) else show n+      valName = mkName $ 'd':suffix+  sig   <- sigD valName (appT (conT ''SNat) (litT (numTyLit n)))+  val   <- valD (varP valName) (normalB [| SNat |]) []+  return [ sig, val ]++-- | Create a range of 'SNat' literals+--+-- > $(decLiteralsD 1200 1202)+--+-- >>> :t d1200+-- d1200 :: SNat 1200+-- >>> :t d1201+-- d1201 :: SNat 1201+-- >>> :t d1202+-- d1202 :: SNat 1202+--+decLiteralsD :: Integer+             -> Integer+             -> Q [Dec]+decLiteralsD from to =+    fmap concat $ sequence $ [ decLiteralD n | n <- [from..to] ]
+ src/Clash/Promoted/Nat/Unsafe.hs view
@@ -0,0 +1,25 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente+                  2022     , QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE Unsafe #-}++module Clash.Promoted.Nat.Unsafe+  (unsafeSNat)+where++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))+{-# OPAQUE unsafeSNat #-}+{-# ANN unsafeSNat hasBlackBox #-}
+ src/Clash/Promoted/Symbol.hs view
@@ -0,0 +1,55 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente+                  2022     , QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++-- Annotations are not allowed in safe Haskell+-- {-# LANGUAGE Safe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Promoted.Symbol+  (SSymbol (..), ssymbolProxy, ssymbolToString)+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+  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+-- /s/+ssymbolProxy :: KnownSymbol s => proxy s -> SSymbol s+ssymbolProxy _ = SSymbol++{-# INLINE ssymbolToString #-}+-- | Reify the type-level 'Symbol' @s@ to it's term-level 'String'+-- representation.+ssymbolToString :: SSymbol s -> String+ssymbolToString s@SSymbol = symbolVal s
+ src/Clash/Signal.hs view
@@ -0,0 +1,1753 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2016-2019, Myrtle Software Ltd,+                  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
@@ -0,0 +1,325 @@+{-|+Copyright  :  (C) 2017, Google Inc.+                  2019, Myrtle Software Ltd+                  2022-2024, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+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.+To cleanly map to functions (and thus support software simulation using Haskell),+a /BiSignal/ comes in two parts; the __in__ part:++@+'BiSignalIn' (ds :: 'BiSignalDefault') (dom :: 'Domain') (n :: Nat)+@++and the __out__ part:++@+'BiSignalOut' (ds :: 'BiSignalDefault') (dom :: 'Domain') (n :: Nat)+@++Where:++  * The internal representation is a 'BitVector'+  * /n/ indicates the number of bits in the 'BitVector'+  * /dom/ is the /clock-/ (and /reset-/) domain to which the memory elements+    manipulating these BiSignals belong.+  * 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,+while 'BiSignalOut' is only used for simulation purposes and generally discarded+by the compiler.++= Example++The following describes a system where two circuits, in alternating fashion,+read the current value from the /bus/, increment it, and write it on the next+cycle.++@+import Clash.Explicit.Prelude+import Clash.Signal.BiSignal++-- | Alternatingly read / increment+write+counter+  :: (Bool, Int)+  -- ^ Internal flip + previous read+  -> Int+  -- ^ Int from inout+  -> ((Bool, Int), Maybe Int)+counter (write, prevread) i = ((write', prevread'), output)+  where+    output    = if write then Just (succ prevread) else Nothing+    prevread' = if write then prevread else i+    write' = not write++-- | Write on odd cyles+f :: Clock System+  -> Reset System+  -> 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+  -> 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+topEntity+  :: Clock System+  -> Reset System+  -> Enable System+  -> Signal System Int+topEntity clk rst en = readFromBiSignal bus'+  where+    bus  = mergeBiSignalOuts $ f clk rst en bus' :> g clk rst en bus' :> Nil+    bus' = veryUnsafeToBiSignalIn bus+@+-}++{-# 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+  , veryUnsafeToBiSignalIn+  ) where++import           Data.Kind                  (Type)+import           Data.List                  (intercalate)+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, fromJustX, NFDataX)++import           GHC.TypeLits               (KnownNat, Nat)+import           GHC.Stack                  (HasCallStack)+import           Data.Reflection            (Given (..))++-- | 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+  | PullDown+  -- ^ __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).+  deriving (Show)++-- | Singleton versions of 'BiSignalDefault'+data SBiSignalDefault :: BiSignalDefault -> Type where+  SPullUp   :: SBiSignalDefault 'PullUp+  SPullDown :: SBiSignalDefault 'PullDown+  SFloating :: SBiSignalDefault 'Floating++instance Given (SBiSignalDefault 'PullUp) where+  given = SPullUp++instance Given (SBiSignalDefault 'PullDown) where+  given = SPullDown++instance Given (SBiSignalDefault 'Floating) where+  given = SFloating++-- | 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.+--+-- 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))]++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)++-- | Monoid instance to support concatenating+--+-- __NB__: Not synthesizable+instance Monoid (BiSignalOut defaultState dom n) where+  mempty = BiSignalOut []++-- /Lazily/ prepend a value to a 'BiSignalIn'.+--+-- Uses a /reified/ 'SBiSignalDefault', the 'Given' constraint, so we can fully+-- create 'BiSignalIn' "out of nowhere" when dealing with circular definitions.+prepend#+  :: Given (SBiSignalDefault ds)+  => Maybe (BitVector n)+  -> BiSignalIn ds d n+  -> BiSignalIn ds d n+prepend# a ~(BiSignalIn _ as) = BiSignalIn given (a :- as)++readFromBiSignal#+  :: ( HasCallStack+     , KnownNat n)+  => BiSignalIn ds d n+  -> Signal d (BitVector n)+readFromBiSignal# (BiSignalIn ds s) =+  case ds of+    SFloating -> fromMaybe (errorX " undefined value on BiSignalIn") <$> s+    SPullDown  -> fromMaybe minBound <$> s+    SPullUp    -> fromMaybe maxBound <$> s+{-# OPAQUE readFromBiSignal# #-}+{-# ANN readFromBiSignal# hasBlackBox #-}++-- | Read the value from an __inout__ port+readFromBiSignal+  :: ( HasCallStack+     , BitPack a)+  => BiSignalIn ds d (BitSize a)+  -- ^ A 'BiSignalIn' with a number of bits needed to represent /a/+  -> Signal d a+readFromBiSignal = fmap unpack . readFromBiSignal#++-- | Combine several __inout__ signals into one.+mergeBiSignalOuts+  :: ( HasCallStack+     , KnownNat n+     )+  => Vec n (BiSignalOut defaultState dom m)+  -> BiSignalOut defaultState dom m+mergeBiSignalOuts = mconcat . V.toList+{-# OPAQUE mergeBiSignalOuts #-}+{-# ANN mergeBiSignalOuts hasBlackBox #-}++writeToBiSignal#+  :: HasCallStack+  => BiSignalIn ds d n+  -> Signal d (Maybe (BitVector n))+  -> Signal d Bool+  -> Signal d (BitVector n)+  -> BiSignalOut ds d n+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, NFDataX a)+  => BiSignalIn ds d (BitSize a)+  -> Signal d (Maybe a)+  -- ^ Value to write+  --+  --   * /Just a/ writes an /a/ value+  --   * /Nothing/ puts the port in a /high-impedance/ state+  -> BiSignalOut ds d (BitSize a)+writeToBiSignal input writes =+  writeToBiSignal#+    input+    (fmap pack <$> writes)+    (isJust <$> writes)+    (pack . fromJustX <$> writes)+{-# INLINE writeToBiSignal #-}++-- | 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+  :: ( HasCallStack+     , KnownNat n+     , Given (SBiSignalDefault ds)+     )+  => BiSignalOut ds d n+  -> BiSignalIn ds d n+veryUnsafeToBiSignalIn (BiSignalOut signals) = prepend# result biSignalOut'+  where+    -- Enforce that only one component is writing+    result = case filter (isJust . head#) signals of+      []  -> Nothing+      [w] -> head# w+      _   -> errorX err++    err = unwords+      [ "Multiple components wrote to the BiSignal. This is undefined behavior"+      , "in hardware and almost certainly a logic error. The components wrote:\n"+      , intercalate "\n  " (map (show . head#) signals)+      ]++    -- Recursive step+    biSignalOut' = veryUnsafeToBiSignalIn $ BiSignalOut $ map tail# signals+{-# OPAQUE veryUnsafeToBiSignalIn #-}+{-# ANN veryUnsafeToBiSignalIn hasBlackBox #-}
+ src/Clash/Signal/Bundle.hs view
@@ -0,0 +1,216 @@+{-|+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 :  QBayLogic B.V. <devops@qbaylogic.com>++The Product/Signal isomorphism+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilyDependencies #-}++{-# 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)+import Clash.Sized.Fixed            (Fixed)+import Clash.Sized.Index            (Index)+import Clash.Sized.Signed           (Signed)+import Clash.Sized.Unsigned         (Unsigned)+import Clash.Sized.Vector           (Vec, traverse#, lazyV)+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.+--+-- Instances of 'Bundle' must satisfy the following laws:+--+-- @+-- 'bundle' . 'unbundle' = 'id'+-- 'unbundle' . 'bundle' = 'id'+-- @+--+-- By default, 'bundle' and 'unbundle', are defined as the identity, that is,+-- writing:+--+-- @+-- data D = A | B+--+-- instance Bundle D+-- @+--+-- is the same as:+--+-- @+-- data D = A | B+--+-- instance Bundle D where+--   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+  -- | Example:+  --+  -- @+  -- __bundle__ :: ('Signal' dom a, 'Signal' dom b) -> 'Signal' dom (a,b)+  -- @+  --+  -- However:+  --+  -- @+  -- __bundle__ :: 'Signal' dom 'Clash.Sized.BitVector.Bit' -> 'Signal' dom 'Clash.Sized.BitVector.Bit'+  -- @+  bundle :: Unbundled dom a -> Signal dom a++  {-# INLINE bundle #-}+  default bundle :: (Signal dom a ~ Unbundled dom a)+                 => Unbundled dom a -> Signal dom a+  bundle s = s+  -- | Example:+  --+  -- @+  -- __unbundle__ :: 'Signal' dom (a,b) -> ('Signal' dom a, 'Signal' dom b)+  -- @+  --+  -- However:+  --+  -- @+  -- __unbundle__ :: 'Signal' dom 'Clash.Sized.BitVector.Bit' -> 'Signal' dom 'Clash.Sized.BitVector.Bit'+  -- @+  unbundle :: Signal dom a -> Unbundled dom a++  {-# INLINE unbundle #-}+  default unbundle :: (Unbundled dom a ~ Signal dom a)+                   => Signal dom a -> Unbundled dom a+  unbundle s = s++instance Bundle ()+instance Bundle Bool+instance Bundle Integer+instance Bundle Int+instance Bundle Float+instance Bundle Double+instance Bundle (Maybe a)+instance Bundle (Either a b)++instance Bundle Bit+instance Bundle (BitVector n)+instance Bundle (Index n)+instance Bundle (Fixed rep int frac)+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+  type Unbundled t (Vec n a) = Vec n (Signal t a)+  -- The 'Traversable' instance of 'Vec' is not synthesizable, so we must+  -- define 'bundle' as a primitive.+  bundle   = vecBundle#+  unbundle = sequenceA . fmap lazyV++{-# OPAQUE vecBundle# #-}+{-# ANN vecBundle# hasBlackBox #-}+vecBundle# :: Vec n (Signal t a) -> Signal t (Vec n a)+vecBundle# = traverse# id++instance KnownNat d => Bundle (RTree d a) where+  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
@@ -0,0 +1,170 @@+{-|+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 (deriveBundleTuples, idPrimitive) where++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+  -- ^ Bundle+  -> Name+  -- ^ Unbundled+  -> Name+  -- ^ bundle+  -> Name+  -- ^ unbundle+  -> DecsQ+deriveBundleTuples bundleTyName unbundledTyName bundleName unbundleName = do+  let bundleTy = ConT bundleTyName+      signal   = ConT ''Signal++      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"++  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 $ mkTupleT vars++        -- Associated type Unbundled+        unbundledTypeEq =+          TySynEqn Nothing+            ((ConT unbundledTyName `AppT`+                VarT tNm ) `AppT` mkTupleT vars )+            $ mkTupleT $ map (AppT (signal `AppT` VarT tNm)) vars+        unbundledType = TySynInstD unbundledTypeEq++        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+            unbundlePrimName+            [Clause+              [AsP sNm (TildeP (UInfixP+                                 (AsP tNm (TildeP (TupP (map VarP aNames))))+                                 '(:-)+                                 (VarP sTailNm)))]+              (NormalB unbundleFBody)+              [] ]++        -- bundle2# (a1, a2) = (\ a1' a2' -> (a1', a2')) <$> a1 <*> a2+        bundleNoInlineAnn = PragmaD (InlineP bundlePrimName NoInline FunLike AllPhases)++        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+            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]++             -- 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
@@ -0,0 +1,213 @@+{-|+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 FlexibleContexts #-}+{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE Safe #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}++module Clash.Signal.Delayed+  ( -- * Delay-annotated synchronous signals+    DSignal+  , delayed+  , delayedI+  , delayN+  , delayI+  , delayedFold+  , feedback+    -- * Signal \<-\> DSignal conversion+  , fromSignal+  , toSignal+    -- * List \<-\> DSignal conversion (not synthesizable)+  , dfromList+    -- ** lazy versions+  , dfromList_lazy+    -- * Experimental+  , unsafeFromSignal+  , antiDelay+  , forward+  )+where++import           GHC.TypeLits+  (KnownNat, type (^), type (+), type (*))++import Clash.Signal.Delayed.Internal+  (DSignal(..), dfromList, dfromList_lazy, fromSignal, toSignal,+   unsafeFromSignal, antiDelay, feedback, forward)+import qualified Clash.Explicit.Signal.Delayed as E+import           Clash.Sized.Vector+import           Clash.Signal+  (HiddenClock, HiddenClockResetEnable, HiddenEnable, hideClock,+   hideClockResetEnable, hideEnable)++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 :: (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)+-}++-- | Delay a 'DSignal' for @d@ periods.+--+-- @+-- delay3+--   :: HiddenClockResetEnable dom+--   => 'DSignal' dom n Int+--   -> 'DSignal' dom (n + 3) Int+-- delay3 = 'delayed' (-1 ':>' -1 ':>' -1 ':>' 'Nil')+-- @+--+-- >>> sampleN @System 7 (toSignal (delay3 (dfromList [0..])))+-- [-1,-1,-1,-1,1,2,3]+delayed+  :: ( KnownNat d+     , HiddenClockResetEnable dom+     , NFDataX a+     )+  => Vec d a+  -> DSignal dom n a+  -> 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++-}+delayedI+  :: ( KnownNat d+     , NFDataX a+     , HiddenClockResetEnable dom  )+  => a+  -- ^ Initial value+  -> DSignal dom n a+  -> DSignal dom (n + d) a+delayedI = hideClockResetEnable E.delayedI++-- | Delay a 'DSignal' for @d@ cycles, the value at time 0..d-1 is /a/.+--+-- @+-- delayN2+--   :: ( HiddenClock dom+--      , HiddenEnable dom )+--   => Int+--   -> 'DSignal' dom n Int+--   -> 'DSignal' dom (n + 2) Int+-- delayN2 = 'delayN' d2+-- @+--+-- >>> printX $ sampleN @System 6 (toSignal (delayN2 (-1) (dfromList [1..])))+-- [-1,-1,1,2,3,4]+delayN+  :: forall dom  a d n+   . ( HiddenClock dom+     , HiddenEnable dom+     , NFDataX a )+  => SNat d+  -> a+  -- ^ Initial value+  -> DSignal dom n a+  -> DSignal dom (n+d) a+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+--   :: ( HiddenClock dom+--      , HiddenEnable dom )+--   => Int+--   -> 'DSignal' dom n Int+--   -> 'DSignal' dom (n + 2) Int+-- delayI2 = 'delayI'+-- @+--+-- >>> sampleN @System 6 (toSignal (delayI2 (-1) (dfromList [1..])))+-- [-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+   . ( HiddenClock dom+     , HiddenEnable dom+     , NFDataX a+     , KnownNat d )+  => a+  -- ^ Initial value+  -> DSignal dom n a+  -> DSignal dom (n+d) a+delayI dflt = hideClock (hideEnable (E.delayI dflt))++-- | 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 @System 6 (toSignal (delayedFold d1 (-1) (+) countingSignals))+-- [-1,-2,0,4,8,12]+--+-- >>> printX $ sampleN @System 8 (toSignal (delayedFold d2 (-1) (*) countingSignals))+-- [-1,-1,1,1,0,1,16,81]+delayedFold+  :: forall dom  n delay k a+   . ( HiddenClock dom+     , HiddenEnable dom+     , NFDataX a+     , KnownNat delay+     , KnownNat k )+  => SNat delay+  -- ^ Delay applied after each step+  -> a+  -- ^ Initial value+  -> (a -> a -> a)+  -- ^ Fold operation to apply+  -> 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 d dflt f = hideClock (hideEnable (E.delayedFold d dflt f))
+ src/Clash/Signal/Delayed/Bundle.hs view
@@ -0,0 +1,228 @@+{-|+  Copyright   :  (C) 2019, Myrtle Software Ltd.+                     2018, @blaxill+                     2018, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilyDependencies #-}++module Clash.Signal.Delayed.Bundle (+    Bundle(..)+  -- ** Tools to emulate pre Clash 1.0 @Bundle ()@ instance+  , B.EmptyTuple(..)+  , TaggedEmptyTuple(..)+  ) where++import           GHC.TypeLits                  (KnownNat)+import           Prelude                       hiding (head, map, tail)++import           Clash.Signal.Internal         (Domain)+import           Clash.Signal.Delayed (DSignal, toSignal, unsafeFromSignal)+import qualified Clash.Signal.Bundle           as B++import           Clash.Sized.BitVector         (Bit, BitVector)+import           Clash.Sized.Fixed             (Fixed)+import           Clash.Sized.Index             (Index)+import           Clash.Sized.RTree             (RTree, lazyT)+import           Clash.Sized.Signed            (Signed)+import           Clash.Sized.Unsigned          (Unsigned)+import           Clash.Sized.Vector            (Vec, lazyV)++import           GHC.TypeLits                  (Nat)++-- | Isomorphism between a 'DSignal' of a product type+-- (e.g. a tuple) and a product type of 'DSignal's.+--+-- Instances of 'Bundle' must satisfy the following laws:+--+-- @+-- 'bundle' . 'unbundle' = 'id'+-- 'unbundle' . 'bundle' = 'id'+-- @+--+-- By default, 'bundle' and 'unbundle', are defined as the identity, that is,+-- writing:+--+-- @+-- data D = A | B+--+-- instance Bundle D+-- @+--+-- is the same as:+--+-- @+-- data D = A | B+--+-- instance Bundle D where+--   type 'Unbundled' dom delay D = 'DSignal' dom delay D+--   'bundle'   s = s+--   'unbundle' s = s+-- @+--+class Bundle a where+  type Unbundled (dom :: Domain) (d :: Nat) a = res | res -> dom d a+  type Unbundled dom d a = DSignal dom d a++  -- | Example:+  --+  -- @+  -- __bundle__ :: ('DSignal' dom d a, 'DSignal' dom d b) -> 'DSignal' dom d (a,b)+  -- @+  --+  -- However:+  --+  -- @+  -- __bundle__ :: 'DSignal' dom 'Clash.Sized.BitVector.Bit' -> 'DSignal' dom 'Clash.Sized.BitVector.Bit'+  -- @+  bundle :: Unbundled dom d a -> DSignal dom d a+  {-# INLINE bundle #-}+  default bundle :: (DSignal dom d a ~ Unbundled dom d a)+                 => Unbundled dom d a -> DSignal dom d a+  bundle s = s+  -- | Example:+  --+  -- @+  -- __unbundle__ :: 'DSignal' dom d (a,b) -> ('DSignal' dom d a, 'DSignal' dom d b)+  -- @+  --+  -- However:+  --+  -- @+  -- __unbundle__ :: 'DSignal' dom 'Clash.Sized.BitVector.Bit' -> 'DSignal' dom 'Clash.Sized.BitVector.Bit'+  -- @+  unbundle :: DSignal dom d a -> Unbundled dom d a+  {-# INLINE unbundle #-}+  default unbundle :: (Unbundled dom d a ~ DSignal dom d a)+                   => DSignal dom d a -> Unbundled dom d a+  unbundle s = s++instance Bundle ()+instance Bundle Bool+instance Bundle Integer+instance Bundle Int+instance Bundle Float+instance Bundle Double+instance Bundle (Maybe a)+instance Bundle (Either a b)++instance Bundle Bit+instance Bundle (BitVector n)+instance Bundle (Index n)+instance Bundle (Fixed rep int frac)+instance Bundle (Signed n)+instance Bundle (Unsigned n)++instance Bundle (a,b) where+  type Unbundled t delay (a,b) = (DSignal t delay a, DSignal t delay b)++  bundle       = uncurry (liftA2 (,))+  unbundle tup = (fmap fst tup, fmap snd tup)++instance Bundle (a,b,c) where+  type Unbundled t delay (a,b,c) =+    ( DSignal t delay a, DSignal t delay b, DSignal t delay c)++  bundle   (a,b,c) = (,,) <$> a <*> b <*> c+  unbundle tup     = (fmap (\(x,_,_) -> x) tup+                      ,fmap (\(_,x,_) -> x) tup+                      ,fmap (\(_,_,x) -> x) tup+                      )+instance Bundle (a,b,c,d) where+  type Unbundled t delay (a,b,c,d) =+    ( DSignal t delay a, DSignal t delay b, DSignal t delay c, DSignal t delay d)++  bundle   (a,b,c,d) = (,,,) <$> a <*> b <*> c <*> d+  unbundle tup     = (fmap (\(x,_,_,_) -> x) tup+                      ,fmap (\(_,x,_,_) -> x) tup+                      ,fmap (\(_,_,x,_) -> x) tup+                      ,fmap (\(_,_,_,x) -> x) tup+                      )++instance Bundle (a,b,c,d,e) where+  type Unbundled t delay (a,b,c,d,e) =+    ( DSignal t delay a, DSignal t delay b, DSignal t delay c, DSignal t delay d+    , DSignal t delay e)++  bundle   (a,b,c,d,e) = (,,,,) <$> a <*> b <*> c <*> d <*> e+  unbundle tup     = (fmap (\(x,_,_,_,_) -> x) tup+                      ,fmap (\(_,x,_,_,_) -> x) tup+                      ,fmap (\(_,_,x,_,_) -> x) tup+                      ,fmap (\(_,_,_,x,_) -> x) tup+                      ,fmap (\(_,_,_,_,x) -> x) tup+                      )++instance Bundle (a,b,c,d,e,f) where+  type Unbundled t delay (a,b,c,d,e,f) =+    ( DSignal t delay a, DSignal t delay b, DSignal t delay c, DSignal t delay d+    , DSignal t delay e, DSignal t delay f)++  bundle   (a,b,c,d,e,f) = (,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f+  unbundle tup           = (fmap (\(x,_,_,_,_,_) -> x) tup+                           ,fmap (\(_,x,_,_,_,_) -> x) tup+                           ,fmap (\(_,_,x,_,_,_) -> x) tup+                           ,fmap (\(_,_,_,x,_,_) -> x) tup+                           ,fmap (\(_,_,_,_,x,_) -> x) tup+                           ,fmap (\(_,_,_,_,_,x) -> x) tup+                           )++instance Bundle (a,b,c,d,e,f,g) where+  type Unbundled t delay (a,b,c,d,e,f,g) =+    ( DSignal t delay a, DSignal t delay b, DSignal t delay c, DSignal t delay d+    , DSignal t delay e, DSignal t delay f, DSignal t delay g)++  bundle   (a,b,c,d,e,f,g) = (,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f+                                      <*> g+  unbundle tup             = (fmap (\(x,_,_,_,_,_,_) -> x) tup+                             ,fmap (\(_,x,_,_,_,_,_) -> x) tup+                             ,fmap (\(_,_,x,_,_,_,_) -> x) tup+                             ,fmap (\(_,_,_,x,_,_,_) -> x) tup+                             ,fmap (\(_,_,_,_,x,_,_) -> x) tup+                             ,fmap (\(_,_,_,_,_,x,_) -> x) tup+                             ,fmap (\(_,_,_,_,_,_,x) -> x) tup+                             )++instance Bundle (a,b,c,d,e,f,g,h) where+  type Unbundled t delay (a,b,c,d,e,f,g,h) =+    ( DSignal t delay a, DSignal t delay b, DSignal t delay c, DSignal t delay d+    , DSignal t delay e, DSignal t delay f ,DSignal t delay g, DSignal t delay h)++  bundle   (a,b,c,d,e,f,g,h) = (,,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f+                                         <*> g <*> h+  unbundle tup               = (fmap (\(x,_,_,_,_,_,_,_) -> x) tup+                               ,fmap (\(_,x,_,_,_,_,_,_) -> x) tup+                               ,fmap (\(_,_,x,_,_,_,_,_) -> x) tup+                               ,fmap (\(_,_,_,x,_,_,_,_) -> x) tup+                               ,fmap (\(_,_,_,_,x,_,_,_) -> x) tup+                               ,fmap (\(_,_,_,_,_,x,_,_) -> x) tup+                               ,fmap (\(_,_,_,_,_,_,x,_) -> x) tup+                               ,fmap (\(_,_,_,_,_,_,_,x) -> x) tup+                               )++instance KnownNat n => Bundle (Vec n a) where+  type Unbundled t d (Vec n a) = Vec n (DSignal t d a)+  bundle   = unsafeFromSignal . B.bundle . fmap toSignal+  unbundle = sequenceA . fmap lazyV++instance KnownNat d => Bundle (RTree d a) where+  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
@@ -0,0 +1,232 @@+{-|+  Copyright   :  (C) 2019     , Myrtle Software Ltd.+                     2018     , @blaxill+                     2018-2025, QBayLogic B.V.+                     2021     , LUMI GUIDE FIETSDETECTIE B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}+{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Signal.Delayed.Internal+  ( -- * Delay-annotated synchronous signals+    DSignal(..)+  , feedback+  , fromSignal+    -- * List \<-\> DSignal conversion (not synthesizable)+  , dfromList+    -- ** lazy versions+  , dfromList_lazy+    -- * Experimental+  , unsafeFromSignal+  , antiDelay+  , forward+  )+where++import Data.Coerce                (coerce)+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      (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+      :: 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' a b acc = let acc' = a * b + 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' of its delay information.+            }+  deriving ( Show, Default, Functor, Applicative, Num, Fractional+           , Foldable, Traversable, Arbitrary, CoArbitrary, Lift )++-- | Create a 'DSignal' from a list+--+-- Every element in the list will correspond to a value of the signal for one+-- clock cycle.+--+-- >>> sampleN 2 (toSignal (dfromList [1,2,3,4,5]))+-- [1,2]+--+-- __NB__: This function is not synthesizable+dfromList :: NFDataX a => [a] -> DSignal dom 0 a+dfromList = coerce . fromList++-- | Create a 'DSignal' from a list+--+-- Every element in the list will correspond to a value of the signal for one+-- clock cycle.+--+-- >>> sampleN 2 (toSignal (dfromList [1,2,3,4,5]))+-- [1,2]+--+-- __NB__: This function is not synthesizable+dfromList_lazy :: [a] -> DSignal dom 0 a+dfromList_lazy = coerce . fromList_lazy++-- | Feed the delayed result of a function back to its input:+--+-- @+-- 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' a b acc = let acc' = a * b + acc+--                    in  (acc, 'Clash.Explicit.Signal.Delayed.delayedI' clk rst en 0 acc')+-- @+--+-- >>> 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))+  -> DSignal dom n a+feedback f = let (o,r) = f (coerce r) in o++-- | 'Signal's are not delayed+fromSignal :: Signal dom a -> DSignal dom 0 a+fromSignal = coerce++-- | __EXPERIMENTAL__+--+-- __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'.+unsafeFromSignal :: Signal dom a -> DSignal dom n a+unsafeFromSignal = DSignal++-- | __EXPERIMENTAL__+--+-- Access a /delayed/ signal from the future in the present. Often required+-- When writing a circuit that requires feedback from itself.+--+-- @+-- 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  = '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
@@ -0,0 +1,2217 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  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
@@ -0,0 +1,118 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++module Clash.Signal.Internal.Ambiguous+  ( knownVDomain+  , clockPeriod+  , activeEdge+  , resetKind+  , initBehavior+  , resetPolarity+  ) where++import           Clash.Signal.Internal+import           Clash.Promoted.Nat         (SNat)++-- | Get the clock period from a KnownDomain context+clockPeriod+  :: forall dom period+   . (KnownDomain dom, DomainPeriod dom ~ period)+  => SNat period+clockPeriod =+  case knownDomain @dom of+    SDomainConfiguration{sPeriod} ->+      sPeriod+{-# OPAQUE clockPeriod #-}+-- @NOINLINE: https://github.com/clash-lang/clash-compiler/issues/662++-- | Get 'ActiveEdge' from a KnownDomain context. Example usage:+--+-- @+-- f :: forall dom . KnownDomain dom => ....+-- f a b c =+--   case activeEdge @dom of+--     SRising -> foo+--     SFalling -> bar+-- @+activeEdge+  :: forall dom edge+   . (KnownDomain dom, DomainActiveEdge dom ~ edge)+  => SActiveEdge edge+activeEdge =+  case knownDomain @dom of+    SDomainConfiguration{sActiveEdge} ->+      sActiveEdge+{-# OPAQUE activeEdge #-}+-- @NOINLINE: https://github.com/clash-lang/clash-compiler/issues/662++-- | Get 'ResetKind' from a KnownDomain context. Example usage:+--+-- @+-- f :: forall dom . KnownDomain dom => ....+-- f a b c =+--   case resetKind @dom of+--     SAsynchronous -> foo+--     SSynchronous -> bar+-- @+resetKind+  :: forall dom sync+   . (KnownDomain dom, DomainResetKind dom ~ sync)+  => SResetKind sync+resetKind =+  case knownDomain @dom of+    SDomainConfiguration{sResetKind} ->+      sResetKind+{-# OPAQUE resetKind #-}+-- @NOINLINE: https://github.com/clash-lang/clash-compiler/issues/662++-- | Get 'InitBehavior' from a KnownDomain context. Example usage:+--+-- @+-- f :: forall dom . KnownDomain dom => ....+-- f a b c =+--   case initBehavior @dom of+--     SDefined -> foo+--     SUnknown -> bar+-- @+initBehavior+  :: forall dom init+   . (KnownDomain dom, DomainInitBehavior dom ~ init)+  => SInitBehavior init+initBehavior =+  case knownDomain @dom of+    SDomainConfiguration{sInitBehavior} ->+      sInitBehavior+{-# OPAQUE initBehavior #-}+-- @NOINLINE: https://github.com/clash-lang/clash-compiler/issues/662++-- | Get 'ResetPolarity' from a KnownDomain context. Example usage:+--+-- @+-- f :: forall dom . KnownDomain dom => ....+-- f a b c =+--   case resetPolarity @dom of+--     SActiveHigh -> foo+--     SActiveLow -> bar+-- @+resetPolarity+  :: forall dom polarity+   . (KnownDomain dom, DomainResetPolarity dom ~ polarity)+  => SResetPolarity polarity+resetPolarity =+  case knownDomain @dom of+    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+-- in combination with 'createDomain'.+knownVDomain+  :: forall dom+   . KnownDomain dom+  => VDomainConfiguration+knownVDomain =+  vDomain (knownDomain @dom)
+ src/Clash/Signal/Trace.hs view
@@ -0,0 +1,691 @@+{-|+Copyright  :  (C) 2018, Google Inc.+                  2019, Myrtle Software Ltd+                  2022-2026, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Utilities for tracing signals and dumping them in various ways. Example usage:++@+import Clash.Prelude hiding (writeFile)+import Data.Text.IO  (writeFile)++-- | Count and wrap around+subCounter :: SystemClockResetEnable => Signal System (Index 3)+subCounter = traceSignal1 "sub" counter+  where+    counter =+      register 0 (fmap succ' counter)++    succ' c+      | c == maxBound = 0+      | otherwise     = c + 1++-- | Count, but only when my subcounter is wrapping around+mainCounter :: SystemClockResetEnable => Signal System (Signed 64)+mainCounter = traceSignal1 "main" counter+  where+    counter =+      register 0 (fmap succ' $ bundle (subCounter,counter))++    succ' (sc, c)+      | sc == maxBound = c + 1+      | otherwise      = c++-- | Collect traces, and dump them to a VCD file.+main :: IO ()+main = do+  let cntrOut = exposeClockResetEnable mainCounter systemClockGen systemResetGen enableGen+  vcd <- dumpVCD (0, 100) cntrOut ["main", "sub"]+  case vcd of+    Left msg ->+      error msg+    Right contents ->+      writeFile "mainCounter.vcd" contents+@+-}+{-# 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       #-}++module Clash.Signal.Trace+  (+  -- * Tracing functions+  -- ** Simple+    traceSignal1+  , traceVecSignal1+  -- ** Tracing in a multi-clock environment+  , traceSignal+  , traceVecSignal++  -- * VCD dump functions+  , dumpVCD++  -- * Replay functions+  , dumpReplayable+  , replay++  -- * Internal+  -- ** Types+  , VCDFile(..)+  , VCDTime+  , IDCode+  , TimeUnit(..)+  , DeclarationCommand(..)+  , Var(..)+  , SimulationCommand(..)+  , ValueChange(..)+  , Period+  , Changed+  , Value+  , Width+  , TraceMap+  , TypeRepBS+  -- ** Functions+  , traceSignal#+  , traceVecSignal#+  , 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)+import           Clash.Sized.Vector    (Vec, iterateI)+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 (Signal ((:-)), sample)+import           Clash.XException      (deepseqX, NFDataX)+import           Clash.Sized.Internal.BitVector+  (BitVector(BV))++-- Haskell / GHC:+import           Control.Monad         (foldM)+import           Data.Bits             (testBit)+import           Data.Binary           (encode, decodeOrFail)+import           Data.ByteString.Lazy  (ByteString)+import qualified Data.ByteString.Lazy  as ByteStringLazy+import           Data.Char             (ord, chr)+import           Data.IORef+  (IORef, atomicModifyIORef', atomicWriteIORef, newIORef, readIORef)+#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)+import           Type.Reflection       (Typeable, TypeRep, typeRep)++#ifdef CABAL+import qualified Data.Version+import qualified Paths_clash_prelude+#endif++type Period   = Int+type Changed  = Bool+type Value    = (Natural, Natural) -- (Mask, Value)+type Width    = Int++-- | Serialized TypeRep we need to store for dumpReplayable / replay+type TypeRepBS = ByteString++type TraceMap  = Map.Map String (TypeRepBS, Period, Width, [Value])++-- | Map of traces used by the non-internal trace and dumpvcd functions.+traceMap# :: IORef TraceMap+traceMap# = unsafePerformIO (newIORef Map.empty)+{-# OPAQUE traceMap# #-}++mkTrace+  :: HasCallStack+  => BitPack a+  => NFDataX a+  => Signal dom a+  -> [Value]+mkTrace signal = sample (unsafeToTup . pack <$> signal)+ where+  unsafeToTup (BV mask value) = (mask, value)++-- | Trace a single signal. Will emit an error if a signal with the same name+-- was previously registered.+traceSignal#+  :: forall dom a+   . ( BitPack a+     , NFDataX a+     , Typeable a )+  => IORef TraceMap+  -- ^ Map to store the trace+  -> Int+  -- ^ The associated clock period for the trace+  -> String+  -- ^ Name of signal in the VCD output+  -> Signal dom a+  -- ^ Signal to trace+  -> IO (Signal dom a)+traceSignal# traceMap period traceName signal =+  atomicModifyIORef' traceMap $ \m ->+    if Map.member traceName m then+      error $ "Already tracing a signal with the name: '" ++ traceName ++ "'."+    else+      ( Map.insert+          traceName+          ( encode (typeRep @a)+          , period+          , width+          , mkTrace signal)+          m+      , signal)+ where+  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 n+     , BitPack a+     , NFDataX a+     , Typeable a )+  => IORef TraceMap+  -- ^ Map to store the traces+  -> Int+  -- ^ Associated clock period for the trace+  -> String+  -- ^ Name of signal in the VCD output. Will be appended by _0, _1, ..., _n.+  -> Signal dom (Vec (n+1) a)+  -- ^ Signal to trace+  -> IO (Signal dom (Vec (n+1) a))+traceVecSignal# traceMap period vecTraceName (unbundle -> vecSignal) =+  fmap bundle . sequenceA $+    Vector.zipWith trace' (iterateI succ (0 :: Int)) vecSignal+ where+  trace' i s = traceSignal# traceMap period (name' i) s+  name' i    = vecTraceName ++ "_" ++ show i+{-# 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+-- 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+     , BitPack a+     , NFDataX a+     , Typeable a )+  => String+  -- ^ Name of signal in the VCD output+  -> Signal dom a+  -- ^ Signal to trace+  -> Signal dom a+traceSignal traceName signal =+  case knownDomain @dom of+    SDomainConfiguration{sPeriod} ->+      unsafePerformIO $+        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+-- results in incorrect VCD files when working with circuits that have+-- multiple clocks. Use 'traceSignal' when working with circuits that have+-- multiple clocks.+traceSignal1+  :: ( BitPack a+     , NFDataX a+     , Typeable a )+  => String+  -- ^ Name of signal in the VCD output+  -> Signal dom a+  -- ^ Signal to trace+  -> Signal dom a+traceSignal1 traceName signal =+  unsafePerformIO (traceSignal# traceMap# 1 traceName signal)+{-# 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 convenient to+-- use when the domain of your circuit is polymorphic.+traceVecSignal+  :: forall dom a  n+   . ( KnownDomain dom+     , KnownNat n+     , BitPack a+     , NFDataX a+     , Typeable a )+  => String+  -- ^ Name of signal in debugging output. Will be appended by _0, _1, ..., _n.+  -> Signal dom (Vec (n+1) a)+  -- ^ Signal to trace+  -> Signal dom (Vec (n+1) a)+traceVecSignal traceName signal =+  case knownDomain @dom of+    SDomainConfiguration{sPeriod} ->+      unsafePerformIO $+        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+-- 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 n+     , BitPack a+     , NFDataX a+     , Typeable a )+  => String+  -- ^ Name of signal in debugging output. Will be appended by _0, _1, ..., _n.+  -> Signal dom (Vec (n+1) a)+  -- ^ Signal to trace+  -> Signal dom (Vec (n+1) a)+traceVecSignal1 traceName signal =+  unsafePerformIO $ traceVecSignal# traceMap# 1 traceName signal+{-# 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"++toPeriodMap :: TraceMap -> Map.Map Period [(String, Width, [Value])]+toPeriodMap m = foldl' go Map.empty (Map.assocs m)+  where+    go periodMap (traceName, (_rep, period, width, values)) =+      Map.alter (Just . go') period periodMap+        where+          go' = ((traceName, width, values):) . (fromMaybe [])++flattenMap :: Map.Map a [b] -> [(a, b)]+flattenMap m = concat [[(a, b) | b <- bs] | (a, bs) <- Map.assocs m]++printable :: Char -> Bool+printable (ord -> c) = 33 <= c && c <= 126++-- | 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+  -> 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."+  | (nm:_) <- offensiveNames =+      Left $ unwords [ "Trace '" ++ nm ++ "' contains"+                     , "non-printable ASCII characters, which is not"+                     , "supported by VCD." ]+  | otherwise =+      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++  -- 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++  -- Normalize traces until they have the "same" period. That is, assume+  -- we have two traces; trace A with a period of 20 ps and trace B with+  -- a period of 40 ps:+  --+  --   A: [A1, A2, A3, ...]+  --   B: [B1, B2, B3, ...]+  --+  -- After normalization these look like:+  --+  --   A: [A1, A2, A3, A4, A5, A6, ...]+  --   B: [B1, B1, B2, B2, B3, B3, ...]+  --+  -- ..because B is "twice as slow" as A.+  (periods, traceNames, widths, valuess) =+    unzip4 $ map+      (\(a, (b, c, d)) -> (a, b, c, d))+      (flattenMap periodMap)++  periods' = map (`quot` timescale) periods+  valuess' = map slice $ zipWith normalize periods' valuess+  normalize period (initial:values) = initial : concatMap (replicate period) values+  normalize _      []               = []+  slice values = drop offset $ take cycles values++  initValues = zipWith ($) formatters inits++  formatters = zipWith ValueChange widths labels+  inits = map (maybe (error "dumpVCD##: empty value") fst . uncons) valuess'+  tails = map changed valuess'++  -- 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 [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 [SimulationCommand]+  bodyPart values =+    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+  => IORef TraceMap+  -- ^ Map with collected traces+  -> (Int, Int)+  -- ^ (offset, number of samples)+  -> Signal dom a+  -- ^ (One of) the output(s) the circuit containing the traces+  -> [String]+  -- ^ The names of the traces you definitely want to be dumped to the VCD file+  -> IO (Either String Text.Text)+dumpVCD# traceMap slice signal traceNames = do+  waitForTraces# traceMap signal traceNames+  m <- readIORef traceMap+  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+-- non-printable or non-VCD characters.+--+-- Due to lazy evaluation, the created VCD files might not contain all the+-- traces you were expecting. You therefore have to provide a list of names+-- you definately want to be dumped in the VCD file.+--+-- For example:+--+-- @+-- vcd <- dumpVCD (0, 100) cntrOut ["main", "sub"]+-- @+--+-- Evaluates /cntrOut/ long enough in order for to guarantee that the @main@,+-- and @sub@ traces end up in the generated VCD file.+dumpVCD+  :: NFDataX a+  => (Int, Int)+  -- ^ (offset, number of samples)+  -> Signal dom a+  -- ^ (One of) the outputs of the circuit containing the traces+  -> [String]+  -- ^ The names of the traces you definitely want to be dumped in the VCD file+  -> IO (Either String Text.Text)+dumpVCD = dumpVCD# traceMap#++-- | Dump a number of samples to a replayable bytestring.+dumpReplayable+  :: forall a dom+   . NFDataX a+  => Int+  -- ^ Number of samples+  -> Signal dom a+  -- ^ (One of) the outputs of the circuit containing the traces+  -> String+  -- ^ Name of trace to dump+  -> IO ByteString+dumpReplayable n oSignal traceName = do+  waitForTraces# traceMap# oSignal [traceName]+  replaySignal <- (Map.! traceName) <$> readIORef traceMap#+  let (tRep, _period, _width, samples) = replaySignal+  pure (ByteStringLazy.concat (tRep : map encode (take n samples)))++-- | 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. Note that this always happens if you+-- evaluate more values than were originally dumped.+replay+  :: forall a dom n+   . ( Typeable a+     , NFDataX a+     , BitPack a+     , KnownNat n+     , n ~ BitSize a )+  => ByteString+  -> Either String (Signal dom a)+replay bytes0 = samples1+ where+  samples1 =+    case decodeOrFail bytes0 of+      Left (_, _, err) ->+        Left ("Failed to decode typeRep. Parser reported:\n\n" ++ err)+      Right (bytes1, _, _ :: TypeRep a) ->+        let samples0 = decodeSamples bytes1 in+        let err = "Failed to decode value in signal. Parser reported:\n\n " in+        Right (fromList (map (either (error . (err ++)) id) samples0))++-- | Helper function of 'replay'. Decodes ByteString to some type with+-- BitVector as an intermediate type.+decodeSamples+  :: forall a n+   . ( BitPack a+     , KnownNat n+     , n ~ BitSize a )+  => ByteString+  -> [Either String a]+decodeSamples bytes0 =+  case decodeOrFail bytes0 of+    Left (_, _, err) ->+      [Left err]+    Right (bytes1, _, (m, v)) ->+      (Right (unpack (BV m v))) : decodeSamples bytes1++-- | Keep evaluating given signal until all trace names are present.+waitForTraces#+  :: NFDataX a+  => IORef TraceMap+  -- ^ Map with collected traces+  -> Signal dom a+  -- ^ (One of) the output(s) the circuit containing the traces+  -> [String]+  -- ^ The names of the traces you definitely want to be dumped to the VCD file+  -> IO ()+waitForTraces# traceMap signal traceNames = do+  atomicWriteIORef traceMap Map.empty+  rest <- foldM go signal traceNames+  seq rest (return ())+ where+  go (s0 :- ss) nm = do+    m <- readIORef traceMap+    if Map.member nm m then+      deepseqX s0 (return ss)+    else+      deepseqX+        s0+        (go ss nm)
+ src/Clash/Sized/BitVector.hs view
@@ -0,0 +1,75 @@+{-|+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 Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Sized.BitVector+  ( -- * Bit+    Bit+    -- ** Construction+    -- *** Initialisation+  , high+  , low+    -- * BitVector+  , BitVector+    -- ** Accessors+    -- *** Length information+  , size#+  , 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
@@ -0,0 +1,1269 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2021-2025, QBayLogic B.V.,+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Fixed point numbers++* The 'Num' operators for the given types saturate on overflow,+  and use truncation as the rounding method.+* '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'. __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 CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# 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 #-}++module Clash.Sized.Fixed+  ( -- * 'SFixed': 'Signed' 'Fixed' point numbers+    SFixed, sf, unSF+    -- * 'UFixed': 'Unsigned' 'Fixed' point numbers+  , UFixed, uf, unUF+      -- * Division+  , divide+    -- * Compile-time 'Double' conversion+  , fLit+    -- * Run-time 'Double' conversion (not synthesizable)+  , fLitR+    -- * 'Fixed' point wrapper+  , Fixed (..), resizeF, fracShift+    -- * Constraint synonyms #constraintsynonyms#+    -- $constraintsynonyms++    -- ** Constraint synonyms for 'SFixed'+  , NumSFixedC, ENumSFixedC, FracSFixedC, ResizeSFC, DivideSC+    -- ** Constraint synonyms for 'UFixed'+  , NumUFixedC, ENumUFixedC, FracUFixedC, ResizeUFC, DivideUC+    -- ** Constraint synonyms for 'Fixed' wrapper+  , NumFixedC, ENumFixedC, FracFixedC, ResizeFC, DivideC+    -- * Proxy+  , asRepProxy, asIntProxy+  )+where++import Control.DeepSeq            (NFData)+import Control.Arrow              ((***), second)+import Data.Bits                  (Bits (..), FiniteBits)+import Data.Data                  (Data)+import Data.Default               (Default (..))+import Data.Either                (isLeft)+import Data.Kind                  (Type)+import Text.Read                  (Read(..))+import Data.List                  (find)+import Data.Proxy                 (Proxy (..))+import Data.Ratio                 ((%), denominator, numerator)+import Data.Typeable              (Typeable, TypeRep, typeRep, typeOf)+import GHC.TypeLits               (KnownNat, Nat, type (+), natVal)+import GHC.TypeLits.Extra         (Max)+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 (..))+import Clash.Class.Num            (ExtendingNum (..), SaturatingNum (..),+                                   SaturationMode (..), boundedAdd, boundedSub,+                                   boundedMul)+import Clash.Class.Resize         (Resize (..))+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, fromJustX)++{- $setup+>>> :set -XDataKinds+>>> :set -XTemplateHaskell+>>> import Clash.Prelude+>>> let n = $$(fLit pi) :: SFixed 4 4+-}++-- | 'Fixed'-point number+--+-- Where:+--+-- * @rep@ is the underlying representation+--+-- * @int@ is the number of bits used to represent the integer part+--+-- * @frac@ is the number of bits used to represent the fractional part+--+-- The 'Num' operators for this type saturate to 'maxBound' on overflow and+-- 'minBound' on underflow, and use truncation as the rounding method.+--+-- 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)+deriving instance (Typeable rep, Typeable int, Typeable frac+                  , 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 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)+deriving instance CoArbitrary (rep (int + frac)) => CoArbitrary (Fixed rep int frac)+deriving instance FiniteBits (rep (int + frac)) => FiniteBits (Fixed rep int frac)++-- | Instance functions do not saturate.+-- Meaning that \"@\`shiftL\` 1 == 'satMul' 'SatWrap' 2'@\"+deriving instance Bits (rep (int + frac)) => Bits (Fixed rep int frac)++-- | Signed 'Fixed'-point number, with @int@ integer bits (including sign-bit)+-- and @frac@ fractional bits.+--+-- * The range 'SFixed' @int@ @frac@ numbers is: [-(2^(@int@ -1)) ..+-- 2^(@int@-1) - 2^-@frac@ ]+-- * The resolution of 'SFixed' @int@ @frac@ numbers is: 2^@frac@+-- * The 'Num' operators for this type saturate on overflow,+--   and use truncation as the rounding method.+--+-- >>>  maxBound :: SFixed 3 4+-- 3.9375+-- >>> minBound :: SFixed 3 4+-- -4.0+-- >>> read (show (maxBound :: SFixed 3 4)) :: SFixed 3 4+-- 3.9375+-- >>> 1 + 2 :: SFixed 3 4+-- 3.0+-- >>> 2 + 3 :: SFixed 3 4+-- 3.9375+-- >>> (-2) + (-3) :: SFixed 3 4+-- -4.0+-- >>> 1.375 * (-0.8125) :: SFixed 3 4+-- -1.125+-- >>> (1.375 :: SFixed 3 4) `mul` (-0.8125 :: SFixed 3 4) :: SFixed 6 8+-- -1.1171875+-- >>> (2 :: SFixed 3 4) `add` (3 :: SFixed 3 4) :: SFixed 4 4+-- 5.0+-- >>> (-2 :: SFixed 3 4) `add` (-3 :: SFixed 3 4) :: SFixed 4 4+-- -5.0+type SFixed = Fixed Signed++-- | Unsigned 'Fixed'-point number, with @int@ integer bits and @frac@+-- fractional bits+--+-- * The range 'UFixed' @int@ @frac@ numbers is: [0 .. 2^@int@ - 2^-@frac@ ]+-- * The resolution of 'UFixed' @int@ @frac@ numbers is: 2^@frac@+-- * The 'Num' operators for this type saturate on overflow,+--   and use truncation as the rounding method.+--+-- >>> maxBound :: UFixed 3 4+-- 7.9375+-- >>> minBound :: UFixed 3 4+-- 0.0+-- >>> 1 + 2 :: UFixed 3 4+-- 3.0+-- >>> 2 + 6 :: UFixed 3 4+-- 7.9375+-- >>> 1 - 3 :: UFixed 3 4+-- 0.0+-- >>> 1.375 * 0.8125 :: UFixed 3 4+-- 1.0625+-- >>> (1.375 :: UFixed 3 4) `mul` (0.8125 :: UFixed 3 4) :: UFixed 6 8+-- 1.1171875+-- >>> (2 :: UFixed 3 4) `add` (6 :: UFixed 3 4) :: UFixed 4 4+-- 8.0+--+-- However, 'sub' does not saturate to 'minBound' on underflow:+--+-- >>> (1 :: UFixed 3 4) `sub` (3 :: UFixed 3 4) :: UFixed 4 4+-- 14.0+type UFixed = Fixed Unsigned++{-# INLINE sf #-}+-- | Treat a 'Signed' integer as a @Signed@ 'Fixed'-@point@ integer+--+-- >>> sf d4 (-22 :: Signed 7)+-- -1.375+sf+  :: SNat frac+  -- ^ Position of the virtual @point@+  -> Signed (int + frac)+  -- ^ The 'Signed' integer+  -> SFixed int frac+sf _ fRep = Fixed fRep++{-# INLINE unSF #-}+-- | See the underlying representation of a Signed Fixed-point integer+unSF :: SFixed int frac+     -> Signed (int + frac)+unSF (Fixed fRep) = fRep++{-# INLINE uf #-}+-- | Treat an 'Unsigned' integer as a @Unsigned@ 'Fixed'-@point@ number+--+-- >>> uf d4 (92 :: Unsigned 7)+-- 5.75+uf+  :: SNat frac+  -- ^ Position of the virtual @point@+  -> Unsigned (int + frac)+  -- ^ The 'Unsigned' integer+  -> UFixed int frac+uf _ fRep = Fixed fRep++{-# INLINE unUF #-}+-- | See the underlying representation of an Unsigned Fixed-point integer+unUF :: UFixed int frac+     -> Unsigned (int + frac)+unUF (Fixed fRep) = fRep++{-# INLINE asRepProxy #-}+-- | 'Fixed' as a 'Proxy' for it's representation type @rep@+asRepProxy :: Fixed rep int frac -> Proxy rep+asRepProxy _ = Proxy++{-# INLINE asIntProxy #-}+-- | 'Fixed' as a 'Proxy' for the number of integer bits @int@+asIntProxy :: Fixed rep int frac -> Proxy int+asIntProxy _ = Proxy++-- | Get the position of the virtual @point@ of a 'Fixed'-@point@ number+fracShift :: KnownNat frac => Fixed rep int frac -> Int+fracShift fx = fromInteger (natVal fx)++instance ( size ~ (int + frac), KnownNat frac, Integral (rep size)+         ) => Show (Fixed rep int frac) where+  show f@(Fixed fRep) =+      i ++ "." ++ (uncurry pad . second (show . numerator) .+                   fromJustX . find ((==1) . denominator . snd) .+                   iterate (succ *** (*10)) . (,) 0 $ (nom % denom))+    where+      pad n str = replicate (n - length str) '0' ++ str++      nF        = fracShift f+      fRepI     = toInteger fRep+      fRepI_abs = abs fRepI+      i         = if fRepI < 0 then '-' : show (fRepI_abs `shiftR` nF)+                               else show (fRepI `shiftR` nF)+      nom       = if fRepI < 0 then fRepI_abs .&. ((2 ^ nF) - 1)+                               else fRepI .&. ((2 ^ nF) - 1)+      denom     = 2 ^ nF++instance ( size ~ (int + frac), KnownNat frac, Integral (rep size)+         ) => ShowX (Fixed rep int frac) where+  showsPrecX = showsPrecXWith showsPrec++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))+      => Read (Fixed rep int frac) where+  readPrec = fLitR <$> readPrec++{- $constraintsynonyms+Writing polymorphic functions over fixed point numbers can be a potentially+verbose due to the many class constraints induced by the functions and operators+of this module.++Writing a simple multiply-and-accumulate function can already give rise to many+lines of constraints:++@+mac :: ( 'GHC.TypeLits.KnownNat' frac+       , 'GHC.TypeLits.KnownNat' (frac + frac)+       , 'GHC.TypeLits.KnownNat' (int + frac)+       , 'GHC.TypeLits.KnownNat' (1 + (int + frac))+       , 'GHC.TypeLits.KnownNat' ((int + frac) + (int + frac))+       , ((int + int) + (frac + frac)) ~ ((int + frac) + (int + frac))+       )+    => 'SFixed' int frac+    -> 'SFixed' int frac+    -> 'SFixed' int frac+    -> 'SFixed' int frac+mac s x y = s + (x * y)+@++But with constraint synonyms, you can write the type signature like this:++@+mac1 :: 'NumSFixedC' int frac+    => 'SFixed' int frac+    -> 'SFixed' int frac+    -> 'SFixed' int frac+    -> 'SFixed' int frac+mac1 s x y = s + (x * y)+@++Where 'NumSFixedC' refers to the @Constraints@ needed by the operators of+the 'Num' class for the 'SFixed' datatype.++Although the number of constraints for the @mac@ function defined earlier might+be considered small, here is a \"this way lies madness\" example where you+really want to use constraint kinds:++@+mac2 :: ( 'GHC.TypeLits.KnownNat' frac1+        , 'GHC.TypeLits.KnownNat' frac2+        , 'GHC.TypeLits.KnownNat' frac3+        , 'GHC.TypeLits.KnownNat' (Max frac1 frac2)+        , 'GHC.TypeLits.KnownNat' (int1 + frac1)+        , 'GHC.TypeLits.KnownNat' (int2 + frac2)+        , 'GHC.TypeLits.KnownNat' (int3 + frac3)+        , 'GHC.TypeLits.KnownNat' (frac1 + frac2)+        , 'GHC.TypeLits.KnownNat' (Max (frac1 + frac2) frac3)+        , 'GHC.TypeLits.KnownNat' (((int1 + int2) + (frac1 + frac2)) + (int3 + frac3))+        , 'GHC.TypeLits.KnownNat' ((int1 + int2) + (frac1 + frac2))+        , 'GHC.TypeLits.KnownNat' (1 + Max (int1 + frac1) (int2 + frac2))+        , 'GHC.TypeLits.KnownNat' (1 + Max (int1 + int2) int3 + Max (frac1 + frac2) frac3)+        , 'GHC.TypeLits.KnownNat' ((1 + Max int1 int2) + Max frac1 frac2)+        , 'GHC.TypeLits.KnownNat' ((1 + Max ((int1 + int2) + (frac1 + frac2)) (int3 + frac3)))+        , ((int1 + frac1) + (int2 + frac2)) ~ ((int1 + int2) + (frac1 + frac2))+        , (((int1 + int2) + int3) + ((frac1 + frac2) + frac3)) ~ (((int1 + int2) + (frac1 + frac2)) + (int3 + frac3))+        )+     => 'SFixed' int1 frac1+     -> 'SFixed' int2 frac2+     -> 'SFixed' int3 frac3+     -> 'SFixed' (1 + Max (int1 + int2) int3) (Max (frac1 + frac2) frac3)+mac2 x y s = (x \`mul\` y) \`add\` s+@++Which, with the proper constraint kinds can be reduced to:++@+mac3 :: ( 'ENumSFixedC' int1 frac1 int2 frac2+        , 'ENumSFixedC' (int1 + int2) (frac1 + frac2) int3 frac3+        )+     => 'SFixed' int1 frac1+     -> 'SFixed' int2 frac2+     -> 'SFixed' int3 frac3+     -> 'SFixed' (1 + Max (int1 + int2) int3) (Max (frac1 + frac2) frac3)+mac3 x y s = (x \`mul\` y) \`add\` s+@+-}++-- | Constraint for the 'ExtendingNum' instance of 'Fixed'+type ENumFixedC rep int1 frac1 int2 frac2+  = ( Bounded  (rep ((1 + Max int1 int2) + Max frac1 frac2))+    , Num      (rep ((1 + Max int1 int2) + Max frac1 frac2))+    , Bits     (rep ((1 + Max int1 int2) + Max frac1 frac2))+    , ExtendingNum (rep (int1 + frac1)) (rep (int2 + frac2))+    , MResult (rep (int1 + frac1)) (rep (int2 + frac2)) ~+              rep ((int1 + int2) + (frac1 + frac2))+    , KnownNat int1+    , KnownNat int2+    , KnownNat frac1+    , KnownNat frac2+    , Resize   rep+    )++-- | Constraint for the 'ExtendingNum' instance of 'SFixed'+type ENumSFixedC int1 frac1 int2 frac2+  = ( KnownNat (int2 + frac2)+    , KnownNat (1 + Max int1 int2 + Max frac1 frac2)+    , KnownNat (Max frac1 frac2)+    , KnownNat (1 + Max int1 int2)+    , KnownNat (int1 + frac1)+    , KnownNat frac2+    , KnownNat int2+    , KnownNat frac1+    , KnownNat int1+    )++-- | Constraint for the 'ExtendingNum' instance of 'UFixed'+type ENumUFixedC int1 frac1 int2 frac2 =+     ENumSFixedC int1 frac1 int2 frac2++-- | When used in a polymorphic setting, use the following+-- <Clash-Sized-Fixed.html#constraintsynonyms Constraint synonyms> for less+-- verbose type signatures:+--+-- * @'ENumFixedC'  rep frac1 frac2 size1 size2@ for: 'Fixed'+-- * @'ENumSFixedC' int1 frac1 int2 frac2@       for: 'SFixed'+-- * @'ENumUFixedC' int1 frac1 int2 frac2@       for: 'UFixed'+instance ENumFixedC rep int1 frac1 int2 frac2 =>+  ExtendingNum (Fixed rep int1 frac1) (Fixed rep int2 frac2) where+  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 = natToNum @(Max frac1 frac2) - natToNum @frac1 :: Int+        f1R = shiftL (resize f1) sh1 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))+        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 = natToNum @(Max frac1 frac2) - natToNum @frac1 :: Int+        f1R = shiftL (resize f1) sh1 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))+        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) =+               Fixed rep (int1 + int2) (frac1 + frac2)+  mul (Fixed fRep1) (Fixed fRep2) = Fixed (mul fRep1 fRep2)++-- | Constraint for the 'Num' instance of 'Fixed'+type NumFixedC rep int frac+  = ( SaturatingNum (rep (int + frac))+    , ExtendingNum (rep (int + frac)) (rep (int + frac))+    , MResult (rep (int + frac)) (rep (int + frac)) ~+              rep ((int + int) + (frac + frac))+    , BitSize (rep ((int + int) + (frac + frac))) ~+              (int + ((int + frac) + frac))+    , BitPack (rep ((int + int) + (frac + frac)))+    , Bits    (rep ((int + int) + (frac + frac)))+    , BitPack (rep (int + frac))+    , Bits    (rep (int + frac))+    , Integral (rep (int + frac))+    , Resize  rep+    , Typeable rep+    , KnownNat int+    , KnownNat frac+    )++-- | Constraint for the 'Num' instance of 'SFixed'+type NumSFixedC int frac =+  ( KnownNat ((int + int) + (frac + frac))+  , KnownNat (frac + frac)+  , KnownNat (int + int)+  , KnownNat (int + frac)+  , KnownNat frac+  , KnownNat int+  )++-- | Constraint for the 'Num' instance of 'UFixed'+type NumUFixedC int frac =+     NumSFixedC int frac++-- | The operators of this instance saturate on overflow, and use truncation as+-- the rounding method.+--+-- When used in a polymorphic setting, use the following+-- <Clash-Sized-Fixed.html#constraintsynonyms Constraint synonyms> for less+-- verbose type signatures:+--+-- * @'NumFixedC' frac rep size@ for: @'Fixed' frac rep size@+-- * @'NumSFixedC' int frac@     for: @'SFixed' int frac@+-- * @'NumUFixedC' int frac@     for: @'UFixed' int frac@+instance (NumFixedC rep int frac) => Num (Fixed rep int frac) where+  (+)              = boundedAdd+  (*)              = boundedMul+  (-)              = boundedSub+  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 = 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)), 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)++instance (Lift (rep (int + frac)), KnownNat frac, KnownNat int, Typeable rep) =>+  Lift (Fixed rep int frac) where+  lift f@(Fixed fRep) = sigE [| Fixed fRep |]+                          (decFixed (typeRep (asRepProxy f))+                                    (natVal (asIntProxy f))+                                    (natVal f))+  liftTyped = liftTypedFromUntyped++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)+                            , litT (numTyLit f)+                            ]++-- | Constraint for the 'resizeF' function+type ResizeFC rep int1 frac1 int2 frac2+  = ( Resize   rep+    , Ord      (rep (int1 + frac1))+    , Num      (rep (int1 + frac1))+    , Bits     (rep (int1 + frac1))+    , Bits     (rep (int2 + frac2))+    , Bounded  (rep (int2 + frac2))+    , KnownNat int1+    , KnownNat frac1+    , KnownNat int2+    , KnownNat frac2+    )++-- | Constraint for the 'resizeF' function, specialized for 'SFixed'+type ResizeSFC int1 frac1 int2 frac2+  = ( KnownNat int1+    , KnownNat frac1+    , KnownNat int2+    , KnownNat frac2+    , KnownNat (int2 + frac2)+    , KnownNat (int1 + frac1)+    )++-- | Constraint for the 'resizeF' function, specialized for 'UFixed'+type ResizeUFC int1 frac1 int2 frac2 =+     ResizeSFC int1 frac1 int2 frac2++{-# INLINE resizeF #-}+-- | Saturating resize operation, truncates for rounding+--+-- >>> 0.8125 :: SFixed 3 4+-- 0.8125+-- >>> resizeF (0.8125 :: SFixed 3 4) :: SFixed 2 3+-- 0.75+-- >>> 3.4 :: SFixed 3 4+-- 3.375+-- >>> resizeF (3.4 :: SFixed 3 4) :: SFixed 2 3+-- 1.875+-- >>> maxBound :: SFixed 2 3+-- 1.875+--+-- When used in a polymorphic setting, use the following+-- <#constraintsynonyms Constraint synonyms> for less verbose type signatures:+--+-- * @'ResizeFC' rep int1 frac1 int2 frac2@ for:+--   @'Fixed' rep int1 frac1 -> 'Fixed' rep int2 frac2@+--+-- * @'ResizeSFC' int1 frac1 int2 frac2@ for:+--   @'SFixed' int1 frac1 -> 'SFixed' int2 frac2@+--+-- * @'ResizeUFC' rep int1 frac1 int2 frac2@ for:+--   @'UFixed' int1 frac1 -> 'UFixed' int2 frac2@+resizeF+  :: forall rep int1 frac1 int2 frac2+   . ResizeFC rep int1 frac1 int2 frac2+  => Fixed rep int1 frac1+  -> Fixed rep int2 frac2+resizeF (Fixed fRep) = Fixed sat+  where+    fMin  = minBound :: rep (int2 + frac2)+    fMax  = maxBound :: rep (int2 + frac2)+    argSZ = natToInteger @(int1 + frac1)+    resSZ = natToInteger @(int2 + 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+    sat = if argSZ <= resSZ+            -- if the argument is smaller than the result, resize before shift+            then if argFracSZ <= resFracSZ+                    then resize fRep `shiftL` (resFracSZ - argFracSZ)+                    else resize fRep `shiftR` (argFracSZ - resFracSZ)+            -- if the argument is bigger than the result, shift before resize+            else let mask = complement (resize fMax) :: rep (int1 + frac1)+                 in if argFracSZ <= resFracSZ+                       then let shiftedL         = fRep `shiftL`+                                                   (resFracSZ - argFracSZ)+                                shiftedL_masked  = shiftedL .&. mask+                                shiftedL_resized = resize shiftedL+                            in if fRep >= 0+                                  then if shiftedL_masked == 0+                                          then shiftedL_resized+                                          else fMax+                                  else if shiftedL_masked == mask+                                          then shiftedL_resized+                                          else fMin+                       else let shiftedR         = fRep `shiftR`+                                                   (argFracSZ - resFracSZ)+                                shiftedR_masked  = shiftedR .&. mask+                                shiftedR_resized = resize shiftedR+                            in if fRep >= 0+                                  then if shiftedR_masked == 0+                                          then shiftedR_resized+                                          else fMax+                                  else if shiftedR_masked == mask+                                          then shiftedR_resized+                                          else fMin++-- | Convert, at compile-time, a 'Double' /constant/ to a 'Fixed'-point /literal/.+-- The conversion saturates on overflow, and uses truncation as its rounding+-- method.+--+-- So when you type:+--+-- @+-- n = $$('fLit' pi) :: 'SFixed' 4 4+-- @+--+-- The compiler sees:+--+-- @+-- n = 'Fixed' (fromInteger 50) :: 'SFixed' 4 4+-- @+--+-- Upon evaluation you see that the value is rounded / truncated in accordance+-- to the fixed point representation:+--+-- >>> n+-- 3.125+--+-- Further examples:+--+-- >>> sin 0.5 :: Double+-- 0.479425538604203+-- >>> $$(fLit (sin 0.5)) :: SFixed 1 8+-- 0.4765625+-- >>> atan 0.2 :: Double+-- 0.19739555984988078+-- >>> $$(fLit (atan 0.2)) :: SFixed 1 8+-- 0.1953125+-- >>> $$(fLit (atan 0.2)) :: SFixed 1 20+-- 0.19739532470703125+fLit+  :: forall rep int frac size+   . ( size ~ (int + frac)+     , KnownNat frac+     , Bounded (rep size)+     , Integral (rep size) )+  => Double+  -> TH.Code Q (Fixed rep int frac)+fLit a = [|| Fixed (fromInteger sat) ||]+  where+    rMax      = toInteger (maxBound :: rep size)+    rMin      = toInteger (minBound :: rep size)+    sat       = if truncated > rMax+                   then rMax+                   else if truncated < rMin+                           then rMin+                           else truncated+    truncated = truncate shifted :: Integer+    shifted   = a * (2 ^ (natToInteger @frac))++-- | Convert, at run-time, a 'Double' to a 'Fixed'-point.+--+-- __NB__: This function is /not/ synthesizable+--+-- = Creating data-files #creatingdatafiles#+--+-- 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+--+-- 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,+-- @createRomFile@, which uses 'fLitR':+--+-- @createRomFile.hs@:+--+-- @+-- module Main where+--+-- import Clash.Prelude+-- import Clash.Prelude.ROM.File+-- import System.Environment+-- import qualified Data.List as L+--+-- 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+--       fes = L.map convert ds+--   writeFile fileW ('Clash.Prelude.ROM.File.memFile' Nothing fes)+--+-- toSFixed8_8 :: Double -> SFixed 8 8+-- toSFixed8_8 = 'fLitR'+--+-- main :: IO ()+-- main = do+--   [fileR,fileW] <- getArgs+--   createRomFile toSFixed8_8 fileR fileW+-- @+--+-- We then compile this to an executable:+--+-- > $ 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 ASCII-encoded+-- binary data:+--+-- > $ ./createRomFile Data.txt Data.bin+--+-- Which results in a @Data.bin@ file containing:+--+-- > 0000000100110011+-- > 0000001000000000+-- > 0000001100000000+-- > 0000010000000000+-- > 1111111100000000+-- > 1111111000000000+-- > 1111110010000000+-- > 1111110000000000+--+-- We can then use this @Data.bin@ file in for our ROM:+--+-- @+-- romF :: Unsigned 3 -> Unsigned 3 -> SFixed 8 8+-- romF rowAddr colAddr = 'unpack'+--                      $ 'Clash.Prelude.ROM.File.asyncRomFile' d8 "Data.bin" ((rowAddr * 4) + colAddr)+-- @+--+-- And see that it works as expected:+--+-- @+-- __>>> romF 1 2__+-- -3.5+-- __>>> romF 0 0__+-- 1.19921875+-- @+--+-- == Using Template Haskell+--+-- 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/exts/template_haskell.html Template Haskell>.+-- For this we first create a module @CreateRomFileTH.hs@:+--+-- @+-- module CreateRomFileTH (romDataFromFile) where+--+-- import Clash.Prelude+-- 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 :: 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+--       fes = L.map convert ds+--   writeFile fileW ('Clash.Prelude.ROM.File.memFile' Nothing fes)+--+-- romDataFromFile :: BitPack a => (Double -> a) -> String -> ExpQ+-- romDataFromFile convert fileR = do+--   let fileW = fileR L.++ ".bin"+--   qRunIO (createRomFile convert fileR fileW)+--   litE (stringL fileW)+-- @+--+-- Instead of first converting @Data.txt@ to @Data.bin@, we will now use the+-- @romDataFromFile@ function to convert @Data.txt@ to a new file in the proper+-- format at compile-time of our new @romF'@ function:+--+-- @+-- import Clash.Prelude+-- import CreateRomFileTH+--+-- romF' :: Unsigned 3 -> Unsigned 3 -> SFixed 8 8+-- romF' rowAddr colAddr = unpack $+--   asyncRomFile d8+--                $(romDataFromFile (fLitR :: Double -> SFixed 8 8) "Data.txt") -- Template Haskell splice+--                ((rowAddr * 4) + colAddr)+-- @+--+-- And see that it works just like the @romF@ function from earlier:+--+-- @+-- __>>> romF' 1 2__+-- -3.5+-- __>>> romF' 0 0__+-- 1.19921875+-- @+fLitR+  :: forall rep int frac size+   . ( size ~ (int + frac)+     , KnownNat frac+     , Bounded (rep size)+     , Integral (rep size))+  => Double+  -> Fixed rep int frac+fLitR a = Fixed (fromInteger sat)+  where+    rMax      = toInteger (maxBound :: rep size)+    rMin      = toInteger (minBound :: rep size)+    sat       = if truncated > rMax+                   then rMax+                   else if truncated < rMin+                           then rMin+                           else truncated+    truncated = truncate shifted :: Integer+    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   = natToNum @frac+        res' = shiftR res sh+    in  Fixed (resize res')++  satMul SatBound (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))+                         _ -> case msb rL of+                                0 -> maxBound+                                _ -> minBound+          False -> case rL of+                     0 -> unpack (resize (shiftR rR sh))+                     _ -> maxBound++  satMul SatZero (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))+                         _ -> 0+          False -> case rL of+                     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      = 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))+                         _ -> case msb rL of+                                0 -> maxBound+                                _ -> 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+    , Integral (rep (((int1 + frac2) + 1) + (int2 + frac1)))+    , Bits     (rep (((int1 + frac2) + 1) + (int2 + frac1)))+    , KnownNat int1+    , KnownNat frac1+    , KnownNat int2+    , KnownNat frac2+    )++-- | Constraint for the 'divide' function, specialized for 'SFixed'+type DivideSC int1 frac1 int2 frac2+  = ( KnownNat (((int1 + frac2) + 1) + (int2 + frac1))+    , KnownNat frac2+    , KnownNat int2+    , KnownNat frac1+    , KnownNat int1+    )++-- | Constraint for the 'divide' function, specialized for 'UFixed'+type DivideUC int1 frac1 int2 frac2 =+     DivideSC int1 frac1 int2 frac2++-- | Fixed point division+--+-- When used in a polymorphic setting, use the following+-- <#constraintsynonyms Constraint synonyms> for less verbose type signatures:+--+-- * @'DivideC' rep int1 frac1 int2 frac2@ for:+--   @'Fixed' rep int1 frac1 -> 'Fixed' rep int2 frac2 -> 'Fixed' rep (int1 + frac2 + 1) (int2 + frac1)@+--+-- * @'DivideSC' rep int1 frac1 int2 frac2@ for:+--   @'SFixed' int1 frac1 -> 'SFixed' int2 frac2 -> 'SFixed' (int1 + frac2 + 1) (int2 + frac1)@+--+-- * @'DivideUC' rep int1 frac1 int2 frac2@ for:+--   @'UFixed' int1 frac1 -> 'UFixed' int2 frac2 -> 'UFixed' (int1 + frac2 + 1) (int2 + frac1)@+divide+  :: DivideC rep int1 frac1 int2 frac2+  => Fixed rep int1 frac1+  -> Fixed rep int2 frac2+  -> Fixed rep (int1 + frac2 + 1) (int2 + frac1)+divide (Fixed fr1) fx2@(Fixed fr2) =+  let int2  = fromInteger (natVal (asIntProxy fx2))+      frac2 = fromInteger (natVal fx2)+      fr1'  = resize fr1+      fr2'  = resize fr2+      fr1SH = shiftL fr1' ((int2 + frac2))+      res   = fr1SH `quot` fr2'+  in  Fixed res++-- | Constraint for the 'Fractional' instance of 'Fixed'+type FracFixedC rep int frac+  = ( NumFixedC rep int frac+    , DivideC   rep int frac int frac+    )++-- | Constraint for the 'Fractional' instance of 'SFixed'+type FracSFixedC int frac+  = ( NumSFixedC int frac+    , KnownNat ((int + frac + 1) + (int + frac))+    )++-- | Constraint for the 'Fractional' instance of 'UFixed'+type FracUFixedC int frac+  = FracSFixedC int frac++-- | The operators of this instance saturate on overflow, and use truncation as+-- the rounding method.+--+-- When used in a polymorphic setting, use the following+-- <Clash-Sized-Fixed.html#constraintsynonyms Constraint synonyms> for less+-- verbose type signatures:+--+-- * @'FracFixedC' frac rep size@ for: @'Fixed' frac rep size@+-- * @'FracSFixedC' int frac@     for: @'SFixed' int frac@+-- * @'FracUFixedC' int frac@     for: @'UFixed' int frac@+instance FracFixedC rep int frac => Fractional (Fixed rep int frac) where+  f1 / f2        = resizeF (divide f1 f2)+  recip fx       = resizeF (divide (1 :: Fixed rep int frac) fx)+  fromRational r = res+    where+      res  = Fixed (fromInteger sat)+      sat  = if res' > rMax+                then rMax+                else if res' < rMin then rMin else res'++      rMax = toInteger (maxBound :: rep (int + frac))+      rMin = toInteger (minBound :: rep (int + frac))+      res' = n `div` d++      frac = fromInteger (natVal res)+      n    = numerator   r `shiftL` (2 * frac)+      d    = denominator r `shiftL` frac++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 => 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)+      frMask = fromInteger $ (1 `shiftL` fracShift f) - 1+      offset = if f < 0 && fRep .&. frMask /= 0 then 1 else 0
+ src/Clash/Sized/Index.hs view
@@ -0,0 +1,43 @@+{-|+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 Trustworthy #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise  #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Sized.Index+  (Index, bv2i, fromSNat)+where++import GHC.TypeLits (KnownNat, type (^))+import GHC.TypeLits.Extra (CLog) -- documentation only++import Clash.Sized.Internal.BitVector (BitVector)+import Clash.Sized.Internal.Index++-- | An alternative implementation of 'Clash.Class.BitPack.unpack' for the+-- 'Index' data type; for when you know the size of the 'BitVector' and want+-- to determine the size of the 'Index'.+--+-- That is, the type of 'Clash.Class.BitPack.unpack' is:+--+-- @+-- __unpack__ :: 'BitVector' ('CLog' 2 n) -> 'Index' n+-- @+--+-- And is useful when you know the size of the 'Index', and want to get a value+-- from a 'BitVector' that is large enough (@CLog 2 n@) enough to hold an+-- 'Index'. Note that 'Clash.Class.BitPack.unpack' can fail at /run-time/ when+-- the value inside the 'BitVector' is higher than 'n-1'.+--+-- 'bv2i' on the other hand will /never/ fail at run-time, because the+-- 'BitVector' argument determines the size.+bv2i :: KnownNat n => BitVector n -> Index (2^n)+bv2i = unpack#
+ 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
@@ -0,0 +1,1395 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2019     , Gergő Érdi+                  2016-2019, Myrtle Software Ltd,+                  2021-2025, QBayLogic B.V.+                  2023     , Nadia Chambers+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE Unsafe #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}+{-# OPTIONS_HADDOCK show-extensions not-home #-}++module Clash.Sized.Internal.BitVector+  ( -- * Bit+    Bit (..)+    -- ** Construction+  , high+  , low+    -- ** Type classes+    -- *** Eq+  , eq##+  , neq##+    -- *** Ord+  , lt##+  , ge##+  , gt##+  , le##+    -- *** Enum+  , toEnum##+    -- *** Num+  , fromInteger##+    -- *** Bits+  , and##+  , or##+  , xor##+  , complement##+    -- *** BitPack+  , pack#+  , unpack#+    -- * BitVector+  , BitVector (..)+    -- ** Accessors+  , size#+  , maxIndex#+    -- ** Construction+  , bLit+  , hLit+  , oLit+  , undefined#+    -- ** Concatenation+  , (++#)+    -- ** Reduction+  , reduceAnd#+  , reduceOr#+  , reduceXor#+    -- ** Indexing+  , index#+  , replaceBit#+  , setSlice#+  , slice#+  , split#+  , msb#+  , lsb#+    -- ** Type classes+    -- **** Eq+  , eq#+  , neq#+  , isLike#+    -- *** Ord+  , lt#+  , ge#+  , gt#+  , le#+    -- *** Enum+  , toEnum#+  , fromEnum#+    -- *** Enum (not synthesizable)+  , enumFrom#+  , enumFromThen#+  , enumFromTo#+  , enumFromThenTo#+    -- *** Bounded+  , minBound#+  , maxBound#+    -- *** Num+  , (+#)+  , (-#)+  , (*#)+  , negate#+  , fromInteger#+    -- *** ExtendingNum+  , plus#+  , minus#+  , times#+    -- *** Integral+  , quot#+  , rem#+  , toInteger#+    -- *** Bits+  , and#+  , or#+  , xor#+  , complement#+  , shiftL#+  , shiftR#+  , rotateL#+  , rotateR#+  , popCountBV+    -- *** FiniteBits+  , countLeadingZerosBV+  , countTrailingZerosBV+    -- *** Resize+  , truncateB#+    -- *** QuickCheck+  , shrinkSizedUnsigned+  -- ** Other+  , 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               (Default (..))+import Data.Either                (isLeft)+import Data.Proxy                 (Proxy (..))+import Data.Typeable              (Typeable, typeOf)+import GHC.Generics               (Generic)+import Data.Maybe                 (fromMaybe)+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+  (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, natToNum)+import Clash.Sized.Internal (formatRange)+import Clash.XException+  (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+--+-- * 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 fields, 'unsafeMask' and 'unsafeToNatural', are not+    -- synthesizable.+    BV { unsafeMask      :: !Natural+       , unsafeToNatural :: !Natural+       }+  deriving (Data, Generic)++{-# ANN BV hasBlackBox #-}++-- * 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 fields, 'unsafeMask#' and 'unsafeToInteger#', are not+  -- synthesizable.+  Bit { unsafeMask#      :: {-# unpack #-} !Word+      , unsafeToInteger# :: {-# unpack #-} !Word+      }+  deriving (Data, Generic)++{-# ANN Bit hasBlackBox #-}++-- * Constructions+-- ** Initialisation+{-# OPAQUE high #-}+{-# ANN high hasBlackBox #-}+-- | logic '1'+high :: Bit+high = Bit 0 1++{-# OPAQUE low #-}+{-# ANN low hasBlackBox #-}+-- | logic '0'+low :: Bit+low = Bit 0 0++-- ** Instances+instance NFData Bit where+  rnf (Bit m i) = rnf m `seq` rnf i `seq` ()+  {-# NOINLINE rnf #-}++instance Show Bit where+  show (Bit 0 b) =+    case testBit b 0 of+      True  -> "1"+      False -> "0"+  show (Bit _ _) = "."++instance ShowX Bit where+  showsPrecX = showsPrecXWith showsPrec++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## $(litE (WordPrimL (toInteger m))) i |]+  {-# NOINLINE lift #-}+  liftTyped = liftTypedFromUntyped++instance Eq Bit where+  (==) = eq##+  (/=) = neq##++eq## :: Bit -> Bit -> Bool+eq## b1 b2 = eq# (pack# b1) (pack# b2)+{-# OPAQUE eq## #-}+{-# ANN eq## hasBlackBox #-}++neq## :: Bit -> Bit -> Bool+neq## b1 b2 = neq# (pack# b1) (pack# b2)+{-# OPAQUE neq## #-}+{-# ANN neq## hasBlackBox #-}++instance Ord Bit where+  (<)  = lt##+  (<=) = le##+  (>)  = gt##+  (>=) = ge##++lt##,ge##,gt##,le## :: Bit -> Bit -> Bool+lt## b1 b2 = lt# (pack# b1) (pack# b2)+{-# OPAQUE lt## #-}+{-# ANN lt## hasBlackBox #-}+ge## b1 b2 = ge# (pack# b1) (pack# b2)+{-# OPAQUE ge## #-}+{-# ANN ge## hasBlackBox #-}+gt## b1 b2 = gt# (pack# b1) (pack# b2)+{-# OPAQUE gt## #-}+{-# ANN gt## hasBlackBox #-}+le## b1 b2 = le# (pack# b1) (pack# b2)+{-# OPAQUE le## #-}+{-# ANN le## hasBlackBox #-}++instance Enum Bit where+  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++instance Default Bit where+  def = low++instance Num Bit where+  (+)         = xor##+  (-)         = xor##+  (*)         = and##+  negate      = id+  abs         = id+  signum b    = b+  fromInteger = fromInteger## 0##++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++instance Integral Bit where+  quot    a _ = a+  rem     _ _ = low+  div     a _ = a+  mod     _ _ = low+  quotRem n _ = (n,low)+  divMod  n _ = (n,low)+  toInteger b = if eq## b low then 0 else 1++instance Bits Bit where+  (.&.)             = and##+  (.|.)             = or##+  xor               = xor##+  complement        = complement##+  zeroBits          = low+  bit i             = if i == 0 then high else low+  setBit b i        = if i == 0 then high else b+  clearBit b i      = if i == 0 then low  else b+  complementBit b i = if i == 0 then complement## b else b+  testBit b i       = if i == 0 then eq## b high else False+  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++instance FiniteBits Bit where+  finiteBitSize _      = 1+  countLeadingZeros b  = if eq## b low then 1 else 0+  countTrailingZeros b = if eq## b low then 1 else 0++and##, or##, xor## :: Bit -> Bit -> Bit+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## (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## (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## (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 (W# m) (W# b)) = BV (NS m) (NS b)+{-# OPAQUE pack# #-}+{-# ANN pack# hasBlackBox #-}++unpack# :: BitVector 1 -> Bit+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+  rnf (BV i m) = rnf i `seq` rnf m `seq` ()+  {-# NOINLINE rnf #-}+  -- NOINLINE is needed so that Clash doesn't trip on the "BitVector ~# Integer"+  -- coercion++instance KnownNat n => Show (BitVector n) where+  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)++    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 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")+-- 0b1001+--+-- __NB__: You can also just write:+--+-- >>> 0b1001 :: BitVector 4+-- 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'))+-- 0b1111+--+-- Also 'bLit' can handle don't care bits:+--+-- >>> $(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++  iLit = LitE . IntegerL . toInteger+  (n, BV mask value) = read# s :: (Natural, BitVector n)++read# :: String -> (Natural, BitVector n)+read# cs0 = (fromIntegral (length cs1), BV m v)+  where+    cs1 = filter (/= '_') cs0+    (vs, ms) = unzip (map readBit cs1)+    combineBits = foldl (\b a -> b*2+a) 0+    v = combineBits vs+    m = combineBits ms+    readBit c = case c of+      '0' -> (0,0)+      '1' -> (1,0)+      '.' -> (0,1)+      _   -> 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#++{-# 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++{-# 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++instance KnownNat n => Ord (BitVector n) where+  (<)  = lt#+  (>=) = ge#+  (>)  = gt#+  (<=) = le#++lt#,ge#,gt#,le# :: KnownNat n => BitVector n -> BitVector n -> Bool+{-# OPAQUE lt# #-}+{-# ANN lt# hasBlackBox #-}+lt# (BV 0 n) (BV 0 m) = n < m+lt# bv1 bv2 = undefErrorI "<" bv1 bv2+{-# OPAQUE ge# #-}+{-# ANN ge# hasBlackBox #-}+ge# (BV 0 n) (BV 0 m) = n >= m+ge# bv1 bv2 = undefErrorI ">=" bv1 bv2+{-# OPAQUE gt# #-}+{-# ANN gt# hasBlackBox #-}+gt# (BV 0 n) (BV 0 m) = n > m+gt# bv1 bv2 = undefErrorI ">" bv1 bv2+{-# OPAQUE le# #-}+{-# ANN le# hasBlackBox #-}+le# (BV 0 n) (BV 0 m) = n <= m+le#  bv1 bv2 = undefErrorI "<=" bv1 bv2++-- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and+-- 'enumFromThenTo', are not synthesizable.+instance KnownNat n => Enum (BitVector n) where+  succ           = (+# fromInteger# 0 1)+  pred           = (-# fromInteger# 0 1)+  toEnum         = toEnum#+  fromEnum       = fromEnum#+  enumFrom       = enumFrom#+  enumFromThen   = enumFromThen#+  enumFromTo     = enumFromTo#+  enumFromThenTo = enumFromThenTo#++toEnum# :: forall n. KnownNat n => Int -> BitVector n+toEnum# = fromInteger# 0 . toInteger+{-# OPAQUE toEnum# #-}+{-# ANN toEnum# hasBlackBox #-}++fromEnum# :: forall n. KnownNat n => BitVector n -> Int+fromEnum# = fromEnum . toInteger#+{-# OPAQUE fromEnum# #-}+{-# ANN fromEnum# hasBlackBox #-}++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# #-}++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# #-}++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#++minBound# :: BitVector n+minBound# = BV 0 0+{-# OPAQUE minBound# #-}+{-# ANN minBound# hasBlackBox #-}++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+  (+)         = (+#)+  (-)         = (-#)+  (*)         = (*#)+  negate      = negate#+  abs         = id+  signum bv   = resizeBV (pack# (reduceOr# bv))+  fromInteger = fromInteger# 0++(+#),(-#),(*#) :: forall n . KnownNat n => BitVector n -> BitVector n -> BitVector n+{-# OPAQUE (+#) #-}+{-# ANN (+#) hasBlackBox #-}+(+#) = go+  where+    go (BV 0 i) (BV 0 j) = BV 0 (addMod m i j)+    go bv1 bv2 = undefErrorI "+" bv1 bv2++    m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))++{-# OPAQUE (-#) #-}+{-# ANN (-#) hasBlackBox #-}+(-#) = go+  where+    go (BV 0 i) (BV 0 j) = BV 0 (subMod m i j)+    go bv1 bv2 = undefErrorI "-" bv1 bv2++    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# = go+ where+  go (BV 0 i) = BV 0 (negateMod m i)+  go bv = undefErrorU "negate" bv++  m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))++{-# OPAQUE fromInteger# #-}+{-# ANN fromInteger# hasBlackBox #-}+fromInteger# :: KnownNat n => Natural -> Integer -> BitVector n+fromInteger# m i = sz `seq` mx+  where+    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)+  add  = plus#+  sub = minus#+  type MResult (BitVector m) (BitVector n) = BitVector (m + n)+  mul = times#++{-# 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 "add" bv1 bv2++{-# OPAQUE minus# #-}+{-# ANN minus# hasBlackBox #-}+minus# :: forall m n . (KnownNat m, KnownNat n) => BitVector m -> BitVector n+                                                -> BitVector (Max m n + 1)+minus# = go+ where+  go (BV 0 a) (BV 0 b) = BV 0 (subMod m a b)+  go bv1 bv2 = undefErrorP "sub" bv1 bv2++  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 "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#+  div         = quot#+  mod         = rem#+  quotRem n d = (n `quot#` d,n `rem#` d)+  divMod  n d = (n `quot#` d,n `rem#` d)+  toInteger   = toInteger#++quot#,rem# :: KnownNat n => BitVector n -> BitVector n -> BitVector n+{-# OPAQUE quot# #-}+{-# ANN quot# hasBlackBox #-}+quot# (BV 0 i) (BV 0 j) = BV 0 (i `quot` j)+quot# bv1 bv2 = undefErrorP "quot" bv1 bv2+{-# OPAQUE rem# #-}+{-# ANN rem# hasBlackBox #-}+rem# (BV 0 i) (BV 0 j) = BV 0 (i `rem` j)+rem# bv1 bv2 = undefErrorP "rem" bv1 bv2++{-# OPAQUE toInteger# #-}+{-# ANN toInteger# hasBlackBox #-}+toInteger# :: KnownNat n => BitVector n -> Integer+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#+  xor               = xor#+  complement        = complement#+  zeroBits          = 0+  bit i             = replaceBit# 0 i high+  setBit v i        = replaceBit# v i high+  clearBit v i      = replaceBit# v i low+  complementBit v i = replaceBit# v i (complement## (index# v i))+  testBit v i       = eq## (index# v i) high+  bitSizeMaybe v    = Just (size# v)+  bitSize           = size#+  isSigned _        = False+  shiftL v i        = shiftL# v i+  shiftR v i        = shiftR# v i+  rotateL v i       = rotateL# v i+  rotateR v i       = rotateR# v i+  popCount bv       = fromInteger (I.toInteger# (popCountBV (bv ++# (0 :: BitVector 1))))++instance KnownNat n => FiniteBits (BitVector n) where+  finiteBitSize       = size#+  countLeadingZeros   = fromInteger . I.toInteger# . countLeadingZerosBV+  countTrailingZeros  = fromInteger . I.toInteger# . countTrailingZerosBV++countLeadingZerosBV :: KnownNat n => BitVector n -> I.Index (n+1)+countLeadingZerosBV = V.foldr (\l r -> if eq## l low then 1 + r else 0) 0 . V.bv2v+{-# INLINE countLeadingZerosBV #-}++countTrailingZerosBV :: KnownNat n => BitVector n -> I.Index (n+1)+countTrailingZerosBV = V.foldl (\l r -> if eq## r low then 1 + l else 0) 0 . V.bv2v+{-# INLINE countTrailingZerosBV #-}++{-# OPAQUE reduceAnd# #-}+{-# ANN reduceAnd# hasBlackBox #-}+reduceAnd# :: KnownNat n => BitVector n -> Bit+reduceAnd# bv@(BV 0 i) = Bit 0 (W# (int2Word# (dataToTag# check)))+  where+    check = i == maxI++    sz    = natVal bv+    maxI  = (2 ^ sz) - 1+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++    sz    = natVal bv+    maxI  = (2 ^ sz) - 1++{-# OPAQUE reduceOr# #-}+{-# ANN reduceOr# hasBlackBox #-}+reduceOr# :: KnownNat n => BitVector n -> Bit+reduceOr# (BV 0 i) = Bit 0 (W# (int2Word# (dataToTag# check)))+  where+    check = i /= 0+reduceOr# bv@(BV m i) | defI /= 0 = Bit 0 1+                      | otherwise = Bit 1 0+ where+  complementN = complementMod $ natVal bv+  defI = i .&. (complementN m)++{-# OPAQUE reduceXor# #-}+{-# ANN reduceXor# hasBlackBox #-}+reduceXor# :: KnownNat n => BitVector n -> Bit+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+{-# OPAQUE size# #-}+{-# ANN size# hasBlackBox #-}+size# :: KnownNat n => BitVector n -> Int+size# bv = fromIntegral (natVal bv)++{-# OPAQUE maxIndex# #-}+{-# ANN maxIndex# hasBlackBox #-}+maxIndex# :: KnownNat n => BitVector n -> Int+maxIndex# bv = fromIntegral (natVal bv) - 1++-- ** Indexing+{-# OPAQUE index# #-}+{-# ANN index# hasBlackBox #-}+index# :: KnownNat n => BitVector n -> Int -> Bit+index# bv@(BV m v) i+    | i >= 0 && i < sz = Bit (W# (int2Word# (dataToTag# (testBit m i))))+                             (W# (int2Word# (dataToTag# (testBit v i))))+    | otherwise        = err+  where+    sz  = fromIntegral (natVal bv)+    err = error $ concat [ "(!): "+                         , show i+                         , " is out of range "+                         , formatRange 0 (sz - 1)+                         ]++{-# OPAQUE msb# #-}+{-# ANN msb# hasBlackBox #-}+-- | MSB+msb# :: forall n . KnownNat n => BitVector n -> Bit+msb# (BV m v)+  = Bit (msbN m)+        (msbN v)+ where+  !(NS i#) = natVal (Proxy @n)++  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 (W# (int2Word# (dataToTag# (testBit m 0))))+                    (W# (int2Word# (dataToTag# (testBit v 0))))++{-# 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')+  where+    m' = snatToInteger m+    n' = snatToNum n++    mask = 2 ^ (m' + 1) - 1++-- * Constructions++-- ** Concatenation+{-# 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 = fromIntegral (natVal bv2)+    v1' = naturalShiftL v1 size2+    m1' = naturalShiftL m1 size2++-- * Modifying BitVectors+{-# 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 .|. (naturalFromWord mb `shiftL` i))+                            (if testBit b 0 && mb == 0 then setBit v i else clearBit v i)+    | otherwise        = err+  where+    sz   = fromIntegral (natVal bv)+    err  = error $ concat [ "replaceBit: "+                          , show i+                          , " is out of range "+                          , formatRange 0 (sz - 1)+                          ]++{-# OPAQUE setSlice# #-}+{-# ANN setSlice# hasBlackBox #-}+setSlice#+  :: 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# 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   = 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)))++{-# OPAQUE split# #-}+{-# ANN split# hasBlackBox #-}+split#+  :: forall n m+   . KnownNat n+  => BitVector (m + n)+  -> (BitVector m, BitVector 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# :: 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+    complementN = complementMod (natVal (Proxy @n))++{-# 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+    complementN = complementMod (natVal (Proxy @n))++{-# 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+    complementN = complementMod (natVal (Proxy @n))++{-# 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#+  :: forall n . KnownNat n => BitVector n -> Int -> BitVector n++{-# 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++{-# OPAQUE shiftR# #-}+{-# ANN shiftR# hasBlackBox #-}+shiftR# (BV m v) i+  | i < 0     = error+              $ "'shiftR' undefined for negative number: " ++ show i+  | otherwise = BV (shiftR m i) (shiftR v i)++{-# 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''++          ml    = naturalShiftL msk b'+          mr    = naturalShiftR msk 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++{-# 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 =+  let v = V.bv2v bv+  in  sum (V.map (fromIntegral . pack#) v)+{-# INLINE popCountBV #-}++instance Resize BitVector where+  resize     = resizeBV+  zeroExtend = (0 ++#)+  signExtend = \bv -> (if msb# bv == low then id else complement) 0 ++# bv+  truncateB  = truncateB#++resizeBV :: forall n m . (KnownNat n, KnownNat m) => BitVector n -> BitVector m+resizeBV = case compareSNat @n @m (SNat @n) (SNat @m) of+  SNatLE -> (++#) @n @(m-n) 0+  SNatGT -> truncateB# @m @(n - m)+{-# INLINE resizeBV #-}++truncateB# :: forall a b . KnownNat a => BitVector (a + b) -> BitVector a+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 $(litE (IntegerL (toInteger i))) |] (decBitVector (natVal bv))+  {-# NOINLINE lift #-}+  liftTyped = liftTypedFromUntyped++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+  satAdd SatZero a b =+    let r = plus# a b+    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+           then truncateB# r+           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+           then truncateB# r+           else minBound#++  satMul SatWrap a b = a *# b+  satMul SatZero a b =+    let r       = times# a b+        (rL,rR) = split# r+    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+    in  case rL of+          0 -> rR+          _ -> maxBound#++instance KnownNat n => Arbitrary (BitVector n) where+  arbitrary = arbitraryBoundedIntegral+  shrink    = shrinkSizedUnsigned++-- | 'shrink' for sized unsigned types+shrinkSizedUnsigned :: (KnownNat n, Integral (p n)) => p n -> [p n]+shrinkSizedUnsigned x | natVal x < 2 = case toInteger x of+                                         1 -> [0]+                                         _ -> []+                      -- 'shrinkIntegral' uses "`quot` 2", which for sized types+                      -- less than 2 bits wide results in a division by zero.+                      --+                      -- See: https://github.com/clash-lang/clash-compiler/issues/153+                      | otherwise    = shrinkIntegral x+{-# INLINE shrinkSizedUnsigned #-}++instance KnownNat n => CoArbitrary (BitVector n) where+  coarbitrary = coarbitraryIntegral++type instance Index   (BitVector n) = Int+type instance IxValue (BitVector n) = Bit+instance KnownNat n => Ixed (BitVector n) where+  ix i f bv = replaceBit# bv i <$> f (index# bv i)+++-- error for infix operator+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 :: (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 :: (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 :: 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 :: 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 functions+checkUnpackUndef :: (KnownNat n, Typeable a)+                 => (BitVector n -> a) -- ^ unpack function+                 -> BitVector n -> a+checkUnpackUndef f bv@(BV 0 _) = f bv+checkUnpackUndef _ bv = res+  where+    ty = typeOf res+    res = undefError (show ty ++ ".unpack") [bv]+{-# OPAQUE checkUnpackUndef #-}+{-# ANN checkUnpackUndef hasBlackBox #-}++-- | Create a BitVector with all its bits undefined+undefined# :: forall n . KnownNat n => BitVector n+undefined# =+  let m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))+  in  BV (m-1) 0+{-# OPAQUE undefined# #-}+{-# ANN undefined# hasBlackBox #-}++-- | 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.")+-- >>> let checked  = $(bLit "11")+--+-- >>> checked  `isLike#` expected+-- True+-- >>> expected `isLike#` checked+-- False+--+-- __NB__: Not synthesizable+--+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++-- | Template Haskell macro for generating a pattern matching on some+-- bits of a value.+--+-- This macro compiles to an efficient view pattern that matches the+-- bits of a given value against the bits specified in the+-- 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+--+--   * @\'.\'@ 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 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 "aa.._b0b1") = Just (aa + bb > 1)+--   decode _ = Nothing+-- @+bitPattern :: String -> Q Pat+bitPattern s = [p| ((\_x -> $preprocess) -> $tuple) |]+  where+    (_, 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++    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
@@ -0,0 +1,19 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RoleAnnotations #-}+module Clash.Sized.Internal.BitVector where++import GHC.TypeLits (KnownNat,Nat)+import Data.Kind    (Type)++type role BitVector nominal+data BitVector :: Nat -> Type+data Bit++undefError :: KnownNat n => String -> [BitVector n] -> a
+ src/Clash/Sized/Internal/Index.hs view
@@ -0,0 +1,559 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2016-2019, Myrtle Software Ltd,+                  2021-2026, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE Unsafe #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-}++{-# OPTIONS_HADDOCK show-extensions not-home #-}++module Clash.Sized.Internal.Index+  ( -- * Datatypes+    Index (..)+    -- * Construction+  , fromSNat+  -- * Accessors+  -- ** Length information+  , size#+    -- * Type classes+    -- ** BitPack+  , pack#+  , unpack#+    -- ** Eq+  , eq#+  , neq#+    -- ** Ord+  , lt#+  , ge#+  , gt#+  , le#+    -- ** Enum+  , toEnum#+  , fromEnum#+    -- ** Enum (not synthesizable)+  , enumFrom#+  , enumFromThen#+  , enumFromTo#+  , enumFromThenTo#+    -- ** Bounded+  , maxBound#+    -- ** Num+  , (+#)+  , (-#)+  , (*#)+  , negate#+  , fromInteger#+    -- ** ExtendingNum+  , plus#+  , minus#+  , times#+    -- ** Integral+  , quot#+  , rem#+  , toInteger#+    -- ** Resize+  , resize#+  )+where++import Prelude hiding             (even, odd)++import Control.DeepSeq            (NFData (..))+import Data.Bits                  (Bits (..), FiniteBits (..))+import Data.Data                  (Data)+import Data.Default               (Default (..))+import Text.Read                  (Read (..), ReadPrec)+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 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               (KnownNat, Nat, type (+), type (-),+                                   type (*), type (<=), natVal)+import GHC.TypeLits.Extra         (CLogWZ)+import Test.QuickCheck.Arbitrary  (Arbitrary (..), CoArbitrary (..),+                                   arbitraryBoundedIntegral,+                                   coarbitraryIntegral, shrinkIntegral)++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.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(..), UNat(..), toUNat, snatToNum, natToInteger)+import Clash.XException+  (ShowX (..), NFDataX (..), errorX, showsPrecXWith, rwhnfX, seqX)++{- $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]+--+-- >>> maxBound :: Index 8+-- 7+-- >>> minBound :: Index 8+-- 0+-- >>> read (show (maxBound :: Index 8)) :: Index 8+-- 7+-- >>> 1 + 2 :: Index 8+-- 3+-- >>> 2 + 6 :: Index 8+-- *** Exception: X: Clash.Sized.Index: result 8 is out of bounds: [0..7]+-- ...+-- >>> 1 - 3 :: Index 8+-- *** Exception: X: Clash.Sized.Index: result -2 is out of bounds: [0..7]+-- ...+-- >>> 2 * 3 :: Index 8+-- 6+-- >>> 2 * 4 :: Index 8+-- *** Exception: X: Clash.Sized.Index: result 8 is out of bounds: [0..7]+-- ...+--+-- __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 }+  deriving (Data, Generic)++{-# ANN I hasBlackBox #-}++{-# OPAQUE size# #-}+size# :: KnownNat n => Index n -> Int+size# = BV.size# . pack#++instance NFData (Index n) where+  rnf (I i) = rnf i `seq` ()+  {-# NOINLINE rnf #-}+  -- NOINLINE is needed so that Clash doesn't trip on the "Index ~# Integer"+  -- coercion++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, n + 1 <= m) => SNat n -> Index m+fromSNat = snatToNum++{-# OPAQUE pack# #-}+{-# ANN pack# hasBlackBox #-}+pack# :: Index n -> BitVector (CLogWZ 2 n 0)+pack# (I i) = BV 0 (naturalFromInteger 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#++{-# OPAQUE eq# #-}+{-# ANN eq# hasBlackBox #-}+eq# :: (Index n) -> (Index n) -> Bool+(I n) `eq#` (I m) = n == m++{-# OPAQUE neq# #-}+{-# ANN neq# hasBlackBox #-}+neq# :: (Index n) -> (Index n) -> Bool+(I n) `neq#` (I m) = n /= m++instance Ord (Index n) where+  (<)  = lt#+  (>=) = ge#+  (>)  = gt#+  (<=) = le#++lt#,ge#,gt#,le# :: Index n -> Index n -> Bool+{-# OPAQUE lt# #-}+{-# ANN lt# hasBlackBox #-}+lt# (I n) (I m) = n < m+{-# OPAQUE ge# #-}+{-# ANN ge# hasBlackBox #-}+ge# (I n) (I m) = n >= m+{-# OPAQUE gt# #-}+{-# ANN gt# hasBlackBox #-}+gt# (I n) (I m) = n > m+{-# OPAQUE le# #-}+{-# ANN le# hasBlackBox #-}+le# (I n) (I m) = n <= m++-- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and+-- 'enumFromThenTo', are not synthesizable.+instance KnownNat n => Enum (Index n) where+  succ           = (+# fromInteger# 1)+  pred           = (-# fromInteger# 1)+  toEnum         = toEnum#+  fromEnum       = fromEnum#+  enumFrom       = enumFrom#+  enumFromThen   = enumFromThen#+  enumFromTo     = enumFromTo#+  enumFromThenTo = enumFromThenTo#++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]+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#++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      = negate#+  abs         = id+  signum i    = if i == 0 then 0 else 1+  fromInteger = fromInteger#++(+#),(-#),(*#) :: KnownNat n => Index n -> Index n -> Index n+{-# OPAQUE (+#) #-}+{-# ANN (+#) hasBlackBox #-}+(+#) (I a) (I b) = fromInteger_INLINE $ a + b++{-# OPAQUE (-#) #-}+{-# ANN (-#) hasBlackBox #-}+(-#) (I a) (I b) = fromInteger_INLINE $ a - b++{-# 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+{-# 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 = natToInteger @n+    err   = errorX ("Clash.Sized.Index: result " ++ show i +++                   " 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)+  add  = plus#+  sub = minus#+  type MResult (Index m) (Index n) = Index (((m - 1) * (n - 1)) + 1)+  mul = times#++plus#, minus# :: Index m -> Index n -> Index (m + n - 1)+{-# OPAQUE plus# #-}+{-# ANN plus# hasBlackBox #-}+plus# (I a) (I b) = I (a + b)++{-# OPAQUE minus# #-}+{-# ANN minus# hasBlackBox #-}+minus# (I a) (I b) =+  let z   = a - b+      err = error ("Clash.Sized.Index.minus: result " ++ show z +++                   " is smaller than 0")+      res = if z < 0 then err else I z+  in  res++{-# 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 => 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# (natToInteger @(n - 1))+          , z > m -> fromInteger# 0+        z -> resize# z+  satAdd SatError a b = case toUNat (SNat @n) of+    UZero -> a+    USucc _ ->+      case plus# a b of+        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++  satSub SatWrap a b =+    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 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# (natToInteger @(n - 1))+          , z > m -> fromInteger# 0+        z -> resize# z+  satMul SatError a b = case toUNat (SNat @n) of+    UZero -> a+    USucc _ ->+      case times# a b of+        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#+  div         = quot#+  mod         = rem#+  quotRem n d = (n `quot#` d,n `rem#` d)+  divMod  n d = (n `quot#` d,n `rem#` d)+  toInteger   = toInteger#++quot#,rem# :: Index n -> Index n -> Index n+{-# OPAQUE quot# #-}+{-# ANN quot# hasBlackBox #-}+(I a) `quot#` (I b) = I (a `div` b)+{-# OPAQUE rem# #-}+{-# ANN rem# hasBlackBox #-}+(I a) `rem#` (I b) = I (a `rem` b)++{-# OPAQUE toInteger# #-}+{-# ANN toInteger# hasBlackBox #-}+toInteger# :: Index n -> Integer+toInteger# (I n) = n++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)+  complement        = unpack# . BV.complement# . pack#+  zeroBits          = unpack# zeroBits+  bit i             = unpack# $ bit i+  setBit v i        = unpack# $ replaceBit i high (pack# v)+  clearBit v i      = unpack# $ replaceBit i low  (pack# v)+  complementBit v i = unpack# $ complementBit (pack# v) i+  testBit v i       = testBit (pack# v) i+  bitSizeMaybe v    = Just (size# v)+  bitSize           = size#+  isSigned _        = False+  shiftL v i        = unpack# $ shiftL (pack# v) i+  shiftR v i        = unpack# $ shiftR (pack# v) i+  rotateL v i       = unpack# $ rotateL (pack# v) i+  rotateR v i       = unpack# $ rotateR (pack# v) i+  popCount i        = popCount (pack# i)++instance KnownNat n => FiniteBits (Index n) where+  finiteBitSize        = size#+  countLeadingZeros  i = countLeadingZeros  (pack# i)+  countTrailingZeros i = countTrailingZeros (pack# i)++instance Resize Index where+  resize     = resize#+  zeroExtend = extend+  truncateB  = resize#++resize# :: KnownNat m => Index n -> Index m+resize# (I i) = fromInteger_INLINE i+{-# 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 :: Quote m => Integer -> m Type+decIndex n = appT (conT ''Index) (litT $ numTyLit n)++instance Show (Index n) where+  show (I i) = show i+  {-# NOINLINE show #-}++instance ShowX (Index n) where+  showsPrecX = showsPrecXWith showsPrec++instance NFDataX (Index n) where+  deepErrorX = errorX+  ensureSpine = id+  rnfX = rwhnfX++-- | None of the 'Read' class' methods are synthesizable.+instance KnownNat n => Read (Index n) where+  readPrec = fromIntegral <$> (readPrec :: ReadPrec Natural)++instance KnownNat n => Default (Index n) where+  def = fromInteger# 0++instance KnownNat n => Arbitrary (Index n) where+  arbitrary = arbitraryBoundedIntegral+  shrink    = shrinkIndex++shrinkIndex :: KnownNat n => Index n -> [Index n]+shrinkIndex x | natVal x < 3 = case toInteger x of+                                 1 -> [0]+                                 _ -> []+              -- 'shrinkIntegral' uses "`quot` 2", which for 'Index' types with+              -- an upper bound less than 2 results in an error.+              | otherwise    = shrinkIntegral x++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
@@ -0,0 +1,20 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# 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 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
@@ -0,0 +1,836 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2016     , Myrtle Software Ltd,+                  2021-2025, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE Unsafe #-}++{-# OPTIONS_HADDOCK show-extensions not-home #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}++module Clash.Sized.Internal.Signed+  ( -- * Datatypes+    Signed (..)+    -- * Accessors+    -- ** Length information+  , size#+    -- * Type classes+    -- ** BitPack+  , pack#+  , unpack#+    -- ** Eq+  , eq#+  , neq#+    -- ** Ord+  , lt#+  , ge#+  , gt#+  , le#+    -- ** Enum+  , toEnum#+  , fromEnum#+    -- ** Enum (not synthesizable)+  , enumFrom#+  , enumFromThen#+  , enumFromTo#+  , enumFromThenTo#+    -- ** Bounded+  , minBound#+  , maxBound#+    -- ** Num+  , (+#)+  , (-#)+  , (*#)+  , negate#+  , abs#+  , fromInteger#+    -- ** ExtendingNum+  , plus#+  , minus#+  , times#+    -- ** Integral+  , quot#+  , rem#+  , div#+  , mod#+  , toInteger#+    -- ** Bits+  , and#+  , or#+  , xor#+  , complement#+  , shiftL#+  , shiftR#+  , rotateL#+  , rotateR#+    -- ** Resize+  , resize#+  , truncateB#+    -- ** SaturatingNum+  , minBoundSym#+  )+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                   (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 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.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+--+-- 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] for+-- @n > 0@. When @n = 0@, both the min and max bound are 0.+--+-- * __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+-- 3+-- >>> minBound :: Signed 3+-- -4+-- >>> read (show (minBound :: Signed 3)) :: Signed 3+-- -4+-- >>> 1 + 2 :: Signed 3+-- 3+-- >>> 2 + 3 :: Signed 3+-- -3+-- >>> (-2) + (-3) :: Signed 3+-- 3+-- >>> 2 * 3 :: Signed 4+-- 6+-- >>> 2 * 4 :: Signed 4+-- -8+-- >>> (2 :: Signed 3) `mul` (4 :: Signed 4) :: Signed 7+-- 8+-- >>> (2 :: Signed 3) `add` (3 :: Signed 3) :: Signed 4+-- 5+-- >>> (-2 :: Signed 3) `add` (-3 :: Signed 3) :: Signed 4+-- -5+-- >>> satAdd SatSymmetric 2 3 :: Signed 3+-- 3+-- >>> satAdd SatSymmetric (-2) (-3) :: Signed 3+-- -3+--+-- 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}+  deriving (Data, Generic)++{-# ANN S hasBlackBox #-}++instance NFDataX (Signed n) where+  deepErrorX = errorX+  ensureSpine = id+  rnfX = rwhnfX++{-# OPAQUE size# #-}+{-# ANN size# hasBlackBox #-}+size# :: KnownNat n => Signed n -> Int+size# bv = fromInteger (natVal bv)++instance NFData (Signed n) where+  rnf (S i) = rnf i `seq` ()+  {-# NOINLINE rnf #-}+  -- NOINLINE is needed so that Clash doesn't trip on the "Signed ~# Integer"+  -- coercion++instance Show (Signed n) where+  show (S i) = show i+  {-# NOINLINE show #-}++instance ShowX (Signed n) where+  showsPrecX = showsPrecXWith showsPrec++-- | None of the 'Read' class' methods are synthesizable.+instance KnownNat n => Read (Signed n) where+  readPrec = fromIntegral <$> (readPrec :: ReadPrec Integer)++instance KnownNat n => BitPack (Signed n) where+  type BitSize (Signed n) = n+  pack   = packXWith pack#+  unpack = unpack#++{-# OPAQUE pack# #-}+{-# ANN pack# hasBlackBox #-}+pack# :: forall n . KnownNat n => Signed n -> BitVector n+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)++{-# OPAQUE unpack# #-}+{-# ANN unpack# hasBlackBox #-}+unpack# :: forall n . KnownNat n => BitVector n -> Signed n+unpack# (BV 0 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#++{-# OPAQUE eq# #-}+{-# ANN eq# hasBlackBox #-}+eq# :: Signed n -> Signed n -> Bool+eq# (S v1) (S v2) = v1 == v2++{-# OPAQUE neq# #-}+{-# ANN neq# hasBlackBox #-}+neq# :: Signed n -> Signed n -> Bool+neq# (S v1) (S v2) = v1 /= v2++instance Ord (Signed n) where+  (<)  = lt#+  (>=) = ge#+  (>)  = gt#+  (<=) = le#++lt#,ge#,gt#,le# :: Signed n -> Signed n -> Bool+{-# OPAQUE lt# #-}+{-# ANN lt# hasBlackBox #-}+lt# (S n) (S m) = n < m+{-# OPAQUE ge# #-}+{-# ANN ge# hasBlackBox #-}+ge# (S n) (S m) = n >= m+{-# OPAQUE gt# #-}+{-# ANN gt# hasBlackBox #-}+gt# (S n) (S m) = n > m+{-# 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 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#++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# :: 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+  (+)         = (+#)+  (-)         = (-#)+  (*)         = (*#)+  negate      = negate#+  abs         = abs#+  signum s    = if s < 0 then (-1) else+                   if s > 0 then 1 else 0+  fromInteger = fromInteger#++(+#), (-#), (*#) :: forall n . KnownNat n => Signed n -> Signed n -> Signed n+{-# 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)++{-# 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)++{-# 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+{-# 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)++{-# 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)++{-# 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 :: 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)+  add  = plus#+  sub = minus#+  type MResult (Signed m) (Signed n) = Signed (m + n)+  mul = times#++plus#, minus# :: Signed m -> Signed n -> Signed (Max m n + 1)+{-# OPAQUE plus# #-}+{-# ANN plus# hasBlackBox #-}+plus# (S a) (S b) = S (a + b)++{-# OPAQUE minus# #-}+{-# ANN minus# hasBlackBox #-}+minus# (S a) (S b) = S (a - b)++{-# 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#+  div         = div#+  mod         = mod#+  quotRem n d = (n `quot#` d,n `rem#` d)+  divMod  n d = (n `div#`  d,n `mod#` d)+  toInteger   = toInteger#++{-# 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)++{-# 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)++{-# 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#+  xor               = xor#+  complement        = complement#+  zeroBits          = 0+  bit i             = replaceBit i high 0+  setBit v i        = replaceBit i high v+  clearBit v i      = replaceBit i low  v+  complementBit v i = replaceBit i (BV.complement## (v ! i)) v+  testBit v i       = v ! i == 1+  bitSizeMaybe v    = Just (size# v)+  bitSize           = size#+  isSigned _        = True+  shiftL v i        = shiftL# v i+  shiftR v i        = shiftR# v i+  rotateL v i       = rotateL# v i+  rotateR v i       = rotateR# v i+  popCount s        = popCount (pack# s)++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++{-# 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++{-# 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++{-# 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++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++{-# 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)+  countTrailingZeros s = countTrailingZeros (pack# s)++instance Resize Signed where+  resize       = resize#+  zeroExtend s = unpack# (0 ++# pack s)+  truncateB    = truncateB#++{-# OPAQUE resize# #-}+{-# ANN resize# hasBlackBox #-}+resize# :: forall m n . (KnownNat n, KnownNat m) => Signed n -> Signed m+resize# s@(S i)+  | natToNatural @m == 0 = S 0+  | n' <= m'  = extended+  | otherwise = truncated+  where+    n  = fromInteger (natVal s)+    n' = shiftL 1 n+    m' = shiftL mask 1+    extended = S i++    mask      = 1 `shiftL` fromInteger (natVal (Proxy @m) -1)+    i'        = i `mod` mask+    truncated = if testBit i (n-1)+                   then S (i' - mask)+                   else S i'++{-# 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++instance KnownNat n => Lift (Signed n) where+  lift s@(S i) = sigE [| fromInteger# i |] (decSigned (natVal s))+  {-# NOINLINE lift #-}+  liftTyped = liftTypedFromUntyped++decSigned :: Quote m => Integer -> m Type+decSigned n = appT (conT ''Signed) (litT $ numTyLit n)++instance KnownNat n => SaturatingNum (Signed n) where+  satAdd SatWrap  a b = a +# b+  satAdd SatBound a b =+    let r      = plus# a b+        (_,r') = split r+    in  case msb r `xor` msb r' of+          0 -> unpack# r'+          _ -> case msb a .&. msb b of+            0 -> maxBound#+            _ -> minBound#+  satAdd SatZero a b =+    let r      = plus# a b+        (_,r') = split r+    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+    in  case msb r `xor` msb r' of+          0 -> unpack# r'+          _ -> case msb a .&. msb b of+            0 -> maxBound#+            _ -> minBoundSym#++  satSub SatWrap a b = a -# b+  satSub SatBound a b =+    let r      = minus# a b+        (_,r') = split r+    in  case msb r `xor` msb r' of+          0 -> unpack# r'+          _ -> case BV.pack# (msb a) ++# BV.pack# (msb b) of+            2 -> minBound#+            _ -> maxBound#+  satSub SatZero a b =+    let r      = minus# a b+        (_,r') = split r+    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+    in  case msb r `xor` msb r' of+          0 -> unpack# r'+          _ -> case BV.pack# (msb a) ++# BV.pack# (msb b) of+            2 -> minBoundSym#+            _ -> maxBound#++  satMul SatWrap a b = a *# b+  satMul SatBound 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+          _ -> case msb rL of+            0 -> maxBound#+            _ -> minBound#+  satMul SatZero 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+          _ -> 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)+    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++instance KnownNat n => Arbitrary (Signed n) where+  arbitrary = arbitraryBoundedIntegral+  shrink    = shrinkSizedSigned++shrinkSizedSigned :: (KnownNat n, Integral (p n)) => p n -> [p n]+shrinkSizedSigned x | natVal x < 2 = case toInteger x of+                                       0 -> []+                                       _ -> [0]+                    -- 'shrinkIntegral' uses "`quot` 2", which for sized types+                    -- less than 2 bits wide results in a division by zero.+                    --+                    -- See: https://github.com/clash-lang/clash-compiler/issues/153+                    | otherwise    = shrinkIntegral x+{-# INLINE shrinkSizedSigned #-}++instance KnownNat n => CoArbitrary (Signed n) where+  coarbitrary = coarbitraryIntegral++type instance Index   (Signed n) = Int+type instance IxValue (Signed n) = Bit+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
@@ -0,0 +1,682 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2016     , Myrtle Software Ltd,+                  2021-2025, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE Unsafe #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_HADDOCK show-extensions not-home #-}++module Clash.Sized.Internal.Unsigned+  ( -- * Datatypes+    Unsigned (..)+    -- * Accessors+    -- ** Length information+  , size#+    -- * Type classes+    -- ** BitPack+  , pack#+  , unpack#+    -- ** Eq+  , eq#+  , neq#+    -- ** Ord+  , lt#+  , ge#+  , gt#+  , le#+    -- ** Enum+  , toEnum#+  , fromEnum#+    -- ** Enum (not synthesizable)+  , enumFrom#+  , enumFromThen#+  , enumFromTo#+  , enumFromThenTo#+    -- ** Bounded+  , minBound#+  , maxBound#+    -- ** Num+  , (+#)+  , (-#)+  , (*#)+  , negate#+  , fromInteger#+    -- ** ExtendingNum+  , plus#+  , minus#+  , times#+    -- ** Integral+  , quot#+  , rem#+  , toInteger#+    -- ** Bits+  , and#+  , or#+  , xor#+  , complement#+  , shiftL#+  , shiftR#+  , rotateL#+  , 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                   (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.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 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 Language.Haskell.TH.Compat+import Language.Haskell.TH            (Quote, Type)+import Test.QuickCheck.Arbitrary      (Arbitrary (..), CoArbitrary (..),+                                       arbitraryBoundedIntegral,+                                       coarbitraryIntegral)++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.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 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+-- 7+-- >>> minBound :: Unsigned 3+-- 0+-- >>> read (show (maxBound :: Unsigned 3)) :: Unsigned 3+-- 7+-- >>> 1 + 2 :: Unsigned 3+-- 3+-- >>> 2 + 6 :: Unsigned 3+-- 0+-- >>> 1 - 3 :: Unsigned 3+-- 6+-- >>> 2 * 3 :: Unsigned 3+-- 6+-- >>> 2 * 4 :: Unsigned 3+-- 0+-- >>> (2 :: Unsigned 3) `mul` (4 :: Unsigned 3) :: Unsigned 6+-- 8+-- >>> (2 :: Unsigned 3) `add` (6 :: Unsigned 3) :: Unsigned 4+-- 8+-- >>> satAdd SatSymmetric 2 6 :: Unsigned 3+-- 7+-- >>> satSub SatSymmetric 2 3 :: Unsigned 3+-- 0+--+-- 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 { unsafeToNatural :: !Natural }+  deriving (Data, Generic)++{-# ANN U hasBlackBox #-}++{-# OPAQUE size# #-}+{-# ANN size# hasBlackBox #-}+size# :: KnownNat n => Unsigned n -> Int+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 ~# Natural"+  -- coercion++instance Show (Unsigned n) where+  show (U i) = show i+  {-# NOINLINE show #-}++instance ShowX (Unsigned n) where+  showsPrecX = showsPrecXWith showsPrec++instance NFDataX (Unsigned n) where+  deepErrorX = errorX+  ensureSpine = id+  rnfX = rwhnfX++-- | None of the 'Read' class' methods are synthesizable.+instance KnownNat n => Read (Unsigned n) where+  readPrec = fromIntegral <$> (readPrec :: ReadPrec Natural)++instance KnownNat n => BitPack (Unsigned n) where+  type BitSize (Unsigned n) = n+  pack   = packXWith pack#+  unpack = unpack#++{-# OPAQUE pack# #-}+{-# ANN pack# hasBlackBox #-}+pack# :: Unsigned n -> BitVector n+pack# (U i) = BV 0 i++{-# OPAQUE unpack# #-}+{-# ANN unpack# hasBlackBox #-}+unpack# :: KnownNat n => BitVector n -> Unsigned n+unpack# (BV 0 i) = U i+unpack# bv = undefError "Unsigned.unpack" [bv]++instance Eq (Unsigned n) where+  (==) = eq#+  (/=) = neq#++{-# OPAQUE eq# #-}+{-# ANN eq# hasBlackBox #-}+eq# :: Unsigned n -> Unsigned n -> Bool+eq# (U v1) (U v2) = v1 == v2++{-# OPAQUE neq# #-}+{-# ANN neq# hasBlackBox #-}+neq# :: Unsigned n -> Unsigned n -> Bool+neq# (U v1) (U v2) = v1 /= v2++instance Ord (Unsigned n) where+  (<)  = lt#+  (>=) = ge#+  (>)  = gt#+  (<=) = le#++lt#,ge#,gt#,le# :: Unsigned n -> Unsigned n -> Bool+{-# OPAQUE lt# #-}+{-# ANN lt# hasBlackBox #-}+lt# (U n) (U m) = n < m+{-# OPAQUE ge# #-}+{-# ANN ge# hasBlackBox #-}+ge# (U n) (U m) = n >= m+{-# OPAQUE gt# #-}+{-# ANN gt# hasBlackBox #-}+gt# (U n) (U m) = n > m+{-# 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 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#++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#++minBound# :: Unsigned n+minBound# = U 0+{-# OPAQUE minBound# #-}+{-# ANN minBound# hasBlackBox #-}++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+  (+)         = (+#)+  (-)         = (-#)+  (*)         = (*#)+  negate      = negate#+  abs         = id+  signum bv   = resize# (unpack# (BV.pack# (reduceOr bv)))+  fromInteger = fromInteger#++(+#),(-#),(*#) :: forall n . KnownNat n => Unsigned n -> Unsigned n -> Unsigned n+{-# OPAQUE (+#) #-}+{-# ANN (+#) hasBlackBox #-}+(+#) = \(U i) (U j) -> U (addMod m i j)+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))++{-# OPAQUE (-#) #-}+{-# ANN (-#) hasBlackBox #-}+(-#) = \(U i) (U j) -> U (subMod m i j)+  where m = 1 `naturalShiftL` naturalToWord (natVal (Proxy @n))++{-# OPAQUE (*#) #-}+{-# ANN (*#) hasBlackBox #-}+(*#) = \(U i) (U j) -> U (mulMod2 m i j)+  where m = (1 `naturalShiftL` naturalToWord (natVal (Proxy @n))) - 1++{-# OPAQUE negate# #-}+{-# ANN negate# hasBlackBox #-}+negate# :: forall n . KnownNat n => Unsigned n -> Unsigned n+negate# = \(U i) -> U (negateMod m i)+  where m = 1 `naturalShiftL` naturalToWord (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)+  add  = plus#+  sub = minus#+  type MResult (Unsigned m) (Unsigned n) = Unsigned (m + n)+  mul = times#++{-# OPAQUE plus# #-}+{-# ANN plus# hasBlackBox #-}+plus# :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1)+plus# (U a) (U b) = U (a + b)++{-# 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) -> U (subMod mask a b)+ where+  sz   = naturalToWord (natVal (Proxy @(Max m n + 1)))+  mask = 1 `naturalShiftL` sz++{-# 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#+  div         = quot#+  mod         = rem#+  quotRem n d = (n `quot#` d,n `rem#` d)+  divMod  n d = (n `quot#` d,n `rem#` d)+  toInteger   = toInteger#++quot#,rem# :: Unsigned n -> Unsigned n -> Unsigned n+{-# OPAQUE quot# #-}+{-# ANN quot# hasBlackBox #-}+quot# (U i) (U j) = U (i `quot` j)+{-# OPAQUE rem# #-}+{-# ANN rem# hasBlackBox #-}+rem# (U i) (U j) = U (i `rem` j)++{-# OPAQUE toInteger# #-}+{-# ANN toInteger# hasBlackBox #-}+toInteger# :: Unsigned n -> Integer+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#+  xor               = xor#+  complement        = complement#+  zeroBits          = 0+  bit i             = replaceBit i high 0+  setBit v i        = replaceBit i high v+  clearBit v i      = replaceBit i low  v+  complementBit v i = replaceBit i (BV.complement## (v ! i)) v+  testBit v i       = v ! i == high+  bitSizeMaybe v    = Just (size# v)+  bitSize           = size#+  isSigned _        = False+  shiftL v i        = shiftL# v i+  shiftR v i        = shiftR# v i+  rotateL v i       = rotateL# v i+  rotateR v i       = rotateR# v i+  popCount u        = popCount (pack# u)++{-# OPAQUE and# #-}+{-# ANN and# hasBlackBox #-}+and# :: Unsigned n -> Unsigned n -> Unsigned n+and# (U v1) (U v2) = U (v1 .&. v2)++{-# OPAQUE or# #-}+{-# ANN or# hasBlackBox #-}+or# :: Unsigned n -> Unsigned n -> Unsigned n+or# (U v1) (U v2) = U (v1 .|. v2)++{-# OPAQUE xor# #-}+{-# ANN xor# hasBlackBox #-}+xor# :: Unsigned n -> Unsigned n -> Unsigned n+xor# (U v1) (U v2) = U (v1 `xor` v2)++{-# 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# :: 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++{-# 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+  | otherwise = U (shiftR v i)++{-# 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+    sz = naturalToWord (natVal (Proxy @n))+    m  = 1 `naturalShiftL` sz++{-# 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+    sz = naturalToWord (natVal (Proxy @n))+    m  = 1 `naturalShiftL` sz+++instance KnownNat n => FiniteBits (Unsigned n) where+  finiteBitSize        = size#+  countLeadingZeros  u = countLeadingZeros  (pack# u)+  countTrailingZeros u = countTrailingZeros (pack# u)++instance Resize Unsigned where+  resize     = resize#+  zeroExtend = extend+  truncateB  = resize#++{-# OPAQUE resize# #-}+{-# ANN resize# hasBlackBox #-}+resize# :: forall n m . KnownNat m => Unsigned n -> Unsigned m+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#++instance KnownNat n => Lift (Unsigned n) where+  lift u@(U i) = sigE [| fromInteger# i |] (decUnsigned (natVal u))+  {-# NOINLINE lift #-}+  liftTyped = liftTypedFromUntyped++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+  satAdd SatZero a b =+    let r = plus# a b+    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+          0 -> resize# r+          _ -> 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+          0 -> resize# r+          _ -> minBound#++  satMul SatWrap a b = a *# b+  satMul SatZero a b =+    let r       = times# a b+        (rL,rR) = split r+    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+    in  case rL of+          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++instance KnownNat n => CoArbitrary (Unsigned n) where+  coarbitrary = coarbitraryIntegral++type instance Index   (Unsigned n) = Int+type instance IxValue (Unsigned n) = Bit+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
@@ -0,0 +1,673 @@+{-|+Copyright  :  (C) 2016, University of Twente+                  2022-2025, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-}++module Clash.Sized.RTree+  ( -- * 'RTree' data type+    RTree (LR, BR, RLeaf, RBranch)+    -- * Construction+  , treplicate+  , trepeat+    -- * Accessors+  , thead+  , tlast+    -- ** Indexing+  , indexTree+  , tindices+    -- * Modifying trees+  , replaceTree+    -- * Element-wise operations+    -- ** Mapping+  , tmap+  , tzipWith+    -- ** Zipping+  , tzip+    -- ** Unzipping+  , tunzip+    -- * Folding+  , tfold+    -- ** Specialised folds+  , tdfold+    -- ** Prefix sums (scans)+    -- $scans+  , scanlPar+  , tscanl+  , scanrPar+  , tscanr+    -- * Conversions+  , v2t+  , t2v+    -- * Misc+  , lazyT++  -- * Internal+  , textract+  , tsplit+  )+where++import Control.DeepSeq             (NFData(..))+import qualified Control.Lens      as Lens+import Data.Default                (Default (..))+import Data.Either                 (isLeft)+import Data.Foldable               (toList)+import Data.Kind                   (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 Language.Haskell.TH.Compat+import Prelude                     hiding ((++), (!!), map)+import Test.QuickCheck             (Arbitrary (..), CoArbitrary (..))++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)+import Clash.XException+  (ShowX (..), NFDataX (..), isX, showsX, showsPrecXWith)++{- $setup+>>> :set -XDataKinds+>>> :set -XTypeFamilies+>>> :set -XTypeOperators+>>> :set -XTemplateHaskell+>>> :set -XFlexibleContexts+>>> :set -XTypeApplications+>>> :set -fplugin GHC.TypeLits.Normalise+>>> :set -XUndecidableInstances+>>> import Clash.Prelude+>>> 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)+    populationCount' bv = tdfold (Proxy @IIndex)+                                 fromIntegral+                                 (\_ x y -> add x y)+                                 (v2t (bv2v bv))+:}+-}++-- | Perfect depth binary tree.+--+-- * Only has elements at the leaf of the tree+-- * A tree of depth /d/ has /2^d/ elements.+data RTree :: Nat -> Type -> Type where+  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 (RLeaf x) = rnf x+    rnf (RBranch l r ) = rnf l `seq` rnf r++textract :: RTree 0 a -> a+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 (RBranch l r) = (l,r)+#if __GLASGOW_HASKELL__ < 912+tsplit (RLeaf _)   = error $ "tsplit: leaf is atomic"+#endif+{-# OPAQUE tsplit #-}+{-# ANN tsplit hasBlackBox #-}++-- | RLeaf of a perfect depth tree+--+-- >>> LR 1+-- 1+-- >>> let x = LR 1+-- >>> :t x+-- x :: Num a => RTree 0 a+--+-- Can be used as a pattern:+--+-- >>> let f (LR a) (LR b) = a + b+-- >>> :t f+-- f :: Num a => RTree 0 a -> RTree 0 a -> a+-- >>> f (LR 1) (LR 2)+-- 3+pattern LR :: a -> RTree 0 a+pattern LR x <- (textract -> x)+  where+    LR x = RLeaf x++-- | RBranch of a perfect depth tree+--+-- >>> BR (LR 1) (LR 2)+-- <1,2>+-- >>> let x = BR (LR 1) (LR 2)+-- >>> :t x+-- x :: Num a => RTree 1 a+--+-- Case be used a pattern:+--+-- >>> let f (BR (LR a) (LR b)) = LR (a + b)+-- >>> :t f+-- f :: Num a => RTree 1 a -> RTree 0 a+-- >>> f (BR (LR 1) (LR 2))+-- 3+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 = RBranch l r++instance (KnownNat d, Eq a) => Eq (RTree d a) where+  (==) t1 t2 = (==) (t2v t1) (t2v t2)++instance (KnownNat d, Ord a) => Ord (RTree d a) where+  compare t1 t2 = compare (t2v t1) (t2v t2)++instance Show a => Show (RTree n a) where+  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 _ (RLeaf a)   = showsX a+      go _ (RBranch l r) = \s -> '<':showsX l (',':showsX r ('>':s))++instance KnownNat d => Functor (RTree d) where+  fmap = tmap++instance KnownNat d => Applicative (RTree d) where+  pure  = trepeat+  (<*>) = tzipWith ($)++instance KnownNat d => Foldable (RTree d) where+  foldMap f = tfold f mappend++data TraversableTree (g :: Type -> Type) (a :: Type) (f :: TyFun Nat Type) :: Type+type instance Apply (TraversableTree f a) d = f (RTree d a)++instance KnownNat d => Traversable (RTree d) where+  traverse :: forall f a b . Applicative f => (a -> f b) -> RTree d a -> f (RTree d b)+  traverse f = tdfold (Proxy @(TraversableTree f b))+                      (fmap LR . f)+                      (const (liftA2 BR))++instance (KnownNat d, BitPack a) =>+  BitPack (RTree d a) where+  type BitSize (RTree d a) = (2^d) * (BitSize a)+  pack   = pack . t2v . lazyT+  unpack = v2t . unpack++type instance Lens.Index   (RTree d a) = Int+type instance Lens.IxValue (RTree d a) = a+instance KnownNat d => Lens.Ixed (RTree d a) where+  ix i f t = replaceTree i <$> f (indexTree t i) <*> pure t++instance (KnownNat d, Default a) => Default (RTree d a) where+  def = trepeat def++instance Lift a => Lift (RTree d a) where+  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)+  shrink    = sequenceA . fmap shrink++instance (KnownNat d, CoArbitrary a) => CoArbitrary (RTree d a) where+  coarbitrary = coarbitrary . toList++instance (KnownNat d, NFDataX a) => NFDataX (RTree d a) where+  deepErrorX x = pure (deepErrorX x)++  rnfX t = if isLeft (isX t) then () else go t+   where+    go :: RTree d a -> ()+    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++  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.+       -> RTree k a -- ^ Tree to fold over.+       -> (p @@ k)+tdfold _ f g = go SNat+  where+    go :: SNat m -> RTree m a -> (p @@ m)+    go _  (RLeaf a)   = f a+    go sn (RBranch l r) = let sn' = sn `subSNat` d1+                      in  g sn' (go sn' l) (go sn' r)+{-# OPAQUE tdfold #-}+{-# ANN tdfold hasBlackBox #-}++data TfoldTree (a :: Type) (f :: TyFun Nat Type) :: Type+type instance Apply (TfoldTree a) d = a++-- | Reduce a tree to a single element+tfold :: forall d a b .+         KnownNat d+      => (a -> b) -- ^ Function to apply to the leaves+      -> (b -> b -> b) -- ^ Function to combine the results of the reduction+                       -- of two branches+      -> RTree d a -- ^ Tree to fold reduce+      -> b+tfold f g = tdfold (Proxy @(TfoldTree b)) f (const g)++-- | \"'treplicate' @d a@\" returns a tree of depth /d/, and has /2^d/ copies+-- of /a/.+--+-- >>> treplicate (SNat :: SNat 3) 6+-- <<<6,6>,<6,6>>,<<6,6>,<6,6>>>+-- >>> treplicate d3 6+-- <<<6,6>,<6,6>>,<<6,6>,<6,6>>>+treplicate :: forall d a . SNat d -> a -> RTree d a+treplicate sn a = go (toUNat sn)+  where+    go :: UNat n -> RTree n a+    go UZero      = LR a+    go (USucc un) = BR (go un) (go un)+{-# OPAQUE treplicate #-}+{-# ANN treplicate hasBlackBox #-}++-- | \"'trepeat' @a@\" creates a tree with as many copies of /a/ as demanded by+-- the context.+--+-- >>> trepeat 6 :: RTree 2 Int+-- <<6,6>,<6,6>>+trepeat :: KnownNat d => a -> RTree d a+trepeat = treplicate SNat++data MapTree (a :: Type) (f :: TyFun Nat Type) :: Type+type instance Apply (MapTree a) d = RTree d a++-- | \"'tmap' @f t@\" is the tree obtained by apply /f/ to each element of /t/,+-- i.e.,+--+-- > tmap f (BR (LR a) (LR b)) == BR (LR (f a)) (LR (f b))+tmap :: forall d a b . KnownNat d => (a -> b) -> RTree d a -> RTree d b+tmap f = tdfold (Proxy @(MapTree b)) (LR . f) (\_ l r -> BR l r)++-- | Generate a tree of indices, where the depth of the tree is determined by+-- the context.+--+-- >>> tindices :: RTree 3 (Index 8)+-- <<<0,1>,<2,3>>,<<4,5>,<6,7>>>+tindices :: forall d . KnownNat d => RTree d (Index (2^d))+tindices =+  tdfold (Proxy @(MapTree (Index (2^d)))) LR+         (\s@SNat l r -> BR l (tmap (+(snatToNum (pow2SNat s))) r))+         (treplicate SNat 0)++data V2TTree (a :: Type) (f :: TyFun Nat Type) :: Type+type instance Apply (V2TTree a) d = RTree d a++-- | Convert a vector with /2^d/ elements to a tree of depth /d/.+--+-- >>> 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)++data T2VTree (a :: Type) (f :: TyFun Nat Type) :: Type+type instance Apply (T2VTree a) d = Vec (2^d) a++-- | Convert a tree of depth /d/ to a vector of /2^d/ elements+--+-- >>> (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 :> Nil+t2v :: forall d a . KnownNat d => RTree d a -> Vec (2^d) a+t2v = tdfold (Proxy @(T2VTree a)) (:> Nil) (\_ l r -> l ++ r)++-- | \"'indexTree' @t n@\" returns the /n/'th element of /t/.+--+-- The bottom-left leaf had index /0/, and the bottom-right leaf has index+-- /2^d-1/, where /d/ is the depth of the tree+--+-- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 0+-- 1+-- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 2+-- 3+-- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 14+-- *** Exception: Clash.Sized.Vector.(!!): index 14 is larger than maximum index 3+-- ...+indexTree :: (KnownNat d, Enum i) => RTree d a -> i -> a+indexTree t i = (t2v t) !! i++-- | \"'replaceTree' @n a t@\" returns the tree /t/ where the /n/'th element is+-- replaced by /a/.+--+-- The bottom-left leaf had index /0/, and the bottom-right leaf has index+-- /2^d-1/, where /d/ is the depth of the tree+--+-- >>> replaceTree 0 5 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4)))+-- <<5,2>,<3,4>>+-- >>> 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 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++data ZipWithTree (b :: Type) (c :: Type) (f :: TyFun Nat Type) :: Type+type instance Apply (ZipWithTree b c) d = RTree d b -> RTree d c++-- | 'tzipWith' generalizes 'tzip' by zipping with the function given as the+-- first argument, instead of a tupling function. For example, "tzipWith (+)"+-- applied to two trees produces the tree of corresponding sums.+--+-- > tzipWith f (BR (LR a1) (LR b1)) (BR (LR a2) (LR b2)) == BR (LR (f a1 a2)) (LR (f b1 b2))+tzipWith :: forall a b c d . KnownNat d => (a -> b -> c) -> RTree d a -> RTree d b -> RTree d c+tzipWith f = tdfold (Proxy @(ZipWithTree b c)) lr br+  where+    lr :: a -> RTree 0 b -> RTree 0 c+    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 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 (,)++data UnzipTree (a :: Type) (b :: Type) (f :: TyFun Nat Type) :: Type+type instance Apply (UnzipTree a b) d = (RTree d a, RTree d b)++-- | 'tunzip' transforms a tree of pairs into a tree of first components and a+-- tree of second components.+tunzip :: forall d a b . KnownNat d => RTree d (a,b) -> (RTree d a,RTree d b)+tunzip = tdfold (Proxy @(UnzipTree a b)) lr br+  where+    lr   (a,b) = (LR a,LR b)++    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+-- 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 ())++-- | 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/Signed.hs view
@@ -0,0 +1,14 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE Trustworthy #-}++module Clash.Sized.Signed+  ( Signed+  )+where++import Clash.Sized.Internal.Signed
+ src/Clash/Sized/Unsigned.hs view
@@ -0,0 +1,13 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE Trustworthy #-}++module Clash.Sized.Unsigned+  (Unsigned)+where++import Clash.Sized.Internal.Unsigned
+ src/Clash/Sized/Vector.hs view
@@ -0,0 +1,2771 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2017     , Myrtle Software Ltd+                  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
@@ -0,0 +1,27 @@+{-|+Copyright  :  (C) 2015-2016, University of Twente+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Clash.Sized.Vector where++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 -> Type -> Type++instance KnownNat n => Foldable (Vec n)++bv2v  :: KnownNat n => BitVector n -> Vec n Bit+map   :: (a -> b) -> Vec n a -> Vec n b+foldr :: (a -> b -> b) -> b -> Vec n a -> b+foldl :: (b -> a -> b) -> b -> Vec n a -> 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
@@ -0,0 +1,25 @@+{-|+Copyright : © 2014-2016, Christiaan Baaij,+              2017-2019, Myrtle Software Ltd+              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
@@ -0,0 +1,755 @@+{-|+Copyright  :  (C) 2016,      University of Twente,+                  2017,      QBayLogic, Google Inc.+                  2017-2019, Myrtle Software Ltd,+                  2021-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 StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++{-# LANGUAGE Trustworthy #-}++module Clash.XException+  ( -- * '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, seqErrorX, forceX, deepseqX, rwhnfX, defaultSeqX, hwSeqX+    -- * Structured undefined / deep evaluation with undefined values+  , NFDataX (rnfX, deepErrorX, hasUndefined, ensureSpine)+  )+where++import           Prelude             hiding (undefined)++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)++-- $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+++-- | 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+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 @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 = _|_+--+-- 'seqX' will do:+--+-- > seqX (XException msg) b = b+-- > seqX _|_              b = _|_+seqX :: a -> b -> b+seqX a b = unsafeDupablePerformIO+  (catch (evaluate a >> return b) (\(XException _) -> return b))+{-# 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'. 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 (XException msg, _|_) = _|_+-- > maybeX hasX (_|_, XException msg) = _|_+-- > maybeX hasX (3, _|_)              = _|_+-- > maybeX hasX _|_                   = _|_+-- >+-- > maybeX isX 42                  = Just 42+-- > maybeX isX (XException msg)    = Nothing+-- > maybeX isX (3, XException msg) = Just (3, XException msg)+-- > maybeX isX (3, _|_)            = Just (3, _|_)+-- > maybeX isX _|_                 = _|_+--+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'. Note+-- that non-'XException' errors take precedence over 'XException' ones.+--+-- > 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, NFDataX a) => a -> Maybe a+maybeHasX = maybeX hasX++-- | Evaluate a value to WHNF, returning 'Nothing' if it throws 'XException'.+--+-- > maybeIsX 42                  = Just 42+-- > maybeIsX (XException msg)    = Nothing+-- > maybeIsX (3, XException msg) = Just (3, XException msg)+-- > maybeIsX (3, _|_)            = Just (3, _|_)+-- > maybeIsX _|_                 = _|_+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 (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 '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) -> 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, _|_)            = Right (3, _|_)+-- > isX _|_                 = _|_+isX :: a -> Either String a+isX a =+  unsafeDupablePerformIO+    (catch+      (evaluate a >> return (Right a))+      (\(XException msg) -> return (Left msg)))+{-# OPAQUE isX #-}++-- | 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 "No value here" :: Integer, 4 :: Int)+-- "(*** Exception: X: No value here+-- CallStack (from HasCallStack):+-- ...+-- >>> showX (errorX "No value here" :: Integer, 4 :: Int)+-- "(undefined,4)"+--+-- Can be derived using 'GHC.Generics':+--+-- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+-- >+-- > import Clash.Prelude+-- > import GHC.Generics+-- >+-- > data T = MkTA Int | MkTB Bool+-- >   deriving (Show,Generic,ShowX)+class ShowX a where+  -- | 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 '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 '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++-- | 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 ()+-- | @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++instance ShowX Char where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX Bool++instance ShowX Double where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX a => ShowX (Down a) where+  showsPrecX = showsPrecXWith showsPrecX++instance (ShowX a, ShowX b) => ShowX (Either a b)++instance ShowX Float where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX Int where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX Int8 where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX Int16 where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX Int32 where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX Int64 where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX Integer where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX Natural where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX Ordering++instance ShowX a => ShowX (Seq a) where+  showsPrecX _ = showListX . toList++instance ShowX Word where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX Word8 where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX Word16 where+  showsPrecX = showsPrecXWith showsPrec++instance ShowX Word32 where+  showsPrecX = showsPrecXWith showsPrec++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+  showsPrecX = showsPrecXWith showsPrecX++instance ShowX a => ShowX (Complex a)++instance {-# OVERLAPPING #-} ShowX String where+  showsPrecX = showsPrecXWith showsPrec+++-- | a variant of 'deepseqX' that is useful in some circumstances:+--+-- > forceX x = x `deepseqX` x+forceX :: NFDataX a => a -> a+forceX x = x `deepseqX` x+{-# INLINE forceX #-}++-- | 'deepseqX': fully evaluates the first argument, before returning the+-- second. Does not propagate 'XException's.+deepseqX :: NFDataX a => a -> b -> b+deepseqX a b = rnfX a `seq` b+{-# OPAQUE deepseqX #-}+{-# ANN deepseqX hasBlackBox #-}+infixr 0 `deepseqX`++-- | Reduce to weak head normal form+--+-- Equivalent to @\\x -> 'seqX' x ()@.+--+-- Useful for defining 'NFDataX.rnfX' for types for which NF=WHNF holds.+rwhnfX :: a -> ()+rwhnfX = (`seqX` ())+{-# INLINE rwhnfX #-}++-- | 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.+  deepErrorX :: HasCallStack => String -> a++  default deepErrorX :: (HasCallStack, Generic a, GDeepErrorX (Rep a)) => String -> a+  deepErrorX = withFrozenCallStack $ to . gDeepErrorX++  -- | 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 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+  rnfX s =+    if isLeft (isX s) then () else go s+   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++instance (NFDataX a, NFDataX b) => NFDataX (SG.Arg a b)+instance NFDataX (SG.All)+instance NFDataX (SG.Any)+instance NFDataX a => NFDataX (SG.Dual a)+instance NFDataX a => NFDataX (SG.Endo a)+instance NFDataX a => NFDataX (SG.First a)+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.Product a)+instance NFDataX a => NFDataX (SG.Sum a)+instance NFDataX a => NFDataX (M.First a)+instance NFDataX a => NFDataX (M.Last a)++-- | __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]++-- | __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]++-- | Call to 'errorX' with default string+undefined :: HasCallStack => a+undefined = errorX "undefined"++-- | 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
@@ -0,0 +1,393 @@+{-|+Copyright  :  (C) 2017, Google Inc,+                  2023, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++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 CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}++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+  (Clock, DiffClock(..), 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.++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.+--+-- 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++-- | 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.+--+-- __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.+--+-- 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.+--+-- 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.+--+-- __NB__: Because the clock generator reacts asynchronously to the incoming+-- reset input, the signal __must__ be glitch-free.+--+-- 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
@@ -0,0 +1,128 @@+{-|+Copyright  :  (C) 2017, Google Inc+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++DDR primitives for Xilinx FPGAs++For general information about DDR primitives see "Clash.Explicit.DDR".++For more information about the Xilinx DDR primitives see:++* Vivado Design Suite 7 Series FPGA and Zynq-7000 All Programmable SoC+  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 FlexibleContexts #-}+{-# 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)+import Clash.Explicit.Prelude+import Clash.Explicit.DDR++-- | Xilinx specific variant of 'ddrIn' implemented using the Xilinx IDDR+-- 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+  :: 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 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+  :: 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 =+  fmap unpack . uncurry (withFrozenCallStack oddr# clk rst en) . unbundle .+    fmap (bimap pack pack)++oddr#+  :: 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+{-# OPAQUE oddr# #-}+{-# ANN oddr# hasBlackBox #-}
+ src/Language/Haskell/TH/Compat.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-}++module Language.Haskell.TH.Compat where+import           Language.Haskell.TH.Syntax++-- | Compatibility helper to create TySynInstD+mkTySynInstD :: Name -> [Type] -> Type -> Dec+mkTySynInstD tyConNm tyArgs rhs =+        TySynInstD (TySynEqn Nothing+                     (foldl AppT (ConT tyConNm) tyArgs)+                     rhs)++-- | 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
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}++{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}++module Clash.Tests.BitPack where++import Test.Tasty+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)++data Unit    = Unit                        deriving (Generic, BitPack, Eq, Show)+data Wrapper = Wrapper Int                 deriving (Generic, BitPack, Eq, Show)+data Sum     = SumTypeA | SumTypeB         deriving (Generic, BitPack, Eq, Show)+data BigSum  = BS1 | BS2 | BS3 | BS4 | BS5 deriving (Generic, BitPack, Eq, Show)+data Product = Product Int Int             deriving (Generic, BitPack, Eq, Show)+data SP      = S Int Int | P Int           deriving (Generic, BitPack, Eq, Show)+data Rec1    = Rec1 { a :: Int }           deriving (Generic, BitPack, Eq, Show)+data Rec2    = Rec2 { b :: Int, c :: Int } deriving (Generic, BitPack, Eq, Show)++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+    "BitPack"+    [ testGroup+        "Generic"+        [ testCase "Unit" (rtt Unit)+        , testCase "Wrapper" (rtt (Wrapper 3))+        , testCase "SumTypeA" (rtt SumTypeA)+        , testCase "SumTypeB" (rtt SumTypeB)+        , testCase "BigSum1" (rtt BS1)+        , testCase "BigSum2" (rtt BS2)+        , testCase "BigSum3" (rtt BS3)+        , testCase "BigSum4" (rtt BS4)+        , testCase "BigSum5" (rtt BS5)+        , testCase "Product" (rtt (Product 3 5))+        , testCase "SP1" (rtt (S 3 5))+        , testCase "SP2" (rtt (P 10))+        , 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
@@ -0,0 +1,173 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# 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.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 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 "1111_1110") -> 3+    $(bitPattern "110a_babb") -> 4 + fromIntegral aa + fromIntegral bbb+    $(bitPattern "...._....") -> 4+    _                         -> 5  -- To keep exhaustiveness checker happy++tests :: TestTree+tests = localOption (Q.QuickCheckMaxRatio 2) $ testGroup "All"+  [ testGroup+    "bitPattern"+    [ testCase "case0-0" $ test1 0b00000000 @?= 0+    , testCase "case0-1" $ test1 0b00011001 @?= 0+    , testCase "case0-2" $ test1 0b01111111 @?= 0+    , testCase "case0-3" $ test1 0b01100000 @?= 0+    , testCase "case2-0" $ test1 0b11111101 @?= 2+    , testCase "case2-1" $ test1 0b11100001 @?= 2+    , testCase "case3-0" $ test1 0b11111110 @?= 3+    , testCase "case3-1" $ test1 0b11111111 @?= 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
@@ -0,0 +1,158 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Clash.Tests.DerivingDataRepr where++import Test.Tasty+import Test.Tasty.HUnit+import Prelude ((=<<), ($))+import Clash.Annotations.BitRepresentation+import Clash.Annotations.BitRepresentation.Deriving+import Clash.Tests.DerivingDataReprTypes (Train(..), RGB(..), Headphones(..), EarCup(..))+import Data.Maybe (Maybe(..))++---------------------------------------------------------+------------ DERIVING SIMPLE REPRESENTATIONS ------------+---------------------------------------------------------+oneHotOverlapLRepr :: DataReprAnn+oneHotOverlapLRepr = $( (simpleDerivator OneHot OverlapL) =<< [t| Train |] )++oneHotOverlapLRepr' :: DataReprAnn+oneHotOverlapLRepr' =+  DataReprAnn+    $(liftQ [t| Train |])+    8+    [ ConstrRepr 'Passenger   16  16  [0b1100]+    , ConstrRepr 'Freight     32  32  [0b1100, 0b0011]+    , ConstrRepr 'Maintenance 64  64  []+    , 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 |] )++oneHotWideRepr' :: DataReprAnn+oneHotWideRepr' =+  DataReprAnn+    $(liftQ [t| Train |])+    10+    [ ConstrRepr 'Passenger   64  64  [0b110000]+    , ConstrRepr 'Freight     128 128 [0b001100, 0b000011]+    , ConstrRepr 'Maintenance 256 256 []+    , ConstrRepr 'Toy         512 512 []+    ]++countOverlapRepr :: DataReprAnn+countOverlapRepr = $( (simpleDerivator Binary OverlapL) =<< [t| Train |] )++countOverlapRepr' :: DataReprAnn+countOverlapRepr' =+  DataReprAnn+    $(liftQ [t| Train |])+    6+    [ ConstrRepr 'Passenger   0b110000 0b000000 [0b001100]+    , ConstrRepr 'Freight     0b110000 0b010000 [0b001100,0b000011]+    , ConstrRepr 'Maintenance 0b110000 0b100000 []+    , ConstrRepr 'Toy         0b110000 0b110000 []+    ]++countWideRepr :: DataReprAnn+countWideRepr = $( (simpleDerivator Binary Wide) =<< [t| Train |] )++countWideRepr' :: DataReprAnn+countWideRepr' =+  DataReprAnn+    $(liftQ [t| Train |])+    8+    [ ConstrRepr 'Passenger   0b11000000 0b00000000 [0b110000]+    , ConstrRepr 'Freight     0b11000000 0b01000000 [0b001100,0b000011]+    , ConstrRepr 'Maintenance 0b11000000 0b10000000 []+    , ConstrRepr 'Toy         0b11000000 0b11000000 []+    ]++------------------------------------------------+------------ PACKED REPRESENTATIONS ------------+------------------------------------------------++packedRepr :: DataReprAnn+packedRepr = $( packedDerivator =<< [t| Train |] )++packedRepr' :: DataReprAnn+packedRepr' =+  DataReprAnn+    $(liftQ [t| Train |])+    5+    [ ConstrRepr 'Freight     0b10000 0 [12,3]+    , ConstrRepr 'Passenger   3       1 [12]+    , ConstrRepr 'Toy         3       2 []+    , ConstrRepr 'Maintenance 3       3 []+    ]++------------------------------------------------------+------------ PACKED MAYBE REPRESENTATIONS ------------+------------------------------------------------------++packedMaybeRGB :: DataReprAnn+packedMaybeRGB = $( packedMaybeDerivator $(defaultDerivator =<< [t| Maybe RGB |]) =<< [t| Maybe RGB |] )++packedMaybeRGB' :: DataReprAnn+packedMaybeRGB' =+  DataReprAnn+    $(liftQ [t| Maybe RGB |])+    2+    [ ConstrRepr 'Nothing 0b11 0b11 []+    , ConstrRepr 'Just    0b00 0b00 [0b11]+    ]++-- MAIN+tests :: TestTree+tests = testGroup "DerivingDataRepr"+  [ 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
@@ -0,0 +1,39 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Clash.Tests.DerivingDataReprTypes where++import Clash.Sized.Unsigned+import Clash.Annotations.BitRepresentation.Deriving++type SmallInt = Unsigned 2++data Train+  = Passenger+      -- Number of wagons:+      SmallInt+  | Freight+      -- Number of wagons:+      SmallInt+      -- Max weight:+      SmallInt+  | Maintenance+  | Toy+++data RGB+  = R+  | G+  | B++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
@@ -0,0 +1,176 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}++{-# 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.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 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 #-}++tests :: TestTree+tests =+  testGroup+    "NFDataX"+    [ testGroup+        "GenericRnf"+        [ testCase "Unit"     $ rnfX (undef :: Unit)                  @?= ()+        , testCase "Wrapper1" $ rnfX (undef :: Wrapper)               @?= ()+        , testCase "Wrapper2" $ rnfX (Wrapper undef)                  @?= ()+        , testCase "Sum"      $ rnfX (undef :: Sum)                   @?= ()+        , testCase "BigSum"   $ rnfX (undef :: BigSum)                @?= ()+        , testCase "Product1" $ rnfX (undef :: Product)               @?= ()+        , testCase "Product2" $ rnfX (Product undef undef :: Product) @?= ()+        , testCase "Product3" $ rnfX (Product 3 undef :: Product)     @?= ()+        , testCase "Product4" $ rnfX (Product undef 5 :: Product)     @?= ()+        , testCase "SP1"      $ rnfX (undef :: SP)                    @?= ()+        , testCase "SP2"      $ rnfX (S undef undef :: SP)            @?= ()+        , testCase "SP3"      $ rnfX (S 3 undef :: SP)                @?= ()+        , testCase "SP3"      $ rnfX (S undef 5 :: SP)                @?= ()+        , testCase "SP4"      $ rnfX (P undef :: SP)                  @?= ()+        , testCase "Rec0"     $ rnfX (undef :: Rec0)                  @?= ()+        , testCase "Rec1_1"   $ rnfX (undef :: Rec1)                  @?= ()+        , testCase "Rec1_2"   $ rnfX (Rec1 undef)                     @?= ()+        , testCase "Rec2_1"   $ rnfX (undef :: Rec2)                  @?= ()+        , testCase "Rec2_2"   $ rnfX (Rec2 3 undef)                   @?= ()+        , testCase "Rec2_3"   $ rnfX (Rec2 undef 5)                   @?= ()+        , testCase "Void"     $ rnfX (undef :: Void)                  @?= ()+        ]+    , testGroup+        "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)            @?= ()+        , testCase "Maybe2"    $ rnfX (Just undef :: Maybe Int)       @?= ()+        , testCase "Either1"   $ rnfX (undef :: Either Int Int)       @?= ()+        , testCase "Either2"   $ rnfX (Left undef :: Either Int Int)  @?= ()+        , testCase "Either3"   $ rnfX (Right undef :: Either Int Int) @?= ()+        , 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
@@ -0,0 +1,216 @@+{-|+Copyright  :  (C) 2019, Myrtle Software Ltd+                  2022, Google Inc.+                  2023, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# 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 qualified Prelude as P+import           Prelude hiding (undefined)++import qualified Clash.Explicit.Prelude         as E+import           Clash.Prelude                  hiding (sample)++import           Clash.Signal.Internal+  (Femtoseconds(..), dynamicClockGen, sample, head#)++import           Control.Exception              (evaluate)+import           Test.Tasty+import           Test.Tasty.HUnit++createDomain vSystem{vName="H11", vPeriod=hzToPeriod 11}+createDomain vSystem{vName="H77", vPeriod=hzToPeriod 77}++createDomain vSystem{vName="F1", vPeriod=20}+createDomain vSystem{vName="F6", vPeriod=250}++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+  testGroup+    "Signal"+    [ testGroup+        "Implicit"+        [ -- See: https://github.com/clash-lang/clash-compiler/pull/655+          let rst0 = fromList [True, True, False, False, True, True]+              rst1 = unsafeFromActiveHigh rst0+              reg  = register 'a' (pure 'b')+              sig = withReset @System rst1 reg+          in  testCase "withReset behavior" (sampleN @System 6 sig @?= "aaabaa")++        , 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+      ]+    ]++-- | 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++    clk11 = clockGen @H11+    clk77 = clockGen @H77++    -- 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)++    dclk11 = dynamicClockGen @H11 (pure fs11)+    dclk77 = dynamicClockGen @H77 (pure fs77)++    counter :: forall dom. Signal dom Int+    counter = fromList [0..]++  assertEqual+    "clk11+clk77 == dclk11+dclk77"+    (sampleMagicN (E.unsafeSynchronizer clk11 clk77 counter))+    (sampleMagicN (E.unsafeSynchronizer dclk11 dclk77 counter))++  assertEqual+    "clk11+dclk77 == dclk11+clk77"+    (sampleMagicN (E.unsafeSynchronizer clk11 dclk77 counter))+    (sampleMagicN (E.unsafeSynchronizer dclk11 clk77 counter))++-- | Asserts that "lying" about a clock's frequency has effect.+case_dynamicHasEffect :: Assertion+case_dynamicHasEffect = do+  let+    sampleMagicN = P.take 500 . sample++    -- 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+    ]++-- | Regression test+case_F1_F6 :: Assertion+case_F1_F6 = do+  let+    clk1 = clockGen @F1+    clk6 = clockGen @F6++    counter = fromList [(0 :: Int)..]++    actual = P.take 70 (sample (E.unsafeSynchronizer clk1 clk6 counter))++  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,6 +1,8 @@+{-# LANGUAGE CPP #-} module Main where -import Test.DocTest (doctest)+import Test.DocTest (mainFromCabal)+import System.Environment (getArgs)  main :: IO ()-main = doctest ["-i src","CLaSH.Prelude","CLaSH.Examples","CLaSH.Tutorial"]+main = mainFromCabal "clash-prelude" =<< getArgs
+ tests/unittests.hs view
@@ -0,0 +1,74 @@+module Main where++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.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.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.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 ()+main = defaultMain tests