packages feed

clash-lib 0.7.1 → 1.10.0

raw patch · 340 files changed

Files

CHANGELOG.md view
@@ -1,279 +1,1070 @@-# Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package--## 0.7.1 *April 11th 2017*-* New features:-  * Support distribution of primitive templates with Cabal/Hackage packages [commit](https://github.com/clash-lang/clash-compiler/commit/82cd31863aafcbaf3bdbf7746d89d13859af5aaf)-  * Find memory data files and primitive files relative to import dirs (`-i<DIR>`)-* Fixes bugs:-  * `case (EmptyCase ty) of ty' { ... }` -> `EmptyCase ty'` [#198](https://github.com/clash-lang/clash-compiler/issues/198)-  * `BitVector.split#` apply the correct type arguments--## 0.7 *January 16th 2017*-* New features:-  * Support for `clash-prelude` 0.11-  * Primitive templates can include QSys files-  * VHDL blackboxes: support additional libraries and uses keywords in generated VHDL-  * Highly limited Float/Double support (literals and `Rational` conversion), hidden behind the `-clash-float-support` flag.-* Fixes bugs:-  * Reduce type families inside clock period calculation [#180](https://github.com/clash-lang/clash-compiler/issues/180)-  * Only output signed literals as hex when they're multiple of 4 bits [#187](https://github.com/clash-lang/clash-compiler/issues/187)-  * Correctly print negative hex literals--## 0.6.21 *August 18th 2016*-* Fixes bugs:-  * Type families are not currently being reduced correctly [#167](https://github.com/clash-lang/clash-compiler/issues/167)--## 0.6.20 *August 3rd 2016*-* Fixes bugs:-  * Bug in DEC transformation overwrites case-alternatives-  * Bug in DEC transformation creates non-representable let-binders--## 0.6.19 *July 19th 2016*-* Fixes bugs:-  * Rounding error in `logBase` calculation--## 0.6.18 *July 15th 2016*-* New features:-  * Better error location reporting-* Fixes bugs:-  * Values of type Index 'n', where 'n' > 2^MACHINE_WIDTH, incorrectly considered non-synthesisable due to overflow--## 0.6.17 *June 9th 2016*-* Fixes bugs:-  * `Eq` instance of `Vec` sometimes not synthesisable--## 0.6.16 *June 7th 2016*-* New features:-  * DEC transformation also lifts HO-primitives applied to "interesting" primitives (i.e. `zipWith (*)`)-* Fixes bugs:-  * replicate unfolded incorrectly [#150](https://github.com/clash-lang/clash-compiler/issues/150)-  * `imap` is not unrolled [#151](https://github.com/clash-lang/clash-compiler/issues/151)--## 0.6.15 *April 7th 2016*-* New features:-  * Up to 2x reduced compilation times when working with large `Vec` literals-* Fixes bugs:-  * Bug in DEC transformation throws CLaSH into an endless loop [#140](https://github.com/clash-lang/clash-compiler/issues/140)--## 0.6.14 *March 21st 2016*-* New features:-  * Also generate testbench for circuits without input ports [#135](https://github.com/clash-lang/clash-compiler/issues/135)-* Fixes bugs:-  * `clockWizard` broken [#49](https://github.com/clash-lang/clash-prelude/issues/49)--## 0.6.13 *March 14th 2016*-* Fixes bugs:-  * Not all lambda's in a function position removed--## 0.6.12 *March 14th 2016*-* Fixes bugs:-  * Not all lambda's in a function position removed due to bad eta-expansion [#132](https://github.com/clash-lang/clash-compiler/issues/132)--## 0.6.11 *March 11th 2016*-* New features:-  * Add support for HDL synthesis tool specific HDL generation-  * Preserve more Haskell names in generated HDL [#128](https://github.com/clash-lang/clash-compiler/issues/128)--## 0.6.10 *February 10th 2016*-* New features:-  * hdl files can be written to a directory other than the current working directory [#125](https://github.com/clash-lang/clash-compiler/issues/125)-* Fixes bugs:-  * `caseCon` transformation does not work on non-exhaustive case-expressions [#123](https://github.com/clash-lang/clash-compiler/issues/123)-  * Primitive reductions don't look through `Signal` [#126](https://github.com/clash-lang/clash-compiler/issues/126)--## 0.6.9-* Fixes bugs:-  * `case undefined of ...` should reduce to `undefined` [#116](https://github.com/clash-lang/clash-compiler/issues/109)-  * Type families obscure eligibility for synthesis [#114](https://github.com/clash-lang/clash-compiler/issues/114)--## 0.6.8 *January 13th 2015*-* New features:-  * Support for Haskell's: `Char`, `Int8`, `Int16`, `Int32`, `Int64`, `Word`, `Word8`, `Word16`, `Word32`, `Word64`.-  * Int/Word/Integer bitwidth for generated HDL is configurable using the `-clash-intwidth=N` flag, where `N` can be either 32 or 64.-* Fixes bugs:-  * Cannot reduce `case error ... of ...` to `error ...` [#109](https://github.com/clash-lang/clash-compiler/issues/109)--## 0.6.7 *December 21st 2015*-* Support for `unbound-generics-0.3`-* New features:-  * Only look for 'topEntity' in the root module. [#22](https://github.com/clash-lang/clash-compiler/issues/22)--## 0.6.6 *December 11th 2015*-* New features:-  * Remove all existing HDL files before generating new ones. This can be disabled by the `-clash-noclean` flag. [#96](https://github.com/clash-lang/clash-compiler/issues/96)-  * Support for `clash-prelude` 0.10.4--## 0.6.5 *November 17th 2015*-* Fixes bugs:-  * Integer literals used as arguments not always properly annotated with their type.--## 0.6.4 *November 12th 2015*-* Fixes bugs:-  * Reversing alternatives is not meaning preserving for literal patterns [#91](https://github.com/clash-lang/clash-compiler/issues/91)-  * DEC: root of the case-tree must contain at least 2 alternatives [#92](https://github.com/clash-lang/clash-compiler/issues/92)--## 0.6.3 *October 24th 2015*-* New features:-  * Improve DEC transformation: consider alternatives before the subject when checking for disjoint expressions.-* Fixes bugs:-  * DEC: don't generate single-branch case-expressions [#90](https://github.com/clash-lang/clash-compiler/issues/90)--## 0.6.2 *October 21st 2015*-* Fixes bugs:-  * DEC: Subject and alternatives are not disjoint [#88](https://github.com/clash-lang/clash-compiler/issues/88)--## 0.6.1 *October 16th 2015*-* New features:-  * Support for `clash-prelude` 0.10.1-  * Transformation that lifts applications of the same function out of alternatives of case-statements. e.g.--    ```haskell-    case x of-      A -> f 3 y-      B -> f x x-      C -> h x-    ```--    is transformed into:--    ```haskell-    let f_arg0 = case x of {A -> 3; B -> x}-        f_arg1 = case x of {A -> y; B -> x}-        f_out  = f f_arg0 f_arg1-    in  case x of-          A -> f_out-          B -> f_out-          C -> h x-    ```--* Fixes bugs:-  * Case-statements acting like normal decoder circuits are erroneously synthesised to priority decoder circuits.--## 0.6 *October 3rd 2015*-* New features:-  * Support for `clash-prelude` 0.10-  * Add `~INDEXTYPE` tag: primitives get access to the `Index` clash-prelude type-  * Add `~IF` construct: primitives can do conditional templating-  * Unroll "definitions" of the following primitives: `fold`, `dfold`, `foldr`--## 0.5.13 *September 21st 2015*-* Fixes bugs:-  * Performance bug: top-level definitions of type "Signal" erroneously inlined.--## 0.5.12 *September 14th 2015*-* New features:-  * Completely unroll "definitions" of some higher-order primitives with non-representable argument or result vectors:-    It is now possible to translate e.g. `f xs ys = zipWith ($) (map (+) xs) ys :: Vec 4 Int -> Vec 4 Int -> Vec 4 Int`--* Fixes bugs:-  * `topLet` transformation erroneously not performed in a top-down traversal-  * Specialisation limit unchecked on types and constants-  * Vector of functions cannot be translated [#25](https://github.com/clash-lang/clash-compiler/issues/25 )-  * CLaSH fails to generate VHDL when map is applied [#78](https://github.com/clash-lang/clash-compiler/issues/78)--## 0.5.11 *September 7th 2015*-* Fixes bugs:-  * Clash running out of memory on Simple-ish project [#70](https://github.com/clash-lang/clash-compiler/issues/70)-  * `CLaSH.Sized.Vector.:>` was not allowed as a function argument to HO-primitives--## 0.5.10 *August 2nd 2015*-* Fixes bugs:-  * Make testbench generation deterministic-  * Compile against unbound-generics-0.2--## 0.5.9 *July 9th 2015*-* Fixes bugs:-  * `coreView` didn't look through newtypes of the form: `newtype Foo a = MkFoo (Maybe a)`--## 0.5.8 *June 26th 2015*-* Fixes bugs:-  * Allow text and tags in ~SIGD black box construct--## 0.5.7 *June 25th 2015*-* New features:-  * Support for copying string literals from Haskell to generated code-  * Collect and copy data-files--* Fixes bugs:-  * Signals declared twice when not using a clock-generating component [#60](https://github.com/clash-lang/clash-compiler/issues/60)-  * This piece of code eat up all CPU when generating verilog [#62](https://github.com/clash-lang/clash-compiler/issues/60)--## 0.5.6 *June 3rd 2015*-* New features:-  * Support Verilog backend-  * Generated component names are prefixed by the name of the module containing the `topEntity`--## 0.5.5 *May 18th 2015*-* New features:-  * Make inlining and specialisation limit configurable-  * Make debug message level configurable--* Fixes bugs:-  * Netlist: ensure that the arguments of a component instantiation are always simple variables-  * CaseCon transformation: ensure that we run the compile-time evaluator on the subject before handling the one-alternative case-  * Emit a warning if a function remains recursive, instead of producing an error: compilation can still be successful if the function is an argument to a higher-order blackbox that doesn't use the function.-  * Emit a warning if inlining limit is reached, instead of producing an error: compilation can still be successful if the function is an argument to a higher-order blackbox that doesn't use the function.-  * Always inline terms that have a type of kind `Constraint`--## 0.5.4 *May 10th 2015*-* New features:-  * Add `~COMPNAME` tag: primitives get access to the component name in which they are instantiated--## 0.5.3 *May 5th 2015*-* New features:-  * `TopEntity` wrappers are now specified as `ANN` annotation pragmas-* Fixes bugs:-  * Lost system1000 clock in VHDL generation... [#53](https://github.com/clash-lang/clash-compiler/issues/53)-  * `flattenCallTree` sometimes introduces free variables--## 0.5.2 *May 1st 2015*-* New features:-  * Generate wrappers around `topEntity` that have constant names and types--## 0.5.1 *April 20th 2015*-* GHC 7.10 support--## 0.5 *March 11th 2015*-* New features:-  * Simplify BlackBox handling, and improve VHDL generation. [#47](https://github.com/clash-lang/clash-compiler/issues/47)-  * Use unbound-generics. [#48](https://github.com/clash-lang/clash-compiler/issues/48)--* Fixes bugs:-  * VHDL generation error: wrapper for sum-of-products type. [#44](https://github.com/clash-lang/clash-compiler/issues/44)--## 0.4.1 *February 4th 2015*-* Fixes bugs:-  * Treat BlackBox expressions as declarations when DC args. [#37](https://github.com/christiaanb/clash2/issues/33)-  * Don't inline recursive closed bindings--## 0.4 *November 17th 2014*-* New features:-  * Support for clash-prelude 0.6--* Fixes bugs:-  * Ambiguous type: 'std_logic_vector' or 'std_ulogic_vector' [#33](https://github.com/christiaanb/clash2/issues/33)--## 0.3.2 *June 5th 2014*--* Fixes bugs:-  * VHDL array constant ambiguous [#18](https://github.com/christiaanb/clash2/issues/18)-  * Exception: can't create selector [#24](https://github.com/christiaanb/clash2/issues/24)-  * Calls to `vhdlTypeMark` don't result to inclusion of VHDL type in types.vhdl [#28](https://github.com/christiaanb/clash2/issues/28)--## 0.3.1 *May 15th 2014*--* New features:-  * Make ANF lift non-representable values [#7](https://github.com/christiaanb/clash2/issues/7)-  * Hardcode `fromInteger` for `Signed` and `Unsigned` [#9](https://github.com/christiaanb/clash2/issues/9)-  * Replace VHDL default hole by error hole [#13](https://github.com/christiaanb/clash2/issues/13)--* Fixes bugs:-  * Type families are not expanded [#3](https://github.com/christiaanb/clash2/issues/3)-  * Exception: CLaSH.Netlist.VHDL(512): fromSLV: Vector 13 Bool [#5](https://github.com/christiaanb/clash2/issues/5)-  * Incorrect vhdl generation for default value in blackbox [#6](https://github.com/christiaanb/clash2/issues/6)-  * Duplicate type names when multiple ADTs need the same amount of bits [#8](https://github.com/christiaanb/clash2/issues/8)-  * Circuit testbench generation with MAC example fails[#15](https://github.com/christiaanb/clash2/issues/15)--* Code improvements:-  * Refactor Netlist/BlackBox [#10](https://github.com/christiaanb/clash2/issues/10)-  * CPP special-case conversion of `Control.Exception.Base.irrefutPatError` [#11](https://github.com/christiaanb/clash2/issues/11)+# 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) 2012-2016, University of Twente,-              2017, QBayLogic+              2016-2017, Myrtle Software Ltd,+              2017-2019, QBayLogic B.V., Google Inc. All rights reserved.  Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,18 +1,17 @@-# `clash-lib` - CλaSH compiler, as a library+# `clash-lib` - Clash compiler, as a library    * See the LICENSE file for license and copyright details -# CλaSH - A functional hardware description language-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 - A functional hardware description language+Clash is a functional hardware description language that borrows both+its syntax and semantics from the functional programming language+Haskell. The Clash compiler transforms these high-level descriptions to low-level synthesizable VHDL, Verilog, or SystemVerilog. -Features of CλaSH:+Features of Clash: -  * Strongly typed (like VHDL), yet with a very high degree of type inference,-    enabling both safe and fast prototying using consise descriptions (like-    Verilog).+  * Strongly typed, but with a very high degree of type inference, enabling both+    safe and fast prototyping using concise descriptions.    * Interactive REPL: load your designs in an interpreter and easily test all     your component without needing to setup a test bench.@@ -25,5 +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)
clash-lib.cabal view
@@ -1,13 +1,14 @@+Cabal-version:        2.2 Name:                 clash-lib-Version:              0.7.1-Synopsis:             CAES Language for Synchronous Hardware - As a Library+Version:              1.10.0+Synopsis:             Clash: a functional hardware description language - As a 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.@@ -36,131 +37,402 @@   .   Front-ends (for: parsing, typecheck, etc.) are provided by separate packages:   .-  * <http://hackage.haskell.org/package/clash-ghc GHC/Haskell Frontend>+  * <https://hackage.haskell.org/package/clash-ghc GHC/Haskell Frontend>   .   * <https://github.com/christiaanb/Idris-dev Idris Frontend>   .   .-  Prelude library: <http://hackage.haskell.org/package/clash-prelude>-Homepage:             http://www.clash-lang.org/-bug-reports:          http://github.com/clash-lang/clash-compiler/issues-License:              BSD2+  Prelude library: <https://hackage.haskell.org/package/clash-prelude>+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>-Copyright:            Copyright © 2012-2016, University of Twente, 2017, QBayLogic+Author:               The Clash Authors+Maintainer:           QBayLogic B.V. <devops@qbaylogic.com>+Copyright:            Copyright © 2012-2016, University of Twente,+                                  2016-2019, Myrtle Software Ltd,+                                  2017-2023, QBayLogic B.V., Google Inc. 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+Extra-source-files:+  README.md,+  CHANGELOG.md,+  src/ClashDebug.h -Cabal-version:        >=1.10+Data-files:+  data-files/tcl/clashConnector.tcl+  prims/common/*.primitives.yaml,+  prims/commonverilog/*.primitives.yaml,+  prims/verilog/*.primitives.yaml,+  prims/systemverilog/*.primitives.yaml,+  prims/vhdl/*.primitives.yaml  source-repository head   type: git   location: https://github.com/clash-lang/clash-compiler.git+  subdir: clash-lib +flag debug+   description:+     Build a debug compiler+   default: False+   manual: True++flag unittests+  description:+    You can disable testing with unittests using `-f-unittests`.+  default: True+  manual: True++flag doctests+  description:+    You can disable testing with doctests using `-f-doctests`.+  default: True+  manual: True++flag workaround-ghc-mmap-crash+  description:+    Only use this flag when hit by GHC bug #19421. See clash-compiler PR #2444.+  default: False+  manual: True++common common-options+  default-language:   Haskell2010+  default-extensions: BangPatterns+                      BinaryLiterals+                      DataKinds+                      DefaultSignatures+                      DeriveDataTypeable+                      DeriveFoldable+                      DeriveFunctor+                      DeriveGeneric+                      DeriveLift+                      DeriveTraversable+                      DerivingStrategies+                      InstanceSigs+                      KindSignatures+                      NoStarIsType+                      PostfixOperators+                      ScopedTypeVariables+                      StandaloneDeriving+                      TupleSections+                      TypeApplications+                      TypeOperators+                      ViewPatterns+ Library+  import:             common-options   HS-Source-Dirs:     src -  default-language:   Haskell2010-  ghc-options:        -Wall+  ghc-options:        -Wall -Wcompat   CPP-Options:        -DCABAL    other-extensions:   CPP                       DeriveAnyClass-                      DeriveGeneric-                      DeriveFoldable-                      DeriveFunctor                       FlexibleContexts                       FlexibleInstances                       GeneralizedNewtypeDeriving                       LambdaCase                       MultiParamTypeClasses                       OverloadedStrings-                      Rank2Types+                      RankNTypes                       RecordWildCards-                      ScopedTypeVariables                       TemplateHaskell-                      TupleSections-                      ViewPatterns -  Build-depends:      aeson                   >= 0.6.2.0  && < 1.2,-                      attoparsec              >= 0.10.4.0 && < 0.14,-                      base                    >= 4.8      && < 5,-                      bytestring              >= 0.10.0.2 && < 0.11,-                      clash-prelude           >= 0.11     && < 0.12,-                      concurrent-supply       >= 0.1.7    && < 0.2,-                      containers              >= 0.5.0.0  && < 0.6,+  Build-depends:      aeson                   >= 2.0.0.0  && < 2.3,+                      attoparsec-aeson        >= 2.1      && < 2.3,+                      aeson-pretty            >= 0.8      && < 0.9,+                      ansi-terminal           >= 0.8.0.0  && < 1.2,+                      array,+                      async                   >= 2.2.0    && < 2.3,+                      attoparsec              >= 0.10.4.0 && < 0.15,+                      base                    >= 4.18     && < 5,+                      base16-bytestring       >= 0.1.1    && < 1.1,+                      binary                  >= 0.8.5    && < 0.11,+                      bytestring              >= 0.10.0.2 && < 0.13,+                      clash-prelude           == 1.10.0,+                      containers              >= 0.6.7    && < 0.9,+                      cryptohash-sha256       >= 0.11     && < 0.12,                       data-binary-ieee754     >= 0.4.4    && < 0.6,-                      deepseq                 >= 1.3.0.2  && < 1.5,+                      data-default            >= 0.7      && < 0.9,+                      deepseq                 >= 1.3.0.2  && < 1.6,+                      dlist                   >= 0.8      && < 1.1,                       directory               >= 1.2.0.1  && < 1.4,-                      errors                  >= 1.4.2    && < 2.2,-                      fgl                     >= 5.4.2.4  && < 5.6,-                      filepath                >= 1.3.0.1  && < 1.5,-                      ghc                     >= 8.0.1    && < 8.2,-                      hashable                >= 1.2.1.0  && < 1.3,-                      integer-gmp             >= 1.0      && < 1.1,-                      lens                    >= 3.9.2    && < 4.16,-                      mtl                     >= 2.1.2    && < 2.3,-                      pretty                  >= 1.1.1.0  && < 1.2,-                      process                 >= 1.1.0.2  && < 1.5,-                      template-haskell        >= 2.8.0.0  && < 2.12,-                      text                    >= 0.11.3.1 && < 1.3,-                      time                    >= 1.4.0.1  && < 1.8,-                      transformers            >= 0.3.0.0  && < 0.6,-                      unbound-generics        >= 0.1      && < 0.4,-                      unordered-containers    >= 0.2.3.3  && < 0.3,-                      uu-parsinglib           >= 2.8.1    && < 2.10,-                      wl-pprint-text          >= 1.1.0.0  && < 1.2+                      exceptions              >= 0.8.3    && < 0.11.0,+                      extra                   >= 1.6.17   && < 1.9,+                      filepath                >= 1.3.0.1  && < 1.6,+                      ghc                     >= 9.6.0    && < 9.13,+                      ghc-boot,+                      ghc-boot-th,+                      ghc-prim,+                      ghc-bignum              >=1.0       && <1.4,+                      hashable                >= 1.4.1.0  && < 1.6,+                      haskell-src-meta        >= 0.8      && < 0.9,+                      hint                    >= 0.7      && < 0.10,+                      infinite-list           ^>= 0.1,+                      lens                    >= 4.10     && < 5.4,+                      mtl                     >= 2.3.1    && < 2.4,+                      ordered-containers      >= 0.2      && < 0.3,+                      prettyprinter           >= 1.2.0.1  && < 1.8,+                      prettyprinter-interp    ^>= 0.2,+                      pretty-show             >= 1.9      && < 2.0,+                      primitive               >= 0.5.0.1  && < 1.0,+                      string-interpolate      ^>= 0.3,+                      template-haskell        >= 2.20.0.0  && < 2.24,+                      temporary               >= 1.2.1    && < 1.4,+                      terminal-size           >= 0.3      && < 0.4,+                      text                    >= 1.2.2    && < 2.2,+                      time                    >= 1.4.0.1  && < 1.15,+                      transformers            >= 0.6.1.0  && < 0.7,+                      trifecta                >= 1.7.1.1  && < 2.2,+                      vector                  >= 0.11     && < 1.0,+                      vector-binary-instances >= 0.2.3.5  && < 0.3,+                      unordered-containers    >= 0.2.11   && < 0.3,+                      yaml                    >= 0.11     && < 0.12, -  Exposed-modules:    CLaSH.Backend+  Autogen-Modules:    Paths_clash_lib -                      CLaSH.Core.DataCon-                      CLaSH.Core.FreeVars-                      CLaSH.Core.Literal-                      CLaSH.Core.Pretty-                      CLaSH.Core.Subst-                      CLaSH.Core.Term-                      CLaSH.Core.TyCon-                      CLaSH.Core.Type-                      CLaSH.Core.TysPrim-                      CLaSH.Core.Util-                      CLaSH.Core.Var+  Exposed-modules:    Clash.Annotations.BitRepresentation.ClashLib -                      CLaSH.Driver-                      CLaSH.Driver.TestbenchGen-                      CLaSH.Driver.TopWrapper-                      CLaSH.Driver.Types+                      Clash.Backend+                      Clash.Backend.SystemVerilog+                      Clash.Backend.Verilog+                      Clash.Backend.Verilog.Time+                      Clash.Backend.VHDL -                      CLaSH.Netlist-                      CLaSH.Netlist.BlackBox-                      CLaSH.Netlist.BlackBox.Parser-                      CLaSH.Netlist.BlackBox.Types-                      CLaSH.Netlist.BlackBox.Util-                      CLaSH.Netlist.Id-                      CLaSH.Netlist.Types-                      CLaSH.Netlist.Util+                      Clash.Core.DataCon+                      Clash.Core.EqSolver+                      Clash.Core.Evaluator.Types+                      Clash.Core.FreeVars+                      Clash.Core.HasType+                      Clash.Core.HasFreeVars+                      Clash.Core.Literal+                      Clash.Core.Name+                      Clash.Core.PartialEval+                      Clash.Core.PartialEval.AsTerm+                      Clash.Core.PartialEval.Monad+                      Clash.Core.PartialEval.NormalForm+                      Clash.Core.Pretty+                      Clash.Core.Subst+                      Clash.Core.Term+                      Clash.Core.TermInfo+                      Clash.Core.TermLiteral+                      Clash.Core.TermLiteral.TH+                      Clash.Core.TyCon+                      Clash.Core.Type+                      Clash.Core.TysPrim+                      Clash.Core.Util+                      Clash.Core.Var+                      Clash.Core.VarEnv -                      CLaSH.Normalize-                      CLaSH.Normalize.DEC-                      CLaSH.Normalize.PrimitiveReductions-                      CLaSH.Normalize.Strategy-                      CLaSH.Normalize.Transformations-                      CLaSH.Normalize.Types-                      CLaSH.Normalize.Util+                      Clash.Data.UniqMap -                      CLaSH.Primitives.Types-                      CLaSH.Primitives.Util+                      Clash.DataFiles -                      CLaSH.Rewrite.Combinators-                      CLaSH.Rewrite.Types-                      CLaSH.Rewrite.Util+                      Clash.Debug -                      CLaSH.Util+                      Clash.Driver+                      Clash.Driver.Bool+                      Clash.Driver.BrokenGhcs+                      Clash.Driver.Manifest+                      Clash.Driver.Types -  Other-Modules:      Data.Aeson.Extra-                      GHC.Extra+                      Clash.Edalize.Edam++                      Clash.Netlist+                      Clash.Netlist.BlackBox+                      Clash.Netlist.BlackBox.Parser+                      Clash.Netlist.BlackBox.Types+                      Clash.Netlist.BlackBox.Util+                      Clash.Netlist.Expr+                      Clash.Netlist.Id+                      Clash.Netlist.Id.Common+                      Clash.Netlist.Id.Internal+                      Clash.Netlist.Id.SystemVerilog+                      Clash.Netlist.Id.Verilog+                      Clash.Netlist.Id.VHDL+                      Clash.Netlist.Types+                      Clash.Netlist.Util++                      Clash.Normalize+                      Clash.Normalize.PrimitiveReductions+                      Clash.Normalize.Primitives+                      Clash.Normalize.Strategy+                      Clash.Normalize.Transformations+                      Clash.Normalize.Transformations.ANF+                      Clash.Normalize.Transformations.Case+                      Clash.Normalize.Transformations.Cast+                      Clash.Normalize.Transformations.DEC+                      Clash.Normalize.Transformations.EtaExpand+                      Clash.Normalize.Transformations.Inline+                      Clash.Normalize.Transformations.Letrec+                      Clash.Normalize.Transformations.MultiPrim+                      Clash.Normalize.Transformations.Reduce+                      Clash.Normalize.Transformations.SeparateArgs+                      Clash.Normalize.Transformations.Specialize+                      Clash.Normalize.Transformations.XOptimize+                      Clash.Normalize.Types+                      Clash.Normalize.Util++                      Clash.Primitives.DSL+                      Clash.Primitives.Types+                      Clash.Primitives.Util++                      Clash.Primitives.Annotations.SynthesisAttributes+                      Clash.Primitives.GHC.Int+                      Clash.Primitives.GHC.Literal+                      Clash.Primitives.GHC.Word+                      Clash.Primitives.Intel.ClockGen+                      Clash.Primitives.Magic+                      Clash.Primitives.Sized.ToInteger+                      Clash.Primitives.Sized.Signed+                      Clash.Primitives.Sized.Vector+                      Clash.Primitives.Verification+                      Clash.Primitives.Xilinx.ClockGen++                      Clash.Rewrite.Combinators+                      Clash.Rewrite.Types+                      Clash.Rewrite.Util+                      Clash.Rewrite.WorkFree++                      Clash.Unique+                      Clash.Util+                      Clash.Util.Eq+                      Clash.Util.Graph+                      Clash.Util.Interpolate+                      Clash.Util.Supply+                      Clash.Pretty++                      Clash.Verification.Pretty++                      -- Used in v16-upgrade-primitives to decode our non-standard+                      -- JSON primitive files.+                      Data.Aeson.Extra++                      -- Used in clash-cores+                      Data.Text.Prettyprint.Doc.Extra++                      -- Used in clash-ghc+                      GHC.BasicTypes.Extra++  Other-Modules:      Clash.Annotations.TopEntity.Extra+                      Data.List.Extra+                      Data.Map.Ordered.Extra+                      Data.Monoid.Extra+                      Data.Primitive.ByteArray.Extra+                      Data.Set.Ordered.Extra+                      Data.Text.Extra+                      GHC.SrcLoc.Extra                       Paths_clash_lib-                      Unbound.Generics.LocallyNameless.Extra++  if flag(debug)+    cpp-options:      -DDEBUG++executable v16-upgrade-primitives+  Main-Is:            tools/v16-upgrade-primitives.hs+  Build-Depends:+    base,+    aeson,+    attoparsec-aeson,+    deepseq,+    yaml,+    bytestring,+    clash-lib,+    text,+    containers,+    directory,+    Glob+  GHC-Options:        -Wall -Wcompat+  default-language:   Haskell2010++executable static-files+  Main-Is:            tools/static-files.hs+  Build-Depends:+    base,+    clash-lib,+    directory,+    docopt                  ^>= 0.7,+    extra,+    filepath+  GHC-Options:        -Wall -Wcompat+  default-language:   Haskell2010+  buildable: False+++test-suite doctests+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  main-is:          doctests.hs+  ghc-options:      -Wall -Wcompat -threaded+  hs-source-dirs:   tests++  if !flag(doctests)+    buildable: False+  else+    build-depends:+      base,+      clash-lib,+      doctest-parallel >= 0.2 && < 0.5,+      filepath++test-suite unittests+  import:           common-options+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  main-is:          unittests.hs+  ghc-options:      -Wall -Wcompat -threaded+  -- Note that multiple -with-rtsopts are not cumulative, so we can't add the+  -- common RTS options in the unconditional GHC-Options+  if 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,+      clash-lib,++      ghc-typelits-knownnat,++      aeson,+      attoparsec-aeson,+      aeson-pretty,+      base,+      base16-bytestring,+      bytestring,+      containers,+      data-default,+      deepseq,+      haskell-src-exts,+      ghc,+      lens,+      pretty-show,+      quickcheck-text,+      tasty         >= 1.2      && < 1.6,+      tasty-hunit,+      tasty-quickcheck,+      tasty-th,+      template-haskell,+      text,+      transformers,+      unordered-containers++  Other-Modules: Clash.Tests.Core.FreeVars+                 Clash.Tests.Core.Subst+                 Clash.Tests.Core.TermLiteral+                 Clash.Tests.Core.TermLiteral.Types+                 Clash.Tests.Driver.Manifest+                 Clash.Tests.Netlist.Id+                 Clash.Tests.Util.Interpolate+                 Clash.Tests.Normalize.Transformations++                 Test.Clash.Rewrite
+ data-files/tcl/clashConnector.tcl view
@@ -0,0 +1,606 @@+# Copyright  :  (C) 2021-2022, QBayLogic B.V.,+#                   2022     , Google Inc.,+# License    :  BSD2 (see the file LICENSE)+# Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+#+# Script to parse output generated by Clash to use in the synthesis tool.+#+# TODO: More user documentation++package require json++namespace eval clash {+    variable metadata {}+    variable topEntity++    # Set verbosity level. Range is 0-4, where 0 means "silent". Example:+    #     set clash::verbosity 3+    variable verbosity 1++    # Dry run can be enabled by+    #     set clash::dryRun true+    variable dryRun false++    # Invoke with $topEntityDir set to the path where the manifest file of+    # your top entity is. Read all the metadata generated by Tcl: manifests+    # and Tcl interface scripts, for the top entity and its dependencies.+    proc readMetadata topEntityDir {+        variable metadata+        variable topEntity++        # If we are called multiple times, we will remove the results of+        # earlier invocations.+        set metadata [dict create]+        if {[namespace exists tclIface]} {+            namespace delete tclIface+        }++        set topEntity [ParseManifest $topEntityDir true]+        Log 1 "Top entity is $topEntity"+        return+    }++    # Issue "read_vhdl" / "read_verilog" for all HDL files generated by Clash+    proc readHdl {} {+        variable metadata+        variable topEntity++        CheckMetadataExists+        set libs [dict get $metadata $topEntity dependencies]+        lappend libs $topEntity+        foreach lib $libs {+            foreach hdlFile [dict get $metadata $lib hdlFiles] {+                if {[string match {*.vhdl} $hdlFile]} {+                    PerformAction {+                        read_vhdl -library } -var lib { } -var hdlFile+                } elseif {[string match {*.v} $hdlFile]} {+                    PerformAction {+                        read_verilog } -var hdlFile+                } elseif {[string match {*.sv} $hdlFile]} {+                    PerformAction {+                        read_verilog -sv } -var hdlFile+                } else {+                    error "Error: Unknown extension on HDL file $hdlFile"+                }+            }+        }+        return+    }++    # Issue "read_xdc" for all constraint files generated by Clash for the top+    # entity, and all constraint files managed by the Clash<->Tcl API (not just+    # for the top entity, but for all libraries).+    proc readXdc orders {+        variable metadata+        variable topEntity++        CheckMetadataExists+        foreach order $orders {+            if {$order ni {early normal late}} {+                error "Error: readXdc: Invalid order $order"+            }+        }+        unset order++        set early {}+        set normal {}+        set late {}+        foreach tclIface [GetAllTclIfaces {purposes readXdc}] {+            namespace upvar ${tclIface} order order+            lappend $order $tclIface+        }++        if {{early} in $orders} {+            foreach tclIface $early {+                ReadManagedXdc $tclIface+            }+        }+        if {{normal} in $orders} {+            ReadUnmanagedXdc+            foreach tclIface $normal {+                ReadManagedXdc $tclIface+            }+        }+        if {{late} in $orders} {+            foreach tclIface $late {+                ReadManagedXdc $tclIface+            }+        }+        return+    }++    # Invoke all Clash-generated Tcl interfaces that specify a "createIp"+    # purpose, which will call Vivado's "create_ip" with any additional+    # arguments passed to this function (hint: "createIp -dir yourdir" will+    # create the IP in the subdirectory named "yourdir"). Following that, the+    # IP is configured.+    #+    # Also see "createAndReadIp" below; call it or use its code as+    # inspiration. It is suggested to call it like "createAndReadIp -dir ip"+    # so you keep the files in a separate directory named "ip". The directory+    # will need to exist already.+    proc createIp args {+        CheckMetadataExists+        # Identical names means identical IP, only one run needed even if it+        # occurs in multiple HDL directories.+        set seen {}+        foreach tclIface [GetAllTclIfaces {purposes createIp}] {+            namespace upvar ${tclIface} ipName ipName+            if {$ipName in $seen} {+                continue+            }+            PerformAction -var tclIface {::createIp } -var ipName { } \+                    -varexpand args+            LogProc 3 {    } ${tclIface}::createIp+            lappend seen $ipName+        }+        return $seen+    }++    # Convenience method to create the IP in a temporary in-memory project and+    # then read in the results in non-project mode. Finally, targets are+    # created for the IP.+    #+    # NOTE WELL: since this switches into and out of project mode, it should+    # probably be the very first thing you call in setting up the design.+    proc createAndReadIp args {+        CheckMetadataExists+        if {![llength [GetAllTclIfaces {purposes createIp}]]} {+            return+        }+        PerformAction {+            create_project -in_memory+        }+        set ips [createIp {*}$args]+        PerformAction {+            set ipFiles [get_property IP_FILE [get_ips } -var ips {]]+            close_project+            read_ip $ipFiles+            set_property GENERATE_SYNTH_CHECKPOINT false [get_files $ipFiles]+            generate_target {synthesis simulation} [get_ips } -var ips {]+        }+        return+    }++    #---------------------------------------------------------------------------+    # Private definitions+    #---------------------------------------------------------------------------++    proc Log {level msg} {+        variable verbosity++        if {$verbosity >= $level} {+            puts "Clash \[$level\]: $msg"+        }+        return+    }++    proc LogDry {level msg} {+        variable dryRun++        if {$dryRun} {+            puts "Clash \[$level\]: \[DRY-RUN\] $msg"+        } else {+            Log $level $msg+        }+        return+    }++    # Remove leading and trailing lines with just spaces+    proc TrimLines msg {+        return [regsub {^( *\n)*(.*?)\n?( *\n?)*$} $msg {\2}]+    }++    proc GetCommonIndent msg {+        set indent -1+        foreach line [split $msg \n] {+            regexp -indices {^ *} $line blanks+            if {[lindex $blanks 1] == [string length $line] - 1} {+                # Empty line or line of all blanks; ignore+                continue+            }+            set leader [expr {[lindex $blanks 1] - [lindex $blanks 0] + 1}]+            if {$indent < 0 || $leader < $indent} {+                set indent $leader+            }+        }+        if {$indent < 0} {+            return 0+        }+        return $indent+    }++    proc LogProc {level leader procName} {+        Log $level "${leader}proc [namespace tail $procName]\+                {[info args $procName]} \{"+        set body [TrimLines [info body $procName]]+        set outdent [GetCommonIndent $body]+        foreach line [split $body \n] {+            Log $level "$leader    [string range $line $outdent end]"+        }+        Log $level $leader\}+        return+    }++    proc PerformAction args {+        variable dryRun++        set action {}+        set trace {}+        set argsLen [llength $args]+        for {set i 0} {$i < $argsLen} {incr i} {+            set fragment [lindex $args $i]+            if {$fragment ni {-var -varexpand}} {+                set action $action$fragment+                set trace $trace$fragment+                continue+            }+            incr i+            if {$i == $argsLen} {+                error "Error: $fragment requires an argument"+            }+            set varName [lindex $args $i]+            upvar $varName var+            switch $fragment {+                -var {+                    set action "$action\${$varName}"+                    set trace $trace$var+                }+                -varexpand {+                    set action "$action{*}\${$varName}"+                    set trace $trace$var+                }+            }+        }+        set trace [TrimLines $trace]+        set outdent [GetCommonIndent $trace]+        foreach line [split $trace \n] {+            LogDry 2 [string range $line $outdent end]+        }+        if {$dryRun} {+            return+        }+        catch {+            uplevel 1 $action+        } msg opts+        dict incr opts -level+        return {*}$opts $msg+    }++    proc WriteIntVar {def gname name1 _name2 _op} {+        upvar $name1 var+        if {![string is integer -strict $var]} {+            set var $def+            error "Error: $gname: Only integer values are accepted;\+                    reset to default: $def"+        }+        return+    }++    proc WriteBoolVar {def gname name1 _name2 _op} {+        upvar $name1 var+        if {![string is boolean -strict $var]} {+            set var $def+            error "Error: $gname: Only {0 1 false true no yes off on} are\+                    accepted; reset to default: $def"+        }+        return+    }++    proc TraceWrite {varName cmd args} {+        set ns [namespace current]+        set commandPrefix [linsert $args 0 ${ns}::$cmd]+        lappend commandPrefix ${ns}::$varName+        uplevel 1 [list trace remove variable $varName write $commandPrefix]+        uplevel 1 [list trace add variable $varName write $commandPrefix]+        return+    }++    proc CheckMetadataExists {} {+        variable metadata+        if {![dict size $metadata]} {+            error "Error: Please invoke clash::readMetadata first."+        }+        return+    }++    proc GetNsVar {ns varName} {+        if {![llength [uplevel 1 [list info vars ${ns}::$varName]]]} {+            error "Error: $ns doesn't provide \"$varName\"\+                    variable."+        }+        return [uplevel 1 [list set ${ns}::$varName]]+    }++    proc ParseManifest {entityDir withDeps} {+        variable metadata++        set manC [open [file join $entityDir clash-manifest.json] r]+        set manifest [json::json2dict [read $manC]]+        close $manC+        set lib [dict get $manifest top_component name]+        Log 1 "New top component: $lib"+        # Clash sometimes lists files multiple times, process them only once+        set seen {}+        set topConstraintName [file join $entityDir "${lib}.sdc"]+        dict set metadata $lib hdlFiles {}+        dict set metadata $lib constraintFiles {}+        foreach fileEntry [dict get $manifest files] {+            set name [file join $entityDir [dict get $fileEntry name]]+            if {$name in $seen} {+                continue+            }+            lappend seen $name+            if {$name eq $topConstraintName} {+                dict set metadata $lib topConstraintFile $name+            } elseif {+                   [string match {*.vhdl} $name]+                || [string match {*.v} $name]+                || [string match {*.sv} $name]+            } then {+                Log 3 "Adding HDL file: $name"+                dict with metadata $lib {+                    lappend hdlFiles $name+                }+            } elseif {+                   [string match {*.sdc} $name]+                || [string match {*.xdc} $name]+            } then {+                Log 3 "Adding constraint file: $name"+                dict with metadata $lib {+                    lappend constraintFiles $name+                }+            } elseif {[string match {*.clash.tcl} $name]} {+                Log 3 "Adding Clash<->Tcl API file: $name"+                LoadTclIface $lib $name+            }+        }+        RemoveManagedFiles $lib++        if {!$withDeps} {+            return $lib+        }++        set dependencies {}+        foreach dependency [dict get $manifest dependencies transitive] {+            set dependencyDir [file join [file dirname $entityDir] $dependency]+            lappend dependencies [ParseManifest $dependencyDir false]+        }+        dict set metadata $lib dependencies $dependencies+        return $lib+    }++    # Populate a namespace with a Clash-generated Tcl interface.+    # Namespace is clash::tclIface::${lib}::$baseName+    proc LoadTclIface {lib tclIfaceFile} {+        set fileName [file tail $tclIfaceFile]+        # Strip all extensions+        set baseName [string range $fileName 0 [string first . $fileName]-1]+        set tclIface [namespace current]::tclIface::${lib}::$baseName+        # Evaluate script code inside temporary throwaway namespace to+        # separate its code from ours and reduce the chance of accidentally+        # corrupting our code.+        namespace eval tmp {}+        set tmp::tclIfaceFile $tclIfaceFile+        set tmp::tclIface $tclIface+        namespace eval tmp {+            # -notrace is a Vivado specific option inhibiting the printing of+            # the script to stdout+            source -notrace $tclIfaceFile+        }+        if {![namespace exists $tclIface]} {+            error "Error: $tclIfaceFile did not create the requested namespace\+                    specified by the \$tclIface variable. The Tcl script does\+                    not conform to the defined Clash<->Tcl API."+        }+        namespace delete tmp+        VerifyTclIface $tclIface $tclIfaceFile true+        return+    }++    # Verify that the read interface file is strictly something we support.+    proc VerifyTclIface {tclIface tclIfaceFile isRoot} {+        set api [GetNsVar $tclIface api]+        if {$api ne {1}} {+            error "Error: $tclIface doesn't implement an API we support:\+                    api = \"$api\"."+        }+        set purpose [GetNsVar $tclIface scriptPurpose]+        Log 3 "  API level / purpose: $api/$purpose"+        if {$purpose eq {multipleScripts}} {+            if {!$isRoot} {+                error "Error: ${tclIface}::scriptPurpose = \"multipleScripts\",\+                        nested use not allowed."+            }+            if {![namespace exists ${tclIface}::multipleScripts]} {+                error "Error: ${tclIface}::multipleScripts does not exist."+            }+            set children [namespace children ${tclIface}::multipleScripts]+            if {![llength $children]} {+                error "Error: ${tclIface}::multipleScripts doesn't provide any\+                        scripts."+            }+            foreach child $children {+                if {[llength [info vars ${child}::api]]} {+                    error "Error: $child cannot specify api: it is specified by\+                            parent script."+                }+                set ${child}::api $api+                VerifyTclIface $child $tclIfaceFile false+            }++        } elseif {$purpose eq {createIp}} {+            Log 3 "    IP name: [GetNsVar $tclIface ipName]"+            # In Tcl, you can call procedures with a partial name. So an+            # invocation of "createIp" could call "createIpAlt" if+            # "createIp" did not exist. Let's be strict here to prevent+            # confusion: only accept the exact name "createIp".+            if {![llength [info procs ${tclIface}::createIp]]} {+                error "Error: $tclIface doesn't provide \"createIp\"\+                        procedure."+            }+            LogProc 4 {    } ${tclIface}::createIp++        } elseif {$purpose eq {readXdc}} {+            set order [GetNsVar $tclIface order]+            if {$order ni {early normal late}} {+                error "Error: ${tclIface}::order bogus value \"$order\"."+            }+            set usedIn [GetNsVar $tclIface usedIn]+            foreach stage $usedIn {+                if {$stage ni {synthesis implementation}} {+                    error "Error: ${tclIface}::usedIn bogus value \"$stage\"."+                }+            }+            set xdcFile [GetNsVar $tclIface xdcFile]+            # "file join" also correctly handles an absolute $xdcFile+            set resolvedFile [file join [file dirname $tclIfaceFile] $xdcFile]+            # "file isfile" also positively matches a symlink to a regular+            # file+            if {![file isfile $resolvedFile]} {+                error "Error: ${tclIface}::xdcFile = \"$xdcFile\" does not\+                        refer to an existing file."+            }+            set ${tclIface}::xdcFile $resolvedFile+            Log 3 "    Constraint file: $resolvedFile"+            Log 4 "    Order: $order"+            if {[llength [info vars ${tclIface}::scopeRef]]} {+                namespace upvar ${tclIface} scopeRef scopeRef+                Log 4 "    Scoped to ref: $scopeRef"+            }+            Log 4 "    Used in: $usedIn"++        } else {+            error "Error: ${tclIface}::scriptPurpose bogus value \"$purpose\"."+        }+        return+    }++    # Remove constraint files that are managed by a Tcl interface script from+    # the list of constraint files for the library.+    proc RemoveManagedFiles lib {+        variable metadata++        foreach tclIface [GetAllTclIfaces {libs $lib purposes readXdc}] {+            namespace upvar ${tclIface} xdcFile xdcFile+            set constraintFiles [dict get $metadata $lib constraintFiles]+            if {[lsearch -exact $constraintFiles $xdcFile] >= 0} {+                Log 3 "Marking as managed by the Clash<->Tcl API: $xdcFile"+                set filtered [lsearch -all -inline -exact -not \+                        $constraintFiles $xdcFile]+                dict set metadata $lib constraintFiles $filtered+            }+        }+        return+    }++    # Return all the Tcl interface namespaces+    #+    # They can optionally be filtered by specifying a list of libraries to+    # consider, a list of interface names to consider, or a list of script+    # purposes to consider. The sole argument of the function is a dictionary of+    # options, with the possible keys "libs", "ifaces" and "purposes".+    #+    # For example, if these two interfaces exist:+    #   - ::clash::tclIface::libA::ifaceX+    #   - ::clash::tclIface::libB::ifaceX+    #+    # Then "GetAllTclIfaces {libs libA}" would only return the first, but+    # "GetAllTclIfaces {ifaces ifaceX}" would return both since the interface+    # names both match.+    proc GetAllTclIfaces {{opts {}}} {+        if {![namespace exists tclIface]} {+            # There are no scripts+            return+        }++        if {[dict exists $opts libs]} {+            set walkLibs {}+            foreach lib [dict get $opts libs] {+                if {[namespace exists tclIface::$lib]} {+                    lappend walkLibs tclIface::$lib+                }+            }+        } else {+            set walkLibs [namespace children tclIface]+        }+        set tclIfaces {}+        set hasIfaces [dict exists $opts ifaces]+        if {$hasIfaces} {+            set ifaces [dict get $opts ifaces]+        }+        set hasPurposes [dict exists $opts purposes]+        if {$hasPurposes} {+            set purposes [dict get $opts purposes]+        }+        foreach libNs $walkLibs {+            foreach tclIface [namespace children $libNs] {+                if {$hasIfaces && [namespace tail $tclIface] ni $ifaces} {+                    continue+                }+                namespace upvar ${tclIface} scriptPurpose purpose+                if {$purpose ne {multipleScripts}} {+                    if {(!$hasPurposes) || $purpose in $purposes} {+                        lappend tclIfaces $tclIface+                    }+                    continue+                }+                set childIfaces \+                        [namespace children ${tclIface}::multipleScripts]+                foreach childIface $childIfaces {+                    namespace upvar ${childIface} scriptPurpose purpose+                    if {(!$hasPurposes) || $purpose in $purposes} {+                        lappend tclIfaces $childIface+                    }+                }+            }+        }+        return $tclIfaces+    }++    # If Clash generates constraint files without an accompanying tclIface, they+    # fall into two categories. Given $lib as the name of the top component in a+    # library, ${lib}.sdc contains the "create_clock" statements. We only read+    # that for the top entity. All other constraint files are passed to Vivado+    # as-is and should match on unique identifiers in the HDL, such that they+    # can be read for all libraries without worrying about `current_instance` or+    # similar scoping mechanisms.+    proc ReadUnmanagedXdc {} {+        variable metadata+        variable topEntity++        if {[dict exists $metadata $topEntity topConstraintFile]} {+            set topConstraintFile \+                    [dict get $metadata $topEntity topConstraintFile]+            PerformAction {+                read_xdc } -var topConstraintFile+        }+        set libs [dict get $metadata $topEntity dependencies]+        lappend libs $topEntity+        foreach lib $libs {+            set constraintFiles [dict get $metadata $lib constraintFiles]+            foreach constraintFile $constraintFiles {+                PerformAction {+                    read_xdc } -var constraintFile+            }+        }+    }++    proc ReadManagedXdc tclIface {+        namespace upvar $tclIface xdcFile xdcFile usedIn usedIn+        if {[llength [info vars ${tclIface}::scopeRef]]} {+            namespace upvar ${tclIface} scopeRef scopeRef+            set scopeRefArg [list -ref $scopeRef]+        } else {+            set scopeRefArg {}+        }+        PerformAction {+            read_xdc } -varexpand scopeRefArg { } -var xdcFile {+            set_property USED_IN } -var usedIn { [get_files } -var xdcFile {]+        }+        return+    }++    TraceWrite verbosity WriteIntVar 1+    TraceWrite dryRun WriteBoolVar false+}
+ prims/common/Clash_Annotations_BitRepresentation_Deriving.primitives.yaml view
@@ -0,0 +1,7 @@+- BlackBox:+    name: Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL+    kind: Expression+    type: 'dontApplyInHDL+      :: (a -> b) -> a -> b'+    template: ~ARG[1]+    workInfo: Never
+ prims/common/Clash_Annotations_SynthesisAttributes.primitives.yaml view
@@ -0,0 +1,3 @@+- Primitive:+    name: Clash.Annotations.SynthesisAttributes.annotateReg+    primType: Function
+ prims/common/Clash_Class_BitPack.primitives.yaml view
@@ -0,0 +1,34 @@+- BlackBox:+    name: Clash.Class.BitPack.Internal.packFloat#+    kind: Expression+    type: 'packFloat# :: Float+      -> BitVector 32'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackFloat#+    kind: Expression+    type: 'packFloat# :: BitVector+      32 -> Float'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packDouble#+    kind: Expression+    type: 'packFloat# :: Double+      -> BitVector 64'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackDouble#+    kind: Expression+    type: 'packFloat# :: BitVector+      64 -> Double'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.xToBV+    kind: Expression+    type: 'xToBV :: KnownNat n => BitVector n -> BitVector n'+    template: ~ARG[1]+    workInfo: Never
+ prims/common/Clash_Explicit_Signal.primitives.yaml view
@@ -0,0 +1,24 @@+- BlackBox:+    name: Clash.Explicit.Signal.veryUnsafeSynchronizer+    kind: Expression+    type: |-+      veryUnsafeSynchronizer+        :: Either Int (Signal dom1 Int) -- ARG[0]+        -> Either Int (Signal dom2 Int) -- ARG[1]+        -> Signal dom1 a                -- ARG[2]+        -> Signal dom2 a+    template: ~ARG[2]+    workInfo: Never+- BlackBox:+    name: Clash.Explicit.Signal.unsafeSynchronizer+    kind: Expression+    type: |-+      unsafeSynchronizer+        :: ( KnownDomain dom1    -- ARG[0]+           , KnownDomain dom2 )  -- ARG[1]+        => Clock dom1            -- ARG[2]+        -> Clock dom2            -- ARG[3]+        -> Signal dom1 a         -- ARG[4]+        -> Signal dom2 a+    template: ~ARG[4]+    workInfo: Never
+ prims/common/Clash_Explicit_Testbench.primitives.yaml view
@@ -0,0 +1,15 @@+- BlackBox:+    name: Clash.Explicit.Testbench.unsafeSimSynchronizer+    kind: Expression+    type: |-+      unsafeSimSynchronizer+        :: forall dom1 dom2 a+         . ( KnownDomain dom1         -- ARG[0]+           , KnownDomain dom2 )       -- ARG[1]+        => Clock dom1                 -- ARG[2]+        -> Clock dom2                 -- ARG[3]+        -> Signal dom1 a              -- ARG[4]+        -> Signal dom2 a+    template: ~ARG[4]+    warning: Clash.Explicit.Testbench.unsafeSimSynchronizer is not safely synthesizable!+    workInfo: Never
+ prims/common/Clash_GHC_GHC2Core.primitives.yaml view
@@ -0,0 +1,8 @@+- Primitive:+    name: _CO_+    primType: Constructor+    workInfo: Constant+- Primitive:+    name: _TY_+    primType: Constructor+    workInfo: Constant
+ prims/common/Clash_Intel_ClockGen.primitives.yaml view
@@ -0,0 +1,22 @@+- BlackBox:+    name: Clash.Intel.ClockGen.unsafeAltpll+    format: Haskell+    includes:+    - name: altpll+      extension: qsys+      format: Haskell+      templateFunction: Clash.Primitives.Intel.ClockGen.altpllQsysTF+    kind: Declaration+    templateFunction: Clash.Primitives.Intel.ClockGen.altpllTF+    workInfo: Always+- BlackBox:+    name: Clash.Intel.ClockGen.unsafeAlteraPll+    format: Haskell+    includes:+    - name: altera_pll+      extension: qsys+      format: Haskell+      templateFunction: Clash.Primitives.Intel.ClockGen.alteraPllQsysTF+    kind: Declaration+    templateFunction: Clash.Primitives.Intel.ClockGen.alteraPllTF+    workInfo: Always
+ prims/common/Clash_Magic.primitives.yaml view
@@ -0,0 +1,24 @@+- Primitive:+    name: Clash.Magic.prefixName+    primType: Function+- Primitive:+    name: Clash.Magic.suffixName+    primType: Function+- Primitive:+    name: Clash.Magic.suffixNameFromNat+    primType: Function+- Primitive:+    name: Clash.Magic.suffixNameP+    primType: Function+- Primitive:+    name: Clash.Magic.suffixNameFromNatP+    primType: Function+- Primitive:+    name: Clash.Magic.setName+    primType: Function+- BlackBox:+    name: Clash.Magic.SimOnly+    kind: Expression+    type: 'SimOnly :: a -> SimOnly a'+    template: ~ERRORO+    workInfo: Constant
+ prims/common/Clash_Normalize_Primitives.primitives.yaml view
@@ -0,0 +1,24 @@+- BlackBox:+    name: Clash.Normalize.Primitives.removedArg+    kind: Expression+    type: 'removedArg :: a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: Clash.Normalize.Primitives.undefined+    kind: Expression+    type: 'undefined :: forall+      a . a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: Clash.Normalize.Primitives.undefinedX+    kind: Expression+    type: 'undefinedX :: forall a . a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: c$multiPrimSelect+    kind: Expression+    template: '!__SHOULD NOT BE RENDERED__! ~ARG[0]~ARG[1]'+    workInfo: Always
+ prims/common/Clash_Promoted_Nat.primitives.yaml view
@@ -0,0 +1,7 @@+- BlackBox:+    name: Clash.Promoted.Nat.powSNat+    kind: Expression+    type: 'Clash.Promoted.Nat.powSNat+      :: SNat a -> SNat b -> SNat (a^b)'+    template: ~LIT[0] ** ~LIT[1]+    workInfo: Never
+ prims/common/Clash_Promoted_Nat_Unsafe.primitives.yaml view
@@ -0,0 +1,7 @@+- BlackBox:+    name: Clash.Promoted.Nat.Unsafe.unsafeSNat+    kind: Expression+    type: 'Clash.Promoted.Nat.Unsafe.unsafeSNat+      :: Integer -> SNat k'+    template: ~LIT[0]+    workInfo: Never
+ prims/common/Clash_Promoted_Symbol.primitives.yaml view
@@ -0,0 +1,14 @@+- BlackBox:+    name: Clash.Promoted.Symbol.SSymbol+    kind: Expression+    type: 'SSymbol :: KnownNat+      n => Proxy n -> SSymbol n'+    template: ~LIT[0]+    workInfo: Never+- BlackBox:+    name: Clash.Promoted.Symbol.symbolToString+    kind: Expression+    type: 'symbolToString+      :: SSymbol n -> String'+    template: ~LIT[0]+    workInfo: Never
+ prims/common/Clash_Signal_BiSignal.primitives.yaml view
@@ -0,0 +1,25 @@+- BlackBox:+    name: Clash.Signal.BiSignal.veryUnsafeToBiSignalIn+    kind: Declaration+    type: |-+      veryUnsafeToBiSignalIn+        :: ( HasCallStack                -- ARG[0]+           , KnownNat n                  -- ARG[1]+           , Given (SBiSignalDefault ds) -- ARG[2]+           )+        => BiSignalOut ds d n            -- ARG[3]+        -> BiSignalIn ds d n+    template: ~DEVNULL[~ARG[3]]+    workInfo: Never+- BlackBox:+    name: Clash.Signal.BiSignal.mergeBiSignalOuts+    kind: Expression+    type: |-+      mergeBiSignalOuts+        :: ( HasCallStack                         -- ARG[0]+           , KnownNat n                           -- ARG[1]+           )+        => Vec n (BiSignalOut defaultState dom m) -- ARG[2]+        -> BiSignalOut defaultState dom m+    template: ~DEVNULL[~ARG[2]]+    workInfo: Never
+ prims/common/Clash_Signal_Bundle.primitives.yaml view
@@ -0,0 +1,4 @@+- Primitive:+    name: Clash.Signal.Bundle.vecBundle#+    primType: Function+    workInfo: Never
+ prims/common/Clash_Signal_Internal.primitives.yaml view
@@ -0,0 +1,24 @@+- Primitive:+    name: Clash.Signal.Internal.signal#+    primType: Function+    workInfo: Never+- Primitive:+    name: Clash.Signal.Internal.mapSignal#+    primType: Function+    workInfo: Never+- Primitive:+    name: Clash.Signal.Internal.appSignal#+    primType: Function+    workInfo: Never+- Primitive:+    name: Clash.Signal.Internal.foldr#+    primType: Function+    workInfo: Never+- Primitive:+    name: Clash.Signal.Internal.traverse#+    primType: Function+    workInfo: Never+- Primitive:+    name: Clash.Signal.Internal.joinSignal#+    primType: Function+    workInfo: Never
+ prims/common/Clash_Signal_Trace.primitives.yaml view
@@ -0,0 +1,58 @@+- BlackBox:+    name: Clash.Signal.Trace.traceSignal1+    kind: Expression+    type: |-+      traceSignal1+        :: ( BitPack a    -- ARG[0]+           , NFDataX a    -- ARG[1]+           , Typeable a ) -- ARG[2]+        => String         -- ARG[3]+        -> Signal dom a   -- ARG[4]+        -> Signal dom a+    template: ~ARG[4]+    workInfo: Never+- BlackBox:+    name: Clash.Signal.Trace.traceVecSignal1+    kind: Expression+    type: |-+      traceVecSignal1+        :: ( KnownNat n             -- ARG[0]+           , BitPack a              -- ARG[1]+           , NFDataX a              -- ARG[2]+           , Typeable a )           -- ARG[3]+        => String                   -- ARG[4]+        -> Signal dom (Vec (n+1) a) -- ARG[5]+        -> Signal dom (Vec (n+1) a)+    template: ~ARG[5]+    workInfo: Never+- BlackBox:+    name: Clash.Signal.Trace.traceSignal+    kind: Expression+    type: |-+      traceSignal+        :: forall dom a+         . ( KnownDomain dom -- ARG[0]+           , BitPack a       -- ARG[1]+           , NFDataX a       -- ARG[2]+           , Typeable a )    -- ARG[3]+        => String            -- ARG[4]+        -> Signal dom a      -- ARG[5]+        -> Signal dom a+    template: ~ARG[5]+    workInfo: Never+- BlackBox:+    name: Clash.Signal.Trace.traceVecSignal+    kind: Expression+    type: |-+      traceVecSignal+        :: forall dom a n+         . ( KnownDomain dom        -- ARG[0]+           , KnownNat n             -- ARG[1]+           , BitPack a              -- ARG[2]+           , NFDataX a              -- ARG[3]+           , Typeable a )           -- ARG[4]+        => String                   -- ARG[5]+        -> Signal dom (Vec (n+1) a) -- ARG[6]+        -> Signal dom (Vec (n+1) a)+    template: ~ARG[6]+    workInfo: Never
+ prims/common/Clash_Sized_Internal_BitVector.primitives.yaml view
@@ -0,0 +1,35 @@+- BlackBox:+    name: Clash.Sized.Internal.BitVector.undefined#+    kind: Expression+    type: 'undefined# :: forall+      n . KnownNat n => BitVector n'+    template: ~ERRORO+    workInfo: Constant+- Primitive:+    name: Clash.Sized.Internal.BitVector.checkUnpackUndef+    primType: Function+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.lt##+    kind: Expression+    type: 'lt## :: Bit ->+      Bit -> Bool'+    template: ~ARG[0] < ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.ge##+    kind: Expression+    type: 'ge## :: Bit ->+      Bit -> Bool'+    template: ~ARG[0] >= ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.gt##+    kind: Expression+    type: 'gt## :: Bit ->+      Bit -> Bool'+    template: ~ARG[0] > ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.le##+    kind: Expression+    type: 'le## :: Bit ->+      Bit -> Bool'+    template: ~ARG[0] <= ~ARG[1]
+ prims/common/Clash_Sized_Internal_Signed.primitives.yaml view
@@ -0,0 +1,12 @@+- BlackBox:+    name: Clash.Sized.Internal.Signed.+#+    kind: Expression+    type: '(+#) :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: ~ARG[1] + ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Signed.-#+    kind: Expression+    type: '(-#) :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: ~ARG[1] - ~ARG[2]
+ prims/common/Clash_Sized_Internal_Unsigned.primitives.yaml view
@@ -0,0 +1,28 @@+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.+#+    kind: Expression+    type: '(+#) :: KnownNat+      n => Unsigned n -> Unsigned n -> Unsigned n'+    template: ~ARG[1] + ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.-#+    kind: Expression+    type: '(-#) :: KnownNat+      n => Unsigned n -> Unsigned n -> Unsigned n'+    template: ~ARG[1] - ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.unsignedToWord+    kind: Expression+    template: ~ARG[0]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.unsigned8toWord8+    kind: Expression+    template: ~ARG[0]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.unsigned16toWord16+    kind: Expression+    template: ~ARG[0]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.unsigned32toWord32+    kind: Expression+    template: ~ARG[0]
+ prims/common/Clash_Sized_RTree.primitives.yaml view
@@ -0,0 +1,4 @@+- Primitive:+    name: Clash.Sized.RTree.tdfold+    primType: Function+    workInfo: Never
+ prims/common/Clash_Sized_Vector.primitives.yaml view
@@ -0,0 +1,33 @@+- BlackBox:+    name: Clash.Sized.Vector.lazyV+    kind: Expression+    type: 'lazyV :: KnownNat+      n => Vec n a -> Vec n a'+    template: ~ARG[1]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.seqV+    kind: Expression+    type: 'seqV :: KnownNat+      n => Vec n a -> b -> b'+    template: ~ARG[2]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.seqVX+    kind: Expression+    type: 'seqVX :: KnownNat+      n => Vec n a -> b -> b'+    template: ~ARG[2]+    workInfo: Never+- Primitive:+    name: Clash.Sized.Vector.dfold+    primType: Function+    workInfo: Never+- Primitive:+    name: Clash.Sized.Vector.dtfold+    primType: Function+    workInfo: Never+- Primitive:+    name: Clash.Sized.Vector.traverse#+    primType: Function+    workInfo: Never
+ prims/common/Clash_XException.primitives.yaml view
@@ -0,0 +1,37 @@+- BlackBox:+    name: Clash.XException.seqX+    kind: Expression+    type: 'seqX :: a -> b+      -> b'+    template: ~ARG[1]+    workInfo: Never+- BlackBox:+    name: Clash.XException.seqErrorX+    kind: Expression+    type: 'seqErrorX :: a+      -> b -> b'+    template: ~ARG[1]+    workInfo: Never+- BlackBox:+    name: Clash.XException.errorX+    kind: Expression+    type: 'errorX :: HasCallStack+      => String -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: Clash.XException.deepseqX+    kind: Expression+    type: 'deepseqX :: NFDataX a => a -> b -> b'+    template: ~ARG[2]+    workInfo: Never+- BlackBox:+    name: Clash.XException.hwSeqX+    kind: Expression+    type: 'hwSeqX :: a ->+      b -> b'+    template: ~DEVNULL[~VAR[x][0]]~ARG[1]+    workInfo: Never+- Primitive:+    name: Clash.XException.xToErrorCtx+    primType: Function
+ prims/common/Clash_Xilinx_ClockGen.primitives.yaml view
@@ -0,0 +1,22 @@+- BlackBox:+    name: Clash.Xilinx.ClockGen.unsafeClockWizard+    kind: Declaration+    format: Haskell+    templateFunction: Clash.Primitives.Xilinx.ClockGen.clockWizardTF+    includes:+      - name: clk_wiz+        extension: clash.tcl+        format: Haskell+        templateFunction: Clash.Primitives.Xilinx.ClockGen.clockWizardTclTF+    workInfo: Always+- BlackBox:+    name: Clash.Xilinx.ClockGen.unsafeClockWizardDifferential+    kind: Declaration+    format: Haskell+    templateFunction: Clash.Primitives.Xilinx.ClockGen.clockWizardDifferentialTF+    includes:+      - name: clk_wiz+        extension: clash.tcl+        format: Haskell+        templateFunction: Clash.Primitives.Xilinx.ClockGen.clockWizardDifferentialTclTF+    workInfo: Always
+ prims/common/Control_Exception_Base.primitives.yaml view
@@ -0,0 +1,63 @@+- BlackBox:+    name: Control.Exception.Base.recSelError+    kind: Expression+    type: 'recSelError ::+      Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: Control.Exception.Base.recConError+    kind: Expression+    type: 'recConError ::+      Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: Control.Exception.Base.irrefutPatError+    kind: Expression+    type: 'irrefutPatError+      :: Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: Control.Exception.Base.runtimeError+    kind: Expression+    type: 'runtimeError ::+      Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: Control.Exception.Base.nonExhaustiveGuardsError+    kind: Expression+    type: 'nonExhaustiveGuardsError+      :: Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: Control.Exception.Base.patError+    kind: Expression+    type: 'patError :: Addr#+      -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: Control.Exception.Base.noMethodBindingError+    kind: Expression+    type: 'noMethodBindingError+      :: Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: Control.Exception.Base.absentError+    kind: Expression+    type: 'absentError ::+      Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: Control.Exception.Base.typeError+    kind: Expression+    type: 'typeError :: Addr#+      -> a'+    template: ~ERRORO+    workInfo: Constant
+ prims/common/Debug_Trace.primitives.yaml view
@@ -0,0 +1,7 @@+- BlackBox:+    name: Debug.Trace.trace+    kind: Expression+    type: 'trace :: String+      -> a -> a'+    template: ~ARG[1]+    workInfo: Never
+ prims/common/GHC_Base.primitives.yaml view
@@ -0,0 +1,4 @@+- Primitive:+    name: GHC.Base.$+    primType: Function+    workInfo: Never
+ prims/common/GHC_CString.primitives.yaml view
@@ -0,0 +1,14 @@+- BlackBox:+    name: GHC.CString.unpackCString#+    kind: Expression+    template: ~LIT[0]+    workInfo: Never+- BlackBox:+    name: GHC.CString.unpackFoldrCString#+    kind: Expression+    template: ~LIT[0]+    workInfo: Never+- Primitive:+    name: GHC.CString.unpackCStringUtf8#+    primType: Function+    workInfo: Never
+ prims/common/GHC_Classes.primitives.yaml view
@@ -0,0 +1,24 @@+- BlackBox:+    name: GHC.Classes.gtInt+    kind: Expression+    type: 'gtInt :: Int ->+      Int -> Bool'+    template: ~ARG[0] > ~ARG[1]+- BlackBox:+    name: GHC.Classes.geInt+    kind: Expression+    type: 'geInt :: Int ->+      Int -> Bool'+    template: ~ARG[0] >= ~ARG[1]+- BlackBox:+    name: GHC.Classes.ltInt+    kind: Expression+    type: 'ltInt :: Int ->+      Int -> Bool'+    template: ~ARG[0] < ~ARG[1]+- BlackBox:+    name: GHC.Classes.leInt+    kind: Expression+    type: 'leInt :: Int ->+      Int -> Bool'+    template: ~ARG[0] <= ~ARG[1]
+ prims/common/GHC_Err.primitives.yaml view
@@ -0,0 +1,18 @@+- BlackBox:+    name: GHC.Err.error+    kind: Expression+    type: 'error :: forall r a . HasCallStack => [Char] -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Err.errorWithoutStackTrace+    kind: Expression+    type: 'errorWithoutStackTrace :: forall r a . [Char] -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Err.undefined+    kind: Expression+    type: 'undefined :: forall r a . HasCallStack => a'+    template: ~ERRORO+    workInfo: Constant
+ prims/common/GHC_IO_Exception.primitives.yaml view
@@ -0,0 +1,13 @@+- BlackBox:+    name: GHC.IO.Exception.assertError+    comment: |-+      It would be nice if we could use a HDL assertion, however,+                           because in HDL, case alternatives are evaluated+                           concurrently, we would end up with the assertion being+                           triggered, even when the result of that branch is not+                           chosen in the multiplexer+    kind: Expression+    type: 'assertError ::+      HasCallStack => Bool -> a -> a'+    template: ~ARG[2]+    workInfo: Never
+ prims/common/GHC_Integer_Type.primitives.yaml view
@@ -0,0 +1,48 @@+- BlackBox:+    name: GHC.Integer.Type.plusInteger+    kind: Expression+    type: 'plusInteger ::+      Integer -> Integer -> Integer'+    template: ~ARG[0] + ~ARG[1]+    warning: 'GHC.Integer.Type.plusInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.minusInteger+    kind: Expression+    type: 'minusInteger ::+      Integer -> Integer -> Integer'+    template: ~ARG[0] - ~ARG[1]+    warning: 'GHC.Integer.Type.minusInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.leInteger+    kind: Expression+    type: 'leInteger :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] <= ~ARG[1]+    warning: 'GHC.Integer.Type.leInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.gtInteger+    kind: Expression+    type: 'gtInteger :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] > ~ARG[1]+    warning: 'GHC.Integer.Type.gtInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.ltInteger+    kind: Expression+    type: 'ltInteger :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] < ~ARG[1]+    warning: 'GHC.Integer.Type.ltInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.geInteger+    kind: Expression+    type: 'geInteger :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] >= ~ARG[1]+    warning: 'GHC.Integer.Type.geInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'
+ prims/common/GHC_Internal_Control_Exception_Base.primitives.yaml view
@@ -0,0 +1,63 @@+- BlackBox:+    name: GHC.Internal.Control.Exception.Base.recSelError+    kind: Expression+    type: 'recSelError ::+      Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Internal.Control.Exception.Base.recConError+    kind: Expression+    type: 'recConError ::+      Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Internal.Control.Exception.Base.irrefutPatError+    kind: Expression+    type: 'irrefutPatError+      :: Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Internal.Control.Exception.Base.runtimeError+    kind: Expression+    type: 'runtimeError ::+      Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Internal.Control.Exception.Base.nonExhaustiveGuardsError+    kind: Expression+    type: 'nonExhaustiveGuardsError+      :: Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Internal.Control.Exception.Base.patError+    kind: Expression+    type: 'patError :: Addr#+      -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Internal.Control.Exception.Base.noMethodBindingError+    kind: Expression+    type: 'noMethodBindingError+      :: Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Internal.Control.Exception.Base.absentError+    kind: Expression+    type: 'absentError ::+      Addr# -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Internal.Control.Exception.Base.typeError+    kind: Expression+    type: 'typeError :: Addr#+      -> a'+    template: ~ERRORO+    workInfo: Constant
+ prims/common/GHC_Internal_Debug_Trace.primitives.yaml view
@@ -0,0 +1,7 @@+- BlackBox:+    name: GHC.Internal.Debug.Trace.trace+    kind: Expression+    type: 'trace :: String+      -> a -> a'+    template: ~ARG[1]+    workInfo: Never
+ prims/common/GHC_Internal_Err.primitives.yaml view
@@ -0,0 +1,18 @@+- BlackBox:+    name: GHC.Internal.Err.error+    kind: Expression+    type: 'error :: forall r a . HasCallStack => [Char] -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Internal.Err.errorWithoutStackTrace+    kind: Expression+    type: 'errorWithoutStackTrace :: forall r a . [Char] -> a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Internal.Err.undefined+    kind: Expression+    type: 'undefined :: forall r a . HasCallStack => a'+    template: ~ERRORO+    workInfo: Constant
+ prims/common/GHC_Internal_TypeNats.primitives.yaml view
@@ -0,0 +1,17 @@+- BlackBox:+    name: GHC.Internal.TypeNats.natVal+    kind: Expression+    type: 'natVal :: forall+      n proxy. KnownNat n => proxy n -> Natural'+    template: ~ARG[0]+    workInfo: Never+- Primitive:+    name: GHC.Internal.TypeNats.someNatVal+    primType: Function+    type: 'someNatVal :: Natural -> SomeNat'+    workInfo: Never+- Primitive:+    name: GHC.Internal.TypeNats.withSomeSNat+    primType: Function+    type: 'withSomeSNat :: forall rep (r :: TYPE rep). Natural -> (forall n. SNat n -> r) -> r'+    workInfo: Never
+ prims/common/GHC_Magic.primitives.yaml view
@@ -0,0 +1,18 @@+- Primitive:+    name: GHC.Magic.lazy+    primType: Function+    workInfo: Never+- Primitive:+    name: GHC.Magic.noinline+    primType: Function+    type: forall a. a -> a+    workInfo: Never+- Primitive:+    name: GHC.Magic.nospec+    primType: Function+    type: forall a. a -> a+    workInfo: Never+- Primitive:+    name: GHC.Magic.runRW#+    primType: Function+    workInfo: Never
+ prims/common/GHC_Natural.primitives.yaml view
@@ -0,0 +1,42 @@+- Primitive:+    name: GHC.Natural.NatS#+    comment: Needed to make the evaluator handle this constructor strictly+    primType: Constructor+    warning: 'GHC.Natural.NatS#: Naturals are dynamically sized in simulation, but+      fixed-length after synthesis. Use carefully.'+    workInfo: Never+- Primitive:+    name: GHC.Natural.naturalToInteger+    primType: Function+    warning: 'GHC.Natural.naturalToInteger: No blackbox available without size inference+      for Natural and Integer'+    workInfo: Never+- BlackBox:+    name: GHC.Natural.underflowError+    kind: Expression+    type: 'underflowError+      :: a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Natural.plusNatural+    kind: Expression+    type: 'plusNatural ::+      Natural -> Natural -> Natural'+    template: ~ARG[0] + ~ARG[1]+    warning: 'GHC.Natural.plusNatural: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Natural.minusNatural+    kind: Expression+    type: 'minusNatural ::+      Natural -> Natural -> Natural'+    template: ~ARG[0] - ~ARG[1]+    warning: 'GHC.Natural.minusNatural: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- Primitive:+    name: GHC.Natural.gcdNatural+    primType: Function+    warning: 'GHC.Natural.gcdNatural: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never
+ prims/common/GHC_Num_Integer.primitives.yaml view
@@ -0,0 +1,75 @@+- Primitive:+    name: GHC.Num.Integer.IS+    comment: Needed to make the evaluator handle this constructor strictly+    primType: Constructor+    warning: 'GHC.Num.Integer.IS: Integers are dynamically sized in simulation, but+      fixed-length after synthesis. Use carefully.'+    workInfo: Never+- Primitive:+    name: GHC.Num.Integer.IP+    comment: Needed to make the evaluator handle this constructor strictly+    primType: Constructor+    warning: 'GHC.Num.Integer.IP: Integers are dynamically sized in simulation, but+      fixed-length after synthesis. Use carefully.'+    workInfo: Never+- Primitive:+    name: GHC.Num.Integer.IN+    comment: Needed to make the evaluator handle this constructor strictly+    primType: Constructor+    warning: 'GHC.Num.Integer.IN: Integers are dynamically sized in simulation, but+      fixed-length after synthesis. Use carefully.'+    workInfo: Never+- Primitive:+    name: GHC.Num.Integer.integerFromNatural+    primType: Function+    warning: 'GHC.Num.Integer.integerFromNatural: No blackbox available without size+      inference for Natural and Integer'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerAdd+    kind: Expression+    type: 'integerAdd :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] + ~ARG[1]+    warning: 'GHC.Num.Integer.integerAdd: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerSub+    kind: Expression+    type: 'integerSub :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] - ~ARG[1]+    warning: 'GHC.Num.Integer.integerSub: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerLe+    kind: Expression+    type: 'integerLe :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] <= ~ARG[1]+    warning: 'GHC.Num.Integer.integerLe: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerGt+    kind: Expression+    type: 'integerGt :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] > ~ARG[1]+    warning: 'GHC.Num.Integer.integerGt: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerLt+    kind: Expression+    type: 'integerLt :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] < ~ARG[1]+    warning: 'GHC.Num.Integer.integerLt: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerGe+    kind: Expression+    type: 'integerGe :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] >= ~ARG[1]+    warning: 'GHC.Num.Integer.integerGe: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'
+ prims/common/GHC_Num_Natural.primitives.yaml view
@@ -0,0 +1,64 @@+- Primitive:+    name: GHC.Num.Natural.NS+    comment: Needed to make the evaluator handle this constructor strictly+    primType: Constructor+    warning: 'GHC.Num.Natural.NS: Naturals are dynamically sized in simulation, but+      fixed-length after synthesis. Use carefully.'+    workInfo: Never+- Primitive:+    name: GHC.Num.Natural.NB+    comment: Needed to make the evaluator handle this constructor strictly+    primType: Constructor+    warning: 'GHC.Num.Natural.NB: Naturals are dynamically sized in simulation, but+      fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Natural.naturalAdd+    kind: Expression+    type: 'naturalSub :: Natural+      -> Natural -> Natural'+    template: ~ARG[0] + ~ARG[1]+    warning: 'GHC.Num.Natural.naturalAdd: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- Primitive:+    name: GHC.Num.Natural.naturalSub+    primType: Function+    warning: 'GHC.Num.Natural.naturalSub: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Natural.naturalSubUnsafe+    kind: Expression+    type: 'naturalSubUnsafe+      :: Natural -> Natural -> Natural'+    template: ~ARG[0] - ~ARG[1]+    warning: 'GHC.Num.Natural.naturalSubUnsafe: Naturals are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalSubThrow+    kind: Expression+    type: 'naturalSubThrow+      :: Natural -> Natural -> Natural'+    template: ~ARG[0] - ~ARG[1]+    warning: 'GHC.Num.Natural.naturalSubThrow: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalMul+    kind: Expression+    type: 'naturalMul :: Natural+      -> Natural -> Natural'+    template: ~ARG[0] * ~ARG[1]+    warning: 'GHC.Num.Natural.naturalMul: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- Primitive:+    name: GHC.Num.Natural.naturalGcd+    primType: Function+    warning: 'GHC.Num.Natural.naturalGcd: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- Primitive:+    name: GHC.Num.Natural.naturalLcm+    primType: Function+    warning: 'GHC.Num.Natural.naturalLcm: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never
+ prims/common/GHC_Prim.primitives.yaml view
@@ -0,0 +1,107 @@+- Primitive:+    name: GHC.Prim.dataToTag#+    primType: Function+- Primitive:+    name: GHC.Prim.dataToTagSmall#+    primType: Function+- Primitive:+    name: GHC.Prim.dataToTagLarge#+    primType: Function+- Primitive:+    name: GHC.Prim.tagToEnum#+    primType: Function+- BlackBox:+    name: GHC.Prim.unsafeCoerce#+    kind: Expression+    type: 'unsafeCoerce# ::+      a -> b'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: GHC.Prim.+#+    kind: Expression+    type: '(+#) :: Int# ->+      Int# -> Int#'+    template: ~ARG[0] + ~ARG[1]+- BlackBox:+    name: GHC.Prim.plusInt8#+    kind: Expression+    template: ~ARG[0] + ~ARG[1]+- BlackBox:+    name: GHC.Prim.plusInt16#+    kind: Expression+    template: ~ARG[0] + ~ARG[1]+- BlackBox:+    name: GHC.Prim.plusInt32#+    kind: Expression+    template: ~ARG[0] + ~ARG[1]+- BlackBox:+    name: GHC.Prim.plusInt64#+    kind: Expression+    template: ~ARG[0] + ~ARG[1]+- BlackBox:+    name: GHC.Prim.-#+    kind: Expression+    type: '(-#) :: Int# ->+      Int# -> Int#'+    template: ~ARG[0] - ~ARG[1]+- BlackBox:+    name: GHC.Prim.subInt8#+    kind: Expression+    template: ~ARG[0] - ~ARG[1]+- BlackBox:+    name: GHC.Prim.subInt16#+    kind: Expression+    template: ~ARG[0] - ~ARG[1]+- BlackBox:+    name: GHC.Prim.subInt32#+    kind: Expression+    template: ~ARG[0] - ~ARG[1]+- BlackBox:+    name: GHC.Prim.subInt64#+    kind: Expression+    template: ~ARG[0] - ~ARG[1]+- BlackBox:+    name: GHC.Prim.plusWord#+    kind: Expression+    type: 'plusWord# :: Word#+      -> Word# -> Word#'+    template: ~ARG[0] + ~ARG[1]+- BlackBox:+    name: GHC.Prim.plusWord8#+    kind: Expression+    template: ~ARG[0] + ~ARG[1]+- BlackBox:+    name: GHC.Prim.plusWord16#+    kind: Expression+    template: ~ARG[0] + ~ARG[1]+- BlackBox:+    name: GHC.Prim.plusWord32#+    kind: Expression+    template: ~ARG[0] + ~ARG[1]+- BlackBox:+    name: GHC.Prim.plusWord64#+    kind: Expression+    template: ~ARG[0] + ~ARG[1]+- BlackBox:+    name: GHC.Prim.minusWord#+    kind: Expression+    type: 'minusWord# :: Word#+      -> Word# -> Word#'+    template: ~ARG[0] - ~ARG[1]+- BlackBox:+    name: GHC.Prim.subWord8#+    kind: Expression+    template: ~ARG[0] - ~ARG[1]+- BlackBox:+    name: GHC.Prim.subWord16#+    kind: Expression+    template: ~ARG[0] - ~ARG[1]+- BlackBox:+    name: GHC.Prim.subWord32#+    kind: Expression+    template: ~ARG[0] - ~ARG[1]+- BlackBox:+    name: GHC.Prim.subWord64#+    kind: Expression+    template: ~ARG[0] - ~ARG[1]
+ prims/common/GHC_Prim_Panic.primitives.yaml view
@@ -0,0 +1,7 @@+- BlackBox:+    name: GHC.Prim.Panic.absentError+    kind: Expression+    type: 'absentError ::+      Addr# -> a'+    template: ~ERRORO+    workInfo: Constant
+ prims/common/GHC_Real.primitives.yaml view
@@ -0,0 +1,21 @@+- BlackBox:+    name: GHC.Real.divZeroError+    kind: Expression+    type: 'divZeroError ::+      a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Real.ratioZeroDenominatorError+    kind: Expression+    type: 'ratioZeroDenominatorError+      :: a'+    template: ~ERRORO+    workInfo: Constant+- BlackBox:+    name: GHC.Real.overflowError+    kind: Expression+    type: 'overflowError ::+      a'+    template: ~ERRORO+    workInfo: Constant
+ prims/common/GHC_TypeNats.primitives.yaml view
@@ -0,0 +1,17 @@+- BlackBox:+    name: GHC.TypeNats.natVal+    kind: Expression+    type: 'natVal :: forall+      n proxy. KnownNat n => proxy n -> Natural'+    template: ~ARG[0]+    workInfo: Never+- Primitive:+    name: GHC.TypeNats.someNatVal+    primType: Function+    type: 'someNatVal :: Natural -> SomeNat'+    workInfo: Never+- Primitive:+    name: GHC.TypeNats.withSomeSNat+    primType: Function+    type: 'withSomeSNat :: forall rep (r :: TYPE rep). Natural -> (forall n. SNat n -> r) -> r'+    workInfo: Never
+ prims/common/GHC_Typelits.primitives.yaml view
@@ -0,0 +1,7 @@+- BlackBox:+    name: GHC.TypeLits.natVal+    kind: Expression+    type: 'natVal :: forall+      n proxy. KnownNat n => proxy n -> Integer'+    template: ~ARG[0]+    workInfo: Never
+ prims/common/GHC_Types.primitives.yaml view
@@ -0,0 +1,18 @@+- Primitive:+    name: GHC.Types.MkCoercible+    primType: Constructor+    workInfo: Never+- BlackBox:+    name: GHC.Types.I#+    kind: Expression+    comment: Needed to make the evaluator handle this constructor strictly+    type: 'I# :: Int# -> Int'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: GHC.Types.W#+    kind: Expression+    comment: Needed to make the evaluator handle this constructor strictly+    type: 'W# :: Word# -> Word'+    template: ~ARG[0]+    workInfo: Never
+ prims/common/Unsafe_Coerce.primitives.yaml view
@@ -0,0 +1,7 @@+- BlackBox:+    name: Unsafe.Coerce.unsafeCoerce+    kind: Expression+    type: 'unsafeCoerce ::+      a -> b'+    template: ~ARG[0]+    workInfo: Never
+ prims/commonverilog/Clash_Class_BitPack.primitives.yaml view
@@ -0,0 +1,132 @@+- BlackBox:+    name: Clash.Class.BitPack.Internal.packChar#+    kind: Expression+    type: 'packChar# :: Char -> BitVector 21'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packInt8#+    kind: Expression+    type: 'packInt8# :: Int8 -> Bitvector 8'+    template: $unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packInt16#+    kind: Expression+    type: 'packInt16# :: Int16 -> Bitvector 16'+    template: $unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packInt32#+    kind: Expression+    type: 'packInt32# :: Int32 -> Bitvector 32'+    template: $unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packInt64#+    kind: Expression+    type: 'packInt64# :: Int64 -> Bitvector 64'+    template: $unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packWord#+    kind: Expression+    type: 'packWord# :: Word -> Bitvector WORD_SIZE_IN_BITS'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packWord8#+    kind: Expression+    type: 'packWord8# :: Word8 -> Bitvector 8'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packWord16#+    kind: Expression+    type: 'packWord16# :: Word16 -> Bitvector 16'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packWord32#+    kind: Expression+    type: 'packWord32# :: Word32 -> Bitvector 32'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packWord64#+    kind: Expression+    type: 'packWord64# :: Word64 -> Bitvector 64'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packCUShort#+    kind: Expression+    type: 'packCUShort# :: CUShort -> Bitvector 16'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackChar#+    kind: Expression+    type: 'unpackChar# :: BitVector 21 -> Char'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackInt8#+    kind: Expression+    type: 'unpackInt8# :: Bitvector 8 -> Int8'+    template: $signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackInt16#+    kind: Expression+    type: 'unpackInt16# :: Bitvector 16 -> Int16'+    template: $signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackInt32#+    kind: Expression+    type: 'unpackInt32# :: Bitvector 32 -> Int32'+    template: $signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackInt64#+    kind: Expression+    type: 'unpackInt64# :: Bitvector 64 -> Int64'+    template: $signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackWord#+    kind: Expression+    type: 'unpackWord# :: Bitvector WORD_SIZE_IN_BITS -> Word'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackWord8#+    kind: Expression+    type: 'unpackWord8# :: Bitvector 8 -> Word8'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackWord16#+    kind: Expression+    type: 'unpackWord16# :: Bitvector 16 -> Word16'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackWord32#+    kind: Expression+    type: 'unpackWord32# :: Bitvector 32 -> Word32'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackWord64#+    kind: Expression+    type: 'unpackWord64# :: Bitvector 64 -> Word64'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackCUShort#+    kind: Expression+    type: 'unpackCUShort# :: Bitvector 16 -> CUShort'+    template: ~ARG[0]+    workInfo: Never
+ prims/commonverilog/Clash_Class_Exp.primitives.yaml view
@@ -0,0 +1,24 @@+- BlackBox:+    name: Clash.Class.Exp.expIndex#+    kind: Declaration+    type: 'expIndex# :: KnownNat+      m => Index m -> SNat n -> Index (m^n)'+    template: assign ~RESULT = ~DEVNULL[~ARG[0]]$signed(~ARG[1] ** ~LIT[2]);+    warning: Exponentiation is only supported on relatively small constructs (< 32+      bits). Ideally, Clash should have constant folded your expression. See https://github.com/clash-lang/clash-compiler/issues/593.+- BlackBox:+    name: Clash.Class.Exp.expSigned#+    kind: Declaration+    type: 'expSigned# :: KnownNat+      m => Signed m -> SNat n -> Signed (m*n)'+    template: assign ~RESULT = ~DEVNULL[~ARG[0]]$signed(~ARG[1] ** ~LIT[2]);+    warning: Exponentiation is only supported on relatively small constructs (< 32+      bits). Ideally, Clash should have constant folded your expression. See https://github.com/clash-lang/clash-compiler/issues/593.+- BlackBox:+    name: Clash.Class.Exp.expUnsigned#+    kind: Declaration+    type: 'expUnsigned# ::+      KnownNat m => Unsigned m -> SNat n -> Unsigned (m*n)'+    template: assign ~RESULT = ~DEVNULL[~ARG[0]]$unsigned(~ARG[1] ** ~LIT[2]);+    warning: Exponentiation is only supported on relatively small constructs (< 32+      bits). Ideally, Clash should have constant folded your expression. See https://github.com/clash-lang/clash-compiler/issues/593.
+ prims/commonverilog/Clash_Explicit_SimIO.primitives.yaml view
@@ -0,0 +1,94 @@+- Primitive:+    name: Clash.Explicit.SimIO.mealyIO+    primType: Function+- BlackBox:+    name: Clash.Explicit.SimIO.display+    kind: Declaration+    renderVoid: RenderVoid+    template: $display(~ARG[0]);+- BlackBox:+    name: Clash.Explicit.SimIO.finish+    kind: Declaration+    renderVoid: RenderVoid+    template: |-+      `ifdef VERILATOR+      $c("std::exit(~LIT[0]);");+      `else+      // NOTE: $finish_and_return is an iverilog extension!+      $finish_and_return(~LIT[0]);+      `endif+- BlackBox:+    name: Clash.Explicit.SimIO.reg+    kind: Expression+    template: ~ARG[0]+- BlackBox:+    name: Clash.Explicit.SimIO.readReg+    kind: Expression+    template: ~ARG[0]+- BlackBox:+    name: Clash.Explicit.SimIO.writeReg+    kind: Declaration+    renderVoid: RenderVoid+    outputUsage: Blocking+    template: ~ARG[0] = ~ARG[1];+- BlackBox:+    name: Clash.Explicit.SimIO.openFile+    kind: Expression+    template: $fopen(~FILE[~LIT[0]],~LIT[1])+- BlackBox:+    name: Clash.Explicit.SimIO.closeFile+    kind: Declaration+    renderVoid: RenderVoid+    template: $fclose(~ARG[0]);+- BlackBox:+    name: Clash.Explicit.SimIO.getChar+    kind: Expression+    template: $fgetc(~ARG[0])+- BlackBox:+    name: Clash.Explicit.SimIO.putChar+    kind: Declaration+    renderVoid: RenderVoid+    template: $ungetc(~ARG[0],~ARG[1]);+- BlackBox:+    name: Clash.Explicit.SimIO.getLine+    kind: Declaration+    outputUsage: Blocking+    template: ~RESULT = $fgets(~ARG[2],~ARG[1]);+- BlackBox:+    name: Clash.Explicit.SimIO.isEOF+    kind: Expression+    template: $feof(~ARG[0])+- BlackBox:+    name: Clash.Explicit.SimIO.flush+    kind: Declaration+    renderVoid: RenderVoid+    template: $fflush(~ARG[0]);+- BlackBox:+    name: Clash.Explicit.SimIO.seek+    kind: Declaration+    outputUsage: Blocking+    template: ~RESULT = $fseek(~ARG[0],~ARG[1],~ARG[2]);+- BlackBox:+    name: Clash.Explicit.SimIO.rewind+    kind: Declaration+    outputUsage: Blocking+    template: ~RESULT = $rewind(~ARG[0]);+- BlackBox:+    name: Clash.Explicit.SimIO.tell+    kind: Expression+    template: $ftell(~ARG[0])+- Primitive:+    name: Clash.Explicit.SimIO.fmapSimIO#+    primType: Function+- Primitive:+    name: Clash.Explicit.SimIO.pureSimIO#+    primType: Function+- Primitive:+    name: Clash.Explicit.SimIO.apSimIO#+    primType: Function+- Primitive:+    name: Clash.Explicit.SimIO.bindSimIO#+    primType: Function+- Primitive:+    name: Clash.Explicit.SimIO.unSimIO+    primType: Function
+ prims/commonverilog/Clash_Explicit_Testbench.primitives.yaml view
@@ -0,0 +1,11 @@+- BlackBox:+    name: Clash.Explicit.Testbench.tbEnableGen+    kind: Declaration+    type: 'tbEnableGen ::+      Enable dom'+    template: assign ~RESULT = 1'b1;+    workInfo: Always+- BlackBox:+    name: Clash.Explicit.Testbench.clockToDiffClock+    kind: Expression+    template: '{~ARG[1], ~ ~ARG[1]}'
+ prims/commonverilog/Clash_Intel_DDR.primitives.yaml view
@@ -0,0 +1,50 @@+- BlackBox:+    name: Clash.Intel.DDR.altddioOut#+    kind: Declaration+    libraries:+    - altera_mf+    type: |-+      altddioOut#+        :: forall deviceFamily n dom domDDR+         . HasCallStack              -- ARG[0]+        => KnownDomain dom           -- ARG[1]+        => KnownDomain domDDR        -- ARG[2]+        => DomPeriod ~ 2 * ...       -- ARG[3]+        => DomEdge ~ Rising          -- ARG[4]+        => KnownNat n                -- ARG[5]+        => SSymbol deviceFamily      -- ARG[6]+        -> Clock dom                 -- ARG[7]+        -> Reset dom                 -- ARG[8]+        -> Enable dom                -- ARG[9]+        -> Signal dom (BitVector n)  -- ARG[10]+        -> Signal dom (BitVector n)  -- ARG[11]+        -> Signal domDDR (BitVector n)+    template: |-+      // altddioOut begin+      altddio_out+        #(+          .extend_oe_disable ("OFF"),+          .intended_device_family (~LIT[6]),+          .invert_output ("OFF"),+          .lpm_hint ("UNUSED"),+          .lpm_type ("altddio_out"),+          .oe_reg ("UNREGISTERED"),+          .power_up_high ("OFF"),+          .width (~SIZE[~TYPO])+        )+        ~GENSYM[~COMPNAME_ALTDDIO_OUT][7] (~IF ~ISSYNC[1] ~THEN+          .sclr (~ARG[8]),+          .aclr (1'b0),~ELSE+          .aclr (~ARG[8]),+          .sclr (1'b0),~FI+          .datain_h (~ARG[10]),+          .datain_l (~ARG[11]),+          .outclock (~ARG[7]),+          .outclocken (~IF ~ISACTIVEENABLE[9] ~THEN ~ARG[9] ~ELSE 1'b1 ~FI),+          .dataout (~RESULT),+          .aset (1'b0),+          .sset (1'b0),+          .oe (1'b1),+          .oe_out ()+        );+      // altddioOut end
+ prims/commonverilog/Clash_Magic.primitives.yaml view
@@ -0,0 +1,11 @@+- BlackBox:+    name: Clash.Magic.nameHint+    kind: Declaration+    type: |-+      nameHint+        :: SSymbol sym  -- ARG[0]+        -> a            -- ARG[1]+        -> a+    resultName:+      template: ~NAME[0]+    template: assign ~RESULT = ~ARG[1];
+ prims/commonverilog/Clash_Promoted_Nat.primitives.yaml view
@@ -0,0 +1,71 @@+- BlackBox:+    name: Clash.Promoted.Nat.flogBaseSNat+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: flogBase+      extension: inc+      template: |-+        // floor of logBase+        function integer ~INCLUDENAME[0];+          input integer base, value;+          begin+            for (~INCLUDENAME[0] = 0; value >= base; ~INCLUDENAME[0]=~INCLUDENAME[0]+1)+              value = value / base;+          end+        endfunction+    kind: Expression+    type: |-+      Clash.Promoted.Nat.flogBaseSNat :: (2 <= base, 1 <= x)+                                                           => SNat base -- ARG[2]+                                                           -> SNat x    -- ARG[3]+                                                           -> SNat (FLog base x+    template: ~INCLUDENAME[0](~LIT[2],~LIT[3])+    workInfo: Never+- BlackBox:+    name: Clash.Promoted.Nat.clogBaseSNat+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: clogBase+      extension: inc+      template: |-+        // ceiling of logBase+        function integer ~INCLUDENAME[0];+          input integer base, value;+          begin+            for (~INCLUDENAME[0] = 0; base ** ~INCLUDENAME[0] < value; ~INCLUDENAME[0]=~INCLUDENAME[0]+1);+          end+        endfunction+    kind: Expression+    type: |-+      Clash.Promoted.Nat.clogBaseSNat :: (2 <= base, 1 <= x)+                                                           => SNat base -- ARG[2]+                                                           -> SNat x    -- ARG[3]+                                                           -> SNat (CLog base x+    template: ~INCLUDENAME[0](~LIT[2],~LIT[3])+    workInfo: Never+- BlackBox:+    name: Clash.Promoted.Nat.logBaseSNat+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: clogBase+      extension: inc+      template: |-+        // logBaseSNat begin+        function integer ~INCLUDENAME[0];+          input integer base, value;+          begin+            for (~INCLUDENAME[0] = 0; value >= base; ~INCLUDENAME[0]=~INCLUDENAME[0]+1)+              value = value / base;+          end+        endfunction+    kind: Expression+    type: |-+      Clash.Promoted.Nat.logBaseSNat :: (FLog base x ~ CLog base x)+                                                          => SNat base -- ARG[1]+                                                          -> SNat x    -- ARG[2]+                                                          -> SNat (Log base x)+    template: ~INCLUDENAME[0](~LIT[1],~LIT[2])+    workInfo: Never
+ prims/commonverilog/Clash_Signal_Internal.primitives.yaml view
@@ -0,0 +1,14 @@+- BlackBox:+    name: Clash.Signal.Internal.unsafeFromReset+    kind: Expression+    type: 'unsafeFromReset+      :: Reset dom -> Signal dom Bool'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Signal.Internal.unsafeToReset+    kind: Expression+    type: 'unsafeToReset ::+      KnownDomain dom => Signal dom Bool -> Reset dom'+    template: ~ARG[1]+    workInfo: Never
+ prims/commonverilog/Clash_Sized_Internal_BitVector.primitives.yaml view
@@ -0,0 +1,346 @@+- BlackBox:+    name: Clash.Sized.Internal.BitVector.BV+    comment: THIS IS ONLY USED WHEN WW EXPOSES BITVECTOR INTERNALS+    kind: Expression+    type: 'BV :: Integer ->+      Integer -> BitVector n'+    template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {1'b0}},~VAR[i][1]})~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.Bit+    comment: THIS IS ONLY USED WHEN WW EXPOSES BIT INTERNALS+    kind: Expression+    type: 'Bit :: Integer+      -> Integer -> BitVector n'+    template: ~VAR[i][1][0]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.high+    kind: Expression+    type: 'high :: Bit'+    template: 1'b1+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.low+    kind: Expression+    type: 'low :: Bit'+    template: 1'b0+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.pack#+    kind: Expression+    type: 'pack# :: Bit ->+      BitVector 1'+    template: ~ARG[0]+    workInfo: Identity 0 []+- BlackBox:+    name: Clash.Sized.Internal.BitVector.unpack#+    kind: Expression+    type: 'unpack# :: BitVector+      1 -> Bit'+    template: ~ARG[0]+    workInfo: Identity 0 []+- BlackBox:+    name: Clash.Sized.Internal.BitVector.reduceAnd#+    kind: Expression+    type: 'reduceAnd# :: KnownNat+      n => BitVector n -> Bit'+    template: ~IF~SIZE[~TYP[1]]~THEN& (~ARG[1])~ELSE1'b1~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.reduceOr#+    kind: Expression+    type: 'reduceOr# :: KnownNat+      n => BitVector n -> Bit'+    template: ~IF~SIZE[~TYP[1]]~THEN| (~ARG[1])~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.reduceXor#+    kind: Expression+    type: 'reduceXor# :: KnownNat+      n => BitVector n -> Bit'+    template: ~IF~SIZE[~TYP[1]]~THEN^ (~ARG[1])~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.eq##+    kind: Expression+    type: 'eq## :: Bit ->+      Bit -> Bool'+    template: ~ARG[0] == ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.neq##+    kind: Expression+    type: 'neq## :: Bit ->+      Bit -> Bool'+    template: ~ARG[0] != ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.fromInteger##+    kind: Expression+    type: 'fromInteger## ::+      Integer -> Integer -> Bit'+    template: '~VAR[i][0][0] ? 1''bx : ~VAR[i][1][0]'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.toEnum##+    kind: Expression+    type: 'toEnum## :: Int+      -> Bit'+    template: '~VAR[i][0][0] ? 1''b1 : 1''b0'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.and##+    kind: Expression+    type: 'and## :: Bit ->+      Bit -> Bit'+    template: ~ARG[0] & ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.or##+    kind: Expression+    type: 'or## :: Bit ->+      Bit -> Bit'+    template: ~ARG[0] | ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.xor##+    kind: Expression+    type: 'xor## :: Bit ->+      Bit -> Bit'+    template: ~ARG[0] ^ ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.complement##+    kind: Expression+    type: 'complement## ::+      Bit -> Bit'+    template: ~ ~ARG[0]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.eq#+    kind: Expression+    type: 'eq# :: KnownNat+      n => BitVector n -> BitVector n -> Bool'+    template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] == ~ARG[2]~ELSE1'b1~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.neq#+    kind: Expression+    type: 'neq# :: KnownNat+      n => BitVector n -> BitVector n -> Bool'+    template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] != ~ARG[2]~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.lt#+    kind: Expression+    type: 'lt# :: KnownNat+      n => BitVector n -> BitVector n -> Bool'+    template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] < ~ARG[2]~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.ge#+    kind: Expression+    type: 'ge# :: KnownNat+      n => BitVector n -> BitVector n -> Bool'+    template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] >= ~ARG[2]~ELSE1'b1~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.gt#+    kind: Expression+    type: 'gt# :: KnownNat+      n => BitVector n -> BitVector n -> Bool'+    template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] > ~ARG[2]~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.le#+    kind: Expression+    type: 'le# :: KnownNat+      n => BitVector n -> BitVector n -> Bool'+    template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] <= ~ARG[2]~ELSE1'b1~FI+- BlackBoxHaskell:+    name: Clash.Sized.Internal.BitVector.toInteger#+    templateFunction: Clash.Primitives.Sized.ToInteger.bvToIntegerVerilog+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.fromEnum#+    kind: Expression+    type: 'fromEnum# :: KnownNat+      n => BitVector n -> Int'+    template: ~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[bv][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {1'b0}},~VAR[bv][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.size#+    kind: Expression+    type: 'size# :: KnownNat+      n => BitVector n -> Int'+    template: ~SIZE[~TYPO]'sd~SIZE[~TYP[1]]+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.BitVector.maxIndex#+    kind: Expression+    type: 'maxIndex# :: KnownNat+      n => BitVector n -> Int'+    template: ~SIZE[~TYPO]'sd~SIZE[~TYP[1]] - ~SIZE[~TYPO]'sd1+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.BitVector.++#+    kind: Expression+    type: '(++#) :: KnownNat+      m => BitVector n -> BitVector m -> BitVector (n + m)'+    template: ~IF~AND[~SIZE[~TYP[1]],~SIZE[~TYP[2]]]~THEN{~ARG[1],~ARG[2]}~ELSE~IF~SIZE[~TYP[1]]~THEN~ARG[1]~ELSE~ARG[2]~FI~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.index#+    kind: Expression+    type: |-+      index# :: KnownNat n  -- ARG[0]+              => BitVector n -- ARG[1]+              -> Int         -- ARG[2]+              -> Bit+    template: ~VAR[bv][1][~ARG[2]]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.slice#+    kind: Expression+    type: |-+      slice# :: BitVector (m + 1 + i) -- ARG[0]+              -> SNat m                -- ARG[1]+              -> SNat n                -- ARG[2]+              -> BitVector (m + 1 - n)+    template: '~VAR[bv][0][~LIT[1] : ~LIT[2]]'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.msb#+    kind: Expression+    type: |-+      msb# :: KnownNat n  -- ARG[0]+            => BitVector n -- ARG[1]+            -> Bit+    template: ~IF ~SIZE[~TYP[1]] ~THEN ~VAR[bv][1][~SIZE[~TYP[1]]-1] ~ELSE 1'b0 ~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.lsb#+    kind: Expression+    type: |-+      lsb# :: BitVector n -- ARG[0]+            -> Bit+    template: ~IF ~SIZE[~TYP[0]] ~THEN ~VAR[bv][0][0] ~ELSE 1'b0 ~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.minBound#+    kind: Expression+    type: 'minBound# :: BitVector+      n'+    template: ~SIZE[~TYPO]'d0+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.BitVector.maxBound#+    kind: Expression+    type: 'maxBound# :: KnownNat+      n => BitVector n'+    template: '{~SIZE[~TYPO] {1''b1}}'+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.BitVector.+#+    kind: Expression+    type: '(+#) :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: ~ARG[1] + ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.-#+    kind: Expression+    type: '(-#) :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: ~ARG[1] - ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.*#+    kind: Expression+    type: '(*#) :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: ~ARG[1] * ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.negate#+    kind: Expression+    type: 'negate# :: KnownNat+      n => BitVector n -> BitVector n'+    template: -~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.fromInteger#+    kind: Expression+    type: 'fromInteger# ::+      KnownNat n => Integer -> Integer -> BitVector n'+    template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[2]]]~THEN$unsigned(~VAR[i][2][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[2]])+      {1'b0}},~VAR[i][2]})~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.toEnum#+    kind: Expression+    type: 'toEnum# :: KnownNat+      n => Int -> BitVector n'+    template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {1'b0}},~VAR[i][1]})~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.plus#+    kind: Declaration+    type: 'plus# :: (KnownNat+      m, KnownNat n) => BitVector m -> BitVector n -> BitVector (Max m n + 1)'+    template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THEN~ARG[2]+      + ~ARG[3]~ELSE~IF~SIZE[~TYP[2]]~THEN~ARG[2]~ELSE~ARG[3]~FI~FI;+- BlackBox:+    name: Clash.Sized.Internal.BitVector.minus#+    kind: Declaration+    type: 'minus# :: (KnownNat+      m, KnownNat n) => BitVector m -> BitVector n -> BitVector (Max m n + 1)'+    template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THEN~ARG[2]+      - ~ARG[3]~ELSE~IF~SIZE[~TYP[2]]~THEN~ARG[2]~ELSE-~ARG[3]~FI~FI;+- BlackBox:+    name: Clash.Sized.Internal.BitVector.times#+    kind: Declaration+    type: 'times# :: (KnownNat+      m, KnownNat n) => BitVector m -> BitVector n -> BitVector (m + n)'+    template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THEN~ARG[2]+      * ~ARG[3]~ELSE~SIZE[~TYPO]'d0~FI;+- BlackBox:+    name: Clash.Sized.Internal.BitVector.quot#+    kind: Expression+    type: 'quot# :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: ~ARG[1] / ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.rem#+    kind: Expression+    type: 'rem# :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: ~ARG[1] % ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.and#+    kind: Expression+    type: 'and# :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: ~ARG[1] & ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.or#+    kind: Expression+    type: 'or# :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: ~ARG[1] | ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.xor#+    kind: Expression+    type: 'xor# :: KnownNat+      => BitVector n -> BitVector n -> BitVector n'+    template: ~ARG[1] ^ ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.complement#+    kind: Expression+    type: 'complement# ::+      KnownNat n => BitVector n -> BitVector n'+    template: ~ ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.shiftL#+    kind: Expression+    type: 'shiftL# :: KnownNat+      n => BitVector n -> Int -> BitVector n'+    template: ~ARG[1] << ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.shiftR#+    kind: Expression+    type: 'shiftR# :: KnownNat+      n => BitVector n -> Int -> BitVector n'+    template: ~ARG[1] >> ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.truncateB#+    kind: Expression+    type: 'truncateB# :: forall+      a b . KnownNat a => BitVector (a + b) -> BitVector a'+    template: ~VAR[bv][1][0+:~SIZE[~TYPO]]+    workInfo: Never
+ prims/commonverilog/Clash_Sized_Internal_Index.primitives.yaml view
@@ -0,0 +1,141 @@+- BlackBox:+    name: Clash.Sized.Internal.Index.pack#+    kind: Expression+    type: |-+      pack# :: Index n -> BitVector (CLogWZ 2 n 0)+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.unpack#+    kind: Expression+    type: |-+      unpack# :: KnownNat n => BitVector (CLogWZ 2 n 0) -> Index n+    template: ~ARG[1]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.eq#+    kind: Expression+    type: 'eq# :: Index n+      -> Index n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] == ~ARG[1]~ELSE1'b1~FI+- BlackBox:+    name: Clash.Sized.Internal.Index.neq#+    kind: Expression+    type: 'neq# :: Index n+      -> Index n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] != ~ARG[1]~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.Index.lt#+    kind: Expression+    type: 'lt# :: Index n+      -> Index n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.Index.ge#+    kind: Expression+    type: 'ge# :: Index n+      -> Index n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSE1'b1~FI+- BlackBox:+    name: Clash.Sized.Internal.Index.gt#+    kind: Expression+    type: 'gt# :: Index n+      -> Index n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.Index.le#+    kind: Expression+    type: 'le# :: Index n+      -> Index n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSE1'b1~FI+- BlackBox:+    name: Clash.Sized.Internal.Index.maxBound#+    kind: Expression+    type: 'maxBound# :: KnownNat+      n => Index n'+    template: ~ARG[0]-~SIZE[~TYPO]'d1+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Index.fromEnum#+    kind: Expression+    type: 'fromEnum# :: KnownNat+      n => Index n -> Int'+    template: ~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {1'b0}},~VAR[i][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.toEnum#+    kind: Expression+    type: 'toEnum# :: KnownNat+      n => Int -> Index n'+    template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {1'b0}},~VAR[i][1]})~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.+#+    kind: Expression+    type: '(+#) :: KnownNat+      n => Index n -> Index n -> Index n'+    template: ~ARG[1] + ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Index.-#+    kind: Expression+    type: '(-#) :: KnownNat+      n => Index n -> Index n -> Index n'+    template: ~ARG[1] - ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Index.*#+    kind: Expression+    type: '(*#) :: KnownNat+      n => Index n -> Index n -> Index n'+    template: ~ARG[1] * ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Index.fromInteger#+    kind: Expression+    type: 'fromInteger# ::+      KnownNat n => Integer -> Index n'+    template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {1'b0}},~VAR[i][1]})~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.plus#+    kind: Declaration+    type: Index m -> Index+      n -> Index (m + n - 1)+    template: assign ~RESULT = ~ARG[0] + ~ARG[1];+- BlackBox:+    name: Clash.Sized.Internal.Index.minus#+    kind: Declaration+    type: Index m -> Index+      n -> Index (m + n - 1)+    template: assign ~RESULT = ~ARG[0] - ~ARG[1];+- BlackBox:+    name: Clash.Sized.Internal.Index.times#+    kind: Declaration+    type: Index m -> Index+      n -> Index (((m-1) * (n-1)) + 1)+    template: assign ~RESULT = ~ARG[0] * ~ARG[1];+- BlackBox:+    name: Clash.Sized.Internal.Index.rem#+    kind: Expression+    type: 'rem# :: Index n+      -> Index n -> Index n'+    template: ~ARG[0] % ~ARG[1]+- BlackBoxHaskell:+    name: Clash.Sized.Internal.Index.toInteger#+    templateFunction: Clash.Primitives.Sized.ToInteger.indexToIntegerVerilog+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.resize#+    kind: Expression+    type: 'resize# :: KnownNat+      m => Index n -> Index m'+    template: ~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN~VAR[bv][1][0+:~SIZE[~TYPO]]~ELSE{{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {1'b0}},~ARG[1]}~FI~ELSE~SIZE[~TYPO]'d0~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.quot#+    kind: Expression+    type: 'quot# :: Index+      n -> Index n -> Index n'+    template: ~ARG[0] / ~ARG[1]
+ prims/commonverilog/Clash_Sized_Internal_Signed.primitives.yaml view
@@ -0,0 +1,206 @@+- BlackBox:+    name: Clash.Sized.Internal.Signed.eq#+    kind: Expression+    type: 'eq# :: Signed n+      -> Signed n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] == ~ARG[1]~ELSE1'b1~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.neq#+    kind: Expression+    type: 'neq# :: Signed+      n -> Signed n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] != ~ARG[1]~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.lt#+    kind: Expression+    type: 'lt# :: Signed n+      -> Signed n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.ge#+    kind: Expression+    type: 'ge# :: Signed n+      -> Signed n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSE1'b1~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.gt#+    kind: Expression+    type: 'gt# :: Signed n+      -> Signed n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.le#+    kind: Expression+    type: 'le# :: Signed n+      -> Signed n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSE1'b1~FI+- BlackBoxHaskell:+    name: Clash.Sized.Internal.Signed.toInteger#+    templateFunction: Clash.Primitives.Sized.ToInteger.signedToIntegerVerilog+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.fromEnum#+    kind: Expression+    type: 'fromEnum# :: KnownNat+      n => Signed n -> Int'+    template: ~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$signed(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {~VAR[i][1][~SIZE[~TYP[1]]-1]}},~VAR[i][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.size#+    kind: Expression+    type: 'size# :: KnownNat+      n => Signed n -> Int'+    template: ~SIZE[~TYPO]'sd~LIT[0]+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Signed.pack#+    kind: Expression+    type: 'pack# :: KnownNat+      n => Signed n -> BitVector n'+    template: $unsigned(~ARG[1])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.unpack#+    kind: Expression+    type: 'unpack# :: KnownNat+      n => BitVector n -> Signed n'+    template: $signed(~ARG[1])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.minBound#+    comment: Generates incorrect SV for n=0+    kind: Expression+    type: 'minBound# :: KnownNat+      n => Signed n'+    template: $signed({1'b1, {(~LIT[0]-1) {1'b0}}})+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Signed.maxBound#+    comment: Generates incorrect SV for n=0+    kind: Expression+    type: 'maxBound# :: KnownNat+      n => Signed n'+    template: $signed({1'b0, {(~LIT[0]-1) {1'b1}}})+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Signed.*#+    kind: Expression+    type: '(*#) :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: ~ARG[1] * ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Signed.negate#+    kind: Expression+    type: 'negate# :: KnownNat+      n => Signed n -> Signed n'+    template: -~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Signed.abs#+    kind: Expression+    type: 'abs# :: KnownNat+      n => Signed n -> Signed n'+    template: '(~ARG[1] < ~LIT[0]''sd0) ? -~ARG[1] : ~ARG[1]'+- BlackBox:+    name: Clash.Sized.Internal.Signed.fromInteger#+    kind: Expression+    type: 'fromInteger# ::+      KnownNat n => Integer -> Signed (n :: Nat)'+    template: >-+      ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]+      ~THEN$signed(~VAR[i][1][0+:~SIZE[~TYPO]])+      ~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]){~VAR[i][1][~SIZE[~TYP[1]]-1]}},~VAR[i][1]})+      ~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.toEnum#+    kind: Expression+    type: 'toEnum# :: KnownNat+      n => Int -> Signed n'+    template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$signed(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {~VAR[i][1][~SIZE[~TYP[1]]-1]}},~VAR[i][1]})~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.plus#+    kind: Declaration+    type: 'plus# :: Signed+      m -> Signed n -> Signed (1 + Max m n)'+    template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN~ARG[0]+      + ~ARG[1]~ELSE~IF~SIZE[~TYP[0]]~THEN~ARG[0]~ELSE~ARG[1]~FI~FI;+- BlackBox:+    name: Clash.Sized.Internal.Signed.minus#+    kind: Declaration+    type: 'minus# :: Signed+      m -> Signed n -> Signed (1 + Max m n)'+    template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN ~ARG[0]+      - ~ARG[1]~ELSE~IF~SIZE[~TYP[0]]~THEN ~ARG[0]~ELSE - ~ARG[1] ~FI~FI;+- BlackBox:+    name: Clash.Sized.Internal.Signed.times#+    kind: Declaration+    type: 'times# :: Signed+      m -> Signed n -> Signed (m + n)'+    template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN~ARG[0]+      * ~ARG[1]~ELSE~SIZE[~TYPO]'d0~FI;+- BlackBox:+    name: Clash.Sized.Internal.Signed.rem#+    kind: Expression+    type: 'rem# :: Signed+      n -> Signed n -> Signed n'+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Signed.and#+    kind: Expression+    type: 'and# :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: ~ARG[1] & ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Signed.or#+    kind: Expression+    type: 'or# :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: ~ARG[1] | ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Signed.xor#+    kind: Expression+    type: 'xor# :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: ~ARG[1] ^ ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Signed.complement#+    kind: Expression+    type: 'complement# ::+      KnownNat n => Signed n -> Signed n'+    template: ~ ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Signed.shiftL#+    kind: Expression+    type: 'shiftL# :: KnownNat+      n => Signed n -> Int -> Signed n'+    template: ~ARG[1] <<< ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Signed.shiftR#+    kind: Expression+    type: 'shiftR# :: KnownNat+      n => Signed n -> Int -> Signed n'+    template: ~ARG[1] >>> ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Signed.truncateB#+    kind: Expression+    type: 'truncateB# :: KnownNat+      m => Signed (n + m) -> Signed m'+    template: $signed(~VAR[s][1][0+:~SIZE[~TYPO]])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.resize#+    kind: Expression+    type: 'resize# :: (KnownNat+      n, KnownNat m) => Signed n -> Signed m'+    template: ~IF~SIZE[~TYP[2]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[2]]]~THEN$signed({~VAR[s][2][~LIT[0]-1],~VAR[s][2][0+:(~SIZE[~TYPO]-1)]})~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[2]])+      {~VAR[s][2][~LIT[0]-1]}},~VAR[s][2]})~FI~ELSE~SIZE[~TYPO]'sd0~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.quot#+    kind: Expression+    type: 'quot# :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: ~ARG[1] / ~ARG[2]
+ prims/commonverilog/Clash_Sized_Internal_Unsigned.primitives.yaml view
@@ -0,0 +1,188 @@+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.eq#+    kind: Expression+    type: 'eq# :: Unsigned+      n -> Unsigned n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] == ~ARG[1]~ELSE1'b1~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.neq#+    kind: Expression+    type: 'neq# :: Unsigned+      n -> Unsigned n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] != ~ARG[1]~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.lt#+    kind: Expression+    type: 'lt# :: Unsigned+      n -> Unsigned n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.ge#+    kind: Expression+    type: 'ge# :: Unsigned+      n -> Unsigned n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSE1'b1~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.gt#+    kind: Expression+    type: 'gt# :: Unsigned+      n -> Unsigned n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSE1'b0~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.le#+    kind: Expression+    type: 'le# :: Unsigned+      n -> Unsigned n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSE1'b1~FI+- BlackBoxHaskell:+    name: Clash.Sized.Internal.Unsigned.toInteger#+    templateFunction: Clash.Primitives.Sized.ToInteger.unsignedToIntegerVerilog+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.fromEnum#+    kind: Expression+    type: 'fromEnum# :: KnownNat+      n => Unsigned n -> Int'+    template: ~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {1'b0}},~VAR[i][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.size#+    kind: Expression+    type: 'size# :: KnownNat+      n => Unsigned n -> Int'+    template: ~SIZE[~TYPO]'sd~LIT[0]+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.pack#+    kind: Expression+    type: 'pack# :: Unsigned+      n -> BitVector n'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.unpack#+    kind: Expression+    type: 'unpack# :: KnownNat+      n => BitVector n -> Unsigned n'+    template: ~ARG[1]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.minBound#+    kind: Expression+    type: 'minBound# :: Unsigned+      n'+    template: ~SIZE[~TYPO]'d0+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.maxBound#+    kind: Expression+    type: 'maxBound# :: KnownNat+      n => Unsigned n'+    template: '{~LIT[0] {1''b1}}'+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.*#+    kind: Expression+    type: '(*#) :: KnownNat+      n => Unsigned n -> Unsigned n -> Unsigned n'+    template: ~ARG[1] * ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.negate#+    kind: Expression+    type: 'negate# :: KnownNat+      n => Unsigned n -> Unsigned n'+    template: '- ~ARG[1]'+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.fromInteger#+    kind: Expression+    type: 'fromInteger# ::+      KnownNat n => Integer -> Unsigned n'+    template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {1'b0}},~VAR[i][1]})~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.toEnum#+    kind: Expression+    type: 'toEnum# :: KnownNat+      n => Int -> Unsigned n'+    template: ~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[i][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {1'b0}},~VAR[i][1]})~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.plus#+    kind: Declaration+    type: 'plus# :: Unsigned+      m -> Unsigned n -> Unsigned (1 + Max m n)'+    template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN~ARG[0]+      + ~ARG[1]~ELSE~IF~SIZE[~TYP[0]]~THEN~ARG[0]~ELSE~ARG[1]~FI~FI;+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.minus#+    kind: Declaration+    type: 'minus# :: (KnownNat+      m, KnownNat n) => Unsigned m -> Unsigned n -> Unsigned (1 + Max m n)'+    template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THEN ~ARG[2]+      - ~ARG[3]~ELSE~IF~SIZE[~TYP[2]]~THEN ~ARG[2]~ELSE - ~ARG[3]~FI~FI;+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.times#+    kind: Declaration+    type: 'times# :: Unsigned+      m -> Unsigned n -> Unsigned (m + n)'+    template: assign ~RESULT = ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN~ARG[0]+      * ~ARG[1]~ELSE~SIZE[~TYPO]'d0~FI;+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.rem#+    kind: Expression+    type: 'rem# :: Unsigned+      n -> Unsigned n -> Unsigned n'+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.and#+    kind: Expression+    type: 'and# :: Unsigned+      n -> Unsigned n -> Unsigned n'+    template: ~ARG[0] & ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.or#+    kind: Expression+    type: 'or# :: Unsigned+      n -> Unsigned n -> Unsigned n'+    template: ~ARG[0] | ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.xor#+    kind: Expression+    type: 'xor# :: Unsigned+      n -> Unsigned n -> Unsigned n'+    template: ~ARG[0] ^ ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.complement#+    kind: Expression+    type: 'complement# ::+      KnownNat n => Unsigned n -> Unsigned n'+    template: ~ ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.shiftL#+    kind: Expression+    type: 'shiftL# :: KnownNat+      n => Unsigned n -> Int -> Unsigned n'+    template: ~ARG[1] << ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.shiftR#+    kind: Expression+    type: 'shiftR# :: KnownNat+      n => Unsigned n -> Int -> Unsigned n'+    template: ~ARG[1] >> ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.resize#+    kind: Expression+    type: 'resize# :: KnownNat+      m => Unsigned n -> Unsigned m'+    template: ~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN~VAR[bv][1][0+:~SIZE[~TYPO]]~ELSE{{(~SIZE[~TYPO]-~SIZE[~TYP[1]])+      {1'b0}},~ARG[1]}~FI~ELSE~SIZE[~TYPO]'d0~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.quot#+    kind: Expression+    type: 'quot# :: Unsigned+      n -> Unsigned n -> Unsigned n'+    template: ~ARG[0] / ~ARG[1]
+ prims/commonverilog/Clash_Sized_Vector.primitives.yaml view
@@ -0,0 +1,14 @@+- BlackBox:+    name: Clash.Sized.Vector.maxIndex+    kind: Expression+    type: 'maxIndex :: KnownNat+      n => Vec n a -> Int'+    template: ~SIZE[~TYPO]'sd~LIT[0] - ~SIZE[~TYPO]'sd1+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Vector.length+    kind: Expression+    type: 'length :: KnownNat+      n => Vec n a -> Int'+    template: ~SIZE[~TYPO]'sd~LIT[0]+    workInfo: Constant
+ prims/commonverilog/GHC_Base.primitives.yaml view
@@ -0,0 +1,12 @@+- BlackBox:+    name: GHC.Base.remInt+    kind: Expression+    type: 'remInt :: Int ->+      Int -> Int'+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: GHC.Base.quotInt+    kind: Expression+    type: 'quotInt :: Int+      -> Int -> Int'+    template: ~ARG[0] / ~ARG[1]
+ prims/commonverilog/GHC_Classes.primitives.yaml view
@@ -0,0 +1,30 @@+- BlackBox:+    name: GHC.Classes.eqInt+    kind: Expression+    type: 'eqInt :: Int ->+      Int -> Bool'+    template: ~ARG[0] == ~ARG[1]+- BlackBox:+    name: GHC.Classes.neInt+    kind: Expression+    type: 'neInt :: Int ->+      Int -> Bool'+    template: ~ARG[0] != ~ARG[1]+- BlackBox:+    name: GHC.Classes.&&+    kind: Expression+    type: '(&&) :: Bool ->+      Bool -> Bool'+    template: ~ARG[0] & ~ARG[1]+- BlackBox:+    name: GHC.Classes.||+    kind: Expression+    type: '(||) :: Bool ->+      Bool -> Bool'+    template: ~ARG[0] | ~ARG[1]+- BlackBox:+    name: GHC.Classes.not+    kind: Expression+    type: 'not :: Bool ->+      Bool'+    template: ~ ~ARG[0]
+ prims/commonverilog/GHC_Int.primitives.yaml view
@@ -0,0 +1,16 @@+- BlackBoxHaskell:+    name: GHC.Int.I8#+    templateFunction: Clash.Primitives.GHC.Int.intTF+    workInfo: Never+- BlackBoxHaskell:+    name: GHC.Int.I16#+    templateFunction: Clash.Primitives.GHC.Int.intTF+    workInfo: Never+- BlackBoxHaskell:+    name: GHC.Int.I32#+    templateFunction: Clash.Primitives.GHC.Int.intTF+    workInfo: Never+- BlackBoxHaskell:+    name: GHC.Int.I64#+    templateFunction: Clash.Primitives.GHC.Int.intTF+    workInfo: Never
+ prims/commonverilog/GHC_Integer_Logarithms.primitives.yaml view
@@ -0,0 +1,22 @@+- BlackBox:+    name: GHC.Integer.Logarithms.integerLogBase#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: integerLogBase+      extension: inc+      template: |-+        // integer logBase+        function integer ~INCLUDENAME[0];+          input integer base, value;+          begin+            for (~INCLUDENAME[0] = 0; value >= base; ~INCLUDENAME[0]=~INCLUDENAME[0]+1)+              value = value / base;+          end+        endfunction+    kind: Expression+    type: 'integerLogBase#+      :: Integer -> Integer -> Int#'+    template: ~INCLUDENAME[0](~ARG[0],~ARG[1])+    warning: 'GHC.Integer.Logarithms.integerLogBase#: Integers are dynamically sized+      in simulation, but fixed-length after synthesis. Use carefully.'
+ prims/commonverilog/GHC_Integer_Type.primitives.yaml view
@@ -0,0 +1,223 @@+- BlackBox:+    name: GHC.Integer.Type.smallInteger+    kind: Declaration+    type: 'smallInteger ::+      Int# -> Integer'+    template: assign ~RESULT = $signed(~ARG[0]);+    warning: 'GHC.Integer.Type.smallInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Integer.Type.integerToInt+    kind: Declaration+    type: 'integerToInt ::+      Integer -> Int#'+    template: assign ~RESULT = $signed(~ARG[0]);+    warning: 'GHC.Integer.Type.integerToInt: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Integer.Type.timesInteger+    kind: Expression+    type: 'timesInteger ::+      Integer -> Integer -> Integer'+    template: ~ARG[0] * ~ARG[1]+    warning: 'GHC.Integer.Type.timesInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.negateInteger+    kind: Expression+    type: 'negateInteger ::+      Integer -> Integer'+    template: -~ARG[0]+    warning: 'GHC.Integer.Type.negateInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.absInteger+    kind: Expression+    type: 'absInteger :: Integer+      -> Integer'+    template: '(~ARG[0] < ~SIZE[~TYPO]''sd0) ? -~ARG[0] : ~ARG[0]'+    warning: 'GHC.Integer.Type.absInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.remInteger+    kind: Expression+    type: 'remInteger :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] % ~ARG[1]+    warning: 'GHC.Integer.Type.remInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.eqInteger+    kind: Expression+    type: 'eqInteger :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] == ~ARG[1]+    warning: 'GHC.Integer.Type.eqInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.neqInteger+    kind: Expression+    type: 'neqInteger :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] != ~ARG[1]+    warning: 'GHC.Integer.Type.neqInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.eqInteger#+    kind: Expression+    type: 'eqInteger :: Integer+      -> Integer -> Bool'+    template: '(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+    warning: 'GHC.Integer.Type.eqInteger#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.neqInteger#+    kind: Expression+    type: 'neqInteger :: Integer+      -> Integer -> Bool'+    template: '(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+    warning: 'GHC.Integer.Type.neqInteger#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.leInteger#+    kind: Expression+    type: 'leInteger :: Integer+      -> Integer -> Bool'+    template: '(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+    warning: 'GHC.Integer.Type.leInteger#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.gtInteger#+    kind: Expression+    type: 'gtInteger :: Integer+      -> Integer -> Bool'+    template: '(~ARG[0] > ~ARG[1] ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+    warning: 'GHC.Integer.Type.gtInteger#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.ltInteger#+    kind: Expression+    type: 'ltInteger :: Integer+      -> Integer -> Bool'+    template: '(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+    warning: 'GHC.Integer.Type.ltInteger#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.geInteger#+    kind: Expression+    type: 'geInteger :: Integer+      -> Integer -> Bool'+    template: '(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+    warning: 'GHC.Integer.Type.geInteger#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.shiftRInteger+    kind: Expression+    type: 'shiftRInteger ::+      Integer -> Int# -> Integer'+    template: ~ARG[0] >>> ~ARG[1]+    warning: 'GHC.Integer.Type.shiftRInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.shiftLInteger+    kind: Expression+    type: 'shiftLInteger ::+      Integer -> Int# -> Integer'+    template: ~ARG[0] <<< ~ARG[1]+    warning: 'GHC.Integer.Type.shiftLInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.testBitInteger+    kind: Expression+    type: 'testBitInteger+      :: Integer -> Int# -> Bool'+    template: ~VAR[input][0][~ARG[1]] == 1'b1+    warning: 'GHC.Integer.Type.testBitInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.wordToInteger+    kind: Declaration+    type: 'wordToInteger ::+      Word# -> Integer'+    template: assign ~RESULT = $signed(~ARG[0]);+    warning: 'GHC.Integer.Type.wordToInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Integer.Type.integerToWord+    kind: Declaration+    type: 'integerToWord ::+      Integer -> Word#'+    template: assign ~RESULT = $unsigned(~ARG[0]);+    warning: 'GHC.Integer.Type.integerToWord: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Integer.Type.integerToWord64+    comment: only used by 32 bit GHC+    kind: Declaration+    type: 'integerToWord ::+      Integer -> Word64#'+    template: assign ~RESULT = $unsigned(~ARG[0]);+    warning: 'GHC.Integer.Type.integerToWord64: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Integer.Type.bitInteger+    kind: Expression+    type: 'bitInteger :: Int+      -> Integer'+    template: 1 << ~ARG[0]+    warning: 'GHC.Integer.Type.bitInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.complementInteger+    kind: Expression+    type: 'complementInteger+      :: Integer -> Integer'+    template: ~ ~ARG[0]+    warning: 'GHC.Integer.Type.complementInteger: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.xorInteger+    kind: Expression+    type: 'xorInteger :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] ^ ~ARG[1]+    warning: 'GHC.Integer.Type.xorInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.orInteger+    kind: Expression+    type: 'orInteger :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] | ~ARG[1]+    warning: 'GHC.Integer.Type.orInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.andInteger+    kind: Expression+    type: 'andInteger :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] & ~ARG[1]+    warning: 'GHC.Integer.Type.andInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.$wsignumInteger+    kind: Expression+    type: '$wsignumInteger+      :: Integer -> Integer'+    template: '(~ARG[0] < ~SIZE[~TYPO]''sd0) ? -~SIZE[~TYPO]''sd1 : ((~ARG[0] == ~SIZE[~TYPO]''sd0)+      ? ~SIZE[~TYPO]''sd0 : ~SIZE[~TYPO]''sd1)'+    warning: 'GHC.Integer.Type.$wsignumInteger: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.quotInteger+    kind: Expression+    type: 'quotInteger ::+      Integer -> Integer -> Integer'+    template: ~ARG[0] / ~ARG[1]+    warning: 'GHC.Integer.Type.quotInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'
+ prims/commonverilog/GHC_Natural.primitives.yaml view
@@ -0,0 +1,26 @@+- BlackBox:+    name: GHC.Natural.naturalFromInteger+    kind: Expression+    type: 'naturalFromInteger+      :: Integer -> Natural'+    template: $unsigned(~VAR[n][0][(~SIZE[~TYPO]-1):0])+    warning: 'GHC.Natural.naturalFromInteger: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Natural.timesNatural+    kind: Expression+    type: 'timesNatural ::+      Natural -> Natural -> Natural'+    template: ~ARG[0] * ~ARG[1]+    warning: 'GHC.Natural.timesNatural: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Natural.wordToNatural#+    kind: Declaration+    type: 'wordToNatural#+      :: Word# -> Natural'+    template: assign ~RESULT = $unsigned(~ARG[0]);+    warning: 'GHC.Natural.wordToNatural#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never
+ prims/commonverilog/GHC_Num_Integer.primitives.yaml view
@@ -0,0 +1,306 @@+- BlackBox:+    name: GHC.Num.Integer.integerToNatural+    kind: Expression+    type: 'integerToNatural+      :: Integer -> Natural'+    template: $unsigned(~VAR[n][0][(~SIZE[~TYPO]-1):0])+    warning: 'GHC.Num.Integer.integerToNatural: Naturals are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerToNaturalThrow+    kind: Expression+    type: 'integerToNaturalThrow+      :: Integer -> Natural'+    template: '(~ARG[0] < ~SIZE[~TYP[0]]''d0 ? ~ERRORO: $unsigned(~VAR[n][0][(~SIZE[~TYPO]-1):0]))'+    warning: 'GHC.Num.Integer.integerToNaturalThrow: Naturals are dynamically sized+      in simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerToNaturalClamp+    kind: Expression+    type: 'integerToNatural+      :: Integer -> Natural'+    template: '(~ARG[0] < ~SIZE[~TYP[0]]''d0 ? ~SIZE[~TYPO]''d0 : $unsigned(~VAR[n][0][(~SIZE[~TYPO]-1):0]))'+    warning: 'GHC.Num.Integer.integerToNaturalClamp: Naturals are dynamically sized+      in simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerToInt#+    kind: Declaration+    type: 'integerToInt ::+      Integer -> Int#'+    template: assign ~RESULT = $signed(~ARG[0]);+    warning: 'GHC.Num.Integer.integerToInt#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerMul+    kind: Expression+    type: 'integerMul :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] * ~ARG[1]+    warning: 'GHC.Num.Integer.integerMul: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerNegate+    kind: Expression+    type: 'integerNegate ::+      Integer -> Integer'+    template: -~ARG[0]+    warning: 'GHC.Num.Integer.integerNegate: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerAbs+    kind: Expression+    type: 'integerAbs :: Integer+      -> Integer'+    template: '(~ARG[0] < ~SIZE[~TYPO]''sd0) ? -~ARG[0] : ~ARG[0]'+    warning: 'GHC.Num.Integer.integerAbs: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerRem+    kind: Expression+    type: 'integerRem :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] % ~ARG[1]+    warning: 'GHC.Num.Integer.integerRem: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerEq+    kind: Expression+    type: 'integerEq :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] == ~ARG[1]+    warning: 'GHC.Num.Integer.integerEq: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerNe+    kind: Expression+    type: 'integerNe :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] != ~ARG[1]+    warning: 'GHC.Num.Integer.integerNe: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerEq#+    kind: Expression+    type: 'integerEq :: Integer+      -> Integer -> Int#'+    template: '(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+    warning: 'GHC.Num.Integer.integerEq#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerNe#+    kind: Expression+    type: 'integerNe# :: Integer+      -> Integer -> Int#'+    template: '(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+    warning: 'GHC.Num.Integer.integerNe#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerLe#+    kind: Expression+    type: 'integerLe :: Integer+      -> Integer -> Int#'+    template: '(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+    warning: 'GHC.Num.Integer.integerLe#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerGt#+    kind: Expression+    type: 'integerGt# :: Integer+      -> Integer -> Int#'+    template: '(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+    warning: 'GHC.Num.Integer.integerGt#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerLt#+    kind: Expression+    type: 'integerLt# :: Integer+      -> Integer -> Int#'+    template: '(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+    warning: 'GHC.Num.Integer.integerLt#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerGe#+    kind: Expression+    type: 'integerGe# :: Integer+      -> Integer -> Int#'+    template: '(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+    warning: 'GHC.Num.Integer.integerGe#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerShiftR#+    kind: Expression+    type: 'integerShiftR ::+      Integer -> Word# -> Integer'+    template: ~ARG[0] >>> ~ARG[1]+    warning: 'GHC.Num.Integer.integerShiftR#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerShiftL#+    kind: Expression+    type: 'integerShiftL ::+      Integer -> Word# -> Integer'+    template: ~ARG[0] <<< ~ARG[1]+    warning: 'GHC.Num.Integer.integerShiftL#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerTestBit#+    kind: Expression+    type: 'integerTestBit+      :: Integer -> Word# -> Int#'+    template: "((~VAR[input][0][~ARG[1]] == 1'b1) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0)"+    warning: 'GHC.Num.Integer.integerTestBit#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerFromWord#+    kind: Declaration+    type: 'integerFromWord#+      :: Word# -> Integer'+    template: assign ~RESULT = $signed(~ARG[0]);+    warning: 'GHC.Num.Integer.integerFromWord#: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerToWord#+    kind: Declaration+    type: 'integerToWord#+      :: Integer -> Word#'+    template: assign ~RESULT = $unsigned(~ARG[0]);+    warning: 'GHC.Num.Integer.integerToWord#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerToInt64#+    kind: Expression+    type: 'integerToInt64#:: Integer -> Int64#'+    template: ~ARG[0]+    warning: 'GHC.Num.Integer.integerToInt64#: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerToWord64#+    comment: only used by 32 bit GHC+    kind: Declaration+    type: 'integerToWord64#+      :: Integer -> Word64#'+    template: assign ~RESULT = $unsigned(~ARG[0]);+    warning: 'GHC.Num.Integer.integerToWord64#: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerFromWord64#+    kind: Declaration+    type: 'integerFromWord64# :: Word64# -> Integer'+    template: assign ~RESULT = $signed(~ARG[0]);+    warning: 'GHC.Num.Integer.integerFromWord64#: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerBit#+    kind: Expression+    type: 'integerBit# ::+      Word# -> Integer'+    template: 1 << ~ARG[0]+    warning: 'GHC.Num.Integer.integerBit#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerComplement+    kind: Expression+    type: 'integerComplement+      :: Integer -> Integer'+    template: ~ ~ARG[0]+    warning: 'GHC.Num.Integer.integerComplement: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerXor+    kind: Expression+    type: 'integerXor :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] ^ ~ARG[1]+    warning: 'GHC.Num.Integer.integerXor: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerOr+    kind: Expression+    type: 'integerOr :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] | ~ARG[1]+    warning: 'GHC.Num.Integer.integerOr: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerAnd+    kind: Expression+    type: 'andInteger :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] & ~ARG[1]+    warning: 'GHC.Num.Integer.integerAnd: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerSignum+    kind: Expression+    type: 'integerSignum ::+      Integer -> Integer'+    template: '(~ARG[0] < ~SIZE[~TYPO]''sd0) ? -~SIZE[~TYPO]''sd1 : ((~ARG[0] == ~SIZE[~TYPO]''sd0)+      ? ~SIZE[~TYPO]''sd0 : ~SIZE[~TYPO]''sd1)'+    warning: 'GHC.Num.Integer.integerSignum: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.$wintegerSignum+    kind: Expression+    type: 'integerSignum ::+      Integer -> Int#'+    template: '(~ARG[0] < ~SIZE[~TYPO]''sd0) ? -~SIZE[~TYPO]''sd1 : ((~ARG[0] == ~SIZE[~TYPO]''sd0)+      ? ~SIZE[~TYPO]''sd0 : ~SIZE[~TYPO]''sd1)'+    warning: 'GHC.Num.Integer.$wintegerSignum: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerLogBase#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: integerLogBase+      extension: inc+      template: |-+        // integer logBase+        function integer ~INCLUDENAME[0];+        input integer base, value;+        begin+          for (~INCLUDENAME[0] = 0; value >= base; ~INCLUDENAME[0]=~INCLUDENAME[0]+1)+            value = value / base;+        end+        endfunction+    kind: Expression+    type: 'integerLogBase#+      :: Integer -> Integer -> Word#'+    template: ~INCLUDENAME[0](~ARG[0],~ARG[1])+    warning: 'GHC.Num.Integer.integerLogBase#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerCompare+    kind: Expression+    type: 'integerCompare+      :: Integer -> Integer -> Ordering'+    template: '(~ARG[0] < ~ARG[1]) ? -~SIZE[~TYPO]''d0 : ((~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''d1+      : ~SIZE[~TYPO]''d2)'+    warning: 'GHC.Num.Integer.integerCompare: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerQuot+    kind: Expression+    type: 'integerQuot ::+      Integer -> Integer -> Integer'+    template: ~ARG[0] / ~ARG[1]+    warning: 'GHC.Num.Integer.integerQuot: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.$wintegerFromInt64#+    kind: Declaration+    type: '$wintegerFromInt64# :: Int64# -> Int#'+    template: |-+      // wintegerFromInt64 begin+      assign ~RESULT = ~ARG[0];+      // wintegerFromInt64 end+    workInfo: Never
+ prims/commonverilog/GHC_Num_Natural.primitives.yaml view
@@ -0,0 +1,128 @@+- BlackBox:+    name: GHC.Num.Natural.naturalMul+    kind: Expression+    type: 'naturalMul :: Natural+      -> Natural -> Natural'+    template: ~ARG[0] * ~ARG[1]+    warning: 'GHC.Num.Natural.naturalMul: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalFromWord#+    kind: Declaration+    type: 'naturalFromWord#+      :: Word# -> Natural'+    template: assign ~RESULT = $unsigned(~ARG[0]);+    warning: 'GHC.Num.Natural.naturalFromWord#: Naturals are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Natural.naturalRem+    kind: Expression+    type: 'naturalRem :: Natural+      -> Natural -> Natural'+    template: ~ARG[0] % ~ARG[1]+    warning: 'GHC.Num.Natural.naturalRem: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalLogBase#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: naturalLogBase+      extension: inc+      template: |-+        // natural logBase+        function integer ~INCLUDENAME[0];+        input [~SIZE[~TYP[0]]-1:0] base, value;+        begin+          for (~INCLUDENAME[0] = 0; value >= base; ~INCLUDENAME[0]=~INCLUDENAME[0]+1)+            value = value / base;+        end+        endfunction+    kind: Expression+    type: 'naturalLogBase#+      :: Natural -> Natural -> Word#'+    template: ~INCLUDENAME[0](~ARG[0],~ARG[1])+    warning: 'GHC.Num.Natural.naturalLogBase#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalEq#+    kind: Expression+    type: 'naturalEq :: Natural+      -> Natural -> Int#'+    template: '(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d0'+    warning: 'GHC.Num.Natural.naturalEq#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalNe#+    kind: Expression+    type: 'naturalNe# :: Natural+      -> Natural -> Int#'+    template: '(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d0'+    warning: 'GHC.Num.Natural.naturalNe#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalLe#+    kind: Expression+    type: 'naturalLe :: Natural+      -> Natural -> Int#'+    template: '(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d0'+    warning: 'GHC.Num.Natural.naturalLe#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalGt#+    kind: Expression+    type: 'naturalGt# :: Natural+      -> Natural -> Int#'+    template: '(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d0'+    warning: 'GHC.Num.Natural.naturalGt#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalLt#+    kind: Expression+    type: 'naturalLt# :: Natural+      -> Natural -> Int#'+    template: '(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d0'+    warning: 'GHC.Num.Natural.naturalLt#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalGe#+    kind: Expression+    type: 'naturalGe# :: Natural+      -> Natural -> Int#'+    template: '(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]''d1 : ~SIZE[~TYPO]''d0'+    warning: 'GHC.Num.Natural.naturalGe#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalShiftL#+    kind: Expression+    type: 'naturalShiftL#+      :: Natural -> Word# -> Natural'+    template: ~ARG[0] <<< ~ARG[1]+    warning: 'GHC.Num.Natural.naturalShiftL#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalShiftR#+    kind: Expression+    type: 'naturalShiftR#+      :: Natuarl -> Word# -> Natural'+    template: ~ARG[0] >>> ~ARG[1]+    warning: 'GHC.Num.Natural.naturalShiftR#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.NaturalCompare+    kind: Expression+    type: 'naturalCompare+      :: Natural -> Natural -> Ordering'+    template: '(~ARG[0] < ~ARG[1]) ? -~SIZE[~TYPO]''d0 : ((~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''d1+      : ~SIZE[~TYPO]''d2)'+    warning: 'GHC.Num.Natural.naturalCompare: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalQuot+    kind: Expression+    type: 'naturalQuot ::+      Natural -> Natural -> Natural'+    template: ~ARG[0] / ~ARG[1]+    warning: 'GHC.Num.Natural.naturalQuot: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'
+ prims/commonverilog/GHC_Prim.primitives.yaml view
@@ -0,0 +1,1050 @@+- BlackBox:+    name: GHC.Prim.gtChar#+    kind: Expression+    type: 'gtChar# :: Char#+      -> Char# -> Int#'+    template: '(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.geChar#+    kind: Expression+    type: 'geChar# :: Char#+      -> Char# -> Int#'+    template: '(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.eqChar#+    kind: Expression+    type: 'eqChar# :: Char#+      -> Char# -> Int#'+    template: '(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.neChar#+    kind: Expression+    type: 'neChar# :: Char#+      -> Char# -> Int#'+    template: '(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.ltChar#+    kind: Expression+    type: 'ltChar# :: Char#+      -> Char# -> Int#'+    template: '(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.leChar#+    kind: Expression+    type: 'leChar# :: Char#+      -> Char# -> Int#'+    template: '(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.ord#+    kind: Expression+    type: 'ord :: Char# ->+      Int#'+    template: $signed({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[c][0]})+- BlackBox:+    name: GHC.Prim.*#+    kind: Expression+    type: '(*#) :: Int# ->+      Int# -> Int#'+    template: ~ARG[0] * ~ARG[1]+- BlackBox:+    name: GHC.Prim.remInt#+    kind: Expression+    type: 'remInt# :: Int#+      -> Int# -> Int#'+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: GHC.Prim.andI#+    kind: Expression+    type: 'andI# :: Int# ->+      Int# -> Int#'+    template: ~ARG[0] & ~ARG[1]+- BlackBox:+    name: GHC.Prim.orI#+    kind: Expression+    type: 'orI# :: Int# ->+      Int# -> Int#'+    template: ~ARG[0] | ~ARG[1]+- BlackBox:+    name: GHC.Prim.xorI#+    kind: Expression+    type: 'xorI# :: Int# ->+      Int# -> Int#'+    template: ~ARG[0] ^ ~ARG[1]+- BlackBox:+    name: GHC.Prim.notI#+    kind: Expression+    type: 'notI# :: Int# ->+      Int#'+    template: ~ ~ARG[0]+- BlackBox:+    name: GHC.Prim.negateInt#+    kind: Expression+    type: 'negateInt# :: Int#+      -> Int#'+    template: -(~ARG[0])+- BlackBox:+    name: GHC.Prim.>#+    kind: Expression+    type: '(>#) :: Int# ->+      Int# -> Int#'+    template: '(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.>=#+    kind: Expression+    type: '(>=#) :: Int# ->+      Int# -> Int#'+    template: '(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.==#+    kind: Expression+    type: '(==) :: Int# ->+      Int# -> Int#'+    template: '(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim./=#+    kind: Expression+    type: '(/=#) :: Int# ->+      Int# -> Int#'+    template: '(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.<#+    kind: Expression+    type: '(<#) :: Int# ->+      Int# -> Int#'+    template: '(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.<=#+    kind: Expression+    type: '(<=#) :: Int# ->+      Int# -> Int#'+    template: '(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.chr#+    kind: Expression+    type: 'ord :: Int# ->+      Char#'+    template: $unsigned(~VAR[i][0][0+:~SIZE[~TYPO]])+- BlackBox:+    name: GHC.Prim.int2Word#+    kind: Expression+    type: 'int2Word# :: Int#+      -> Word#'+    template: $unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.uncheckedIShiftL#+    kind: Expression+    type: 'uncheckedIShiftL#+      :: Int# -> Int# -> Int#'+    template: ~ARG[0] <<< ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedIShiftRA#+    kind: Expression+    type: 'uncheckedIShiftRA#+      :: Int# -> Int# -> Int#'+    template: ~ARG[0] >>> ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedIShiftRL#+    kind: Expression+    type: 'uncheckedIShiftRL#+      :: Int# -> Int# -> Int#'+    template: ~ARG[0] >> ~ARG[1]+- BlackBox:+    name: GHC.Prim.timesWord#+    kind: Expression+    type: 'timesWord# :: Word#+      -> Word# -> Word#'+    template: ~ARG[0] * ~ARG[1]+- BlackBox:+    name: GHC.Prim.remWord#+    kind: Expression+    type: 'remWord# :: Word#+      -> Word# -> Word#'+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: GHC.Prim.and#+    kind: Expression+    type: 'and# :: Word# ->+      Word# -> Word#'+    template: ~ARG[0] & ~ARG[1]+- BlackBox:+    name: GHC.Prim.or#+    kind: Expression+    type: 'or# :: Word# ->+      Word# -> Word#'+    template: ~ARG[0] | ~ARG[1]+- BlackBox:+    name: GHC.Prim.xor#+    kind: Expression+    type: 'xor# :: Word# ->+      Word# -> Word#'+    template: ~ARG[0] ^ ~ARG[1]+- BlackBox:+    name: GHC.Prim.not#+    kind: Expression+    type: 'not# :: Word# ->+      Word#'+    template: ~ ~ARG[0]+- BlackBox:+    name: GHC.Prim.uncheckedShiftL#+    kind: Expression+    type: 'uncheckedShiftL#+      :: Word# -> Int# -> Word#'+    template: ~ARG[0] << ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftRL#+    kind: Expression+    type: 'uncheckedShiftRL#+      :: Word# -> Int# -> Word#'+    template: ~ARG[0] >> ~ARG[1]+- BlackBox:+    name: GHC.Prim.word2Int#+    kind: Expression+    type: 'int2Word# :: Word#+      -> Int#'+    template: $signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.gtWord#+    kind: Expression+    type: 'gtWord# :: Word#+      -> Word# -> Int#'+    template: '(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.geWord#+    kind: Expression+    type: 'geWord# :: Word#+      -> Word# -> Int#'+    template: '(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.eqWord#+    kind: Expression+    type: 'eqWord# :: Word#+      -> Word# -> Int#'+    template: '(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.neWord#+    kind: Expression+    type: 'neWord# :: Word#+      -> Word# -> Int#'+    template: '(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.ltWord#+    kind: Expression+    type: 'ltWord# :: Word#+      -> Word# -> Int#'+    template: '(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.leWord#+    kind: Expression+    type: 'leWord# :: Word#+      -> Word# -> Int#'+    template: '(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]''sd1 : ~SIZE[~TYPO]''sd0'+- BlackBox:+    name: GHC.Prim.byteSwap16#+    kind: Declaration+    type: 'byteSwap16# ::+      Word# -> Word#'+    template: |-+      // byteSwap16 begin~IF ~IW64 ~THEN+      assign ~RESULT = {~VAR[w][0][63:16],~VAR[w][0][7:0],~VAR[w][0][15:8]};~ELSE+      assign ~RESULT = {~VAR[w][0][31:16],~VAR[w][0][7:0],~VAR[w][0][15:8]};~FI+      // byteSwap16 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.byteSwap32#+    kind: Declaration+    type: 'byteSwap32# ::+      Word# -> Word#'+    template: |-+      // byteSwap32 begin~IF ~IW64 ~THEN+      assign ~RESULT = {~VAR[w][0][63:32],~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]};~ELSE+      assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]};~FI+      // byteSwap32 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.byteSwap64#+    kind: Declaration+    type: 'byteSwap64# ::+      Word# -> Word#'+    template: |-+      // byteSwap64 begin+      assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]+                       ,~VAR[w][0][39:32],~VAR[w][0][47:40],~VAR[w][0][55:48],~VAR[w][0][63:56]};+      // byteSwap64 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.byteSwap#+    kind: Declaration+    type: 'byteSwap# :: Word#+      -> Word#'+    template: |-+      // byteSwap begin~IF ~IW64 ~THEN+      assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]+                       ,~VAR[w][0][39:32],~VAR[w][0][47:40],~VAR[w][0][55:48],~VAR[w][0][63:56]};~ELSE+      assign ~RESULT = {~VAR[w][0][7:0],~VAR[w][0][15:8],~VAR[w][0][23:16],~VAR[w][0][31:24]};~FI+      // byteSwap end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.narrow8Int#+    kind: Declaration+    type: 'narrow8Int# ::+      Int# -> Int#'+    template: |-+      // narrow8Int begin+      assign ~RESULT = $signed(~VAR[i][0][7:0]);+      // narrow8Int end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.narrow16Int#+    kind: Declaration+    type: 'narrow16Int# ::+      Int# -> Int#'+    template: |-+      // narrow16Int begin+      assign ~RESULT = $signed(~VAR[i][0][15:0]);+      // narrow16Int end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.narrow32Int#+    kind: Declaration+    type: 'narrow32Int# ::+      Int# -> Int#'+    template: |-+      // narrow32Int begin+      assign ~RESULT = $signed(~VAR[i][0][31:0]);+      // narrow32Int end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.narrow8Word#+    kind: Declaration+    type: 'narrow8Int# ::+      Word# -> Word#'+    template: |-+      // narrow8Word begin+      assign ~RESULT = $unsigned(~VAR[w][0][7:0]);+      // narrow8Word end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.narrow16Word#+    kind: Declaration+    type: 'narrow16Word# ::+      Word# -> Word#'+    template: |-+      // narrow16Word begin+      assign ~RESULT = $unsigned(~VAR[w][0][15:0]);+      // narrow16Word end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.narrow32Word#+    kind: Declaration+    type: 'narrow32Int# ::+      Word# -> Word#'+    template: |-+      // narrow32Word begin+      assign ~RESULT = $unsigned(~VAR[w][0][31:0]);+      // narrow32Word end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.bitReverse#+    kind: Declaration+    type: 'bitReverse# ::+      Word# -> Word#'+    template: |-+      // bitReverse begin+      genvar ~GENSYM[i][0];+      ~GENERATE+      for (~SYM[0] = 0; ~SYM[0] < ~IF ~IW64 ~THEN 64 ~ELSE 32 ~FI; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse][2]+        assign ~RESULT[~SYM[0]] = ~VAR[x][0][~IF ~IW64 ~THEN 63 ~ELSE 31 ~FI-~SYM[0]];+      end+      ~ENDGENERATE+      // bitReverse end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.bitReverse8#+    kind: Declaration+    type: 'bitReverse8# ::+      Word# -> Word#'+    template: |-+      // bitReverse8 begin+      genvar ~GENSYM[i][0];+      ~GENERATE+      for (~SYM[0] = 0; ~SYM[0] < 8; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse8][2]+        assign ~RESULT[~SYM[0]] = ~VAR[x][0][7-~SYM[0]];+      end+      ~ENDGENERATE+      // bitReverse8 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.bitReverse16#+    kind: Declaration+    type: 'bitReverse16# ::+      Word# -> Word#'+    template: |-+      // bitReverse16 begin+      genvar ~GENSYM[i][0];+      ~GENERATE+      for (~SYM[0] = 0; ~SYM[0] < 16; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse16][2]+        assign ~RESULT[~SYM[0]] = ~VAR[x][0][15-~SYM[0]];+      end+      ~ENDGENERATE+      // bitReverse16 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.bitReverse32#+    kind: Declaration+    type: 'bitReverse32# ::+      Word# -> Word#'+    template: |-+      // bitReverse32 begin+      genvar ~GENSYM[i][0];+      ~GENERATE+      for (~SYM[0] = 0; ~SYM[0] < 32; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse32][2]+        assign ~RESULT[~SYM[0]] = ~VAR[x][0][31-~SYM[0]];+      end+      ~ENDGENERATE+      // bitReverse32 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.bitReverse64#+    kind: Declaration+    type: 'bitReverse64# ::+      Word# -> Word#'+    template: |-+      // bitReverse64 begin+      genvar ~GENSYM[i][0];+      ~GENERATE+      for (~SYM[0] = 0; ~SYM[0] < 64; ~SYM[0]=~SYM[0]+1) begin : ~GENSYM[bitReverse64][2]+        assign ~RESULT[~SYM[0]] = ~VAR[x][0][63-~SYM[0]];+      end+      ~ENDGENERATE+      // bitReverse64 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.quotInt#+    kind: Expression+    type: 'quotInt# :: Int#+      -> Int# -> Int#'+    template: ~ARG[0] / ~ARG[1]+- BlackBox:+    name: GHC.Prim.quotWord#+    kind: Expression+    type: 'quotWord# :: Word#+      -> Word# -> Word#'+    template: ~ARG[0] / ~ARG[1]+- BlackBox:+    name: GHC.Prim.int8ToInt#+    kind: Declaration+    template: |-+      // int8ToInt begin+      assign ~RESULT = ~ARG[0];+      // int8ToInt end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.intToInt8#+    kind: Declaration+    template: |-+      // intToInt8 begin+      assign ~RESULT = ~ARG[0];+      // intToInt8 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.negateInt8#+    kind: Expression+    template: -(~ARG[0])+- BlackBox:+    name: GHC.Prim.timesInt8#+    kind: Expression+    template: ~ARG[0] * ~ARG[1]+- BlackBox:+    name: GHC.Prim.quotInt8#+    kind: Expression+    template: ~ARG[0] / ~ARG[1]+- BlackBox:+    name: GHC.Prim.remInt8#+    kind: Expression+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftLInt8#+    kind: Expression+    template: ~ARG[0] <<< ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftRAInt8#+    kind: Expression+    template: ~ARG[0] >>> ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftRLInt8#+    kind: Expression+    template: ~ARG[0] >> ~ARG[1]+- BlackBox:+    name: GHC.Prim.int8ToWord8#+    kind: Expression+    template: $unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqInt8#+    kind: Expression+    template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.geInt8#+    kind: Expression+    template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.gtInt8#+    kind: Expression+    template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.leInt8#+    kind: Expression+    template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.ltInt8#+    kind: Expression+    template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.neInt8#+    kind: Expression+    template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.word8ToWord#+    kind: Declaration+    template: |-+      // word8ToWord begin+      assign ~RESULT = ~ARG[0];+      // word8ToWord end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.wordToWord8#+    kind: Declaration+    template: |-+      // wordToWord8 begin+      assign ~RESULT = ~ARG[0];+      // wordToWord8 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.timesWord8#+    kind: Expression+    template: ~ARG[0] * ~ARG[1]+- BlackBox:+    name: GHC.Prim.quotWord8#+    kind: Expression+    template: ~ARG[0] / ~ARG[1]+- BlackBox:+    name: GHC.Prim.remWord8#+    kind: Expression+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: GHC.Prim.andWord8#+    kind: Expression+    template: ~ARG[0] & ~ARG[1]+- BlackBox:+    name: GHC.Prim.orWord8#+    kind: Expression+    template: ~ARG[0] | ~ARG[1]+- BlackBox:+    name: GHC.Prim.xorWord8#+    kind: Expression+    template: ~ARG[0] ^ ~ARG[1]+- BlackBox:+    name: GHC.Prim.notWord8#+    kind: Expression+    template: ~ ~ARG[0]+- BlackBox:+    name: GHC.Prim.uncheckedShiftLWord8#+    kind: Expression+    template: ~ARG[0] << ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftRLWord8#+    kind: Expression+    template: ~ARG[0] >> ~ARG[1]+- BlackBox:+    name: GHC.Prim.word8ToInt8#+    kind: Expression+    template: $signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqWord8#+    kind: Expression+    template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.geWord8#+    kind: Expression+    template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.gtWord8#+    kind: Expression+    template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.leWord8#+    kind: Expression+    template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.ltWord8#+    kind: Expression+    template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.neWord8#+    kind: Expression+    template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.int16ToInt#+    kind: Declaration+    template: |-+      // int16ToInt begin+      assign ~RESULT = ~ARG[0];+      // int16ToInt end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.intToInt16#+    kind: Declaration+    template: |-+      // intToInt16 begin+      assign ~RESULT = ~ARG[0];+      // intToInt16 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.negateInt16#+    kind: Expression+    template: -(~ARG[0])+- BlackBox:+    name: GHC.Prim.timesInt16#+    kind: Expression+    template: ~ARG[0] * ~ARG[1]+- BlackBox:+    name: GHC.Prim.quotInt16#+    kind: Expression+    template: ~ARG[0] / ~ARG[1]+- BlackBox:+    name: GHC.Prim.remInt16#+    kind: Expression+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftLInt16#+    kind: Expression+    template: ~ARG[0] <<< ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftRAInt16#+    kind: Expression+    template: ~ARG[0] >>> ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftRLInt16#+    kind: Expression+    template: ~ARG[0] >> ~ARG[1]+- BlackBox:+    name: GHC.Prim.int16ToWord16#+    kind: Expression+    template: $unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqInt16#+    kind: Expression+    template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.geInt16#+    kind: Expression+    template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.gtInt16#+    kind: Expression+    template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.leInt16#+    kind: Expression+    template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.ltInt16#+    kind: Expression+    template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.neInt16#+    kind: Expression+    template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.word16ToWord#+    kind: Declaration+    template: |-+      // word16ToWord begin+      assign ~RESULT = ~ARG[0];+      // word16ToWord end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.wordToWord16#+    kind: Declaration+    template: |-+      // wordToWord16 begin+      assign ~RESULT = ~ARG[0];+      // wordToWord16 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.timesWord16#+    kind: Expression+    template: ~ARG[0] * ~ARG[1]+- BlackBox:+    name: GHC.Prim.quotWord16#+    kind: Expression+    template: ~ARG[0] / ~ARG[1]+- BlackBox:+    name: GHC.Prim.remWord16#+    kind: Expression+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: GHC.Prim.andWord16#+    kind: Expression+    template: ~ARG[0] & ~ARG[1]+- BlackBox:+    name: GHC.Prim.orWord16#+    kind: Expression+    template: ~ARG[0] | ~ARG[1]+- BlackBox:+    name: GHC.Prim.xorWord16#+    kind: Expression+    template: ~ARG[0] ^ ~ARG[1]+- BlackBox:+    name: GHC.Prim.notWord16#+    kind: Expression+    template: ~ ~ARG[0]+- BlackBox:+    name: GHC.Prim.uncheckedShiftLWord16#+    kind: Expression+    template: ~ARG[0] << ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftRLWord16#+    kind: Expression+    template: ~ARG[0] >> ~ARG[1]+- BlackBox:+    name: GHC.Prim.word16ToInt16#+    kind: Expression+    template: $signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqWord16#+    kind: Expression+    template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.geWord16#+    kind: Expression+    template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.gtWord16#+    kind: Expression+    template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.leWord16#+    kind: Expression+    template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.ltWord16#+    kind: Expression+    template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.neWord16#+    kind: Expression+    template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.int32ToInt#+    kind: Declaration+    template: |-+      // int32ToInt begin+      assign ~RESULT = ~ARG[0];+      // int32ToInt end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.intToInt32#+    kind: Declaration+    template: |-+      // intToInt32 begin+      assign ~RESULT = ~ARG[0];+      // intToInt32 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.negateInt32#+    kind: Expression+    template: -(~ARG[0])+- BlackBox:+    name: GHC.Prim.timesInt32#+    kind: Expression+    template: ~ARG[0] * ~ARG[1]+- BlackBox:+    name: GHC.Prim.quotInt32#+    kind: Expression+    template: ~ARG[0] / ~ARG[1]+- BlackBox:+    name: GHC.Prim.remInt32#+    kind: Expression+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftLInt32#+    kind: Expression+    template: ~ARG[0] <<< ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftRAInt32#+    kind: Expression+    template: ~ARG[0] >>> ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftRLInt32#+    kind: Expression+    template: ~ARG[0] >> ~ARG[1]+- BlackBox:+    name: GHC.Prim.int32ToWord32#+    kind: Expression+    template: $unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqInt32#+    kind: Expression+    template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.geInt32#+    kind: Expression+    template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.gtInt32#+    kind: Expression+    template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.leInt32#+    kind: Expression+    template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.ltInt32#+    kind: Expression+    template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.neInt32#+    kind: Expression+    template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.word32ToWord#+    kind: Declaration+    template: |-+      // word32ToWord begin+      assign ~RESULT = ~ARG[0];+      // word32ToWord end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.wordToWord32#+    kind: Declaration+    template: |-+      // wordToWord32 begin+      assign ~RESULT = ~ARG[0];+      // wordToWord32 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.timesWord32#+    kind: Expression+    template: ~ARG[0] * ~ARG[1]+- BlackBox:+    name: GHC.Prim.quotWord32#+    kind: Expression+    template: ~ARG[0] / ~ARG[1]+- BlackBox:+    name: GHC.Prim.remWord32#+    kind: Expression+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: GHC.Prim.andWord32#+    kind: Expression+    template: ~ARG[0] & ~ARG[1]+- BlackBox:+    name: GHC.Prim.orWord32#+    kind: Expression+    template: ~ARG[0] | ~ARG[1]+- BlackBox:+    name: GHC.Prim.xorWord32#+    kind: Expression+    template: ~ARG[0] ^ ~ARG[1]+- BlackBox:+    name: GHC.Prim.notWord32#+    kind: Expression+    template: ~ ~ARG[0]+- BlackBox:+    name: GHC.Prim.uncheckedShiftLWord32#+    kind: Expression+    template: ~ARG[0] << ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftRLWord32#+    kind: Expression+    template: ~ARG[0] >> ~ARG[1]+- BlackBox:+    name: GHC.Prim.word32ToInt32#+    kind: Expression+    template: $signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqWord32#+    kind: Expression+    template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.geWord32#+    kind: Expression+    template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.gtWord32#+    kind: Expression+    template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.leWord32#+    kind: Expression+    template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.ltWord32#+    kind: Expression+    template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.neWord32#+    kind: Expression+    template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.int64ToInt#+    kind: Declaration+    template: |-+      // int64ToInt begin+      assign ~RESULT = ~ARG[0];+      // int64ToInt end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.intToInt64#+    kind: Declaration+    template: |-+      // intToInt64 begin+      assign ~RESULT = ~ARG[0];+      // intToInt64 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.negateInt64#+    kind: Expression+    template: -(~ARG[0])+- BlackBox:+    name: GHC.Prim.timesInt64#+    kind: Expression+    template: ~ARG[0] * ~ARG[1]+- BlackBox:+    name: GHC.Prim.quotInt64#+    kind: Expression+    template: ~ARG[0] / ~ARG[1]+- BlackBox:+    name: GHC.Prim.remInt64#+    kind: Expression+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedIShiftL64#+    kind: Expression+    template: ~ARG[0] <<< ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedIShiftRA64#+    kind: Expression+    template: ~ARG[0] >>> ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedIShiftRL64#+    kind: Expression+    template: ~ARG[0] >> ~ARG[1]+- BlackBox:+    name: GHC.Prim.int64ToWord64#+    kind: Expression+    template: $unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqInt64#+    kind: Expression+    template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.geInt64#+    kind: Expression+    template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.gtInt64#+    kind: Expression+    template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.leInt64#+    kind: Expression+    template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.ltInt64#+    kind: Expression+    template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.neInt64#+    kind: Expression+    template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.word64ToWord#+    kind: Declaration+    template: |-+      // word64ToWord begin+      assign ~RESULT = ~ARG[0];+      // word64ToWord end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.wordToWord64#+    kind: Declaration+    template: |-+      // wordToWord64 begin+      assign ~RESULT = ~ARG[0];+      // wordToWord64 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.timesWord64#+    kind: Expression+    template: ~ARG[0] * ~ARG[1]+- BlackBox:+    name: GHC.Prim.quotWord64#+    kind: Expression+    template: ~ARG[0] / ~ARG[1]+- BlackBox:+    name: GHC.Prim.remWord64#+    kind: Expression+    template: ~ARG[0] % ~ARG[1]+- BlackBox:+    name: GHC.Prim.and64#+    kind: Expression+    template: ~ARG[0] & ~ARG[1]+- BlackBox:+    name: GHC.Prim.or64#+    kind: Expression+    template: ~ARG[0] | ~ARG[1]+- BlackBox:+    name: GHC.Prim.xor64#+    kind: Expression+    template: ~ARG[0] ^ ~ARG[1]+- BlackBox:+    name: GHC.Prim.not64#+    kind: Expression+    template: ~ ~ARG[0]+- BlackBox:+    name: GHC.Prim.uncheckedShiftL64#+    kind: Expression+    template: ~ARG[0] << ~ARG[1]+- BlackBox:+    name: GHC.Prim.uncheckedShiftRL64#+    kind: Expression+    template: ~ARG[0] >> ~ARG[1]+- BlackBox:+    name: GHC.Prim.word64ToInt64#+    kind: Expression+    template: $signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqWord64#+    kind: Expression+    template: "(~ARG[0] == ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.geWord64#+    kind: Expression+    template: "(~ARG[0] >= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.gtWord64#+    kind: Expression+    template: "(~ARG[0] > ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.leWord64#+    kind: Expression+    template: "(~ARG[0] <= ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.ltWord64#+    kind: Expression+    template: "(~ARG[0] < ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"+- BlackBox:+    name: GHC.Prim.neWord64#+    kind: Expression+    template: "(~ARG[0] != ~ARG[1]) ? ~SIZE[~TYPO]'sd1 : ~SIZE[~TYPO]'sd0"
+ prims/commonverilog/GHC_Word.primitives.yaml view
@@ -0,0 +1,16 @@+- BlackBoxHaskell:+    name: GHC.Word.W8#+    templateFunction: Clash.Primitives.GHC.Word.wordTF+    workInfo: Never+- BlackBoxHaskell:+    name: GHC.Word.W16#+    templateFunction: Clash.Primitives.GHC.Word.wordTF+    workInfo: Never+- BlackBoxHaskell:+    name: GHC.Word.W32#+    templateFunction: Clash.Primitives.GHC.Word.wordTF+    workInfo: Never+- BlackBoxHaskell:+    name: GHC.Word.W64#+    templateFunction: Clash.Primitives.GHC.Word.wordTF+    workInfo: Never
+ prims/systemverilog/Clash_Explicit_BlockRam.primitives.yaml view
@@ -0,0 +1,133 @@+- BlackBox:+    name: Clash.Explicit.BlockRam.blockRam#+    kind: Declaration+    type: |-+      blockRam#+        :: ( KnownDomain dom        ARG[0]+           , HasCallStack  --       ARG[1]+           , NFDataX a )   --       ARG[2]+        => Clock dom       -- clk,  ARG[3]+        -> Enable dom      -- en,   ARG[4]+        -> Vec n a         -- init, ARG[5]+        -> Signal dom Int  -- rd,   ARG[6]+        -> Signal dom Bool -- wren, ARG[7]+        -> Signal dom Int  -- wr,   ARG[8]+        -> Signal dom a    -- din,  ARG[9]+        -> Signal dom a+    template: |-+      // blockRam begin+      ~SIGD[~GENSYM[RAM][1]][5];+      logic [~SIZE[~TYP[9]]-1:0] ~GENSYM[~RESULT_q][2];+      initial begin+        ~SYM[1] = ~CONST[5];+      end~IF ~ISACTIVEENABLE[4] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_blockRam][3]~IF ~VIVADO ~THEN+        if (~ARG[4]) begin+          if (~ARG[7]) begin+            ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]];+          end+          ~SYM[2] <= ~SYM[1][~ARG[6]];+        end~ELSE+        if (~ARG[7] & ~ARG[4]) begin+          ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]];+        end+        if (~ARG[4]) begin+          ~SYM[2] <= ~SYM[1][~ARG[6]];+        end~FI+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3]+        if (~ARG[7]) begin+          ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]];+        end+        ~SYM[2] <= ~SYM[1][~ARG[6]];+      end~FI+      assign ~RESULT = ~FROMBV[~SYM[2]][~TYP[9]];+      // blockRam end+- BlackBox:+    name: Clash.Explicit.BlockRam.blockRamU#+    kind: Declaration+    type: |-+      blockRamU#+        :: ( KnownDomain dom        ARG[0]+           , HasCallStack  --       ARG[1]+           , NFDataX a )   --       ARG[2]+        => Clock dom       -- clk,  ARG[3]+        -> Enable dom      -- en,   ARG[4]+        -> SNat n          -- len,  ARG[5]+        -> Signal dom Int  -- rd,   ARG[6]+        -> Signal dom Bool -- wren, ARG[7]+        -> Signal dom Int  -- wr,   ARG[8]+        -> Signal dom a    -- din,  ARG[9]+        -> Signal dom a+    template: |-+      // blockRamU begin,+      ~TYPO ~GENSYM[~RESULT_RAM][1] [0:~LIT[5]-1];+      logic [~SIZE[~TYP[9]]-1:0] ~GENSYM[~RESULT_q][2];~IF ~ISACTIVEENABLE[4] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_blockRam][3]~IF ~VIVADO ~THEN+        if (~ARG[4]) begin+          if (~ARG[7]) begin+            ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]];+          end+          ~SYM[2] <= ~SYM[1][~ARG[6]];+        end~ELSE+        if (~ARG[7] & ~ARG[4]) begin+          ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]];+        end+        if (~ARG[4]) begin+          ~SYM[2] <= ~SYM[1][~ARG[6]];+        end~FI+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3]+        if (~ARG[7]) begin+          ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]];+        end+        ~SYM[2] <= ~SYM[1][~ARG[6]];+      end~FI+      assign ~RESULT = ~FROMBV[~SYM[2]][~TYP[9]];+      // blockRamU end+- BlackBox:+    name: Clash.Explicit.BlockRam.blockRam1#+    kind: Declaration+    type: |-+      blockRam1#+        :: ( KnownDomain dom        ARG[0]+           , HasCallStack  --       ARG[1]+           , NFDataX a )   --       ARG[2]+        => Clock dom       -- clk,  ARG[3]+        -> Enable dom      -- en,   ARG[4]+        -> SNat n          -- len,  ARG[5]+        -> a               -- init, ARG[6]+        -> Signal dom Int  -- rd,   ARG[7]+        -> Signal dom Bool -- wren, ARG[8]+        -> Signal dom Int  -- wr,   ARG[9]+        -> Signal dom a    -- din,  ARG[10]+        -> Signal dom a+    template: |-+      // blockRam1 begin,+      ~TYPO ~GENSYM[~RESULT_RAM][1] [0:~LIT[5]-1];+      logic [~SIZE[~TYP[10]]-1:0] ~GENSYM[~RESULT_q][2];+      initial begin+        ~SYM[1] = '{default: ~CONST[6]};+      end~IF ~ISACTIVEENABLE[4] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_blockRam][3]~IF ~VIVADO ~THEN+        if (~ARG[4]) begin+          if (~ARG[8]) begin+            ~SYM[1][~ARG[9]] <= ~TOBV[~ARG[10]][~TYP[10]];+          end+          ~SYM[2] <= ~SYM[1][~ARG[7]];+        end~ELSE+        if (~ARG[8] & ~ARG[4]) begin+          ~SYM[1][~ARG[9]] <= ~TOBV[~ARG[10]][~TYP[10]];+        end+        if (~ARG[4]) begin+          ~SYM[2] <= ~SYM[1][~ARG[7]];+        end~FI+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3]+        if (~ARG[8]) begin+          ~SYM[1][~ARG[9]] <= ~TOBV[~ARG[10]][~TYP[10]];+        end+        ~SYM[2] <= ~SYM[1][~ARG[7]];+      end~FI+      assign ~RESULT = ~FROMBV[~SYM[2]][~TYP[10]];+      // blockRam1 end
+ prims/systemverilog/Clash_Explicit_BlockRam_Blob.primitives.yaml view
@@ -0,0 +1,43 @@+- BlackBox:+    name: Clash.Explicit.BlockRam.Blob.blockRamBlob#+    kind: Declaration+    type: |-+      blockRamBlob#+        :: KnownDomain dom           --       ARG[0]+        => Clock dom                 -- clk,  ARG[1]+        -> Enable dom                -- en,   ARG[2]+        -> MemBlob n m               -- init, ARG[3]+        -> Signal dom Int            -- rd,   ARG[4]+        -> Signal dom Bool           -- wren, ARG[5]+        -> Signal dom Int            -- wr,   ARG[6]+        -> Signal dom (BitVector m)  -- din,  ARG[7]+        -> Signal dom (BitVector m)+    template: |-+      // blockRamBlob begin+      ~SIGD[~GENSYM[RAM][1]][3];+      logic [~SIZE[~TYP[7]]-1:0] ~GENSYM[~RESULT_q][2];+      initial begin+        ~SYM[1] = ~CONST[3];+      end~IF ~ISACTIVEENABLE[2] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~GENSYM[~COMPNAME_blockRam][3]~IF ~VIVADO ~THEN+        if (~ARG[2]) begin+          if (~ARG[5]) begin+            ~SYM[1][~ARG[6]] <= ~ARG[7];+          end+          ~SYM[2] <= ~SYM[1][~ARG[4]];+        end~ELSE+        if (~ARG[5] & ~ARG[2]) begin+          ~SYM[1][~ARG[6]] <= ~ARG[7];+        end+        if (~ARG[2]) begin+          ~SYM[2] <= ~SYM[1][~ARG[4]];+        end~FI+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~SYM[3]+        if (~ARG[5]) begin+          ~SYM[1][~ARG[6]] <= ~ARG[7];+        end+        ~SYM[2] <= ~SYM[1][~ARG[4]];+      end~FI+      assign ~RESULT = ~SYM[2];+      // blockRamBlob end
+ prims/systemverilog/Clash_Explicit_BlockRam_File.primitives.yaml view
@@ -0,0 +1,49 @@+- BlackBox:+    name: Clash.Explicit.BlockRam.File.blockRamFile#+    kind: Declaration+    type: |-+      blockRamFile#+        :: ( KnownDomain dom         --       ARG[0]+           , KnownNat m              --       ARG[1]+           , HasCallStack )          --       ARG[2]+        => Clock dom                 -- clk,  ARG[3]+        => Enable dom                -- en,   ARG[4]+        -> SNat n                    -- sz,   ARG[5]+        -> FilePath                  -- file, ARG[6]+        -> Signal dom Int            -- rd,   ARG[7]+        -> Signal dom Bool           -- wren, ARG[8]+        -> Signal dom Int            -- wr,   ARG[9]+        -> Signal dom (BitVector m)  -- din,  ARG[10]+        -> Signal dom (BitVector m)+    template: |-+      // blockRamFile begin+      ~SIGDO[~GENSYM[RAM][1]] [0:~LIT[5]-1];+      ~SIGD[~GENSYM[~RESULT_q][2]][10];++      initial begin+        $readmemb(~FILE[~LIT[6]],~SYM[1]);+      end+      ~IF ~ISACTIVEENABLE[4] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_blockRamFile][3]~IF ~VIVADO ~THEN+        if (~ARG[4]) begin+          if (~ARG[8]) begin+            ~SYM[1][~ARG[9]] <= ~ARG[10];+          end+          ~SYM[2] <= ~SYM[1][~ARG[7]];+        end~ELSE+        if (~ARG[8] & ~ARG[4]) begin+          ~SYM[1][~ARG[9]] <= ~ARG[10];+        end+        if (~ARG[4]) begin+          ~SYM[2] <= ~SYM[1][~ARG[7]];+        end~FI+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3]+        if (~ARG[8]) begin+          ~SYM[1][~ARG[9]] <= ~ARG[10];+        end+        ~SYM[2] <= ~SYM[1][~ARG[7]];+      end~FI++      assign ~RESULT = ~SYM[2];+      // blockRamFile end
+ prims/systemverilog/Clash_Explicit_DDR.primitives.yaml view
@@ -0,0 +1,92 @@+- BlackBox:+    name: Clash.Explicit.DDR.ddrIn#+    kind: Declaration+    type: |-+      ddrIn# :: forall a dom domDDR+              . HasCallStack             -- ARG[0]+             => NFDataX a                -- ARG[1]+             => KnownDomain dom          -- ARG[2]+             => KnownDomain domDDR       -- ARG[3]+             => DomPeriod ~ 2 * ...      -- ARG[4]+             => Clock dom                -- ARG[5]+             -> Reset dom                -- ARG[6]+             -> Enable dom               -- ARG[7]+             -> a                        -- ARG[8]+             -> a                        -- ARG[9]+             -> a                        -- ARG[10]+             -> Signal domDDR a          -- ARG[11]+             -> Signal dom (a,a)+    template: |-+      // ddrIn begin+      ~SIGD[~GENSYM[data_Pos][1]][11];+      ~SIGD[~GENSYM[data_Neg][2]][11];+      ~SIGD[~GENSYM[data_Neg_Latch][3]][11];+      always @(~IF~ACTIVEEDGE[Rising][2]~THENposedge~ELSEnegedge~FI ~ARG[5]~IF~ISSYNC[2]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[6])~FI begin : ~GENSYM[~COMPNAME_ddrIn_pos][6]+        if (~IF~ISACTIVEHIGH[2]~THEN~ARG[6]~ELSE! ~ARG[6]~FI) begin+          ~SYM[1] <= ~ARG[9];+        end else ~IF ~ISACTIVEENABLE[7] ~THEN if (~ARG[7]) ~ELSE ~FI begin+          ~SYM[1] <= ~ARG[11];+        end+      end+      always @(~IF~ACTIVEEDGE[Rising][2]~THENnegedge~ELSEposedge~FI ~ARG[5]~IF~ISSYNC[2]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[6])~FI begin : ~GENSYM[~COMPNAME_ddrIn_neg][7]+        if (~IF~ISACTIVEHIGH[2]~THEN~ARG[6]~ELSE! ~ARG[6]~FI) begin+          ~SYM[2] <= ~ARG[10];+        end else ~IF ~ISACTIVEENABLE[7] ~THEN if (~ARG[7]) ~ELSE ~FI begin+          ~SYM[2] <= ~ARG[11];+        end+      end+      always @(~IF~ACTIVEEDGE[Rising][2]~THENposedge~ELSEnegedge~FI ~ARG[5]~IF~ISSYNC[2]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[6])~FI begin : ~GENSYM[~COMPNAME_ddrIn_neg_latch][8]+        if (~IF~ISACTIVEHIGH[2]~THEN~ARG[6]~ELSE! ~ARG[6]~FI) begin+          ~SYM[3] <= ~ARG[8];+        end else ~IF ~ISACTIVEENABLE[7] ~THEN if (~ARG[7]) ~ELSE ~FI begin+          ~SYM[3] <= ~SYM[2];+        end+      end++      assign ~RESULT = {~SYM[3], ~SYM[1]};+      // ddrIn end+- BlackBox:+    name: Clash.Explicit.DDR.ddrOut#+    kind: Declaration+    outputUsage: Blocking+    type: |-+      ddrOut# :: forall a dom domDDR+               . HasCallStack                 -- ARG[0]+              => NFDataX a                    -- ARG[1]+              => KnownDomain dom              -- ARG[2]+              => KnownDomain domDDR           -- ARG[3]+              => DomPeriod ~ 2 * ...          -- ARG[4]+              => Clock dom                    -- ARG[5]+              -> Reset dom                    -- ARG[6]+              -> Enable dom                   -- ARG[7]+              -> a                            -- ARG[8]+              -> Signal dom a                 -- ARG[9]+              -> Signal dom a                 -- ARG[10]+              -> Signal domDDR a+    template: |-+      // ddrOut begin+      ~SIGD[~GENSYM[data_Pos][1]][8];+      ~SIGD[~GENSYM[data_Neg][2]][8];+      always @(~IF~ACTIVEEDGE[Rising][2]~THENposedge~ELSEnegedge~FI ~ARG[5]~IF~ISSYNC[2]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[6])~FI begin : ~GENSYM[~COMPNAME_ddrOut_pos][5]+        if (~IF~ISACTIVEHIGH[2]~THEN~ARG[6]~ELSE! ~ARG[6]~FI) begin+          ~SYM[1] <= ~ARG[8];+        end else ~IF ~ISACTIVEENABLE[7] ~THEN if (~ARG[7]) ~ELSE ~FI begin+          ~SYM[1] <= ~ARG[9];+        end+      end+      always @(~IF~ACTIVEEDGE[Rising][2]~THENposedge~ELSEnegedge~FI ~ARG[5]~IF~ISSYNC[2]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[6])~FI begin : ~GENSYM[~COMPNAME_ddrOut_neg][6]+        if (~IF~ISACTIVEHIGH[2]~THEN~ARG[6]~ELSE! ~ARG[6]~FI) begin+          ~SYM[2] <= ~ARG[8];+        end else ~IF ~ISACTIVEENABLE[7] ~THEN if (~ARG[7]) ~ELSE ~FI begin+          ~SYM[2] <= ~ARG[10];+        end+      end++      always @(*) begin+        if (~ARG[5]) begin+          ~RESULT = ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[1]~ELSE~SYM[2]~FI;+        end else begin+          ~RESULT = ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[2]~ELSE~SYM[1]~FI;+        end+      end+      // ddrOut end
+ prims/systemverilog/Clash_Explicit_RAM.primitives.yaml view
@@ -0,0 +1,29 @@+- BlackBox:+    name: Clash.Explicit.RAM.asyncRam#+    kind: Declaration+    type: |-+      asyncRam#+        :: ( HasCallStack      --         ARG[0]+           , KnownDomain wdom  --         ARG[1]+           , KnownDomain rdom  --         ARG[2]+           , NFDataX a )       --         ARG[3]+        => Clock wdom          -- ^ wclk, ARG[4]+        -> Clock rdom          -- ^ rclk, ARG[5]+        -> Enable wdom         -- ^ wen,  ARG[6]+        -> SNat n              -- ^ sz,   ARG[7]+        -> Signal rdom Int     -- ^ rd,   ARG[8]+        -> Signal wdom Bool    -- ^ en,   ARG[9]+        -> Signal wdom Int     -- ^ wr,   ARG[10]+        -> Signal wdom a       -- ^ din,  ARG[11]+        -> Signal rdom a+    template: |-+      // asyncRam begin+      logic [~SIZE[~TYP[11]]-1:0] ~GENSYM[RAM][0] [0:~LIT[7]-1];+      always @(~IF~ACTIVEEDGE[Rising][1]~THENposedge~ELSEnegedge~FI ~ARG[4]) begin : ~GENSYM[~COMPNAME_Ram][1]+        if (~IF ~ISACTIVEENABLE[6] ~THEN ~ARG[6] & ~ELSE ~FI ~ARG[9]) begin+          ~SYM[0][~ARG[10]] <= ~TOBV[~ARG[11]][~TYP[11]];+        end+      end++      assign ~RESULT = ~FROMBV[~SYM[0][\~ARG[8]\]][~TYPO];+      // asyncRam end
+ prims/systemverilog/Clash_Explicit_ROM.primitives.yaml view
@@ -0,0 +1,29 @@+- BlackBox:+    name: Clash.Explicit.ROM.rom#+    kind: Declaration+    type: |-+      rom# :: ( KnownDomain dom        ARG[0]+               , KnownNat n    --       ARG[1]+               , NFDataX a )   --       ARG[2]+            => Clock dom       -- clk,  ARG[3]+            => Enable dom      -- en,   ARG[4]+            -> Vec n a         -- init, ARG[5]+            -> Signal dom Int  -- rd,   ARG[6]+            -> Signal dom a+    template: |-+      // rom begin+      ~SIGD[~GENSYM[ROM][1]][5];+      assign ~SYM[1] = ~LIT[5];++      logic [~SIZE[~TYPO]-1:0] ~GENSYM[~RESULT_q][2];~IF ~ISACTIVEENABLE[4] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_rom][3]+        if (~ARG[4]) begin+          ~SYM[2] <= ~SYM[1][~ARG[6]];+        end+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3]+        ~SYM[2] <= ~SYM[1][~ARG[6]];+      end~FI++      assign ~RESULT = ~FROMBV[~SYM[2]][~TYPO];+      // rom end
+ prims/systemverilog/Clash_Explicit_ROM_Blob.primitives.yaml view
@@ -0,0 +1,28 @@+- BlackBox:+    name: Clash.Explicit.ROM.Blob.romBlob#+    kind: Declaration+    type: |-+      romBlob#+        :: KnownDomain dom  --       ARG[0]+        => Clock dom        -- clk,  ARG[1]+        -> Enable dom       -- en,   ARG[2]+        -> MemBlob n m      -- init, ARG[3]+        -> Signal dom Int   -- rd,   ARG[4]+        -> Signal dom (BitVector m)+    template: |-+      // romBlob begin+      ~SIGD[~GENSYM[ROM][1]][3];+      assign ~SYM[1] = ~CONST[3];++      logic [~SIZE[~TYPO]-1:0] ~GENSYM[~RESULT_q][2];~IF ~ISACTIVEENABLE[2] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~GENSYM[~COMPNAME_rom][3]+        if (~ARG[2]) begin+          ~SYM[2] <= ~SYM[1][~ARG[4]];+        end+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~SYM[3]+        ~SYM[2] <= ~SYM[1][~ARG[4]];+      end~FI++      assign ~RESULT = ~SYM[2];+      // rom end
+ prims/systemverilog/Clash_Explicit_ROM_File.primitives.yaml view
@@ -0,0 +1,32 @@+- BlackBox:+    name: Clash.Explicit.ROM.File.romFile#+    kind: Declaration+    type: |-+      romFile# :: ( KnownNat m             --       ARG[0]+                   , KnownDomain dom )      --       ARG[1]+                => Clock dom                -- clk,  ARG[2]+                -> Enable dom               -- en,   ARG[3]+                -> SNat n                   -- sz,   ARG[4]+                -> FilePath                 -- file, ARG[5]+                -> Signal dom Int           -- rd,   ARG[6]+                -> Signal dom (BitVector m)+    template: |-+      // romFile begin+      ~SIGDO[~GENSYM[ROM][0]] [0:~LIT[4]-1];++      initial begin+        $readmemb(~FILE[~LIT[5]],~SYM[0]);+      end++      ~SIGDO[~GENSYM[~RESULT_q][1]];~IF ~ISACTIVEENABLE[3] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][1]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~GENSYM[~COMPNAME_romFile][2]+        if (~ARG[3]) begin+          ~SYM[1] <= ~SYM[0][~ARG[6]];+        end+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][1]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~SYM[2]+        ~SYM[1] <= ~SYM[0][~ARG[6]];+      end~FI++      assign ~RESULT = ~SYM[1];+      // romFile end
+ prims/systemverilog/Clash_Explicit_Testbench.primitives.yaml view
@@ -0,0 +1,61 @@+- BlackBox:+    name: Clash.Explicit.Testbench.assert+    kind: Declaration+    type: |-+      assert+        :: (KnownDomain dom, Eq a, ShowX a)      -- (ARG[0], ARG[1], ARG[2])+        => Clock dom                             -- ARG[3]+        -> Reset dom                             -- ARG[4]+        -> String                                -- ARG[5]+        -> Signal dom a                          -- Checked value  (ARG[6])+        -> Signal dom a                          -- Expected value (ARG[7])+        -> Signal dom b                          -- Return valued  (ARG[8])+        -> Signal dom b+    template: |-+      // assert begin+      // pragma translate_off+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin+        if (~ARG[6] !== ~ARG[7]) begin+          $display("@%0tns: %s, expected: %b, actual: %b", $time, ~LIT[5], ~TOBV[~ARG[7]][~TYP[7]], ~TOBV[~ARG[6]][~TYP[6]]);+          `ifdef VERILATOR+            $c("std::exit(1);");+          `endif+          $stop;+        end+      end+      // pragma translate_on+      assign ~RESULT = ~ARG[8];+      // assert end+- BlackBox:+    name: Clash.Explicit.Testbench.assertBitVector+    kind: Declaration+    type: |-+      assertBitVector+        :: ( KnownDomain dom        --                 ARG[0]+           , KnownNat n )           --                 ARG[1]+        => Clock dom                --                 ARG[2]+        -> Reset dom                --                 ARG[3]+        -> String                   --                 ARG[4]+        -> Signal dom (BitVector n) -- Checked value  (ARG[5])+        -> Signal dom (BitVector n) -- Expected value (ARG[6])+        -> Signal dom b             -- Return valued  (ARG[7])+        -> Signal dom b+    template: |-+      // assertBitVector begin+      // pragma translate_off+      wire ~TYP[6] ~GENSYM[maskXor][0]  = ~ARG[6] ^ ~ARG[6];+      wire ~TYP[6] ~GENSYM[checked][1]  = ~ARG[5] ^ ~SYM[0];+      wire ~TYP[6] ~GENSYM[expected][2] = ~ARG[6] ^ ~SYM[0];++      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin+        if (~SYM[1] !== ~SYM[2]) begin+          $display("@%0tns: %s, expected: %b, actual: %b", $time, ~LIT[4], ~TOBV[~ARG[6]][~TYP[6]], ~TOBV[~ARG[5]][~TYP[5]]);+          `ifdef VERILATOR+            $c("std::exit(1);");+          `endif+          $stop;+        end+      end+      // pragma translate_on+      assign ~RESULT = ~ARG[7];+      // assertBitVector end
+ prims/systemverilog/Clash_Intel_DDR.primitives.yaml view
@@ -0,0 +1,49 @@+- BlackBox:+    name: Clash.Intel.DDR.altddioIn#+    kind: Declaration+    libraries:+    - altera_mf+    type: |-+      altddioIn#+        :: forall deviceFamily n dom domDDR+         . HasCallStack                 -- ARG[0]+        => KnownDomain dom              -- ARG[1]+        => KnownDomain domDDR           -- ARG[2]+        => DomPeriod ~ 2 * ...          -- ARG[3]+        => DomEdge ~ Rising             -- ARG[4]+        => KnownNat n                   -- ARG[5]+        => SSymbol deviceFamily         -- ARG[6]+        -> Clock dom                    -- ARG[7]+        -> Reset dom                    -- ARG[8]+        -> Enable dom                   -- ARG[9]+        -> Signal domDDR (BitVector n)  -- ARG[10]+        -> Signal dom (BitVector n, BitVector n)+    template: |-+      // altddioIn begin+      ~SIGD[~GENSYM[dataout_l][1]][10];+      ~SIGD[~GENSYM[dataout_h][2]][10];++      altddio_in+        #(+          .intended_device_family (~LIT[6]),+          .invert_input_clocks ("OFF"),+          .lpm_hint ("UNUSED"),+          .lpm_type ("altddio_in"),+          .power_up_high ("OFF"),+          .width (~SIZE[~TYP[10]])+        )+        ~GENSYM[~COMPNAME_ALTDDIO_IN][7] (~IF ~ISSYNC[1] ~THEN+          .sclr (~ARG[8]),+          .aclr (1'b0),~ELSE+          .aclr (~ARG[8]),+          .sclr (1'b0),~FI+          .datain (~ARG[10]),+          .inclock (~ARG[7]),+          .inclocken (~IF ~ISACTIVEENABLE[9] ~THEN~ARG[9]~ELSE1'b1~FI),+          .dataout_h (~SYM[2]),+          .dataout_l (~SYM[1]),+          .aset (1'b0),+          .sset (1'b0)+        );+      assign ~RESULT = {~SYM[1],~SYM[2]};+      // altddioIn end
+ prims/systemverilog/Clash_Prelude_ROM.primitives.yaml view
@@ -0,0 +1,17 @@+- BlackBox:+    name: Clash.Prelude.ROM.asyncRom#+    kind: Declaration+    type: |-+      asyncRom#+        :: ( KnownNat n  -- ARG[0]+           , NFDataX a)  -- ARG[1]+        => Vec n a       -- ARG[2]+        -> Int           -- ARG[3]+        -> a+    template: |-+      // asyncRom begin+      ~SIGD[~GENSYM[ROM][0]][2];+      assign ~SYM[0] = ~CONST[2];++      assign ~RESULT = ~FROMBV[~SYM[0][\~ARG[3]\]][~TYPO];+      // asyncRom end
+ prims/systemverilog/Clash_Prelude_ROM_Blob.primitives.yaml view
@@ -0,0 +1,15 @@+- BlackBox:+    name: Clash.Prelude.ROM.Blob.asyncRomBlob#+    kind: Declaration+    type: |-+      asyncRomBlob#+        :: MemBlob n m  -- ARG[0]+        -> Int          -- ARG[1]+        -> BitVector m+    template: |-+      // asyncRomBlob begin+      ~SIGD[~GENSYM[ROM][0]][0];+      assign ~SYM[0] = ~CONST[0];++      assign ~RESULT = ~SYM[0][~ARG[1]];+      // asyncRomBlob end
+ prims/systemverilog/Clash_Prelude_ROM_File.primitives.yaml view
@@ -0,0 +1,19 @@+- BlackBox:+    name: Clash.Prelude.ROM.File.asyncRomFile#+    kind: Declaration+    type: |-+      asyncRomFile :: KnownNat m -- ARG[0]+                    => SNat n     -- sz,   ARG[1]+                    -> FilePath   -- file, ARG[2]+                    -> Int        -- rd,   ARG[3]+                    -> BitVector m+    template: |-+      // asyncRomFile begin+      ~SIGDO[~GENSYM[ROM][0]] [0:~LIT[1]-1];++      initial begin+        $readmemb(~FILE[~LIT[2]],~SYM[0]);+      end++      assign ~RESULT = ~SYM[0][~ARG[3]];+      // asyncRomFile end
+ prims/systemverilog/Clash_Signal_BiSignal.primitives.yaml view
@@ -0,0 +1,30 @@+- BlackBox:+    name: Clash.Signal.BiSignal.writeToBiSignal#+    kind: Declaration+    type: |-+      writeToBiSignal#+        :: HasCallStack                   -- ARG[0]+        => BiSignalIn ds d n              -- ARG[1]+        -> Signal d (Maybe (BitVector n)) -- ARG[2]+        -> Signal d Bool                  -- ARG[3]+        -> Signal d (BitVector n)         -- ARG[4]+        -> BiSignalOut ds d n+    renderVoid: RenderVoid+    template: |-+      // writeToBiSignal# begin+      assign ~ARG[1] = (~ARG[3] == 1'b1) ? ~ARG[4] : {~SIZE[~TYP[1]] {1'bz}};+      // writeToBiSignal# end+- BlackBox:+    name: Clash.Signal.BiSignal.readFromBiSignal#+    kind: Declaration+    type: |-+      readFromBiSignal#+        :: ( HasCallStack    -- ARG[0]+           , KnownNat n)     -- ARG[1]+        => BiSignalIn ds d n -- ARG[2]+        -> Signal d (BitVector n)+    template: |-+      // readFromBiSignal begin+      assign ~RESULT = ~ARG[2];+      // readFromBiSignal end+    workInfo: Never
+ prims/systemverilog/Clash_Signal_Internal.primitives.yaml view
@@ -0,0 +1,178 @@+- BlackBox:+    name: Clash.Signal.Internal.delay#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      delay#+        :: ( KnownDomain dom        -- ARG[0]+           , NFDataX a )            -- ARG[1]+        => Clock dom                -- ARG[2]+        -> Enable dom               -- ARG[3]+        -> a                        -- ARG[4]+        -> Signal clk a             -- ARG[5]+        -> Signal clk a+    resultInit:+      template: ~IF~ISINITDEFINED[0]~THEN~CONST[4]~ELSE~FI+    resultName:+      template: ~CTXNAME+    template: |-+      // delay begin~IF ~ISACTIVEENABLE[3] ~THEN+      always_ff @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~GENSYM[~RESULT_delay][1]+        if (~ARG[3]) begin+          ~RESULT <= ~ARG[5];+        end+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~SYM[1]+        ~RESULT <= ~ARG[5];+      end~FI+      // delay end+- BlackBox:+    name: Clash.Signal.Internal.asyncRegister#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      asyncRegister#+        :: ( KnownDomain dom        -- ARG[0]+           , NFDataX a )            -- ARG[1]+        => Clock dom                -- ARG[2]+        -> Reset dom                -- ARG[3]+        -> Enable dom               -- ARG[4]+        -> a                        -- ARG[5] (powerup value)+        -> a                        -- ARG[6] (reset value)+        -> Signal clk a             -- ARG[7]+        -> Signal clk a+    resultInit:+      template: ~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI+    resultName:+      template: ~CTXNAME+    template: |-+      // async register begin+      always_ff @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]~IF ~ISUNDEFINED[6] ~THEN ~ELSE or ~IF ~ISACTIVEHIGH[0] ~THEN posedge ~ELSE negedge ~FI ~VAR[rst][3]~FI) begin : ~GENSYM[~RESULT_register][1]+        ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI~VAR[rst][3]) begin+          ~RESULT <= ~CONST[6];+        end else ~FI~IF ~ISACTIVEENABLE[4] ~THEN if (~ARG[4]) ~ELSE ~FI begin+          ~RESULT <= ~ARG[7];+        end+      end+      // async register end+- BlackBox:+    name: Clash.Signal.Internal.register#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      register#+        :: ( KnownDomain dom        -- ARG[0]+           , NFDataX a )            -- ARG[1]+        => Clock dom                -- ARG[2]+        -> Reset dom                -- ARG[3]+        -> Enable dom               -- ARG[4]+        -> a                        -- ARG[5] (powerup value)+        -> a                        -- ARG[6] (reset value)+        -> Signal clk a             -- ARG[7]+        -> Signal clk a+    resultInit:+      template: ~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI+    resultName:+      template: ~CTXNAME+    template: |-+      // register begin+      always_ff @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]~IF ~ISSYNC[0] ~THEN ~ELSE~IF ~ISUNDEFINED[6] ~THEN ~ELSE or ~IF ~ISACTIVEHIGH[0] ~THEN posedge ~ELSE negedge ~FI ~VAR[rst][3]~FI~FI) begin : ~GENSYM[~RESULT_register][1]+        ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI~VAR[rst][3]) begin+          ~RESULT <= ~CONST[6];+        end else ~FI~IF ~ISACTIVEENABLE[4] ~THEN if (~ARG[4]) ~ELSE ~FI begin+          ~RESULT <= ~ARG[7];+        end+      end+      // register end+- BlackBox:+    name: Clash.Signal.Internal.tbClockGen+    kind: Declaration+    outputUsage: Blocking+    type: |-+      tbClockGen+        :: KnownDomain dom     -- ARG[0]+        => Signal dom Bool     -- ARG[1]+        -> Clock dom+    template: |-+      // ~IF~ISACTIVEENABLE[1]~THENtbClockGen~ELSEclockGen~FI begin+      // pragma translate_off+      // 1 = 0.1ps+      localparam ~GENSYM[half_period][0] = (~PERIOD[0]0 / 2);+      always begin+        ~RESULT = ~IF~ACTIVEEDGE[Rising][0]~THEN 0 ~ELSE 1 ~FI;+        #~LONGESTPERIOD0 forever begin+          ~IF~ISACTIVEENABLE[1]~THEN+          if (~ ~ARG[1]) begin+            `ifdef VERILATOR+              $c("std::exit(0);");+            `endif+            $finish;+          end+          ~ELSE~FI+          ~RESULT = ~ ~RESULT;+          #~SYM[0];+          ~RESULT = ~ ~RESULT;+          #~SYM[0];+        end+      end+      // pragma translate_on+      // tbClockGen end+    warning: Clash.Signal.Internal.tbClockGen is not synthesizable!+    workInfo: Always+- BlackBox:+    name: Clash.Signal.Internal.tbDynamicClockGen+    kind: Declaration+    outputUsage: Blocking+    type: |-+      tbDynamicClockGen+        :: KnownDomain dom     -- ARG[0]+        -> Signal dom Natural  -- ARG[1]+        -> Signal dom Bool     -- ARG[2]+        => Clock dom+    template: |-+      // tbDynamicClockGen begin+      // pragma translate_off+      // 1 = 0.1ps+      time ~GENSYM[half_period][0];+      always begin+        ~RESULT = ~IF~ACTIVEEDGE[Rising][0]~THEN 0 ~ELSE 1 ~FI;+        #~LONGESTPERIOD0 forever begin+          ~IF~ISACTIVEENABLE[2]~THEN+          if (~ ~ARG[2]) begin+            `ifdef VERILATOR+              $c("std::exit(0);");+            `endif+            $finish;+          end+          ~ELSE~FI+          // 1 = 0.1ps+          ~SYM[0] = (~VAR[periods][1] / 2);++          ~RESULT = ~ ~RESULT;+          #(~SYM[0] * 0.01);+          ~RESULT = ~ ~RESULT;+          #(~SYM[0] * 0.01);+        end+      end+      // pragma translate_on+      // tbDynamicClockGen end+    warning: Clash.Signal.Internal.tbDynamicClockGen is not synthesizable!+    workInfo: Always+- BlackBox:+    name: Clash.Signal.Internal.resetGenN+    kind: Declaration+    outputUsage: Blocking+    type: 'resetGenN :: (KnownDomain+      dom, 1 <= n) => SNat n -> Reset dom'+    template: |-+      // resetGen begin+      // pragma translate_off+      localparam ~GENSYM[reset_period][0] = ~LONGESTPERIOD0 - 10 + (~LIT[2] * ~PERIOD[0]0);+      initial begin+        #1 ~RESULT = ~IF ~ISACTIVEHIGH[0] ~THEN 1 ~ELSE 0 ~FI;+        #~SYM[0] ~RESULT = ~IF ~ISACTIVEHIGH[0] ~THEN 0 ~ELSE 1 ~FI;+      end+      // pragma translate_on+      // resetGen end+    warning: Clash.Signal.Internal.resetGenN can not be synthesized to hardware!+    workInfo: Always
+ prims/systemverilog/Clash_Sized_Internal_BitVector.primitives.yaml view
@@ -0,0 +1,72 @@+- BlackBox:+    name: Clash.Sized.Internal.BitVector.replaceBit#+    kind: Declaration+    outputUsage: Blocking+    type: |-+      replaceBit# :: KnownNat n  -- ARG[0]+                   => BitVector n -- ARG[1]+                   -> Int         -- ARG[2]+                   -> Bit         -- ARG[3]+                   -> BitVector n+    template: |-+      // replaceBit start+      always_comb begin+        ~RESULT = ~ARG[1];+        ~RESULT[~ARG[2]] = ~ARG[3];+      end+      // replaceBit end+- BlackBox:+    name: Clash.Sized.Internal.BitVector.setSlice#+    kind: Declaration+    outputUsage: Blocking+    type: |-+      setSlice# :: SNat (m + 1 + i)+                 -> BitVector (m + 1 + i) -- ARG[1]+                 -> SNat m                -- ARG[2]+                 -> SNat n                -- ARG[3]+                 -> BitVector (m + 1 - n) -- ARG[4]+                 -> BitVector (m + 1 + i)+    template: |-+      // setSlice begin+      always_comb begin+        ~RESULT = ~ARG[1];+        ~RESULT[~LIT[2] : ~LIT[3]] = ~ARG[4];+      end+      // setSlice end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.split#+    kind: Declaration+    type: |-+      split# :: KnownNat n        -- ARG[0]+              => BitVector (m + n) -- ARG[1]+              -> (BitVector m, BitVector n)+    template: |-+      // split begin+      assign ~RESULT = { ~VAR[bv][1][$high(~VAR[bv][1]) : ~LIT[0]]+                       , ~VAR[bv][1][(~LIT[0]-1) : 0]+                       };+      // split end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.rotateL#+    kind: Declaration+    type: 'rotateL# :: KnownNat+      n => BitVector n -> Int -> BitVector n'+    template: |-+      // rotateL begin+      logic [2*~SIZE[~TYPO]-1:0] ~GENSYM[bv][0];+      assign ~SYM[0] = {~ARG[1],~ARG[1]} << (~ARG[2] % ~SIZE[~TYPO]);+      assign ~RESULT = ~SYM[0][2*~SIZE[~TYPO]-1 : ~SIZE[~TYPO]];+      // rotateL end+- BlackBox:+    name: Clash.Sized.Internal.BitVector.rotateR#+    kind: Declaration+    type: 'rotateR# :: KnownNat+      n => BitVector n -> Int -> BitVector n'+    template: |-+      // rotateR begin+      logic [2*~SIZE[~TYPO]-1:0] ~GENSYM[bv][0];+      assign ~SYM[0] = {~ARG[1],~ARG[1]} >> (~ARG[2] % ~SIZE[~TYPO]);+      assign ~RESULT = ~SYM[0][~SIZE[~TYPO]-1 : 0];+      // rotateR end
+ prims/systemverilog/Clash_Sized_Internal_Signed.primitives.yaml view
@@ -0,0 +1,64 @@+- BlackBox:+    name: Clash.Sized.Internal.Signed.div#+    kind: Declaration+    type: 'div# :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: |-+      // divSigned begin+      logic ~GENSYM[resultPos][1];+      logic ~GENSYM[dividerNeg][2];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6];++      assign ~SYM[1] = ~VAR[dividend][1][~SIZE[~TYPO]-1] == ~VAR[divider][2][~SIZE[~TYPO]-1];+      assign ~SYM[2] = ~VAR[divider][2][~SIZE[~TYPO]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][1][~SIZE[~TYPO]-1]},~VAR[dividend][1]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][2][~SIZE[~TYPO]-1]} ,~VAR[divider][2]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]);+      // divSigned end+- BlackBox:+    name: Clash.Sized.Internal.Signed.mod#+    kind: Declaration+    type: 'mod# :: Signed+      n -> Signed n -> Signed n'+    template: |-+      // modSigned begin+      // remainder+      ~SIGD[~GENSYM[rem_res][0]][0];+      assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1];++      // modulo+      assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ?+                       ~SYM[0] :+                       (~SYM[0] == ~SIZE[~TYPO]'sd0 ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]);+      // modSigned end+- BlackBox:+    name: Clash.Sized.Internal.Signed.rotateL#+    kind: Declaration+    type: 'rotateL# :: KnownNat+      n => Signed n -> Int -> Signed n'+    template: |-+      // rotateL begin+      logic [2*~SIZE[~TYPO]-1:0] ~GENSYM[s][0];+      assign ~SYM[0] = {~ARG[1],~ARG[1]} << (~ARG[2] % ~SIZE[~TYPO]);+      assign ~RESULT = $signed(~SYM[0][2*~SIZE[~TYPO]-1 : ~SIZE[~TYPO]]);+      // rotateL end+- BlackBox:+    name: Clash.Sized.Internal.Signed.rotateR#+    kind: Declaration+    type: 'rotateR# :: KnownNat+      n => Signed n -> Int -> Signed n'+    template: |-+      // rotateR begin+      logic [2*~SIZE[~TYPO]-1:0] ~GENSYM[s][0];+      assign ~SYM[0] = {~ARG[1],~ARG[1]} >> (~ARG[2] % ~SIZE[~TYPO]);+      assign ~RESULT = $signed(~SYM[0][~SIZE[~TYPO]-1 : 0]);+      // rotateR end
+ prims/systemverilog/Clash_Sized_Internal_Unsigned.primitives.yaml view
@@ -0,0 +1,22 @@+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.rotateL#+    kind: Declaration+    type: 'rotateL# :: KnownNat+      n => Unsigned n -> Int -> Unsigned n'+    template: |-+      // rotateL begin+      logic [2*~SIZE[~TYPO]-1:0] ~GENSYM[u][0];+      assign ~SYM[0] = {~ARG[1],~ARG[1]} << (~ARG[2] % ~SIZE[~TYPO]);+      assign ~RESULT = ~SYM[0][2*~SIZE[~TYPO]-1 : ~SIZE[~TYPO]];+      // rotateL end+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.rotateR#+    kind: Declaration+    type: 'rotateR# :: KnownNat+      n => Unsigned n -> Int -> Unsigned n'+    template: |-+      // rotateR begin+      logic [2*~SIZE[~TYPO]-1:0] ~GENSYM[u][0];+      assign ~SYM[0] = {~ARG[1],~ARG[1]} >> (~ARG[2] % ~SIZE[~TYPO]);+      assign ~RESULT = ~SYM[0][~SIZE[~TYPO]-1 : 0];+      // rotateR end
+ prims/systemverilog/Clash_Sized_RTree.primitives.yaml view
@@ -0,0 +1,21 @@+- BlackBox:+    name: Clash.Sized.RTree.treplicate+    kind: Expression+    type: 'replicate :: SNat+      d -> a -> RTree d a'+    template: '''{(2**~LIT[0]) {~TOBV[~ARG[1]][~TYP[1]]}}'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.RTree.textract+    kind: Expression+    type: 'textract :: RTree+      0 a -> a'+    template: ~FROMBV[~VAR[tree][0][\0\]][~TYPO]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.RTree.tsplit+    kind: Expression+    type: 'tsplit:: RTree+      (d+1) a -> (RTree d a,RTree d a)'+    template: ~TOBV[~VAR[tree][0]][~TYP[0]]+    workInfo: Never
+ prims/systemverilog/Clash_Sized_Vector.primitives.yaml view
@@ -0,0 +1,331 @@+- BlackBox:+    name: Clash.Sized.Vector.head+    kind: Expression+    type: 'head :: Vec (n + 1) a -> a'+    template: ~FROMBV[~VAR[vec][0][\0\]][~TYPO]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.tail+    kind: Expression+    type: 'tail :: Vec (n + 1) a -> Vec n a'+    template: '~VAR[vec][0][1 : $high(~VAR[vec][0])]'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.last+    kind: Expression+    type: Vec (n + 1) a -> a+    template: ~FROMBV[~VAR[vec][0][\$high(~VAR[vec][0])\]][~TYPO]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.init+    kind: Expression+    type: Vec (n + 1) a -> Vec n a+    template: '~VAR[vec][0][0 : $high(~VAR[vec][0]) - 1]'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.select+    kind: Declaration+    type: |-+      select :: (CmpNat (i + s) (s * n) ~ GT) -- ARG[0]+              => SNat f                        -- ARG[1]+              -> SNat s                        -- ARG[2]+              -> SNat n                        -- ARG[3]+              -> Vec i a                       -- ARG[4]+              -> Vec n a+    template: |-+      // select begin+      genvar ~GENSYM[n][1];+      ~GENERATE+        for (~SYM[1]=0; ~SYM[1] < ~LIT[3]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[select][2]+          assign ~RESULT[~SYM[1]] = ~VAR[vec][4][~LIT[1] + (~LIT[2] * ~SYM[1])];+        end+      ~ENDGENERATE+      // select end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.+++    kind: Expression+    type: '(++) :: Vec n a -> Vec m a -> Vec (n + m) a'+    template: ~FROMBV[{~TOBV[~ARG[0]][~TYP[0]],~TOBV[~ARG[1]][~TYP[1]]}][~TYPO]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.concat+    kind: Declaration+    type: 'concat :: Vec n (Vec m a) -> Vec (n * m) a'+    template: |-+      // concat begin+      genvar ~GENSYM[n][1];+      ~GENERATE+        for (~SYM[1]=0; ~SYM[1] < $size(~VAR[vec][0]); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[concat][2]+          assign ~RESULT[~SYM[1]*~LENGTH[~TYPEL[~TYP[0]]] : ~SYM[1]*~LENGTH[~TYPEL[~TYP[0]]]+(~LENGTH[~TYPEL[~TYP[0]]]-1)] = ~FROMBV[~VAR[vec][0][\~SYM[1]\]][~TYPEL[~TYP[0]]];+        end+      ~ENDGENERATE+      // concat end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.splitAt+    kind: Declaration+    type: 'splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)'+    template: |-+      // splitAt begin~IF~LENGTH[~TYPO]~THEN+      assign ~RESULT = ~ARG[1];~ELSE+      logic [0:~LENGTH[~TYP[1]]-1] [0:~SIZE[~TYPEL[~TYP[1]]]-1] ~GENSYM[vec][0];+      assign ~SYM[0] = ~TOBV[~ARG[1]][~TYP[1]];+      ~GENERATE+        if (~LIT[0] == ~LENGTH[~TYP[1]]) begin : ~GENSYM[no_split][1]+          assign ~RESULT = {~SYM[0]};+        end else begin : ~GENSYM[do_split][2]+          assign ~RESULT = {~SYM[0][0:~LIT[0]-1]+                           ,~SYM[0][~LIT[0]:~LENGTH[~TYP[1]]-1]+                           };+        end+      ~ENDGENERATE~FI+      // splitAt end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.unconcat+    kind: Declaration+    type: |-+      unconcat :: KnownNat n     -- ARG[0]+                 => SNat m         -- ARG[1]+                 -> Vec (n * m) a  -- ARG[2]+                 -> Vec n (Vec m a)+    template: |-+      // unconcat begin~DEVNULL[~ARG[0]]+      genvar ~GENSYM[n][1];+      ~GENERATE+        for (~SYM[1] = 0; ~SYM[1] < $size(~RESULT); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[unconcat][2]+          assign ~RESULT[~SYM[1]] = ~TOBV[~VAR[vec][2][\(~SYM[1] * ~LIT[1]) : ((~SYM[1] * ~LIT[1]) + ~LIT[1] - 1)\]][~TYPEL[~TYPO]];+        end+      ~ENDGENERATE+      // unconcat end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.map+    kind: Declaration+    type: 'map :: (a -> b) -> Vec n a -> Vec n b'+    template: |-+      // map begin+      genvar ~GENSYM[n][1];+      ~GENERATE+      for (~SYM[1]=0; ~SYM[1] < $size(~RESULT); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[map][2]~IF~SIZE[~TYP[1]]~THEN+        ~TYPEL[~TYP[1]] ~GENSYM[map_in][3];+        assign ~SYM[3] = ~FROMBV[~VAR[vec][1][\~SYM[1]\]][~TYPEL[~TYP[1]]];~ELSE ~FI+        ~TYPEL[~TYPO] ~GENSYM[map_out][4];+        ~INST 0+          ~OUTPUT <= ~SYM[4]~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~SYM[3]~ ~TYPEL[~TYP[1]]~+        ~INST+        assign ~RESULT[~SYM[1]] = ~TOBV[~SYM[4]][~TYPEL[~TYPO]];+      end+      ~ENDGENERATE+      // map end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.imap+    kind: Declaration+    type: 'imap :: KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b'+    template: |-+      // imap begin+      genvar ~GENSYM[n][1];+      ~GENERATE+      for (~SYM[1]=0; ~SYM[1] < $size(~RESULT); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[imap][2]+        ~INDEXTYPE[~LIT[0]] ~GENSYM[i][3];+        assign ~SYM[3] = ~SYM[1];~IF~SIZE[~TYP[2]]~THEN+        ~TYPEL[~TYP[2]] ~GENSYM[imap_in][4];+        assign ~SYM[4] = ~FROMBV[~VAR[vec][2][\~SYM[1]\]][~TYPEL[~TYP[2]]];~ELSE ~FI+        ~TYPEL[~TYPO] ~GENSYM[imap_out][5];+        ~INST 1+          ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~SYM[3]~ ~INDEXTYPE[~LIT[0]]~+          ~INPUT  <= ~SYM[4]~ ~TYPEL[~TYP[2]]~+        ~INST+        assign ~RESULT[~SYM[1]] = ~TOBV[~SYM[5]][~TYPEL[~TYPO]];+      end+      ~ENDGENERATE+      // imap end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.imap_go+    kind: Declaration+    type: 'imap_go :: (Index n -> a -> b) -> Vec m a -> Index n -> Vec m b'+    template: |-+      // imap begin+      genvar ~GENSYM[n][1];+      ~GENERATE+      for (~SYM[1]=0; ~SYM[1] < $size(~RESULT); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[imap][2]+        ~TYP[2] ~GENSYM[i][3];+        assign ~SYM[3] = ~SYM[1] + ~ARG[2];~IF~SIZE[~TYP[1]]~THEN+        ~TYPEL[~TYP[1]] ~GENSYM[imap_in][4];+        assign ~SYM[4] = ~FROMBV[~VAR[vec][1][\~SYM[1]\]][~TYPEL[~TYP[1]]];~ELSE ~FI+        ~TYPEL[~TYPO] ~GENSYM[imap_out][5];+        ~INST 0+          ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~SYM[3]~ ~TYP[2]~+          ~INPUT  <= ~SYM[4]~ ~TYPEL[~TYP[1]]~+        ~INST+        assign ~RESULT[~SYM[1]] = ~TOBV[~SYM[5]][~TYPEL[~TYPO]];+      end+      ~ENDGENERATE+      // imap end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.zipWith+    kind: Declaration+    type: 'zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c'+    template: |-+      // zipWith begin+      genvar ~GENSYM[n][2];+      ~GENERATE+      for (~SYM[2] = 0; ~SYM[2] < $size(~RESULT); ~SYM[2] = ~SYM[2] + 1) begin : ~GENSYM[zipWith][3]~IF~SIZE[~TYP[1]]~THEN+        ~TYPEL[~TYP[1]] ~GENSYM[zipWith_in1][4];+        assign ~SYM[4] = ~FROMBV[~VAR[vec1][1][\~SYM[2]\]][~TYPEL[~TYP[1]]];~ELSE ~FI~IF~SIZE[~TYP[2]]~THEN+        ~TYPEL[~TYP[2]] ~GENSYM[zipWith_in2][5];+        assign ~SYM[5] = ~FROMBV[~VAR[vec2][2][\~SYM[2]\]][~TYPEL[~TYP[2]]];~ELSE ~FI+        ~TYPEL[~TYPO] ~GENSYM[zipWith_out][6];+        ~INST 0+          ~OUTPUT <= ~SYM[6]~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~SYM[4]~ ~TYPEL[~TYP[1]]~+          ~INPUT  <= ~SYM[5]~ ~TYPEL[~TYP[2]]~+        ~INST+        assign ~RESULT[~SYM[2]] = ~TOBV[~SYM[6]][~TYPEL[~TYPO]];+      end+      ~ENDGENERATE+      // zipWith end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.foldr+    kind: Declaration+    type: 'foldr :: (a -> b -> b) -> b -> Vec n a -> b'+    template: |-+      // foldr start~IF ~LENGTH[~TYP[2]] ~THEN+      ~SIGDO[~GENSYM[intermediate][0]] [0:~LENGTH[~TYP[2]]];+      assign ~SYM[0][~LENGTH[~TYP[2]]] = ~ARG[1];++      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0; ~SYM[3] < ~LENGTH[~TYP[2]]; ~SYM[3]=~SYM[3]+1) begin : ~GENSYM[foldr_loop][4]~IF~SIZE[~TYP[2]]~THEN+        ~TYPEL[~TYP[2]] ~GENSYM[foldr_in][5];+        assign ~SYM[5] = ~FROMBV[~VAR[xs][2][\~SYM[3]\]][~TYPEL[~TYP[2]]];~ELSE ~FI+        ~INST 0+          ~OUTPUT <= ~SYM[0][~SYM[3]]~ ~TYP[1]~+          ~INPUT <= ~SYM[5]~ ~TYPEL[~TYP[2]]~+          ~INPUT <= ~SYM[0][~SYM[3]+1]~ ~TYP[1]~+        ~INST+      end+      ~ENDGENERATE++      assign ~RESULT = ~SYM[0][0];+      ~ELSE+      assign ~RESULT = ~ARG[1];+      ~FI// foldr end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.index_int+    kind: Expression+    type: 'index_int :: KnownNat n => Vec n a -> Int -> a'+    template: ~IF~SIZE[~TYP[1]]~THEN~FROMBV[~VAR[vec][1][\~ARG[2]\]][~TYPO]~ELSE~ERRORO~FI+- BlackBox:+    name: Clash.Sized.Vector.replace_int+    kind: Declaration+    outputUsage: Blocking+    type: 'replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a'+    template: |-+      // replaceVec start+      always_comb begin+        ~RESULT = ~ARG[1];+        ~RESULT[~ARG[2]] = ~TOBV[~ARG[3]][~TYP[3]];+      end+      // replaceVec end+- BlackBox:+    name: Clash.Sized.Vector.replicate+    kind: Expression+    type: 'replicate :: SNat n -> a -> Vec n a'+    template: "'{~LIT[0] {~TOBV[~ARG[1]][~TYP[1]]}}"+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.transpose+    kind: Declaration+    type: 'transpose :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)'+    template: |-+      // transpose begin+      genvar ~GENSYM[row_index][1];+      genvar ~GENSYM[col_index][2];+      ~GENERATE+        for (~SYM[1] = 0; ~SYM[1] < $size(~VAR[matrix][1]); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[transpose_outer][3]+          for (~SYM[2] = 0; ~SYM[2] < $size(~RESULT); ~SYM[2] = ~SYM[2] + 1) begin : ~GENSYM[transpose_inner][4]~IF ~VIVADO ~THEN+            assign ~RESULT[~SYM[2]][($size(~VAR[matrix][1])-~SYM[1])*~SIZE[~TYPEL[~TYPEL[~TYPO]]]-1 : ($size(~VAR[matrix][1])-~SYM[1]-1)*~SIZE[~TYPEL[~TYPEL[~TYPO]]]] = ~VAR[matrix][1][~SYM[1]][($size(~RESULT)-~SYM[2])*~SIZE[~TYPEL[~TYPEL[~TYPO]]]-1 : ($size(~RESULT)-~SYM[2]-1)*~SIZE[~TYPEL[~TYPEL[~TYPO]]]];~ELSE+            assign ~RESULT[~SYM[2]][~SYM[1]] = ~VAR[matrix][1][~SYM[1]][~SYM[2]];~FI+          end+        end+      ~ENDGENERATE+      // transpose end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.reverse+    kind: Declaration+    type: 'reverse :: Vec n a -> Vec n a'+    template: |-+      // reverse begin+      genvar ~GENSYM[n][1];+      ~GENERATE+        for (~SYM[1] = 0; ~SYM[1] < $size(~VAR[vec][0]); ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[reverse][2]+          assign ~RESULT[$high(~VAR[vec][0]) - ~SYM[1]] = ~VAR[vec][0][~SYM[1]];+        end+      ~ENDGENERATE+      // reverse end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.concatBitVector#+    kind: Expression+    type: |-+      concatBitVector# :: (KnownNat n,KnownNat m) -- (ARG[0],ARG[1])+                        => Vec n (BitVector m)     -- ARG[2]+                        -> BitVector (n * m)+    template: ~TOBV[~ARG[2]][~TYP[2]]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.unconcatBitVector#+    kind: Expression+    type: |-+      unconcatBitVector# :: (KnownNat n, KnownNat m) -- (ARG[0],ARG[1])+                          => BitVector (n * m)        -- ARG[2]+                          -> Vec n (BitVector m)+    template: ~FROMBV[~ARG[2]][~TYPO]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.rotateLeftS+    kind: Declaration+    type: 'rotateLeftS :: KnownNat n => Vec n a -> SNat d -> Vec n a'+    template: |-+      // rotateLeftS begin+      localparam ~GENSYM[shift_amount][2] = ~LIT[2] % ~LIT[0];++      ~GENERATE+      if (~SYM[2] == 0) begin : ~GENSYM[no_shift][3]+        assign ~RESULT = ~VAR[vec][1];+      end else begin : ~GENSYM[do_shift][4]+        assign ~RESULT[0:~LIT[0]-~SYM[2]-1] = ~VAR[vec][1][~SYM[2]:~LIT[0]-1];+        assign ~RESULT[~LIT[0]-~SYM[2]:~LIT[0]-1] = ~VAR[vec][1][0:~SYM[2]-1];+      end+      ~ENDGENERATE+      // rotateLeftS end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.rotateRightS+    kind: Declaration+    type: 'rotateRightS :: KnownNat n => Vec n a -> SNat d -> Vec n a'+    template: |-+      // rotateRightS begin+      localparam ~GENSYM[shift_amount][2] = ~LIT[2] % ~LIT[0];++      ~GENERATE+      if (~SYM[2] == 0) begin : ~GENSYM[no_shift][3]+        assign ~RESULT = ~VAR[vec][1];+      end else begin : ~GENSYM[do_shift][4]+        assign ~RESULT[0:~SYM[2]-1] = ~VAR[vec][1][~LIT[0]-~SYM[2]:~LIT[0]-1];+        assign ~RESULT[~SYM[2]:~LIT[0]-1] = ~VAR[vec][1][0:~LIT[0]-~SYM[2]-1];+      end+      ~ENDGENERATE+      // rotateRightS end+    workInfo: Never
+ prims/systemverilog/Clash_Xilinx_DDR.primitives.yaml view
@@ -0,0 +1,94 @@+- BlackBox:+    name: Clash.Xilinx.DDR.iddr#+    kind: Declaration+    type: |-+      iddr#+        :: forall n dom domDDR+         . HasCallStack                 -- ARG[0]+        => KnownDomain dom              -- ARG[1]+        => KnownDomain domDDR           -- ARG[2]+        => DomPeriod ~ 2 * ...          -- ARG[3]+        => DomEdge ~ Rising             -- ARG[4]+        => KnownNat n                   -- ARG[5]+        => Clock dom                    -- ARG[6]+        -> Reset dom                    -- ARG[7]+        -> Enable dom                   -- ARG[8]+        -> Signal domDDR (BitVector n)  -- ARG[9]+        -> Signal dom (BitVector n, BitVector n)+    template: |-+      // iddr begin+      ~SIGD[~GENSYM[data_pos][1]][9];+      ~SIGD[~GENSYM[data_neg][2]][9];+      ~SIGD[~GENSYM[d][3]][9];+      assign ~SYM[3] = ~ARG[9];++      genvar ~GENSYM[i][8];+      ~GENERATE+      for (~SYM[8]=0; ~SYM[8] < ~SIZE[~TYP[9]]; ~SYM[8]=~SYM[8]+1) begin : ~GENSYM[ddri_array][7]+        IDDR #(+          .DDR_CLK_EDGE("SAME_EDGE"),+          .INIT_Q1(1'b0),+          .INIT_Q2(1'b0),+          .SRTYPE(~IF ~ISSYNC[1] ~THEN "SYNC" ~ELSE "ASYNC" ~FI)+        ) ~GENSYM[~COMPNAME_IDDR][9] (+          .Q1(~SYM[1][~SYM[8]]),+          .Q2(~SYM[2][~SYM[8]]),+          .C(~ARG[6]),+          .CE(~IF ~ISACTIVEENABLE[8] ~THEN ~ARG[8] ~ELSE 1'b1 ~FI),+          .D(~SYM[3][~SYM[8]]),+          .R(~ARG[7]),+          .S(1'b0)+        );+      end+      ~ENDGENERATE++      assign ~RESULT = {~SYM[2],~SYM[1]};+      // iddr end+- BlackBox:+    name: Clash.Xilinx.DDR.oddr#+    kind: Declaration+    type: |-+      oddr#+        :: forall n dom domDDR+         . HasCallStack              -- ARG[0]+        => KnownDomain dom           -- ARG[1]+        => KnownDomain domDDR        -- ARG[2]+        => DomPeriod ~ 2 * ...       -- ARG[3]+        => DomEdge ~ Rising          -- ARG[4]+        => KnownNat n                -- ARG[5]+        => Clock dom                 -- ARG[6]+        -> Reset dom                 -- ARG[7]+        -> Enable dom                -- ARG[8]+        -> Signal dom (BitVector n)  -- ARG[9]+        -> Signal dom (BitVector n)  -- ARG[10]+        -> Signal domDDR (BitVector n)+    template: |-+      // oddr begin+      ~SIGD[~GENSYM[data_pos][1]][10];+      ~SIGD[~GENSYM[data_neg][2]][10];+      ~SIGD[~GENSYM[q][3]][10];++      assign ~SYM[1] = ~ARG[9];+      assign ~SYM[2] = ~ARG[10];++      genvar ~GENSYM[i][8];+      ~GENERATE+      for (~SYM[8]=0; ~SYM[8] < ~SIZE[~TYP[10]]; ~SYM[8]=~SYM[8]+1) begin : ~GENSYM[ddro_array][7]+        ODDR #(+          .DDR_CLK_EDGE("SAME_EDGE"),+          .INIT(1'b0),+          .SRTYPE(~IF ~ISSYNC[1] ~THEN "SYNC" ~ELSE "ASYNC" ~FI)+        ) ~GENSYM[~COMPNAME_ODDR][9] (+          .Q(~SYM[3][~SYM[8]]),+          .C(~ARG[6]),+          .CE(~IF ~ISACTIVEENABLE[8] ~THEN ~ARG[8] ~ELSE 1'b1 ~FI),+          .D1(~SYM[1][~SYM[8]]),+          .D2(~SYM[2][~SYM[8]]),+          .R(~ARG[7]),+          .S(1'b0)+        );+      end+      ~ENDGENERATE++      assign ~RESULT = ~SYM[3];+      // oddr end
+ prims/systemverilog/GHC_Base.primitives.yaml view
@@ -0,0 +1,42 @@+- BlackBox:+    name: GHC.Base.divInt+    kind: Declaration+    type: 'divInt :: Int ->+      Int -> Int'+    template: |-+      // divInt begin+      logic ~GENSYM[resultPos][1];+      logic ~GENSYM[dividerNeg][2];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6];++      assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+      assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]);+      // divInt end+- BlackBox:+    name: GHC.Base.modInt+    kind: Declaration+    type: 'modInt :: Int ->+      Int -> Int'+    template: |-+      // modInt begin+      // remainder+      ~SIGD[~GENSYM[rem_res][0]][0];+      assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1];++      // modulo+      assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ?+                       ~SYM[0] :+                       ((~VAR[dividend][0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]);+      // modInt end
+ prims/systemverilog/GHC_Classes.primitives.yaml view
@@ -0,0 +1,42 @@+- BlackBox:+    name: GHC.Classes.divInt#+    kind: Declaration+    type: 'divInt# :: Int#+      -> Int# -> Int#'+    template: |-+      // divInt# begin+      logic ~GENSYM[resultPos][1];+      logic ~GENSYM[dividerNeg][2];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6];++      assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+      assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]);+      // divInt# end+- BlackBox:+    name: GHC.Classes.modInt#+    kind: Declaration+    type: 'modInt# :: Int#+      -> Int# -> Int#'+    template: |-+      // modInt# begin+      // remainder+      ~SIGD[~GENSYM[rem_res][0]][0];+      assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1];++      // modulo+      assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ?+                       ~SYM[0] :+                       ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]);+      // modInt# end
+ prims/systemverilog/GHC_Integer_Type.primitives.yaml view
@@ -0,0 +1,100 @@+- BlackBox:+    name: GHC.Integer.Type.divInteger+    kind: Declaration+    type: 'divInteger :: Integer+      -> Integer -> Integer'+    template: |-+      // divInteger begin+      logic ~GENSYM[resultPos][1];+      logic ~GENSYM[dividerNeg][2];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6];++      assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+      assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]);+      // divInteger end+    warning: 'GHC.Integer.Type.divInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.modInteger+    kind: Declaration+    type: 'modInteger :: Integer+      -> Integer -> Integer'+    template: |-+      // modInteger begin+      // remainder+      ~SIGD[~GENSYM[rem_res][0]][0];+      assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1];++      // modulo+      assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ?+                       ~SYM[0] :+                       ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]);+      // modInteger end+    warning: 'GHC.Integer.Type.modInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.divModInteger+    kind: Declaration+    type: 'divModInteger ::+      Integer -> Integer -> (# Integer, Integer #)'+    template: |-+      // divModInteger begin+      logic ~GENSYM[resultPos][1];+      logic ~GENSYM[dividerNeg][2];+      logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividend2][3];+      logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividendE][4];+      logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividerE][5];+      logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[quot_res][6];+      logic signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[div_res][7];++      assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1];+      assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYP[0]]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYP[0]]-1]},~VAR[dividend][0]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYP[0]]-1]} ,~VAR[divider][1]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYP[0]]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYP[0]]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~SYM[7] = $signed(~SYM[6][~SIZE[~TYP[0]]-1:0]);++      logic signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[rem_res][8];+      logic signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[mod_res][9];+      assign ~SYM[8] = ~VAR[dividend][0] % ~VAR[divider][1];+      assign ~SYM[9] = (~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1]) ?+                       ~SYM[8] :+                       ((~SYM[8] == ~SIZE[~TYP[0]]'sd0) ? ~SIZE[~TYP[0]]'sd0 : ~SYM[8] + ~VAR[divider][1]);++      assign ~RESULT = {~SYM[7],~SYM[9]};+      // divModInteger end+    warning: 'GHC.Integer.Type.divModInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.quotRemInteger+    kind: Declaration+    type: 'quotRemInteger+      :: Integer -> Integer -> (# Integer, Integer #)'+    template: |-+      // quotRemInteger begin+      ~SIGD[~GENSYM[quot_res][0]][0];+      ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemInteger end+    warning: 'GHC.Integer.Type.quotRemInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'
+ prims/systemverilog/GHC_Num_Integer.primitives.yaml view
@@ -0,0 +1,100 @@+- BlackBox:+    name: GHC.Num.Integer.integerDiv+    kind: Declaration+    type: 'integerDiv :: Integer+      -> Integer -> Integer'+    template: |-+      // integerDiv begin+      logic ~GENSYM[resultPos][1];+      logic ~GENSYM[dividerNeg][2];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+      logic signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6];++      assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+      assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]);+      // integerDiv end+    warning: 'GHC.Num.Integer.integerDiv: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerMod+    kind: Declaration+    type: 'integerMod :: Integer+      -> Integer -> Integer'+    template: |-+      // integerMod begin+      // remainder+      ~SIGD[~GENSYM[rem_res][0]][0];+      assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1];++      // modulo+      assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ?+                       ~SYM[0] :+                       ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]);+      // integerMod end+    warning: 'GHC.Num.Integer.integerMod: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerDivMod#+    kind: Declaration+    type: 'integerDivMod ::+      Integer -> Integer -> (# Integer, Integer #)'+    template: |-+      // integerDivMod begin+      logic ~GENSYM[resultPos][1];+      logic ~GENSYM[dividerNeg][2];+      logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividend2][3];+      logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividendE][4];+      logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividerE][5];+      logic signed [~SIZE[~TYP[0]]:0] ~GENSYM[quot_res][6];+      logic signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[div_res][7];++      assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1];+      assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYP[0]]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYP[0]]-1]},~VAR[dividend][0]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYP[0]]-1]} ,~VAR[divider][1]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYP[0]]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYP[0]]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~SYM[7] = $signed(~SYM[6][~SIZE[~TYP[0]]-1:0]);++      logic signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[rem_res][8];+      logic signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[mod_res][9];+      assign ~SYM[8] = ~VAR[dividend][0] % ~VAR[divider][1];+      assign ~SYM[9] = (~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1]) ?+                       ~SYM[8] :+                       ((~SYM[8] == ~SIZE[~TYP[0]]'sd0) ? ~SIZE[~TYP[0]]'sd0 : ~SYM[8] + ~VAR[divider][1]);++      assign ~RESULT = {~SYM[7],~SYM[9]};+      // integerDivMod end+    warning: 'GHC.Num.Integer.integerDivMod#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerQuotRem#+    kind: Declaration+    type: 'integerQuotRem+      :: Integer -> Integer -> (# Integer, Integer #)'+    template: |-+      // integerQuotRem begin+      ~SIGD[~GENSYM[quot_res][0]][0];+      ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // integerQuotRem end+    warning: 'GHC.Num.Integer.integerQuotRem#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'
+ prims/systemverilog/GHC_Prim.primitives.yaml view
@@ -0,0 +1,1510 @@+- BlackBox:+    name: GHC.Prim.quotRemInt#+    kind: Declaration+    type: 'quotRemInt# ::+      Int# -> Int# -> (#Int#, Int##)'+    template: |-+      // quotRemInt begin+      ~SIGD[~GENSYM[quot_res][0]][0];+      ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemInt end+- BlackBox:+    name: GHC.Prim.quotRemWord#+    kind: Declaration+    type: 'quotRemWord# ::+      Word# -> Word# -> (#Word#, Word##)'+    template: |-+      // quotRemWord begin+      ~SIGD[~GENSYM[quot_res][0]][0];+      ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemWord end+- BlackBox:+    name: GHC.Prim.popCnt8#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: depth2Index+      extension: inc+      template: |-+        // given a level and a depth, calculate the corresponding index into the+        // intermediate array+        function integer ~INCLUDENAME[0];+          input integer levels;+          input integer depth;++          ~INCLUDENAME[0] = (2 ** levels) - (2 ** depth);+        endfunction+    kind: Declaration+    type: 'popCnt8# :: Word#+      -> Word#'+    template: |-+      // popCnt8 begin+      localparam ~GENSYM[width][0] = 8;++      // depth of the tree+      localparam ~GENSYM[levels][2] = $clog2(~SYM[0]);++      logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2];++      // put input into the first half of the intermediate array+      genvar ~GENSYM[i][4];+      ~GENERATE+      for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11]+        assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]);+      end+      ~ENDGENERATE++      // Create the tree of instantiated components+      genvar ~GENSYM[d][6];+      genvar ~GENSYM[i][7];+      ~GENERATE+      if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8]+        for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9]+          for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10]+            assign ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6])+~SYM[7]] =+                   ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] ++                   ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1];+          end+        end+      end+      ~ENDGENERATE++      // The last element of the intermediate array holds the result+      assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]);+      // popCnt8 end+- BlackBox:+    name: GHC.Prim.popCnt16#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: depth2Index+      extension: inc+      template: |-+        // given a level and a depth, calculate the corresponding index into the+        // intermediate array+        function integer ~INCLUDENAME[0];+          input integer levels;+          input integer depth;++          ~INCLUDENAME[0] = (2 ** levels) - (2 ** depth);+        endfunction+    kind: Declaration+    type: 'popCnt16# :: Word#+      -> Word#'+    template: |-+      // popCnt16 begin+      localparam ~GENSYM[width][0] = 16;++      // depth of the tree+      localparam ~GENSYM[levels][2] = $clog2(~SYM[0]);++      logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2];++      // put input into the first half of the intermediate array+      genvar ~GENSYM[i][4];+      ~GENERATE+      for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11]+        assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]);+      end+      ~ENDGENERATE++      // Create the tree of instantiated components+      genvar ~GENSYM[d][6];+      genvar ~GENSYM[i][7];+      ~GENERATE+      if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8]+        for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9]+          for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10]+            assign ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6])+~SYM[7]] =+                   ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] ++                   ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1];+          end+        end+      end+      ~ENDGENERATE++      // The last element of the intermediate array holds the result+      assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]);+      // popCnt16 end+- BlackBox:+    name: GHC.Prim.popCnt32#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: depth2Index+      extension: inc+      template: |-+        // given a level and a depth, calculate the corresponding index into the+        // intermediate array+        function integer ~INCLUDENAME[0];+          input integer levels;+          input integer depth;++          ~INCLUDENAME[0] = (2 ** levels) - (2 ** depth);+        endfunction+    kind: Declaration+    type: 'popCnt32# :: Word#+      -> Word#'+    template: |-+      // popCnt32 begin+      localparam ~GENSYM[width][0] = 32;++      // depth of the tree+      localparam ~GENSYM[levels][2] = $clog2(~SYM[0]);++      logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2];++      // put input into the first half of the intermediate array+      genvar ~GENSYM[i][4];+      ~GENERATE+      for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11]+        assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]);+      end+      ~ENDGENERATE++      // Create the tree of instantiated components+      genvar ~GENSYM[d][6];+      genvar ~GENSYM[i][7];+      ~GENERATE+      if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8]+        for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9]+          for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10]+            assign ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6])+~SYM[7]] =+                   ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] ++                   ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1];+          end+        end+      end+      ~ENDGENERATE++      // The last element of the intermediate array holds the result+      assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]);+      // popCnt32 end+- BlackBox:+    name: GHC.Prim.popCnt64#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: depth2Index+      extension: inc+      template: |-+        // given a level and a depth, calculate the corresponding index into the+        // intermediate array+        function integer ~INCLUDENAME[0];+          input integer levels;+          input integer depth;++          ~INCLUDENAME[0] = (2 ** levels) - (2 ** depth);+        endfunction+    kind: Declaration+    type: 'popCnt64# :: Word#+      -> Word#'+    template: |-+      // popCnt64 begin+      localparam ~GENSYM[width][0] = 64;++      // depth of the tree+      localparam ~GENSYM[levels][2] = $clog2(~SYM[0]);++      logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2];++      // put input into the first half of the intermediate array+      genvar ~GENSYM[i][4];+      ~GENERATE+      for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11]+        assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]);+      end+      ~ENDGENERATE++      // Create the tree of instantiated components+      genvar ~GENSYM[d][6];+      genvar ~GENSYM[i][7];+      ~GENERATE+      if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8]+        for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9]+          for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10]+            assign ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6])+~SYM[7]] =+                   ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] ++                   ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1];+          end+        end+      end+      ~ENDGENERATE++      // The last element of the intermediate array holds the result+      assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]);+      // popCnt64 end+- BlackBox:+    name: GHC.Prim.popCnt#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: depth2Index+      extension: inc+      template: |-+        // given a level and a depth, calculate the corresponding index into the+        // intermediate array+        function integer ~INCLUDENAME[0];+          input integer levels;+          input integer depth;++          ~INCLUDENAME[0] = (2 ** levels) - (2 ** depth);+        endfunction+    kind: Declaration+    type: 'popCnt# :: Word#+      -> Word#'+    template: |-+      // popCnt begin+      localparam ~GENSYM[width][0] = ~SIZE[~TYPO];++      // depth of the tree+      localparam ~GENSYM[levels][2] = $clog2(~SYM[0]);++      logic [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2];++      // put input into the first half of the intermediate array+      genvar ~GENSYM[i][4];+      ~GENERATE+      for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11]+        assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]);+      end+      ~ENDGENERATE++      // Create the tree of instantiated components+      genvar ~GENSYM[d][6];+      genvar ~GENSYM[i][7];+      ~GENERATE+      if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8]+        for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9]+          for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10]+            assign ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6])+~SYM[7]] =+                   ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] ++                   ~SYM[3][~INCLUDENAME[0](~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1];+          end+        end+      end+      ~ENDGENERATE++      // The last element of the intermediate array holds the result+      assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]);+      // popCnt end+- BlackBox:+    name: GHC.Prim.clz8#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'clz8 :: Word# ->+      Word#'+    template: |-+      // clz8 begin+      logic [0:7] ~GENSYM[v][1];+      assign ~SYM[1] = ~VAR[i][0][7:0];++      logic [0:7] ~GENSYM[e][2];+      genvar ~GENSYM[n][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<4;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      logic [0:5] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<2;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage1][6]+        localparam n = 2;+        logic [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:3] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 3;+      logic [5:0] i;+      assign i = ~SYM[4][0:5];+      always_comb begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // clz8 end+- BlackBox:+    name: GHC.Prim.clz16#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'clz16 :: Word#+      -> Word#'+    template: |-+      // clz16 begin+      logic [0:15] ~GENSYM[v][1];+      assign ~SYM[1] = ~VAR[i][0][15:0];++      logic [0:15] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<8;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      logic [0:11] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<4;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        logic [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:7] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<2;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        logic [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:4] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 4;+      logic [7:0] i;+      assign i = ~SYM[9][0:7];+      always_comb begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // clz16 end+- BlackBox:+    name: GHC.Prim.clz32#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'clz32 :: Word#+      -> Word#'+    template: |-+      // clz32 begin+      logic [0:31] ~GENSYM[v][1];+      assign ~SYM[1] = ~VAR[i][0][31:0];++      logic [0:31] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      logic [0:23] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        logic [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:15] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        logic [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:9] ~GENSYM[c][12];+      genvar ~GENSYM[i3][13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14]+        localparam n = 4;+        logic [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:5] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 5;+      logic [9:0] i;+      assign i = ~SYM[12][0:9];+      always_comb begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // clz32 end+- BlackBox:+    name: GHC.Prim.clz64#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'clz64 :: Word#+      -> Word#'+    template: |-+      // clz64 begin+      logic [0:63] ~GENSYM[v][1];+      assign ~SYM[1] = ~VAR[i][0][63:0];++      logic [0:63] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      logic [0:47] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        logic [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:31] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        logic [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:19] ~GENSYM[c][12];+      genvar ~GENSYM[i3][13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14]+        localparam n = 4;+        logic [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:11] ~GENSYM[d][15];+      genvar ~GENSYM[i4][16];+      ~GENERATE+      for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17]+        localparam n = 5;+        logic [9:0] i;+        assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:6] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 6;+      logic [11:0] i;+      assign i = ~SYM[15][0:11];+      always_comb begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // clz64 end+- BlackBox:+    name: GHC.Prim.clz#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'clz :: Word# ->+      Word#'+    template: |-+      // clz begin+      ~IF ~IW64 ~THEN+      logic [0:63] ~GENSYM[v][1];+      assign ~SYM[1] = ~VAR[i][0][63:0];++      logic [0:63] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      logic [0:47] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        logic [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:31] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        logic [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:19] ~GENSYM[c][12];+      genvar ~GENSYM[i3][13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14]+        localparam n = 4;+        logic [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:11] ~GENSYM[d][15];+      genvar ~GENSYM[i4][16];+      ~GENERATE+      for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17]+        localparam n = 5;+        logic [9:0] i;+        assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:6] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 6;+      logic [11:0] i;+      assign i = ~SYM[15][0:11];+      always_comb begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE+      ~ELSE+      logic [0:31] ~SYM[1];+      assign ~SYM[1] = ~VAR[i][0][31:0];++      logic [0:31] ~SYM[2];+      genvar ~SYM[3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~SYM[8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      logic [0:23] ~SYM[4];+      genvar ~SYM[5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~SYM[6]+        localparam n = 2;+        logic [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:15] ~SYM[9];+      genvar ~SYM[10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~SYM[11]+        localparam n = 3;+        logic [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:9] ~SYM[12];+      genvar ~SYM[13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~SYM[14]+        localparam n = 4;+        logic [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:5] ~SYM[7];+      ~GENERATE+      if (1) begin+      localparam n = 5;+      logic [9:0] i;+      assign i = ~SYM[12][0:9];+      always_comb begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE+      ~FI+      assign ~RESULT = $unsigned(~SYM[7]);+      // clz end+- BlackBox:+    name: GHC.Prim.ctz8#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'ctz8 :: Word# ->+      Word#'+    template: |-+      // ctz8 begin+      logic [0:7] ~GENSYM[v][1];+      genvar ~GENSYM[k][18];+      ~GENERATE+      for (~SYM[18]=0;~SYM[18]<8;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]+        assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]];+      end+      ~ENDGENERATE++      logic [0:7] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<4;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      logic [0:5] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<2;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        logic [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:3] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 3;+      logic [5:0] i;+      assign i = ~SYM[4][0:5];+      always_comb begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // ctz8 end+- BlackBox:+    name: GHC.Prim.ctz16#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'ctz16 :: Word#+      -> Word#'+    template: |-+      // ctz16 begin+      logic [0:15] ~GENSYM[v][1];+      genvar ~GENSYM[k][18];+      ~GENERATE+      for (~SYM[18]=0;~SYM[18]<16;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]+        assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]];+      end+      ~ENDGENERATE++      logic [0:15] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<8;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      logic [0:11] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<4;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        logic [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:7] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<2;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        logic [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:4] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 4;+      logic [7:0] i;+      assign i = ~SYM[9][0:7];+      always_comb begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // ctz16 end+- BlackBox:+    name: GHC.Prim.ctz32#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'ctz32 :: Word#+      -> Word#'+    template: |-+      // ctz32 begin+      logic [0:31] ~GENSYM[v][1];+      genvar ~GENSYM[k][18];+      ~GENERATE+      for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]+        assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]];+      end+      ~ENDGENERATE++      logic [0:31] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      logic [0:23] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        logic [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:15] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        logic [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:9] ~GENSYM[c][12];+      genvar ~GENSYM[i3][13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14]+        localparam n = 4;+        logic [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:5] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 5;+      logic [9:0] i;+      assign i = ~SYM[12][0:9];+      always_comb begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // ctz32 end+- BlackBox:+    name: GHC.Prim.ctz64#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'ctz64 :: Word#+      -> Word#'+    template: |-+      // ctz64 begin+      logic [0:63] ~GENSYM[v][1];+      genvar ~GENSYM[k][18];+      ~GENERATE+      for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]+        assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]];+      end+      ~ENDGENERATE++      logic [0:63] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      logic [0:47] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        logic [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:31] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        logic [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:19] ~GENSYM[c][12];+      genvar ~GENSYM[i3][13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14]+        localparam n = 4;+        logic [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:11] ~GENSYM[d][15];+      genvar ~GENSYM[i4][16];+      ~GENERATE+      for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17]+        localparam n = 5;+        logic [9:0] i;+        assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:6] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 6;+      logic [11:0] i;+      assign i = ~SYM[15][0:11];+      always_comb begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // ctz64 end+- BlackBox:+    name: GHC.Prim.ctz#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'ctz :: Word# ->+      Word#'+    template: |-+      // ctz begin+      ~IF ~IW64 ~THEN+      logic [0:63] ~GENSYM[v][1];+      genvar ~GENSYM[k][18];+      ~GENERATE+      for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]+        assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]];+      end+      ~ENDGENERATE++      logic [0:63] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      logic [0:47] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        logic [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:31] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        logic [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:19] ~GENSYM[c][12];+      genvar ~GENSYM[i3][13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14]+        localparam n = 4;+        logic [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:11] ~GENSYM[d][15];+      genvar ~GENSYM[i4][16];+      ~GENERATE+      for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17]+        localparam n = 5;+        logic [9:0] i;+        assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:6] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 6;+      logic [11:0] i;+      assign i = ~SYM[15][0:11];+      always_comb begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE+      ~ELSE+      logic [0:31] ~SYM[1];+      genvar ~SYM[18];+      ~GENERATE+      for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~SYM[19]+        assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]];+      end+      ~ENDGENERATE++      logic [0:31] ~SYM[2];+      genvar ~SYM[3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~SYM[8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      logic [0:23] ~SYM[4];+      genvar ~SYM[5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~SYM[6]+        localparam n = 2;+        logic [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:15] ~SYM[9];+      genvar ~SYM[10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~SYM[11]+        localparam n = 3;+        logic [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:9] ~SYM[12];+      genvar ~SYM[13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~SYM[14]+        localparam n = 4;+        logic [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always_comb begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      logic [0:5] ~SYM[7];+      ~GENERATE+      if (1) begin+      localparam n = 5;+      logic [9:0] i;+      assign i = ~SYM[12][0:9];+      always_comb begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE+      ~FI+      assign ~RESULT = $unsigned(~SYM[7]);+      // ctz end+- BlackBox:+    name: GHC.Prim.quotRemInt8#+    kind: Declaration+    type: 'quotRemInt8# ::+      Int8# -> Int8# -> (#Int8#, Int8##)'+    template: |-+      // quotRemInt8 begin+      ~SIGD[~GENSYM[quot_res][0]][0];+      ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemInt8 end+- BlackBox:+    name: GHC.Prim.quotRemWord8#+    kind: Declaration+    type: 'quotRemWord8# ::+      Word8# -> Word8# -> (#Word8#, Word8##)'+    template: |-+      // quotRemWord8 begin+      ~SIGD[~GENSYM[quot_res][0]][0];+      ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemWord8 end+- BlackBox:+    name: GHC.Prim.quotRemInt16#+    kind: Declaration+    type: 'quotRemInt16# ::+      Int16# -> Int16# -> (#Int16#, Int16##)'+    template: |-+      // quotRemInt16 begin+      ~SIGD[~GENSYM[quot_res][0]][0];+      ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemInt16 end+- BlackBox:+    name: GHC.Prim.quotRemWord16#+    kind: Declaration+    type: 'quotRemWord16# ::+      Word16# -> Word16# -> (#Word16#, Word16##)'+    template: |-+      // quotRemWord16 begin+      ~SIGD[~GENSYM[quot_res][0]][0];+      ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemWord16 end+- BlackBox:+    name: GHC.Prim.quotRemInt32#+    kind: Declaration+    type: 'quotRemInt32# ::+      Int32# -> Int32# -> (#Int32#, Int32##)'+    template: |-+      // quotRemInt32 begin+      ~SIGD[~GENSYM[quot_res][0]][0];+      ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemInt32 end+- BlackBox:+    name: GHC.Prim.quotRemWord32#+    kind: Declaration+    type: 'quotRemWord32# ::+      Word32# -> Word32# -> (#Word32#, Word32##)'+    template: |-+      // quotRemWord32 begin+      ~SIGD[~GENSYM[quot_res][0]][0];+      ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemWord32 end
+ prims/verilog/Clash_Explicit_BlockRam.primitives.yaml view
@@ -0,0 +1,144 @@+- BlackBox:+    name: Clash.Explicit.BlockRam.blockRam#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      blockRam#+        :: ( KnownDomain dom        ARG[0]+           , HasCallStack  --       ARG[1]+           , NFDataX a )   --       ARG[2]+        => Clock dom       -- clk,  ARG[3]+        => Enable dom      -- en,   ARG[4]+        -> Vec n a         -- init, ARG[5]+        -> Signal dom Int  -- rd,   ARG[6]+        -> Signal dom Bool -- wren, ARG[7]+        -> Signal dom Int  -- wr,   ARG[8]+        -> Signal dom a    -- din,  ARG[9]+        -> Signal dom a+    template: |-+      // blockRam begin+      reg ~TYPO ~GENSYM[~RESULT_RAM][1] [0:~LENGTH[~TYP[5]]-1];++      reg ~TYP[5] ~GENSYM[ram_init][3];+      integer ~GENSYM[i][4];+      initial begin+        ~SYM[3] = ~CONST[5];+        for (~SYM[4]=0; ~SYM[4] < ~LENGTH[~TYP[5]]; ~SYM[4] = ~SYM[4] + 1) begin+          ~SYM[1][~LENGTH[~TYP[5]]-1-~SYM[4]] = ~SYM[3][~SYM[4]*~SIZE[~TYPO]+:~SIZE[~TYPO]];+        end+      end+      ~IF ~ISACTIVEENABLE[4] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~RESULT_blockRam][5]~IF ~VIVADO ~THEN+        if (~ARG[4]) begin+          if (~ARG[7]) begin+            ~SYM[1][~ARG[8]] <= ~ARG[9];+          end+          ~RESULT <= ~SYM[1][~ARG[6]];+        end~ELSE+        if (~ARG[7] & ~ARG[4]) begin+          ~SYM[1][~ARG[8]] <= ~ARG[9];+        end+        if (~ARG[4]) begin+          ~RESULT <= ~SYM[1][~ARG[6]];+        end~FI+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[5]+        if (~ARG[7]) begin+          ~SYM[1][~ARG[8]] <= ~ARG[9];+        end+        ~RESULT <= ~SYM[1][~ARG[6]];+      end~FI+      // blockRam end+- BlackBox:+    name: Clash.Explicit.BlockRam.blockRamU#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      blockRamU#+        :: ( KnownDomain dom        ARG[0]+           , HasCallStack  --       ARG[1]+           , NFDataX a )   --       ARG[2]+        => Clock dom       -- clk,  ARG[3]+        -> Enable dom      -- en,   ARG[4]+        -> SNat n          -- len,  ARG[5]+        -> Signal dom Int  -- rd,   ARG[6]+        -> Signal dom Bool -- wren, ARG[7]+        -> Signal dom Int  -- wr,   ARG[8]+        -> Signal dom a    -- din,  ARG[9]+        -> Signal dom a+    template: |-+      // blockRamU begin+      reg ~TYPO ~GENSYM[~RESULT_RAM][0] [0:~LIT[5]-1];++      ~IF ~ISACTIVEENABLE[4] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~RESULT_blockRam][5]~IF ~VIVADO ~THEN+        if (~ARG[4]) begin+          if (~ARG[7]) begin+            ~SYM[0][~ARG[8]] <= ~ARG[9];+          end+          ~RESULT <= ~SYM[0][~ARG[6]];+        end~ELSE+        if (~ARG[7] & ~ARG[4]) begin+          ~SYM[0][~ARG[8]] <= ~ARG[9];+        end+        if (~ARG[4]) begin+          ~RESULT <= ~SYM[0][~ARG[6]];+        end~FI+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[5]+        if (~ARG[7]) begin+          ~SYM[0][~ARG[8]] <= ~ARG[9];+        end+        ~RESULT <= ~SYM[0][~ARG[6]];+      end~FI+      // blockRamU end+- BlackBox:+    name: Clash.Explicit.BlockRam.blockRam1#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      blockRam1#+        :: ( KnownDomain dom        ARG[0]+           , HasCallStack  --       ARG[1]+           , NFDataX a )   --       ARG[2]+        => Clock dom       -- clk,  ARG[3]+        -> Enable dom      -- en,   ARG[4]+        -> SNat n          -- len,  ARG[5]+        -> a               -- init, ARG[6]+        -> Signal dom Int  -- rd,   ARG[7]+        -> Signal dom Bool -- wren, ARG[8]+        -> Signal dom Int  -- wr,   ARG[9]+        -> Signal dom a    -- din,  ARG[10]+        -> Signal dom a+    template: |-+      // blockRam1 begin+      reg ~TYPO ~GENSYM[~RESULT_RAM][0] [0:~LIT[5]-1];+      integer ~GENSYM[i][1];+      initial begin+          for (~SYM[1]=0;~SYM[1]<~LIT[5];~SYM[1]=~SYM[1]+1) begin+              ~SYM[0][~SYM[1]] = ~CONST[6];+          end+      end++      ~IF ~ISACTIVEENABLE[4] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~RESULT_blockRam][5]~IF ~VIVADO ~THEN+        if (~ARG[4]) begin+          if (~ARG[8]) begin+            ~SYM[0][~ARG[9]] <= ~ARG[10];+          end+          ~RESULT <= ~SYM[0][~ARG[7]];+        end~ELSE+        if (~ARG[8] & ~ARG[4]) begin+          ~SYM[0][~ARG[9]] <= ~ARG[10];+        end+        if (~ARG[4]) begin+          ~RESULT <= ~SYM[0][~ARG[7]];+        end~FI+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[5]+        if (~ARG[8]) begin+          ~SYM[0][~ARG[9]] <= ~ARG[10];+        end+        ~RESULT <= ~SYM[0][~ARG[7]];+      end~FI+      // blockRam1 end
+ prims/verilog/Clash_Explicit_BlockRam_Blob.primitives.yaml view
@@ -0,0 +1,49 @@+- BlackBox:+    name: Clash.Explicit.BlockRam.Blob.blockRamBlob#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      blockRamBlob#+        :: KnownDomain dom           --       ARG[0]+        => Clock dom                 -- clk,  ARG[1]+        -> Enable dom                -- en,   ARG[2]+        -> MemBlob n m               -- init, ARG[3]+        -> Signal dom Int            -- rd,   ARG[4]+        -> Signal dom Bool           -- wren, ARG[5]+        -> Signal dom Int            -- wr,   ARG[6]+        -> Signal dom (BitVector m)  -- din,  ARG[7]+        -> Signal dom (BitVector m)+    template: |-+      // blockRamBlob begin+      reg ~TYPO ~GENSYM[~RESULT_RAM][1] [0:~LENGTH[~TYP[3]]-1];++      reg ~TYP[3] ~GENSYM[ram_init][3];+      integer ~GENSYM[i][4];+      initial begin+        ~SYM[3] = ~CONST[3];+        for (~SYM[4]=0; ~SYM[4] < ~LENGTH[~TYP[3]]; ~SYM[4] = ~SYM[4] + 1) begin+          ~SYM[1][~LENGTH[~TYP[3]]-1-~SYM[4]] = ~SYM[3][~SYM[4]*~SIZE[~TYPO]+:~SIZE[~TYPO]];+        end+      end+      ~IF ~ISACTIVEENABLE[2] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~GENSYM[~RESULT_blockRam][5]~IF ~VIVADO ~THEN+        if (~ARG[2]) begin+          if (~ARG[5]) begin+            ~SYM[1][~ARG[6]] <= ~ARG[7];+          end+          ~RESULT <= ~SYM[1][~ARG[4]];+        end~ELSE+        if (~ARG[5] & ~ARG[2]) begin+          ~SYM[1][~ARG[6]] <= ~ARG[7];+        end+        if (~ARG[2]) begin+          ~RESULT <= ~SYM[1][~ARG[4]];+        end~FI+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~SYM[5]+        if (~ARG[5]) begin+          ~SYM[1][~ARG[6]] <= ~ARG[7];+        end+        ~RESULT <= ~SYM[1][~ARG[4]];+      end~FI+      // blockRamBlob end
+ prims/verilog/Clash_Explicit_BlockRam_File.primitives.yaml view
@@ -0,0 +1,47 @@+- BlackBox:+    name: Clash.Explicit.BlockRam.File.blockRamFile#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      blockRamFile#+        :: ( KnownDomain dom         --       ARG[0]+           , KnownNat m              --       ARG[1]+           , HasCallStack )          --       ARG[2]+        => Clock dom                 -- clk,  ARG[3]+        => Enable dom                -- en,   ARG[4]+        -> SNat n                    -- sz,   ARG[5]+        -> FilePath                  -- file, ARG[6]+        -> Signal dom Int            -- rd,   ARG[7]+        -> Signal dom Bool           -- wren, ARG[8]+        -> Signal dom Int            -- wr,   ARG[9]+        -> Signal dom (BitVector m)  -- din,  ARG[10]+        -> Signal dom (BitVector m)+    template: |-+      // blockRamFile begin+      reg ~TYPO ~GENSYM[RAM][1] [0:~LIT[5]-1];++      initial begin+        $readmemb(~FILE[~LIT[6]],~SYM[1]);+      end+      ~IF ~ISACTIVEENABLE[4] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_blockRamFile][3]~IF ~VIVADO ~THEN+        if (~ARG[4]) begin+          if (~ARG[8]) begin+            ~SYM[1][~ARG[9]] <= ~ARG[10];+          end+          ~RESULT <= ~SYM[1][~ARG[7]];+        end~ELSE+        if (~ARG[8] & ~ARG[4]) begin+          ~SYM[1][~ARG[9]] <= ~ARG[10];+        end+        if (~ARG[4]) begin+          ~RESULT <= ~SYM[1][~ARG[7]];+        end~FI+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3]+        if (~ARG[8]) begin+          ~SYM[1][~ARG[9]] <= ~ARG[10];+        end+        ~RESULT <= ~SYM[1][~ARG[7]];+      end~FI+      // blockRamFile end
+ prims/verilog/Clash_Explicit_DDR.primitives.yaml view
@@ -0,0 +1,95 @@+- BlackBox:+    name: Clash.Explicit.DDR.ddrIn#+    kind: Declaration+    type: |-+      ddrIn# :: forall a dom domDDR+              . HasCallStack             -- ARG[0]+             => NFDataX a                -- ARG[1]+             => KnownDomain dom          -- ARG[2]+             => KnownDomain domDDR       -- ARG[3]+             => DomPeriod ~ 2 * ...      -- ARG[4]+             => Clock dom                -- ARG[5]+             -> Reset dom                -- ARG[6]+             -> Enable dom               -- ARG[7]+             -> a                        -- ARG[8]+             -> a                        -- ARG[9]+             -> a                        -- ARG[10]+             -> Signal domDDR a          -- ARG[11]+             -> Signal dom (a,a)+    template: |-+      // ddrIn begin+      reg ~SIGD[~GENSYM[data_Pos][1]][11];+      reg ~SIGD[~GENSYM[data_Neg][2]][11];+      reg ~SIGD[~GENSYM[data_Neg_Latch][3]][11];+      always @(~IF~ACTIVEEDGE[Rising][2]~THENposedge~ELSEnegedge~FI ~ARG[5]~IF~ISSYNC[2]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[6])~FI begin : ~GENSYM[~COMPNAME_ddrIn_pos][6]+        if (~IF~ISACTIVEHIGH[2]~THEN~ARG[6]~ELSE! ~ARG[6]~FI) begin+          ~SYM[1] <= ~ARG[9];+        end else ~IF ~ISACTIVEENABLE[7] ~THEN if (~ARG[7]) ~ELSE ~FI begin+          ~SYM[1] <= ~ARG[11];+        end+      end+      always @(~IF~ACTIVEEDGE[Rising][2]~THENnegedge~ELSEposedge~FI ~ARG[5]~IF~ISSYNC[2]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[6])~FI begin : ~GENSYM[~COMPNAME_ddrIn_neg][7]+        if (~IF~ISACTIVEHIGH[2]~THEN~ARG[6]~ELSE! ~ARG[6]~FI) begin+          ~SYM[2] <= ~ARG[10];+        end else ~IF ~ISACTIVEENABLE[7] ~THEN if (~ARG[7]) ~ELSE ~FI begin+          ~SYM[2] <= ~ARG[11];+        end+      end+      always @(~IF~ACTIVEEDGE[Rising][2]~THENposedge~ELSEnegedge~FI ~ARG[5]~IF~ISSYNC[2]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[6])~FI begin : ~GENSYM[~COMPNAME_ddrIn_neg_latch][8]+        if (~IF~ISACTIVEHIGH[2]~THEN~ARG[6]~ELSE! ~ARG[6]~FI) begin+          ~SYM[3] <= ~ARG[8];+        end else ~IF ~ISACTIVEENABLE[7] ~THEN if (~ARG[7]) ~ELSE ~FI begin+          ~SYM[3] <= ~SYM[2];+        end+      end++      assign ~RESULT = {~SYM[3], ~SYM[1]};+      // ddrIn end+- BlackBox:+    name: Clash.Explicit.DDR.ddrOut#+    kind: Declaration+    type: |-+      ddrOut# :: forall a dom domDDR+               . HasCallStack                 -- ARG[0]+              => NFDataX a                    -- ARG[1]+              => KnownDomain dom              -- ARG[2]+              => KnownDomain domDDR           -- ARG[3]+              => DomPeriod ~ 2 * ...          -- ARG[4]+              => Clock dom                    -- ARG[5]+              -> Reset dom                    -- ARG[6]+              -> Enable dom                   -- ARG[7]+              -> a                            -- ARG[8]+              -> Signal dom a                 -- ARG[9]+              -> Signal dom a                 -- ARG[10]+              -> Signal domDDR a+    template: |-+      // ddrOut begin+      reg ~SIGD[~GENSYM[data_Pos][1]][8];+      reg ~SIGD[~GENSYM[data_Neg][2]][8];+      ~IF ~VIVADO ~THENreg ~SIGDO[~GENSYM[ddrOut][3]];~ELSE~FI+      always @(~IF~ACTIVEEDGE[Rising][2]~THENposedge~ELSEnegedge~FI ~ARG[5]~IF~ISSYNC[2]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[6])~FI begin : ~GENSYM[~COMPNAME_ddrOut_pos][5]+        if (~IF~ISACTIVEHIGH[2]~THEN~ARG[6]~ELSE! ~ARG[6]~FI) begin+          ~SYM[1] <= ~ARG[8];+        end else ~IF ~ISACTIVEENABLE[7] ~THEN if (~ARG[7]) ~ELSE ~FI begin+          ~SYM[1] <= ~ARG[9];+        end+      end+      always @(~IF~ACTIVEEDGE[Rising][2]~THENposedge~ELSEnegedge~FI ~ARG[5]~IF~ISSYNC[2]~THEN)~ELSE or ~IF~ISACTIVEHIGH[2]~THENposedge~ELSEnegedge~FI ~ARG[6])~FI begin : ~GENSYM[~COMPNAME_ddrOut_neg][6]+        if (~IF~ISACTIVEHIGH[2]~THEN~ARG[6]~ELSE! ~ARG[6]~FI) begin+          ~SYM[2] <= ~ARG[8];+        end else ~IF ~ISACTIVEENABLE[7] ~THEN if (~ARG[7]) ~ELSE ~FI begin+          ~SYM[2] <= ~ARG[10];+        end+      end++      ~IF ~VIVADO ~THENalways @(*) begin+        if (~ARG[5]) begin+          ~SYM[3] = ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[1]~ELSE~SYM[2]~FI;+        end else begin+          ~SYM[3] = ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[2]~ELSE~SYM[1]~FI;+        end+      end+      assign ~RESULT = ~SYM[3];~ELSE+      assign ~RESULT = ~ARG[5] ? ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[1] : ~SYM[2]~ELSE~SYM[2] : ~SYM[1]~FI;~FI++      // ddrOut end
+ prims/verilog/Clash_Explicit_RAM.primitives.yaml view
@@ -0,0 +1,29 @@+- BlackBox:+    name: Clash.Explicit.RAM.asyncRam#+    kind: Declaration+    type: |-+      asyncRam#+        :: ( HasCallStack      --         ARG[0]+           , KnownDomain wdom  --         ARG[1]+           , KnownDomain rdom  --         ARG[2]+           , NFDataX a )       --         ARG[3]+        => Clock wdom          -- ^ wclk, ARG[4]+        -> Clock rdom          -- ^ rclk, ARG[5]+        -> Enable wdom         -- ^ wen,  ARG[6]+        -> SNat n              -- ^ sz,   ARG[7]+        -> Signal rdom Int     -- ^ rd,   ARG[8]+        -> Signal wdom Bool    -- ^ en,   ARG[9]+        -> Signal wdom Int     -- ^ wr,   ARG[10]+        -> Signal wdom a       -- ^ din,  ARG[11]+        -> Signal rdom a+    template: |-+      // asyncRam begin+      reg ~TYPO ~GENSYM[RAM][0] [0:~LIT[7]-1];+      always @(~IF~ACTIVEEDGE[Rising][1]~THENposedge~ELSEnegedge~FI ~ARG[4]) begin : ~GENSYM[~COMPNAME_Ram][1]+        if (~ARG[9] ~IF ~ISACTIVEENABLE[6] ~THEN & ~ARG[6] ~ELSE ~FI) begin+          ~SYM[0][~ARG[10]] <= ~ARG[11];+        end+      end++      assign ~RESULT = ~SYM[0][~ARG[8]];+      // asyncRam end
+ prims/verilog/Clash_Explicit_ROM.primitives.yaml view
@@ -0,0 +1,35 @@+- BlackBox:+    name: Clash.Explicit.ROM.rom#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      rom# :: ( KnownDomain dom        ARG[0]+               , KnownNat n    --       ARG[1]+               , NFDataX a )   --       ARG[2]+            => Clock dom       -- clk,  ARG[3]+            -> Enable dom      -- en,   ARG[4]+            -> Vec n a         -- init, ARG[5]+            -> Signal dom Int  -- rd,   ARG[6]+            -> Signal dom a+    template: |-+      // rom begin+      reg ~TYPO ~GENSYM[ROM][1] [0:~LIT[1]-1];++      reg ~TYP[5] ~GENSYM[rom_init][3];+      integer ~GENSYM[i][4];+      initial begin+        ~SYM[3] = ~LIT[5];+        for (~SYM[4]=0; ~SYM[4] < ~LIT[1]; ~SYM[4] = ~SYM[4] + 1) begin+          ~SYM[1][~LIT[1]-1-~SYM[4]] = ~SYM[3][~SYM[4]*~SIZE[~TYPO]+:~SIZE[~TYPO]];+        end+      end+      ~IF ~ISACTIVEENABLE[4] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_rom][5]+        if (~ARG[4]) begin+          ~RESULT <= ~SYM[1][~ARG[6]];+        end+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[5]+        ~RESULT <= ~SYM[1][~ARG[6]];+      end~FI+      // rom end
+ prims/verilog/Clash_Explicit_ROM_Blob.primitives.yaml view
@@ -0,0 +1,34 @@+- BlackBox:+    name: Clash.Explicit.ROM.Blob.romBlob#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      romBlob#+        :: KnownDomain dom  --       ARG[0]+        => Clock dom        -- clk,  ARG[1]+        -> Enable dom       -- en,   ARG[2]+        -> MemBlob n m      -- init, ARG[3]+        -> Signal dom Int   -- rd,   ARG[4]+        -> Signal dom (BitVector m)+    template: |-+      // romBlob begin+      reg ~TYPO ~GENSYM[ROM][1] [0:~LENGTH[~TYP[3]]-1];++      reg ~TYP[3] ~GENSYM[rom_init][3];+      integer ~GENSYM[i][4];+      initial begin+        ~SYM[3] = ~CONST[3];+        for (~SYM[4]=0; ~SYM[4] < ~LENGTH[~TYP[3]]; ~SYM[4] = ~SYM[4] + 1) begin+          ~SYM[1][~LENGTH[~TYP[3]]-1-~SYM[4]] = ~SYM[3][~SYM[4]*~SIZE[~TYPO]+:~SIZE[~TYPO]];+        end+      end+      ~IF ~ISACTIVEENABLE[2] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~GENSYM[~COMPNAME_rom][5]+        if (~ARG[2]) begin+          ~RESULT <= ~SYM[1][~ARG[4]];+        end+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[1]) begin : ~SYM[5]+        ~RESULT <= ~SYM[1][~ARG[4]];+      end~FI+      // romBlob end
+ prims/verilog/Clash_Explicit_ROM_File.primitives.yaml view
@@ -0,0 +1,30 @@+- BlackBox:+    name: Clash.Explicit.ROM.File.romFile#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      romFile# :: ( KnownNat m             --       ARG[0]+                   , KnownDomain dom      ) --       ARG[1]+                => Clock dom                -- clk,  ARG[2]+                -> Enable dom               -- en,   ARG[3]+                -> SNat n                   -- sz,   ARG[4]+                -> FilePath                 -- file, ARG[5]+                -> Signal dom Int           -- rd,   ARG[6]+                -> Signal dom (BitVector m)+    template: |-+      // romFile begin+      reg ~TYPO ~GENSYM[ROM][0] [0:~LIT[4]-1];++      initial begin+        $readmemb(~FILE[~LIT[5]],~SYM[0]);+      end+      ~IF ~ISACTIVEENABLE[3] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][1]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~GENSYM[~COMPNAME_romFile][2]+        if (~ARG[3]) begin+          ~RESULT <= ~SYM[0][~ARG[6]];+        end+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][1]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~SYM[2]+        ~RESULT <= ~SYM[0][~ARG[6]];+      end~FI+      // romFile end
+ prims/verilog/Clash_Explicit_Testbench.primitives.yaml view
@@ -0,0 +1,61 @@+- BlackBox:+    name: Clash.Explicit.Testbench.assert+    kind: Declaration+    type: |-+      assert+        :: (KnownDomain dom, Eq a, ShowX a)      -- (ARG[0], ARG[1], ARG[2])+        => Clock dom                             -- ARG[3]+        -> Reset dom                             -- ARG[4]+        -> String                                -- ARG[5]+        -> Signal dom a                          -- Checked value  (ARG[6])+        -> Signal dom a                          -- Expected value (ARG[7])+        -> Signal dom b                          -- Return valued  (ARG[8])+        -> Signal dom b+    template: |-+      // assert begin+      // pragma translate_off+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin+        if (~VAR[checked][6] !== ~VAR[expected][7]) begin+          $display("@%0tns: %s, expected: %b, actual: %b", $time, ~LIT[5], ~VAR[expected][7], ~VAR[checked][6]);+          `ifdef VERILATOR+            $c("std::exit(1);");+          `endif+          $finish;+        end+      end+      // pragma translate_on+      assign ~RESULT = ~ARG[8];+      // assert end+- BlackBox:+    name: Clash.Explicit.Testbench.assertBitVector+    kind: Declaration+    type: |-+      assertBitVector+        :: ( KnownDomain dom        --                 ARG[0]+           , KnownNat n             --                 ARG[1]+        => Clock dom                --                 ARG[2]+        -> Reset dom                --                 ARG[3]+        -> String                   --                 ARG[4]+        -> Signal dom (BitVector n) -- Checked value  (ARG[5])+        -> Signal dom (BitVector n) -- Expected value (ARG[6])+        -> Signal dom b             -- Return valued  (ARG[7])+        -> Signal dom b+    template: |-+      // assertBitVector begin+      // pragma translate_off+      wire ~TYP[5] ~GENSYM[maskXor][0]  = ~ARG[6] ^ ~ARG[6];+      wire ~TYP[5] ~GENSYM[checked][1]  = ~ARG[5] ^ ~SYM[0];+      wire ~TYP[5] ~GENSYM[expected][2] = ~ARG[6] ^ ~SYM[0];++      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin+        if (~SYM[1] !== ~SYM[2]) begin+          $display("@%0tns: %s, expected: %b, actual: %b", $time, ~LIT[4], ~VAR[expected][6], ~VAR[checked][5]);+          `ifdef VERILATOR+            $c("std::exit(1);");+          `endif+          $finish;+        end+      end+      // pragma translate_on+      assign ~RESULT = ~ARG[7];+      // assertBitVector end
+ prims/verilog/Clash_Intel_DDR.primitives.yaml view
@@ -0,0 +1,49 @@+- BlackBox:+    name: Clash.Intel.DDR.altddioIn#+    kind: Declaration+    libraries:+    - altera_mf+    type: |-+      altddioIn#+        :: forall deviceFamily n dom domDDR+         . HasCallStack                 -- ARG[0]+        => KnownDomain dom              -- ARG[1]+        => KnownDomain domDDR           -- ARG[2]+        => DomPeriod ~ 2 * ...          -- ARG[3]+        => DomEdge ~ Rising             -- ARG[4]+        => KnownNat n                   -- ARG[5]+        => SSymbol deviceFamily         -- ARG[6]+        -> Clock dom                    -- ARG[7]+        -> Reset dom                    -- ARG[8]+        -> Enable dom                   -- ARG[9]+        -> Signal domDDR (BitVector n)  -- ARG[10]+        -> Signal dom (BitVector n, BitVector n)+    template: |-+      // altddioIn begin+      wire ~SIGD[~GENSYM[dataout_l][1]][10];+      wire ~SIGD[~GENSYM[dataout_h][2]][10];++      altddio_in+        #(+          .intended_device_family (~LIT[6]),+          .invert_input_clocks ("OFF"),+          .lpm_hint ("UNUSED"),+          .lpm_type ("altddio_in"),+          .power_up_high ("OFF"),+          .width (~SIZE[~TYP[10]])+        )+        ~GENSYM[~COMPNAME_ALTDDIO_IN][7] (~IF ~ISSYNC[1] ~THEN+          .sclr (~ARG[8]),+          .aclr (1'b0),~ELSE+          .aclr (~ARG[8]),+          .sclr (1'b0),~FI+          .datain (~ARG[10]),+          .inclock (~ARG[7]),+          .inclocken (~IF ~ISACTIVEENABLE[9] ~THEN ~ARG[9] ~ELSE 1'b1 ~FI),+          .dataout_h (~SYM[2]),+          .dataout_l (~SYM[1]),+          .aset (1'b0),+          .sset (1'b0)+        );+      assign ~RESULT = {~SYM[1],~SYM[2]};+      // altddioIn end
+ prims/verilog/Clash_Prelude_ROM.primitives.yaml view
@@ -0,0 +1,25 @@+- BlackBox:+    name: Clash.Prelude.ROM.asyncRom#+    kind: Declaration+    type: |-+      asyncRom#+        :: ( KnownNat n  -- ARG[0]+           , NFDataX a)  -- ARG[1]+        => Vec n a       -- ARG[2]+        -> Int           -- ARG[3]+        -> a+    template: |-+      // asyncRom begin+      wire ~TYPO ~GENSYM[ROM][0] [0:~LIT[0]-1];++      wire ~TYP[2] ~GENSYM[romflat][1];+      assign ~SYM[1] = ~CONST[2];+      genvar ~GENSYM[i][2];+      ~GENERATE+      for (~SYM[2]=0; ~SYM[2] < ~LIT[0]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3]+        assign ~SYM[0][(~LIT[0]-1)-~SYM[2]] = ~SYM[1][~SYM[2]*~SIZE[~TYPO]+:~SIZE[~TYPO]];+      end+      ~ENDGENERATE++      assign ~RESULT = ~SYM[0][~ARG[3]];+      // asyncRom end
+ prims/verilog/Clash_Prelude_ROM_Blob.primitives.yaml view
@@ -0,0 +1,23 @@+- BlackBox:+    name: Clash.Prelude.ROM.Blob.asyncRomBlob#+    kind: Declaration+    type: |-+      asyncRomBlob#+        :: MemBlob n m  -- ARG[0]+        -> Int          -- ARG[1]+        -> BitVector m+    template: |-+      // asyncRomBlob begin+      wire ~TYPO ~GENSYM[ROM][0] [0:~LENGTH[~TYP[0]]-1];++      wire ~TYP[0] ~GENSYM[romflat][1];+      assign ~SYM[1] = ~CONST[0];+      genvar ~GENSYM[i][2];+      ~GENERATE+      for (~SYM[2]=0; ~SYM[2] < ~LENGTH[~TYP[0]]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3]+        assign ~SYM[0][(~LENGTH[~TYP[0]]-1)-~SYM[2]] = ~SYM[1][~SYM[2]*~SIZE[~TYPO]+:~SIZE[~TYPO]];+      end+      ~ENDGENERATE++      assign ~RESULT = ~SYM[0][~ARG[1]];+      // asyncRomBlob end
+ prims/verilog/Clash_Prelude_ROM_File.primitives.yaml view
@@ -0,0 +1,19 @@+- BlackBox:+    name: Clash.Prelude.ROM.File.asyncRomFile#+    kind: Declaration+    type: |-+      asyncRomFile :: KnownNat m -- ARG[0]+                    => SNat n     -- sz,   ARG[1]+                    -> FilePath   -- file, ARG[2]+                    -> Int        -- rd,   ARG[3]+                    -> BitVector m+    template: |-+      // asyncRomFile begin+      reg ~TYPO ~GENSYM[ROM][0] [0:~LIT[1]-1];++      initial begin+        $readmemb(~FILE[~LIT[2]],~SYM[0]);+      end++      assign ~RESULT = ~SYM[0][~ARG[3]];+      // asyncRomFile end
+ prims/verilog/Clash_Signal_BiSignal.primitives.yaml view
@@ -0,0 +1,30 @@+- BlackBox:+    name: Clash.Signal.BiSignal.writeToBiSignal#+    kind: Declaration+    type: |-+      writeToBiSignal#+        :: HasCallStack                   -- ARG[0]+        => BiSignalIn ds d n              -- ARG[1]+        -> Signal d (Maybe (BitVector n)) -- ARG[2]+        -> Signal d Bool                  -- ARG[3]+        -> Signal d (BitVector n)         -- ARG[4]+        -> BiSignalOut ds d n+    renderVoid: RenderVoid+    template: |-+      // writeToBiSignal# begin+      assign ~ARG[1] = (~ARG[3] == 1'b1) ? ~ARG[4] : {~SIZE[~TYP[1]] {1'bz}};+      // writeToBiSignal# end+- BlackBox:+    name: Clash.Signal.BiSignal.readFromBiSignal#+    kind: Declaration+    type: |-+      readFromBiSignal#+        :: ( HasCallStack    -- ARG[0]+           , KnownNat n)     -- ARG[1]+        => BiSignalIn ds d n -- ARG[2]+        -> Signal d (BitVector n)+    template: |-+      // readFromBiSignal begin+      assign ~RESULT = ~ARG[2];+      // readFromBiSignal end+    workInfo: Never
+ prims/verilog/Clash_Signal_Internal.primitives.yaml view
@@ -0,0 +1,183 @@+- BlackBox:+    name: Clash.Signal.Internal.delay#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      delay#+        :: ( KnownDomain dom        -- ARG[0]+           , NFDataX a )            -- ARG[1]+        => Clock dom                -- ARG[2]+        -> Enable dom               -- ARG[3]+        -> a                        -- ARG[4]+        -> Signal clk a             -- ARG[5]+        -> Signal clk a+    resultInit:+      template: ~IF~ISINITDEFINED[0]~THEN~CONST[4]~ELSE~FI+    resultName:+      template: ~CTXNAME+    template: |-+      // delay begin~IF ~ISACTIVEENABLE[3] ~THEN+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~GENSYM[~RESULT_delay][1]+        if (~ARG[3]) begin+          ~RESULT <= ~ARG[5];+        end+      end~ELSE+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~SYM[1]+        ~RESULT <= ~ARG[5];+      end~FI+      // delay end+- BlackBox:+    name: Clash.Signal.Internal.asyncRegister#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      asyncRegister#+        :: ( KnownDomain dom        -- ARG[0]+           , NFDataX a )            -- ARG[1]+        => Clock dom                -- ARG[2]+        -> Reset dom                -- ARG[3]+        -> Enable dom               -- ARG[4]+        -> a                        -- ARG[5] (powerup value)+        -> a                        -- ARG[6] (reset value)+        -> Signal clk a             -- ARG[7]+        -> Signal clk a+    resultInit:+      template: ~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI+    resultName:+      template: ~CTXNAME+    template: |-+      // async register begin+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]~IF ~ISUNDEFINED[6] ~THEN ~ELSE or ~IF ~ISACTIVEHIGH[0] ~THEN posedge ~ELSE negedge ~FI ~VAR[rst][3]~FI) begin : ~GENSYM[~RESULT_register][1]+        ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI~VAR[rst][3]) begin+          ~RESULT <= ~CONST[6];+        end else ~FI~IF ~ISACTIVEENABLE[4] ~THENif (~ARG[4]) ~ELSE~FIbegin+          ~RESULT <= ~ARG[7];+        end+      end+      // async register end+- BlackBox:+    name: Clash.Signal.Internal.register#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      register#+        :: ( KnownDomain dom        -- ARG[0]+           , NFDataX a )            -- ARG[1]+        => Clock dom                -- ARG[2]+        -> Reset dom                -- ARG[3]+        -> Enable dom               -- ARG[4]+        -> a                        -- ARG[5] (powerup value)+        -> a                        -- ARG[6] (reset value)+        -> Signal clk a             -- ARG[7]+        -> Signal clk a+    resultInit:+      template: ~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI+    resultName:+      template: ~CTXNAME+    template: |-+      // register begin+      always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]~IF ~ISSYNC[0] ~THEN ~ELSE~IF ~ISUNDEFINED[6] ~THEN ~ELSE or ~IF ~ISACTIVEHIGH[0] ~THEN posedge ~ELSE negedge ~FI ~VAR[rst][3]~FI~FI) begin : ~GENSYM[~RESULT_register][1]+        ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI~VAR[rst][3]) begin+          ~RESULT <= ~CONST[6];+        end else ~FI~IF ~ISACTIVEENABLE[4] ~THENif (~ARG[4]) ~ELSE~FIbegin+          ~RESULT <= ~ARG[7];+        end+      end+      // register end+- BlackBox:+    name: Clash.Signal.Internal.tbClockGen+    kind: Declaration+    type: |-+      tbClockGen+        :: KnownDomain dom     -- ARG[0]+        => Signal dom Bool     -- ARG[1]+        -> Clock dom+    template: |-+      // ~IF~ISACTIVEENABLE[1]~THENtbClockGen~ELSEclockGen~FI begin+      // pragma translate_off+      reg ~TYPO ~GENSYM[clk][0];+      // 1 = 0.1ps+      localparam ~GENSYM[half_period][1] = (~PERIOD[0]0 / 2);+      always begin+        // Delay of 1 mitigates race conditions (https://github.com/steveicarus/iverilog/issues/160)+        #1 ~SYM[0] = ~IF~ACTIVEEDGE[Rising][0]~THEN 0 ~ELSE 1 ~FI;+        #~LONGESTPERIOD0 forever begin+          ~IF~ISACTIVEENABLE[1]~THEN+          if (~ ~ARG[1]) begin+            `ifdef VERILATOR+              $c("std::exit(0);");+            `endif+            $finish(0);+          end+          ~ELSE~FI+          ~SYM[0] = ~ ~SYM[0];+          #~SYM[1];+          ~SYM[0] = ~ ~SYM[0];+          #~SYM[1];+        end+      end++      assign ~RESULT = ~SYM[0];+      // pragma translate_on+      // tbClockGen end+    warning: Clash.Signal.Internal.tbClockGen is not synthesizable!+    workInfo: Always+- BlackBox:+    name: Clash.Signal.Internal.tbDynamicClockGen+    kind: Declaration+    type: |-+      clockGen+        :: KnownDomain dom     -- ARG[0]+        -> Signal dom Int64    -- ARG[1]+        -> Signal dom Bool     -- ARG[2]+        => Clock dom+    template: |-+      // tbDynamicClockGen begin+      // pragma translate_off+      reg ~TYPO ~GENSYM[clk][0];+      time ~GENSYM[half_period][1];+      always begin+        // Delay of 1 mitigates race conditions (https://github.com/steveicarus/iverilog/issues/160)+        #1 ~SYM[0] = ~IF~ACTIVEEDGE[Rising][0]~THEN 0 ~ELSE 1 ~FI;+        #~LONGESTPERIOD0 forever begin+          ~IF~ISACTIVEENABLE[2]~THEN+          if (~ ~ARG[2]) begin+            `ifdef VERILATOR+              $c("std::exit(0);");+            `endif+            $finish(0);+          end+          ~ELSE~FI+          // 1 = 0.1ps+          ~SYM[1] = (~VAR[periods][1] / 2);++          ~SYM[0] = ~ ~SYM[0];+          #(~SYM[1] * 0.01);+          ~SYM[0] = ~ ~SYM[0];+          #(~SYM[1] * 0.01);+        end+      end++      assign ~RESULT = ~SYM[0];+      // pragma translate_on+      // tbDynamicClockGen end+    warning: Clash.Signal.Internal.tbDynamicClockGen is not synthesizable!+    workInfo: Always+- BlackBox:+    name: Clash.Signal.Internal.resetGenN+    kind: Declaration+    type: 'resetGenN :: (KnownDomain+      dom, 1 <= n) => SNat n -> Reset dom'+    template: |-+      // resetGen begin+      // pragma translate_off+      reg ~TYPO ~GENSYM[rst][0];+      localparam ~GENSYM[reset_period][1] = ~LONGESTPERIOD0 - 10 + (~LIT[2] * ~PERIOD[0]0);+      initial begin+        #1 ~SYM[0] = ~IF ~ISACTIVEHIGH[0] ~THEN 1 ~ELSE 0 ~FI;+        #~SYM[1] ~SYM[0] = ~IF ~ISACTIVEHIGH[0] ~THEN 0 ~ELSE 1 ~FI;+      end+      assign ~RESULT = ~SYM[0];+      // pragma translate_on+      // resetGen end+    workInfo: Always
+ prims/verilog/Clash_Sized_Internal_BitVector.primitives.yaml view
@@ -0,0 +1,66 @@+- BlackBox:+    name: Clash.Sized.Internal.BitVector.replaceBit#+    kind: Declaration+    outputUsage: Blocking+    type: |-+      replaceBit# :: KnownNat n  -- ARG[0]+                   => BitVector n -- ARG[1]+                   -> Int         -- ARG[2]+                   -> Bit         -- ARG[3]+                   -> BitVector n+    template: |-+      // replaceBit start+      always @(*) begin+        ~RESULT = ~ARG[1];+        ~RESULT[~ARG[2]] = ~VAR[din][3];+      end+      // replaceBit end+- BlackBox:+    name: Clash.Sized.Internal.BitVector.setSlice#+    kind: Declaration+    outputUsage: Blocking+    type: |-+      setSlice# :: SNat (m + 1 + i)+                 -> BitVector (m + 1 + i) -- ARG[1]+                 -> SNat m                -- ARG[2]+                 -> SNat n                -- ARG[3]+                 -> BitVector (m + 1 - n) -- ARG[4]+                 -> BitVector (m + 1 + i)+    template: |-+      // setSlice begin+      always @(*) begin+        ~RESULT = ~ARG[1];+        ~RESULT[~LIT[2] : ~LIT[3]] = ~VAR[din][4];+      end+      // setSlice end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.split#+    kind: Expression+    type: |-+      split# :: KnownNat n        -- ARG[0]+              => BitVector (m + n) -- ARG[1]+              -> (BitVector m, BitVector n)+    template: ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.rotateL#+    kind: Declaration+    type: 'rotateL# :: KnownNat+      n => BitVector n -> Int -> BitVector n'+    template: |-+      // rotateL begin+      wire [2*~SIZE[~TYPO]-1:0] ~GENSYM[bv][0];+      assign ~SYM[0] = {~ARG[1],~ARG[1]} << (~ARG[2] % ~SIZE[~TYPO]);+      assign ~RESULT = ~SYM[0][2*~SIZE[~TYPO]-1 : ~SIZE[~TYPO]];+      // rotateL end+- BlackBox:+    name: Clash.Sized.Internal.BitVector.rotateR#+    kind: Declaration+    type: 'rotateR# :: KnownNat+      n => BitVector n -> Int -> BitVector n'+    template: |-+      // rotateR begin+      wire [2*~SIZE[~TYPO]-1:0] ~GENSYM[bv][0];+      assign ~SYM[0] = {~ARG[1],~ARG[1]} >> (~ARG[2] % ~SIZE[~TYPO]);+      assign ~RESULT = ~SYM[0][~SIZE[~TYPO]-1 : 0];+      // rotateR end
+ prims/verilog/Clash_Sized_Internal_Signed.primitives.yaml view
@@ -0,0 +1,64 @@+- BlackBox:+    name: Clash.Sized.Internal.Signed.div#+    kind: Declaration+    type: 'div# :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: |-+      // divSigned begin+      wire ~GENSYM[resultPos][1];+      wire ~GENSYM[dividerNeg][2];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6];++      assign ~SYM[1] = ~VAR[dividend][1][~SIZE[~TYPO]-1] == ~VAR[divider][2][~SIZE[~TYPO]-1];+      assign ~SYM[2] = ~VAR[divider][2][~SIZE[~TYPO]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][1][~SIZE[~TYPO]-1]},~VAR[dividend][1]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][2][~SIZE[~TYPO]-1]} ,~VAR[divider][2]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]);+      // divSigned end+- BlackBox:+    name: Clash.Sized.Internal.Signed.mod#+    kind: Declaration+    type: 'mod# :: Signed+      n -> Signed n -> Signed n'+    template: |-+      // modSigned begin+      // remainder+      wire ~SIGD[~GENSYM[rem_res][0]][0];+      assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1];++      // modulo+      assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ?+                       ~SYM[0] :+                       (~SYM[0] == ~SIZE[~TYPO]'sd0 ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]);+      // modSigned end+- BlackBox:+    name: Clash.Sized.Internal.Signed.rotateL#+    kind: Declaration+    type: 'rotateL# :: KnownNat+      n => Signed n -> Int -> Signed n'+    template: |-+      // rotateL begin+      wire [2*~SIZE[~TYPO]-1:0] ~GENSYM[s][0];+      assign ~SYM[0] = {~ARG[1],~ARG[1]} << (~ARG[2] % ~SIZE[~TYPO]);+      assign ~RESULT = $signed(~SYM[0][2*~SIZE[~TYPO]-1 : ~SIZE[~TYPO]]);+      // rotateL end+- BlackBox:+    name: Clash.Sized.Internal.Signed.rotateR#+    kind: Declaration+    type: 'rotateR# :: KnownNat+      n => Signed n -> Int -> Signed n'+    template: |-+      // rotateR begin+      wire [2*~SIZE[~TYPO]-1:0] ~GENSYM[s][0];+      assign ~SYM[0] = {~ARG[1],~ARG[1]} >> (~ARG[2] % ~SIZE[~TYPO]);+      assign ~RESULT = $signed(~SYM[0][~SIZE[~TYPO]-1 : 0]);+      // rotateR end
+ prims/verilog/Clash_Sized_Internal_Unsigned.primitives.yaml view
@@ -0,0 +1,22 @@+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.rotateL#+    kind: Declaration+    type: 'rotateL# :: KnownNat+      n => Unsigned n -> Int -> Unsigned n'+    template: |-+      // rotateL begin+      wire [2*~SIZE[~TYPO]-1:0] ~GENSYM[u][0];+      assign ~SYM[0] = {~ARG[1],~ARG[1]} << (~ARG[2] % ~SIZE[~TYPO]);+      assign ~RESULT = ~SYM[0][2*~SIZE[~TYPO]-1 : ~SIZE[~TYPO]];+      // rotateL end+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.rotateR#+    kind: Declaration+    type: 'rotateR# :: KnownNat+      n => Unsigned n -> Int -> Unsigned n'+    template: |-+      // rotateR begin+      wire [2*~SIZE[~TYPO]-1:0] ~GENSYM[u][0];+      assign ~SYM[0] = {~ARG[1],~ARG[1]} >> (~ARG[2] % ~SIZE[~TYPO]);+      assign ~RESULT = ~SYM[0][~SIZE[~TYPO]-1 : 0];+      // rotateR end
+ prims/verilog/Clash_Sized_RTree.primitives.yaml view
@@ -0,0 +1,21 @@+- BlackBox:+    name: Clash.Sized.RTree.treplicate+    kind: Expression+    type: 'replicate :: SNat+      d -> a -> RTree d a'+    template: '{(2**~LIT[0]) {~ARG[1]}}'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.RTree.textract+    kind: Expression+    type: 'textract :: RTree+      0 a -> a'+    template: '~VAR[tree][0][~SIZE[~TYP[0]]-1 -: ~SIZE[~TYPO]]'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.RTree.tsplit+    kind: Expression+    type: 'tsplit:: RTree+      (d+1) a -> (RTree d a,RTree d a)'+    template: ~ARG[0]+    workInfo: Never
+ prims/verilog/Clash_Sized_Vector.primitives.yaml view
@@ -0,0 +1,333 @@+- BlackBox:+    name: Clash.Sized.Vector.head+    kind: Expression+    type: 'head :: Vec (n + 1) a -> a'+    template: '~FROMBV[~VAR[vec][0][\~SIZE[~TYP[0]]-1 -: ~SIZE[~TYPO]\]][~TYPO]'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.tail+    kind: Expression+    type: 'tail :: Vec (n + 1) a -> Vec n a'+    template: '~VAR[vec][0][~SIZE[~TYPO]-1 : 0]'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.last+    kind: Expression+    type: Vec (n + 1) a -> a+    template: ~FROMBV[~VAR[vec][0][\~SIZE[~TYPO]-1:0\]][~TYPO]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.init+    kind: Expression+    type: Vec (n + 1) a -> Vec n a+    template: '~VAR[vec][0][~SIZE[~TYP[0]]-1 : ~SIZE[~TYPEL[~TYP[0]]]]'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.select+    kind: Declaration+    type: |-+      select :: (CmpNat (i + s) (s * n) ~ GT) -- ARG[0]+              => SNat f                        -- ARG[1]+              -> SNat s                        -- ARG[2]+              -> SNat n                        -- ARG[3]+              -> Vec i a                       -- ARG[4]+              -> Vec n a+    template: |-+      // select begin+      wire ~TYPEL[~TYPO] ~SYM[1] [0:~LENGTH[~TYP[4]]-1];+      genvar ~GENSYM[i][2];+      ~GENERATE+      for (~SYM[2]=0; ~SYM[2] < ~LENGTH[~TYP[4]]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3]+        assign ~SYM[1][(~LENGTH[~TYP[4]]-1)-~SYM[2]] = ~VAR[vec][4][~SYM[2]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]];+      end+      ~ENDGENERATE++      genvar ~GENSYM[i][4];+      ~GENERATE+      for (~SYM[4]=0; ~SYM[4] < ~LIT[3]; ~SYM[4] = ~SYM[4] + 1) begin : ~GENSYM[select][5]+        assign ~RESULT[(~LIT[3]-1-~SYM[4])*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[1][~LIT[1] + (~LIT[2] * ~SYM[4])];+      end+      ~ENDGENERATE+      // select end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.+++    kind: Expression+    type: '(++) :: Vec n a -> Vec m a -> Vec (n + m) a'+    template: '{~ARG[0],~ARG[1]}'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.concat+    kind: Expression+    type: 'concat :: Vec n (Vec m a) -> Vec (n * m) a'+    template: ~ARG[0]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.splitAt+    kind: Expression+    type: 'splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)'+    template: ~ARG[1]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.unconcat+    kind: Expression+    type: |-+      unconcat :: KnownNat n     -- ARG[0]+                 => SNat m         -- ARG[1]+                 -> Vec (n * m) a  -- ARG[2]+                 -> Vec n (Vec m a)+    template: ~ARG[2]~DEVNULL[~ARG[0]]~DEVNULL[~ARG[1]]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.map+    kind: Declaration+    type: 'map :: (a -> b) -> Vec n a -> Vec n b'+    template: |-+      // map begin+      genvar ~GENSYM[i][1];+      ~GENERATE+      for (~SYM[1]=0; ~SYM[1] < ~LENGTH[~TYPO]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[map][2]+        localparam ~GENSYM[vec_index][5] = ~MAXINDEX[~TYPO] - ~SYM[1];~IF~SIZE[~TYP[1]]~THEN+        wire ~TYPEL[~TYP[1]] ~GENSYM[map_in][3];+        assign ~SYM[3] = ~VAR[vec][1][~SYM[5]*~SIZE[~TYPEL[~TYP[1]]]+:~SIZE[~TYPEL[~TYP[1]]]];~ELSE ~FI+        ~OUTPUTUSAGE[0] ~TYPEL[~TYPO] ~GENSYM[map_out][4];+        ~INST 0+          ~OUTPUT <= ~SYM[4]~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~SYM[3]~ ~TYPEL[~TYP[1]]~+        ~INST+        assign ~RESULT[~SYM[5]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[4];+      end+      ~ENDGENERATE+      // map end+    workInfo: Identity 1 [0]+- BlackBox:+    name: Clash.Sized.Vector.imap+    kind: Declaration+    type: 'imap :: KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b'+    template: |-+      // imap begin+      genvar ~GENSYM[i][1];+      ~GENERATE+      for (~SYM[1]=0; ~SYM[1] < ~LENGTH[~TYPO]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[imap][2]+        localparam ~GENSYM[vec_index][6] = ~MAXINDEX[~TYPO] - ~SYM[1];+        wire [~SIZE[~INDEXTYPE[~LIT[0]]]-1:0] ~GENSYM[map_index][3];~IF~SIZE[~TYP[2]]~THEN+        wire ~TYPEL[~TYP[2]] ~GENSYM[map_in][4];+        assign ~SYM[4] = ~VAR[vec][2][~SYM[6]*~SIZE[~TYPEL[~TYP[2]]]+:~SIZE[~TYPEL[~TYP[2]]]];~ELSE ~FI+        ~OUTPUTUSAGE[1] ~TYPEL[~TYPO] ~GENSYM[map_out][5];++        assign ~SYM[3] = ~SYM[1][0+:~SIZE[~INDEXTYPE[~LIT[0]]]];+        ~INST 1+          ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~SYM[3]~ ~INDEXTYPE[~LIT[0]]~+          ~INPUT  <= ~SYM[4]~ ~TYPEL[~TYP[2]]~+        ~INST+        assign ~RESULT[~SYM[6]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[5];+      end+      ~ENDGENERATE+      // imap end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.imap_go+    kind: Declaration+    type: 'imap_go :: (Index n -> a -> b) -> Vec m a -> Index n -> Vec m b'+    template: |-+      // imap_go begin+      genvar ~GENSYM[i][1];+      ~GENERATE+      for (~SYM[1]=0; ~SYM[1] < ~LENGTH[~TYPO]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[imap_go][2]+        localparam ~GENSYM[vec_index][6] = ~MAXINDEX[~TYPO] - ~SYM[1];+        wire ~TYP[2] ~GENSYM[map_index][3];~IF~SIZE[~TYP[1]]~THEN+        wire ~TYPEL[~TYP[1]] ~GENSYM[map_in][4];+        assign ~SYM[4] = ~VAR[vec][1][~SYM[6]*~SIZE[~TYPEL[~TYP[1]]]+:~SIZE[~TYPEL[~TYP[1]]]];~ELSE ~FI+        ~OUTPUTUSAGE[0] ~TYPEL[~TYPO] ~GENSYM[map_out][5];++        assign ~SYM[3] = ~SYM[1][0+:~SIZE[~TYP[2]]] + ~ARG[2];+        ~INST 0+          ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~SYM[3]~ ~TYP[2]~+          ~INPUT  <= ~SYM[4]~ ~TYPEL[~TYP[1]]~+        ~INST+        assign ~RESULT[~SYM[6]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[5];+      end+      ~ENDGENERATE+      // imap_go end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.zipWith+    kind: Declaration+    type: 'zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c'+    template: |-+      // zipWith start+      genvar ~GENSYM[i][2];+      ~GENERATE+      for (~SYM[2] = 0; ~SYM[2] < ~LENGTH[~TYPO]; ~SYM[2] = ~SYM[2] + 1) begin : ~GENSYM[zipWith][6]+        localparam ~GENSYM[vec_index][7] = ~MAXINDEX[~TYPO] - ~SYM[2];~IF~SIZE[~TYP[1]]~THEN+        wire ~TYPEL[~TYP[1]] ~GENSYM[zipWith_in1][3];+        assign ~SYM[3] = ~VAR[vec1][1][~SYM[7]*~SIZE[~TYPEL[~TYP[1]]]+:~SIZE[~TYPEL[~TYP[1]]]];~ELSE ~FI~IF~SIZE[~TYP[2]]~THEN+        wire ~TYPEL[~TYP[2]] ~GENSYM[zipWith_in2][4];+        assign ~SYM[4] = ~VAR[vec2][2][~SYM[7]*~SIZE[~TYPEL[~TYP[2]]]+:~SIZE[~TYPEL[~TYP[2]]]];~ELSE ~FI+        ~OUTPUTUSAGE[0] ~TYPEL[~TYPO] ~GENSYM[zip_out][5];+        ~INST 0+          ~OUTPUT <= ~SYM[5]~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~SYM[3]~ ~TYPEL[~TYP[1]]~+          ~INPUT  <= ~SYM[4]~ ~TYPEL[~TYP[2]]~+        ~INST+        assign ~RESULT[~SYM[7]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~SYM[5];+      end+      ~ENDGENERATE+      // zipWith end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.foldr+    kind: Declaration+    type: 'foldr :: (a -> b -> b) -> b -> Vec n a -> b'+    template: |-+      // foldr start~IF ~LENGTH[~TYP[2]] ~THEN+      wire ~TYPO ~GENSYM[intermediate][0] [0:~LENGTH[~TYP[2]]];+      assign ~SYM[0][~LENGTH[~TYP[2]]] = ~ARG[1];++      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0; ~SYM[3] < ~LENGTH[~TYP[2]]; ~SYM[3]=~SYM[3]+1) begin : ~GENSYM[foldr][4]~IF~SIZE[~TYP[2]]~THEN+        localparam ~GENSYM[vec_index][8] = ~MAXINDEX[~TYP[2]] - ~SYM[3];+        wire ~TYPEL[~TYP[2]] ~GENSYM[foldr_in1][5];+        assign ~SYM[5] = ~VAR[xs][2][(~SYM[8])*~SIZE[~TYPEL[~TYP[2]]]+:~SIZE[~TYPEL[~TYP[2]]]];~ELSE ~FI+        wire ~TYPO ~GENSYM[foldr_in2][6];+        ~OUTPUTUSAGE[0] ~TYPO ~GENSYM[foldr_out][7];++        assign ~SYM[6] = ~SYM[0][~SYM[3]+1];+        ~INST 0+          ~OUTPUT <= ~SYM[7]~ ~TYP[1]~+          ~INPUT  <= ~SYM[5]~ ~TYPEL[~TYP[2]]~+          ~INPUT  <= ~SYM[6]~ ~TYP[1]~+        ~INST+        assign ~SYM[0][~SYM[3]] = ~SYM[7];+      end+      ~ENDGENERATE++      assign ~RESULT = ~SYM[0][0];+      ~ELSE+      assign ~RESULT = ~ARG[1];+      ~FI// foldr end+    workInfo: Never+- BlackBoxHaskell:+    name: Clash.Sized.Vector.index_int+    templateFunction: Clash.Primitives.Sized.Vector.indexIntVerilog+- BlackBox:+    name: Clash.Sized.Vector.replace_int+    kind: Declaration+    type: 'replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a'+    template: |-+      // vector replace begin+      genvar ~GENSYM[i][0];+      ~GENERATE+      for (~SYM[0]=0;~SYM[0]<~LENGTH[~TYPO];~SYM[0]=~SYM[0]+1) begin : ~GENSYM[vector_replace][1]+        assign ~RESULT[(~MAXINDEX[~TYPO]-~SYM[0])*~SIZE[~TYP[3]]+:~SIZE[~TYP[3]]] = ~ARG[2] == ~SYM[0] ? ~ARG[3] : ~VAR[vec][1][(~MAXINDEX[~TYPO]-~SYM[0])*~SIZE[~TYP[3]]+:~SIZE[~TYP[3]]];+      end+      ~ENDGENERATE+      // vector replace end+- BlackBox:+    name: Clash.Sized.Vector.maxIndex+    kind: Expression+    type: 'maxIndex :: KnownNat n => Vec n a -> Int'+    template: ~SIZE[~TYPO]'sd~LIT[0] - ~SIZE[~TYPO]'d1+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Vector.length+    kind: Expression+    type: 'length :: KnownNat n => Vec n a -> Int'+    template: ~SIZE[~TYPO]'sd~LIT[0]+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Vector.replicate+    kind: Expression+    type: 'replicate :: SNat n -> a -> Vec n a'+    template: '{~LIT[0] {~ARG[1]}}'+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.transpose+    kind: Declaration+    type: 'transpose :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)'+    template: |-+      // transpose begin+      genvar ~GENSYM[row_index][1];+      genvar ~GENSYM[col_index][2];+      ~GENERATE+      for (~SYM[1] = 0; ~SYM[1] < ~LENGTH[~TYP[1]]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[transpose_outer][3]+        for (~SYM[2] = 0; ~SYM[2] < ~LENGTH[~TYPO]; ~SYM[2] = ~SYM[2] + 1) begin : ~GENSYM[transpose_inner][4]+          assign ~RESULT[((~SYM[2]*~SIZE[~TYPEL[~TYPO]])+(~SYM[1]*~SIZE[~TYPEL[~TYPEL[~TYPO]]]))+:~SIZE[~TYPEL[~TYPEL[~TYPO]]]] = ~VAR[matrix][1][((~SYM[1]*~SIZE[~TYPEL[~TYP[1]]])+(~SYM[2]*~SIZE[~TYPEL[~TYPEL[~TYPO]]]))+:~SIZE[~TYPEL[~TYPEL[~TYPO]]]];+        end+      end+      ~ENDGENERATE+      // transpose end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.reverse+    kind: Declaration+    type: 'reverse :: Vec n a -> Vec n a'+    template: |-+      // reverse begin+      genvar ~GENSYM[i][1];+      ~GENERATE+      for (~SYM[1] = 0; ~SYM[1] < ~LENGTH[~TYPO]; ~SYM[1] = ~SYM[1] + 1) begin : ~GENSYM[reverse][2]+        assign ~RESULT[(~LENGTH[~TYPO] - 1 - ~SYM[1])*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]] = ~VAR[vec][0][~SYM[1]*~SIZE[~TYPEL[~TYPO]]+:~SIZE[~TYPEL[~TYPO]]];+      end+      ~ENDGENERATE+      // reverse end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.concatBitVector#+    kind: Expression+    type: |-+      concatBitVector# :: (KnownNat n, KnownNat m) -- (ARG[0],ARG[1])+                        => Vec n (BitVector m)      -- ARG[2]+                        -> BitVector (n * m)+    template: ~ARG[2]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.unconcatBitVector#+    kind: Expression+    type: |-+      unconcatBitVector# :: (KnownNat n, KnownNat m) -- (ARG[0],ARG[1])+                          => BitVector (n * m)        -- ARG[2]+                          -> Vec n (BitVector m)+    template: ~ARG[2]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.rotateLeftS+    kind: Declaration+    type: 'rotateLeftS :: KnownNat n => Vec n a -> SNat d -> Vec n a'+    template: |-+      // rotateLeftS begin+      localparam ~GENSYM[shift_amount][2] = ~LIT[2] % ~LIT[0];++      ~GENERATE+      if (~SYM[2] == 0) begin : ~GENSYM[no_shift][3]+        assign ~RESULT = ~VAR[vec][1];+      end else begin : ~GENSYM[do_shift][4]+        assign ~RESULT = {~VAR[vec][1][((~LIT[0]-~SYM[2])*~SIZE[~TYPEL[~TYPO]])-1 : 0]+                         ,~VAR[vec][1][~SIZE[~TYPO]-1 : (~LIT[0]-~SYM[2])*~SIZE[~TYPEL[~TYPO]]]+                         };+      end+      ~ENDGENERATE+      // rotateLeftS end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.rotateRightS+    kind: Declaration+    type: 'rotateRightS :: KnownNat n => Vec n a -> SNat d -> Vec n a'+    template: |-+      // rotateRightS begin+      localparam ~GENSYM[shift_amount][2] = ~LIT[2] % ~LIT[0];++      ~GENERATE+      if (~SYM[2] == 0) begin : ~GENSYM[no_shift][3]+        assign ~RESULT = ~VAR[vec][1];+      end else begin : ~GENSYM[do_shift][4]+        assign ~RESULT = {~VAR[vec][1][(~SYM[2]*~SIZE[~TYPEL[~TYPO]])-1 : 0]+                         ,~VAR[vec][1][~SIZE[~TYPO]-1 : ~SYM[2]*~SIZE[~TYPEL[~TYPO]]]+                         };+      end+      ~ENDGENERATE+      // rotateRightS end+    workInfo: Never
+ prims/verilog/Clash_Xilinx_DDR.primitives.yaml view
@@ -0,0 +1,94 @@+- BlackBox:+    name: Clash.Xilinx.DDR.iddr#+    kind: Declaration+    type: |-+      iddr#+        :: forall n dom domDDR+         . HasCallStack                 -- ARG[0]+        => KnownDomain dom              -- ARG[1]+        => KnownDomain domDDR           -- ARG[2]+        => DomPeriod ~ 2 * ...          -- ARG[3]+        => DomEdge ~ Rising             -- ARG[4]+        => KnownNat n                   -- ARG[5]+        => Clock dom                    -- ARG[6]+        -> Reset dom                    -- ARG[7]+        -> Enable dom                   -- ARG[8]+        -> Signal domDDR (BitVector n)  -- ARG[9]+        -> Signal dom (BitVector n, BitVector n)+    template: |-+      // iddr begin+      wire ~SIGD[~GENSYM[data_pos][1]][9];+      wire ~SIGD[~GENSYM[data_neg][2]][9];+      wire ~SIGD[~GENSYM[d][3]][9];+      assign ~SYM[3] = ~ARG[9];++      genvar ~GENSYM[i][8];+      ~GENERATE+      for (~SYM[8]=0; ~SYM[8] < ~SIZE[~TYP[9]]; ~SYM[8]=~SYM[8]+1) begin : ~GENSYM[ddri_array][7]+        IDDR #(+          .DDR_CLK_EDGE("SAME_EDGE"),+          .INIT_Q1(1'b0),+          .INIT_Q2(1'b0),+          .SRTYPE(~IF ~ISSYNC[1] ~THEN "SYNC" ~ELSE "ASYNC" ~FI)+        ) ~GENSYM[~COMPNAME_IDDR][9] (+          .Q1(~SYM[1][~SYM[8]]),+          .Q2(~SYM[2][~SYM[8]]),+          .C(~ARG[6]),+          .CE(~IF ~ISACTIVEENABLE[8] ~THEN ~ARG[8] ~ELSE 1'b1 ~FI),+          .D(~SYM[3][~SYM[8]]),+          .R(~ARG[7]),+          .S(1'b0)+        );+      end+      ~ENDGENERATE++      assign ~RESULT = {~SYM[2],~SYM[1]};+      // iddr end+- BlackBox:+    name: Clash.Xilinx.DDR.oddr#+    kind: Declaration+    type: |-+      oddr#+        :: forall n dom domDDR+         . HasCallStack              -- ARG[0]+        => KnownDomain dom           -- ARG[1]+        => KnownDomain domDDR        -- ARG[2]+        => DomPeriod ~ 2 * ...       -- ARG[3]+        => DomEdge ~ Rising          -- ARG[4]+        => KnownNat n                -- ARG[5]+        => Clock dom                 -- ARG[6]+        -> Reset dom                 -- ARG[7]+        -> Enable dom                -- ARG[8]+        -> Signal dom (BitVector n)  -- ARG[9]+        -> Signal dom (BitVector n)  -- ARG[10]+        -> Signal domDDR (BitVector n)+    template: |-+      // oddr begin+      wire ~SIGD[~GENSYM[data_pos][1]][10];+      wire ~SIGD[~GENSYM[data_neg][2]][10];+      wire ~SIGD[~GENSYM[q][3]][10];++      assign ~SYM[1] = ~ARG[9];+      assign ~SYM[2] = ~ARG[10];++      genvar ~GENSYM[i][8];+      ~GENERATE+      for (~SYM[8]=0; ~SYM[8] < ~SIZE[~TYP[10]]; ~SYM[8]=~SYM[8]+1) begin : ~GENSYM[ddro_array][7]+        ODDR #(+          .DDR_CLK_EDGE("SAME_EDGE"),+          .INIT(1'b0),+          .SRTYPE(~IF ~ISSYNC[1] ~THEN "SYNC" ~ELSE "ASYNC" ~FI)+        ) ~GENSYM[~COMPNAME_ODDR][9] (+          .Q(~SYM[3][~SYM[8]]),+          .C(~ARG[6]),+          .CE(~IF ~ISACTIVEENABLE[8] ~THEN ~ARG[8] ~ELSE 1'b1 ~FI),+          .D1(~SYM[1][~SYM[8]]),+          .D2(~SYM[2][~SYM[8]]),+          .R(~ARG[7]),+          .S(1'b0)+        );+      end+      ~ENDGENERATE++      assign ~RESULT = ~SYM[3];+      // oddr end
+ prims/verilog/GHC_Base.primitives.yaml view
@@ -0,0 +1,42 @@+- BlackBox:+    name: GHC.Base.divInt+    kind: Declaration+    type: 'divInt :: Int ->+      Int -> Int'+    template: |-+      // divInt begin+      wire ~GENSYM[resultPos][1];+      wire ~GENSYM[dividerNeg][2];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6];++      assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+      assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]);+      // divInt end+- BlackBox:+    name: GHC.Base.modInt+    kind: Declaration+    type: 'modInt :: Int ->+      Int -> Int'+    template: |-+      // modInt begin+      // remainder+      wire ~SIGD[~GENSYM[rem_res][0]][0];+      assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1];++      // modulo+      assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ?+                       ~SYM[0] :+                       ((~VAR[dividend][0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]);+      // modInt end
+ prims/verilog/GHC_Classes.primitives.yaml view
@@ -0,0 +1,42 @@+- BlackBox:+    name: GHC.Classes.divInt#+    kind: Declaration+    type: 'divInt# :: Int#+      -> Int# -> Int#'+    template: |-+      // divInt# begin+      wire ~GENSYM[resultPos][1];+      wire ~GENSYM[dividerNeg][2];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6];++      assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+      assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]);+      // divInt# end+- BlackBox:+    name: GHC.Classes.modInt#+    kind: Declaration+    type: 'modInt# :: Int#+      -> Int# -> Int#'+    template: |-+      // modInt# begin+      // remainder+      wire ~SIGD[~GENSYM[rem_res][0]][0];+      assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1];++      // modulo+      assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ?+                       ~SYM[0] :+                       ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]);+      // modInt# end
+ prims/verilog/GHC_Integer_Type.primitives.yaml view
@@ -0,0 +1,102 @@+- BlackBox:+    name: GHC.Integer.Type.divInteger+    kind: Declaration+    type: 'divInteger :: Integer+      -> Integer -> Integer'+    template: |-+      // divInteger begin+      wire ~GENSYM[resultPos][1];+      wire ~GENSYM[dividerNeg][2];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6];++      assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+      assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]);+      // divInteger end+    warning: 'GHC.Integer.Type.divInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.modInteger+    kind: Declaration+    type: 'modInteger :: Integer+      -> Integer -> Integer'+    template: |-+      // modInteger begin+      // remainder+      wire ~SIGD[~GENSYM[rem_res][0]][0];+      assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1];++      // modulo+      assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ?+                       ~SYM[0] :+                       ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]);+      // modInteger end+    warning: 'GHC.Integer.Type.modInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.divModInteger+    kind: Declaration+    type: 'divModInteger ::+      Integer -> Integer -> (# Integer, Integer #)'+    template: |-+      // divModInteger begin+      wire ~GENSYM[resultPos][1];+      wire ~GENSYM[dividerNeg][2];+      wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividend2][3];+      wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividendE][4];+      wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividerE][5];+      wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[quot_res][6];+      wire signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[div_res][7];++      assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1];+      assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYP[0]]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYP[0]]-1]},~VAR[dividend][0]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYP[0]]-1]} ,~VAR[divider][1]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYP[0]]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYP[0]]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~SYM[7] = $signed(~SYM[6][~SIZE[~TYP[0]]-1:0]);++      wire ~SIGD[~GENSYM[rem_res][8]][0];+      wire ~SIGD[~GENSYM[mod_res][9]][0];+      assign ~SYM[8] = ~VAR[dividend][0] % ~VAR[divider][1];++      // modulo+      assign ~SYM[9] = (~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1]) ?+                       ~SYM[8] :+                       ((~SYM[8] == ~SIZE[~TYP[0]]'sd0) ? ~SIZE[~TYP[0]]'sd0 : ~SYM[8] + ~VAR[divider][1]);++      assign ~RESULT = {~SYM[7],~SYM[9]};+      // divModInteger end+    warning: 'GHC.Integer.Type.divModInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.quotRemInteger+    kind: Declaration+    type: 'quotRemInteger+      :: Integer -> Integer -> (# Integer, Integer #)'+    template: |-+      // quotRemInteger begin+      wire ~SIGD[~GENSYM[quot_res][0]][0];+      wire ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemInteger end+    warning: 'GHC.Integer.Type.quotRemInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'
+ prims/verilog/GHC_Num_Integer.primitives.yaml view
@@ -0,0 +1,102 @@+- BlackBox:+    name: GHC.Num.Integer.integerDiv+    kind: Declaration+    type: 'integerDiv :: Integer+      -> Integer -> Integer'+    template: |-+      // integerDiv begin+      wire ~GENSYM[resultPos][1];+      wire ~GENSYM[dividerNeg][2];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+      wire signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6];++      assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+      assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]);+      // integerDiv end+    warning: 'GHC.Num.Integer.integerDiv: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerMod+    kind: Declaration+    type: 'integerMod :: Integer+      -> Integer -> Integer'+    template: |-+      // integerMod begin+      // remainder+      wire ~SIGD[~GENSYM[rem_res][0]][0];+      assign ~SYM[0] = ~VAR[dividend][0] % ~VAR[divider][1];++      // modulo+      assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ?+                       ~SYM[0] :+                       ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]);+      // integerMod end+    warning: 'GHC.Num.Integer.integerMod: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerDivMod#+    kind: Declaration+    type: 'integerDivMod ::+      Integer -> Integer -> (# Integer, Integer #)'+    template: |-+      // integerDivMod begin+      wire ~GENSYM[resultPos][1];+      wire ~GENSYM[dividerNeg][2];+      wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividend2][3];+      wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividendE][4];+      wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[dividerE][5];+      wire signed [~SIZE[~TYP[0]]:0] ~GENSYM[quot_res][6];+      wire signed [~SIZE[~TYP[0]]-1:0] ~GENSYM[div_res][7];++      assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1];+      assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYP[0]]-1] == 1'b1;+      assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYP[0]]-1]},~VAR[dividend][0]});  // sign extension+      assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYP[0]]-1]} ,~VAR[divider][1]} );  // sign extension++      assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                               : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYP[0]]'sd1)+                                          : (~SYM[4] - ~SYM[5] + ~SIZE[~TYP[0]]'sd1));++      assign ~SYM[6] = ~SYM[3] / ~SYM[5];+      assign ~SYM[7] = $signed(~SYM[6][~SIZE[~TYP[0]]-1:0]);++      wire ~SIGD[~GENSYM[rem_res][8]][0];+      wire ~SIGD[~GENSYM[mod_res][9]][0];+      assign ~SYM[8] = ~VAR[dividend][0] % ~VAR[divider][1];++      // modulo+      assign ~SYM[9] = (~VAR[dividend][0][~SIZE[~TYP[0]]-1] == ~VAR[divider][1][~SIZE[~TYP[0]]-1]) ?+                       ~SYM[8] :+                       ((~SYM[8] == ~SIZE[~TYP[0]]'sd0) ? ~SIZE[~TYP[0]]'sd0 : ~SYM[8] + ~VAR[divider][1]);++      assign ~RESULT = {~SYM[7],~SYM[9]};+      // integerDivMod end+    warning: 'GHC.Num.Integer.integerDivMod#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerQuotRem#+    kind: Declaration+    type: 'integerQuotRem+      :: Integer -> Integer -> (# Integer, Integer #)'+    template: |-+      // integerQuotRem begin+      wire ~SIGD[~GENSYM[quot_res][0]][0];+      wire ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // integerQuotRem end+    warning: 'GHC.Num.Integer.integerQuotRem#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'
+ prims/verilog/GHC_Prim.primitives.yaml view
@@ -0,0 +1,1558 @@+- BlackBox:+    name: GHC.Prim.quotRemInt#+    kind: Declaration+    type: 'quotRemInt# ::+      Int# -> Int# -> (#Int#, Int##)'+    template: |-+      // quotRemInt begin+      wire ~SIGD[~GENSYM[quot_res][0]][0];+      wire ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemInt end+- BlackBox:+    name: GHC.Prim.quotRemWord#+    kind: Declaration+    type: 'quotRemWord# ::+      Word# -> Word# -> (#Word#, Word##)'+    template: |-+      // quotRemWord begin+      wire ~SIGD[~GENSYM[quot_res][0]][0];+      wire ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemWord end+- BlackBox:+    name: GHC.Prim.popCnt8#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: popCnt8+      extension: inc+      template: |-+        // ceiling of log2+        function integer ~INCLUDENAME[0]_clog2;+          input integer value;+          begin+            value = value-1;+            for (~INCLUDENAME[0]_clog2=0; value>0; ~INCLUDENAME[0]_clog2=~INCLUDENAME[0]_clog2+1)+              value = value>>1;+          end+        endfunction++        // given a level and a depth, calculate the corresponding index into the+        // intermediate array+        function integer ~INCLUDENAME[0]_depth2Index;+          input integer levels;+          input integer depth;++          ~INCLUDENAME[0]_depth2Index = (2 ** levels) - (2 ** depth);+        endfunction+    kind: Declaration+    type: 'popCnt8# :: Word#+      -> Word#'+    template: |-+      // popCnt8 begin+      localparam ~GENSYM[width][0] = 8;++      // depth of the tree+      localparam ~GENSYM[levels][2] = ~INCLUDENAME[0]_clog2(~SYM[0]);++      wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2];++      // put input into the first half of the intermediate array+      genvar ~GENSYM[i][4];+      ~GENERATE+      for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11]+        assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]);+      end+      ~ENDGENERATE++      // Create the tree of instantiated components+      genvar ~GENSYM[d][6];+      genvar ~GENSYM[i][7];+      ~GENERATE+      if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8]+        for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9]+          for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10]+            assign ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6])+~SYM[7]] =+                   ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] ++                   ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1];+          end+        end+      end+      ~ENDGENERATE++      // The last element of the intermediate array holds the result+      assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]);+      // popCnt8 end+- BlackBox:+    name: GHC.Prim.popCnt16#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: popCnt16+      extension: inc+      template: |-+        // ceiling of log2+        function integer ~INCLUDENAME[0]_clog2;+          input integer value;+          begin+            value = value-1;+            for (~INCLUDENAME[0]_clog2=0; value>0; ~INCLUDENAME[0]_clog2=~INCLUDENAME[0]_clog2+1)+              value = value>>1;+          end+        endfunction++        // given a level and a depth, calculate the corresponding index into the+        // intermediate array+        function integer ~INCLUDENAME[0]_depth2Index;+          input integer levels;+          input integer depth;++          ~INCLUDENAME[0]_depth2Index = (2 ** levels) - (2 ** depth);+        endfunction+    kind: Declaration+    type: 'popCnt16# :: Word#+      -> Word#'+    template: |-+      // popCnt16 begin+      localparam ~GENSYM[width][0] = 16;++      // depth of the tree+      localparam ~GENSYM[levels][2] = ~INCLUDENAME[0]_clog2(~SYM[0]);++      wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2];++      // put input into the first half of the intermediate array+      genvar ~GENSYM[i][4];+      ~GENERATE+      for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11]+        assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]);+      end+      ~ENDGENERATE++      // Create the tree of instantiated components+      genvar ~GENSYM[d][6];+      genvar ~GENSYM[i][7];+      ~GENERATE+      if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8]+        for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9]+          for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10]+            assign ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6])+~SYM[7]] =+                   ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] ++                   ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1];+          end+        end+      end+      ~ENDGENERATE++      // The last element of the intermediate array holds the result+      assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]);+      // popCnt16 end+- BlackBox:+    name: GHC.Prim.popCnt32#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: popCnt32+      extension: inc+      template: |-+        // ceiling of log2+        function integer ~INCLUDENAME[0]_clog2;+          input integer value;+          begin+            value = value-1;+            for (~INCLUDENAME[0]_clog2=0; value>0; ~INCLUDENAME[0]_clog2=~INCLUDENAME[0]_clog2+1)+              value = value>>1;+          end+        endfunction++        // given a level and a depth, calculate the corresponding index into the+        // intermediate array+        function integer ~INCLUDENAME[0]_depth2Index;+          input integer levels;+          input integer depth;++          ~INCLUDENAME[0]_depth2Index = (2 ** levels) - (2 ** depth);+        endfunction+    kind: Declaration+    type: 'popCnt32# :: Word#+      -> Word#'+    template: |-+      // popCnt32 begin+      localparam ~GENSYM[width][0] = 32;++      // depth of the tree+      localparam ~GENSYM[levels][2] = ~INCLUDENAME[0]_clog2(~SYM[0]);++      wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2];++      // put input into the first half of the intermediate array+      genvar ~GENSYM[i][4];+      ~GENERATE+      for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11]+        assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]);+      end+      ~ENDGENERATE++      // Create the tree of instantiated components+      genvar ~GENSYM[d][6];+      genvar ~GENSYM[i][7];+      ~GENERATE+      if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8]+        for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9]+          for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10]+            assign ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6])+~SYM[7]] =+                   ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] ++                   ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1];+          end+        end+      end+      ~ENDGENERATE++      // The last element of the intermediate array holds the result+      assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]);+      // popCnt32 end+- BlackBox:+    name: GHC.Prim.popCnt64#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: popCnt64+      extension: inc+      template: |-+        // ceiling of log2+        function integer ~INCLUDENAME[0]_clog2;+          input integer value;+          begin+            value = value-1;+            for (~INCLUDENAME[0]_clog2=0; value>0; ~INCLUDENAME[0]_clog2=~INCLUDENAME[0]_clog2+1)+              value = value>>1;+          end+        endfunction++        // given a level and a depth, calculate the corresponding index into the+        // intermediate array+        function integer ~INCLUDENAME[0]_depth2Index;+          input integer levels;+          input integer depth;++          ~INCLUDENAME[0]_depth2Index = (2 ** levels) - (2 ** depth);+        endfunction+    kind: Declaration+    type: 'popCnt64# :: Word#+      -> Word#'+    template: |-+      // popCnt64 begin+      localparam ~GENSYM[width][0] = 64;++      // depth of the tree+      localparam ~GENSYM[levels][2] = ~INCLUDENAME[0]_clog2(~SYM[0]);++      wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2];++      // put input into the first half of the intermediate array+      genvar ~GENSYM[i][4];+      ~GENERATE+      for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11]+        assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]);+      end+      ~ENDGENERATE++      // Create the tree of instantiated components+      genvar ~GENSYM[d][6];+      genvar ~GENSYM[i][7];+      ~GENERATE+      if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8]+        for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9]+          for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10]+            assign ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6])+~SYM[7]] =+                   ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] ++                   ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1];+          end+        end+      end+      ~ENDGENERATE++      // The last element of the intermediate array holds the result+      assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]);+      // popCnt64 end+- BlackBox:+    name: GHC.Prim.popCnt#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: popCnt+      extension: inc+      template: |-+        // ceiling of log2+        function integer ~INCLUDENAME[0]_clog2;+          input integer value;+          begin+            value = value-1;+            for (~INCLUDENAME[0]_clog2=0; value>0; ~INCLUDENAME[0]_clog2=~INCLUDENAME[0]_clog2+1)+              value = value>>1;+          end+        endfunction++        // given a level and a depth, calculate the corresponding index into the+        // intermediate array+        function integer ~INCLUDENAME[0]_depth2Index;+          input integer levels;+          input integer depth;++          ~INCLUDENAME[0]_depth2Index = (2 ** levels) - (2 ** depth);+        endfunction+    kind: Declaration+    type: 'popCnt# :: Word#+      -> Word#'+    template: |-+      // popCnt begin+      localparam ~GENSYM[width][0] = ~SIZE[~TYPO];++      // depth of the tree+      localparam ~GENSYM[levels][2] = ~INCLUDENAME[0]_clog2(~SYM[0]);++      wire [~SYM[2]:0] ~GENSYM[intermediate][3] [0:(2*~SYM[0])-2];++      // put input into the first half of the intermediate array+      genvar ~GENSYM[i][4];+      ~GENERATE+      for (~SYM[4] = 0; ~SYM[4] < ~SYM[0]; ~SYM[4]=~SYM[4]+1) begin : ~GENSYM[mk_array][11]+        assign ~SYM[3][~SYM[4]] = $unsigned(~VAR[input][0][~SYM[4]]);+      end+      ~ENDGENERATE++      // Create the tree of instantiated components+      genvar ~GENSYM[d][6];+      genvar ~GENSYM[i][7];+      ~GENERATE+      if (~SYM[2] != 0) begin : ~GENSYM[make_tree][8]+        for (~SYM[6] = ~SYM[2]; ~SYM[6] > 0; ~SYM[6]=~SYM[6]-1) begin : ~GENSYM[tree_depth][9]+          for (~SYM[7] = 0; ~SYM[7] < (2**(~SYM[6]-1)); ~SYM[7] = ~SYM[7]+1) begin : ~GENSYM[tree_depth_loop][10]+            assign ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6])+~SYM[7]] =+                   ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])] ++                   ~SYM[3][~INCLUDENAME[0]_depth2Index(~SYM[2]+1,~SYM[6]+1)+(2*~SYM[7])+1];+          end+        end+      end+      ~ENDGENERATE++      // The last element of the intermediate array holds the result+      assign ~RESULT = $unsigned(~SYM[3][(2*~SYM[0])-2]);+      // popCnt end+- BlackBox:+    name: GHC.Prim.clz8#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'clz8 :: Word# ->+      Word#'+    template: |-+      // clz8 begin+      wire [0:7] ~GENSYM[v][1];+      assign ~SYM[1] = ~VAR[i][0][7:0];++      wire [0:7] ~GENSYM[e][2];+      genvar ~GENSYM[n][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<4;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      reg [0:5] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<2;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage1][6]+        localparam n = 2;+        wire [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:3] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 3;+      wire [5:0] i;+      assign i = ~SYM[4][0:5];+      always @(*) begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // clz8 end+- BlackBox:+    name: GHC.Prim.clz16#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'clz16 :: Word#+      -> Word#'+    template: |-+      // clz16 begin+      wire [0:15] ~GENSYM[v][1];+      assign ~SYM[1] = ~VAR[i][0][15:0];++      wire [0:15] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<8;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      reg [0:11] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<4;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        wire [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:7] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<2;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        wire [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:4] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 4;+      wire [7:0] i;+      assign i = ~SYM[9][0:7];+      always @(*) begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // clz16 end+- BlackBox:+    name: GHC.Prim.clz32#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'clz32 :: Word#+      -> Word#'+    template: |-+      // clz32 begin+      wire [0:31] ~GENSYM[v][1];+      assign ~SYM[1] = ~VAR[i][0][31:0];++      wire [0:31] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      reg [0:23] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        wire [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:15] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        wire [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:9] ~GENSYM[c][12];+      genvar ~GENSYM[i3][13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14]+        localparam n = 4;+        wire [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:5] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 5;+      wire [9:0] i;+      assign i = ~SYM[12][0:9];+      always @(*) begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // clz32 end+- BlackBox:+    name: GHC.Prim.clz64#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'clz64 :: Word#+      -> Word#'+    template: |-+      // clz64 begin+      wire [0:63] ~GENSYM[v][1];+      assign ~SYM[1] = ~VAR[i][0][63:0];++      wire [0:63] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      reg [0:47] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        wire [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:31] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        wire [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:19] ~GENSYM[c][12];+      genvar ~GENSYM[i3][13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14]+        localparam n = 4;+        wire [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:11] ~GENSYM[d][15];+      genvar ~GENSYM[i4][16];+      ~GENERATE+      for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17]+        localparam n = 5;+        wire [9:0] i;+        assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:6] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 6;+      wire [11:0] i;+      assign i = ~SYM[15][0:11];+      always @(*) begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // clz64 end+- BlackBox:+    name: GHC.Prim.clz#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'clz :: Word# ->+      Word#'+    template: |-+      // clz begin~IF ~IW64 ~THEN+      wire [0:63] ~GENSYM[v][1];+      assign ~SYM[1] = ~VAR[i][0][63:0];++      wire [0:63] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      reg [0:47] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        wire [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:31] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        wire [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:19] ~GENSYM[c][12];+      genvar ~GENSYM[i3][13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14]+        localparam n = 4;+        wire [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:11] ~GENSYM[d][15];+      genvar ~GENSYM[i4][16];+      ~GENERATE+      for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17]+        localparam n = 5;+        wire [9:0] i;+        assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:6] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 6;+      wire [11:0] i;+      assign i = ~SYM[15][0:11];+      always @(*) begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE+      ~ELSE+      wire [0:31] ~SYM[1];+      assign ~SYM[1] = ~VAR[i][0][31:0];++      wire [0:31] ~SYM[2];+      genvar ~SYM[3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~SYM[8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      reg [0:23] ~SYM[4];+      genvar ~SYM[5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~SYM[6]+        localparam n = 2;+        wire [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:15] ~SYM[9];+      genvar ~SYM[10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~SYM[11]+        localparam n = 3;+        wire [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:9] ~SYM[12];+      genvar ~SYM[13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~SYM[14]+        localparam n = 4;+        wire [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:5] ~SYM[7];+      ~GENERATE+      if (1) begin+      localparam n = 5;+      wire [9:0] i;+      assign i = ~SYM[12][0:9];+      always @(*) begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE+      ~FI+      assign ~RESULT = $unsigned(~SYM[7]);+      // clz end+- BlackBox:+    name: GHC.Prim.ctz8#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'ctz8 :: Word# ->+      Word#'+    template: |-+      // ctz8 begin+      wire [0:7] ~GENSYM[v][1];+      genvar ~GENSYM[k][18];+      ~GENERATE+      for (~SYM[18]=0;~SYM[18]<8;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]+        assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]];+      end+      ~ENDGENERATE++      wire [0:7] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<4;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      reg [0:5] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<2;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        wire [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:3] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 3;+      wire [5:0] i;+      assign i = ~SYM[4][0:5];+      always @(*) begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // ctz8 end+- BlackBox:+    name: GHC.Prim.ctz16#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'ctz16 :: Word#+      -> Word#'+    template: |-+      // ctz16 begin+      wire [0:15] ~GENSYM[v][1];+      genvar ~GENSYM[k][18];+      ~GENERATE+      for (~SYM[18]=0;~SYM[18]<16;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]+        assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]];+      end+      ~ENDGENERATE++      wire [0:15] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<8;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      reg [0:11] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<4;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        wire [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:7] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<2;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        wire [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:4] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 4;+      wire [7:0] i;+      assign i = ~SYM[9][0:7];+      always @(*) begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // ctz16 end+- BlackBox:+    name: GHC.Prim.ctz32#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'ctz32 :: Word#+      -> Word#'+    template: |-+      // ctz32 begin+      wire [0:31] ~GENSYM[v][1];+      genvar ~GENSYM[k][18];+      ~GENERATE+      for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]+        assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]];+      end+      ~ENDGENERATE++      wire [0:31] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      reg [0:23] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        wire [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:15] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        wire [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:9] ~GENSYM[c][12];+      genvar ~GENSYM[i3][13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14]+        localparam n = 4;+        wire [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:5] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 5;+      wire [9:0] i;+      assign i = ~SYM[12][0:9];+      always @(*) begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // ctz32 end+- BlackBox:+    name: GHC.Prim.ctz64#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'ctz64 :: Word#+      -> Word#'+    template: |-+      // ctz64 begin+      wire [0:63] ~GENSYM[v][1];+      genvar ~GENSYM[k][18];+      ~GENERATE+      for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]+        assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]];+      end+      ~ENDGENERATE++      wire [0:63] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      reg [0:47] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        wire [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:31] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        wire [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:19] ~GENSYM[c][12];+      genvar ~GENSYM[i3][13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14]+        localparam n = 4;+        wire [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:11] ~GENSYM[d][15];+      genvar ~GENSYM[i4][16];+      ~GENERATE+      for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17]+        localparam n = 5;+        wire [9:0] i;+        assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:6] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 6;+      wire [11:0] i;+      assign i = ~SYM[15][0:11];+      always @(*) begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE++      assign ~RESULT = $unsigned(~SYM[7]);+      // ctz64 end+- BlackBox:+    name: GHC.Prim.ctz#+    imports:+    - ~INCLUDENAME[0].inc+    includes:+    - name: enc+      extension: inc+      template: |-+        function [1:0] ~INCLUDENAME[0];+          input [1:0] a;+          case (a)+            2'b00:   ~INCLUDENAME[0] = 2'b10;+            2'b01:   ~INCLUDENAME[0] = 2'b01;+            2'b10:   ~INCLUDENAME[0] = 2'b00;+            default: ~INCLUDENAME[0] = 2'b00;+          endcase+        endfunction+    kind: Declaration+    type: 'ctz :: Word# ->+      Word#'+    template: |-+      // ctz begin~IF ~IW64 ~THEN+      wire [0:63] ~GENSYM[v][1];+      genvar ~GENSYM[k][18];+      ~GENERATE+      for (~SYM[18]=0;~SYM[18]<64;~SYM[18]=~SYM[18]+1) begin : ~GENSYM[reverse][19]+        assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]];+      end+      ~ENDGENERATE++      wire [0:63] ~GENSYM[e][2];+      genvar ~GENSYM[i][3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<32;~SYM[3]=~SYM[3]+1) begin : ~GENSYM[enc_stage][8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      reg [0:47] ~GENSYM[a][4];+      genvar ~GENSYM[i1][5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<16;~SYM[5]=~SYM[5]+1) begin : ~GENSYM[mux_stage][6]+        localparam n = 2;+        wire [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:31] ~GENSYM[b][9];+      genvar ~GENSYM[i2][10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<8;~SYM[10]=~SYM[10]+1) begin : ~GENSYM[mux_stage2][11]+        localparam n = 3;+        wire [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:19] ~GENSYM[c][12];+      genvar ~GENSYM[i3][13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<4;~SYM[13]=~SYM[13]+1) begin : ~GENSYM[mux_stage3][14]+        localparam n = 4;+        wire [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:11] ~GENSYM[d][15];+      genvar ~GENSYM[i4][16];+      ~GENERATE+      for (~SYM[16]=0;~SYM[16]<2;~SYM[16]=~SYM[16]+1) begin : ~GENSYM[mux_stage4][17]+        localparam n = 5;+        wire [9:0] i;+        assign i = ~SYM[12][~SYM[16]*10:~SYM[16]*10+9];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[15][~SYM[16]*6:~SYM[16]*6+5] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:6] ~GENSYM[res][7];+      ~GENERATE+      if (1) begin+      localparam n = 6;+      wire [11:0] i;+      assign i = ~SYM[15][0:11];+      always @(*) begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE+      ~ELSE+      wire [0:31] ~SYM[1];+      genvar ~SYM[18];+      ~GENERATE+      for (~SYM[18]=0;~SYM[18]<32;~SYM[18]=~SYM[18]+1) begin : ~SYM[19]+        assign ~SYM[1][~SYM[18]] = ~VAR[][0][~SYM[18]];+      end+      ~ENDGENERATE++      wire [0:31] ~SYM[2];+      genvar ~SYM[3];+      ~GENERATE+      for (~SYM[3]=0;~SYM[3]<16;~SYM[3]=~SYM[3]+1) begin : ~SYM[8]+        assign ~SYM[2][~SYM[3]*2:~SYM[3]*2+1] = ~INCLUDENAME[0](~SYM[1][~SYM[3]*2:~SYM[3]*2+1]);+      end+      ~ENDGENERATE++      reg [0:23] ~SYM[4];+      genvar ~SYM[5];+      ~GENERATE+      for (~SYM[5]=0;~SYM[5]<8;~SYM[5]=~SYM[5]+1) begin : ~SYM[6]+        localparam n = 2;+        wire [3:0] i;+        assign i = ~SYM[2][~SYM[5]*4:~SYM[5]*4+3];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[4][~SYM[5]*3:~SYM[5]*3+2] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:15] ~SYM[9];+      genvar ~SYM[10];+      ~GENERATE+      for (~SYM[10]=0;~SYM[10]<4;~SYM[10]=~SYM[10]+1) begin : ~SYM[11]+        localparam n = 3;+        wire [5:0] i;+        assign i = ~SYM[4][~SYM[10]*6:~SYM[10]*6+5];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[9][~SYM[10]*4:~SYM[10]*4+3] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:9] ~SYM[12];+      genvar ~SYM[13];+      ~GENERATE+      for (~SYM[13]=0;~SYM[13]<2;~SYM[13]=~SYM[13]+1) begin : ~SYM[14]+        localparam n = 4;+        wire [7:0] i;+        assign i = ~SYM[9][~SYM[13]*8:~SYM[13]*8+7];+        always @(*) begin+          case (i[n-1+n])+            1'b0    : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+            default : ~SYM[12][~SYM[13]*5:~SYM[13]*5+4] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+          endcase+        end+      end+      ~ENDGENERATE++      reg [0:5] ~SYM[7];+      ~GENERATE+      if (1) begin+      localparam n = 5;+      wire [9:0] i;+      assign i = ~SYM[12][0:9];+      always @(*) begin+        case (i[n-1+n])+          1'b0    : ~SYM[7] = {i[n-1+n] && i[n-1],1'b0,i[2*n-2:n]};+          default : ~SYM[7] = {i[n-1+n] && i[n-1],~ i[n-1],i[n-2:0]};+        endcase+      end+      end+      ~ENDGENERATE+      ~FI+      assign ~RESULT = $unsigned(~SYM[7]);+      // ctz end+- BlackBox:+    name: GHC.Prim.quotRemInt8#+    kind: Declaration+    type: 'quotRemInt8# ::+      Int8# -> Int8# -> (#Int8#, Int8##)'+    template: |-+      // quotRemInt8 begin+      wire ~SIGD[~GENSYM[quot_res][0]][0];+      wire ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemInt8 end+- BlackBox:+    name: GHC.Prim.quotRemWord8#+    kind: Declaration+    type: 'quotRemWord8# ::+      Word8# -> Word8# -> (#Word8#, Word8##)'+    template: |-+      // quotRemWord8 begin+      wire ~SIGD[~GENSYM[quot_res][0]][0];+      wire ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemWord8 end+- BlackBox:+    name: GHC.Prim.quotRemInt16#+    kind: Declaration+    type: 'quotRemInt16# ::+      Int16# -> Int16# -> (#Int16#, Int16##)'+    template: |-+      // quotRemInt16 begin+      wire ~SIGD[~GENSYM[quot_res][0]][0];+      wire ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemInt16 end+- BlackBox:+    name: GHC.Prim.quotRemWord16#+    kind: Declaration+    type: 'quotRemWord16# ::+      Word16# -> Word16# -> (#Word16#, Word16##)'+    template: |-+      // quotRemWord16 begin+      wire ~SIGD[~GENSYM[quot_res][0]][0];+      wire ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemWord16 end+- BlackBox:+    name: GHC.Prim.quotRemInt32#+    kind: Declaration+    type: 'quotRemInt32# ::+      Int32# -> Int32# -> (#Int32#, Int32##)'+    template: |-+      // quotRemInt32 begin+      wire ~SIGD[~GENSYM[quot_res][0]][0];+      wire ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemInt32 end+- BlackBox:+    name: GHC.Prim.quotRemWord32#+    kind: Declaration+    type: 'quotRemWord32# ::+      Word32# -> Word32# -> (#Word32#, Word32##)'+    template: |-+      // quotRemWord32 begin+      wire ~SIGD[~GENSYM[quot_res][0]][0];+      wire ~SIGD[~GENSYM[rem_res][1]][0];+      assign ~SYM[0] = ~ARG[0] / ~ARG[1];+      assign ~SYM[1] = ~ARG[0] % ~ARG[1];++      assign ~RESULT = {~SYM[0],~SYM[1]};+      // quotRemWord32 end
+ prims/vhdl/Clash_Class_BitPack.primitives.yaml view
@@ -0,0 +1,132 @@+- BlackBox:+    name: Clash.Class.BitPack.Internal.packChar#+    kind: Expression+    type: 'packChar# :: Char -> BitVector 21'+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packInt8#+    kind: Expression+    type: 'packInt8# :: Int8 -> Bitvector 8'+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packInt16#+    kind: Expression+    type: 'packInt16# :: Int16 -> Bitvector 16'+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packInt32#+    kind: Expression+    type: 'packInt32# :: Int32 -> Bitvector 32'+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packInt64#+    kind: Expression+    type: 'packInt64# :: Int64 -> Bitvector 64'+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packWord#+    kind: Expression+    type: 'packWord# :: Word -> Bitvector WORD_SIZE_IN_BITS'+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packWord8#+    kind: Expression+    type: 'packWord8# :: Word8 -> Bitvector 8'+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packWord16#+    kind: Expression+    type: 'packWord16# :: Word16 -> Bitvector 16'+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packWord32#+    kind: Expression+    type: 'packWord32# :: Word32 -> Bitvector 32'+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packWord64#+    kind: Expression+    type: 'packWord64# :: Word64 -> Bitvector 64'+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.packCUShort#+    kind: Expression+    type: 'packCUShort# :: CUShort -> Bitvector 16'+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackChar#+    kind: Expression+    type: 'unpackChar# :: BitVector 21 -> Char'+    template: unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackInt8#+    kind: Expression+    type: 'unpackInt8# :: Bitvector 8 -> Int8'+    template: signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackInt16#+    kind: Expression+    type: 'unpackInt16# :: Bitvector 16 -> Int16'+    template: signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackInt32#+    kind: Expression+    type: 'unpackInt32# :: Bitvector 32 -> Int32'+    template: signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackInt64#+    kind: Expression+    type: 'unpackInt64# :: Bitvector 64 -> Int64'+    template: signed(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackWord#+    kind: Expression+    type: 'unpackWord# :: Bitvector WORD_SIZE_IN_BITS -> Word'+    template: unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackWord8#+    kind: Expression+    type: 'unpackWord8# :: Bitvector 8 -> Word8'+    template: unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackWord16#+    kind: Expression+    type: 'unpackWord16# :: Bitvector 16 -> Word16'+    template: unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackWord32#+    kind: Expression+    type: 'unpackWord32# :: Bitvector 32 -> Word32'+    template: unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackWord64#+    kind: Expression+    type: 'unpackWord64# :: Bitvector 64 -> Word64'+    template: unsigned(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Class.BitPack.Internal.unpackCUShort#+    kind: Expression+    type: 'unpackCUShort# :: Bitvector 16 -> CUShort'+    template: unsigned(~ARG[0])+    workInfo: Never
+ prims/vhdl/Clash_Class_Exp.primitives.yaml view
@@ -0,0 +1,24 @@+- BlackBox:+    name: Clash.Class.Exp.expIndex#+    kind: Expression+    type: 'expIndex# :: KnownNat+      m => Index m -> SNat n -> Index (m^n)'+    template: ~DEVNULL[~ARG[0]]to_unsigned(to_integer(~ARG[1]) ** ~LIT[2], ~SIZE[~TYPO])+    warning: Exponentiation is only supported on relatively small constructs (< 32+      bits). Ideally, Clash should have constant folded your expression. See https://github.com/clash-lang/clash-compiler/issues/593.+- BlackBox:+    name: Clash.Class.Exp.expSigned#+    kind: Expression+    type: 'expSigned# :: KnownNat+      m => Signed m -> SNat n -> Signed (m*n)'+    template: ~DEVNULL[~ARG[0]]to_signed(to_integer(~ARG[1]) ** ~LIT[2], ~SIZE[~TYPO])+    warning: Exponentiation is only supported on relatively small constructs (< 32+      bits). Ideally, Clash should have constant folded your expression. See https://github.com/clash-lang/clash-compiler/issues/593.+- BlackBox:+    name: Clash.Class.Exp.expUnsigned#+    kind: Expression+    type: 'expUnsigned# ::+      KnownNat m => Unsigned m -> SNat n -> Unsigned (m*n)'+    template: ~DEVNULL[~ARG[0]]to_unsigned(to_integer(~ARG[1]) ** ~LIT[2], ~SIZE[~TYPO])+    warning: Exponentiation is only supported on relatively small constructs (< 32+      bits). Ideally, Clash should have constant folded your expression. See https://github.com/clash-lang/clash-compiler/issues/593.
+ prims/vhdl/Clash_Explicit_BlockRam.primitives.yaml view
@@ -0,0 +1,173 @@+- BlackBox:+    name: Clash.Explicit.BlockRam.blockRam#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      blockRam#+        :: ( KnownDomain dom        ARG[0]+           , HasCallStack  --       ARG[1]+           , NFDataX a )   --       ARG[2]+        => Clock dom       -- clk,  ARG[3]+        -> Enable dom      -- en,   ARG[4]+        -> Vec n a         -- init, ARG[5]+        -> Signal dom Int  -- rd,   ARG[6]+        -> Signal dom Bool -- wren, ARG[7]+        -> Signal dom Int  -- wr,   ARG[8]+        -> Signal dom a    -- din,  ARG[9]+        -> Signal dom a+    template: |-+      -- blockRam begin+      ~GENSYM[~RESULT_blockRam][1] : block+        signal ~GENSYM[~RESULT_RAM][2] : ~TYP[5] := ~CONST[5];+        signal ~GENSYM[rd][4]  : integer range 0 to ~LENGTH[~TYP[5]] - 1;+        signal ~GENSYM[wr][5]  : integer range 0 to ~LENGTH[~TYP[5]] - 1;+      begin+        ~SYM[4] <= to_integer(~VAR[rdI][6](31 downto 0))+        -- pragma translate_off+                      mod ~LENGTH[~TYP[5]]+        -- pragma translate_on+                      ;++        ~SYM[5] <= to_integer(~VAR[wrI][8](31 downto 0))+        -- pragma translate_off+                      mod ~LENGTH[~TYP[5]]+        -- pragma translate_on+                      ;+      ~IF ~VIVADO ~THEN+        ~SYM[6] : process(~ARG[3])+        begin+          if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then+            if ~ARG[7] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then+              ~SYM[2](~SYM[5]) <= ~TOBV[~ARG[9]][~TYP[9]];+            end if;+            ~RESULT <= fromSLV(~SYM[2](~SYM[4]));+          end if;+        end process; ~ELSE+        ~SYM[6] : process(~ARG[3])+        begin+          if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then+            if ~ARG[7] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then+              ~SYM[2](~SYM[5]) <= ~ARG[9];+            end if;+            ~RESULT <= ~SYM[2](~SYM[4]);+          end if;+        end process; ~FI+      end block;+      --end blockRam+- BlackBox:+    name: Clash.Explicit.BlockRam.blockRamU#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      blockRamU#+        :: ( KnownDomain dom        ARG[0]+           , HasCallStack  --       ARG[1]+           , NFDataX a )   --       ARG[2]+        => Clock dom       -- clk,  ARG[3]+        -> Enable dom      -- en,   ARG[4]+        -> SNat n          -- len,  ARG[5]+        -> Signal dom Int  -- rd,   ARG[6]+        -> Signal dom Bool -- wren, ARG[7]+        -> Signal dom Int  -- wr,   ARG[8]+        -> Signal dom a    -- din,  ARG[9]+        -> Signal dom a+    template: |-+      -- blockRamU begin+      ~GENSYM[~RESULT_blockRam][1] : block~IF~VIVADO~THEN+        type ~GENSYM[ram_t][8] is array (0 to integer'(~LIT[5])-1) of std_logic_vector(~SIZE[~TYP[9]]-1 downto 0);~ELSE+        type ~SYM[8] is array (0 to integer'(~LIT[5])-1) of ~TYP[9];~FI+        signal ~GENSYM[~RESULT_RAM][2] : ~SYM[8];+        signal ~GENSYM[rd][4]  : integer range 0 to ~LIT[5] - 1;+        signal ~GENSYM[wr][5]  : integer range 0 to ~LIT[5] - 1;+      begin+        ~SYM[4] <= to_integer(~VAR[rdI][6](31 downto 0))+        -- pragma translate_off+                      mod ~LIT[5]+        -- pragma translate_on+                      ;++        ~SYM[5] <= to_integer(~VAR[wrI][8](31 downto 0))+        -- pragma translate_off+                      mod ~LIT[5]+        -- pragma translate_on+                      ;+      ~IF ~VIVADO ~THEN+        ~SYM[6] : process(~ARG[3])+        begin+          if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then+            if ~ARG[7] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then+              ~SYM[2](~SYM[5]) <= ~TOBV[~ARG[9]][~TYP[9]];+            end if;+            ~RESULT <= fromSLV(~SYM[2](~SYM[4]));+          end if;+        end process; ~ELSE+        ~SYM[6] : process(~ARG[3])+        begin+          if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then+            if ~ARG[7] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then+              ~SYM[2](~SYM[5]) <= ~ARG[9];+            end if;+            ~RESULT <= ~SYM[2](~SYM[4]);+          end if;+        end process; ~FI+      end block;+      --end blockRamU+- BlackBox:+    name: Clash.Explicit.BlockRam.blockRam1#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      blockRam1#+        :: ( KnownDomain dom        ARG[0]+           , HasCallStack  --       ARG[1]+           , NFDataX a )   --       ARG[2]+        => Clock dom       -- clk,  ARG[3]+        -> Enable dom      -- en,   ARG[4]+        -> SNat n          -- len,  ARG[5]+        -> a               -- init, ARG[6]+        -> Signal dom Int  -- rd,   ARG[7]+        -> Signal dom Bool -- wren, ARG[8]+        -> Signal dom Int  -- wr,   ARG[9]+        -> Signal dom a    -- din,  ARG[10]+        -> Signal dom a+    template: |-+      -- blockRam1 begin+      ~GENSYM[~RESULT_blockRam][1] : block~IF~VIVADO~THEN+        type ~GENSYM[ram_t][8] is array (0 to integer'(~LIT[5])-1) of std_logic_vector(~SIZE[~TYP[6]]-1 downto 0);~ELSE+        type ~SYM[8] is array (0 to integer'(~LIT[5])-1) of ~TYP[6];~FI+        signal ~GENSYM[~RESULT_RAM][2] : ~SYM[8] := (others => ~IF~VIVADO~THEN~TOBV[~CONST[6]][~TYP[6]]~ELSE~CONST[6]~FI);+        signal ~GENSYM[rd][4]  : integer range 0 to ~LIT[5] - 1;+        signal ~GENSYM[wr][5]  : integer range 0 to ~LIT[5] - 1;+      begin+        ~SYM[4] <= to_integer(~VAR[rdI][7](31 downto 0))+        -- pragma translate_off+                      mod ~LIT[5]+        -- pragma translate_on+                      ;++        ~SYM[5] <= to_integer(~VAR[wrI][9](31 downto 0))+        -- pragma translate_off+                      mod ~LIT[5]+        -- pragma translate_on+                      ;+      ~IF ~VIVADO ~THEN+        ~SYM[6] : process(~ARG[3])+        begin+          if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then+            if ~ARG[8] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then+              ~SYM[2](~SYM[5]) <= ~TOBV[~ARG[10]][~TYP[10]];+            end if;+            ~RESULT <= fromSLV(~SYM[2](~SYM[4]));+          end if;+        end process; ~ELSE+        ~SYM[6] : process(~ARG[3])+        begin+          if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then+            if ~ARG[8] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then+              ~SYM[2](~SYM[5]) <= ~ARG[10];+            end if;+            ~RESULT <= ~SYM[2](~SYM[4]);+          end if;+        end process; ~FI+      end block;+      --end blockRam1
+ prims/vhdl/Clash_Explicit_BlockRam_Blob.primitives.yaml view
@@ -0,0 +1,44 @@+- BlackBox:+    name: Clash.Explicit.BlockRam.Blob.blockRamBlob#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      blockRamBlob#+        :: KnownDomain dom           --       ARG[0]+        => Clock dom                 -- clk,  ARG[1]+        -> Enable dom                -- en,   ARG[2]+        -> MemBlob n m               -- init, ARG[3]+        -> Signal dom Int            -- rd,   ARG[4]+        -> Signal dom Bool           -- wren, ARG[5]+        -> Signal dom Int            -- wr,   ARG[6]+        -> Signal dom (BitVector m)  -- din,  ARG[7]+        -> Signal dom (BitVector m)+    template: |-+      -- blockRamBlob begin+      ~GENSYM[~RESULT_blockRam][1] : block+        signal ~GENSYM[~RESULT_RAM][2] : ~TYP[3] := ~CONST[3];+        signal ~GENSYM[rd][4]  : integer range 0 to ~LENGTH[~TYP[3]] - 1;+        signal ~GENSYM[wr][5]  : integer range 0 to ~LENGTH[~TYP[3]] - 1;+      begin+        ~SYM[4] <= to_integer(~VAR[rdI][4](31 downto 0))+        -- pragma translate_off+                      mod ~LENGTH[~TYP[3]]+        -- pragma translate_on+                      ;++        ~SYM[5] <= to_integer(~VAR[wrI][6](31 downto 0))+        -- pragma translate_off+                      mod ~LENGTH[~TYP[3]]+        -- pragma translate_on+                      ;+        ~SYM[6] : process(~ARG[1])+        begin+          if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[1]) then+            if ~ARG[5]~IF~ISACTIVEENABLE[2]~THEN and ~ARG[2]~ELSE~FI then+              ~SYM[2](~SYM[5]) <= ~ARG[7];+            end if;+            ~RESULT <= ~SYM[2](~SYM[4]);+          end if;+        end process;+      end block;+      -- blockRamBlob end
+ prims/vhdl/Clash_Explicit_BlockRam_File.primitives.yaml view
@@ -0,0 +1,93 @@+- BlackBox:+    name: Clash.Explicit.BlockRam.File.blockRamFile#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      blockRamFile#+        :: ( KnownDomain dom        -- ARG[0]+           , KnownNat m             -- ARG[1]+           , HasCallStack )         -- ARG[2]+        => Clock dom                -- clk,  ARG[3]+        => Enable dom               -- en,   ARG[4]+        -> SNat n                   -- sz,   ARG[5]+        -> FilePath                 -- file, ARG[6]+        -> Signal dom Int           -- rd,   ARG[7]+        -> Signal dom Bool          -- wren, ARG[8]+        -> Signal dom Int           -- wr,   ARG[9]+        -> Signal dom (BitVector m) -- din,  ARG[10]+        -> Signal dom (BitVector m)+    template: |-+      -- blockRamFile begin+      ~GENSYM[~COMPNAME_blockRamFile][1] : block+        type ~GENSYM[RamType][7] is array(natural range <>) of bit_vector(~LIT[1]-1 downto 0);++        impure function ~GENSYM[InitRamFromFile][2] (RamFileName : in string) return ~SYM[7] is+          FILE RamFile : text open read_mode is RamFileName;+          variable RamFileLine : line;+          variable RAM : ~SYM[7](0 to ~LIT[5]-1);+        begin+          for i in RAM'range loop+            readline(RamFile,RamFileLine);+            read(RamFileLine,RAM(i));+          end loop;+          return RAM;+        end function;++        signal ~GENSYM[RAM][3] : ~SYM[7](0 to ~LIT[5]-1) := ~SYM[2](~FILE[~LIT[6]]);+        signal ~GENSYM[rd][5]  : integer range 0 to ~LIT[5]-1;+        signal ~GENSYM[wr][6]  : integer range 0 to ~LIT[5]-1;+      begin+        ~SYM[5] <= to_integer(~VAR[rdI][7](31 downto 0))+        -- pragma translate_off+                      mod ~LIT[5]+        -- pragma translate_on+                      ;++        ~SYM[6] <= to_integer(~VAR[wrI][9](31 downto 0))+        -- pragma translate_off+                      mod ~LIT[5]+        -- pragma translate_on+                      ;+        ~IF ~VIVADO ~THEN ~IF ~ISACTIVEENABLE[4] ~THEN+        ~GENSYM[blockRamFile_sync][10] : process(~ARG[3])+        begin+          if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then+            if ~ARG[4] then+              if ~ARG[8] then+                ~SYM[3](~SYM[6]) <= to_bitvector(~ARG[10]);+              end if;+              ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5]));+            end if;+          end if;+        end process;~ELSE+        ~SYM[10] : process(~ARG[3])+        begin+          if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then+            if ~ARG[8] then+              ~SYM[3](~SYM[6]) <= to_bitvector(~ARG[10]);+            end if;+            ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5]));+          end if;+        end process;~FI ~ELSE ~IF ~ISACTIVEENABLE[4] ~THEN+        ~SYM[10] : process(~ARG[3])+        begin+          if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then+            if ~ARG[8] and ~ARG[4] then+              ~SYM[3](~SYM[6]) <= to_bitvector(~ARG[10]);+            end if;+            if ~ARG[4] then+              ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5]));+            end if;+          end if;+        end process;~ELSE+        ~SYM[10] : process(~ARG[3])+        begin+          if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then+            if ~ARG[8] then+              ~SYM[3](~SYM[6]) <= to_bitvector(~ARG[10]);+            end if;+            ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5]));+          end if;+        end process;~FI ~FI+      end block;+      -- blockRamFile end
+ prims/vhdl/Clash_Explicit_DDR.primitives.yaml view
@@ -0,0 +1,164 @@+- BlackBox:+    name: Clash.Explicit.DDR.ddrIn#+    kind: Declaration+    type: |-+      ddrIn# :: forall a dom domDDR+              . HasCallStack             -- ARG[0]+             => NFDataX a                -- ARG[1]+             => KnownDomain dom          -- ARG[2]+             => KnownDomain domDDR       -- ARG[3]+             => DomPeriod ~ 2 * ...      -- ARG[4]+             => Clock dom                -- ARG[5]+             -> Reset dom                -- ARG[6]+             -> Enable dom               -- ARG[7]+             -> a                        -- ARG[8]+             -> a                        -- ARG[9]+             -> a                        -- ARG[10]+             -> Signal domDDR a          -- ARG[11]+             -> Signal dom (a,a)+    template: |-+      -- ddrIn begin+      ~GENSYM[~COMPNAME_ddrIn][0] : block+        signal ~GENSYM[data_Pos][1]       : ~TYP[11];+        signal ~GENSYM[data_Neg][2]       : ~TYP[11];+        signal ~GENSYM[data_Neg_Latch][3] : ~TYP[11];+      begin+       ~IF ~ISSYNC[2] ~THEN+        -- sync+        -------------+        ~GENSYM[~COMPNAME_ddrIn_pos][6] : process(~ARG[5])+        begin+          if ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[5]) then+            if ~ARG[6] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then+              ~SYM[1] <= ~ARG[9];+            els~IF ~ISACTIVEENABLE[7] ~THENif ~ARG[7] then~ELSEe~FI+              ~SYM[1] <= ~ARG[11];+            end if;+          end if;+        end process;++        ~GENSYM[~COMPNAME_ddrIn_neg][7] : process(~ARG[5])+        begin+          if ~IF~ACTIVEEDGE[Rising][2]~THENfalling_edge~ELSErising_edge~FI(~ARG[5]) then+            if ~ARG[6] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then+              ~SYM[2] <= ~ARG[10];+            els~IF ~ISACTIVEENABLE[7] ~THENif ~ARG[7] then~ELSEe~FI+              ~SYM[2] <= ~ARG[11];+            end if;+          end if;+        end process;++        ~GENSYM[~COMPNAME_ddrIn_neg_latch][8] : process(~ARG[5])+        begin+          if ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[5]) then+            if ~ARG[6] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then+              ~SYM[3] <= ~ARG[8];+            els~IF ~ISACTIVEENABLE[7] ~THENif ~ARG[7] then~ELSEe~FI+              ~SYM[3] <= ~SYM[2];+            end if;+          end if;+        end process;+       ~ELSE+        -- async+        --------------+        ~SYM[6] : process(~ARG[5],~ARG[6])+        begin+          if ~ARG[6] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then+            ~SYM[1] <= ~ARG[9];+          elsif ~IF ~ISACTIVEENABLE[7] ~THEN ~ARG[7] and ~ELSE ~FI ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[5]) then+            ~SYM[1] <= ~ARG[11];+          end if;+        end process;++        ~SYM[7] : process(~ARG[5],~ARG[6])+        begin+          if ~ARG[6] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then+            ~SYM[2] <= ~ARG[10];+          elsif ~IF ~ISACTIVEENABLE[7] ~THEN ~ARG[7] and ~ELSE ~FI ~IF~ACTIVEEDGE[Rising][2]~THENfalling_edge~ELSErising_edge~FI(~ARG[5]) then+            ~SYM[2] <= ~ARG[11];+          end if;+        end process;++        ~SYM[8] : process(~ARG[5],~ARG[6])+        begin+          if ~ARG[6] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then+            ~SYM[3] <= ~ARG[8];+          elsif ~IF ~ISACTIVEENABLE[7] ~THEN ~ARG[7] and ~ELSE ~FI ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[5]) then+            ~SYM[3] <= ~SYM[2];+          end if;+        end process;+       ~FI+        ~RESULT <= (~SYM[3], ~SYM[1]);+      end block;+      -- ddrIn end+- BlackBox:+    name: Clash.Explicit.DDR.ddrOut#+    kind: Declaration+    type: |-+      ddrOut# :: forall a dom domDDR+               . HasCallStack                 -- ARG[0]+              => NFDataX a                    -- ARG[1]+              => KnownDomain dom              -- ARG[2]+              => KnownDomain domDDR           -- ARG[3]+              => DomPeriod ~ 2 * ...          -- ARG[4]+              => Clock dom                    -- ARG[5]+              -> Reset dom                    -- ARG[6]+              -> Enable dom                   -- ARG[7]+              -> a                            -- ARG[8]+              -> Signal dom a                 -- ARG[9]+              -> Signal dom a                 -- ARG[10]+              -> Signal domDDR a+    template: |-+      -- ddrOut begin+      ~GENSYM[~COMPNAME_ddrOut][0] : block+        signal ~GENSYM[data_Pos][1] : ~TYP[8];+        signal ~GENSYM[data_Neg][2] : ~TYP[8];+      begin+       ~IF ~ISSYNC[2] ~THEN+        -- sync+        -------------+        ~GENSYM[~COMPNAME_ddrOut_pos][5] : process(~ARG[5])+        begin+          if ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[5]) then+            if ~ARG[6] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then+              ~SYM[1] <= ~ARG[8];+            els~IF ~ISACTIVEENABLE[7] ~THENif ~ARG[7] then~ELSEe~FI+              ~SYM[1] <= ~ARG[9];+            end if;+          end if;+        end process;++        ~GENSYM[~COMPNAME_ddrOut_neg][6] : process(~ARG[5])+        begin+          if ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[5]) then+            if ~ARG[6] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then+              ~SYM[2] <= ~ARG[8];+            els~IF ~ISACTIVEENABLE[7] ~THENif ~ARG[7] then~ELSEe~FI+              ~SYM[2] <= ~ARG[10];+            end if;+          end if;+        end process;+       ~ELSE+        -- async+        --------------+        ~SYM[5] : process(~ARG[5],~ARG[6]~VARS[9])+        begin+          if ~ARG[6] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then+            ~SYM[1] <= ~ARG[8];+          elsif ~IF ~ISACTIVEENABLE[7] ~THEN ~ARG[7] and ~ELSE ~FI ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[5]) then+            ~SYM[1] <= ~ARG[9];+          end if;+        end process;++        ~SYM[6] : process(~ARG[5],~ARG[6]~VARS[10])+        begin+          if ~ARG[6] = ~IF~ISACTIVEHIGH[2]~THEN'1'~ELSE'0'~FI then+            ~SYM[2] <= ~ARG[8];+          elsif ~IF ~ISACTIVEENABLE[7] ~THEN ~ARG[7] and ~ELSE ~FI ~IF~ACTIVEEDGE[Rising][2]~THENrising_edge~ELSEfalling_edge~FI(~ARG[5]) then+            ~SYM[2] <= ~ARG[10];+          end if;+        end process;+       ~FI+        ~RESULT <= ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[1]~ELSE~SYM[2]~FI when (~ARG[5] = '1') else ~IF~ACTIVEEDGE[Rising][2]~THEN~SYM[2]~ELSE~SYM[1]~FI;+      end block;+      -- ddrOut end
+ prims/vhdl/Clash_Explicit_RAM.primitives.yaml view
@@ -0,0 +1,52 @@+- BlackBox:+    name: Clash.Explicit.RAM.asyncRam#+    kind: Declaration+    type: |-+      asyncRam#+        :: ( HasCallStack      --         ARG[0]+           , KnownDomain wdom  --         ARG[1]+           , KnownDomain rdom  --         ARG[2]+           , NFDataX a )       --         ARG[3]+        => Clock wdom          -- ^ wclk, ARG[4]+        -> Clock rdom          -- ^ rclk, ARG[5]+        -> Enable wdom         -- ^ wen,  ARG[6]+        -> SNat n              -- ^ sz,   ARG[7]+        -> Signal rdom Int     -- ^ rd,   ARG[8]+        -> Signal wdom Bool    -- ^ en,   ARG[9]+        -> Signal wdom Int     -- ^ wr,   ARG[10]+        -> Signal wdom a       -- ^ din,  ARG[11]+        -> Signal rdom a+    template: |-+      -- asyncRam begin+      ~GENSYM[~COMPNAME_asyncRam][0] : block~IF ~VIVADO ~THEN+        type ~GENSYM[RamType][4] is array(natural range <>) of std_logic_vector(~SIZE[~TYP[11]]-1 downto 0);~ELSE+        type ~SYM[4] is array(natural range <>) of ~TYP[11];~FI+        signal ~GENSYM[RAM][1] : ~SYM[4](0 to ~LIT[7]-1);+        signal ~GENSYM[rd][2] : integer range 0 to ~LIT[7] - 1;+        signal ~GENSYM[wr][3] : integer range 0 to ~LIT[7] - 1;+      begin+        ~SYM[2] <= to_integer(~VAR[rdI][8](31 downto 0))+        -- pragma translate_off+                      mod ~LIT[7]+        -- pragma translate_on+                      ;++        ~SYM[3] <= to_integer(~VAR[wrI][10](31 downto 0))+        -- pragma translate_off+                      mod ~LIT[7]+        -- pragma translate_on+                      ;+        ~GENSYM[asyncRam_sync][7] : process(~ARG[4])+        begin+          if ~IF~ACTIVEEDGE[Rising][1]~THENrising_edge~ELSEfalling_edge~FI(~ARG[4]) then+            if (~ARG[9] ~IF ~ISACTIVEENABLE[6] ~THEN and ~ARG[6] ~ELSE ~FI) then~IF ~VIVADO ~THEN+              ~SYM[1](~SYM[3]) <= ~TOBV[~ARG[11]][~TYP[11]];~ELSE+              ~SYM[1](~SYM[3]) <= ~ARG[11];~FI+            end if;+          end if;+        end process;+        ~IF ~VIVADO ~THEN+        ~RESULT <= ~FROMBV[~SYM[1](~SYM[2])][~TYP[11]];~ELSE+        ~RESULT <= ~SYM[1](~SYM[2]);~FI+      end block;+      -- asyncRam end
+ prims/vhdl/Clash_Explicit_ROM.primitives.yaml view
@@ -0,0 +1,35 @@+- BlackBox:+    name: Clash.Explicit.ROM.rom#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      rom# :: ( KnownDomain dom        ARG[0]+               , KnownNat n    --       ARG[1]+               , NFDataX a )   --       ARG[2]+            => Clock dom       -- clk,  ARG[3]+            -> Enable dom      -- en,   ARG[4]+            -> Vec n a         -- init, ARG[5]+            -> Signal dom Int  -- rd,   ARG[6]+            -> Signal dom a+    template: |-+      -- rom begin+      ~GENSYM[~COMPNAME_rom][1] : block+        signal ~GENSYM[ROM][2] : ~TYP[5];+        signal ~GENSYM[rd][3]  : integer range 0 to ~LIT[1]-1;+      begin+        ~SYM[2] <= ~CONST[5];++        ~SYM[3] <= to_integer(~VAR[rdI][6](31 downto 0))+        -- pragma translate_off+                      mod ~LIT[1]+        -- pragma translate_on+                      ;+        ~GENSYM[romSync][6] : process (~ARG[3])+        begin+          if (~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3])~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI) then~IF ~VIVADO ~THEN+            ~RESULT <= ~FROMBV[~SYM[2](~SYM[3])][~TYPO];~ELSE+            ~RESULT <= ~SYM[2](~SYM[3]);~FI+          end if;+        end process;+      end block;+      -- rom end
+ prims/vhdl/Clash_Explicit_ROM_Blob.primitives.yaml view
@@ -0,0 +1,33 @@+- BlackBox:+    name: Clash.Explicit.ROM.Blob.romBlob#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      romBlob#+        :: KnownDomain dom  --       ARG[0]+        => Clock dom        -- clk,  ARG[1]+        -> Enable dom       -- en,   ARG[2]+        -> MemBlob n m      -- init, ARG[3]+        -> Signal dom Int   -- rd,   ARG[4]+        -> Signal dom (BitVector m)+    template: |-+      -- romBlob begin+      ~GENSYM[~COMPNAME_rom][1] : block+        signal ~GENSYM[ROM][2] : ~TYP[3];+        signal ~GENSYM[rd][3]  : integer range 0 to ~LENGTH[~TYP[3]]-1;+      begin+        ~SYM[2] <= ~CONST[3];++        ~SYM[3] <= to_integer(~VAR[rdI][4](31 downto 0))+        -- pragma translate_off+                      mod ~LENGTH[~TYP[3]]+        -- pragma translate_on+                      ;+        ~GENSYM[romSync][6] : process (~ARG[1])+        begin+          if (~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[1])~IF~ISACTIVEENABLE[2]~THEN and ~ARG[2]~ELSE~FI) then+            ~RESULT <= ~SYM[2](~SYM[3]);+          end if;+        end process;+      end block;+      -- romBlob end
+ prims/vhdl/Clash_Explicit_ROM_File.primitives.yaml view
@@ -0,0 +1,55 @@+- BlackBox:+    name: Clash.Explicit.ROM.File.romFile#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      romFile# :: ( KnownNat m           --       ARG[0]+                   , KnownDomain dom      --       ARG[1]+                => Clock dom              -- clk,  ARG[2]+                -> Enable dom             -- en,   ARG[3]+                -> SNat n                 -- sz,   ARG[4]+                -> FilePath               -- file, ARG[5]+                -> Signal dom Int         -- rd,   ARG[6]+                -> Signal dom (BitVector m)+    template: |-+      -- romFile begin+      ~GENSYM[~COMPNAME_romFile][0] : block+        type ~GENSYM[RomType][4] is array(natural range <>) of bit_vector(~LIT[0]-1 downto 0);++        impure function ~GENSYM[InitRomFromFile][1] (RomFileName : in string) return ~SYM[4] is+          FILE RomFile : text open read_mode is RomFileName;+          variable RomFileLine : line;+          variable ROM : ~SYM[4](0 to ~LIT[4]-1);+        begin+          for i in ROM'range loop+            readline(RomFile,RomFileLine);+            read(RomFileLine,ROM(i));+          end loop;+          return ROM;+        end function;++        signal ~GENSYM[ROM][2] : ~SYM[4](0 to ~LIT[4]-1) := ~SYM[1](~FILE[~LIT[5]]);+        signal ~GENSYM[rd][3] : integer range 0 to ~LIT[4]-1;+      begin+        ~SYM[3] <=to_integer(~VAR[rdI][6](31 downto 0))+        -- pragma translate_off+                      mod ~LIT[4]+        -- pragma translate_on+                      ;+        ~IF ~ISACTIVEENABLE[3] ~THEN+        ~GENSYM[romFileSync][7] : process (~ARG[2])+        begin+          if (~IF~ACTIVEEDGE[Rising][1]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2])) then+            if ~ARG[3] then+              ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[3]));+            end if;+          end if;+        end process;~ELSE+        ~SYM[7] : process (~ARG[2])+        begin+          if (~IF~ACTIVEEDGE[Rising][1]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2])) then+            ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[3]));+          end if;+        end process;~FI+      end block;+      -- romFile end
+ prims/vhdl/Clash_Explicit_SimIO.primitives.yaml view
@@ -0,0 +1,18 @@+- Primitive:+    name: Clash.Explicit.SimIO.mealyIO+    primType: Function+- Primitive:+    name: Clash.Explicit.SimIO.fmapSimIO#+    primType: Function+- Primitive:+    name: Clash.Explicit.SimIO.pureSimIO#+    primType: Function+- Primitive:+    name: Clash.Explicit.SimIO.apSimIO#+    primType: Function+- Primitive:+    name: Clash.Explicit.SimIO.bindSimIO#+    primType: Function+- Primitive:+    name: Clash.Explicit.SimIO.unSimIO#+    primType: Function
+ prims/vhdl/Clash_Explicit_Testbench.primitives.yaml view
@@ -0,0 +1,161 @@+- BlackBox:+    name: Clash.Explicit.Testbench.assert+    imports:+    - ~INCLUDENAME[0].all+    includes:+    - name: slv2string+      extension: vhdl+      template: |-+        -- helper function of Clash.Explicit.Testbench.assert+        library IEEE;+        use IEEE.STD_LOGIC_1164.ALL;++        package ~INCLUDENAME[0] is+          function slv2string (slv : std_logic_vector) return STRING;+        end;++        package body ~INCLUDENAME[0] is+          function slv2string (slv : std_logic_vector) return STRING is+             variable result : string (1 to slv'length);+             variable res_l : string (1 to 3);+             variable r : integer;+           begin+             r := 1;+             for i in slv'range loop+                res_l := std_logic'image(slv(i));+                result(r) := res_l(2);+                r := r + 1;+             end loop;+             return result;+          end slv2string;+        end;+    kind: Declaration+    type: |-+      assert+        :: (KnownDomain dom, Eq a, ShowX a)      -- (ARG[0],ARG[1],ARG[2])+        => Clock dom                             -- ARG[3]+        -> Reset dom                             -- ARG[4]+        -> String                                -- ARG[5]+        -> Signal dom a                          -- Checked value  (ARG[6])+        -> Signal dom a                          -- Expected value (ARG[7])+        -> Signal dom b                          -- Return valued  (ARG[8])+        -> Signal dom b+    template: |-+      -- assert begin+      ~GENSYM[assert][0] : block+        -- pragma translate_off+        signal ~GENSYM[actual][2] : ~TYP[6];+        signal ~GENSYM[expected][3] : ~TYP[7];+        -- pragma translate_on+      begin+        -- pragma translate_off+        ~SYM[2] <= ~ARG[6];+        ~SYM[3] <= ~ARG[7];+        process(~ARG[3]) is+        begin+          if (~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3])) then+            assert (toSLV(~SYM[2]) = toSLV(~SYM[3])) report (~LIT[5] & ", expected: " & ~INCLUDENAME[0].slv2string(toSLV(~SYM[3])) & ", actual: " & ~INCLUDENAME[0].slv2string(toSLV(~SYM[2]))) severity error;+          end if;+        end process;+        -- pragma translate_on+        ~RESULT <= ~ARG[8];+      end block;+      -- assert end+- BlackBox:+    name: Clash.Explicit.Testbench.assertBitVector+    imports:+    - ~INCLUDENAME[0].all+    includes:+    - name: assertBitVector+      extension: vhdl+      template: |+        -- helper functions of Clash.Explicit.Testbench.assertBitVector+        library IEEE;+        use IEEE.STD_LOGIC_1164.ALL;++        package ~INCLUDENAME[0] is+          function non_std_match (l, r : std_logic_vector) return boolean;+          function slv2string (slv : std_logic_vector) return STRING;+        end;++        package body ~INCLUDENAME[0] is+          type match_table_type is array (std_ulogic, std_ulogic) of boolean;+          constant match_table: match_table_type :=+            ('0' | 'L' => ('0' | 'L' | '-' => true, others => false),+             '1' | 'H' => ('1' | 'H' | '-' => true, others => false),+             '-' => ('-' => true, others => false),+             others    =>             ('-' => true, others => false)+            );+          -- non_std_match is like std_match+          -- But only accepts '-' as don't care in its the second argument r.+          function non_std_match (l, r : std_logic_vector) return boolean is+            alias la : std_logic_vector (l'length downto 1) is l;+            alias ra : std_logic_vector (r'length downto 1) is r;+          begin+            for i in l'range loop+               if not match_table (l (i), r (i)) then+                 return false;+               end if;+            end loop;+            return true;+          end non_std_match;++          function slv2string (slv : std_logic_vector) return STRING is+             variable result : string (1 to slv'length);+             variable res_l : string (1 to 3);+             variable r : integer;+           begin+             r := 1;+             for i in slv'range loop+                res_l := std_logic'image(slv(i));+                result(r) := res_l(2);+                r := r + 1;+             end loop;+             return result;+          end slv2string;++        end;+    kind: Declaration+    type: |-+      assertBitVector+        :: ( KnownDomain dom        --                 ARG[0]+           , KnownNat n )           --                 ARG[1]+        => Clock dom                --                 ARG[2]+        -> Reset dom                --                 ARG[3]+        -> String                   --                 ARG[4]+        -> Signal dom (BitVector n) -- Checked value  (ARG[5])+        -> Signal dom (BitVector n) -- Expected value (ARG[6])+        -> Signal dom b             -- Return valued  (ARG[7])+        -> Signal dom b+    template: |-+      -- assertBitVector begin+      ~GENSYM[assert][0] : block+        -- pragma translate_off+        signal ~GENSYM[actual][2] : ~TYP[5];+        signal ~GENSYM[expected][3] : ~TYP[6];+        -- pragma translate_on+      begin+        -- pragma translate_off+        ~SYM[2] <= ~ARG[5];+        ~SYM[3] <= ~ARG[6];+        process(~ARG[2]) is+        begin+          if (~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2])) then+            assert (~INCLUDENAME[0].non_std_match(toSLV(~SYM[2]),toSLV(~SYM[3]))) report (~LIT[4] & ", expected: " & ~INCLUDENAME[0].slv2string(toSLV(~SYM[3])) & ", actual: " & ~INCLUDENAME[0].slv2string(toSLV(~SYM[2]))) severity error;+          end if;+        end process;+        -- pragma translate_on+        ~RESULT <= ~ARG[7];+      end block;+      -- assertBitVector end+- BlackBox:+    name: Clash.Explicit.Testbench.tbEnableGen+    kind: Declaration+    type: 'tbEnableGen ::+      Enable dom'+    template: ~RESULT <= true;+    workInfo: Always+- BlackBox:+    name: Clash.Explicit.Testbench.clockToDiffClock+    kind: Expression+    template: (~ARG[1], not ~ARG[1])
+ prims/vhdl/Clash_Intel_DDR.primitives.yaml view
@@ -0,0 +1,102 @@+- BlackBox:+    name: Clash.Intel.DDR.altddioIn#+    imports:+    - altera_mf.altera_mf_components.all+    kind: Declaration+    libraries:+    - altera_mf+    type: |-+      altddioIn#+        :: forall deviceFamily n dom domDDR+         . HasCallStack                 -- ARG[0]+        => KnownDomain dom              -- ARG[1]+        => KnownDomain domDDR           -- ARG[2]+        => DomPeriod ~ 2 * ...          -- ARG[3]+        => DomEdge ~ Rising             -- ARG[4]+        => KnownNat n                   -- ARG[5]+        => SSymbol deviceFamily         -- ARG[6]+        -> Clock dom                    -- ARG[7]+        -> Reset dom                    -- ARG[8]+        -> Enable dom                   -- ARG[9]+        -> Signal domDDR (BitVector n)  -- ARG[10]+        -> Signal dom (BitVector n, BitVector n)+    template: |-+      -- altddioIn begin+      ~GENSYM[~COMPNAME_ALTDDIO_IN][0] : block+        signal ~GENSYM[dataout_l][1] : ~TYP[10];+        signal ~GENSYM[dataout_h][2] : ~TYP[10];~IF ~ISACTIVEENABLE[9] ~THEN+        signal ~GENSYM[ce_logic][4]: std_logic;~ELSE ~FI+      begin~IF ~ISACTIVEENABLE[9] ~THEN+        ~SYM[4] <= '1' when (~ARG[9]) else '0';~ELSE ~FI+        ~GENSYM[~COMPNAME_ALTDDIO_IN][7] : ALTDDIO_IN+        GENERIC MAP (+          intended_device_family => ~LIT[6],+          invert_input_clocks => "OFF",+          lpm_hint => "UNUSED",+          lpm_type => "altddio_in",+          power_up_high => "OFF",+          width => ~SIZE[~TYP[10]]+        )+        PORT MAP (~IF ~ISSYNC[1] ~THEN+          sclr      => ~ARG[8],~ELSE+          aclr      => ~ARG[8],~FI+          datain    => ~ARG[10],~IF ~ISACTIVEENABLE[9] ~THEN+          inclocken => ~SYM[4],~ELSE ~FI+          inclock   => ~ARG[7],+          dataout_h => ~SYM[2],+          dataout_l => ~SYM[1]+        );+        ~RESULT <= (~SYM[1],~SYM[2]);+      end block;+      -- altddioIn end+- BlackBox:+    name: Clash.Intel.DDR.altddioOut#+    imports:+    - altera_mf.altera_mf_components.all+    kind: Declaration+    libraries:+    - altera_mf+    type: |-+      altddioOut#+        :: forall deviceFamily n dom domDDR+         . HasCallStack              -- ARG[0]+        => KnownDomain dom           -- ARG[1]+        => KnownDomain domDDR        -- ARG[2]+        => DomPeriod ~ 2 * ...       -- ARG[3]+        => DomEdge ~ Rising          -- ARG[4]+        => KnownNat n                -- ARG[5]+        => SSymbol deviceFamily      -- ARG[6]+        -> Clock dom                 -- ARG[7]+        -> Reset dom                 -- ARG[8]+        -> Enable dom                -- ARG[9]+        -> Signal dom (BitVector n)  -- ARG[10]+        -> Signal dom (BitVector n)  -- ARG[11]+        -> Signal domDDR (BitVector n)+    template: |-+      -- altddioOut begin+      ~GENSYM[~COMPNAME_ALTDDIO_OUT][0] : block ~IF ~ISACTIVEENABLE[9] ~THEN+        signal ~GENSYM[ce_logic][1] : std_logic; ~ELSE ~FI+      begin~IF ~ISACTIVEENABLE[9] ~THEN+        ~SYM[1] <= '1' when (~ARG[9]) else '0'; ~ELSE ~FI+        ~GENSYM[~COMPNAME_ALTDDIO_OUT][7] : ALTDDIO_OUT+          GENERIC MAP (+            extend_oe_disable => "OFF",+            intended_device_family => ~LIT[6],+            invert_output => "OFF",+            lpm_hint => "UNUSED",+            lpm_type => "altddio_out",+            oe_reg => "UNREGISTERED",+            power_up_high => "OFF",+            width => ~SIZE[~TYPO]+          )+          PORT MAP (~IF ~ISSYNC[1] ~THEN+            sclr       => ~ARG[8],~ELSE+            aclr       => ~ARG[8],~FI ~IF ~ISACTIVEENABLE[9] ~THEN+            outclocken => ~SYM[1],~ELSE ~FI+            outclock   => ~ARG[7],+            datain_h   => ~ARG[10],+            datain_l   => ~ARG[11],+            dataout    => ~RESULT+          );+      end block;+      -- altddioOut end
+ prims/vhdl/Clash_Magic.primitives.yaml view
@@ -0,0 +1,11 @@+- BlackBox:+    name: Clash.Magic.nameHint+    kind: Declaration+    type: |-+      nameHint+        :: SSymbol sym  -- ARG[0]+        -> a            -- ARG[1]+        -> a+    resultName:+      template: ~NAME[0]+    template: ~RESULT <= ~ARG[1];
+ prims/vhdl/Clash_Prelude_ROM.primitives.yaml view
@@ -0,0 +1,27 @@+- BlackBox:+    name: Clash.Prelude.ROM.asyncRom#+    kind: Declaration+    type: |-+      asyncRom#+        :: ( KnownNat n  -- ARG[0]+           , NFDataX a)  -- ARG[1]+        => Vec n a       -- ARG[2]+        -> Int           -- ARG[3]+        -> a+    template: |-+      -- asyncRom begin+      ~GENSYM[asyncRom][0] : block+        signal ~GENSYM[ROM][1] : ~TYP[2];+        signal ~GENSYM[rd][2] : integer range 0 to ~LIT[0]-1;+      begin+        ~SYM[1] <= ~CONST[2];++        ~SYM[2] <= to_integer(~VAR[rdI][3](31 downto 0))+        -- pragma translate_off+                            mod ~LIT[0]+        -- pragma translate_on+                            ;~IF ~VIVADO ~THEN+        ~RESULT <= ~FROMBV[~SYM[1](~SYM[2])][~TYPO];~ELSE+        ~RESULT <= ~SYM[1](~SYM[2]);~FI+      end block;+      -- asyncRom end
+ prims/vhdl/Clash_Prelude_ROM_Blob.primitives.yaml view
@@ -0,0 +1,24 @@+- BlackBox:+    name: Clash.Prelude.ROM.Blob.asyncRomBlob#+    kind: Declaration+    type: |-+      asyncRomBlob#+        :: MemBlob n m  -- ARG[0]+        -> Int          -- ARG[1]+        -> BitVector m+    template: |-+      -- asyncRomBlob begin+      ~GENSYM[asyncRom][0] : block+        signal ~GENSYM[ROM][1] : ~TYP[0];+        signal ~GENSYM[rd][2] : integer range 0 to ~LENGTH[~TYP[0]]-1;+      begin+        ~SYM[1] <= ~CONST[0];++        ~SYM[2] <= to_integer(~VAR[rdI][1](31 downto 0))+        -- pragma translate_off+                            mod ~LENGTH[~TYP[0]]+        -- pragma translate_on+                            ;+        ~RESULT <= ~SYM[1](~SYM[2]);+      end block;+      -- asyncRomBlob end
+ prims/vhdl/Clash_Prelude_ROM_File.primitives.yaml view
@@ -0,0 +1,38 @@+- BlackBox:+    name: Clash.Prelude.ROM.File.asyncRomFile#+    kind: Declaration+    type: |-+      asyncRomFile# :: KnownNat m -- ARG[0]+                     => SNat n     -- sz,   ARG[1]+                     -> FilePath   -- file, ARG[2]+                     -> Int        -- rd,   ARG[3]+                     -> BitVector m+    template: |-+      -- asyncRomFile begin+      ~GENSYM[asyncROMFile][0] : block+        type ~GENSYM[RomType][4] is array(natural range <>) of bit_vector(~LIT[0]-1 downto 0);++        impure function ~GENSYM[InitRomFromFile][1] (RomFileName : in string) return ~SYM[4] is+          FILE RomFile : text open read_mode is RomFileName;+          variable RomFileLine : line;+          variable ROM : ~SYM[4](0 to ~LIT[1]-1);+        begin+          for i in ROM'range loop+            readline(RomFile,RomFileLine);+            read(RomFileLine,ROM(i));+          end loop;+          return ROM;+        end function;++        signal ~GENSYM[ROM][2] : ~SYM[4](0 to ~LIT[1]-1) := ~SYM[1](~FILE[~LIT[2]]);+        signal ~GENSYM[rd][3] : integer range 0 to ~LIT[1]-1;+      begin+        ~SYM[3] <= to_integer(~VAR[rdI][3](31 downto 0))+        -- pragma translate_off+                      mod ~LIT[1]+        -- pragma translate_on+                      ;++        ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[3]));+      end block;+      -- asyncRomFile end
+ prims/vhdl/Clash_Promoted_Nat.primitives.yaml view
@@ -0,0 +1,30 @@+- BlackBox:+    name: Clash.Promoted.Nat.flogBaseSNat+    kind: Expression+    type: |-+      Clash.Promoted.Nat.flogBaseSNat :: (2 <= base, 1 <= x)+                                                           => SNat base -- ARG[2]+                                                           -> SNat x    -- ARG[3]+                                                           -> SNat (FLog base x)+    template: integer(floor(log(real(~LIT[3]),real(~LIT[2]))))+    workInfo: Never+- BlackBox:+    name: Clash.Promoted.Nat.clogBaseSNat+    kind: Expression+    type: |-+      Clash.Promoted.Nat.clogBaseSNat :: (2 <= base, 1 <= x)+                                                           => SNat base -- ARG[2]+                                                           -> SNat x    -- ARG[3]+                                                           -> SNat (CLog base x)+    template: integer(ceiling(log(real(~LIT[3]),real(~LIT[2]))))+    workInfo: Never+- BlackBox:+    name: Clash.Promoted.Nat.logBaseSNat+    kind: Expression+    type: |-+      Clash.Promoted.Nat.logBaseSNat :: (FLog base x ~ CLog base x)+                                                          => SNat base -- ARG[1]+                                                          -> SNat x    -- ARG[2]+                                                          -> SNat (Log base x)+    template: integer(ceiling(log(real(~LIT[2]),real(~LIT[1]))))+    workInfo: Never
+ prims/vhdl/Clash_Signal_BiSignal.primitives.yaml view
@@ -0,0 +1,30 @@+- BlackBox:+    name: Clash.Signal.BiSignal.writeToBiSignal#+    kind: Declaration+    type: |-+      writeToBiSignal#+        :: HasCallStack                   -- ARG[0]+        => BiSignalIn ds d n              -- ARG[1]+        -> Signal d (Maybe (BitVector n)) -- ARG[2]+        -> Signal d Bool                  -- ARG[3]+        -> Signal d (BitVector n)         -- ARG[4]+        -> BiSignalOut ds d n+    renderVoid: RenderVoid+    template: |-+      -- writeToBiSignal# begin+      ~ARG[1] <= ~ARG[4] when ~ARG[3] else (~SIZE[~TYP[1]]-1 downto 0 => 'Z');+      -- writeToBiSignal# end+- BlackBox:+    name: Clash.Signal.BiSignal.readFromBiSignal#+    kind: Declaration+    type: |-+      readFromBiSignal#+        :: ( HasCallStack    -- ARG[0]+           , KnownNat n)     -- ARG[1]+        => BiSignalIn ds d n -- ARG[2]+        -> Signal d (BitVector n)+    template: |-+      -- readFromBiSignal begin+      ~RESULT <= ~ARG[2];+      -- readFromBiSignal end+    workInfo: Never
+ prims/vhdl/Clash_Signal_Internal.primitives.yaml view
@@ -0,0 +1,235 @@+- BlackBox:+    name: Clash.Signal.Internal.delay#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      delay#+        :: ( KnownDomain dom        -- ARG[0]+           , NFDataX a )            -- ARG[1]+        => Clock dom                -- ARG[2]+        -> Enable dom               -- ARG[3]+        -> a                        -- ARG[4]+        -> Signal clk a             -- ARG[5]+        -> Signal clk a+    resultInit:+      template: ~IF~ISINITDEFINED[0]~THEN~CONST[4]~ELSE~FI+    resultName:+      template: ~CTXNAME+    template: |-+      -- delay begin~IF ~ISACTIVEENABLE[3] ~THEN+      ~GENSYM[~RESULT_delay][4] : process(~ARG[2])+      begin+        if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then+          if ~ARG[3] then+            ~RESULT <= ~ARG[5];+          end if;+        end if;+      end process;~ELSE+      ~SYM[4] : process(~ARG[2])+      begin+        if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then+          ~RESULT <= ~ARG[5];+        end if;+      end process;~FI+      -- delay end+- BlackBox:+    name: Clash.Signal.Internal.asyncRegister#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      asyncRegister#+        :: ( KnownDomain dom        -- ARG[0]+           , NFDataX a )            -- ARG[1]+        => Clock dom                -- ARG[2]+        -> Reset dom                -- ARG[3]+        -> Enable dom               -- ARG[4]+        -> a                        -- ARG[5] (powerup value)+        -> a                        -- ARG[6] (reset value)+        -> Signal clk a             -- ARG[7]+        -> Signal clk a+    resultInit:+      template: ~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI+    resultName:+      template: ~CTXNAME+    template: |-+      -- async register begin+      ~SYM[2] : process(~ARG[2]~IF ~ISUNDEFINED[6] ~THEN ~ELSE,~ARG[3]~FI)+      begin+        ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then+          ~RESULT <= ~CONST[6];+        els~FIif ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then+          ~IF ~ISACTIVEENABLE[4] ~THEN+          if ~ARG[4] then+            ~RESULT <= ~ARG[7];+          end if;+          ~ELSE+          ~RESULT <= ~ARG[7];+          ~FI+        end if;+      end process;+      -- async register end+- BlackBox:+    name: Clash.Signal.Internal.register#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      register#+        :: ( KnownDomain dom        -- ARG[0]+           , NFDataX a )            -- ARG[1]+        => Clock dom                -- ARG[2]+        -> Reset dom                -- ARG[3]+        -> Enable dom               -- ARG[4]+        -> a                        -- ARG[5] (powerup value)+        -> a                        -- ARG[6] (reset value)+        -> Signal clk a             -- ARG[7]+        -> Signal clk a+    resultInit:+      template: ~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI+    resultName:+      template: ~CTXNAME+    template: |-+      -- register begin~IF ~ISACTIVEENABLE[4] ~THEN ~IF ~ISSYNC[0] ~THEN+      ~GENSYM[~RESULT_register][2] : process(~ARG[2])+      begin+        if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then+          ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then+            ~RESULT <= ~CONST[6];+          els~FIif ~ARG[4] then+            ~RESULT <= ~ARG[7];+          end if;+        end if;+      end process;~ELSE+      ~SYM[2] : process(~ARG[2]~IF ~ISUNDEFINED[6] ~THEN ~ELSE,~ARG[3]~FI)+      begin+        ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then+          ~RESULT <= ~CONST[6];+        els~FIif ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then+          if ~ARG[4] then+            ~RESULT <= ~ARG[7];+          end if;+        end if;+      end process;~FI~ELSE ~IF ~ISSYNC[0] ~THEN+      ~SYM[2] : process(~ARG[2])+      begin+        if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then+          ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then+            ~RESULT <= ~CONST[6];+          else+            ~FI~RESULT <= ~ARG[7];+          ~IF ~ISUNDEFINED[6] ~THEN ~ELSEend if;~FI+        end if;+      end process;~ELSE+      ~SYM[2] : process(~ARG[2]~IF ~ISUNDEFINED[6] ~THEN ~ELSE,~ARG[3]~FI)+      begin+        ~IF ~ISUNDEFINED[6] ~THEN ~ELSEif ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then+          ~RESULT <= ~CONST[6];+        els~FIif ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then+          ~RESULT <= ~ARG[7];+        end if;+      end process;~FI~FI+      -- register end+- BlackBox:+    name: Clash.Signal.Internal.tbClockGen+    comment: |-+      ModelSim and Vivado seem to round time values to an integer number of picoseconds.+              Use two half periods to prevent rounding errors from affecting the full period.+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      tbClockGen+        :: KnownDomain dom     -- ARG[0]+        => Signal dom Bool     -- ARG[1]+        -> Clock dom+    template: |-+      -- ~IF~ISACTIVEENABLE[1]~THENtbClockGen~ELSEclockGen~FI begin+      -- pragma translate_off+      ~GENSYM[clkGen][0] : process is+        constant ~GENSYM[half_periodH][1] : time := ~PERIOD[0]000 fs / 2;+        constant ~GENSYM[half_periodL][2] : time := ~PERIOD[0]000 fs - ~SYM[1];+      begin+        ~RESULT <= ~IF~ACTIVEEDGE[Rising][0]~THEN'0'~ELSE'1'~FI;+        wait for ~LONGESTPERIOD ps;+        ~IF~ISACTIVEENABLE[1]~THENwhile ~ARG[1] ~ELSE~FIloop+          ~RESULT <= not ~RESULT;+          wait for ~SYM[1];+          ~RESULT <= not ~RESULT;+          wait for ~SYM[2];+        end loop;+        wait;+      end process;+      -- pragma translate_on+      -- tbClockGen end+    warning: Clash.Signal.Internal.tbClockGen is not synthesizable!+    workInfo: Always+- BlackBox:+    name: Clash.Signal.Internal.tbDynamicClockGen+    comment: |-+      ModelSim and Vivado seem to round time values to an integer number of picoseconds.+              Use two half periods to prevent rounding errors from affecting the full period.+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      tbDynamicClockGen+        :: KnownDomain dom     -- ARG[0]+        => Signal dom Int64    -- ARG[1]+        -> Signal dom Bool     -- ARG[2]+        -> Clock dom+    template: |-+      -- tbDynamicClockGen begin+      -- pragma translate_off+      ~GENSYM[dynClkGen][0] : process is+        variable ~GENSYM[whole_period][1] : time;+        variable ~GENSYM[half_periodH][2] : time;+        variable ~GENSYM[half_periodL][3] : time;+      begin+        ~RESULT <= ~IF~ACTIVEEDGE[Rising][0]~THEN'0'~ELSE'1'~FI;+        wait for ~LONGESTPERIOD ps;++        ~IF~ISACTIVEENABLE[2]~THENwhile ~ARG[2] ~ELSE~FIloop+          ~SYM[1] := to_integer(~VAR[periods][1]) * 1 fs;+          ~SYM[2] := ~SYM[1] / 2;+          ~SYM[3] := ~SYM[1] - ~SYM[2];++          ~RESULT <= not ~RESULT;+          wait for ~SYM[2];+          ~RESULT <= not ~RESULT;+          wait for ~SYM[3];+        end loop;+        wait;+      end process;+      -- pragma translate_on+      -- tbDynamicClockGen end+    warning: Clash.Signal.Internal.tbDynamicClockGen is not synthesizable!+    workInfo: Always+- BlackBox:+    name: Clash.Signal.Internal.resetGenN+    kind: Declaration+    type: 'resetGenN :: (KnownDomain+      dom, 1 <= n) => SNat n -> Reset dom'+    template: |-+      -- resetGen begin+      ~GENSYM[resetGen][0] : block+        constant ~GENSYM[reset_delay][1] : time := ~LONGESTPERIOD ps - 1 ps + (integer'(~LIT[2]) * ~PERIOD[0] ps);+      begin+      -- pragma translate_off+      ~RESULT+        <= ~IF ~ISACTIVEHIGH[0] ~THEN'1'~ELSE'0'~FI,+           ~IF ~ISACTIVEHIGH[0] ~THEN'0'~ELSE'1'~FI after ~SYM[1];+      -- pragma translate_on+      end block;+      -- resetGen end+    workInfo: Always+- BlackBox:+    name: Clash.Signal.Internal.unsafeFromReset+    kind: Declaration+    type: 'unsafeFromReset+      :: Reset dom -> Signal dom Bool'+    template: ~RESULT <= true when ~ARG[0] = '1' else false;+    workInfo: Never+- BlackBox:+    name: Clash.Signal.Internal.unsafeToReset+    kind: Declaration+    type: 'unsafeToReset ::+      KnownDomain dom => Signal dom Bool -> Reset dom'+    template: ~RESULT <= '1' when ~ARG[1] = true else '0';+    workInfo: Never
+ prims/vhdl/Clash_Sized_Internal_BitVector.primitives.yaml view
@@ -0,0 +1,586 @@+- BlackBox:+    name: Clash.Sized.Internal.BitVector.BV+    comment: THIS IS ONLY USED WHEN WW EXPOSES BITVECTOR INTERNALS+    kind: Expression+    type: 'BV :: Integer ->+      Integer -> BitVector n'+    template: std_logic_vector(resize(unsigned(std_logic_vector(~ARG[1])),~SIZE[~TYPO]))+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.Bit+    comment: THIS IS ONLY USED WHEN WW EXPOSES BIT INTERNALS+    kind: Expression+    type: 'Bit :: Integer+      -> Integer -> BitVector n'+    template: ~VAR[i][1][0]+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.size#+    kind: Expression+    type: 'size# :: KnownNat+      n => BitVector n -> Int'+    template: to_signed(~SIZE[~TYP[1]],~SIZE[~TYPO])+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.BitVector.maxIndex#+    kind: Expression+    type: 'maxIndex# :: KnownNat+      n => BitVector n -> Int'+    template: to_signed(~SIZE[~TYP[1]] - 1,~SIZE[~TYPO])+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.BitVector.high+    kind: Expression+    type: 'high :: Bit'+    template: '''1'''+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.BitVector.low+    kind: Expression+    type: 'low :: Bit'+    template: '''0'''+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.BitVector.pack#+    kind: Expression+    type: 'pack# :: Bit ->+      BitVector 1'+    template: std_logic_vector'(0 => ~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.unpack#+    kind: Expression+    type: 'unpack# :: BitVector+      1 -> Bit'+    template: ~VAR[bv][0](0)+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.eq##+    kind: Expression+    type: 'eq## :: Bit ->+      Bit -> Bool'+    template: ~ARG[0] = ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.neq##+    kind: Expression+    type: 'neq## :: Bit ->+      Bit -> Bool'+    template: ~ARG[0] /= ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.fromInteger##+    kind: Expression+    type: 'fromInteger## ::+      Integer -> Integer -> Bit'+    template: ~IF~LIT[0]~THEN'U'~ELSE~ARG[1](0)~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.toEnum##+    kind: Expression+    type: 'toEnum## :: Int+      -> Bit'+    template: ~VAR[i][0](0)+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.and##+    kind: Expression+    type: 'and## :: Bit ->+      Bit -> Bit'+    template: ~ARG[0] and ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.or##+    kind: Expression+    type: 'or## :: Bit ->+      Bit -> Bit'+    template: ~ARG[0] or ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.xor##+    kind: Expression+    type: 'xor## :: Bit ->+      Bit -> Bit'+    template: ~ARG[0] xor ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.complement##+    kind: Expression+    type: 'complement## ::+      Bit -> Bit'+    template: not ~ARG[0]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.++#+    kind: Expression+    type: '(++#) :: KnownNat+      m => BitVector n -> BitVector m -> BitVector (n + m)'+    template: ~IF~AND[~SIZE[~TYP[1]],~SIZE[~TYP[2]]]~THENstd_logic_vector'(std_logic_vector'(~ARG[1])+      & std_logic_vector'(~ARG[2]))~ELSE~IF~SIZE[~TYP[1]]~THENstd_logic_vector'(~ARG[1])~ELSEstd_logic_vector'(~ARG[2])~FI~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.reduceAnd#+    kind: Declaration+    type: 'reduceAnd# :: KnownNat+      n => BitVector n -> Bit'+    template: |-+      -- reduceAnd begin,+      ~IF~SIZE[~TYP[1]]~THEN+      ~GENSYM[reduceAnd][0] : block+        function and_reduce (arg : std_logic_vector) return std_logic is+          variable upper, lower : std_logic;+          variable half         : integer;+          variable argi         : std_logic_vector (arg'length - 1 downto 0);+          variable result       : std_logic;+        begin+          if (arg'length < 1) then+            result := '1';+          else+            argi := arg;+            if (argi'length = 1) then+              result := argi(argi'left);+            else+              half   := (argi'length + 1) / 2; -- lsb-biased tree+              upper  := and_reduce (argi (argi'left downto half));+              lower  := and_reduce (argi (half - 1 downto argi'right));+              result := upper and lower;+            end if;+          end if;+          return result;+        end;+      begin+        ~RESULT <= and_reduce(~ARG[1]);+      end block;~ELSE+      ~RESULT <= '1';~FI+      -- reduceAnd end+- BlackBox:+    name: Clash.Sized.Internal.BitVector.reduceOr#+    kind: Declaration+    type: 'reduceOr# :: KnownNat+      n => BitVector n -> Bit'+    template: |-+      -- reduceOr begin ~IF~SIZE[~TYP[1]]~THEN+      ~GENSYM[reduceOr][0] : block+        function or_reduce (arg : std_logic_vector) return std_logic is+          variable upper, lower : std_logic;+          variable half         : integer;+          variable argi         : std_logic_vector (arg'length - 1 downto 0);+          variable result       : std_logic;+        begin+          if (arg'length < 1) then+            result := '0';+          else+            argi := arg;+            if (argi'length = 1) then+              result := argi(argi'left);+            else+              half   := (argi'length + 1) / 2; -- lsb-biased tree+              upper  := or_reduce (argi (argi'left downto half));+              lower  := or_reduce (argi (half - 1 downto argi'right));+              result := upper or lower;+            end if;+          end if;+          return result;+        end;+      begin+        ~RESULT <= or_reduce(~ARG[1]);+      end block;~ELSE+      ~RESULT <= '0'; ~FI+      -- reduceOr end+- BlackBox:+    name: Clash.Sized.Internal.BitVector.reduceXor#+    kind: Declaration+    type: 'reduceXor# :: KnownNat+      n => BitVector n -> Bit'+    template: |-+      -- reduceXor begin ~IF~SIZE[~TYP[1]]~THEN+      ~GENSYM[reduceXor][0] : block+        function xor_reduce (arg : std_logic_vector) return std_logic is+          variable upper, lower : std_logic;+          variable half         : integer;+          variable argi         : std_logic_vector (arg'length - 1 downto 0);+          variable result       : std_logic;+        begin+          if (arg'length < 1) then+            result := '0';+          else+            argi := arg;+            if (argi'length = 1) then+              result := argi(argi'left);+            else+              half   := (argi'length + 1) / 2; -- lsb-biased tree+              upper  := xor_reduce (argi (argi'left downto half));+              lower  := xor_reduce (argi (half - 1 downto argi'right));+              result := upper xor lower;+            end if;+          end if;+          return result;+        end;+      begin+        ~RESULT <= xor_reduce(~ARG[1]);+      end block;~ELSE+      ~RESULT <= '0';~FI+      -- reduceXor end+- BlackBox:+    name: Clash.Sized.Internal.BitVector.index#+    kind: Declaration+    type: |-+      index# :: KnownNat n  -- ARG[0]+              => BitVector n -- ARG[1]+              -> Int         -- ARG[2]+              -> Bit+    template: |-+      -- indexBitVector begin ~IF~SIZE[~TYP[1]]~THEN~IF ~ISVAR[1] ~THEN+      ~GENSYM[indexBitVector][0] : block+        signal ~GENSYM[vec_index][1] : integer range 0 to ~SIZE[~TYP[1]]-1;+      begin+        ~SYM[1] <= to_integer(~ARG[2])+        -- pragma translate_off+                     mod ~SIZE[~TYP[1]]+        -- pragma translate_on+                     ;++        ~RESULT <= ~ARG[1](~SYM[1]);+      end block;~ELSE+      ~SYM[0] : block+        signal ~SYM[1] : integer range 0 to ~SIZE[~TYP[1]]-1;+      begin+        ~SYM[1] <= to_integer(~ARG[2])+        -- pragma translate_off+                     mod ~SIZE[~TYP[1]]+        -- pragma translate_on+                     ;++        ~RESULT <= ~VAR[bv][1](~SYM[1]);+      end block;~FI~ELSE+      ~RESULT <= ~ERRORO;~FI+      -- indexBitVector end+- BlackBox:+    name: Clash.Sized.Internal.BitVector.replaceBit#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      replaceBit# :: KnownNat n  -- ARG[0]+                   => BitVector n -- ARG[1]+                   -> Int         -- ARG[2]+                   -> Bit         -- ARG[3]+                   -> BitVector n+    template: |-+      -- replaceBit begin ~IF~SIZE[~TYP[1]]~THEN+      ~GENSYM[replaceBit][0] : block+        signal ~GENSYM[vec_index][1] : integer range 0 to ~SIZE[~TYP[1]]-1;+      begin+        ~SYM[1] <= to_integer(~ARG[2])+        -- pragma translate_off+                     mod ~SIZE[~TYP[1]]+        -- pragma translate_on+                     ;++        process(~SYM[1],~VAR[b][3]~VARS[1])+          variable ~GENSYM[ivec][2] : ~TYP[1];+        begin+          ~SYM[2] := ~ARG[1];+          ~SYM[2](~SYM[1]) := ~ARG[3];+          ~RESULT <= ~SYM[2];+        end process;+      end block; ~ELSE+      ~RESULT <= ~ERRORO;~FI+      -- replaceBit end+- BlackBox:+    name: Clash.Sized.Internal.BitVector.setSlice#+    kind: Declaration+    outputUsage: NonBlocking+    type: |-+      setSlice# :: SNat (m + 1 + i)+                 => BitVector (m + 1 + i) -- ARG[1]+                 -> SNat m                -- ARG[2]+                 -> SNat n                -- ARG[3]+                 -> BitVector (m + 1 - n) -- ARG[4]+                 -> BitVector (m + 1 + i)+    template: |-+      -- setSlice begin+      ~GENSYM[setSlice][0] : process(~VAR[bv][1]~VARS[4])+        variable ~GENSYM[ivec][1] : ~TYP[1];+      begin+        ~SYM[1] := ~VAR[bv][1];+        ~SYM[1](~LIT[2] downto ~LIT[3]) := ~ARG[4];+        ~RESULT <= ~SYM[1];+      end process;+      -- setSlice end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.slice#+    kind: Expression+    type: |-+      slice# :: BitVector (m + 1 + i) -- ARG[0]+              -> SNat m                -- ARG[1]+              -> SNat n                -- ARG[2]+              -> BitVector (m + 1 - n)+    template: ~VAR[bv][0](~LIT[1] downto ~LIT[2])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.split#+    kind: Expression+    type: |-+      split# :: KnownNat n        -- ARG[0]+              => BitVector (m + n) -- ARG[1]+              -> (BitVector m, BitVector n)+    template: (~VAR[bv][1](~VAR[bv][1]'high downto ~LIT[0]),~VAR[bv][1](~LIT[0]-1+      downto 0))+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.msb#+    kind: Expression+    type: |-+      msb# :: KnownNat n  -- ARG[0]+            => BitVector n -- ARG[1]+            -> Bit+    template: ~IF ~SIZE[~TYP[1]] ~THEN ~VAR[bv][1](~VAR[bv][1]'high) ~ELSE "0" ~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.lsb#+    kind: Expression+    type: |-+      lsb# :: BitVector n -- ARG[0]+            -> Bit+    template: ~IF ~SIZE[~TYP[0]] ~THEN ~VAR[bv][0](0) ~ELSE "0" ~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.eq#+    kind: Expression+    type: 'eq# :: KnownNat+      n => BitVector n -> BitVector n -> Bool'+    template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] = ~ARG[2]~ELSEtrue~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.neq#+    kind: Expression+    type: 'neq# :: KnownNat+      n => BitVector n -> BitVector n -> Bool'+    template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] /= ~ARG[2]~ELSEfalse~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.lt#+    kind: Expression+    type: 'lt# :: KnownNat+      n => BitVector n -> BitVector n -> Bool'+    template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] < ~ARG[2]~ELSEfalse~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.ge#+    kind: Expression+    type: 'ge# :: KnownNat+      n => BitVector n -> BitVector n -> Bool'+    template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] >= ~ARG[2]~ELSEtrue~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.gt#+    kind: Expression+    type: 'gt# :: KnownNat+      n => BitVector n -> BitVector n -> Bool'+    template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] > ~ARG[2]~ELSEfalse~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.le#+    kind: Expression+    type: 'le# :: KnownNat+      n => BitVector n -> BitVector n -> Bool'+    template: ~IF~SIZE[~TYP[1]]~THEN~ARG[1] <= ~ARG[2]~ELSEtrue~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.minBound#+    kind: Expression+    type: 'minBound# :: BitVector+      n'+    template: ~IF~SIZE[~TYPO]~THENstd_logic_vector'(~SIZE[~TYPO]-1 downto 0 => '0')~ELSEstd_logic_vector'(0+      downto 1 => '0')~FI+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.BitVector.maxBound#+    kind: Expression+    type: 'maxBound# :: KnownNat+      n => BitVector n'+    template: ~IF~SIZE[~TYPO]~THENstd_logic_vector'(~SIZE[~TYPO]-1 downto 0 => '1')~ELSEstd_logic_vector'(0+      downto 1 => '1')~FI+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.BitVector.+#+    kind: Expression+    type: '(+#) :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: std_logic_vector(unsigned(~ARG[1]) + unsigned(~ARG[2]))+- BlackBox:+    name: Clash.Sized.Internal.BitVector.-#+    kind: Expression+    type: '(-#) :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: std_logic_vector(unsigned(~ARG[1]) - unsigned(~ARG[2]))+- BlackBox:+    name: Clash.Sized.Internal.BitVector.*#+    kind: Expression+    type: '(*#) :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: std_logic_vector(resize(unsigned(~ARG[1]) * unsigned(~ARG[2]), ~SIZE[~TYP[1]]))+- BlackBox:+    name: Clash.Sized.Internal.BitVector.negate#+    kind: Expression+    type: 'negate# :: KnownNat+      n => BitVector n -> BitVector n'+    template: std_logic_vector(-(signed(~ARG[1])))+- BlackBox:+    name: Clash.Sized.Internal.BitVector.fromInteger#+    kind: Expression+    type: 'fromInteger# ::+      KnownNat n => Integer -> Integer -> BitVector n'+    template: std_logic_vector(resize(unsigned(std_logic_vector(~ARG[2])),~SIZE[~TYPO]))+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.toEnum#+    kind: Expression+    type: 'toEnum# :: KnownNat+      n => Int -> BitVector n'+    template: std_logic_vector(resize(unsigned(std_logic_vector(~ARG[1])),~SIZE[~TYPO]))+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.fromEnum#+    kind: Expression+    type: 'fromEnum# :: KnownNat+      n => BitVector n -> Int'+    template: ~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(unsigned(~ARG[1]),~SIZE[~TYPO])))~ELSEto_signed(0,~SIZE[~TYPO])~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.plus#+    kind: Expression+    type: 'plus# :: (KnownNat+      m, KnownNat n) => BitVector m -> BitVector n -> BitVector (Max m n + 1)'+    template: ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THENstd_logic_vector(resize(unsigned(~ARG[2]),~SIZE[~TYPO])+      + resize(unsigned(~ARG[3]),~SIZE[~TYPO]))~ELSE~IF~SIZE[~TYP[2]]~THENstd_logic_vector(resize(unsigned(~ARG[2]),~SIZE[~TYPO]))~ELSEstd_logic_vector(resize(unsigned(~ARG[3]),~SIZE[~TYPO]))~FI~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.minus#+    kind: Expression+    type: 'minus# :: (KnownNat+      m, KnownNat n) => BitVector m -> BitVector n -> BitVector (Max m n + 1)'+    template: ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THENstd_logic_vector(resize(unsigned(~ARG[2]),~SIZE[~TYPO])+      - resize(unsigned(~ARG[3]),~SIZE[~TYPO]))~ELSE~IF~SIZE[~TYP[2]]~THENstd_logic_vector(resize(unsigned(~ARG[2]),~SIZE[~TYPO]))~ELSEstd_logic_vector(-resize(signed(~ARG[3]),~SIZE[~TYPO]))~FI~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.times#+    kind: Expression+    type: 'times# :: (KnownNat+      m, KnownNat n) => BitVector m -> BitVector n -> BitVector (m + n)'+    template: ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THENstd_logic_vector(unsigned(~ARG[2])+      * unsigned(~ARG[3]))~ELSE(~SIZE[~TYPO]-1 downto 0 => '0')~FI+- BlackBox:+    name: Clash.Sized.Internal.BitVector.quot#+    kind: Declaration+    type: 'quot# :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: |-+      ~RESULT <= std_logic_vector(unsigned(~ARG[1]) / unsigned(~ARG[2]))+          -- pragma translate_off+          when (~ARG[2] /= std_logic_vector(to_unsigned(0,~SIZE[~TYP[2]]))) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: Clash.Sized.Internal.BitVector.rem#+    kind: Declaration+    type: 'rem# :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: |-+      ~RESULT <= std_logic_vector(unsigned(~ARG[1]) rem unsigned(~ARG[2]))+          -- pragma translate_off+          when (~ARG[2] /= std_logic_vector(to_unsigned(0,~SIZE[~TYP[2]]))) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBoxHaskell:+    name: Clash.Sized.Internal.BitVector.toInteger#+    templateFunction: Clash.Primitives.Sized.ToInteger.bvToIntegerVHDL+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.BitVector.and#+    kind: Expression+    type: 'and# :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: ~ARG[1] and ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.or#+    kind: Expression+    type: 'or# :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: ~ARG[1] or ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.xor#+    kind: Expression+    type: 'xor# :: KnownNat+      n => BitVector n -> BitVector n -> BitVector n'+    template: ~ARG[1] xor ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.complement#+    kind: Expression+    type: 'complement# ::+      KnownNat n => BitVector n -> BitVector n'+    template: not ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.BitVector.shiftL#+    kind: Declaration+    type: 'shiftL# :: KnownNat+      n => BitVector n -> Int -> BitVector n'+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][2](~SIZE[~TYP[2]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][2]);+        ~RESULT <= std_logic_vector(shift_left(unsigned(~ARG[1]),~SYM[1]))+            -- pragma translate_off+            when (~ARG[2] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: Clash.Sized.Internal.BitVector.shiftR#+    kind: Declaration+    type: 'shiftR# :: KnownNat+      n => BitVector n -> Int -> BitVector n'+    template: |-+      ~GENSYM[~RESULT_shiftR][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][2](~SIZE[~TYP[2]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][2]);+        ~RESULT <= std_logic_vector(shift_right(unsigned(~ARG[1]),~SYM[1]))+            -- pragma translate_off+            when (~ARG[2] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: Clash.Sized.Internal.BitVector.rotateL#+    kind: Declaration+    type: 'rotateL# :: KnownNat+      n => BitVector n -> Int -> BitVector n'+    template: |-+      ~RESULT <= std_logic_vector(rotate_left(unsigned(~ARG[1]),to_integer((~ARG[2])+          -- pragma translate_off+          mod ~SIZE[~TYP[1]]+          -- pragma translate_on+          )))+          -- pragma translate_off+          when (~ARG[2] >= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: Clash.Sized.Internal.BitVector.rotateR#+    kind: Declaration+    type: 'rotateR# :: KnownNat+      n => BitVector n -> Int -> BitVector n'+    template: |-+      ~RESULT <= std_logic_vector(rotate_right(unsigned(~ARG[1]),to_integer((~ARG[2])+          -- pragma translate_off+          mod ~SIZE[~TYP[1]]+          -- pragma translate_on+          )))+          -- pragma translate_off+          when (~ARG[2] >= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: Clash.Sized.Internal.BitVector.truncateB#+    kind: Expression+    type: 'truncateB# :: forall+      a b . KnownNat a => BitVector (a + b) -> BitVector a'+    template: std_logic_vector(resize(unsigned(~ARG[1]),~SIZE[~TYPO]))+    workInfo: Never
+ prims/vhdl/Clash_Sized_Internal_Index.primitives.yaml view
@@ -0,0 +1,148 @@+- BlackBox:+    name: Clash.Sized.Internal.Index.pack#+    kind: Expression+    type: |-+      pack# :: Index n -> BitVector (CLogWZ 2 n 0)+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.unpack#+    kind: Expression+    type: |-+      unpack# :: KnownNat n => BitVector (CLogWZ 2 n 0) -> Index n+    template: unsigned(~ARG[1])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.eq#+    kind: Expression+    type: 'eq# :: Index n+      -> Index n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] = ~ARG[1]~ELSEtrue~FI+- BlackBox:+    name: Clash.Sized.Internal.Index.neq#+    kind: Expression+    type: 'neq# :: Index n+      -> Index n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] /= ~ARG[1]~ELSEfalse~FI+- BlackBox:+    name: Clash.Sized.Internal.Index.lt#+    kind: Expression+    type: 'lt# :: Index n+      -> Index n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSEfalse~FI+- BlackBox:+    name: Clash.Sized.Internal.Index.ge#+    kind: Expression+    type: 'ge# :: Index n+      -> Index n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSEtrue~FI+- BlackBox:+    name: Clash.Sized.Internal.Index.gt#+    kind: Expression+    type: 'gt# :: Index n+      -> Index n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSEfalse~FI+- BlackBox:+    name: Clash.Sized.Internal.Index.le#+    kind: Expression+    type: 'le# :: Index n+      -> Index n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSEtrue~FI+- BlackBox:+    name: Clash.Sized.Internal.Index.maxBound#+    kind: Expression+    type: 'maxBound# :: KnownNat+      n => Index n'+    template: to_unsigned(~LIT[0]-1,~SIZE[~TYPO])+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Index.toEnum#+    kind: Expression+    type: 'toEnum# :: KnownNat+      n => Int -> Index n'+    template: resize(unsigned(std_logic_vector(~ARG[1])),~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.fromEnum#+    kind: Expression+    type: 'fromEnum# :: KnownNat+      n => Index n -> Int'+    template: ~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(~ARG[1],~SIZE[~TYPO])))~ELSEto_signed(0,~SIZE[~TYPO])~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.+#+    kind: Expression+    type: '(+#) :: KnownNat+      n => Index n -> Index n -> Index n'+    template: ~ARG[1] + ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Index.-#+    kind: Expression+    type: '(-#) :: KnownNat+      n => Index n -> Index n -> Index n'+    template: ~ARG[1] - ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Index.*#+    kind: Expression+    type: '(*#) :: KnownNat+      n => Index n -> Index n -> Index n'+    template: resize(~ARG[1] * ~ARG[2], ~SIZE[~TYPO])+- BlackBox:+    name: Clash.Sized.Internal.Index.fromInteger#+    kind: Expression+    type: 'fromInteger# ::+      KnownNat n => Integer -> Index n'+    template: resize(unsigned(std_logic_vector(~ARG[1])),~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.plus#+    kind: Expression+    type: Index m -> Index+      n -> Index (m + n - 1)+    template: resize(~ARG[0],~SIZE[~TYPO]) + resize(~ARG[1],~SIZE[~TYPO])+- BlackBox:+    name: Clash.Sized.Internal.Index.minus#+    kind: Expression+    type: Index m -> Index+      n -> Index (m + n - 1)+    template: resize(~ARG[0],~SIZE[~TYPO]) - resize(~ARG[1],~SIZE[~TYPO])+- BlackBox:+    name: Clash.Sized.Internal.Index.times#+    kind: Expression+    type: Index m -> Index+      n -> Index (((m-1) * (n-1)) + 1)+    template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+- BlackBox:+    name: Clash.Sized.Internal.Index.rem#+    kind: Declaration+    type: 'rem# :: Index n+      -> Index n -> Index n'+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBoxHaskell:+    name: Clash.Sized.Internal.Index.toInteger#+    templateFunction: Clash.Primitives.Sized.ToInteger.indexToIntegerVHDL+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.resize#+    kind: Expression+    type: 'resize# :: KnownNat+      m => Index n -> Index m'+    template: ~IF~SIZE[~TYP[1]]~THENresize(~ARG[1],~SIZE[~TYPO])~ELSEunsigned'(~SIZE[~TYPO]-1+      downto 0 => '0')~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Index.quot#+    kind: Declaration+    type: 'quot# :: Index+      n -> Index n -> Index n'+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;
+ prims/vhdl/Clash_Sized_Internal_Signed.primitives.yaml view
@@ -0,0 +1,316 @@+- BlackBox:+    name: Clash.Sized.Internal.Signed.size#+    kind: Expression+    type: 'size# :: KnownNat+      n => Signed n -> Int'+    template: to_signed(~LIT[0],~SIZE[~TYPO])+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Signed.pack#+    kind: Expression+    type: 'pack# :: KnownNat+      n => Signed n -> BitVector n'+    template: std_logic_vector(~ARG[1])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.unpack#+    kind: Expression+    type: 'unpack# :: KnownNat+      n => BitVector n -> Signed n'+    template: signed(~ARG[1])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.eq#+    kind: Expression+    type: 'eq# :: Signed n+      -> Signed n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] = ~ARG[1]~ELSEtrue~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.neq#+    kind: Expression+    type: 'neq# :: Signed+      n -> Signed n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] /= ~ARG[1]~ELSEfalse~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.lt#+    kind: Expression+    type: 'lt# :: Signed n+      -> Signed n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSEfalse~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.ge#+    kind: Expression+    type: 'ge# :: Signed n+      -> Signed n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSEtrue~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.gt#+    kind: Expression+    type: 'gt# :: Signed n+      -> Signed n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSEfalse~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.le#+    kind: Expression+    type: 'le# :: Signed n+      -> Signed n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSEtrue~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.minBound#+    comment: the quantification with signed gives the array an ascending index+    kind: Expression+    type: 'minBound# :: KnownNat+      n => Signed n'+    template: ~IF~SIZE[~TYPO]~THENsigned'(0 => '1', 1 to ~LIT[0]-1 => '0')~ELSEsigned'(1+      downto 0 => '0')~FI+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Signed.maxBound#+    comment: the quantification with signed gives the array an ascending index+    kind: Expression+    type: 'maxBound# :: KnownNat+      n => Signed n'+    template: ~IF~SIZE[~TYPO]~THENsigned'(0 => '0', 1 to ~LIT[0]-1  => '1')~ELSEsigned'(1+      downto 0 => '0')~FI+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Signed.*#+    kind: Declaration+    type: '(*#) :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: |-+      ~GENSYM[~RESULT_mult][0] : block+        signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+      begin+        ~SYM[1] <= ~ARG[1] * ~ARG[2];+        ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+      end block;+- BlackBox:+    name: Clash.Sized.Internal.Signed.negate#+    kind: Expression+    type: 'negate# :: KnownNat+      n => Signed n -> Signed n'+    template: -~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Signed.abs#+    kind: Expression+    type: 'abs# :: KnownNat+      n => Signed n -> Signed n'+    template: abs ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Signed.fromInteger#+    format: Haskell+    kind: Expression+    type: 'fromInteger# ::+      KnownNat n => Integer -> Signed (n :: Nat)'+    templateFunction: Clash.Primitives.Sized.Signed.fromIntegerTFvhdl+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.toEnum#+    kind: Expression+    type: 'toEnum# :: KnownNat+      n => Int -> Signed n'+    template: resize(signed(std_logic_vector(~ARG[1])),~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.fromEnum#+    kind: Expression+    type: 'fromEnum# :: KnownNat+      n => Signed n -> Int'+    template: ~IF~SIZE[~TYP[1]]~THENresize(~ARG[1],~SIZE[~TYPO])~ELSEto_signed(0,~SIZE[~TYPO])~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.plus#+    kind: Expression+    type: 'plus# :: Signed+      m -> Signed n -> Signed (1 + Max m n)'+    template: ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THENresize(~ARG[0],~SIZE[~TYPO])+      + resize(~ARG[1],~SIZE[~TYPO])~ELSE~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEresize(~ARG[1],~SIZE[~TYPO])~FI~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.minus#+    kind: Expression+    type: 'minus# :: Signed+      m -> Signed n -> Signed (1 + Max m n)'+    template: ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THENresize(~ARG[0],~SIZE[~TYPO])+      - resize(~ARG[1],~SIZE[~TYPO])~ELSE~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEresize(-+      ~ARG[1],~SIZE[~TYPO])~FI~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.times#+    kind: Expression+    type: 'times# :: Signed+      m -> Signed n -> Signed (m + n)'+    template: ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN~ARG[0] * ~ARG[1]~ELSEsigned'(~SIZE[~TYPO]-1+      downto 0 => '0')~FI+- BlackBox:+    name: Clash.Sized.Internal.Signed.rem#+    kind: Declaration+    type: 'rem# :: Signed+      n -> Signed n -> Signed n'+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: Clash.Sized.Internal.Signed.div#+    kind: Declaration+    type: 'div# :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: |-+      -- divSigned begin+      ~GENSYM[divSigned][0] : block+        signal ~GENSYM[resultPos][1] : boolean;+        signal ~GENSYM[dividerNeg][2] : boolean;+        signal ~GENSYM[dividend2][3] : signed(~SIZE[~TYPO] downto 0);+        signal ~GENSYM[quot_res][4] : signed(~SIZE[~TYPO] downto 0);+      begin+        ~SYM[1] <= ~VAR[dividend][1](~VAR[dividend][1]'high) = ~VAR[divider][2](~VAR[divider][2]'high);+        ~SYM[2] <= ~VAR[divider][2](~VAR[divider][2]'high) = '1';+        ~SYM[3] <= resize(~VAR[dividend][1],~SIZE[~TYPO]+1)   when ~SYM[1] else+                   (resize(~VAR[dividend][1],~SIZE[~TYPO]+1) - resize(~VAR[divider][2],~SIZE[~TYPO]+1) - 1)   when ~SYM[2] else+                   (resize(~VAR[dividend][1],~SIZE[~TYPO]+1) - resize(~VAR[divider][2],~SIZE[~TYPO]+1) + 1);+        ~SYM[4] <= ~SYM[3] / ~VAR[divider][2]+            -- pragma translate_off+            when (~VAR[divider][2] /= 0) else (others => 'X')+            -- pragma translate_on+            ;+        ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0));+      end block;+      -- divSigned end+- BlackBox:+    name: Clash.Sized.Internal.Signed.mod#+    kind: Declaration+    type: 'mod# :: Signed+      n -> Signed n -> Signed n'+    template: |-+      ~RESULT <= ~ARG[0] mod ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBoxHaskell:+    name: Clash.Sized.Internal.Signed.toInteger#+    templateFunction: Clash.Primitives.Sized.ToInteger.signedToIntegerVHDL+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.and#+    kind: Expression+    type: 'and# :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: ~ARG[1] and ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Signed.or#+    kind: Expression+    type: 'or# :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: ~ARG[1] or ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Signed.xor#+    kind: Expression+    type: 'xor# :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: ~ARG[1] xor ~ARG[2]+- BlackBox:+    name: Clash.Sized.Internal.Signed.complement#+    kind: Expression+    type: 'complement# ::+      KnownNat n => Signed n -> Signed n'+    template: not ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Signed.shiftL#+    kind: Declaration+    type: 'shiftL# :: KnownNat+      n => Signed n -> Int -> Signed n'+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][2](~SIZE[~TYP[2]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][2]);+        ~RESULT <= shift_left(~ARG[1],~SYM[1])+            -- pragma translate_off+            when (~ARG[2] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: Clash.Sized.Internal.Signed.shiftR#+    kind: Declaration+    type: 'shiftR# :: KnownNat+      n => Signed n -> Int -> Signed n'+    template: |-+      ~GENSYM[~RESULT_shiftR][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][2](~SIZE[~TYP[2]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][2]);+        ~RESULT <= shift_right(~ARG[1],~SYM[1])+            -- pragma translate_off+            when (~ARG[2] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: Clash.Sized.Internal.Signed.rotateL#+    kind: Declaration+    type: 'rotateL# :: KnownNat+      n => Signed n -> Int -> Signed n'+    template: |-+      ~RESULT <= rotate_left(~ARG[1],to_integer((~ARG[2])+          -- pragma translate_off+          mod ~SIZE[~TYP[1]]+          -- pragma translate_on+          ))+          -- pragma translate_off+          when (~ARG[2] >= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: Clash.Sized.Internal.Signed.rotateR#+    kind: Declaration+    type: 'rotateR# :: KnownNat+      n => Signed n -> Int -> Signed n'+    template: |-+      ~RESULT <= rotate_right(~ARG[1],to_integer((~ARG[2])+          -- pragma translate_off+          mod ~SIZE[~TYP[1]]+          -- pragma translate_on+          ))+          -- pragma translate_off+          when (~ARG[2] >= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: Clash.Sized.Internal.Signed.resize#+    kind: Expression+    type: 'resize# :: (KnownNat+      n, KnownNat m) => Signed n -> Signed m'+    template: ~IF~SIZE[~TYP[2]]~THENresize(~ARG[2],~LIT[1])~ELSEsigned'(~SIZE[~TYPO]-1+      downto 0 => '0')~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.truncateB#+    kind: Expression+    type: 'truncateB# :: KnownNat+      m => Signed (n + m) -> Signed m'+    template: ~IF~SIZE[~TYPO]~THEN~VAR[s][1](~LIT[0]-1 downto 0)~ELSEsigned'(0 downto+      1 => '0')~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Signed.quot#+    kind: Declaration+    type: 'quot# :: KnownNat+      n => Signed n -> Signed n -> Signed n'+    template: |-+      ~RESULT <= ~ARG[1] / ~ARG[2]+          -- pragma translate_off+          when (~ARG[2] /= 0) else (others => 'X')+          -- pragma translate_on+          ;
+ prims/vhdl/Clash_Sized_Internal_Unsigned.primitives.yaml view
@@ -0,0 +1,255 @@+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.size#+    kind: Expression+    type: 'size# :: KnownNat+      n => Unsigned n -> Int'+    template: to_signed(~LIT[0],~SIZE[~TYPO])+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.pack#+    kind: Expression+    type: 'pack# :: Unsigned+      n -> BitVector n'+    template: std_logic_vector(~ARG[0])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.unpack#+    kind: Expression+    type: 'unpack# :: KnownNat+      n => BitVector n -> Unsigned n'+    template: unsigned(~ARG[1])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.eq#+    kind: Expression+    type: 'eq# :: Unsigned+      n -> Unsigned n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] = ~ARG[1]~ELSEtrue~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.neq#+    kind: Expression+    type: 'neq# :: Unsigned+      n -> Unsigned n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] /= ~ARG[1]~ELSEfalse~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.lt#+    kind: Expression+    type: 'lt# :: Unsigned+      n -> Unsigned n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] < ~ARG[1]~ELSEfalse~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.ge#+    kind: Expression+    type: 'ge# :: Unsigned+      n -> Unsigned n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] >= ~ARG[1]~ELSEtrue~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.gt#+    kind: Expression+    type: 'gt# :: Unsigned+      n -> Unsigned n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] > ~ARG[1]~ELSEfalse~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.le#+    kind: Expression+    type: 'le# :: Unsigned+      n -> Unsigned n -> Bool'+    template: ~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSEtrue~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.minBound#+    kind: Expression+    type: 'minBound# :: Unsigned+      n'+    template: ~IF~SIZE[~TYPO]~THENunsigned'(~SIZE[~TYPO]-1 downto 0 => '0')~ELSEunsigned'(0+      downto 1 => '0')~FI+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.maxBound#+    kind: Expression+    type: 'maxBound# :: KnownNat+      n => Unsigned n'+    template: ~IF~SIZE[~TYPO]~THENunsigned'(~LIT[0]-1 downto 0 => '1')~ELSEunsigned'(0+      downto 1 => '1')~FI+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.*#+    kind: Expression+    type: '(*#) :: KnownNat+      n => Unsigned n -> Unsigned n -> Unsigned n'+    template: resize(~ARG[1] * ~ARG[2], ~LIT[0])+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.negate#+    kind: Expression+    type: 'negate# :: KnownNat+      n => Unsigned n -> Unsigned n'+    template: unsigned(std_logic_vector(-(signed(std_logic_vector(~ARG[1])))))+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.fromInteger#+    kind: Expression+    type: 'fromInteger# ::+      KnownNat n => Integer -> Unsigned n'+    template: resize(unsigned(std_logic_vector(~ARG[1])),~LIT[0])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.toEnum#+    kind: Expression+    type: 'toEnum# :: KnownNat+      n => Int -> Unsigned n'+    template: resize(unsigned(std_logic_vector(~ARG[1])),~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.fromEnum#+    kind: Expression+    type: 'fromEnum# :: KnownNat+      n => Unsigned n -> Int'+    template: ~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(~ARG[1],~SIZE[~TYPO])))~ELSEto_signed(0,~SIZE[~TYPO])~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.plus#+    kind: Expression+    type: 'plus# :: Unsigned+      m -> Unsigned n -> Unsigned (1 + Max m n)'+    template: ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THENresize(~ARG[0],~SIZE[~TYPO])+      + resize(~ARG[1],~SIZE[~TYPO])~ELSE~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEresize(~ARG[1],~SIZE[~TYPO])~FI~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.minus#+    kind: Expression+    type: 'minus# :: (KnownNat+      m,KnownNat n) => Unsigned m -> Unsigned n -> Unsigned (1 + Max m n)'+    template: ~IF~AND[~SIZE[~TYP[2]],~SIZE[~TYP[3]]]~THENresize(~ARG[2],~SIZE[~TYPO])+      - resize(~ARG[3],~SIZE[~TYPO])~ELSE~IF~SIZE[~TYP[2]]~THENresize(~ARG[2],~SIZE[~TYPO])~ELSEresize(~ARG[3],~SIZE[~TYPO])~FI~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.times#+    kind: Expression+    type: 'times# :: Unsigned+      m -> Unsigned n -> Unsigned (m + n)'+    template: ~IF~AND[~SIZE[~TYP[0]],~SIZE[~TYP[1]]]~THEN~ARG[0] * ~ARG[1]~ELSEunsigned'(~SIZE[~TYPO]-1+      downto 0 => '0')~FI+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.rem#+    kind: Declaration+    type: 'rem# :: Unsigned+      n -> Unsigned n -> Unsigned n'+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBoxHaskell:+    name: Clash.Sized.Internal.Unsigned.toInteger#+    templateFunction: Clash.Primitives.Sized.ToInteger.unsignedToIntegerVHDL+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.and#+    kind: Expression+    type: 'and# :: Unsigned+      n -> Unsigned n -> Unsigned n'+    template: ~ARG[0] and ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.or#+    kind: Expression+    type: 'or# :: Unsigned+      n -> Unsigned n -> Unsigned n'+    template: ~ARG[0] or ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.xor#+    kind: Expression+    type: 'xor# :: Unsigned+      n -> Unsigned n -> Unsigned n'+    template: ~ARG[0] xor ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.complement#+    kind: Expression+    type: 'complement# ::+      KnownNat n => Unsigned n -> Unsigned n'+    template: not ~ARG[1]+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.shiftL#+    kind: Declaration+    type: 'shiftL# :: KnownNat+      n => Unsigned n -> Int -> Unsigned n'+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][2](~SIZE[~TYP[2]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][2]);+        ~RESULT <= shift_left(~ARG[1],~SYM[1])+            -- pragma translate_off+            when (~ARG[2] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.shiftR#+    kind: Declaration+    type: 'shiftR# :: KnownNat+      n => Unsigned n -> Int -> Unsigned n'+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][2](~SIZE[~TYP[2]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][2]);+        ~RESULT <= shift_right(~ARG[1],~SYM[1])+            -- pragma translate_off+            when (~ARG[2] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.rotateL#+    kind: Declaration+    type: 'rotateL# :: KnownNat+      n => Unsigned n -> Int -> Unsigned n'+    template: |-+      ~RESULT <= rotate_left(~ARG[1],to_integer((~ARG[2])+          -- pragma translate_off+          mod ~SIZE[~TYP[1]]+          -- pragma translate_on+          ))+          -- pragma translate_off+          when (~ARG[2] >= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.rotateR#+    kind: Declaration+    type: 'rotateR# :: KnownNat+      n => Unsigned n -> Int -> Unsigned n'+    template: |-+      ~RESULT <= rotate_right(~ARG[1],to_integer((~ARG[2])+          -- pragma translate_off+          mod ~SIZE[~TYP[1]]+          -- pragma translate_on+          ))+          -- pragma translate_off+          when (~ARG[2] >= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.resize#+    kind: Expression+    type: 'resize# :: KnownNat+      m => Unsigned n -> Unsigned m'+    template: ~IF~SIZE[~TYP[1]]~THENresize(~ARG[1],~LIT[0])~ELSEunsigned'(~SIZE[~TYPO]-1+      downto 0 => '0')~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Internal.Unsigned.quot#+    kind: Declaration+    type: 'quot# :: Unsigned+      n -> Unsigned n -> Unsigned n'+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;
+ prims/vhdl/Clash_Sized_RTree.primitives.yaml view
@@ -0,0 +1,23 @@+- BlackBox:+    name: Clash.Sized.RTree.treplicate+    kind: Expression+    type: 'replicate :: SNat+      n -> a -> RTree d a'+    template: ~TYPMO'(0 to (2**~LIT[0])-1 => ~IF~VIVADO~THEN~TOBV[~ARG[1]][~TYP[1]]~ELSE~ARG[1]~FI)+    workInfo: Never+- BlackBox:+    name: Clash.Sized.RTree.textract+    kind: Expression+    type: 'textract :: RTree+      0 a -> a'+    template: ~IF ~VIVADO ~THEN ~FROMBV[~VAR[t][0](0)][~TYPO] ~ELSE ~VAR[t][0](0)+      ~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.RTree.tsplit+    kind: Expression+    type: 'tsplit:: RTree+      (d+1) a -> (RTree d a,RTree d a)'+    template: (~VAR[t][0](0 to (2**(~DEPTH[~TYP[0]]-1))-1) ,~VAR[t][0](2**(~DEPTH[~TYP[0]]-1)+      to (2**~DEPTH[~TYP[0]])-1))+    workInfo: Never
+ prims/vhdl/Clash_Sized_Vector.primitives.yaml view
@@ -0,0 +1,392 @@+- BlackBox:+    name: Clash.Sized.Vector.head+    kind: Expression+    type: 'head :: Vec (n + 1) a -> a'+    template: ~IF ~VIVADO ~THEN ~TYPMO'(fromSLV(~VAR[vec][0](0))) ~ELSE ~VAR[vec][0](0)+      ~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.tail+    kind: Expression+    type: 'tail :: Vec (n + 1) a -> Vec n a'+    template: ~VAR[vec][0](1 to ~VAR[vec][0]'high)+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.last+    kind: Expression+    type: Vec (n + 1) a -> a+    template: ~IF ~VIVADO ~THEN ~TYPMO'(fromSLV(~VAR[vec][0](~VAR[vec][0]'high)))+      ~ELSE ~VAR[vec][0](~VAR[vec][0]'high) ~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.init+    kind: Expression+    type: Vec (n + 1) a -> Vec n a+    template: ~VAR[vec][0](0 to ~VAR[vec][0]'high - 1)+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.select+    kind: Declaration+    type: |-+      select :: (CmpNat (i + s) (s * n) ~ GT) -- ARG[0]+              => SNat f                        -- ARG[1]+              -> SNat s                        -- ARG[2]+              -> SNat n                        -- ARG[3]+              -> Vec i a                       -- ARG[4]+              -> Vec n a+    template: |-+      -- select begin+      ~GENSYM[select][0] : for ~GENSYM[i][1] in ~RESULT'range generate+        ~RESULT(~SYM[1]) <= ~VAR[vec][4](~LIT[1]+(~LIT[2]*~SYM[1]));+      end generate;+      -- select end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.+++    kind: Expression+    type: '(++) :: Vec n a -> Vec m a -> Vec (n + m) a'+    template: ~TYPMO'(~TYPM[0]'(~ARG[0]) & ~TYPM[1]'(~ARG[1]))+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.concat+    kind: Declaration+    type: 'concat :: Vec n (Vec m a) -> Vec (n * m) a'+    template: |-+      -- concat begin+      ~GENSYM[concat][0] : for ~GENSYM[i][1] in 0 to (~LENGTH[~TYP[0]] - 1) generate+      begin~IF ~VIVADO ~THEN+      ~RESULT(~SYM[1] * ~LENGTH[~TYPEL[~TYP[0]]] to ((~SYM[1]+1) * ~LENGTH[~TYPEL[~TYP[0]]]) - 1) <= fromSLV(~VAR[vec][0](~SYM[1]));~ELSE+      ~RESULT(~SYM[1] * ~LENGTH[~TYPEL[~TYP[0]]] to ((~SYM[1]+1) * ~LENGTH[~TYPEL[~TYP[0]]]) - 1) <= ~VAR[vec][0](~SYM[1]);~FI+      end generate;+      -- concat end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.splitAt+    kind: Expression+    type: 'splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a)'+    template: ~IF~LENGTH[~TYPO]~THEN~ARG[1]~ELSE(~VAR[vec][1](0 to ~LIT[0]-1),~VAR[vec][1](~LIT[0]+      to ~VAR[vec][1]'high))~FI+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.unconcat+    kind: Declaration+    type: |-+      unconcat :: KnownNat n     -- ARG[0]+                => SNat m         -- ARG[1]+                -> Vec (n * m) a  -- ARG[2]+                -> Vec n (Vec m a)+    template: |-+      -- unconcat begin~DEVNULL[~ARG[0]]+      ~GENSYM[unconcat][0] : for ~GENSYM[i][2] in ~RESULT'range generate+      begin~IF ~VIVADO ~THEN+        ~RESULT(~SYM[2]) <= ~TOBV[~VAR[vec][2]((~SYM[2] * ~LIT[1]) to ((~SYM[2] * ~LIT[1]) + ~LIT[1] - 1))][~TYPEL[~TYPO]];~ELSE+        ~RESULT(~SYM[2]) <= ~VAR[vec][2]((~SYM[2] * ~LIT[1]) to ((~SYM[2] * ~LIT[1]) + ~LIT[1] - 1));~FI+      end generate;+      -- unconcat end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.map+    kind: Declaration+    type: 'map :: (a -> b) -> Vec n a -> Vec n b'+    template: |-+      -- map begin+      ~GENSYM[map][0] : for ~GENSYM[i][1] in ~RESULT'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[1]]~THEN+        signal ~GENSYM[map_in][2]  : ~TYPEL[~TYP[1]];~ELSE ~FI+        signal ~GENSYM[map_out][3] : ~TYPEL[~TYPO];+      begin~IF~SIZE[~TYP[1]]~THEN+        ~SYM[2] <= fromSLV(~VAR[vec][1](~SYM[1]));~ELSE ~FI+        ~INST 0+          ~OUTPUT <= ~SYM[3]~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~SYM[2]~ ~TYPEL[~TYP[1]]~+        ~INST+        ~RESULT(~SYM[1]) <= ~TOBV[~SYM[3]][~TYPEL[~TYPO]];+      end generate;~ELSE+      begin+        ~INST 0+          ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~VAR[vec][1](~SYM[1])~ ~TYPEL[~TYP[1]]~+        ~INST+      end generate;~FI+      -- map end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.imap+    kind: Declaration+    type: 'imap :: KnownNat n => (Index n -> a -> b) -> Vec n a -> Vec n b'+    template: |-+      -- imap begin+      ~GENSYM[imap][0] : block+        function ~GENSYM[max][6] (l,r : in natural) return natural is+        begin+          if l > r then return l;+          else return r;+          end if;+        end function;+      begin+        ~GENSYM[imap][5] : for ~GENSYM[i][1] in ~RESULT'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[2]]~THEN+          signal ~GENSYM[map_in][2]  : ~TYPEL[~TYP[2]];~ELSE ~FI+          signal ~GENSYM[map_out][3] : ~TYPEL[~TYPO];+        begin~IF~SIZE[~TYP[2]]~THEN+          ~SYM[2] <= fromSLV(~VAR[vec][2](~SYM[1]));~ELSE ~FI+          ~INST 1+            ~OUTPUT <= ~SYM[3]~ ~TYPEL[~TYPO]~+            ~INPUT  <= to_unsigned(~SYM[1],~SYM[6](1,integer(ceil(log2(real(~LIT[0]))))))~ ~INDEXTYPE[~LIT[0]]~+            ~INPUT  <= ~SYM[2]~ ~TYPEL[~TYP[2]]~+          ~INST+          ~RESULT(~SYM[1]) <= ~TOBV[~SYM[3]][~TYPEL[~TYPO]];+        end generate;~ELSE+        begin+          ~INST 1+            ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~+            ~INPUT  <= to_unsigned(~SYM[1],~SYM[6](1,integer(ceil(log2(real(~LIT[0]))))))~ ~INDEXTYPE[~LIT[0]]~+            ~INPUT  <= ~VAR[vec][2](~SYM[1])~ ~TYPEL[~TYP[2]]~+          ~INST+        end generate;~FI+      end block;+      -- imap end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.imap_go+    kind: Declaration+    type: 'imap_go :: (Index n -> a -> b) -> Vec m a -> Index n -> Vec m b'+    template: |-+      -- imap_go begin+      ~GENSYM[imap][5] : for ~GENSYM[i][1] in ~RESULT'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[1]]~THEN+        signal ~GENSYM[map_in][2]  : ~TYPEL[~TYP[1]];~ELSE ~FI+        signal ~GENSYM[map_out][3] : ~TYPEL[~TYPO];+        signal ~GENSYM[i2][4]      : ~TYP[2];+      begin~IF~SIZE[~TYP[1]]~THEN+        ~SYM[2] <= fromSLV(~VAR[vec][1](~SYM[1]));~ELSE ~FI+        ~SYM[4] <= ~ARG[2] + to_unsigned(~SYM[1],~SIZE[~TYP[2]]);+        ~INST 0+          ~OUTPUT <= ~SYM[3]~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~SYM[4]~ ~TYP[2]~+          ~INPUT  <= ~SYM[2]~ ~TYPEL[~TYP[1]]~+        ~INST+        ~RESULT(~SYM[1]) <= ~TOBV[~SYM[3]][~TYPEL[~TYPO]];+      end generate;~ELSE+        signal ~SYM[4] : ~TYP[2];+      begin+        ~SYM[4] <= ~ARG[2] + to_unsigned(~SYM[1],~SIZE[~TYP[2]]);+        ~INST 0+          ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~SYM[4]~ ~TYP[2]~+          ~INPUT  <= ~VAR[vec][1](~SYM[1])~ ~TYPEL[~TYP[1]]~+        ~INST+      end generate;~FI+      -- imap_go end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.zipWith+    kind: Declaration+    type: 'zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c'+    template: |-+      -- zipWith begin+      ~GENSYM[zipWith][0] : for ~GENSYM[i][1] in ~RESULT'range generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[1]]~THEN+        signal ~GENSYM[zipWith_in1][2] : ~TYPEL[~TYP[1]];~ELSE ~FI~IF~SIZE[~TYP[2]]~THEN+        signal ~GENSYM[zipWith_in2][6] : ~TYPEL[~TYP[2]];~ELSE ~FI+        signal ~GENSYM[zipWith_out][3] : ~TYPEL[~TYPO];+      begin~IF~SIZE[~TYP[1]]~THEN+        ~SYM[2] <= fromSLV(~VAR[vec1][1](~SYM[1]));~ELSE ~FI~IF~SIZE[~TYP[2]]~THEN+        ~SYM[6] <= fromSLV(~VAR[vec2][2](~SYM[1]));~ELSE ~FI+        ~INST 0+          ~OUTPUT <= ~SYM[3]~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~SYM[2]~ ~TYPEL[~TYP[1]]~+          ~INPUT  <= ~SYM[6]~ ~TYPEL[~TYP[2]]~+        ~INST+        ~RESULT(~SYM[1]) <= ~TOBV[~SYM[3]][~TYPEL[~TYPO]];+      end generate;~ELSE+      begin+        ~INST 0+          ~OUTPUT <= ~RESULT(~SYM[1])~ ~TYPEL[~TYPO]~+          ~INPUT  <= ~VAR[vec1][1](~SYM[1])~ ~TYPEL[~TYP[1]]~+          ~INPUT  <= ~VAR[vec2][2](~SYM[1])~ ~TYPEL[~TYP[2]]~+        ~INST+      end generate;~FI+      -- zipWith end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.foldr+    kind: Declaration+    type: 'foldr :: (a -> b -> b) -> b -> Vec n a -> b'+    template: |-+      -- foldr begin~IF ~LENGTH[~TYP[2]] ~THEN+      ~GENSYM[foldr][0] : block+        type ~GENSYM[foldr_res_type][1] is array (natural range <>) of ~TYP[1];+        signal ~GENSYM[intermediate][2] : ~SYM[1] (0 to ~LENGTH[~TYP[2]]);+      begin+        ~SYM[2](~LENGTH[~TYP[2]]) <= ~ARG[1];++        foldr_loop : for ~GENSYM[i][3] in 0 to (~LENGTH[~TYP[2]] - 1) generate~IF ~VIVADO ~THEN~IF~SIZE[~TYP[2]]~THEN+          signal ~GENSYM[foldr_in][4] : ~TYPEL[~TYP[2]];~ELSE ~FI+        begin~IF~SIZE[~TYP[2]]~THEN+          ~SYM[4] <= fromSLV(~VAR[vec][2](~SYM[3]));~ELSE ~FI+          ~INST 0+            ~OUTPUT <= ~SYM[2](~SYM[3])~ ~TYP[1]~+            ~INPUT  <= ~SYM[4]~ ~TYPEL[~TYP[2]]~+            ~INPUT  <= ~SYM[2](~SYM[3]+1)~ ~TYP[1]~+          ~INST+        end generate;~ELSE+        begin+          ~INST 0+            ~OUTPUT <= ~SYM[2](~SYM[3])~ ~TYP[1]~+            ~INPUT  <= ~VAR[vec][2](~SYM[3])~ ~TYPEL[~TYP[2]]~+            ~INPUT  <= ~SYM[2](~SYM[3]+1)~ ~TYP[1]~+          ~INST+        end generate;~FI++        ~RESULT <= ~SYM[2](0);+      end block;~ELSE+      ~RESULT <= ~ARG[1];~FI+      -- foldr end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.index_int+    kind: Declaration+    type: 'index_int :: KnownNat n => Vec n a -> Int -> a'+    template: |-+      -- index begin+      ~IF~SIZE[~TYP[1]]~THEN~GENSYM[indexVec][0] : block+        signal ~GENSYM[vec_index][1] : integer range 0 to ~LIT[0]-1;+      begin+        ~SYM[1] <= to_integer(~ARG[2])+        -- pragma translate_off+                     mod ~LIT[0]+        -- pragma translate_on+                     ;~IF ~VIVADO ~THEN+        ~RESULT <= fromSLV(~VAR[vec][1](~SYM[1]));~ELSE+        ~RESULT <= ~VAR[vec][1](~SYM[1]);~FI+      end block;~ELSE~RESULT <= ~ERRORO;~FI+      -- index end+- BlackBox:+    name: Clash.Sized.Vector.replace_int+    kind: Declaration+    outputUsage: NonBlocking+    type: 'replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a'+    template: |-+      -- replace begin+      ~GENSYM[replaceVec][0] : block+        signal ~GENSYM[vec_index][1] : integer range 0 to ~LIT[0]-1;+      begin+        ~SYM[1] <= to_integer(~ARG[2])+        -- pragma translate_off+                     mod ~LIT[0]+        -- pragma translate_on+                     ;++        process(~SYM[1]~VARS[1]~VARS[3])+          variable ~GENSYM[ivec][2] : ~TYP[1];+        begin+          ~SYM[2] := ~ARG[1];~IF ~VIVADO ~THEN+          ~SYM[2](~SYM[1]) := ~TOBV[~ARG[3]][~TYP[3]];~ELSE+          ~SYM[2](~SYM[1]) := ~ARG[3];~FI+          ~RESULT <= ~SYM[2];+        end process;+      end block;+      -- replace end+- BlackBox:+    name: Clash.Sized.Vector.length+    kind: Expression+    type: 'length :: KnownNat n => Vec n a -> Int'+    template: to_signed(~LIT[0],~SIZE[~TYPO])+    workInfo: Constant+- BlackBox:+    name: Clash.Sized.Vector.replicate+    kind: Expression+    type: 'replicate :: SNat n -> a -> Vec n a'+    template: ~TYPMO'(0 to ~LIT[0]-1 => ~IF ~VIVADO ~THEN ~TOBV[~ARG[1]][~TYP[1]]+      ~ELSE ~ARG[1] ~FI)+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.transpose+    kind: Declaration+    type: 'transpose :: KnownNat n => Vec m (Vec n a) -> Vec n (Vec m a)'+    template: |-+      -- transpose begin+      ~GENSYM[transpose_outer][2] : for ~GENSYM[row_index][3] in 0 to (~LENGTH[~TYP[1]] - 1) generate+        ~GENSYM[transpose_inner][4] : for ~GENSYM[col_index][5] in ~RESULT'range generate~IF ~VIVADO ~THEN+          ~RESULT(~SYM[5])((~LENGTH[~TYP[1]]-~SYM[3])*~SIZE[~TYPEL[~TYPEL[~TYPO]]]-1 downto (~LENGTH[~TYP[1]]-~SYM[3]-1)*~SIZE[~TYPEL[~TYPEL[~TYPO]]]) <= ~VAR[vec][1](~SYM[3])((~RESULT'length-~SYM[5])*~SIZE[~TYPEL[~TYPEL[~TYPO]]]-1 downto (~RESULT'length-~SYM[5]-1)*~SIZE[~TYPEL[~TYPEL[~TYPO]]]);~ELSE+          ~RESULT(~SYM[5])(~SYM[3]) <= ~VAR[matrix][1](~SYM[3])(~SYM[5]);~FI+        end generate;+      end generate;+      -- transpose end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.reverse+    kind: Declaration+    type: 'reverse :: Vec n a -> Vec n a'+    template: |-+      -- reverse begin+      ~GENSYM[reverse_loop][2] : for ~GENSYM[i][3] in 0 to (~LENGTH[~TYP[0]] - 1) generate+        ~RESULT(~VAR[vec][0]'high - ~SYM[3]) <= ~VAR[vec][0](~SYM[3]);+      end generate;+      -- reverse end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.concatBitVector#+    kind: Declaration+    type: |-+      concatBitVector# :: (KnownNat n,KnownNat m) -- (ARG[0],ARG[1])+                        => Vec n (BitVector m)     -- ARG[2]+                        -> BitVector (n * m)+    template: |-+      -- concatBitVector begin+      ~GENSYM[concatBitVectorIter_loop][2] : for ~GENSYM[i][3] in 0 to (~LENGTH[~TYP[2]] - 1) generate+        ~RESULT(((~SYM[3] * ~LIT[1]) + ~LIT[1] - 1) downto (~SYM[3] * ~LIT[1])) <= ~TYPMO'(~VAR[vec][2](~VAR[vec][2]'high - ~SYM[3]));+      end generate;+      -- concatBitVector end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.unconcatBitVector#+    kind: Declaration+    type: |-+      unconcatBitVector# :: (KnownNat n, KnownNat m) -- (ARG[0],ARG[1])+                          => BitVector (n * m)        -- ARG[2]+                          -> Vec n (BitVector m)+    template: |-+      -- unconcatBitVector begin+      ~GENSYM[unconcatBitVectorIter_loop][2] : for ~GENSYM[i][3] in ~RESULT'range generate+        ~RESULT(~RESULT'high - ~SYM[3]) <= ~VAR[vec][2](((~SYM[3] * ~LIT[1]) + ~LIT[1] - 1) downto (~SYM[3] * ~LIT[1]));+      end generate;+      -- unconcatBitVector end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.rotateLeftS+    kind: Declaration+    type: 'rotateLeftS :: KnownNat n => Vec n a -> SNat d -> Vec n a'+    template: |-+      -- rotateLeftS begin+      ~GENSYM[rotateLeftS][0] : block+        constant ~GENSYM[shift_amount][2] : natural := ~LIT[2] mod ~LIT[0];+      begin+        ~GENSYM[no_shift][3] : if ~SYM[2] = 0 generate+          ~RESULT <= ~VAR[vec][1];+        end generate;++        ~GENSYM[do_shift][4] : if ~SYM[2] /= 0 generate+          ~RESULT <= ~VAR[vec][1](~SYM[2] to ~LIT[0]-1) &+                     ~VAR[vec][1](0 to ~SYM[2]-1);+        end generate;+      end block;+      -- rotateLeftS end+    workInfo: Never+- BlackBox:+    name: Clash.Sized.Vector.rotateRightS+    kind: Declaration+    type: 'rotateRightS :: KnownNat n => Vec n a -> SNat d -> Vec n a'+    template: |-+      -- rotateRightS begin+      ~GENSYM[rotateLeftS][0] : block+        constant ~GENSYM[shift_amount][2] : natural := ~LIT[2] mod ~LIT[0];+      begin+        ~GENSYM[no_shift][3] : if ~SYM[2] = 0 generate+          ~RESULT <= ~VAR[vec][1];+        end generate;++        ~GENSYM[do_shift][4] : if ~SYM[2] /= 0 generate+          ~RESULT <= ~VAR[vec][1](~LIT[0]-~SYM[2] to ~LIT[0]-1) &+                     ~VAR[vec][1](0 to ~LIT[0]-~SYM[2]-1);+        end generate;+      end block;+      -- rotateRightS end+    workInfo: Never
+ prims/vhdl/Clash_Xilinx_DDR.primitives.yaml view
@@ -0,0 +1,109 @@+- BlackBox:+    name: Clash.Xilinx.DDR.iddr#+    imports:+    - UNISIM.vcomponents.all+    kind: Declaration+    libraries:+    - UNISIM+    type: |-+      iddr#+        :: forall n dom domDDR+         . HasCallStack                 -- ARG[0]+        => KnownDomain dom              -- ARG[1]+        => KnownDomain domDDR           -- ARG[2]+        => DomPeriod ~ 2 * ...          -- ARG[3]+        => DomEdge ~ Rising             -- ARG[4]+        => KnownNat n                   -- ARG[5]+        => Clock dom                    -- ARG[6]+        -> Reset dom                    -- ARG[7]+        -> Enable dom                   -- ARG[8]+        -> Signal domDDR (BitVector n)  -- ARG[9]+        -> Signal dom (BitVector n, BitVector n)+    template: |-+      -- iddr begin+      ~GENSYM[~COMPNAME_IDDR][0] : block+        signal ~GENSYM[data_pos][1] : ~TYP[9];+        signal ~GENSYM[data_neg][2] : ~TYP[9];+        signal ~GENSYM[d][3]         : ~TYP[9];~IF ~ISACTIVEENABLE[8] ~THEN+        signal ~GENSYM[ce_logic][4]: std_logic;~ELSE ~FI+      begin~IF ~ISACTIVEENABLE[8] ~THEN+        ~SYM[4] <= '1' when (~ARG[8]) else '0';~ELSE ~FI+        ~SYM[3] <= ~ARG[9];++        ~GENSYM[gen_iddr][7] : for ~GENSYM[i][8] in ~SYM[3]'range generate+        begin+          ~GENSYM[~COMPNAME_IDDR_inst][9] : IDDR+          generic map (+            DDR_CLK_EDGE => "SAME_EDGE",+            INIT_Q1      => '0',+            INIT_Q2      => '0',+            SRTYPE       => ~IF ~ISSYNC[1] ~THEN "SYNC" ~ELSE "ASYNC" ~FI)+          port map (+            Q1 => ~SYM[1](~SYM[8]),   -- 1-bit output for positive edge of clock+            Q2 => ~SYM[2](~SYM[8]),   -- 1-bit output for negative edge of clock+            C  => ~ARG[6],   -- 1-bit clock input+            CE => ~IF ~ISACTIVEENABLE[8] ~THEN ~SYM[4] ~ELSE '1' ~FI,       -- 1-bit clock enable input+            D  => ~SYM[3](~SYM[8]),   -- 1-bit DDR data input+            R  => ~ARG[7],   -- 1-bit reset+            S  => '0'        -- 1-bit set+          );+        end generate;++        ~RESULT <= (~SYM[2], ~SYM[1]);+      end block;+      -- iddr# end+- BlackBox:+    name: Clash.Xilinx.DDR.oddr#+    imports:+    - UNISIM.vcomponents.all+    kind: Declaration+    libraries:+    - UNISIM+    type: |-+      oddr#+        :: forall n dom domDDR+         . HasCallStack              -- ARG[0]+        => KnownDomain dom           -- ARG[1]+        => KnownDomain domDDR        -- ARG[2]+        => DomPeriod ~ 2 * ...       -- ARG[3]+        => DomEdge ~ Rising          -- ARG[4]+        => KnownNat n                -- ARG[5]+        => Clock dom                 -- ARG[6]+        -> Reset dom                 -- ARG[7]+        -> Enable dom                -- ARG[8]+        -> Signal dom (BitVector n)  -- ARG[9]+        -> Signal dom (BitVector n)  -- ARG[10]+        -> Signal domDDR (BitVector n)+    template: |-+      -- oddr begin+      ~GENSYM[~COMPNAME_ODDR][0] : block+        signal ~GENSYM[data_pos][1] : ~TYPO;+        signal ~GENSYM[data_neg][2] : ~TYPO;+        signal ~GENSYM[q][3]         : ~TYPO;~IF ~ISACTIVEENABLE[8] ~THEN+        signal ~GENSYM[ce_logic][4]  : std_logic;~ELSE ~FI+      begin~IF ~ISACTIVEENABLE[8] ~THEN+        ~SYM[4] <= '1' when (~ARG[8]) else '0';~ELSE ~FI+        ~SYM[1] <= ~ARG[9];+        ~SYM[2] <= ~ARG[10];++        ~GENSYM[gen_oddr][7] : for ~GENSYM[i][8] in ~SYM[3]'range generate+        begin+          ~GENSYM[~COMPNAME_ODDR_inst][9] : ODDR+          generic map(+            DDR_CLK_EDGE => "SAME_EDGE",+            INIT => '0',+            SRTYPE => ~IF ~ISSYNC[1] ~THEN "SYNC" ~ELSE "ASYNC" ~FI)+          port map (+            Q  => ~SYM[3](~SYM[8]),    -- 1-bit DDR output+            C  => ~ARG[6],   -- 1-bit clock input+            CE => ~IF ~ISACTIVEENABLE[8] ~THEN ~SYM[4] ~ELSE '1' ~FI,       -- 1-bit clock enable input+            D1 => ~SYM[1](~SYM[8]),    -- 1-bit data input (positive edge)+            D2 => ~SYM[2](~SYM[8]),    -- 1-bit data input (negative edge)+            R  => ~ARG[7],    -- 1-bit reset input+            S  => '0'         -- 1-bit set input+          );+        end generate;++        ~RESULT <= ~SYM[3];+      end block;+      -- oddr end
+ prims/vhdl/GHC_Base.primitives.yaml view
@@ -0,0 +1,59 @@+- BlackBox:+    name: GHC.Base.remInt+    kind: Declaration+    type: 'remInt :: Int ->+      Int -> Int'+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Base.divInt+    kind: Declaration+    type: 'divInt :: Int ->+      Int -> Int'+    template: |-+      -- divInt begin+      ~GENSYM[divInt][0] : block+        signal ~GENSYM[resultPos][1] : boolean;+        signal ~GENSYM[dividerNeg][2] : boolean;+        signal ~GENSYM[dividend2][3] : signed(~SIZE[~TYPO] downto 0);+        signal ~GENSYM[quot_res][4] : signed(~SIZE[~TYPO] downto 0);+      begin+        ~SYM[1] <= ~VAR[dividend][0](~VAR[dividend][0]'high) = ~VAR[divider][1](~VAR[divider][1]'high);+        ~SYM[2] <= ~VAR[divider][1](~VAR[divider][1]'high) = '1';+        ~SYM[3] <= resize(~VAR[dividend][0],~SIZE[~TYPO]+1)   when ~SYM[1] else+                   (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) - 1)   when ~SYM[2] else+                   (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) + 1);+        ~SYM[4] <= ~SYM[3] / ~VAR[divider][1]+            -- pragma translate_off+            when (~VAR[divider][1] /= 0) else (others => 'X')+            -- pragma translate_on+            ;+        ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0));+      end block;+      -- divInt end+- BlackBox:+    name: GHC.Base.modInt+    kind: Declaration+    type: 'modInt :: Int ->+      Int -> Int'+    template: |-+      ~RESULT <= ~ARG[0] mod ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Base.quotInt+    kind: Declaration+    type: 'quotInt :: Int+      -> Int -> Int'+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;
+ prims/vhdl/GHC_Classes.primitives.yaml view
@@ -0,0 +1,62 @@+- BlackBox:+    name: GHC.Classes.eqInt+    kind: Expression+    type: 'eqInt :: Int ->+      Int -> Bool'+    template: ~ARG[0] = ~ARG[1]+- BlackBox:+    name: GHC.Classes.neInt+    kind: Expression+    type: 'neInt :: Int ->+      Int -> Bool'+    template: ~ARG[0] /= ~ARG[1]+- BlackBox:+    name: GHC.Classes.&&+    kind: Expression+    type: '(&&) :: Bool ->+      Bool -> Bool'+    template: ~ARG[0] and ~ARG[1]+- BlackBox:+    name: GHC.Classes.||+    kind: Expression+    type: '(::) :: Bool ->+      Bool -> Bool'+    template: ~ARG[0] or ~ARG[1]+- BlackBox:+    name: GHC.Classes.not+    kind: Expression+    type: 'not :: Bool ->+      Bool'+    template: not ~ARG[0]+- BlackBox:+    name: GHC.Classes.divInt#+    kind: Declaration+    type: 'divInt# :: Int#+      -> Int# -> Int#'+    template: |-+      -- divInt# begin+      ~GENSYM[divInt][0] : block+        signal ~GENSYM[resultPos][1] : boolean;+        signal ~GENSYM[dividerNeg][2] : boolean;+        signal ~GENSYM[dividend2][3] : signed(~SIZE[~TYPO] downto 0);+        signal ~GENSYM[quot_res][4] : signed(~SIZE[~TYPO] downto 0);+      begin+        ~SYM[1] <= ~VAR[dividend][0](~VAR[dividend][0]'high) = ~VAR[divider][1](~VAR[divider][1]'high);+        ~SYM[2] <= ~VAR[divider][1](~VAR[divider][1]'high) = '1';+        ~SYM[3] <= resize(~VAR[dividend][0],~SIZE[~TYPO]+1)   when ~SYM[1] else+                   (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) - 1)   when ~SYM[2] else+                   (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) + 1);+        ~SYM[4] <= ~SYM[3] / ~VAR[divider][1]+            -- pragma translate_off+            when (~VAR[divider][1] /= 0) else (others => 'X')+            -- pragma translate_on+            ;+        ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0));+      end block;+      -- divInt# end+- BlackBox:+    name: GHC.Classes.modInt#+    kind: Expression+    type: 'modInt# :: Int#+      -> Int# -> Int#'+    template: ~ARG[0] mod ~ARG[1]
+ prims/vhdl/GHC_Int.primitives.yaml view
@@ -0,0 +1,29 @@+- BlackBox:+    name: GHC.Int.I8#+    kind: Expression+    type: 'I8# :: Int# ->+      Int8'+    template: resize(~ARG[0],8)+    # TODO Starting with ghc-9.0/base-4.16 this takes an I8# that is already properly sized and don't have to do this resize anymore. Same applies to the rest of this file.+    workInfo: Never+- BlackBox:+    name: GHC.Int.I16#+    kind: Expression+    type: 'I16# :: Int# ->+      Int16'+    template: resize(~ARG[0],16)+    workInfo: Never+- BlackBox:+    name: GHC.Int.I32#+    kind: Expression+    type: 'I32# :: Int# ->+      Int32'+    template: resize(~ARG[0],32)+    workInfo: Never+- BlackBox:+    name: GHC.Int.I64#+    kind: Expression+    type: 'I64# :: Int# ->+      Int64'+    template: resize(~ARG[0],64)+    workInfo: Never
+ prims/vhdl/GHC_Integer_Logarithms.primitives.yaml view
@@ -0,0 +1,8 @@+- BlackBox:+    name: GHC.Integer.Logarithms.integerLogBase#+    kind: Expression+    type: 'integerLogBase#+      :: Integer -> Integer -> Int#'+    template: integer(floor(log(real(~ARG[1]),real(~ARG[0]))))+    warning: 'GHC.Integer.Logarithms.integerLogBase#: Integers are dynamically sized+      in simulation, but fixed-length after synthesis. Use carefully.'
+ prims/vhdl/GHC_Integer_Type.primitives.yaml view
@@ -0,0 +1,357 @@+- BlackBox:+    name: GHC.Integer.Type.smallInteger+    kind: Expression+    type: 'smallInteger ::+      Int# -> Integer'+    template: ~ARG[0]+    warning: 'GHC.Integer.Type.smallInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Integer.Type.integerToInt+    kind: Expression+    type: 'integerToInt ::+      Integer -> Int#'+    template: ~ARG[0]+    warning: 'GHC.Integer.Type.integerToInt: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Integer.Type.timesInteger+    kind: Declaration+    type: 'timesInteger ::+      Integer -> Integer -> Integer'+    template: |-+      ~GENSYM[~RESULT_mult][0] : block+        signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+      begin+        ~SYM[1] <= ~ARG[0] * ~ARG[1];+        ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+      end block;+    warning: 'GHC.Integer.Type.timesInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.negateInteger+    kind: Expression+    type: 'negateInteger ::+      Integer -> Integer'+    template: -~ARG[0]+    warning: 'GHC.Integer.Type.negateInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.absInteger+    kind: Expression+    type: 'absInteger :: Integer+      -> Integer'+    template: abs ~ARG[0]+    warning: 'GHC.Integer.Type.absInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.divInteger+    kind: Declaration+    type: 'divInteger :: Integer+      -> Integer -> Integer'+    template: |-+      -- divInteger begin+      ~GENSYM[divInteger][0] : block+        signal ~GENSYM[resultPos][1] : boolean;+        signal ~GENSYM[dividerNeg][2] : boolean;+        signal ~GENSYM[dividend2][3] : signed(~SIZE[~TYPO] downto 0);+        signal ~GENSYM[quot_res][4] : signed(~SIZE[~TYPO] downto 0);+      begin+        ~SYM[1] <= ~VAR[dividend][0](~VAR[dividend][0]'high) = ~VAR[divider][1](~VAR[divider][1]'high);+        ~SYM[2] <= ~VAR[divider][1](~VAR[divider][1]'high) = '1';+        ~SYM[3] <= resize(~VAR[dividend][0],~SIZE[~TYPO]+1)   when ~SYM[1] else+                   (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) - 1)   when ~SYM[2] else+                   (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) + 1);+        ~SYM[4] <= ~SYM[3] / ~VAR[divider][1]+            -- pragma translate_off+            when (~VAR[divider][1] /= 0) else (others => 'X')+            -- pragma translate_on+            ;+        ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0));+      end block;+      -- divInteger end+    warning: 'GHC.Integer.Type.divInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.modInteger+    kind: Expression+    type: 'modInteger :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] mod ~ARG[1]+    warning: 'GHC.Integer.Type.modInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.divModInteger+    kind: Declaration+    type: 'divModInteger ::+      Integer -> Integer -> (# Integer, Integer #)'+    template: |-+      -- divModInteger begin+      ~GENSYM[divModInteger][0] : block+        signal ~GENSYM[resultPos][1] : boolean;+        signal ~GENSYM[dividerNeg][2] : boolean;+        signal ~GENSYM[dividend2][3] : signed(~SIZE[~TYP[0]] downto 0);+        signal ~GENSYM[quot_res][4] : signed(~SIZE[~TYP[0]] downto 0);+        signal ~GENSYM[div_res][5] : signed(~SIZE[~TYP[0]]-1 downto 0);+        signal ~GENSYM[mod_res][6] : signed(~SIZE[~TYP[0]]-1 downto 0);+      begin+        ~SYM[1] <= ~VAR[dividend][0](~VAR[dividend][0]'high) = ~VAR[divider][1](~VAR[divider][1]'high);+        ~SYM[2] <= ~VAR[divider][1](~VAR[divider][1]'high) = '1';+        ~SYM[3] <= resize(~VAR[dividend][0],~SIZE[~TYP[0]]+1)   when ~SYM[1] else+                   (resize(~VAR[dividend][0],~SIZE[~TYP[0]]+1) - resize(~VAR[divider][1],~SIZE[~TYP[0]]+1) - 1)   when ~SYM[2] else+                   (resize(~VAR[dividend][0],~SIZE[~TYP[0]]+1) - resize(~VAR[divider][1],~SIZE[~TYP[0]]+1) + 1);+        ~SYM[4] <= ~SYM[3] / ~VAR[divider][1]+            -- pragma translate_off+            when (~VAR[divider][1] /= 0) else (others => 'X')+            -- pragma translate_on+            ;+        ~SYM[5] <= signed(~SYM[4](~SIZE[~TYP[0]]-1 downto 0));+        ~SYM[6] <= ~VAR[dividend][0] mod ~VAR[divider][1]+            -- pragma translate_off+            when (~VAR[divider][1] /= 0) else (others => 'X')+            -- pragma translate_on+            ;+        ~RESULT <= (~SYM[5], ~SYM[6]);+      end block;+      -- divModInteger end+    warning: 'GHC.Integer.Type.divModInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.quotRemInteger+    kind: Declaration+    type: 'quotRemInteger+      :: Integer -> Integer -> (# Integer, Integer #)'+    template: |-+      ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])+          -- pragma translate_off+          when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X'))+          -- pragma translate_on+          ;+    warning: 'GHC.Integer.Type.quotRemInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.remInteger+    kind: Declaration+    type: 'remInteger :: Integer+      -> Integer -> Integer'+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+    warning: 'GHC.Integer.Type.remInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.eqInteger+    kind: Expression+    type: 'eqInteger :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] = ~ARG[1]+    warning: 'GHC.Integer.Type.eqInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.neqInteger+    kind: Expression+    type: 'neqInteger :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] /= ~ARG[1]+    warning: 'GHC.Integer.Type.neqInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.eqInteger#+    kind: Declaration+    type: 'eqInteger# :: Integer+      -> Integer -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+    warning: 'GHC.Integer.Type.eqInteger#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.neqInteger#+    kind: Declaration+    type: 'neqInteger# ::+      Integer -> Integer -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+    warning: 'GHC.Integer.Type.neqInteger#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.leInteger#+    kind: Declaration+    type: 'leInteger# :: Integer+      -> Integer -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+    warning: 'GHC.Integer.Type.leInteger#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.gtInteger#+    kind: Declaration+    type: 'gtInteger# :: Integer+      -> Integer -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+    warning: 'GHC.Integer.Type.gtInteger#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.ltInteger#+    kind: Declaration+    type: 'ltInteger# :: Integer+      -> Integer -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+    warning: 'GHC.Integer.Type.ltInteger#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.geInteger#+    kind: Declaration+    type: 'geInteger# :: Integer+      -> Integer -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+    warning: 'GHC.Integer.Type.geInteger#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.shiftRInteger+    kind: Declaration+    type: 'shiftRInteger ::+      Integer -> Int# -> Integer'+    template: |-+      ~GENSYM[~RESULT_shiftR][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_right(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+    warning: 'GHC.Integer.Type.shiftRInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.shiftLInteger+    kind: Declaration+    type: 'shiftLInteger ::+      Integer -> Int# -> Integer'+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+    warning: 'GHC.Integer.Type.shiftLInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.testBitInteger+    kind: Expression+    type: 'testBitInteger+      :: Integer -> Int# -> Bool'+    template: ~VAR[input][0](to_integer(~ARG[1])) = '1'+    warning: 'GHC.Integer.Type.testBitInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.wordToInteger+    kind: Expression+    type: 'wordToInteger ::+      Word# -> Integer'+    template: signed(std_logic_vector(~ARG[0]))+    warning: 'GHC.Integer.Type.wordToInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Integer.Type.integerToWord+    kind: Expression+    type: 'integerToWord ::+      Integer -> Word#'+    template: unsigned(std_logic_vector(~ARG[0]))+    warning: 'GHC.Integer.Type.integerToWord: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Integer.Type.integerToWord64+    comment: only used by 32 bit GHC+    kind: Expression+    type: 'integerToWord ::+      Integer -> Word64#'+    template: unsigned(std_logic_vector(~ARG[0]))+    warning: 'GHC.Integer.Type.integerToWord64: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Integer.Type.bitInteger+    kind: Expression+    type: 'bitInteger :: Int+      -> Integer'+    template: shift_left(to_signed(1, ~SIZE[~TYPO]),to_integer(~ARG[0]))+    warning: 'GHC.Integer.Type.bitInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.complementInteger+    kind: Expression+    type: 'complementInteger+      :: Integer -> Integer'+    template: not ~ARG[0]+    warning: 'GHC.Integer.Type.complementInteger: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.xorInteger+    kind: Expression+    type: 'xorInteger :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] xor ~ARG[1]+    warning: 'GHC.Integer.Type.xorInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.orInteger+    kind: Expression+    type: 'orInteger :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] or ~ARG[1]+    warning: 'GHC.Integer.Type.orInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.andInteger+    kind: Expression+    type: 'andInteger :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] and ~ARG[1]+    warning: 'GHC.Integer.Type.andInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.$wsignumInteger+    kind: Declaration+    type: '$wsignumInteger+      :: Integer -> Integer'+    template: |2++      -- begin signumInteger+      ~RESULT <= to_signed(-1, ~SIZE[~TYPO]) when ~ARG[0] < 0+        else to_signed(0, ~SIZE[~TYPO])  when ~ARG[0] = 0+        else to_signed(1, ~SIZE[~TYPO]);+      -- end signumInteger+    warning: 'GHC.Integer.Type.$wsignumInteger: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Integer.Type.quotInteger+    kind: Declaration+    type: 'quotInteger ::+      Integer -> Integer -> Integer'+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+    warning: 'GHC.Integer.Type.quotInteger: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'
+ prims/vhdl/GHC_Natural.primitives.yaml view
@@ -0,0 +1,27 @@+- BlackBox:+    name: GHC.Natural.naturalFromInteger+    kind: Expression+    type: 'naturalFromInteger+      :: Integer -> Natural'+    template: resize(unsigned(std_logic_vector(~ARG[0])),~SIZE[~TYPO])+    warning: 'GHC.Natural.naturalFromInteger: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Natural.timesNatural+    kind: Expression+    type: 'timesNatural ::+      Natural -> Natural -> Natural'+    template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+    warning: 'GHC.Natural.timesNatural: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Natural.wordToNatural#+    kind: Expression+    type: 'wordToNatural#+      :: Word# -> Natural'+    template: unsigned(std_logic_vector(~ARG[0]))+    warning: 'GHC.Natural.wordToNatural#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never
+ prims/vhdl/GHC_Num_Integer.primitives.yaml view
@@ -0,0 +1,433 @@+- BlackBox:+    name: GHC.Num.Integer.integerToNatural+    kind: Expression+    type: 'integerToNatural+      :: Integer -> Natural'+    template: resize(unsigned(std_logic_vector(~ARG[0])),~SIZE[~TYPO])+    warning: 'GHC.Num.Integer.integerToNatural: Naturals are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerToNaturalThrow+    kind: Declaration+    type: 'integerToNaturalThrow+      :: Integer -> Natural'+    template: |-+      -- integerToNaturalThrow begin+      ~RESULT <= ~ERRORO when ~ARG[0] < ~SIZE[~TYP[0]]'d0 else+                 resize(unsigned(std_logic_vector(~ARG[0])),~SIZE[~TYPO]);+      -- integerToNaturalThrow end+    warning: 'GHC.Num.Integer.integerToNaturalThrow: Naturals are dynamically sized+      in simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerToNaturalClamp+    kind: Declaration+    type: 'integerToNatural+      :: Integer -> Natural'+    template: |-+      -- integerToNaturalClamp begin+      ~RESULT <= to_unsigned(0,~SIZE[~TYPO]]) when ~ARG[0] < ~SIZE[~TYP[0]]'d0 else+                 resize(unsigned(std_logic_vector(~ARG[0])),~SIZE[~TYPO]);+      -- integerToNaturalClamp end+    warning: 'GHC.Num.Integer.integerToNaturalClamp: Naturals are dynamically sized+      in simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerToInt#+    kind: Expression+    type: 'integerToInt ::+      Integer -> Int#'+    template: ~ARG[0]+    warning: 'GHC.Num.Integer.integerToInt#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerMul+    kind: Declaration+    type: 'integerMul :: Integer+      -> Integer -> Integer'+    template: |-+      ~GENSYM[~RESULT_mult][0] : block+        signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+      begin+        ~SYM[1] <= ~ARG[0] * ~ARG[1];+        ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+      end block;+    warning: 'GHC.Num.Integer.integerMul: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerNegate+    kind: Expression+    type: 'integerNegate ::+      Integer -> Integer'+    template: -~ARG[0]+    warning: 'GHC.Num.Integer.integerNegate: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerAbs+    kind: Expression+    type: 'integerAbs :: Integer+      -> Integer'+    template: abs ~ARG[0]+    warning: 'GHC.Num.Integer.integerAbs: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerDiv+    kind: Declaration+    type: 'integerDiv :: Integer+      -> Integer -> Integer'+    template: |-+      -- integerDiv begin+      ~GENSYM[integerDiv][0] : block+        signal ~GENSYM[resultPos][1] : boolean;+        signal ~GENSYM[dividerNeg][2] : boolean;+        signal ~GENSYM[dividend2][3] : signed(~SIZE[~TYPO] downto 0);+        signal ~GENSYM[quot_res][4] : signed(~SIZE[~TYPO] downto 0);+      begin+        ~SYM[1] <= ~VAR[dividend][0](~VAR[dividend][0]'high) = ~VAR[divider][1](~VAR[divider][1]'high);+        ~SYM[2] <= ~VAR[divider][1](~VAR[divider][1]'high) = '1';+        ~SYM[3] <= resize(~VAR[dividend][0],~SIZE[~TYPO]+1)   when ~SYM[1] else+                   (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) - 1)   when ~SYM[2] else+                   (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) + 1);+        ~SYM[4] <= ~SYM[3] / ~VAR[divider][1]+            -- pragma translate_off+            when (~VAR[divider][1] /= 0) else (others => 'X')+            -- pragma translate_on+            ;+        ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0));+      end block;+      -- integerDiv end+    warning: 'GHC.Num.Integer.integerDiv: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerMod+    kind: Expression+    type: 'integerMod :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] mod ~ARG[1]+    warning: 'GHC.Num.Integer.integerMod: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerDivMod#+    kind: Declaration+    type: 'integerDivMod ::+      Integer -> Integer -> (# Integer, Integer #)'+    template: |-+      -- integerDivMod begin+      ~GENSYM[integerDivMod][0] : block+        signal ~GENSYM[resultPos][1] : boolean;+        signal ~GENSYM[dividerNeg][2] : boolean;+        signal ~GENSYM[dividend2][3] : signed(~SIZE[~TYP[0]] downto 0);+        signal ~GENSYM[quot_res][4] : signed(~SIZE[~TYP[0]] downto 0);+        signal ~GENSYM[div_res][5] : signed(~SIZE[~TYP[0]]-1 downto 0);+        signal ~GENSYM[mod_res][6] : signed(~SIZE[~TYP[0]]-1 downto 0);+      begin+        ~SYM[1] <= ~VAR[dividend][0](~VAR[dividend][0]'high) = ~VAR[divider][1](~VAR[divider][1]'high);+        ~SYM[2] <= ~VAR[divider][1](~VAR[divider][1]'high) = '1';+        ~SYM[3] <= resize(~VAR[dividend][0],~SIZE[~TYP[0]]+1)   when ~SYM[1] else+                   (resize(~VAR[dividend][0],~SIZE[~TYP[0]]+1) - resize(~VAR[divider][1],~SIZE[~TYP[0]]+1) - 1)   when ~SYM[2] else+                   (resize(~VAR[dividend][0],~SIZE[~TYP[0]]+1) - resize(~VAR[divider][1],~SIZE[~TYP[0]]+1) + 1);+        ~SYM[4] <= ~SYM[3] / ~VAR[divider][1]+            -- pragma translate_off+            when (~VAR[divider][1] /= 0) else (others => 'X')+            -- pragma translate_on+            ;+        ~SYM[5] <= signed(~SYM[4](~SIZE[~TYP[0]]-1 downto 0));+        ~SYM[6] <= ~VAR[dividend][0] mod ~VAR[divider][1]+            -- pragma translate_off+            when (~VAR[divider][1] /= 0) else (others => 'X')+            -- pragma translate_on+            ;+        ~RESULT <= (~SYM[5], ~SYM[6]);+      end block;+      -- integerDivMod end+    warning: 'GHC.Num.Integer.integerDivMod#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerQuotRem#+    kind: Declaration+    type: 'integerQuotRem+      :: Integer -> Integer -> (# Integer, Integer #)'+    template: |-+      ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])+          -- pragma translate_off+          when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X'))+          -- pragma translate_on+          ;+    warning: 'GHC.Num.Integer.integerQuotRem#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerRem+    kind: Declaration+    type: 'integerRem :: Integer+      -> Integer -> Integer'+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+    warning: 'GHC.Num.Integer.integerRem: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerEq+    kind: Expression+    type: 'integerEq :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] = ~ARG[1]+    warning: 'GHC.Num.Integer.integerEq: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerNe+    kind: Expression+    type: 'integerNe :: Integer+      -> Integer -> Bool'+    template: ~ARG[0] /= ~ARG[1]+    warning: 'GHC.Num.Integer.integerNe: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerEq#+    kind: Declaration+    type: 'integerEq# :: Integer+      -> Integer -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+    warning: 'GHC.Num.Integer.integerEq#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerNe#+    kind: Declaration+    type: 'integerNe# :: Integer+      -> Integer -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+    warning: 'GHC.Num.Integer.integerNe#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerLe#+    kind: Declaration+    type: 'integerLe# :: Integer+      -> Integer -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+    warning: 'GHC.Num.Integer.integerLe#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerGt#+    kind: Declaration+    type: 'integerGt# :: Integer+      -> Integer -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+    warning: 'GHC.Num.Integer.integerGt#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerLt#+    kind: Declaration+    type: 'integerLt# :: Integer+      -> Integer -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+    warning: 'GHC.Num.Integer.integerLt#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerGe#+    kind: Declaration+    type: 'integerGe# :: Integer+      -> Integer -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+    warning: 'GHC.Num.Integer.integerGe#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerShiftR#+    kind: Declaration+    type: 'integerShiftR#+      :: Integer -> Word# -> Integer'+    template: |-+      ~GENSYM[~RESULT_shiftR][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_right(~ARG[0],~SYM[1]);+      end block;+    warning: 'GHC.Num.Integer.integerShiftR#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerShiftL#+    kind: Declaration+    type: 'integerShiftL#+      :: Integer -> Word# -> Integer'+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1]);+      end block;+    warning: 'GHC.Num.Integer.integerShiftL#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerTestBit#+    kind: Declaration+    type: 'integerTestBit+      :: Integer -> Word# -> Int#'+    template: ~RESULT <= (0 => ~VAR[input][0](to_integer(~ARG[1])), others => '0');+    warning: 'GHC.Num.Integer.integerTestBit#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerFromWord#+    kind: Expression+    type: 'integerFromWord+      :: Word# -> Integer'+    template: signed(std_logic_vector(~ARG[0]))+    warning: 'GHC.Num.Integer.integerFromWord#: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerToWord#+    kind: Expression+    type: 'integerToWord ::+      Integer -> Word#'+    template: unsigned(std_logic_vector(~ARG[0]))+    warning: 'GHC.Num.Integer.integerToWord#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerToInt64#+    kind: Expression+    type: 'integerToInt64# :: Integer -> Int64#'+    template: ~ARG[0]+    warning: 'GHC.Num.Integer.integerToInt64#: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerToWord64#+    comment: only used by 32 bit GHC+    kind: Expression+    type: 'integerToWord ::+      Integer -> Word64#'+    template: unsigned(std_logic_vector(~ARG[0]))+    warning: 'GHC.Num.Integer.integerToWord64#: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerFromWord64#+    kind: Expression+    type: 'integerFromWord64# :: Word64# -> Integer'+    template: signed(std_logic_vector(~ARG[0]))+    warning: 'GHC.Num.Integer.integerFromWord64#: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Integer.integerBit#+    kind: Expression+    type: 'integerBit :: Word#+      -> Integer'+    template: shift_left(to_signed(1, ~SIZE[~TYPO]),to_integer(~ARG[0]))+    warning: 'GHC.Num.Integer.integerBit#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerComplement+    kind: Expression+    type: 'integerComplement+      :: Integer -> Integer'+    template: not ~ARG[0]+    warning: 'GHC.Num.Integer.integerComplement: Integers are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerXor+    kind: Expression+    type: 'integerXor :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] xor ~ARG[1]+    warning: 'GHC.Num.Integer.integerXor: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerOr+    kind: Expression+    type: 'integerOr :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] or ~ARG[1]+    warning: 'GHC.Num.Integer.integerOr: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerAnd+    kind: Expression+    type: 'integerAnd :: Integer+      -> Integer -> Integer'+    template: ~ARG[0] and ~ARG[1]+    warning: 'GHC.Num.Integer.integerAnd: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerSignum+    kind: Declaration+    type: 'integerSignum ::+      Integer -> Integer'+    template: |2++      -- begin integerSignum+      ~RESULT <= to_signed(-1, ~SIZE[~TYPO]) when ~ARG[0] < 0+        else to_signed(0, ~SIZE[~TYPO])  when ~ARG[0] = 0+        else to_signed(1, ~SIZE[~TYPO]);+      -- end integerSignum+    warning: 'GHC.Num.Integer.integerSignum: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.$wintegerSignum+    kind: Declaration+    type: '$wsignumInteger+      :: Integer -> Int#'+    template: |2++      -- begin signumInteger+      ~RESULT <= to_signed(-1, ~SIZE[~TYPO]) when ~ARG[0] < 0+        else to_signed(0, ~SIZE[~TYPO])  when ~ARG[0] = 0+        else to_signed(1, ~SIZE[~TYPO]);+      -- end signumInteger+    warning: 'GHC.Num.Integer.$wintegerSignum: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerLogBase#+    kind: Expression+    type: 'integerLogBase#+      :: Integer -> Integer -> Int#'+    template: integer(floor(log(real(~ARG[1]),real(~ARG[0]))))+    warning: 'GHC.Num.Integer.integerLogBase#: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerCompare+    kind: Declaration+    type: 'integerCompare+      :: Integer -> Integer -> Ordering'+    template: |2++      -- begin integerCompare+      ~RESULT <= "00" when ~ARG[0] < ~ARG[1] else+                 "01" when ~ARG[0] = ~ARG[1] else+                 "10";+      -- end integerCompare+    warning: 'GHC.Num.Integer.integerCompare: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.integerQuot+    kind: Declaration+    type: 'integerQuot ::+      Integer -> Integer -> Integer'+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+    warning: 'GHC.Num.Integer.integerQuot: Integers are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Integer.$wintegerFromInt64#+    kind: Expression+    type: '$wintegerFromInt64# :: Int64# -> Int#'+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never
+ prims/vhdl/GHC_Num_Natural.primitives.yaml view
@@ -0,0 +1,149 @@+- BlackBox:+    name: GHC.Num.Natural.naturalMul+    kind: Expression+    type: 'timesNatural ::+      Natural -> Natural -> Natural'+    template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+    warning: 'GHC.Num.Natural.timesNatural: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalFromWord#+    kind: Expression+    type: 'naturalFromWord#+      :: Word# -> Natural'+    template: unsigned(std_logic_vector(~ARG[0]))+    warning: 'GHC.Num.Natural.naturalFromWord#: Naturals are dynamically sized in+      simulation, but fixed-length after synthesis. Use carefully.'+    workInfo: Never+- BlackBox:+    name: GHC.Num.Natural.naturalRem+    kind: Declaration+    type: 'naturalRem :: Natural+      -> Natural -> Natural'+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+    warning: 'GHC.Num.Natural.naturalRem: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalLogBase#+    kind: Expression+    type: 'naturalLogBase#+      :: Natural -> Natural -> Word#'+    template: to_unsigned(integer(floor(log(real(to_integer(~ARG[1])),real(to_integer(~ARG[0]))))),~SIZE[~TYPO])+    warning: 'GHC.Num.Natural.naturalLogBase#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalEq#+    kind: Declaration+    type: 'naturalEq# :: Natural+      -> Natural -> Int#'+    template: ~RESULT <= to_unsigned(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_unsigned(0,~SIZE[~TYPO]);+    warning: 'GHC.Num.Natural.naturalEq#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalNe#+    kind: Declaration+    type: 'naturalNe# :: Natural+      -> Natural -> Int#'+    template: ~RESULT <= to_unsigned(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else+      to_unsigned(0,~SIZE[~TYPO]);+    warning: 'GHC.Num.Natural.naturalNe#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalLe#+    kind: Declaration+    type: 'naturalLe# :: Natural+      -> Natural -> Int#'+    template: ~RESULT <= to_unsigned(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else+      to_unsigned(0,~SIZE[~TYPO]);+    warning: 'GHC.Num.Natural.naturalLe#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalGt#+    kind: Declaration+    type: 'naturalGt# :: Natural+      -> Natural -> Int#'+    template: ~RESULT <= to_unsigned(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_unsigned(0,~SIZE[~TYPO]);+    warning: 'GHC.Num.Natural.naturalGt#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalLt#+    kind: Declaration+    type: 'naturalLt# :: Natural+      -> Natural -> Int#'+    template: ~RESULT <= to_unsigned(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_unsigned(0,~SIZE[~TYPO]);+    warning: 'GHC.Num.Natural.naturalLt#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalGe#+    kind: Declaration+    type: 'naturalGe# :: Natural+      -> Natural -> Int#'+    template: ~RESULT <= to_unsigned(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else+      to_unsigned(0,~SIZE[~TYPO]);+    warning: 'GHC.Num.Natural.naturalGe#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalShiftL#+    kind: Declaration+    type: 'naturalShiftL#+      :: Natural -> Word# -> Natural'+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1]);+      end block;+    warning: 'GHC.Num.Natural.naturalShiftL#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalShiftR#+    kind: Declaration+    type: 'naturalShiftR#+      :: Natural -> Word# -> Natural'+    template: |-+      ~GENSYM[~RESULT_shiftR][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_right(~ARG[0],~SYM[1]);+      end block;+    warning: 'GHC.Num.Natural.naturalShiftR#: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'+- BlackBox:+    name: GHC.Num.Natural.naturalCompare+    kind: Declaration+    type: 'naturalCompare+      :: Natural -> Natural -> Ordering'+    template: |-+      -- begin naturalCompare+      ~RESULT <= "00" when ~ARG[0] < ~ARG[1] else+               "01" when ~ARG[0] = ~ARG[1] else+               "10";+      -- end naturalCompare+- BlackBox:+    name: GHC.Num.Natural.naturalQuot+    kind: Declaration+    type: 'naturalQuot ::+      Natural -> Natural -> Natural'+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+    warning: 'GHC.Num.Natural.naturalQuot: Naturals are dynamically sized in simulation,+      but fixed-length after synthesis. Use carefully.'
+ prims/vhdl/GHC_Prim.primitives.yaml view
@@ -0,0 +1,2289 @@+- BlackBox:+    name: GHC.Prim.gtChar#+    kind: Declaration+    type: 'gtChar# :: Char#+      -> Char# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.geChar#+    kind: Declaration+    type: 'geChar# :: Char#+      -> Char# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.eqChar#+    kind: Declaration+    type: 'eqChar# :: Char#+      -> Char# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.neChar#+    kind: Declaration+    type: 'neChar# :: Char#+      -> Char# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.ltChar#+    kind: Declaration+    type: 'ltChar# :: Char#+      -> Char# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.leChar#+    kind: Declaration+    type: 'leChar# :: Char#+      -> Char# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.ord#+    kind: Expression+    type: 'ord# :: Char# ->+      Int#'+    template: signed(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))+- BlackBox:+    name: GHC.Prim.*#+    kind: Declaration+    type: '(*#) :: Int# ->+      Int# -> Int#'+    template: |-+      ~GENSYM[~RESULT_mult][0] : block+        signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+      begin+        ~SYM[1] <= ~ARG[0] * ~ARG[1];+        ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+      end block;+- BlackBox:+    name: GHC.Prim.remInt#+    kind: Declaration+    type: 'remInt# :: Int#+      -> Int# -> Int#'+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.quotRemInt#+    kind: Declaration+    type: 'quotRemInt# ::+      Int# -> Int# -> (#Int#, Int##)'+    template: |2-++      ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])+          -- pragma translate_off+          when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X'))+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.andI#+    kind: Expression+    type: 'and# :: Int# ->+      Int# -> Int#'+    template: ~ARG[0] and ~ARG[1]+- BlackBox:+    name: GHC.Prim.orI#+    kind: Expression+    type: 'or# :: Int# ->+      Int# -> Int#'+    template: ~ARG[0] or ~ARG[1]+- BlackBox:+    name: GHC.Prim.xorI#+    kind: Expression+    type: 'xor# :: Int# ->+      Int# -> Int#'+    template: ~ARG[0] xor ~ARG[1]+- BlackBox:+    name: GHC.Prim.notI#+    kind: Expression+    type: 'not# :: Int# ->+      Int#'+    template: not ~ARG[0]+- BlackBox:+    name: GHC.Prim.negateInt#+    kind: Expression+    type: 'negateInt# :: Int#+      -> Int#'+    template: -~ARG[0]+- BlackBox:+    name: GHC.Prim.>#+    kind: Declaration+    type: '(>#) :: Int# ->+      Int# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.>=#+    kind: Declaration+    type: '(>=#) :: Int# ->+      Int# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.==#+    kind: Declaration+    type: '(==) :: Int# ->+      Int# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim./=#+    kind: Declaration+    type: '(/=#) :: Int# ->+      Int# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.<#+    kind: Declaration+    type: '(<#) :: Int# ->+      Int# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.<=#+    kind: Declaration+    type: '(<=#) :: Int# ->+      Int# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.chr#+    kind: Expression+    type: 'ord# :: Int# ->+      Chr#'+    template: resize(unsigned(std_logic_vector(~ARG[0])),21)+    workInfo: Never+- BlackBox:+    name: GHC.Prim.int2Word#+    kind: Expression+    type: 'word2Int# :: Int#+      -> Word#'+    template: unsigned(std_logic_vector(~ARG[0]))+    workInfo: Never+- BlackBox:+    name: GHC.Prim.uncheckedIShiftL#+    kind: Declaration+    type: 'uncheckedIShiftL#+      :: Int# -> Int# -> Int#'+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedIShiftRA#+    kind: Declaration+    type: 'uncheckedIShiftRA#+      :: Int# -> Int# -> Int#'+    template: |-+      ~GENSYM[~RESULT_shiftR][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_right(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedIShiftRL#+    kind: Declaration+    type: 'uncheckedIShiftRL#+      :: Int# -> Int# -> Int#'+    template: |-+      ~GENSYM[~RESULT_shiftRL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= ~ARG[0] srl ~SYM[1]+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.timesWord#+    kind: Expression+    type: 'timesWord# :: Word#+      -> Word# -> Word#'+    template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+- BlackBox:+    name: GHC.Prim.remWord#+    kind: Declaration+    type: 'remWord# :: Word#+      -> Word# -> Word#'+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.quotRemWord#+    kind: Declaration+    type: 'quotRemWord# ::+      Word# -> Word# -> (#Word#, Word##)'+    template: |2-++      ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])+          -- pragma translate_off+          when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X'))+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.and#+    kind: Expression+    type: 'and# :: Word# ->+      Word# -> Word#'+    template: ~ARG[0] and ~ARG[1]+- BlackBox:+    name: GHC.Prim.or#+    kind: Expression+    type: 'or# :: Word# ->+      Word# -> Word#'+    template: ~ARG[0] or ~ARG[1]+- BlackBox:+    name: GHC.Prim.xor#+    kind: Expression+    type: 'xor# :: Word# ->+      Word# -> Word#'+    template: ~ARG[0] xor ~ARG[1]+- BlackBox:+    name: GHC.Prim.not#+    kind: Expression+    type: 'not# :: Word# ->+      Word#'+    template: not ~ARG[0]+- BlackBox:+    name: GHC.Prim.uncheckedShiftL#+    kind: Declaration+    type: 'uncheckedShiftL#+      :: Word# -> Int# -> Word#'+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedShiftRL#+    kind: Declaration+    type: 'uncheckedShiftR#+      :: Word# -> Int# -> Word#'+    template: |-+      ~GENSYM[~RESULT_shiftR][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_right(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.word2Int#+    kind: Expression+    type: 'word2Int# :: word#+      -> Int#'+    template: signed(std_logic_vector(~ARG[0]))+    workInfo: Never+- BlackBox:+    name: GHC.Prim.gtWord#+    kind: Declaration+    type: 'gtWord# :: Word#+      -> Word# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.geWord#+    kind: Declaration+    type: 'geWord# :: Word#+      -> Word# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.eqWord#+    kind: Declaration+    type: 'eqWord# :: Word#+      -> Word# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.neWord#+    kind: Declaration+    type: 'neWord# :: Word#+      -> Word# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.ltWord#+    kind: Declaration+    type: 'ltWord# :: Word#+      -> Word# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.leWord#+    kind: Declaration+    type: 'leWord# :: Word#+      -> Word# -> Int#'+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.popCnt8#+    kind: Declaration+    type: 'popCnt8 :: Word#+      -> Word#'+    template: |-+      -- popCnt8 begin+      ~GENSYM[popCnt8][0] : block+        -- given a level and a depth, calculate the corresponding index into the+        -- intermediate array+        function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is+        begin+          return (2 ** levels - 2 ** depth);+        end function;++        constant ~GENSYM[width][2] : natural := 8;+        constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2]))));+        type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0);+        signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2);+      begin+        -- put input into the first half of the intermediate array+        ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate+          ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1);+        end generate;++        -- Create the tree of adders+        ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate+          ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate+            ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate+              ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <=+                ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) ++                ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1);+            end generate;+          end generate;+        end generate;++        -- The last element of the intermediate array holds the result+        ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]);+      end block;+      -- popCnt8 end+- BlackBox:+    name: GHC.Prim.popCnt16#+    kind: Declaration+    type: 'popCnt16 :: Word#+      -> Word#'+    template: |-+      -- popCnt16 begin+      ~GENSYM[popCnt16][0] : block+        -- given a level and a depth, calculate the corresponding index into the+        -- intermediate array+        function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is+        begin+          return (2 ** levels - 2 ** depth);+        end function;++        constant ~GENSYM[width][2] : natural := 16;+        constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2]))));+        type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0);+        signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2);+      begin+        -- put input into the first half of the intermediate array+        ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate+          ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1);+        end generate;++        -- Create the tree of adders+        ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate+          ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate+            ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate+              ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <=+                ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) ++                ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1);+            end generate;+          end generate;+        end generate;++        -- The last element of the intermediate array holds the result+        ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]);+      end block;+      -- popCnt16 end+- BlackBox:+    name: GHC.Prim.popCnt32#+    kind: Declaration+    type: 'popCnt32 :: Word#+      -> Word#'+    template: |-+      -- popCnt32 begin+      ~GENSYM[popCnt32][0] : block+        -- given a level and a depth, calculate the corresponding index into the+        -- intermediate array+        function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is+        begin+          return (2 ** levels - 2 ** depth);+        end function;++        constant ~GENSYM[width][2] : natural := 32;+        constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2]))));+        type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0);+        signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2);+      begin+        -- put input into the first half of the intermediate array+        ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate+          ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1);+        end generate;++        -- Create the tree of adders+        ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate+          ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate+            ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate+              ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <=+                ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) ++                ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1);+            end generate;+          end generate;+        end generate;++        -- The last element of the intermediate array holds the result+        ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]);+      end block;+      -- popCnt32 end+- BlackBox:+    name: GHC.Prim.popCnt64#+    kind: Declaration+    type: 'popCnt64 :: Word#+      -> Word#'+    template: |-+      -- popCnt64 begin+      ~GENSYM[popCnt64][0] : block+        -- given a level and a depth, calculate the corresponding index into the+        -- intermediate array+        function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is+        begin+          return (2 ** levels - 2 ** depth);+        end function;++        constant ~GENSYM[width][2] : natural := 64;+        constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2]))));+        type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0);+        signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2);+      begin+        -- put input into the first half of the intermediate array+        ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate+          ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1);+        end generate;++        -- Create the tree of adders+        ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate+          ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate+            ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate+              ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <=+                ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) ++                ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1);+            end generate;+          end generate;+        end generate;++        -- The last element of the intermediate array holds the result+        ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]);+      end block;+      -- popCnt64 end+- BlackBox:+    name: GHC.Prim.popCnt#+    kind: Declaration+    type: 'popCnt :: Word#+      -> Word#'+    template: |-+      -- popCnt begin+      ~GENSYM[popCnt][0] : block+        -- given a level and a depth, calculate the corresponding index into the+        -- intermediate array+        function ~GENSYM[depth2Index][1] (levels,depth : in natural) return natural is+        begin+          return (2 ** levels - 2 ** depth);+        end function;++        constant ~GENSYM[width][2] : natural := ~SIZE[~TYPO];+        constant ~GENSYM[levels][3] : natural := natural (ceil (log2 (real (~SYM[2]))));+        type ~GENSYM[popCnt_res_vec][4] is array (natural range <>) of unsigned(~SYM[3] downto 0);+        signal ~GENSYM[intermediate][5] : ~SYM[4](0 to (2*~SYM[2])-2);+      begin+        -- put input into the first half of the intermediate array+        ~GENSYM[make_array][6]: for ~GENSYM[i][7] in 0 to (~SYM[2] - 1) generate+          ~SYM[5](~SYM[7]) <= resize(~VAR[input][0](~SYM[7] downto ~SYM[7]),~SYM[3]+1);+        end generate;++        -- Create the tree of adders+        ~GENSYM[make_tree][8] : if ~SYM[3] /= 0 generate+          ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[3]-1 downto 0 generate+            ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate+              ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+1)+~SYM[12]) <=+                ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])) ++                ~SYM[5](~SYM[1](~SYM[3]+1,~SYM[10]+2)+(2*~SYM[12])+1);+            end generate;+          end generate;+        end generate;++        -- The last element of the intermediate array holds the result+        ~RESULT <= resize(~SYM[5]((2*~SYM[2])-2),~SIZE[~TYPO]);+      end block;+      -- popCnt end+- BlackBox:+    name: GHC.Prim.clz8#+    kind: Declaration+    type: 'clz8 :: Word# ->+      Word#'+    template: |-+      -- clz8 begin+      ~GENSYM[clz8][0] : block+        function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is+        begin+          case a is+            when "00" => return "10";+            when "01" => return "01";+            when "10" => return "00";+            when others => return "00";+          end case;+        end function;++        function ~GENSYM[clzi][2] (+          constant n : in natural;+          constant i : in unsigned) return unsigned is+          variable v : unsigned(i'length-1 downto 0):=i;+        begin+          if v(n-1+n)='0' then+            return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n);+          else+            return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0);+          end if;+        end function;++        function ~GENSYM[clz8][3] (constant v : unsigned(0 to 7)) return unsigned is+          variable e : unsigned(0 to 7);     -- 8+          variable a : unsigned(0 to 2*3-1); -- 6+        begin+          for i in 0 to 3 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1));    end loop;+          for i in 0 to 1 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop;+          return ~SYM[2](3,a(0 to 5));+        end function;+      begin+        ~RESULT <= resize(~SYM[3](~VAR[][0](7 downto 0)),~SIZE[~TYPO]);+      end block;+      -- clz8 end+- BlackBox:+    name: GHC.Prim.clz16#+    kind: Declaration+    type: 'clz16 :: Word#+      -> Word#'+    template: |-+      -- clz16 begin+      ~GENSYM[clz16][0] : block+        function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is+        begin+          case a is+            when "00" => return "10";+            when "01" => return "01";+            when "10" => return "00";+            when others => return "00";+          end case;+        end function;++        function ~GENSYM[clzi][2] (+          constant n : in natural;+          constant i : in unsigned) return unsigned is+          variable v : unsigned(i'length-1 downto 0):=i;+        begin+          if v(n-1+n)='0' then+            return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n);+          else+            return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0);+          end if;+        end function;++        function ~GENSYM[clz16][3] (constant v : unsigned(0 to 15)) return unsigned is+          variable e : unsigned(0 to 15);    -- 16+          variable a : unsigned(0 to 4*3-1); -- 12+          variable b : unsigned(0 to 2*4-1); -- 8+        begin+          for i in 0 to 7 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1));    end loop;+          for i in 0 to 3 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop;+          for i in 0 to 1 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop;+          return ~SYM[2](4,b(0 to 7));+        end function;+      begin+        ~RESULT <= resize(~SYM[3](~VAR[][0](15 downto 0)),~SIZE[~TYPO]);+      end block;+      -- clz16 end+- BlackBox:+    name: GHC.Prim.clz32#+    kind: Declaration+    type: 'clz32 :: Word#+      -> Word#'+    template: |-+      -- clz32 begin+      ~GENSYM[clz32][0] : block+        function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is+        begin+          case a is+            when "00" => return "10";+            when "01" => return "01";+            when "10" => return "00";+            when others => return "00";+          end case;+        end function;++        function ~GENSYM[clzi][2] (+          constant n : in natural;+          constant i : in unsigned) return unsigned is+          variable v : unsigned(i'length-1 downto 0):=i;+        begin+          if v(n-1+n)='0' then+            return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n);+          else+            return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0);+          end if;+        end function;++        function ~GENSYM[clz32][3] (constant v : unsigned(0 to 31)) return unsigned is+          variable e : unsigned(0 to 31);    -- 32+          variable a : unsigned(0 to 8*3-1); -- 24+          variable b : unsigned(0 to 4*4-1); -- 16+          variable c : unsigned(0 to 2*5-1); -- 10+        begin+          for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1));    end loop;+          for i in 0 to 7  loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop;+          for i in 0 to 3  loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop;+          for i in 0 to 1  loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop;+          return ~SYM[2](5,c(0 to 9));+        end function;+      begin+        ~RESULT <= resize(~SYM[3](~VAR[][0](31 downto 0)),~SIZE[~TYPO]);+      end block;+      -- clz32 end+- BlackBox:+    name: GHC.Prim.clz64#+    kind: Declaration+    type: 'clz64 :: Word#+      -> Word#'+    template: |-+      -- clz64 begin+      ~GENSYM[clz64][0] : block+        function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is+        begin+          case a is+            when "00" => return "10";+            when "01" => return "01";+            when "10" => return "00";+            when others => return "00";+          end case;+        end function;++        function ~GENSYM[clzi][2] (+          constant n : in natural;+          constant i : in unsigned) return unsigned is+          variable v : unsigned(i'length-1 downto 0):=i;+        begin+          if v(n-1+n)='0' then+            return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n);+          else+            return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0);+          end if;+        end function;++        function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is+          variable e : unsigned(0 to 63);     -- 64+          variable a : unsigned(0 to 16*3-1); -- 48+          variable b : unsigned(0 to 8*4-1);  -- 32+          variable c : unsigned(0 to 4*5-1);  -- 20+          variable d : unsigned(0 to 2*6-1);  -- 12+        begin+          for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1));      end loop;+          for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3));   end loop;+          for i in 0 to 7  loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5));   end loop;+          for i in 0 to 3  loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7));   end loop;+          for i in 0 to 1  loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop;+          return ~SYM[2](6,d(0 to 11));+        end function;+      begin+        ~RESULT <= resize(~SYM[3](~ARG[0]),~SIZE[~TYPO]);+      end block;+      -- clz64 end+- BlackBox:+    name: GHC.Prim.clz#+    kind: Declaration+    type: 'clz :: Word# ->+      Word#'+    template: |-+      -- clz begin+      ~GENSYM[clz][0] : block+        function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is+        begin+          case a is+            when "00" => return "10";+            when "01" => return "01";+            when "10" => return "00";+            when others => return "00";+          end case;+        end function;++        function ~GENSYM[clzi][2] (+          constant n : in natural;+          constant i : in unsigned) return unsigned is+          variable v : unsigned(i'length-1 downto 0):=i;+        begin+          if v(n-1+n)='0' then+            return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n);+          else+            return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0);+          end if;+        end function;+      ~IF ~IW64 ~THEN+        function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is+          variable e : unsigned(0 to 63);     -- 64+          variable a : unsigned(0 to 16*3-1); -- 48+          variable b : unsigned(0 to 8*4-1);  -- 32+          variable c : unsigned(0 to 4*5-1);  -- 20+          variable d : unsigned(0 to 2*6-1);  -- 12+        begin+          for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1));      end loop;+          for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3));   end loop;+          for i in 0 to 7  loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5));   end loop;+          for i in 0 to 3  loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7));   end loop;+          for i in 0 to 1  loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop;+          return ~SYM[2](6,d(0 to 11));+        end function;+      ~ELSE+        function ~GENSYM[clz32][4] (constant v : unsigned(0 to 31)) return unsigned is+          variable e : unsigned(0 to 31);    -- 32+          variable a : unsigned(0 to 8*3-1); -- 24+          variable b : unsigned(0 to 4*4-1); -- 16+          variable c : unsigned(0 to 2*5-1); -- 10+        begin+          for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1));    end loop;+          for i in 0 to 7  loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop;+          for i in 0 to 3  loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop;+          for i in 0 to 1  loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop;+          return ~SYM[2](5,c(0 to 9));+        end function;+      ~FI+      begin+      ~IF ~IW64 ~THEN+        ~RESULT <= resize(~SYM[3](~ARG[0]),~SIZE[~TYPO]);+      ~ELSE+        ~RESULT <= resize(~SYM[4](~ARG[0]),~SIZE[~TYPO]);+      ~FI+      end block;+      -- clz end+- BlackBox:+    name: GHC.Prim.ctz8#+    kind: Declaration+    type: 'ctz8 :: Word# ->+      Word#'+    template: |-+      -- ctz8 begin+      ~GENSYM[ctz8][0] : block+        function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is+        begin+          case a is+            when "00" => return "10";+            when "01" => return "01";+            when "10" => return "00";+            when others => return "00";+          end case;+        end function;++        function ~GENSYM[clzi][2] (+          constant n : in natural;+          constant i : in unsigned) return unsigned is+          variable v : unsigned(i'length-1 downto 0):=i;+        begin+          if v(n-1+n)='0' then+            return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n);+          else+            return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0);+          end if;+        end function;++        function ~GENSYM[clz8][3] (constant v : unsigned(0 to 7)) return unsigned is+          variable e : unsigned(0 to 7);     -- 8+          variable a : unsigned(0 to 2*3-1); -- 6+        begin+          for i in 0 to 3 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1));    end loop;+          for i in 0 to 1 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop;+          return ~SYM[2](3,a(0 to 5));+        end function;++        signal ~GENSYM[w_reversed][5] : ~TYP[0];+      begin+        ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate+          ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]);+        end generate;+      ~IF ~IW64 ~THEN+        ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 56)),~SIZE[~TYPO]);+      ~ELSE+        ~RESULT <= resize(~SYM[3](~SYM[5](31 downto 24)),~SIZE[~TYPO]);+      ~FI+      end block;+      -- ctz8 end+- BlackBox:+    name: GHC.Prim.ctz16#+    kind: Declaration+    type: 'ctz16 :: Word#+      -> Word#'+    template: |-+      -- ctz16 begin+      ~GENSYM[ctz16][0] : block+        function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is+        begin+          case a is+            when "00" => return "10";+            when "01" => return "01";+            when "10" => return "00";+            when others => return "00";+          end case;+        end function;++        function ~GENSYM[clzi][2] (+          constant n : in natural;+          constant i : in unsigned) return unsigned is+          variable v : unsigned(i'length-1 downto 0):=i;+        begin+          if v(n-1+n)='0' then+            return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n);+          else+            return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0);+          end if;+        end function;++        function ~GENSYM[clz16][3] (constant v : unsigned(0 to 15)) return unsigned is+          variable e : unsigned(0 to 15);    -- 16+          variable a : unsigned(0 to 4*3-1); -- 12+          variable b : unsigned(0 to 2*4-1); -- 8+        begin+          for i in 0 to 7 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1));    end loop;+          for i in 0 to 3 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop;+          for i in 0 to 1 loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop;+          return ~SYM[2](4,b(0 to 7));+        end function;++        signal ~GENSYM[w_reversed][5] : ~TYP[0];+      begin+        ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate+          ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]);+        end generate;+      ~IF ~IW64 ~THEN+        ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 48)),~SIZE[~TYPO]);+      ~ELSE+        ~RESULT <= resize(~SYM[3](~SYM[5](31 downto 16)),~SIZE[~TYPO]);+      ~FI+      end block;+      -- ctz16 end+- BlackBox:+    name: GHC.Prim.ctz32#+    kind: Declaration+    type: 'ctz32 :: Word#+      -> Word#'+    template: |-+      -- ctz32 begin+      ~GENSYM[ctz32][0] : block+        function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is+        begin+          case a is+            when "00" => return "10";+            when "01" => return "01";+            when "10" => return "00";+            when others => return "00";+          end case;+        end function;++        function ~GENSYM[clzi][2] (+          constant n : in natural;+          constant i : in unsigned) return unsigned is+          variable v : unsigned(i'length-1 downto 0):=i;+        begin+          if v(n-1+n)='0' then+            return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n);+          else+            return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0);+          end if;+        end function;++        function ~GENSYM[clz32][3] (constant v : unsigned(0 to 31)) return unsigned is+          variable e : unsigned(0 to 31);    -- 32+          variable a : unsigned(0 to 8*3-1); -- 24+          variable b : unsigned(0 to 4*4-1); -- 16+          variable c : unsigned(0 to 2*5-1); -- 10+        begin+          for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1));    end loop;+          for i in 0 to 7  loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop;+          for i in 0 to 3  loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop;+          for i in 0 to 1  loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop;+          return ~SYM[2](5,c(0 to 9));+        end function;++        signal ~GENSYM[w_reversed][5] : ~TYP[0];+      begin+        ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate+          ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]);+        end generate;+      ~IF ~IW64 ~THEN+        ~RESULT <= resize(~SYM[3](~SYM[5](63 downto 32)),~SIZE[~TYPO]);+      ~ELSE+        ~RESULT <= resize(~SYM[3](~SYM[5]),~SIZE[~TYPO]);+      ~FI+      end block;+      -- ctz32 end+- BlackBox:+    name: GHC.Prim.ctz64#+    kind: Declaration+    type: 'ctz64 :: Word#+      -> Word#'+    template: |-+      -- ctz64 begin+      ~GENSYM[ctz64][0] : block+        function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is+        begin+          case a is+            when "00" => return "10";+            when "01" => return "01";+            when "10" => return "00";+            when others => return "00";+          end case;+        end function;++        function ~GENSYM[clzi][2] (+          constant n : in natural;+          constant i : in unsigned) return unsigned is+          variable v : unsigned(i'length-1 downto 0):=i;+        begin+          if v(n-1+n)='0' then+            return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n);+          else+            return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0);+          end if;+        end function;++        function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is+          variable e : unsigned(0 to 63);     -- 64+          variable a : unsigned(0 to 16*3-1); -- 48+          variable b : unsigned(0 to 8*4-1);  -- 32+          variable c : unsigned(0 to 4*5-1);  -- 20+          variable d : unsigned(0 to 2*6-1);  -- 12+        begin+          for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1));      end loop;+          for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3));   end loop;+          for i in 0 to 7  loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5));   end loop;+          for i in 0 to 3  loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7));   end loop;+          for i in 0 to 1  loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop;+          return ~SYM[2](6,d(0 to 11));+        end function;++        signal ~GENSYM[w_reversed][5] : ~TYP[0];+      begin+        ~GENSYM[reverse_loop][6] : for ~GENSYM[n][7] in ~VAR[w][0]'range generate+          ~SYM[5](~VAR[w][0]'high - ~SYM[7]) <= ~VAR[w][0](~SYM[7]);+        end generate;++        ~RESULT <= resize(~SYM[3](~SYM[5]),~SIZE[~TYPO]);+      end block;+      -- ctz64 end+- BlackBox:+    name: GHC.Prim.ctz#+    kind: Declaration+    type: 'ctz :: Word# ->+      Word#'+    template: |-+      -- ctz begin+      ~GENSYM[ctz][0] : block+        function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is+        begin+          case a is+            when "00" => return "10";+            when "01" => return "01";+            when "10" => return "00";+            when others => return "00";+          end case;+        end function;++        function ~GENSYM[clzi][2] (+          constant n : in natural;+          constant i : in unsigned) return unsigned is+          variable v : unsigned(i'length-1 downto 0):=i;+        begin+          if v(n-1+n)='0' then+            return (v(n-1+n) and v(n-1)) & '0' & v(2*n-2 downto n);+          else+            return (v(n-1+n) and v(n-1)) & not v(n-1) & v(n-2 downto 0);+          end if;+        end function;++      ~IF ~IW64 ~THEN+        function ~GENSYM[clz64][3] (constant v : unsigned(0 to 63)) return unsigned is+          variable e : unsigned(0 to 63);     -- 64+          variable a : unsigned(0 to 16*3-1); -- 48+          variable b : unsigned(0 to 8*4-1);  -- 32+          variable c : unsigned(0 to 4*5-1);  -- 20+          variable d : unsigned(0 to 2*6-1);  -- 12+        begin+          for i in 0 to 31 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1));      end loop;+          for i in 0 to 15 loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3));   end loop;+          for i in 0 to 7  loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5));   end loop;+          for i in 0 to 3  loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7));   end loop;+          for i in 0 to 1  loop d(i*6 to i*6+5):=~SYM[2](5,c(i*10 to i*10+9)); end loop;+          return ~SYM[2](6,d(0 to 11));+        end function;+      ~ELSE+        function ~GENSYM[clz32][4] (constant v : unsigned(0 to 31)) return unsigned is+          variable e : unsigned(0 to 31);    -- 32+          variable a : unsigned(0 to 8*3-1); -- 24+          variable b : unsigned(0 to 4*4-1); -- 16+          variable c : unsigned(0 to 2*5-1); -- 10+        begin+          for i in 0 to 15 loop e(i*2 to i*2+1):=~SYM[1](v(i*2 to i*2+1));    end loop;+          for i in 0 to 7  loop a(i*3 to i*3+2):=~SYM[2](2,e(i*4 to i*4+3)); end loop;+          for i in 0 to 3  loop b(i*4 to i*4+3):=~SYM[2](3,a(i*6 to i*6+5)); end loop;+          for i in 0 to 1  loop c(i*5 to i*5+4):=~SYM[2](4,b(i*8 to i*8+7)); end loop;+          return ~SYM[2](5,c(0 to 9));+        end function;+      ~FI++        signal ~GENSYM[w_reversed][6] : ~TYP[0];+      begin+        ~GENSYM[reverse_loop][7] : for ~GENSYM[n][8] in ~VAR[w][0]'range generate+          ~SYM[6](~VAR[w][0]'high - ~SYM[8]) <= ~VAR[w][0](~SYM[8]);+        end generate;+      ~IF ~IW64 ~THEN+        ~RESULT <= resize(~SYM[3](~SYM[6]),~SIZE[~TYPO]);+      ~ELSE+        ~RESULT <= resize(~SYM[4](~SYM[6]),~SIZE[~TYPO]);+      ~FI+      end block;+      -- ctz end+- BlackBox:+    name: GHC.Prim.byteSwap16#+    kind: Declaration+    type: 'byteSwap16# ::+      Word# -> Word#'+    template: |-+      -- byteSwap16 begin~IF ~IW64 ~THEN+      ~RESULT <= ~VAR[w][0](63 downto 16) & ~VAR[w][0](7 downto 0) & ~VAR[w][0](15 downto 8);~ELSE+      ~RESULT <= ~VAR[w][0](31 downto 16) & ~VAR[w][0](7 downto 0) & ~VAR[w][0](15 downto 8);~FI+      -- byteSwap16 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.byteSwap32#+    kind: Declaration+    type: 'byteSwap32# ::+      Word# -> Word#'+    template: |-+      -- byteSwap32 begin~IF ~IW64 ~THEN+      ~RESULT <= ~VAR[w][0](63 downto 32) & ~VAR[w][0](7  downto 0 ) & ~VAR[w][0](15 downto 8)+                                          & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24);~ELSE+      ~RESULT <= ~VAR[w][0](7  downto 0 ) & ~VAR[w][0](15 downto 8)+               & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24);~FI+      -- byteSwap32 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.byteSwap64#+    kind: Declaration+    type: 'byteSwap64# ::+      Word# -> Word#'+    template: |-+      -- byteSwap64 begin+      ~RESULT <= ~VAR[w][0](7  downto 0 ) & ~VAR[w][0](15 downto 8)+               & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24)+               & ~VAR[w][0](39 downto 32) & ~VAR[w][0](47 downto 40)+               & ~VAR[w][0](55 downto 48) & ~VAR[w][0](63 downto 56);+      -- byteSwap64 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.byteSwap#+    kind: Declaration+    type: 'byteSwap# :: Word#+      -> Word#'+    template: |-+      -- byteSwap begin ~IF ~IW64 ~THEN+      ~RESULT <= ~VAR[w][0](7  downto 0 ) & ~VAR[w][0](15 downto 8)+               & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24)+               & ~VAR[w][0](39 downto 32) & ~VAR[w][0](47 downto 40)+               & ~VAR[w][0](55 downto 48) & ~VAR[w][0](63 downto 56);~ELSE+      ~RESULT <= ~VAR[w][0](7  downto 0 ) & ~VAR[w][0](15 downto 8)+               & ~VAR[w][0](23 downto 16) & ~VAR[w][0](31 downto 24);~FI+      -- byteSwap end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.narrow8Int#+    kind: Expression+    type: 'narrow8Int# ::+      Int# -> Int#'+    template: resize(~VAR[i][0](7 downto 0),~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.narrow16Int#+    kind: Expression+    type: 'narrow16Int# ::+      Int# -> Int#'+    template: resize(~VAR[i][0](15 downto 0),~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.narrow32Int#+    kind: Expression+    type: 'narrow32Int# ::+      Int# -> Int#'+    template: resize(~VAR[i][0](31 downto 0),~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.narrow8Word#+    kind: Expression+    type: 'narrow8Word# ::+      Word# -> Word#'+    template: resize(~VAR[w][0](7 downto 0),~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.narrow16Word#+    kind: Expression+    type: 'narrow16Word# ::+      Word# -> Word#'+    template: resize(~VAR[w][0](15 downto 0),~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.narrow32Word#+    kind: Expression+    type: 'narrow32Word# ::+      Word# -> Word#'+    template: resize(~VAR[w][0](31 downto 0),~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.bitReverse#+    kind: Declaration+    type: 'bitReverse# ::+      Word# -> Word#'+    template: |-+      -- bitReverse begin+      ~GENSYM[bitReverse][0] : for ~GENSYM[i][1] in 0 to ~IF ~IW64 ~THEN 63 ~ELSE 31 ~FI generate+      begin+      ~RESULT(~SYM[1]) <= ~VAR[x][0](~IF ~IW64 ~THEN 63 ~ELSE 31 ~FI-~SYM[1]);+      end generate;+      -- bitReverse end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.bitReverse8#+    kind: Declaration+    type: 'bitReverse8# ::+      Word# -> Word#'+    template: |-+      -- bitReverse8 begin+      ~GENSYM[bitReverse8][0] : for ~GENSYM[i][1] in 0 to 7 generate+      begin+      ~RESULT(~SYM[1]) <= ~VAR[x][0](7-~SYM[1]);+      end generate;+      -- bitReverse8 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.bitReverse16#+    kind: Declaration+    type: 'bitReverse16# ::+      Word# -> Word#'+    template: |-+      -- bitReverse16 begin+      ~GENSYM[bitReverse16][0] : for ~GENSYM[i][1] in 0 to 15 generate+      begin+      ~RESULT(~SYM[1]) <= ~VAR[x][0](15-~SYM[1]);+      end generate;+      -- bitReverse16 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.bitReverse32#+    kind: Declaration+    type: 'bitReverse32# ::+      Word# -> Word#'+    template: |-+      -- bitReverse32 begin+      ~GENSYM[bitReverse32][0] : for ~GENSYM[i][1] in 0 to 31 generate+      begin+      ~RESULT(~SYM[1]) <= ~VAR[x][0](31-~SYM[1]);+      end generate;+      -- bitReverse32 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.bitReverse64#+    kind: Declaration+    type: 'bitReverse64# ::+      Word# -> Word#'+    template: |-+      -- bitReverse64 begin+      ~GENSYM[bitReverse64][0] : for ~GENSYM[i][1] in 0 to 63 generate+      begin+      ~RESULT(~SYM[1]) <= ~VAR[x][0](63-~SYM[1]);+      end generate;+      -- bitReverse64 end+    workInfo: Never+- BlackBox:+    name: GHC.Prim.quotInt#+    kind: Declaration+    type: 'quotInt# :: Int#+      -> Int# -> Int#'+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.quotWord#+    kind: Declaration+    type: 'quotWord# :: Word#+      -> Word# -> Word#'+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.int8ToInt#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.intToInt8#+    kind: Expression+    template: ~VAR[i][0](7 downto 0)+    workInfo: Never+- BlackBox:+    name: GHC.Prim.negateInt8#+    kind: Expression+    template: -~ARG[0]+- BlackBox:+    name: GHC.Prim.timesInt8#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_mult][0] : block+        signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+      begin+        ~SYM[1] <= ~ARG[0] * ~ARG[1];+        ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+      end block;+- BlackBox:+    name: GHC.Prim.quotInt8#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.remInt8#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.quotRemInt8#+    kind: Declaration+    template: |-+      ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])+          -- pragma translate_off+          when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X'))+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.uncheckedShiftLInt8#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedShiftRAInt8#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftR][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_right(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedShiftRLInt8#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftRL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= ~ARG[0] srl ~SYM[1]+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.int8ToWord8#+    kind: Expression+    template: unsigned(std_logic_vector(~ARG[0]))+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqInt8#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.geInt8#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.gtInt8#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.leInt8#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.ltInt8#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.neInt8#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.word8ToWord#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.wordToWord8#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.timesWord8#+    kind: Expression+    template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+- BlackBox:+    name: GHC.Prim.quotWord8#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.remWord8#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.quotRemWord8#+    kind: Declaration+    template: |-+      ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])+          -- pragma translate_off+          when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X'))+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.andWord8#+    kind: Expression+    template: ~ARG[0] and ~ARG[1]+- BlackBox:+    name: GHC.Prim.orWord8#+    kind: Expression+    template: ~ARG[0] or ~ARG[1]+- BlackBox:+    name: GHC.Prim.xorWord8#+    kind: Expression+    template: ~ARG[0] xor ~ARG[1]+- BlackBox:+    name: GHC.Prim.notWord8#+    kind: Expression+    template: not ~ARG[0]+- BlackBox:+    name: GHC.Prim.uncheckedShiftLWord8#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedShiftRLWord8#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftRL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= ~ARG[0] srl ~SYM[1]+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.word8ToInt8#+    kind: Expression+    template: signed(std_logic_vector(~ARG[0]))+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqWord8#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.geWord8#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.gtWord8#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.leWord8#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.ltWord8#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.neWord8#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.int16ToInt#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.intToInt16#+    kind: Expression+    template: ~VAR[i][0](15 downto 0)+    workInfo: Never+- BlackBox:+    name: GHC.Prim.negateInt16#+    kind: Expression+    template: -~ARG[0]+- BlackBox:+    name: GHC.Prim.timesInt16#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_mult][0] : block+        signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+      begin+        ~SYM[1] <= ~ARG[0] * ~ARG[1];+        ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+      end block;+- BlackBox:+    name: GHC.Prim.quotInt16#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.remInt16#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.quotRemInt16#+    kind: Declaration+    template: |-+      ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])+          -- pragma translate_off+          when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X'))+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.uncheckedShiftLInt16#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedShiftRAInt16#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftR][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_right(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedShiftRLInt16#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftRL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= ~ARG[0] srl ~SYM[1]+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.int16ToWord16#+    kind: Expression+    template: unsigned(std_logic_vector(~ARG[0]))+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqInt16#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.geInt16#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.gtInt16#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.leInt16#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.ltInt16#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.neInt16#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.word16ToWord#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.wordToWord16#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.timesWord16#+    kind: Expression+    template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+- BlackBox:+    name: GHC.Prim.quotWord16#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.remWord16#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.quotRemWord16#+    kind: Declaration+    template: |-+      ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])+          -- pragma translate_off+          when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X'))+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.andWord16#+    kind: Expression+    template: ~ARG[0] and ~ARG[1]+- BlackBox:+    name: GHC.Prim.orWord16#+    kind: Expression+    template: ~ARG[0] or ~ARG[1]+- BlackBox:+    name: GHC.Prim.xorWord16#+    kind: Expression+    template: ~ARG[0] xor ~ARG[1]+- BlackBox:+    name: GHC.Prim.notWord16#+    kind: Expression+    template: not ~ARG[0]+- BlackBox:+    name: GHC.Prim.uncheckedShiftLWord16#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedShiftRLWord16#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftRL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= ~ARG[0] srl ~SYM[1]+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.word16ToInt16#+    kind: Expression+    template: signed(std_logic_vector(~ARG[0]))+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqWord16#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.geWord16#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.gtWord16#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.leWord16#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.ltWord16#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.neWord16#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.int32ToInt#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.intToInt32#+    kind: Expression+    template: ~VAR[i][0](31 downto 0)+    workInfo: Never+- BlackBox:+    name: GHC.Prim.negateInt32#+    kind: Expression+    template: -~ARG[0]+- BlackBox:+    name: GHC.Prim.timesInt32#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_mult][0] : block+        signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+      begin+        ~SYM[1] <= ~ARG[0] * ~ARG[1];+        ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+      end block;+- BlackBox:+    name: GHC.Prim.quotInt32#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.remInt32#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.quotRemInt32#+    kind: Declaration+    template: |-+      ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])+          -- pragma translate_off+          when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X'))+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.uncheckedShiftLInt32#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedShiftRAInt32#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftR][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_right(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedShiftRLInt32#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftRL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= ~ARG[0] srl ~SYM[1]+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.int32ToWord32#+    kind: Expression+    template: unsigned(std_logic_vector(~ARG[0]))+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqInt32#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.geInt32#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.gtInt32#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.leInt32#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.ltInt32#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.neInt32#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.word32ToWord#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.wordToWord32#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.timesWord32#+    kind: Expression+    template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+- BlackBox:+    name: GHC.Prim.quotWord32#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.remWord32#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.quotRemWord32#+    kind: Declaration+    template: |-+      ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])+          -- pragma translate_off+          when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X'))+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.andWord32#+    kind: Expression+    template: ~ARG[0] and ~ARG[1]+- BlackBox:+    name: GHC.Prim.orWord32#+    kind: Expression+    template: ~ARG[0] or ~ARG[1]+- BlackBox:+    name: GHC.Prim.xorWord32#+    kind: Expression+    template: ~ARG[0] xor ~ARG[1]+- BlackBox:+    name: GHC.Prim.notWord32#+    kind: Expression+    template: not ~ARG[0]+- BlackBox:+    name: GHC.Prim.uncheckedShiftLWord32#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedShiftRLWord32#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftRL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= ~ARG[0] srl ~SYM[1]+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.word32ToInt32#+    kind: Expression+    template: signed(std_logic_vector(~ARG[0]))+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqWord32#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.geWord32#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.gtWord32#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.leWord32#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.ltWord32#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.neWord32#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.int64ToInt#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.intToInt64#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.negateInt64#+    kind: Expression+    template: -~ARG[0]+- BlackBox:+    name: GHC.Prim.timesInt64#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_mult][0] : block+        signal ~GENSYM[~RESULT_mult_full][1] : signed(~SIZE[~TYPO]*2-1 downto 0);+      begin+        ~SYM[1] <= ~ARG[0] * ~ARG[1];+        ~RESULT <= ~SYM[1](~SIZE[~TYPO]-1 downto 0);+      end block;+- BlackBox:+    name: GHC.Prim.quotInt64#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.remInt64#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.quotRemInt64#+    kind: Declaration+    template: |-+      ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])+          -- pragma translate_off+          when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X'))+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.uncheckedIShiftL64#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedIShiftRA64#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftR][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_right(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedIShiftRL64#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftRL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= ~ARG[0] srl ~SYM[1]+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.int64ToWord64#+    kind: Expression+    template: unsigned(std_logic_vector(~ARG[0]))+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqInt64#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.geInt64#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.gtInt64#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.leInt64#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.ltInt64#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.neInt64#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.word64ToWord#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.wordToWord64#+    kind: Expression+    template: resize(~ARG[0],~SIZE[~TYPO])+    workInfo: Never+- BlackBox:+    name: GHC.Prim.timesWord64#+    kind: Expression+    template: resize(~ARG[0] * ~ARG[1],~SIZE[~TYPO])+- BlackBox:+    name: GHC.Prim.quotWord64#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] / ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.remWord64#+    kind: Declaration+    template: |-+      ~RESULT <= ~ARG[0] rem ~ARG[1]+          -- pragma translate_off+          when (~ARG[1] /= 0) else (others => 'X')+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.quotRemWord64#+    kind: Declaration+    template: |-+      ~RESULT <= (~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])+          -- pragma translate_off+          when (~ARG[1] /= 0) else ((others => 'X'), (others => 'X'))+          -- pragma translate_on+          ;+- BlackBox:+    name: GHC.Prim.and64#+    kind: Expression+    template: ~ARG[0] and ~ARG[1]+- BlackBox:+    name: GHC.Prim.or64#+    kind: Expression+    template: ~ARG[0] or ~ARG[1]+- BlackBox:+    name: GHC.Prim.xor64#+    kind: Expression+    template: ~ARG[0] xor ~ARG[1]+- BlackBox:+    name: GHC.Prim.not64#+    kind: Expression+    template: not ~ARG[0]+- BlackBox:+    name: GHC.Prim.uncheckedShiftL64#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= shift_left(~ARG[0],~SYM[1])+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.uncheckedShiftRL64#+    kind: Declaration+    template: |-+      ~GENSYM[~RESULT_shiftRL][0] : block+        signal ~GENSYM[sh][1] : natural;+      begin+        ~SYM[1] <=+            -- pragma translate_off+            natural'high when (~VAR[shI][1](~SIZE[~TYP[1]]-1 downto 31) /= 0) else+            -- pragma translate_on+            to_integer(~VAR[shI][1]);+        ~RESULT <= ~ARG[0] srl ~SYM[1]+            -- pragma translate_off+            when (~ARG[1] >= 0) else (others => 'X')+            -- pragma translate_on+            ;+      end block;+- BlackBox:+    name: GHC.Prim.word64ToInt64#+    kind: Expression+    template: signed(std_logic_vector(~ARG[0]))+    workInfo: Never+- BlackBox:+    name: GHC.Prim.eqWord64#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] = ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.geWord64#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] >= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.gtWord64#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] > ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.leWord64#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] <= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.ltWord64#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] < ~ARG[1] else to_signed(0,~SIZE[~TYPO]);+- BlackBox:+    name: GHC.Prim.neWord64#+    kind: Declaration+    template: ~RESULT <= to_signed(1,~SIZE[~TYPO]) when ~ARG[0] /= ~ARG[1] else to_signed(0,~SIZE[~TYPO]);
+ prims/vhdl/GHC_Word.primitives.yaml view
@@ -0,0 +1,28 @@+- BlackBox:+    name: GHC.Word.W8#+    kind: Expression+    type: 'W8# :: Word# ->+      Word8'+    template: resize(~ARG[0],8)+    workInfo: Never+- BlackBox:+    name: GHC.Word.W16#+    kind: Expression+    type: 'W16# :: Word# ->+      Word16'+    template: resize(~ARG[0],16)+    workInfo: Never+- BlackBox:+    name: GHC.Word.W32#+    kind: Expression+    type: 'W32# :: Word# ->+      Word32'+    template: resize(~ARG[0],32)+    workInfo: Never+- BlackBox:+    name: GHC.Word.W64#+    kind: Expression+    type: 'W64# :: Word# ->+      Word64'+    template: resize(~ARG[0],64)+    workInfo: Never
− src/CLaSH/Backend.hs 
@@ -1,76 +0,0 @@-{-|-  Copyright  :  (C) 2015-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--module CLaSH.Backend where--import Data.HashSet                         (HashSet)-import Data.Text.Lazy                       (Text)-import Control.Monad.State                  (State)-import Text.PrettyPrint.Leijen.Text.Monadic (Doc)--import SrcLoc (SrcSpan)--import CLaSH.Netlist.Types-import CLaSH.Netlist.BlackBox.Types--import CLaSH.Annotations.Primitive          (HDL)--type ModName = String--class Backend state where-  -- | Initial state for state monad-  initBackend :: Int -> HdlSyn -> state--  -- | What HDL is the backend generating-  hdlKind :: state -> HDL--  -- | Location for the primitive definitions-  primDir :: state -> IO FilePath--  -- | Name of backend, used for directory to put output files in. Should be-  -- | constant function / ignore argument.-  name :: state -> String--  -- | File extension for target langauge-  extension :: state -> String--  -- | Get the set of types out of state-  extractTypes     :: state -> HashSet HWType--  -- | Generate HDL for a Netlist component-  genHDL           :: String -> SrcSpan -> Component -> State state ((String, Doc),[(String,Doc)])-  -- | Generate a HDL package containing type definitions for the given HWTypes-  mkTyPackage      :: String -> [HWType] -> State state [(String, Doc)]-  -- | Convert a Netlist HWType to a target HDL type-  hdlType          :: HWType       -> State state Doc-  -- | Convert a Netlist HWType to an HDL error value for that type-  hdlTypeErrValue  :: HWType       -> State state Doc-  -- | Convert a Netlist HWType to the root of a target HDL type-  hdlTypeMark      :: HWType       -> State state Doc-  -- | Create a signal declaration from an identifier (Text) and Netlist HWType-  hdlSig           :: Text -> HWType -> State state Doc-  -- | Create a generative block statement marker-  genStmt          :: Bool -> State state Doc-  -- | Turn a Netlist Declaration to a HDL concurrent block-  inst             :: Declaration  -> State state (Maybe Doc)-  -- | Turn a Netlist expression into a HDL expression-  expr             :: Bool -> Expr -> State state Doc-  -- | Bit-width of Int/Word/Integer-  iwWidth          :: State state Int-  -- | Convert to a bit-vector-  toBV             :: HWType -> Text -> State state Doc-  -- | Convert from a bit-vector-  fromBV           :: HWType -> Text -> State state Doc-  -- | Synthesis tool we're generating HDL for-  hdlSyn           :: State state HdlSyn-  -- | mkBasicId-  mkBasicId        :: State state (Identifier -> Identifier)-  -- | setModName-  setModName       :: ModName -> state -> state-  -- | setSrcSpan-  setSrcSpan       :: SrcSpan -> State state ()-  -- | getSrcSpan-  getSrcSpan       :: State state SrcSpan
− src/CLaSH/Core/DataCon.hs 
@@ -1,118 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Data Constructors in CoreHW--}--{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell       #-}--module CLaSH.Core.DataCon-  ( DataCon (..)-  , DcName-  , ConTag-  , dataConInstArgTys-  )-where--#ifndef MIN_VERSION_unbound_generics-#define MIN_VERSION_unbound_generics(x,y,z)(1)-#endif--import Control.DeepSeq                        (NFData(..))-import GHC.Generics                           (Generic)-import Unbound.Generics.LocallyNameless       (Alpha(..),Name,Subst(..))-import Unbound.Generics.LocallyNameless.Extra ()-#if MIN_VERSION_unbound_generics(0,3,0)-import Data.Monoid                            (All (..))-import Unbound.Generics.LocallyNameless       (NthPatFind (..),-                                               NamePatFind (..))-#endif--import {-# SOURCE #-} CLaSH.Core.Type         (TyName, Type)-import CLaSH.Util---- | Data Constructor-data DataCon-  = MkData-  { dcName       :: !DcName  -- ^ Name of the DataCon-  , dcTag        :: !ConTag  -- ^ Syntactical position in the type definition-  , dcType       :: !Type    -- ^ Type of the 'DataCon-  , dcUnivTyVars :: [TyName] -- ^ Universally quantified type-variables,-                             -- these type variables are also part of the-                             -- result type of the DataCon-  , dcExtTyVars  :: [TyName] -- ^ Existentially quantified type-variables,-                             -- these type variables are not part of the result-                             -- of the DataCon, but only of the arguments.-  , dcArgTys     :: [Type]   -- ^ Argument types-  } deriving (Generic,NFData)--instance Show DataCon where-  show = show . dcName--instance Eq DataCon where-  (==) = (==) `on` dcName--instance Ord DataCon where-  compare = compare `on` dcName---- | Syntactical position of the DataCon in the type definition-type ConTag = Int--- | DataCon reference-type DcName = Name DataCon--instance Alpha DataCon where-  aeq' c dc1 dc2      = aeq' c (dcName dc1) (dcName dc2)--  fvAny' _ _ dc       = pure dc--  close _ _ dc        = dc-  open _ _ dc         = dc--  isPat _             = mempty--#if MIN_VERSION_unbound_generics(0,3,0)-  isTerm _            = All True-  nthPatFind _        = NthPatFind Left-  namePatFind _       = NamePatFind (const (Left 0))-#else-  isTerm _            = True-  nthPatFind _        = Left-  namePatFind _ _     = Left 0-#endif--  swaps' _ _ dc       = dc-  lfreshen' _ dc cont = cont dc mempty-  freshen' _ dc       = return (dc,mempty)--  acompare' c dc1 dc2 = acompare' c (dcName dc1) (dcName dc2)--instance Subst a DataCon where-  subst _ _ dc = dc-  substs _ dc  = dc---- | Given a DataCon and a list of types, the type variables of the DataCon--- type are substituted for the list of types. The argument types are returned.------ The list of types should be equal to the number of type variables, otherwise--- @Nothing@ is returned.-dataConInstArgTys :: DataCon -> [Type] -> Maybe [Type]-dataConInstArgTys (MkData { dcArgTys     = arg_tys-                          , dcUnivTyVars = univ_tvs-                          , dcExtTyVars  = ex_tvs-                          })-                  inst_tys-  | length tyvars == length inst_tys-  = Just (map (substs (zip tyvars inst_tys)) arg_tys)--  | otherwise-  = Nothing--  where-    tyvars = univ_tvs ++ ex_tvs
− src/CLaSH/Core/FreeVars.hs 
@@ -1,27 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Free variable calculations--}--module CLaSH.Core.FreeVars where--import Control.Lens.Fold                (Fold)-import Unbound.Generics.LocallyNameless (fv)--import CLaSH.Core.Term                  (Term, TmName)-import CLaSH.Core.Type                  (TyName, Type)---- | Gives the free type-variables in a Type-typeFreeVars :: Fold Type TyName-typeFreeVars = fv---- | Gives the free term-variables of a Term-termFreeIds :: Fold Term TmName-termFreeIds = fv---- | Gives the free type-variables of a Term-termFreeTyVars :: Fold Term TyName-termFreeTyVars = fv
− src/CLaSH/Core/Literal.hs 
@@ -1,63 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Term Literal--}--{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module CLaSH.Core.Literal-  ( Literal (..)-  , literalType-  )-where--import Control.DeepSeq                        (NFData (..))-import GHC.Generics                           (Generic)-import Unbound.Generics.LocallyNameless.Extra ()-import Unbound.Generics.LocallyNameless       (Alpha (..), Subst (..))--import {-# SOURCE #-} CLaSH.Core.Type         (Type)-import CLaSH.Core.TysPrim                     (intPrimTy, integerPrimTy,-                                               charPrimTy, stringPrimTy,-                                               wordPrimTy,-                                               int64PrimTy, word64PrimTy,-                                               floatPrimTy, doublePrimTy)---- | Term Literal-data Literal-  = IntegerLiteral  !Integer-  | IntLiteral      !Integer-  | WordLiteral     !Integer-  | Int64Literal    !Integer-  | Word64Literal   !Integer-  | StringLiteral   !String-  | FloatLiteral    !Rational-  | DoubleLiteral   !Rational-  | CharLiteral     !Char-  deriving (Eq,Ord,Show,Generic,NFData)--instance Alpha Literal where-  fvAny' _ _ l = pure l--instance Subst a Literal where-  subst _ _ l = l-  substs _ l  = l---- | Determines the Type of a Literal-literalType :: Literal-            -> Type-literalType (IntegerLiteral  _) = integerPrimTy-literalType (IntLiteral      _) = intPrimTy-literalType (WordLiteral     _) = wordPrimTy-literalType (StringLiteral   _) = stringPrimTy-literalType (FloatLiteral    _) = floatPrimTy-literalType (DoubleLiteral   _) = doublePrimTy-literalType (CharLiteral     _) = charPrimTy-literalType (Int64Literal    _) = int64PrimTy-literalType (Word64Literal   _) = word64PrimTy
− src/CLaSH/Core/Pretty.hs 
@@ -1,358 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Pretty printing class and instances for CoreHW--}--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE ViewPatterns      #-}--module CLaSH.Core.Pretty-  ( Pretty (..)-  , showDoc-  )-where--import Data.Char                        (isSymbol, isUpper, ord)-import Data.Text                        (unpack)-import GHC.Show                         (showMultiLineString)-import Numeric                          (fromRat)-import Text.PrettyPrint                 (Doc, char, comma, empty, equals, hang,-                                         hsep, integer, parens, punctuate,-                                         render, sep, text, vcat, ($$), ($+$),-                                         (<+>), (<>), nest, float, double)-import Unbound.Generics.LocallyNameless (Embed (..), LFresh, Name, lunbind,-                                         name2String, runLFreshM, unembed,-                                         unrebind, unrec)--import CLaSH.Core.DataCon               (DataCon (..))-import CLaSH.Core.Literal               (Literal (..))-import CLaSH.Core.Term                  (Pat (..), Term (..))-import CLaSH.Core.TyCon                 (TyCon (..), TyConName, isTupleTyConLike)-import CLaSH.Core.Type                  (ConstTy (..), Kind, LitTy (..),-                                         Type (..), TypeView (..), tyView)-import CLaSH.Core.Var                   (Id, TyVar, Var, varKind, varName,-                                         varType)-import CLaSH.Util---- | Pretty printing Show-like typeclass-class Pretty p where-  ppr :: LFresh m => p -> m Doc-  ppr = pprPrec 0--  pprPrec :: LFresh m => Rational -> p -> m Doc--noPrec, opPrec, appPrec :: Num a => a-noPrec = 0-opPrec = 1-appPrec = 2---- | Print a Pretty thing to a String-showDoc :: Pretty p => p -> String-showDoc = render . runLFreshM . ppr--prettyParen :: Bool -> Doc -> Doc-prettyParen False = id-prettyParen True  = parens--instance Pretty (Name a) where-  pprPrec _ = return . text . show--instance Pretty a => Pretty [a] where-  pprPrec prec xs = do-    xs' <- mapM (pprPrec prec) xs-    return $ vcat xs'--instance Pretty (Id, Term) where-  pprPrec _ = pprTopLevelBndr--pprTopLevelBndr :: LFresh m => (Id,Term) -> m Doc-pprTopLevelBndr (bndr,expr) = do-  bndr' <- ppr bndr-  bndrName <- ppr (varName bndr)-  expr' <- ppr expr-  return $ bndr' $$ hang (bndrName <+> equals) 2 expr' <> text "\n"--dcolon :: Doc-dcolon = text "::"--period :: Doc-period = char '.'--rarrow :: Doc-rarrow = text "->"--instance Pretty Type where-  pprPrec _ = pprType--instance Pretty (Var Type) where-  pprPrec _ v = ppr $ varName v--instance Pretty TyCon where-  pprPrec _ tc = return . text . name2String $ tyConName tc--instance Pretty LitTy where-  pprPrec _ (NumTy i) = return $ integer i-  pprPrec _ (SymTy s) = return $ text s--instance Pretty Term where-  pprPrec prec e = case e of-    Var _ x      -> pprPrec prec x-    Data dc      -> pprPrec prec dc-    Literal l    -> pprPrec prec l-    Prim nm _    -> return $ text $ unpack nm-    Lam b        -> lunbind b $ \(v,e')  -> pprPrecLam prec [v] e'-    TyLam b      -> lunbind b $ \(tv,e') -> pprPrecTyLam prec [tv] e'-    App fun arg  -> pprPrecApp prec fun arg-    TyApp e' ty  -> pprPrecTyApp prec e' ty-    Letrec b     -> lunbind b $ \(xes,e') -> pprPrecLetrec prec (unrec xes) e'-    Case e' _ alts -> pprPrecCase prec e' =<< mapM (`lunbind` return) alts--data BindingSite-  = LambdaBind-  | CaseBind-  | LetBind--instance Pretty (Var Term) where-  pprPrec _ v = do-    v'  <- ppr (varName v)-    ty' <- ppr (unembed $ varType v)-    return $ v' <+> dcolon <+> ty'--instance Pretty DataCon where-  pprPrec _ dc = return . text . name2String $ dcName dc--instance Pretty Literal where-  pprPrec _ l = case l of-    IntegerLiteral i-      | i < 0         -> return $ parens (integer i)-      | otherwise     -> return $ integer i-    IntLiteral i-      | i < 0         -> return $ parens (integer i)-      | otherwise     -> return $ integer i-    Int64Literal i-      | i < 0         -> return $ parens (integer i)-      | otherwise     -> return $ integer i-    WordLiteral w     -> return $ integer w-    Word64Literal w   -> return $ integer w-    FloatLiteral r    -> return $ float (fromRat r)-    DoubleLiteral r   -> return $ double (fromRat r)-    CharLiteral c     -> return $ char c-    StringLiteral s   -> return $ vcat $ map text $ showMultiLineString s--instance Pretty Pat where-  pprPrec prec pat = case pat of-    DataPat dc pxs -> do-      let (txs,xs) = unrebind pxs-      dc'  <- ppr (unembed dc)-      txs' <- mapM (pprBndr LetBind) txs-      xs'  <- mapM (pprBndr CaseBind) xs-      return $ prettyParen (prec >= appPrec) $ dc' <+> hsep txs' $$ (nest 2 (vcat xs'))-    LitPat l   -> ppr (unembed l)-    DefaultPat -> return $ char '_'--pprPrecLam :: LFresh m => Rational -> [Id] -> Term -> m Doc-pprPrecLam prec xs e = do-  xs' <- mapM (pprBndr LambdaBind) xs-  e'  <- pprPrec noPrec e-  return $ prettyParen (prec > noPrec) $-    char 'λ' <> hsep xs' <+> rarrow $+$ e'--pprPrecTyLam :: LFresh m => Rational -> [TyVar] -> Term -> m Doc-pprPrecTyLam prec tvs e = do-  tvs' <- mapM ppr tvs-  e'   <- pprPrec noPrec e-  return $ prettyParen (prec > noPrec) $-    char 'Λ' <> hsep tvs' <+> rarrow $+$ e'--pprPrecApp :: LFresh m => Rational -> Term -> Term -> m Doc-pprPrecApp prec e1 e2 = do-  e1' <- pprPrec opPrec e1-  e2' <- pprPrec appPrec e2-  return $ prettyParen (prec >= appPrec) $ e1' $$ (nest 2 e2')--pprPrecTyApp :: LFresh m => Rational -> Term -> Type -> m Doc-pprPrecTyApp prec e ty = do-  e' <- pprPrec opPrec e-  ty' <- pprParendType ty-  return $ prettyParen (prec >= appPrec) $ e' $$ (char '@' <> ty')--pprPrecLetrec :: LFresh m => Rational -> [(Id, Embed Term)] -> Term-  -> m Doc-pprPrecLetrec prec xes body-  | [] <- xes = pprPrec prec body-  | otherwise = do-    body' <- pprPrec noPrec body-    xes'  <- mapM (\(x,e) -> do-                    x' <- pprBndr LetBind x-                    e' <- pprPrec noPrec (unembed e)-                    return $ x' $$ equals <+> e'-                  ) xes-    return $ prettyParen (prec > noPrec) $-      hang (text "letrec") 2 (vcat xes') $$ text "in" <+> body'--pprPrecCase :: LFresh m => Rational -> Term -> [(Pat,Term)] -> m Doc-pprPrecCase prec e alts = do-  e' <- pprPrec prec e-  alts' <- mapM (pprPrecAlt noPrec) alts-  return $ prettyParen (prec > noPrec) $-    hang (text "case" <+> e' <+> text "of") 2 $ vcat alts'--pprPrecAlt :: LFresh m => Rational -> (Pat,Term) -> m Doc-pprPrecAlt _ (altPat, altE) = do-  altPat' <- pprPrec noPrec altPat-  altE'   <- pprPrec noPrec altE-  return $ hang (altPat' <+> rarrow) 2 altE'--pprBndr :: (LFresh m, Pretty a) => BindingSite -> a -> m Doc-pprBndr bs x = prettyParen needsParen <$> ppr x-  where-    needsParen = case bs of-      LambdaBind -> True-      CaseBind   -> True-      LetBind    -> False--data TypePrec-  = TopPrec-  | FunPrec-  | TyConPrec-  deriving (Eq,Ord)--maybeParen :: TypePrec -> TypePrec -> Doc -> Doc-maybeParen ctxt_prec inner_prec = prettyParen (ctxt_prec >= inner_prec)--pprType :: LFresh m => Type -> m Doc-pprType = ppr_type TopPrec--pprParendType :: LFresh m => Type -> m Doc-pprParendType = ppr_type TyConPrec--ppr_type :: LFresh m => TypePrec -> Type -> m Doc-ppr_type _ (VarTy _ tv)                 = ppr tv-ppr_type _ (LitTy tyLit)                = ppr tyLit-ppr_type p ty@(ForAllTy _)              = pprForAllType p ty-ppr_type p (ConstTy (TyCon tc))         = pprTcApp p ppr_type tc []-ppr_type p (tyView -> TyConApp tc args) = pprTcApp p ppr_type tc args-ppr_type p (tyView -> FunTy ty1 ty2)    = pprArrowChain p <$> ppr_type FunPrec ty1 <:> pprFunTail ty2-  where-    pprFunTail (tyView -> FunTy ty1' ty2') = ppr_type FunPrec ty1' <:> pprFunTail ty2'-    pprFunTail otherTy                     = ppr_type TopPrec otherTy <:> pure []--ppr_type p (AppTy ty1 ty2) = maybeParen p TyConPrec <$> ((<+>) <$> pprType ty1 <*> ppr_type TyConPrec ty2)-ppr_type _ (ConstTy Arrow) = return (parens rarrow)--pprForAllType :: LFresh m => TypePrec -> Type -> m Doc-pprForAllType p ty = maybeParen p FunPrec <$> pprSigmaType True ty--pprSigmaType :: LFresh m => Bool -> Type -> m Doc-pprSigmaType showForalls ty = do-    (tvs, rho)     <- split1 [] ty-    sep <$> sequenceA [ if showForalls then pprForAll tvs else pure empty-                      , pprType rho-                      ]-  where-    split1 tvs (ForAllTy b) =-      lunbind b $ \(tv,resTy) -> split1 (tv:tvs) resTy-    split1 tvs resTy = return (reverse tvs,resTy)--pprForAll :: LFresh m => [TyVar] -> m Doc-pprForAll [] = return empty-pprForAll tvs = do-  tvs' <- mapM pprTvBndr tvs-  return $ char '∀' <+> sep tvs' <> period--pprTvBndr :: LFresh m => TyVar -> m Doc-pprTvBndr tv-  = do-      tv'   <- ppr tv-      kind' <- pprKind kind-      return $ parens (tv' <+> dcolon <+> kind')-  where-    kind = unembed $ varKind tv--pprKind :: LFresh m => Kind -> m Doc-pprKind = pprType--pprTcApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc)-  -> TyConName -> [Type] -> m Doc-pprTcApp _ _  tc []-  = return . text $ name2String tc--pprTcApp p pp tc tys-  | isTupleTyConLike tc-  = do-    tys' <- mapM (pp TopPrec) tys-    return $ parens $ sep $ punctuate comma tys'--  | otherwise-  = pprTypeNameApp p pp tc tys--pprTypeNameApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc)-  -> Name a -> [Type] -> m Doc-pprTypeNameApp p pp name tys-  | isSym-  , [ty1,ty2] <- tys-  = pprInfixApp p pp name ty1 ty2-  | otherwise-  = do-    tys' <- mapM (pp TyConPrec) tys-    let name' = text $ name2String name-    return $ pprPrefixApp p (pprPrefixVar isSym name') tys'-  where-    isSym = isSymName name--pprInfixApp :: LFresh m => TypePrec -> (TypePrec -> Type -> m Doc)-  -> Name a -> Type -> Type -> m Doc-pprInfixApp p pp name ty1 ty2 = do-  ty1'  <- pp FunPrec ty1-  ty2'  <- pp FunPrec ty2-  let name' = text $ name2String name-  return $ maybeParen p FunPrec $ sep [ty1', pprInfixVar True name' <+> ty2']--pprPrefixApp :: TypePrec -> Doc -> [Doc] -> Doc-pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $-                                 hang pp_fun 2 (sep pp_tys)--pprPrefixVar :: Bool -> Doc -> Doc-pprPrefixVar is_operator pp_v-  | is_operator = parens pp_v-  | otherwise   = pp_v--pprInfixVar :: Bool -> Doc -> Doc-pprInfixVar is_operator pp_v-  | is_operator = pp_v-  | otherwise   = char '`' <> pp_v <> char '`'--pprArrowChain :: TypePrec -> [Doc] -> Doc-pprArrowChain _ []         = empty-pprArrowChain p (arg:args) = maybeParen p FunPrec $-                               sep [arg, sep (map (rarrow <+>) args)]--isSymName :: Name a -> Bool-isSymName n = go (name2String n)-  where-    go s | null s           = False-         | isUpper $ head s = isLexConSym s-         | otherwise        = isLexSym s--isLexSym :: String -> Bool-isLexSym cs = isLexConSym cs || isLexVarSym cs--isLexConSym :: String -> Bool-isLexConSym "->" = True-isLexConSym cs   = startsConSym (head cs)--isLexVarSym :: String -> Bool-isLexVarSym cs = startsVarSym (head cs)--startsConSym :: Char -> Bool-startsConSym c = c == ':'--startsVarSym :: Char -> Bool-startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c)--isSymbolASCII :: Char -> Bool-isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
− src/CLaSH/Core/Subst.hs 
@@ -1,59 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Capture-free substitution function for CoreHW--}--module CLaSH.Core.Subst where--import Unbound.Generics.LocallyNameless (subst, substs)--import CLaSH.Core.Term                  (Term, TmName)-import {-# SOURCE #-} CLaSH.Core.Type   (KiName, Kind, TyName, Type)---- | Substitutes types in a type-substTys :: [(TyName,Type)]-         -> Type-         -> Type-substTys = substs---- | Substitutes a type in a type-substTy :: TyName-        -> Type-        -> Type-        -> Type-substTy = subst---- | Substitutes kinds in a kind-substKindWith :: [(KiName,Kind)]-              -> Kind-              -> Kind-substKindWith = substs---- | Substitutes a type in a term-substTyInTm :: TyName-            -> Type-            -> Term-            -> Term-substTyInTm = subst---- | Substitutes types in a term-substTysinTm :: [(TyName,Type)]-             -> Term-             -> Term-substTysinTm = substs---- | Substitutes a term in a term-substTm :: TmName-        -> Term-        -> Term-        -> Term-substTm = subst---- | Substitutes terms in a term-substTms :: [(TmName,Term)]-         -> Term-         -> Term-substTms = substs
− src/CLaSH/Core/Term.hs 
@@ -1,92 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Term representation in the CoreHW language: System F + LetRec + Case--}--{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell       #-}--module CLaSH.Core.Term-  ( Term (..)-  , TmName-  , LetBinding-  , Pat (..)-  )-where---- External Modules-import Control.DeepSeq-import Data.Text                               (Text)-import GHC.Generics-import Unbound.Generics.LocallyNameless-import Unbound.Generics.LocallyNameless.Extra  ()---- Internal Modules-import CLaSH.Core.DataCon                      (DataCon)-import CLaSH.Core.Literal                      (Literal)-import {-# SOURCE #-} CLaSH.Core.Type          (Type)-import CLaSH.Core.Var                          (Id, TyVar)---- | Term representation in the CoreHW language: System F + LetRec + Case-data Term-  = Var     !Type !TmName                   -- ^ Variable reference-  | Data    !DataCon                        -- ^ Datatype constructor-  | Literal !Literal                        -- ^ Literal-  | Prim    !Text !Type                     -- ^ Primitive-  | Lam     !(Bind Id Term)                 -- ^ Term-abstraction-  | TyLam   !(Bind TyVar Term)              -- ^ Type-abstraction-  | App     !Term !Term                     -- ^ Application-  | TyApp   !Term !Type                     -- ^ Type-application-  | Letrec  !(Bind (Rec [LetBinding]) Term) -- ^ Recursive let-binding-  | Case    !Term !Type [Bind Pat Term]     -- ^ Case-expression: subject, type of-                                            -- alternatives, list of alternatives-  deriving (Show,Generic,NFData)---- | Term reference-type TmName     = Name Term--- | Binding in a LetRec construct-type LetBinding = (Id, Embed Term)---- | Patterns in the LHS of a case-decomposition-data Pat-  = DataPat !(Embed DataCon) !(Rebind [TyVar] [Id])-  -- ^ Datatype pattern, '[TyVar]' bind existentially-quantified-  -- type-variables of a DataCon-  | LitPat  !(Embed Literal)-  -- ^ Literal pattern-  | DefaultPat-  -- ^ Default pattern-  deriving (Eq,Show,Generic,NFData,Alpha)--instance Eq Term where-  (==) = aeq--instance Ord Term where-  compare = acompare--instance Alpha Term where-  fvAny' c nfn (Var t n)  = fmap (Var t) $ fvAny' c nfn n-  fvAny' c nfn t          = fmap to . gfvAny c nfn $ from t--  aeq' c (Var _ n)   (Var _ m)   = aeq' c n m-  aeq' _ (Prim t1 _) (Prim t2 _) = t1 == t2-  aeq' c t1          t2          = gaeq c (from t1) (from t2)--  acompare' c (Var _ n)   (Var _ m)   = acompare' c n m-  acompare' _ (Prim t1 _) (Prim t2 _) = compare t1 t2-  acompare' c t1          t2          = gacompare c (from t1) (from t2)--instance Subst Type Pat-instance Subst Term Pat--instance Subst Term Term where-  isvar (Var _ x) = Just (SubstName x)-  isvar _         = Nothing--instance Subst Type Term
− src/CLaSH/Core/Term.hs-boot 
@@ -1,17 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# OPTIONS_GHC -fno-warn-missing-methods #-}--module CLaSH.Core.Term where--import GHC.Generics                     (Generic)-import Unbound.Generics.LocallyNameless (Name)--data Term-type TmName = Name Term--instance Generic Term
− src/CLaSH/Core/TyCon.hs 
@@ -1,151 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Type Constructors in CoreHW--}--{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module CLaSH.Core.TyCon-  ( TyCon (..)-  , TyConName-  , AlgTyConRhs (..)-  , mkKindTyCon-  , isTupleTyConLike-  , tyConDataCons-  )-where--#ifndef MIN_VERSION_unbound_generics-#define MIN_VERSION_unbound_generics(x,y,z)(1)-#endif---- External Import-import Control.DeepSeq-import GHC.Generics-import Unbound.Generics.LocallyNameless       (Alpha(..))-import Unbound.Generics.LocallyNameless.Extra ()-import Unbound.Generics.LocallyNameless.Name  (Name,name2String)-#if MIN_VERSION_unbound_generics(0,3,0)-import Data.Monoid                            (All (..))-import Unbound.Generics.LocallyNameless       (NthPatFind (..),-                                               NamePatFind (..))-#endif---- Internal Imports-import CLaSH.Core.DataCon                     (DataCon)-import {-# SOURCE #-} CLaSH.Core.Type         (Kind, TyName, Type)-import CLaSH.Util---- | Type Constructor-data TyCon-  -- | Algorithmic DataCons-  = AlgTyCon-  { tyConName   :: !TyConName   -- ^ Name of the TyCon-  , tyConKind   :: !Kind        -- ^ Kind of the TyCon-  , tyConArity  :: !Int         -- ^ Number of type arguments-  , algTcRhs    :: !AlgTyConRhs -- ^ DataCon definitions-  }-  -- | Function TyCons (e.g. type families)-  | FunTyCon-  { tyConName   :: !TyConName      -- ^ Name of the TyCon-  , tyConKind   :: !Kind           -- ^ Kind of the TyCon-  , tyConArity  :: !Int            -- ^ Number of type arguments-  , tyConSubst  :: [([Type],Type)] -- ^ List of: ([LHS match types], RHS type)-  }-  -- | Primitive TyCons-  | PrimTyCon-  { tyConName    :: !TyConName  -- ^ Name of the TyCon-  , tyConKind    :: !Kind       -- ^ Kind of the TyCon-  , tyConArity   :: !Int        -- ^ Number of type arguments-  }-  -- | To close the loop on the type hierarchy-  | SuperKindTyCon-  { tyConName :: !TyConName     -- ^ Name of the TyCon-  }-  deriving (Generic,NFData)--instance Show TyCon where-  show (AlgTyCon       {tyConName = n}) = "AlgTyCon: " ++ show n-  show (FunTyCon       {tyConName = n}) = "FunTyCon: " ++ show n-  show (PrimTyCon      {tyConName = n}) = "PrimTyCon: " ++ show n-  show (SuperKindTyCon {tyConName = n}) = "SuperKindTyCon: " ++ show n--instance Eq TyCon where-  (==) = (==) `on` tyConName--instance Ord TyCon where-  compare = compare `on` tyConName---- | TyCon reference-type TyConName = Name TyCon---- | The RHS of an Algebraic Datatype-data AlgTyConRhs-  = DataTyCon-  { dataCons :: [DataCon]        -- ^ The DataCons of a TyCon-  }-  | NewTyCon-  { dataCon   :: !DataCon        -- ^ The newtype DataCon-  , ntEtadRhs :: ([TyName],Type) -- ^ The argument type of the newtype-                                 -- DataCon in eta-reduced form, which is-                                 -- just the representation of the TyCon.-                                 -- The TyName's are the type-variables from-                                 -- the corresponding TyCon.-  }-  deriving (Show,Generic,NFData,Alpha)--instance Alpha TyCon where-  aeq' c tc1 tc2      = aeq' c (tyConName tc1) (tyConName tc2)--  fvAny' _ _ tc       = pure tc--  close _ _ tc        = tc-  open _ _ tc         = tc--  isPat _             = mempty--#if MIN_VERSION_unbound_generics(0,3,0)-  isTerm _            = All True-  nthPatFind _        = NthPatFind Left-  namePatFind _       = NamePatFind (const (Left 0))-#else-  isTerm _            = True-  nthPatFind _        = Left-  namePatFind _ _     = Left 0-#endif--  swaps' _ _ tc       = tc-  lfreshen' _ tc cont = cont tc mempty-  freshen' _ tc       = return (tc,mempty)--  acompare' c tc1 tc2 = acompare' c (tyConName tc1) (tyConName tc2)---- | Create a Kind out of a TyConName-mkKindTyCon :: TyConName-            -> Kind-            -> TyCon-mkKindTyCon name kind-  = PrimTyCon name kind 0---- | Does the TyCon look like a tuple TyCon-isTupleTyConLike :: TyConName -> Bool-isTupleTyConLike nm = tupleName (name2String nm)-  where-    tupleName nm'-      | '(' <- head nm'-      , ')' <- last nm'-      = all (== ',') (init $ tail nm')-    tupleName _ = False---- | Get the DataCons belonging to a TyCon-tyConDataCons :: TyCon -> [DataCon]-tyConDataCons (AlgTyCon {algTcRhs = DataTyCon { dataCons = cons}}) = cons-tyConDataCons (AlgTyCon {algTcRhs = NewTyCon  { dataCon  = con }}) = [con]-tyConDataCons _                                                    = []
− src/CLaSH/Core/TyCon.hs-boot 
@@ -1,12 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--module CLaSH.Core.TyCon where--import Unbound.Generics.LocallyNameless (Name)--data TyCon-type TyConName = Name TyCon
− src/CLaSH/Core/Type.hs 
@@ -1,469 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Types in CoreHW--}--{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MagicHash             #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE ViewPatterns          #-}--module CLaSH.Core.Type-  ( Type (..)-  , TypeView (..)-  , ConstTy (..)-  , LitTy (..)-  , Kind-  , KindOrType-  , KiName-  , TyName-  , TyVar-  , tyView-  , coreView-  , typeKind-  , mkTyConTy-  , mkFunTy-  , mkTyConApp-  , splitFunTy-  , splitFunTys-  , splitFunForallTy-  , splitCoreFunForallTy-  , splitTyConAppM-  , isPolyFunTy-  , isPolyFunCoreTy-  , isPolyTy-  , isFunTy-  , applyFunTy-  , applyTy-  , findFunSubst-  , reduceTypeFamily-  , undefinedTy-  )-where---- External import-import           Control.DeepSeq                         as DS-import           Data.HashMap.Strict                     (HashMap)-import qualified Data.HashMap.Strict                     as HashMap-import           Data.Maybe                              (isJust, mapMaybe)-import           GHC.Base                                (isTrue#,(==#))-import           GHC.Generics                            (Generic(..))-import           GHC.Integer                             (smallInteger)-import           GHC.Integer.Logarithms                  (integerLogBase#)-import           Unbound.Generics.LocallyNameless        (Alpha(..),Bind,Fresh,-                                                          Subst(..),SubstName(..),-                                                          acompare,aeq,bind,embed,-                                                          gacompare,gaeq,gfvAny,-                                                          runFreshM,unbind)-import           Unbound.Generics.LocallyNameless.Name   (Name (..),name2String,-                                                          string2Name)-import           Unbound.Generics.LocallyNameless.Extra  ()---- Local imports-import           CLaSH.Core.DataCon-import           CLaSH.Core.Subst-import {-# SOURCE #-} CLaSH.Core.Term-import           CLaSH.Core.TyCon-import           CLaSH.Core.TysPrim-import           CLaSH.Core.Var-import           CLaSH.Util---- | Types in CoreHW: function and polymorphic types-data Type-  = VarTy    !Kind !TyName      -- ^ Type variable-  | ConstTy  !ConstTy           -- ^ Type constant-  | ForAllTy !(Bind TyVar Type) -- ^ Polymorphic Type-  | AppTy    !Type !Type        -- ^ Type Application-  | LitTy    !LitTy             -- ^ Type literal-  deriving (Show,Generic,NFData)---- | An easier view on types-data TypeView-  = FunTy    !Type  !Type      -- ^ Function type-  | TyConApp !TyConName [Type] -- ^ Applied TyCon-  | OtherType !Type            -- ^ Neither of the above-  deriving Show---- | Type Constants-data ConstTy-  = TyCon !TyConName -- ^ TyCon type-  | Arrow            -- ^ Function type-  deriving (Show,Generic,NFData,Alpha)---- | Literal Types-data LitTy-  = NumTy !Integer-  | SymTy !String-  deriving (Show,Generic,NFData,Alpha)---- | The level above types-type Kind       = Type--- | Either a Kind or a Type-type KindOrType = Type---- | Reference to a Type-type TyName     = Name Type--- | Reference to a Kind-type KiName     = Name Kind--instance Alpha Type where-  fvAny' c nfn (VarTy t n) = fmap (VarTy t) $ fvAny' c nfn n-  fvAny' c nfn t           = fmap to . gfvAny c nfn $ from t--  aeq' c (VarTy _ n) (VarTy _ m) = aeq' c n m-  aeq' c t1          t2          = gaeq c (from t1) (from t2)--  acompare' c (VarTy _ n) (VarTy _ m) = acompare' c n m-  acompare' c t1          t2          = gacompare c (from t1) (from t2)--instance Subst a LitTy where-  subst _ _ lt = lt-  substs _ lt  = lt--instance Subst a ConstTy where-  subst _ _ ct = ct-  substs _ ct  = ct--instance Subst Term Type-instance Subst Type Type where-  isvar (VarTy _ v) = Just (SubstName v)-  isvar _           = Nothing--instance Eq Type where-  (==) = aeq--instance Ord Type where-  compare = acompare---- | An easier view on types-tyView :: Type -> TypeView-tyView ty@(AppTy _ _) = case splitTyAppM ty of-  Just (ConstTy Arrow, [ty1,ty2]) -> FunTy ty1 ty2-  Just (ConstTy (TyCon tc), args) -> TyConApp tc args-  _ -> OtherType ty-tyView (ConstTy (TyCon tc)) = TyConApp tc []-tyView t = OtherType t---- | A view on types in which newtypes are transparent, the Signal type is--- transparent, and type functions are evaluated to WHNF (when possible).------ Only strips away one "layer".-coreView :: HashMap TyConName TyCon -> Type -> Maybe Type-coreView tcMap ty = case tyView ty of-  TyConApp tcNm args-    | name2String tcNm == "CLaSH.Signal.Internal.Signal'"-    , [_,elTy] <- args-    -> Just elTy-    | otherwise-    -> case tcMap HashMap.! tcNm of-         AlgTyCon {algTcRhs = (NewTyCon _ nt)}-           -> Just (newTyConInstRhs nt args)-         _ -> reduceTypeFamily tcMap ty-  _ -> Nothing---- | Instantiate and Apply the RHS/Original of a NewType with the given--- list of argument types-newTyConInstRhs :: ([TyName],Type) -> [Type] -> Type-newTyConInstRhs (tvs,ty) tys = foldl AppTy (substTys (zip tvs tys1) ty) tys2-  where-    (tys1, tys2) = splitAtList tvs tys---- | Make a function type of an argument and result type-mkFunTy :: Type -> Type -> Type-mkFunTy t1 = AppTy (AppTy (ConstTy Arrow) t1)---- | Make a TyCon Application out of a TyCon and a list of argument types-mkTyConApp :: TyConName -> [Type] -> Type-mkTyConApp tc = foldl AppTy (ConstTy $ TyCon tc)---- | Make a Type out of a TyCon-mkTyConTy :: TyConName -> Type-mkTyConTy ty = ConstTy $ TyCon ty---- | Split a TyCon Application in a TyCon and its arguments-splitTyConAppM :: Type-               -> Maybe (TyConName,[Type])-splitTyConAppM (tyView -> TyConApp tc args) = Just (tc,args)-splitTyConAppM _                            = Nothing---- | Is a type a Superkind?-isSuperKind :: HashMap TyConName TyCon -> Type -> Bool-isSuperKind tcMap (ConstTy (TyCon ((tcMap HashMap.!) -> SuperKindTyCon {}))) = True-isSuperKind _ _ = False---- | Determine the kind of a type-typeKind :: HashMap TyConName TyCon -> Type -> Kind-typeKind _ (VarTy k _)          = k-typeKind m (ForAllTy b)         = let (_,ty) = runFreshM $ unbind b-                                  in typeKind m ty-typeKind _ (LitTy (NumTy _))    = typeNatKind-typeKind _ (LitTy (SymTy _))    = typeSymbolKind-typeKind m (tyView -> FunTy _arg res)-  | isSuperKind m k = k-  | otherwise       = liftedTypeKind-  where k = typeKind m res--typeKind m (tyView -> TyConApp tc args) = foldl kindFunResult (tyConKind (m HashMap.! tc)) args--typeKind m (AppTy fun arg)      = kindFunResult (typeKind m fun) arg-typeKind _ (ConstTy ct)         = error $ $(curLoc) ++ "typeKind: naked ConstTy: " ++ show ct--kindFunResult :: Kind -> KindOrType -> Kind-kindFunResult (tyView -> FunTy _ res) _ = res--kindFunResult (ForAllTy b) arg =-  let (kv,ki) = runFreshM . unbind $ b-  in  substKindWith (zip [varName kv] [arg]) ki--kindFunResult k tys =-  error $ $(curLoc) ++ "kindFunResult: " ++ show (k,tys)---- | Is a type polymorphic?-isPolyTy :: Type -> Bool-isPolyTy (ForAllTy _)            = True-isPolyTy (tyView -> FunTy _ res) = isPolyTy res-isPolyTy _                       = False---- | Split a function type in an argument and result type-splitFunTy :: HashMap TyConName TyCon-           -> Type-           -> Maybe (Type, Type)-splitFunTy m (coreView m -> Just ty)   = splitFunTy m ty-splitFunTy _ (tyView -> FunTy arg res) = Just (arg,res)-splitFunTy _ _ = Nothing--splitFunTys :: HashMap TyConName TyCon-            -> Type-            -> ([Type],Type)-splitFunTys m ty = go [] ty ty-  where-    go args orig_ty (coreView m -> Just ty')  = go args orig_ty ty'-    go args _       (tyView -> FunTy arg res) = go (arg:args) res res-    go args orig_ty _                         = (reverse args, orig_ty)---- | Split a poly-function type in a: list of type-binders and argument types,--- and the result type-splitFunForallTy :: Type-                 -> ([Either TyVar Type],Type)-splitFunForallTy = go []-  where-    go args (ForAllTy b) = let (tv,ty) = runFreshM $ unbind b-                           in  go (Left tv:args) ty-    go args (tyView -> FunTy arg res) = go (Right arg:args) res-    go args ty                        = (reverse args,ty)---- | Split a poly-function type in a: list of type-binders and argument types,--- and the result type. Looks through 'Signal' and type functions.-splitCoreFunForallTy :: HashMap TyConName TyCon-                     -> Type-                     -> ([Either TyVar Type], Type)-splitCoreFunForallTy tcm ty = go [] ty ty-  where-    go args orig_ty (coreView tcm -> Just ty') = go args orig_ty ty'-    go args _       (ForAllTy b)               = let (tv,res) = runFreshM $ unbind b-                                                 in  go (Left tv:args) res res-    go args _       (tyView -> FunTy arg res)  = go (Right arg:args) res res-    go args orig_ty _                          = (reverse args,orig_ty)---- | Is a type a polymorphic or function type?-isPolyFunTy :: Type-            -> Bool-isPolyFunTy = not . null . fst . splitFunForallTy---- | Is a type a polymorphic or function type under 'coreView'?-isPolyFunCoreTy :: HashMap TyConName TyCon-                -> Type-                -> Bool-isPolyFunCoreTy m (coreView m -> Just ty) = isPolyFunCoreTy m ty-isPolyFunCoreTy _ ty = case tyView ty of-  FunTy _ _ -> True-  OtherType (ForAllTy _) -> True-  _ -> False---- | Is a type a function type?-isFunTy :: HashMap TyConName TyCon-        -> Type-        -> Bool-isFunTy m = isJust . splitFunTy m---- | Apply a function type to an argument type and get the result type-applyFunTy :: HashMap TyConName TyCon-           -> Type-           -> Type-           -> Type-applyFunTy m (coreView m -> Just ty)   arg = applyFunTy m ty arg-applyFunTy _ (tyView -> FunTy _ resTy) _   = resTy-applyFunTy _ _ _ = error $ $(curLoc) ++ "Report as bug: not a FunTy"---- | Substitute the type variable of a type ('ForAllTy') with another type-applyTy :: Fresh m-        => HashMap TyConName TyCon-        -> Type-        -> KindOrType-        -> m Type-applyTy tcm (coreView tcm -> Just ty) arg = applyTy tcm ty arg-applyTy _   (ForAllTy b) arg = do-  (tv,ty) <- unbind b-  return (substTy (varName tv) arg ty)-applyTy _ ty arg = error ($(curLoc) ++ "applyTy: not a forall type:\n" ++ show ty ++ "\nArg:\n" ++ show arg)---- | Split a type application in the applied type and the argument types-splitTyAppM :: Type-            -> Maybe (Type, [Type])-splitTyAppM = fmap (second reverse) . go []-  where-    go args (AppTy ty1 ty2) =-      case go args ty1 of-        Nothing             -> Just (ty1,ty2:args)-        Just (ty1',ty1args) -> Just (ty1',ty2:ty1args )-    go _ _ = Nothing---- Type function substitutions---- Given a set of type functions, and list of argument types, get the first--- type function that matches, and return its substituted RHS type.-findFunSubst :: HashMap TyConName TyCon -> [([Type],Type)] -> [Type] -> Maybe Type-findFunSubst _   [] _ = Nothing-findFunSubst tcm (tcSubst:rest) args = case funSubsts tcm tcSubst args of-  Just ty -> Just ty-  Nothing -> findFunSubst tcm rest args---- Given a ([LHS match type], RHS type) representing a type function, and--- a set of applied types. Match LHS with args, and when successful, return--- a substituted RHS-funSubsts :: HashMap TyConName TyCon -> ([Type],Type) -> [Type] -> Maybe Type-funSubsts tcm (tcSubstLhs,tcSubstRhs) args = do-  tySubts <- foldl (funSubst tcm) (Just []) (zip tcSubstLhs args)-  let tyRhs = substTys tySubts tcSubstRhs-  return tyRhs---- Given a LHS matching type, and a RHS to-match type, check if LHS and RHS--- are a match. If they do match, and the LHS is a variable, return a--- substitution-funSubst :: HashMap TyConName TyCon -> Maybe [(TyName,Type)] -> (Type,Type) -> Maybe [(TyName,Type)]-funSubst _   Nothing  = const Nothing-funSubst tcm (Just s) = uncurry go-  where-    go (VarTy _ nmF) ty = case lookup nmF s of-      Nothing -> Just ((nmF,ty):s)-      -- Given, for example, the type family definition:-      ---      -- > type family Max x y where-      -- >   Max 0 b = b-      -- >   Max a 0 = a-      -- >   Max n n = n-      -- >   Max a b = If (a <=? b) b a-      ---      -- Then `Max 4 8` matches against the 4th clause.-      ---      -- So this is why, whenever we match against a type variable, we first-      -- check if there is already a substitution defined for this type variable,-      -- and if so, the applied type, and the type in the substitution should match.-      Just ty' | ty' == ty -> Just s-      _ -> Nothing-    go ty1 (reduceTypeFamily tcm -> Just ty2) = go ty1 ty2 -- See [Note: lazy type families]-    go ty1@(LitTy _) ty2 = if ty1 == ty2 then Just s else Nothing-    go (tyView -> TyConApp tc argTys) (tyView -> TyConApp tc' argTys')-      | tc == tc'-      = foldl (funSubst tcm) (Just s) (zip argTys argTys')-    go _ _ = Nothing--{- [Note: lazy type families]--I don't know whether type families are evaluated strictly or lazily, but this-being Haskell, I assume type families are evaluated lazily.--CLaSH hence follows the Haskell way, and only evaluates type family arguments-to (WH)NF when the formal parameter is _not_ a type variable.--}--reduceTypeFamily :: HashMap TyConName TyCon -> Type -> Maybe Type-reduceTypeFamily tcm (tyView -> TyConApp tc tys)-  | name2String tc == "GHC.TypeLits.+"-  , [i1, i2] <- mapMaybe (litView tcm) tys-  = Just (LitTy (NumTy (i1 + i2)))--  | name2String tc == "GHC.TypeLits.*"-  , [i1, i2] <- mapMaybe (litView tcm) tys-  = Just (LitTy (NumTy (i1 * i2)))--  | name2String tc == "GHC.TypeLits.^"-  , [i1, i2] <- mapMaybe (litView tcm) tys-  = Just (LitTy (NumTy (i1 ^ i2)))--  | name2String tc == "GHC.TypeLits.-"-  , [i1, i2] <- mapMaybe (litView tcm) tys-  = Just (LitTy (NumTy (i1 - i2)))--  | name2String tc == "GHC.TypeLits.<=?"-  , [i1, i2] <- mapMaybe (litView tcm) tys-  , Just (FunTyCon {tyConKind = tck}) <- HashMap.lookup tc tcm-  , (_,tyView -> TyConApp boolTcNm []) <- splitFunTys tcm tck-  , Just boolTc <- HashMap.lookup boolTcNm tcm-  = let [falseTc,trueTc] = map ((\(Fn s i) -> Fn s i) . dcName) (tyConDataCons boolTc)-    in  if i1 <= i2 then Just (mkTyConApp trueTc [] )-                    else Just (mkTyConApp falseTc [])--  | name2String tc == "GHC.TypeLits.Extra.FLog"-  , [i1, i2] <- mapMaybe (litView tcm) tys-  , i1 > 1-  , i2 > 0-  = Just (LitTy (NumTy (smallInteger (integerLogBase# i1 i2))))--  | name2String tc == "GHC.TypeLits.Extra.CLog"-  , [i1, i2] <- mapMaybe (litView tcm) tys-  , Just k <- clogBase i1 i2-  = Just (LitTy (NumTy (toInteger k)))--  | name2String tc == "GHC.TypeLits.Extra.Log"-  , [i1, i2] <- mapMaybe (litView tcm) tys-  , i1 > 1-  , i2 > 0-  = if i2 == 1-       then Just (LitTy (NumTy 0))-       else let z1 = integerLogBase# i1 i2-                z2 = integerLogBase# i1 (i2-1)-            in  if isTrue# (z1 ==# z2)-                   then Nothing-                   else Just (LitTy (NumTy (smallInteger z1)))---  | name2String tc == "GHC.TypeLits.Extra.GCD"-  , [i1, i2] <- mapMaybe (litView tcm) tys-  = Just (LitTy (NumTy (i1 `gcd` i2)))--  | name2String tc == "GHC.TypeLits.Extra.LCM"-  , [i1, i2] <- mapMaybe (litView tcm) tys-  = Just (LitTy (NumTy (i1 `lcm` i2)))--  | name2String tc == "GHC.TypeLits.Extra.Div"-  , [i1, i2] <- mapMaybe (litView tcm) tys-  , i2 > 0-  = Just (LitTy (NumTy (i1 `div` i2)))--  | name2String tc == "GHC.TypeLits.Extra.Mod"-  , [i1, i2] <- mapMaybe (litView tcm) tys-  , i2 > 0-  = Just (LitTy (NumTy (i1 `mod` i2)))--  | Just (FunTyCon {tyConSubst = tcSubst}) <- HashMap.lookup tc tcm-  = findFunSubst tcm tcSubst tys--reduceTypeFamily _ _ = Nothing--litView :: HashMap TyConName TyCon -> Type -> Maybe Integer-litView _ (LitTy (NumTy i))                = Just i-litView m (reduceTypeFamily m -> Just ty') = litView m ty'-litView _ _ = Nothing---- | The type of GHC.Err.undefined :: forall a . a-undefinedTy :: Type-undefinedTy =-  let aNm = string2Name "a"-  in  ForAllTy (bind (TyVar aNm (embed liftedTypeKind)) (VarTy liftedTypeKind aNm))
− src/CLaSH/Core/Type.hs-boot 
@@ -1,34 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE MultiParamTypeClasses #-}--{-# OPTIONS_GHC -fno-warn-missing-methods #-}--module CLaSH.Core.Type where--import Control.DeepSeq                  (NFData)-import GHC.Generics                     (Generic)-import Unbound.Generics.LocallyNameless (Alpha,Name,Subst)--import {-# SOURCE #-} CLaSH.Core.Term-import {-# SOURCE #-} CLaSH.Core.TyCon--data Type--type Kind   = Type-type TyName = Name Type-type KiName = Name Kind--instance Eq       Type-instance Generic  Type-instance Show     Type-instance Alpha    Type-instance Subst    Type Type-instance Subst    Term Type-instance NFData   Type--mkTyConTy :: TyConName -> Type
− src/CLaSH/Core/TysPrim.hs 
@@ -1,116 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Builtin Type and Kind definitions--}--module CLaSH.Core.TysPrim-  ( liftedTypeKind-  , typeNatKind-  , typeSymbolKind-  , intPrimTy-  , integerPrimTy-  , charPrimTy-  , stringPrimTy-  , voidPrimTy-  , wordPrimTy-  , int64PrimTy-  , word64PrimTy-  , floatPrimTy-  , doublePrimTy-  , tysPrimMap-  )-where--import           Data.HashMap.Strict              (HashMap)-import qualified Data.HashMap.Strict              as HashMap-import           Unbound.Generics.LocallyNameless (string2Name)--import           CLaSH.Core.TyCon-import {-# SOURCE #-} CLaSH.Core.Type---- | Builtin Name-tySuperKindTyConName, liftedTypeKindTyConName, typeNatKindTyConName, typeSymbolKindTyConName :: TyConName-tySuperKindTyConName      = string2Name "BOX"-liftedTypeKindTyConName   = string2Name "*"-typeNatKindTyConName      = string2Name "Nat"-typeSymbolKindTyConName   = string2Name "Symbol"---- | Builtin Kind-liftedTypeKindtc, tySuperKindtc, typeNatKindtc, typeSymbolKindtc :: TyCon-tySuperKindtc    = SuperKindTyCon tySuperKindTyConName-liftedTypeKindtc = mkKindTyCon liftedTypeKindTyConName tySuperKind-typeNatKindtc    = mkKindTyCon typeNatKindTyConName tySuperKind-typeSymbolKindtc = mkKindTyCon typeSymbolKindTyConName tySuperKind--liftedTypeKind, tySuperKind, typeNatKind, typeSymbolKind :: Type-tySuperKind    = mkTyConTy tySuperKindTyConName-liftedTypeKind = mkTyConTy liftedTypeKindTyConName-typeNatKind    = mkTyConTy typeNatKindTyConName-typeSymbolKind = mkTyConTy typeSymbolKindTyConName---intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName,-  voidPrimTyConName, wordPrimTyConName, int64PrimTyConName,-  word64PrimTyConName, floatPrimTyConName, doublePrimTyConName :: TyConName-intPrimTyConName     = string2Name "GHC.Prim.Int#"-integerPrimTyConName = string2Name "GHC.Integer.Type.Integer"-stringPrimTyConName  = string2Name "String"-charPrimTyConName    = string2Name "GHC.Prim.Char#"-voidPrimTyConName    = string2Name "VOID"-wordPrimTyConName    = string2Name "GHC.Prim.Word#"-int64PrimTyConName   = string2Name "GHC.Prim.Int64#"-word64PrimTyConName  = string2Name "GHC.Prim.Word64#"-floatPrimTyConName   = string2Name "GHC.Prim.Float#"-doublePrimTyConName  = string2Name "GHC.Prim.Double#"--liftedPrimTC :: TyConName-             -> TyCon-liftedPrimTC name = PrimTyCon name liftedTypeKind 0---- | Builtin Type-intPrimTc, integerPrimTc, charPrimTc, stringPrimTc, voidPrimTc, wordPrimTc,-  int64PrimTc, word64PrimTc, floatPrimTc, doublePrimTc :: TyCon-intPrimTc     = liftedPrimTC intPrimTyConName-integerPrimTc = liftedPrimTC integerPrimTyConName-charPrimTc    = liftedPrimTC charPrimTyConName-stringPrimTc  = liftedPrimTC stringPrimTyConName-voidPrimTc    = liftedPrimTC voidPrimTyConName-wordPrimTc    = liftedPrimTC wordPrimTyConName-int64PrimTc   = liftedPrimTC int64PrimTyConName-word64PrimTc  = liftedPrimTC word64PrimTyConName-floatPrimTc   = liftedPrimTC floatPrimTyConName-doublePrimTc  = liftedPrimTC doublePrimTyConName--intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, voidPrimTy, wordPrimTy,-  int64PrimTy, word64PrimTy, floatPrimTy, doublePrimTy :: Type-intPrimTy     = mkTyConTy intPrimTyConName-integerPrimTy = mkTyConTy integerPrimTyConName-charPrimTy    = mkTyConTy charPrimTyConName-stringPrimTy  = mkTyConTy stringPrimTyConName-voidPrimTy    = mkTyConTy voidPrimTyConName-wordPrimTy    = mkTyConTy wordPrimTyConName-int64PrimTy   = mkTyConTy int64PrimTyConName-word64PrimTy  = mkTyConTy word64PrimTyConName-floatPrimTy   = mkTyConTy floatPrimTyConName-doublePrimTy  = mkTyConTy doublePrimTyConName--tysPrimMap :: HashMap TyConName TyCon-tysPrimMap = HashMap.fromList-  [ (tySuperKindTyConName,tySuperKindtc)-  , (liftedTypeKindTyConName,liftedTypeKindtc)-  , (typeNatKindTyConName,typeNatKindtc)-  , (typeSymbolKindTyConName,typeSymbolKindtc)-  , (intPrimTyConName,intPrimTc)-  , (integerPrimTyConName,integerPrimTc)-  , (charPrimTyConName,charPrimTc)-  , (stringPrimTyConName,stringPrimTc)-  , (voidPrimTyConName,voidPrimTc)-  , (wordPrimTyConName,wordPrimTc)-  , (int64PrimTyConName,int64PrimTc)-  , (word64PrimTyConName,word64PrimTc)-  , (floatPrimTyConName,floatPrimTc)-  , (doublePrimTyConName,doublePrimTc)-  ]
− src/CLaSH/Core/Util.hs 
@@ -1,447 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Smart constructor and destructor functions for CoreHW--}--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE ViewPatterns      #-}--module CLaSH.Core.Util where--import Control.Monad.Trans.Except              (Except, throwE)-import qualified Data.HashMap.Strict           as HMS-import qualified Data.HashMap.Lazy             as HashMap-import Data.HashMap.Lazy                       (HashMap)-import qualified Data.HashSet                  as HashSet-import Data.Maybe                              (fromJust, mapMaybe)-import Unbound.Generics.LocallyNameless        (Fresh, bind, embed, rebind,-                                                string2Name, unbind, unembed,-                                                unrebind, unrec)-import Unbound.Generics.LocallyNameless.Name   (name2String)-import Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind)--import CLaSH.Core.DataCon                      (DataCon, dcType, dataConInstArgTys)-import CLaSH.Core.Literal                      (literalType)-import CLaSH.Core.Pretty                       (showDoc)-import CLaSH.Core.Term                         (LetBinding, Pat (..), Term (..),-                                                TmName)-import CLaSH.Core.Type                         (Kind, LitTy (..), TyName,-                                                Type (..), TypeView (..), applyTy,-                                                coreView, isFunTy, isPolyFunCoreTy,-                                                mkFunTy, splitFunTy, tyView)-import CLaSH.Core.TyCon                        (TyCon (..), TyConName,-                                                tyConDataCons)-import CLaSH.Core.TysPrim                      (typeNatKind)-import CLaSH.Core.Var                          (Id, TyVar, Var (..), varType)-import CLaSH.Util---- | Type environment/context-type Gamma = HashMap TmName Type--- | Kind environment/context-type Delta = HashMap TyName Kind---- | Determine the type of a term-termType :: Fresh m-         => HashMap TyConName TyCon-         -> Term-         -> m Type-termType m e = case e of-  Var t _        -> return t-  Data dc        -> return $ dcType dc-  Literal l      -> return $ literalType l-  Prim _ t       -> return t-  Lam b          -> do (v,e') <- unbind b-                       mkFunTy (unembed $ varType v) <$> termType m e'-  TyLam b        -> do (tv,e') <- unbind b-                       ForAllTy <$> bind tv <$> termType m e'-  App _ _        -> case collectArgs e of-                      (fun, args) -> termType m fun >>=-                                     (flip (applyTypeToArgs m) args)-  TyApp e' ty    -> termType m e' >>= (\f -> applyTy m f ty)-  Letrec b       -> do (_,e') <- unbind b-                       termType m e'-  Case _ ty _    -> return ty---- | Split a (Type)Application in the applied term and it arguments-collectArgs :: Term-            -> (Term, [Either Term Type])-collectArgs = go []-  where-    go args (App e1 e2) = go (Left e2:args) e1-    go args (TyApp e t) = go (Right t:args) e-    go args e           = (e, args)---- | Split a (Type)Abstraction in the bound variables and the abstracted term-collectBndrs :: Fresh m-             => Term-             -> m ([Either Id TyVar], Term)-collectBndrs = go []-  where-    go bs (Lam b) = do-      (v,e') <- unbind b-      go (Left v:bs) e'-    go bs (TyLam b) = do-      (tv,e') <- unbind b-      go (Right tv:bs) e'-    go bs e' = return (reverse bs,e')---- | Get the result type of a polymorphic function given a list of arguments-applyTypeToArgs :: Fresh m-                => HashMap TyConName TyCon-                -> Type-                -> [Either Term Type]-                -> m Type-applyTypeToArgs _ opTy []              = return opTy-applyTypeToArgs m opTy (Right ty:args) = applyTy m opTy ty >>=-                                          (flip (applyTypeToArgs m) args)-applyTypeToArgs m opTy (Left e:args)   = case splitFunTy m opTy of-  Just (_,resTy) -> applyTypeToArgs m resTy args-  Nothing        -> error $-                    concat [ $(curLoc)-                           , "applyTypeToArgs splitFunTy: not a funTy:\n"-                           , "opTy: "-                           , showDoc opTy-                           , "\nTerm: "-                           , showDoc e-                           , "\nOtherArgs: "-                           , unlines (map (either showDoc showDoc) args)-                           ]---- | Get the list of term-binders out of a DataType pattern-patIds :: Pat -> [Id]-patIds (DataPat _ ids) = snd $ unrebind ids-patIds _               = []---- | Make a type variable-mkTyVar :: Kind-        -> TyName-        -> TyVar-mkTyVar tyKind tyName = TyVar tyName (embed tyKind)---- | Make a term variable-mkId :: Type-     -> TmName-     -> Id-mkId tmType tmName = Id tmName (embed tmType)---- | Abstract a term over a list of term and type variables-mkAbstraction :: Term-              -> [Either Id TyVar]-              -> Term-mkAbstraction = foldr (either (Lam `dot` bind) (TyLam `dot` bind))---- | Abstract a term over a list of term variables-mkTyLams :: Term-         -> [TyVar]-         -> Term-mkTyLams tm = mkAbstraction tm . map Right---- | Abstract a term over a list of type variables-mkLams :: Term-       -> [Id]-       -> Term-mkLams tm = mkAbstraction tm . map Left---- | Apply a list of types and terms to a term-mkApps :: Term-       -> [Either Term Type]-       -> Term-mkApps = foldl (\e a -> either (App e) (TyApp e) a)---- | Apply a list of terms to a term-mkTmApps :: Term-         -> [Term]-         -> Term-mkTmApps = foldl App---- | Apply a list of types to a term-mkTyApps :: Term-         -> [Type]-         -> Term-mkTyApps = foldl TyApp---- | Does a term have a function type?-isFun :: Fresh m-      => HashMap TyConName TyCon-      -> Term-      -> m Bool-isFun m t = fmap (isFunTy m) $ (termType m) t---- | Does a term have a function or polymorphic type?-isPolyFun :: Fresh m-          => HashMap TyConName TyCon-          -> Term-          -> m Bool-isPolyFun m t = isPolyFunCoreTy m <$> termType m t---- | Is a term a term-abstraction?-isLam :: Term-      -> Bool-isLam (Lam _) = True-isLam _       = False---- | Is a term a recursive let-binding?-isLet :: Term-      -> Bool-isLet (Letrec _) = True-isLet _          = False---- | Is a term a variable reference?-isVar :: Term-      -> Bool-isVar (Var _ _) = True-isVar _         = False---- | Is a term a datatype constructor?-isCon :: Term-      -> Bool-isCon (Data _) = True-isCon _        = False---- | Is a term a primitive?-isPrim :: Term-       -> Bool-isPrim (Prim _ _) = True-isPrim _          = False---- | Make variable reference out of term variable-idToVar :: Id-        -> Term-idToVar (Id nm tyE) = Var (unembed tyE) nm-idToVar tv          = error $ $(curLoc) ++ "idToVar: tyVar: " ++ showDoc tv---- | Make a term variable out of a variable reference-varToId :: Term-        -> Id-varToId (Var ty nm) = Id nm (embed ty)-varToId e           = error $ $(curLoc) ++ "varToId: not a var: " ++ showDoc e--termSize :: Term-         -> Int-termSize (Var _ _)   = 1-termSize (Data _)    = 1-termSize (Literal _) = 1-termSize (Prim _ _)  = 1-termSize (Lam b)     = let (_,e) = unsafeUnbind b-                       in  termSize e + 1-termSize (TyLam b)   = let (_,e) = unsafeUnbind b-                       in  termSize e-termSize (App e1 e2) = termSize e1 + termSize e2-termSize (TyApp e _) = termSize e-termSize (Letrec b)  = let (bndrsR,body) = unsafeUnbind b-                           bndrSzs       = map (termSize . unembed . snd) (unrec bndrsR)-                           bodySz        = termSize body-                       in sum (bodySz:bndrSzs)-termSize (Case subj _ alts) = let subjSz = termSize subj-                                  altSzs = map (termSize . snd . unsafeUnbind) alts-                              in  sum (subjSz:altSzs)---- | Create a vector of supplied elements-mkVec :: DataCon -- ^ The Nil constructor-      -> DataCon -- ^ The Cons (:>) constructor-      -> Type    -- ^ Element type-      -> Integer -- ^ Length of the vector-      -> [Term]  -- ^ Elements to put in the vector-      -> Term-mkVec nilCon consCon resTy = go-  where-    go _ [] = mkApps (Data nilCon) [Right (LitTy (NumTy 0))-                                   ,Right resTy-                                   ,Left  (Prim "_CO_" nilCoTy)-                                   ]--    go n (x:xs) = mkApps (Data consCon) [Right (LitTy (NumTy n))-                                        ,Right resTy-                                        ,Right (LitTy (NumTy (n-1)))-                                        ,Left (Prim "_CO_" (consCoTy n))-                                        ,Left x-                                        ,Left (go (n-1) xs)]--    nilCoTy    = head (fromJust $! dataConInstArgTys nilCon  [(LitTy (NumTy 0))-                                                             ,resTy])-    consCoTy n = head (fromJust $! dataConInstArgTys consCon-                                                     [(LitTy (NumTy n))-                                                     ,resTy-                                                     ,(LitTy (NumTy (n-1)))])---- | Append elements to the supplied vector-appendToVec :: DataCon -- ^ The Cons (:>) constructor-            -> Type    -- ^ Element type-            -> Term    -- ^ The vector to append the elements to-            -> Integer -- ^ Length of the vector-            -> [Term]  -- ^ Elements to append-            -> Term-appendToVec consCon resTy vec = go-  where-    go _ []     = vec-    go n (x:xs) = mkApps (Data consCon) [Right (LitTy (NumTy n))-                                        ,Right resTy-                                        ,Right (LitTy (NumTy (n-1)))-                                        ,Left (Prim "_CO_" (consCoTy n))-                                        ,Left x-                                        ,Left (go (n-1) xs)]--    consCoTy n = head (fromJust $! dataConInstArgTys consCon-                                                   [(LitTy (NumTy n))-                                                   ,resTy-                                                   ,(LitTy (NumTy (n-1)))])---- | Create let-bindings with case-statements that select elements out of a--- vector. Returns both the variables to which element-selections are bound--- and the let-bindings-extractElems :: DataCon -- ^ The Cons (:>) constructor-             -> Type    -- ^ The element type-             -> Char    -- ^ Char to append to the bound variable names-             -> Integer -- ^ Length of the vector-             -> Term    -- ^ The vector-             -> [(Term,[LetBinding])]-extractElems consCon resTy s maxN = go maxN-  where-    go :: Integer -> Term -> [(Term,[LetBinding])]-    go 0 _ = []-    go n e = (elVar-             ,[(Id elBNm (embed resTy) ,embed lhs)-              ,(Id restBNm (embed restTy),embed rhs)-              ]-             ) :-             go (n-1) (Var restTy restBNm)--      where-        elBNm     = string2Name ("el" ++ s:show (maxN-n))-        restBNm   = string2Name ("rest" ++ s:show (maxN-n))-        elVar     = Var resTy elBNm-        pat       = DataPat (embed consCon) (rebind [mTV] [co,el,rest])-        elPatNm   = string2Name "el"-        restPatNm = string2Name "rest"-        lhs       = Case e resTy  [bind pat (Var resTy  elPatNm)]-        rhs       = Case e restTy [bind pat (Var restTy restPatNm)]--        mName = string2Name "m"-        mTV   = TyVar mName (embed typeNatKind)-        tys   = [(LitTy (NumTy n)),resTy,(LitTy (NumTy (n-1)))]-        (Just idTys) = dataConInstArgTys consCon tys-        [co,el,rest] = zipWith Id [string2Name "_co_",elPatNm, restPatNm]-                                  (map embed idTys)-        restTy = last (fromJust (dataConInstArgTys consCon tys))----- | Create let-bindings with case-statements that select elements out of a--- tree. Returns both the variables to which element-selections are bound--- and the let-bindings-extractTElems :: DataCon -- ^ The 'LR' constructor-              -> DataCon -- ^ The 'BR' constructor-              -> Type    -- ^ The element type-              -> Char    -- ^ Char to append to the bound variable names-              -> Integer -- ^ Depth of the tree-              -> Term    -- ^ The tree-              -> ([Term],[LetBinding])-extractTElems lrCon brCon resTy s maxN = go maxN [0..(2^(maxN+1))-2] [0..(2^maxN - 1)]-  where-    go :: Integer -> [Int] -> [Int] -> Term -> ([Term],[LetBinding])-    go 0 _ ks e = ([elVar],[(Id elBNm (embed resTy), embed lhs)])-      where-        elBNm   = string2Name ("el" ++ s:show (head ks))-        elVar   = Var resTy elBNm-        pat     = DataPat (embed lrCon) (rebind [] [co,el])-        elPatNm = string2Name "el"-        lhs     = Case e resTy [bind pat (Var resTy elPatNm)]--        tys          = [LitTy (NumTy 0),resTy]-        (Just idTys) = dataConInstArgTys lrCon tys-        [co,el]      = zipWith Id [string2Name "_co_",elPatNm]-                                  (map embed idTys)--    go n bs ks e = (lVars ++ rVars,(Id ltBNm (embed brTy),embed ltLhs):-                                   (Id rtBNm (embed brTy),embed rtLhs):-                                   (lBinds ++ rBinds))-      where-        ltBNm = string2Name ("lt" ++ s:show b0)-        rtBNm = string2Name ("rt" ++ s:show b1)-        ltVar = Var brTy ltBNm-        rtVar = Var brTy rtBNm-        pat   = DataPat (embed brCon) (rebind [mTV] [co,lt,rt])-        ltPatNm = string2Name "lt"-        rtPatNm = string2Name "rt"-        ltLhs   = Case e brTy [bind pat (Var brTy ltPatNm)]-        rtLhs   = Case e brTy [bind pat (Var brTy rtPatNm)]--        mName = string2Name "m"-        mTV = TyVar mName (embed typeNatKind)-        tys = [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))]-        (Just idTys) = dataConInstArgTys brCon tys-        [co,lt,rt] = zipWith Id [string2Name "_co_",ltPatNm,rtPatNm]-                                (map embed idTys)-        brTy = last idTys-        (kL,kR) = splitAt (length ks `div` 2) ks-        (b0:bL,b1:bR) = splitAt (length bs `div` 2) bs--        (lVars,lBinds) = go (n-1) bL kL ltVar-        (rVars,rBinds) = go (n-1) bR kR rtVar---- | Create a vector of supplied elements-mkRTree :: DataCon -- ^ The LR constructor-        -> DataCon -- ^ The BR constructor-        -> Type    -- ^ Element type-        -> Integer -- ^ Depth of the tree-        -> [Term]  -- ^ Elements to put in the tree-        -> Term-mkRTree lrCon brCon resTy = go-  where-    go _ [x] = mkApps (Data lrCon) [Right (LitTy (NumTy 0))-                                    ,Right resTy-                                    ,Left  (Prim "_CO_" lrCoTy)-                                    ,Left  x-                                    ]--    go n xs =-      let (xsL,xsR) = splitAt (length xs `div` 2) xs-      in  mkApps (Data brCon) [Right (LitTy (NumTy n))-                              ,Right resTy-                              ,Right (LitTy (NumTy (n-1)))-                              ,Left (Prim "_CO_" (brCoTy n))-                              ,Left (go (n-1) xsL)-                              ,Left (go (n-1) xsR)]--    lrCoTy   = head (fromJust $! dataConInstArgTys lrCon  [(LitTy (NumTy 0))-                                                         ,resTy])-    brCoTy n = head (fromJust $! dataConInstArgTys brCon-                                                   [(LitTy (NumTy n))-                                                   ,resTy-                                                   ,(LitTy (NumTy (n-1)))])---- | Determine whether a type is isomorphic to "CLaSH.Signal.Internal.Signal'"------ It is i.e.:------   * Signal' clk a---   * (Signal' clk a, Signal' clk b)---   * Vec n (Signal' clk a)---   * data Wrap = W (Signal clk' Int)---   * etc.-isSignalType :: HashMap TyConName TyCon -> Type -> Bool-isSignalType tcm ty = go HashSet.empty ty-  where-    go tcSeen (tyView -> TyConApp tcNm args) = case name2String tcNm of-      "CLaSH.Signal.Internal.Signal'"  -> True-      _ | tcNm `HashSet.member` tcSeen -> False -- Do not follow rec types-        | otherwise -> case HashMap.lookup tcNm tcm of-            Just tc -> let dcs         = tyConDataCons tc-                           dcInsArgTys = concat-                                       $ mapMaybe (`dataConInstArgTys` args) dcs-                           tcSeen'     = HashSet.insert tcNm tcSeen-                       in  any (go tcSeen') dcInsArgTys-            Nothing -> traceIf True ($(curLoc) ++ "isSignalType: " ++ show tcNm-                                     ++ " not found.") False--    go _ _ = False--tyNatSize :: HMS.HashMap TyConName TyCon-          -> Type-          -> Except String Integer-tyNatSize m (coreView m -> Just ty) = tyNatSize m ty-tyNatSize _ (LitTy (NumTy i))       = return i-tyNatSize _ ty = throwE $ $(curLoc) ++ "Cannot reduce an integer: " ++ show ty
− src/CLaSH/Core/Var.hs 
@@ -1,59 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Variables in CoreHW--}--{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module CLaSH.Core.Var-  ( Var (..)-  , Id-  , TyVar-  , modifyVarName-  )-where--import Control.DeepSeq                  (NFData (..))-import Data.Typeable                    (Typeable)-import GHC.Generics                     (Generic)-import Unbound.Generics.LocallyNameless (Alpha,Embed,Name,Subst(..))-import Unbound.Generics.LocallyNameless.Extra ()--import {-# SOURCE #-} CLaSH.Core.Term   (Term)-import {-# SOURCE #-} CLaSH.Core.Type   (Kind, Type)---- | Variables in CoreHW-data Var a-  -- | Constructor for type variables-  = TyVar-  { varName :: Name a-  , varKind :: Embed Kind-  }-  -- | Constructor for term variables-  | Id-  { varName :: Name a-  , varType :: Embed Type-  }-  deriving (Eq,Show,Generic,NFData)---- | Term variable-type Id    = Var Term--- | Type variable-type TyVar = Var Type--instance (Typeable a, Alpha a) => Alpha (Var a)-instance Generic b => Subst Term (Var b)-instance Generic b => Subst Type (Var b)---- | Change the name of a variable-modifyVarName ::-  (Name a -> Name a)-  -> Var a-  -> Var a-modifyVarName f (TyVar n k) = TyVar (f n) k-modifyVarName f (Id n t)    = Id (f n) t
− src/CLaSH/Driver.hs 
@@ -1,214 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente, 2017, QBayLogic-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Module that connects all the parts of the CLaSH compiler library--}--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}--module CLaSH.Driver where--import qualified Control.Concurrent.Supply        as Supply-import           Control.DeepSeq-import           Control.Monad                    (when, unless)-import           Control.Monad.State              (evalState, get)-import qualified Data.HashMap.Lazy                as HML-import           Data.HashMap.Strict              (HashMap)-import qualified Data.HashMap.Strict              as HM-import qualified Data.HashSet                     as HashSet-import           Data.IntMap                      (IntMap)-import           Data.Maybe                       (fromMaybe)-import           Data.Text.Lazy                   (Text)-import qualified Data.Text.Lazy                   as Text-import qualified Data.Time.Clock                  as Clock-import qualified System.Directory                 as Directory-import           System.FilePath                  ((</>), (<.>))-import qualified System.FilePath                  as FilePath-import qualified System.IO                        as IO-import           Text.PrettyPrint.Leijen.Text     (Doc, hPutDoc)-import           Unbound.Generics.LocallyNameless (name2String)--import           GHC.Extra                        ()--import           CLaSH.Annotations.TopEntity      (TopEntity (..))-import           CLaSH.Backend-import           CLaSH.Core.Term                  (Term, TmName)-import           CLaSH.Core.Type                  (Type)-import           CLaSH.Core.TyCon                 (TyCon, TyConName)-import           CLaSH.Driver.TestbenchGen-import           CLaSH.Driver.TopWrapper-import           CLaSH.Driver.Types-import           CLaSH.Netlist                    (genComponentName, genNetlist)-import           CLaSH.Netlist.BlackBox.Parser    (runParse)-import           CLaSH.Netlist.BlackBox.Types     (BlackBoxTemplate)-import           CLaSH.Netlist.Types              (Component (..), HWType)-import           CLaSH.Normalize                  (checkNonRecursive, cleanupGraph,-                                                   normalize, runNormalization)-import           CLaSH.Normalize.Util             (callGraph, mkRecursiveComponents)-import           CLaSH.Primitives.Types-import           CLaSH.Util                       (first, second)---- | Create a set of target HDL files for a set of functions-generateHDL :: forall backend . Backend backend-            => BindingMap -- ^ Set of functions-            -> Maybe backend-            -> PrimMap (Text.Text) -- ^ Primitive / BlackBox Definitions-            -> HashMap TyConName TyCon -- ^ TyCon cache-            -> IntMap TyConName -- ^ Tuple TyCon cache-            -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded 'Type' -> 'HWType' translator-            -> (HashMap TyConName TyCon -> Bool -> Term -> Term) -- ^ Hardcoded evaluator (delta-reduction)-            -> (TmName,Maybe TopEntity) -- ^ topEntity bndr + (maybe) TopEntity annotation-            -> Maybe TmName -- ^ testInput bndr-            -> Maybe TmName -- ^ expectedOutput bndr-            -> CLaSHOpts -- ^ Debug information level for the normalization process-            -> (Clock.UTCTime,Clock.UTCTime)-            -> IO ()-generateHDL bindingsMap hdlState primMap tcm tupTcm typeTrans eval (topEntity,annM) testInpM expOutM opts (startTime,prepTime) = do-  let primMap' = (HM.map parsePrimitive :: PrimMap Text.Text -> PrimMap BlackBoxTemplate) primMap--  (supplyN,supplyTB) <- Supply.splitSupply-                      . snd-                      . Supply.freshId-                     <$> Supply.newSupply--  let doNorm     = do norm <- normalize [topEntity]-                      let normChecked = checkNonRecursive topEntity norm-                      cleanupGraph topEntity normChecked-      cg         = callGraph [] bindingsMap topEntity-      rcs        = concat $ mkRecursiveComponents cg-      rcsMap     = HML.fromList-                 $ map (\(t,_) -> (t,t `elem` rcs)) cg-      transformedBindings = runNormalization opts supplyN bindingsMap typeTrans tcm tupTcm eval primMap' rcsMap doNorm--  normTime <- transformedBindings `deepseq` Clock.getCurrentTime-  let prepNormDiff = Clock.diffUTCTime normTime prepTime-  putStrLn $ "Normalisation took " ++ show prepNormDiff--  let modName   = takeWhile (/= '.') (name2String topEntity)-      iw        = opt_intWidth opts-      hdlsyn    = opt_hdlSyn opts-      hdlState' = setModName modName-                $ fromMaybe (initBackend iw hdlsyn :: backend) hdlState-      mkId      = evalState mkBasicId hdlState'-      topNm     = maybe (mkId (Text.pack $ modName ++ "_topEntity"))-                        (Text.pack . t_name)-                        annM--  (netlist,dfiles,seen) <- genNetlist transformedBindings primMap' tcm-                                 typeTrans Nothing modName [] iw mkId [topNm] topEntity--  netlistTime <- netlist `deepseq` Clock.getCurrentTime-  let normNetDiff = Clock.diffUTCTime netlistTime normTime-  putStrLn $ "Netlist generation took " ++ show normNetDiff--  let topComponent = head-                   $ filter (\(_,Component cName _ _ _ _) ->-                                Text.isSuffixOf (genComponentName [topNm] mkId modName topEntity)-                                  cName)-                            netlist--  (testBench,dfiles') <- genTestBench opts supplyTB primMap'-                             typeTrans tcm tupTcm eval mkId seen bindingsMap-                             testInpM-                             expOutM-                             modName-                             dfiles-                             (snd topComponent)---  testBenchTime <- testBench `seq` Clock.getCurrentTime-  let netTBDiff = Clock.diffUTCTime testBenchTime netlistTime-  putStrLn $ "Testbench generation took " ++ show netTBDiff--  let topWrapper = mkTopWrapper primMap' mkId annM modName iw (snd topComponent)-      hdlDocs = createHDL hdlState' modName ((noSrcSpan,topWrapper) : netlist ++ testBench)-      dir = fromMaybe "." (opt_hdlDir opts) </>-            CLaSH.Backend.name hdlState' </>-            takeWhile (/= '.') (name2String topEntity)-  prepareDir (opt_cleanhdl opts) (extension hdlState') dir-  mapM_ (writeHDL dir) hdlDocs-  copyDataFiles (opt_importPaths opts) dir dfiles'--  endTime <- hdlDocs `seq` Clock.getCurrentTime-  let startEndDiff = Clock.diffUTCTime endTime startTime-  putStrLn $ "Total compilation took " ++ show startEndDiff--parsePrimitive :: Primitive Text -> Primitive BlackBoxTemplate-parsePrimitive (BlackBox pNm libM imps inc templT) =-  let (templ,err) = either (first Left . runParse) (first Right . runParse) templT-      inc'        = case fmap (second runParse) inc of-                      Just (x,(t,[])) -> Just (x,t)-                      _ -> Nothing-  in  case err of-        [] -> BlackBox pNm libM imps inc' templ-        _  -> error $ "Errors in template for: " ++ show pNm ++ ":\n" ++ show err-parsePrimitive (Primitive pNm typ) = Primitive pNm typ---- | Pretty print Components to HDL Documents-createHDL :: Backend backend-           => backend     -- ^ Backend-           -> String-           -> [(SrcSpan,Component)] -- ^ List of components-           -> [(String,Doc)]-createHDL backend modName components = flip evalState backend $ do-  -- (hdlNms,hdlDocs) <- unzip <$> mapM genHDL components-  -- let hdlNmDocs = zip hdlNms hdlDocs-  (hdlNmDocs,incs) <- unzip <$> mapM (uncurry (genHDL modName)) components-  hwtys <- HashSet.toList <$> extractTypes <$> get-  typesPkg <- mkTyPackage modName hwtys-  let hdl   = map (first (<.> CLaSH.Backend.extension backend)) (typesPkg ++ hdlNmDocs)-      qincs = map (first (<.> "qsys")) (concat incs)-  return (hdl ++ qincs)---- | Prepares the directory for writing HDL files. This means creating the---   dir if it does not exist and removing all existing .hdl files from it.-prepareDir :: Bool -- ^ Remove existing HDL files-           -> String -- ^ File extension of the HDL files.-           -> String-           -> IO ()-prepareDir cleanhdl ext dir = do-  -- Create the dir if needed-  Directory.createDirectoryIfMissing True dir-  -- Clean the directory when needed-  when cleanhdl $ do-    -- Find all HDL files in the directory-    files <- Directory.getDirectoryContents dir-    let to_remove = filter ((==ext) . FilePath.takeExtension) files-    -- Prepend the dirname to the filenames-    let abs_to_remove = map (FilePath.combine dir) to_remove-    -- Remove the files-    mapM_ Directory.removeFile abs_to_remove---- | Writes a HDL file to the given directory-writeHDL :: FilePath -> (String, Doc) -> IO ()-writeHDL dir (cname, hdl) = do-  handle <- IO.openFile (dir </> cname) IO.WriteMode-  hPutDoc handle hdl-  IO.hPutStr handle "\n"-  IO.hClose handle--copyDataFiles :: [FilePath] -> FilePath -> [(String,FilePath)] -> IO ()-copyDataFiles idirs dir = mapM_ (copyFile' idirs)-  where-    copyFile' dirs (nm,old) = do-      oldExists <- Directory.doesFileExist old-      if oldExists-        then Directory.copyFile old new-        else goImports dirs-      where-        new = dir FilePath.</> nm--        goImports [] = do-          oldExists <- Directory.doesFileExist old-          if oldExists-            then Directory.copyFile old new-            else unless (null old) (putStrLn ("WARNING: file " ++ show old ++ " does not exist"))-        goImports (d:ds) = do-          let old2 = d FilePath.</> old-          old2Exists <- Directory.doesFileExist old2-          if old2Exists-            then Directory.copyFile old2 new-            else goImports ds
− src/CLaSH/Driver/TestbenchGen.hs 
@@ -1,272 +0,0 @@-{-|-  Copyright   :  (C) 2013-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Generate a HDL testbench for a component given a set of stimuli and a set of-  matching expected outputs--}--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}--module CLaSH.Driver.TestbenchGen-  ( genTestBench )-where--import           Control.Concurrent.Supply        (Supply)-import           Control.Lens                     ((.=))-import           Data.HashMap.Lazy                (HashMap)-import qualified Data.HashMap.Lazy                as HashMap-import           Data.IntMap.Strict               (IntMap)-import           Data.List                        (find,nub)-import           Data.Maybe                       (catMaybes,listToMaybe,-                                                   mapMaybe)-import           Data.Text.Lazy                   (append,pack)-import           Unbound.Generics.LocallyNameless (name2String)--import           CLaSH.Core.Term-import           CLaSH.Core.TyCon-import           CLaSH.Core.Type--import           CLaSH.Driver.Types--import           CLaSH.Netlist-import           CLaSH.Netlist.BlackBox           (prepareBlackBox)-import           CLaSH.Netlist.BlackBox.Types     (BlackBoxTemplate, Element (Err))-import           CLaSH.Netlist.Types              as N-import           CLaSH.Normalize                  (cleanupGraph, normalize,-                                                   runNormalization)-import           CLaSH.Normalize.Util             (callGraph, mkRecursiveComponents)-import           CLaSH.Primitives.Types-import           CLaSH.Rewrite.Types--import           CLaSH.Util---- | Generate a HDL testbench for a component given a set of stimuli and a--- set of matching expected outputs-genTestBench :: CLaSHOpts-             -> Supply-             -> PrimMap BlackBoxTemplate                     -- ^ Primitives-             -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))-             -> HashMap TyConName TyCon-             -> IntMap TyConName-             -> (HashMap TyConName TyCon -> Bool -> Term -> Term)-             -> (Identifier -> Identifier)-             -> [Identifier]-             -> HashMap TmName (Type,SrcSpan,Term)   -- ^ Global binders-             -> Maybe TmName                 -- ^ Stimuli-             -> Maybe TmName                 -- ^ Expected output-             -> String                       -- ^ Name of the module containing the @topEntity@-             -> [(String,FilePath)]          -- ^ Set of collected data-files-             -> Component                    -- ^ Component to generate TB for-             -> IO ([(SrcSpan,Component)],[(String,FilePath)])-genTestBench opts supply primMap typeTrans tcm tupTcm eval mkId seen globals stimuliNmM expectedNmM modName dfiles-  c@(Component cName hidden inps [outp] _) = do-  let inpM    = listToMaybe inps-      iw      = opt_intWidth opts-      ioDecl  = maybe [] ((:[]) . uncurry NetDecl) inpM ++-                [uncurry NetDecl outp]--  (inpInstM,inpComps,seen',hidden',dfiles') <- case inpM of-    Just inp -> case stimuliNmM of-      Just stimuliNm-              -> (\(v,w,x,y,z) -> (Just v,w,x,y,z)) <$>-                 genStimuli seen primMap globals typeTrans mkId tcm normalizeSignal hidden inp modName dfiles iw stimuliNm-      Nothing -> let inpExpr = Assignment (fst inp) (BlackBoxE "" [] [] Nothing [Err Nothing] (emptyBBContext {bbResult = (undefined,snd inp)}) False)-                 in  return (Just inpExpr,[],seen,hidden,dfiles)-    Nothing   -> return (Nothing,[],seen,hidden,dfiles)--  ((finDecl,finExpr),s) <- runNetlistMonad globals primMap tcm typeTrans modName dfiles' iw mkId ("finished":"done":seen') $ do-      done    <- genDone primMap-      let finDecl' = [ NetDecl "finished" Bool-                     , done-                     ]-      finExpr' <- genFinish primMap-      return (finDecl',finExpr')--  (expInst,expComps,seen'',hidden'',dfiles'') <- maybe (return (finExpr,[],seen',hidden',dfiles'))-      (genVerifier seen' primMap globals typeTrans mkId tcm normalizeSignal hidden' outp modName dfiles' iw)-      expectedNmM--  let clkNms = mapMaybe (\hd -> case hd of (_,Clock _ _) -> Just hd; _ -> Nothing) hidden-      rstNms = mapMaybe (\hd -> case hd of (_,Reset _ _) -> Just hd; _ -> Nothing) hidden--  ((clks,rsts),_) <- runNetlistMonad globals primMap tcm typeTrans modName dfiles'' iw mkId ("finished":"done":seen'') $ do-      varCount .= (_varCount s)-      clks' <- catMaybes <$> mapM (genClock primMap) hidden''-      rsts' <- catMaybes <$> mapM (genReset primMap) hidden''-      return (clks',rsts')--  let instDecl = InstDecl cName "totest"-                   (map (\(i,t) -> (i,In,t,Identifier i Nothing))-                        (concat [ clkNms, rstNms, maybe [] (:[]) inpM ])-                   ++-                   [(\(i,t) -> (i,Out,t,Identifier i Nothing)) outp])--      tbComp = Component (mkId (pack modName `append` "_testbench")) [] [] [("done",Bool)]-                  (concat [ finDecl-                          , concat clks-                          , concat rsts-                          , ioDecl-                          , catMaybes [Just instDecl,inpInstM,Just expInst]-                          ])--  case inps of-    (_:_:_) -> traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],dfiles)-    _ -> return ((noSrcSpan,tbComp):(inpComps++expComps),dfiles'')-  where-    normalizeSignal :: HashMap TmName (Type,SrcSpan,Term)-                    -> TmName-                    -> HashMap TmName (Type,SrcSpan,Term)-    normalizeSignal glbls bndr = do-      let cg  = callGraph [] glbls bndr-          rcs = concat $ mkRecursiveComponents cg-          rcsMap = HashMap.fromList-                 $ map (\(t,_) -> (t,t `elem` rcs)) cg-      runNormalization opts supply glbls typeTrans tcm tupTcm eval primMap rcsMap (normalize [bndr] >>= cleanupGraph bndr)--genTestBench opts _ _ _ _ _ _ _ _ _ _ _ _ dfiles c = traceIf (opt_dbgLevel opts > DebugNone) ("Can't make testbench for: " ++ show c) $ return ([],dfiles)--genClock :: PrimMap BlackBoxTemplate-         -> (Identifier,HWType)-         -> NetlistMonad (Maybe [Declaration])-genClock primMap (clkName,Clock clkSym rate) =-  case HashMap.lookup "CLaSH.Driver.TestbenchGen.clockGen" primMap of-    Just (BlackBox _ lib imps Nothing (Left templ)) -> do-      let (rising,rest) = divMod (toInteger rate) 2-          falling       = rising + rest-          ctx = emptyBBContext-                  { bbResult = (Left (Identifier clkName Nothing), Clock clkSym rate)-                  , bbInputs = [ (Left (N.Literal Nothing (NumLit 3)),Signed 32,True)-                               , (Left (N.Literal Nothing (NumLit rising)),Signed 32,True)-                               , (Left (N.Literal Nothing (NumLit falling)),Signed 32,True)-                               ]-                  }-      templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.clockGen" templ ctx-      let clkGenDecl = BlackBoxD "CLaSH.Driver.TestbenchGen.clockGen" lib imps Nothing templ' ctx-          clkDecls   = [ NetDecl clkName (Clock clkSym rate)-                       , clkGenDecl-                       ]-      return (Just clkDecls)-    pM -> error $ $(curLoc) ++ ("Can't make clock declaration for: " ++ show pM)--genClock _ _ = return Nothing--genReset :: PrimMap BlackBoxTemplate-         -> (Identifier,HWType)-         -> NetlistMonad (Maybe [Declaration])-genReset primMap (rstName,Reset clkSym rate) =-  case HashMap.lookup "CLaSH.Driver.TestbenchGen.resetGen" primMap of-    Just (BlackBox _ lib imps Nothing (Left templ)) -> do-      let ctx = emptyBBContext-                  { bbResult = (Left (Identifier rstName Nothing), Reset clkSym rate)-                  , bbInputs = [(Left (N.Literal Nothing (NumLit 2)),Signed 32,True)]-                  }-      templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.resetGen" templ ctx-      let resetGenDecl =  BlackBoxD "CLaSH.Driver.TestbenchGen.resetGen" lib imps Nothing templ' ctx-          rstDecls     = [ NetDecl rstName (Reset clkSym rate)-                       , resetGenDecl-                       ]-      return (Just rstDecls)--    pM -> error $ $(curLoc) ++ ("Can't make reset declaration for: " ++ show pM)--genReset _ _ =  return Nothing--genFinish :: PrimMap BlackBoxTemplate-          -> NetlistMonad Declaration-genFinish primMap = case HashMap.lookup "CLaSH.Driver.TestbenchGen.finishedGen" primMap of-  Just (BlackBox _ lib imps Nothing (Left templ)) -> do-    let ctx = emptyBBContext-                { bbResult = (Left (Identifier "finished" Nothing), Bool)-                , bbInputs = [ (Left (N.Literal Nothing (NumLit 100)),Signed 32,True) ]-                }-    templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.finishGen" templ ctx-    return $ BlackBoxD "CLaSH.Driver.TestbenchGen.finishGen" lib imps Nothing templ' ctx-  pM -> error $ $(curLoc) ++ ("Can't make finish declaration for: " ++ show pM)--genDone :: PrimMap BlackBoxTemplate-        -> NetlistMonad Declaration-genDone primMap = case HashMap.lookup "CLaSH.Driver.TestbenchGen.doneGen" primMap of-  Just (BlackBox _ lib imps Nothing (Left templ)) -> do-    let ctx = emptyBBContext-                { bbResult    = (Left (Identifier "done" Nothing), Bool)-                , bbInputs    = [(Left (Identifier "finished" Nothing),Bool,False)]-                }-    templ' <- prepareBlackBox "CLaSH.Driver.TestbenchGen.doneGen" templ ctx-    return $ BlackBoxD "CLaSH.Driver.TestbenchGen.doneGen" lib imps Nothing templ' ctx-  pM -> error $ $(curLoc) ++ ("Can't make done declaration for: " ++ show pM)--genStimuli :: [Identifier]-           -> PrimMap BlackBoxTemplate-           -> HashMap TmName (Type,SrcSpan,Term)-           -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))-           -> (Identifier -> Identifier)-           -> HashMap TyConName TyCon-           -> ( HashMap TmName (Type,SrcSpan,Term)-                -> TmName-                -> HashMap TmName (Type,SrcSpan,Term) )-           -> [(Identifier,HWType)]-           -> (Identifier,HWType)-           -> String-           -> [(String,FilePath)]-           -> Int-           -> TmName-           -> IO (Declaration,[(SrcSpan,Component)],[Identifier],[(Identifier,HWType)],[(String,FilePath)])-genStimuli seen primMap globals typeTrans mkId tcm normalizeSignal hidden inp modName dfiles iw signalNm = do-  let stimNormal = normalizeSignal globals signalNm-  (comps,dfiles',seen') <- genNetlist stimNormal primMap tcm typeTrans Nothing modName dfiles iw mkId seen signalNm-  let sigNm   = genComponentName seen mkId modName signalNm-      sigComp = case find ((sigNm ==) . componentName . snd) comps of-                  Just c -> c-                  Nothing -> error $ $(curLoc) ++ "Can't locate component for stimuli gen: " ++ (show $ pack $ name2String signalNm) ++ show (map (componentName.snd) comps)--      (cName,hidden',outp) = case sigComp of-                               (_,Component a b [] [(c,_)] _) -> (a,b,c)-                               (_,Component a _ is _ _)       -> error $ $(curLoc) ++ "Stimuli gen " ++ show a ++ " has unexpected inputs: " ++ show is-      hidden'' = nub (hidden ++ hidden')-      clkNms   = mapMaybe (\hd -> case hd of (_,Clock _ _) -> Just hd; _ -> Nothing) hidden'-      rstNms   = mapMaybe (\hd -> case hd of (_,Reset _ _) -> Just hd; _ -> Nothing) hidden'-      decl     = InstDecl cName "stimuli"-                   (map (\(i,t) -> (i,In,t,Identifier i Nothing))-                        (concat [ clkNms, rstNms ]) ++-                        [(outp,Out,(snd inp),Identifier (fst inp) Nothing)]-                   )-  return (decl,comps,seen',hidden'',dfiles')--genVerifier :: [Identifier]-            -> PrimMap BlackBoxTemplate-            -> HashMap TmName (Type,SrcSpan,Term)-            -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))-            -> (Identifier -> Identifier)-            -> HashMap TyConName TyCon-            -> ( HashMap TmName (Type,SrcSpan,Term)-                 -> TmName-                 -> HashMap TmName (Type,SrcSpan,Term) )-            -> [(Identifier,HWType)]-            -> (Identifier,HWType)-            -> String-            -> [(String,FilePath)]-            -> Int-            -> TmName-            -> IO (Declaration,[(SrcSpan,Component)],[Identifier],[(Identifier,HWType)],[(String,FilePath)])-genVerifier seen primMap globals typeTrans mkId tcm normalizeSignal hidden outp modName dfiles iw signalNm = do-  let stimNormal = normalizeSignal globals signalNm-  (comps,dfiles',seen') <- genNetlist stimNormal primMap tcm typeTrans Nothing modName dfiles iw mkId seen signalNm-  let sigNm   = genComponentName seen mkId modName signalNm-      sigComp = case find ((sigNm ==) . componentName . snd) comps of-                  Just c -> c-                  Nothing -> error $ $(curLoc) ++ "Can't locate component for Verifier: " ++ (show $ pack $ name2String signalNm) ++ show (map (componentName . snd) comps)-      (cName,hidden',inp,fin) = case sigComp of-        (_,Component a b [(c,_)] [(d,_)] _) -> (a,b,c,d)-        (_,Component a _ is _ _)            -> error $ $(curLoc) ++ "Verifier " ++ show a ++ " has unexpected inputs: " ++ show is-      hidden'' = nub (hidden ++ hidden')-      clkNms   = mapMaybe (\hd -> case hd of (_,Clock _ _) -> Just hd; _ -> Nothing) hidden'-      rstNms   = mapMaybe (\hd -> case hd of (_,Reset _ _) -> Just hd; _ -> Nothing) hidden'-      decl     = InstDecl cName "verify"-                   (map (\(i,t) -> (i,In,t,Identifier i Nothing))-                        (concat [ clkNms, rstNms ]) ++-                        [(inp,In,snd outp,Identifier (fst outp) Nothing),(fin,Out,Bool,Identifier "finished" Nothing)]-                   )-  return (decl,comps,seen',hidden'',dfiles')
− src/CLaSH/Driver/TopWrapper.hs 
@@ -1,346 +0,0 @@-{-|-  Copyright  :  (C) 2015-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE TemplateHaskell   #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Driver.TopWrapper where--import           Data.Char            (isDigit)-import qualified Data.HashMap.Lazy    as HashMap-import           Data.List            (mapAccumL)-import           Data.Maybe           (mapMaybe)-import           Data.Text.Lazy       (Text, append, pack, unpack)-import           System.IO.Unsafe     (unsafePerformIO)--import CLaSH.Annotations.TopEntity    (TopEntity (..), ClockSource (..))--import CLaSH.Netlist                  (runNetlistMonad)-import CLaSH.Netlist.BlackBox         (prepareBlackBox)-import CLaSH.Netlist.BlackBox.Types   (BlackBoxTemplate)-import CLaSH.Netlist.Types            (BlackBoxContext (..), Component (..),-                                       Declaration (..), Expr (..), Identifier,-                                       HWType (..), Modifier (..), NetlistMonad,-                                       PortDirection(..), emptyBBContext)-import CLaSH.Primitives.Types         (PrimMap, Primitive (..))-import CLaSH.Util---- | Create a wrapper around a component, potentially initiating clock sources-mkTopWrapper :: PrimMap BlackBoxTemplate-             -> (Identifier -> Identifier)-             -> Maybe TopEntity -- ^ TopEntity specifications-             -> String          -- ^ Name of the module containing the @topEntity@-             -> Int             -- ^ Int/Word/Integer bit-width-             -> Component       -- ^ Entity to wrap-             -> Component-mkTopWrapper primMap mkId teM modName iw topComponent-  = Component-  { componentName = maybe (mkId (pack modName `append` "_topEntity")) (pack . t_name) teM-  , inputs        = inputs'' ++ extraIn teM-  , outputs       = outputs'' ++ extraOut teM-  , hiddenPorts   = case maybe [] t_clocks teM of-                      [] -> originalHidden-                      _  -> filter (`notElem` (mapMaybe isNetDecl clkDecls))-                                   originalHidden-  , declarations  = concat [ clkDecls-                           , wrappers-                           , instDecl:unwrappers-                           ]-  }-  where-    iNameSupply                = maybe [] (map pack . t_inputs) teM-    originalHidden             = hiddenPorts topComponent--    clkDecls                   = mkClocks primMap originalHidden iw teM--    inputs'                    = map (first (const "input"))-                                     (inputs topComponent)-    (inputs'',(wrappers,idsI)) = (concat *** (first concat . unzip))-                               . unzip-                               . snd-                               $ mapAccumL (\nm (i,c) -> mkInput nm i c)-                                            iNameSupply-                                            (zip inputs' [0..])--    oNameSupply                   = maybe [] (map pack . t_outputs) teM-    outputs'                      = map (first (const "output"))-                                        (outputs topComponent)-    (outputs'',(unwrappers,idsO)) = (concat *** (first concat . unzip))-                                  . unzip-                                  . snd-                                  $ mapAccumL (\nm (o,c) -> mkOutput nm o c)-                                              oNameSupply-                                              (zip outputs' [0..])--    instDecl = InstDecl (componentName topComponent)-                        (append (componentName topComponent) (pack "_inst"))-                        (zipWith (\(p,t) i -> (p,In,t,Identifier i Nothing))-                                 (inputs topComponent)-                                 idsI-                         ++-                         map (\(p,t) -> (p,In,t,Identifier p Nothing))-                             (hiddenPorts topComponent)-                         ++-                         zipWith (\(p,t) i -> (p,Out,t,Identifier i Nothing))-                                 (outputs topComponent)-                                 idsO)--    isNetDecl (NetDecl nm ty) = Just (nm,ty)-    isNetDecl _               = Nothing---- | Create extra input ports for the wrapper-extraIn :: Maybe TopEntity -> [(Identifier,HWType)]-extraIn = maybe [] ((map (pack *** BitVector)) . t_extraIn)---- | Create extra output ports for the wrapper-extraOut :: Maybe TopEntity -> [(Identifier,HWType)]-extraOut = maybe [] ((map (pack *** BitVector)) . t_extraOut)---- | Generate input port mappings-mkInput :: [Identifier]-        -> (Identifier,HWType)-        -> Int-        -> ( [Identifier]-           , ( [(Identifier,HWType)]-             , ( [Declaration]-               , Identifier-               )-             )-           )-mkInput nms (i,hwty) cnt = case hwty of-  Vector sz hwty' ->-    let (nms',(ports',(decls',ids)))-                 = second ( (concat *** (first concat . unzip))-                          . unzip-                          )-                 $ mapAccumL-                    (\nm c -> mkInput nm (iName,hwty') c)-                    nms [0..(sz-1)]-        netdecl  = NetDecl iName hwty-        netassgn = Assignment iName (mkVectorChain sz hwty' ids)-    in  (nms',(ports',(netdecl:decls' ++ [netassgn],iName)))-  RTree d hwty' ->-    let (nms',(ports',(decls',ids)))-                 = second ( (concat *** (first concat . unzip))-                          . unzip-                          )-                 $ mapAccumL-                    (\nm c -> mkInput nm (iName,hwty') c)-                    nms [0..((2^d)-1)]-        netdecl  = NetDecl iName hwty-        netassgn = Assignment iName (mkRTreeChain d hwty' ids)-    in  (nms',(ports',(netdecl:decls' ++ [netassgn],iName)))-  Product _ hwtys ->-    let (nms',(ports',(decls',ids)))-                 = second ( (concat *** (first concat . unzip))-                          . unzip-                          )-                 $ mapAccumL-                    (\nm (inp,c) -> mkInput nm inp c)-                    nms (zip (map (iName,) hwtys) [0..])-        netdecl  = NetDecl iName hwty-        ids'     = map (`Identifier` Nothing) ids-        netassgn = Assignment iName (DataCon hwty (DC (hwty,0)) ids')-    in  (nms',(ports',(netdecl:decls' ++ [netassgn],iName)))-  _ -> case nms of-         []       -> (nms,([(iName,hwty)],([],iName)))-         (n:nms') -> (nms',([(n,hwty)],([],n)))-  where--    iName = append i (pack ("_" ++ show cnt))---- | Create a Vector chain for a list of 'Identifier's-mkVectorChain :: Int-              -> HWType-              -> [Identifier]-              -> Expr-mkVectorChain _ elTy []      = DataCon (Vector 0 elTy) VecAppend []-mkVectorChain _ elTy [i]     = DataCon (Vector 1 elTy) VecAppend-                                [Identifier i Nothing]-mkVectorChain sz elTy (i:is) = DataCon (Vector sz elTy) VecAppend-                                [ Identifier i Nothing-                                , mkVectorChain (sz-1) elTy is-                                ]---- | Create a RTree chain for a list of 'Identifier's-mkRTreeChain :: Int-             -> HWType-             -> [Identifier]-             -> Expr-mkRTreeChain _ elTy [i] = DataCon (RTree 0 elTy) RTreeAppend-                                  [Identifier i Nothing]-mkRTreeChain d elTy is =-  let (isL,isR) = splitAt (length is `div` 2) is-  in  DataCon (RTree d elTy) RTreeAppend-        [ mkRTreeChain (d-1) elTy isL-        , mkRTreeChain (d-1) elTy isR-        ]---- | Generate output port mappings-mkOutput :: [Identifier]-         -> (Identifier,HWType)-         -> Int-         -> ( [Identifier]-            , ( [(Identifier,HWType)]-              , ( [Declaration]-                , Identifier-                )-              )-            )-mkOutput nms (i,hwty) cnt = case hwty of-  Vector sz hwty' ->-    let (nms',(ports',(decls',ids)))-                = second ( (concat *** (first concat . unzip))-                         . unzip-                         )-                $ mapAccumL-                   (\nm c -> mkOutput nm (iName,hwty') c)-                   nms [0..(sz-1)]-        netdecl = NetDecl iName hwty-        assigns = zipWith-                    (\id_ n -> Assignment id_-                                 (Identifier iName (Just (Indexed (hwty,10,n)))))-                    ids-                    [0..]-    in  (nms',(ports',(netdecl:assigns ++ decls',iName)))-  RTree d hwty' ->-    let (nms',(ports',(decls',ids)))-                 = second ( (concat *** (first concat . unzip))-                          . unzip-                          )-                 $ mapAccumL-                    (\nm c -> mkOutput nm (iName,hwty') c)-                    nms [0..((2^d)-1)]-        netdecl  = NetDecl iName hwty-        assigns = zipWith-                    (\id_ n -> Assignment id_-                                 (Identifier iName (Just (Indexed (hwty,10,n)))))-                    ids-                    [0..]-    in  (nms',(ports',(netdecl:assigns ++ decls',iName)))-  Product _ hwtys ->-    let (nms',(ports',(decls',ids)))-                = second ( (concat *** (first concat . unzip))-                         . unzip-                         )-                $ mapAccumL-                   (\nm (inp,c) -> mkOutput nm inp c)-                   nms (zip (map (iName,) hwtys) [0..])-        netdecl = NetDecl iName hwty-        assigns = zipWith-                    (\id_ n -> Assignment id_-                                (Identifier iName (Just (Indexed (hwty,0,n)))))-                    ids-                    [0..]-    in  (nms',(ports',(netdecl:assigns ++ decls',iName)))-  _ -> case nms of-         []       -> (nms,([(iName,hwty)],([],iName)))-         (n:nms') -> (nms',([(n,hwty)],([],n)))-  where-    iName = append i (pack ("_" ++ show cnt))---- | Create clock generators-mkClocks :: PrimMap BlackBoxTemplate -> [(Identifier,HWType)] -> Int -> Maybe TopEntity -> [Declaration]-mkClocks primMap hidden iw teM = concat-    [ clockGens-    , resets-    ]-  where-    (clockGens,clkLocks) = maybe ([],[])-                                 (first concat . unzip . map mkClock . t_clocks)-                                 teM-    resets               = mkResets primMap hidden iw clkLocks--stringToVar :: String -> Expr-stringToVar = (`Identifier` Nothing) . pack---- | Create a single clock generator-mkClock :: ClockSource -> ([Declaration],(Identifier,[String],Bool))-mkClock (ClockSource {..}) = (clkDecls ++ [lockedDecl,instDecl],(lockedName,clks,c_sync))-  where-    c_nameT      = pack c_name-    lockedName   = append c_nameT "_locked"-    lockedDecl   = NetDecl lockedName (Reset lockedName 0)-    (ports,clks) = clockPorts c_inp c_outp-    clkDecls     = map mkClockDecl clks-    instDecl     = InstDecl c_nameT (append c_nameT "_inst")-                 $ concat [ ports-                          , maybe [] ((:[]) . (\(i,e) -> (pack i,In,Reset "" 0,stringToVar e)))-                                  c_reset-                          , [(pack c_lock,Out,Reset "" 0,Identifier lockedName Nothing)]-                          ]--mkClockDecl :: String -> Declaration-mkClockDecl s = NetDecl (pack s) (Clock (pack name) (read rate))-  where-    (name,rate) = span (not . isDigit) s----- | Create a single clock path-clockPorts :: [(String,String)] -> [(String,String)]-           -> ([(Identifier,PortDirection,HWType,Expr)],[String])-clockPorts inp outp = (inPorts ++ outPorts,clks)-  where-    inPorts  = map (\(i,e) -> (pack i,In,Clock "" 0,stringToVar e)) inp-    outPorts = map (\(i,e) -> (pack i,Out,Clock "" 0,stringToVar e)) outp-    clks  = map snd outp---- | Generate resets-mkResets :: PrimMap BlackBoxTemplate-         -> [(Identifier,HWType)]-         -> Int-         -> [(Identifier,[String],Bool)]-         -> [Declaration]-mkResets primMap hidden iw = unsafeRunNetlist iw . fmap concat . mapM assingReset-  where-    assingReset (lock,clks,doSync) = concat <$> mapM connectReset matched-      where-        matched = filter match hidden-        match (_,(Reset nm r)) = elem (unpack nm ++ show r) clks-        match _                = False--        connectReset (rst,(Reset nm r)) = if doSync-            then return [NetDecl rst (Reset nm r), Assignment rst (Identifier lock Nothing)]-            else genSyncReset primMap lock rst nm r-        connectReset _ = return []---- | Generate a reset synchroniser that synchronously de-asserts an--- asynchronous reset signal-genSyncReset :: PrimMap BlackBoxTemplate-             -> Identifier-             -> Identifier-             -> Text-             -> Integer-             -> NetlistMonad [Declaration]-genSyncReset primMap lock rst nm r = do-  let resetType = Reset rst 0-      ctx = emptyBBContext-              { bbResult = (Right ((Identifier rst Nothing),(nm,r)), resetType)-              , bbInputs = [(Left (Identifier lock Nothing),resetType,False)]-              }-      bbName = "CLaSH.TopWrapper.syncReset"-  resetGenDecl <- case HashMap.lookup bbName primMap of-        Just (BlackBox _ lib imps Nothing (Left templ)) -> do-          templ' <- prepareBlackBox bbName templ ctx-          return (BlackBoxD bbName lib imps Nothing templ' ctx)-        pM -> error $ $(curLoc) ++ ("Can't make reset sync for: " ++ show pM)--  return [NetDecl rst (Reset nm r),resetGenDecl]---- | The 'NetListMonad' is a transformer stack with 'IO' at the bottom.--- So we must use 'unsafePerformIO'.-unsafeRunNetlist :: Int-                 -> NetlistMonad a-                 -> a-unsafeRunNetlist iw-  = unsafePerformIO-  . fmap fst-  . runNetlistMonad HashMap.empty HashMap.empty-      HashMap.empty (\_ _ -> Nothing) "" [] iw id []
− src/CLaSH/Driver/Types.hs 
@@ -1,49 +0,0 @@-{-|-  Copyright  :  (C) 2013-2016, University of Twente, 2017, QBayLogic-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Type definitions used by the Driver module--}--module CLaSH.Driver.Types-  (module CLaSH.Driver.Types-  ,SrcSpan, noSrcSpan-  )-where--import Control.Exception (Exception)-import Data.HashMap.Lazy (HashMap)--import SrcLoc            (SrcSpan, noSrcSpan)--import CLaSH.Core.Term   (Term,TmName)-import CLaSH.Core.Type   (Type)--import CLaSH.Rewrite.Types (DebugLevel)-import CLaSH.Netlist.BlackBox.Types (HdlSyn)---- | Global function binders-type BindingMap = HashMap TmName (Type,SrcSpan,Term)--data CLaSHOpts = CLaSHOpts { opt_inlineLimit :: Int-                           , opt_specLimit   :: Int-                           , opt_inlineBelow :: Int-                           , opt_dbgLevel    :: DebugLevel-                           , opt_cleanhdl    :: Bool-                           , opt_intWidth    :: Int-                           , opt_hdlDir      :: Maybe String-                           , opt_hdlSyn      :: HdlSyn-                           , opt_errorExtra  :: Bool-                           , opt_floatSupport :: Bool-                           , opt_allowZero   :: Bool-                           , opt_importPaths :: [FilePath]-                           , opt_errorInvalidCoercions :: Bool-                           }--data CLaSHException = CLaSHException SrcSpan String (Maybe String)--instance Show CLaSHException where-  show (CLaSHException _ s eM) = s ++ "\n" ++ maybe "" id eM--instance Exception CLaSHException
− src/CLaSH/Netlist.hs 
@@ -1,468 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Create Netlists out of normalized CoreHW Terms--}--{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections   #-}--module CLaSH.Netlist where--import           Control.Exception                (throw)-import           Control.Lens                     ((.=),(^.),_1,_2)-import qualified Control.Lens                     as Lens-import           Control.Monad.State.Strict       (runStateT)-import           Control.Monad.Writer.Strict      (listen, runWriterT, tell)-import           Data.Binary.IEEE754              (floatToWord, doubleToWord)-import           Data.Char                        (ord)-import           Data.Either                      (lefts,partitionEithers)-import           Data.HashMap.Lazy                (HashMap)-import qualified Data.HashMap.Lazy                as HashMap-import           Data.List                        (elemIndex)-import           Data.Maybe                       (fromMaybe)-import           Data.Set                         (toList,fromList)-import qualified Data.Text.Lazy                   as Text-import           Unbound.Generics.LocallyNameless (Embed (..), name2String,-                                                  runFreshMT, unbind, unembed,-                                                  unrebind)--import           SrcLoc                           (SrcSpan,noSrcSpan)--import           CLaSH.Core.DataCon               (DataCon (..))-import           CLaSH.Core.FreeVars              (typeFreeVars)-import           CLaSH.Core.Literal               (Literal (..))-import           CLaSH.Core.Pretty                (showDoc)-import           CLaSH.Core.Term                  (Pat (..), Term (..), TmName)-import qualified CLaSH.Core.Term                  as Core-import           CLaSH.Core.Type                  (Type (..))-import           CLaSH.Core.TyCon                 (TyConName, TyCon)-import           CLaSH.Core.Util                  (collectArgs, isVar, termType)-import           CLaSH.Core.Var                   (Id, Var (..))-import           CLaSH.Driver.Types               (CLaSHException (..))-import           CLaSH.Netlist.BlackBox-import           CLaSH.Netlist.BlackBox.Types     (BlackBoxTemplate)-import           CLaSH.Netlist.Id-import           CLaSH.Netlist.Types              as HW-import           CLaSH.Netlist.Util-import           CLaSH.Normalize.Util-import           CLaSH.Primitives.Types           as P-import           CLaSH.Util---- | Generate a hierarchical netlist out of a set of global binders with--- @topEntity@ at the top.-genNetlist :: HashMap TmName (Type,SrcSpan,Term)-           -- ^ Global binders-           -> PrimMap BlackBoxTemplate-           -- ^ Primitive definitions-           -> HashMap TyConName TyCon-           -- ^ TyCon cache-           -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))-           -- ^ Hardcoded Type -> HWType translator-           -> Maybe Int-           -- ^ Symbol count-           -> String-           -- ^ Name of the module containing the @topEntity@-           -> [(String,FilePath)]-           -- ^ Set of collected data-files-           -> Int-           -- ^ Int/Word/Integer bit-width-           -> (Identifier -> Identifier)-           -- ^ valid identifiers-           -> [Identifier]-           -- ^ Seen components-           -> TmName-           -- ^ Name of the @topEntity@-           -> IO ([(SrcSpan,Component)],[(String,FilePath)],[Identifier])-genNetlist globals primMap tcm typeTrans mStart modName dfiles iw mkId seen topEntity = do--  (_,s) <- runNetlistMonad globals primMap tcm typeTrans modName dfiles iw mkId seen $ genComponent topEntity mStart-  return (HashMap.elems $ _components s, _dataFiles s, _seenComps s)---- | Run a NetlistMonad action in a given environment-runNetlistMonad :: HashMap TmName (Type,SrcSpan,Term)-                -- ^ Global binders-                -> PrimMap BlackBoxTemplate-                -- ^ Primitive Definitions-                -> HashMap TyConName TyCon-                -- ^ TyCon cache-                -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))-                -- ^ Hardcode Type -> HWType translator-                -> String-                -- ^ Name of the module containing the @topEntity@-                -> [(String,FilePath)]-                -- ^ Set of collected data-files-                -> Int-                -- ^ Int/Word/Integer bit-width-                -> (Identifier -> Identifier)-                -- ^ valid identifiers-                -> [Identifier]-                -- ^ Seen components-                -> NetlistMonad a-                -- ^ Action to run-                -> IO (a, NetlistState)-runNetlistMonad s p tcm typeTrans modName dfiles iw mkId seen-  = runFreshMT-  . flip runStateT s'-  . (fmap fst . runWriterT)-  . runNetlist-  where-    s' = NetlistState s HashMap.empty 0 HashMap.empty p typeTrans tcm (Text.empty,noSrcSpan) dfiles iw mkId [] seen' names-    (seen',names) = genNames mkId modName seen HashMap.empty (HashMap.keys s)--genNames :: (Identifier -> Identifier)-         -> String-         -> [Identifier]-         -> HashMap TmName Identifier-         -> [TmName]-         -> ([Identifier], HashMap TmName Identifier)-genNames mkId modName = go-  where-    go s m []       = (s,m)-    go s m (nm:nms) = let nm' = genComponentName s mkId modName nm-                          s'  = nm':s-                          m'  = HashMap.insert nm nm' m-                      in  go s' m' nms---- | Generate a component for a given function (caching)-genComponent :: TmName -- ^ Name of the function-             -> Maybe Int -- ^ Starting value of the unique counter-             -> NetlistMonad (SrcSpan,Component)-genComponent compName mStart = do-  compExprM <- fmap (HashMap.lookup compName) $ Lens.use bindings-  case compExprM of-    Nothing -> do-      (_,sp) <- Lens.use curCompNm-      throw (CLaSHException sp ($(curLoc) ++ "No normalized expression found for: " ++ show compName) Nothing)-    Just (_,_,expr_) -> do-      c@(_,Component _ clks _ _ _) <- makeCached compName components $ genComponentT compName expr_ mStart-      -- This might seem redundant, because you think `genComponentT` already-      -- added those clocks, right? wrong!-      ---      -- `makeCached` stores the value returned by a monadic action, so when-      -- we use a cached result, its clocks weren't added to the current-      -- writer which is keeping track of used clock ports.-      tell (fromList clks)-      return c---- | Generate a component for a given function-genComponentT :: TmName -- ^ Name of the function-              -> Term -- ^ Corresponding term-              -> Maybe Int -- ^ Starting value of the unique counter-              -> NetlistMonad (SrcSpan,Component)-genComponentT compName componentExpr mStart = do-  varCount .= fromMaybe 0 mStart-  componentName' <- (HashMap.! compName) <$> Lens.use componentNames-  sp <- ((^. _2) . (HashMap.! compName)) <$> Lens.use bindings-  curCompNm .= (componentName',sp)--  tcm <- Lens.use tcCache-  seenIds .= []-  (arguments,binders,result) <- do { normalizedM <- splitNormalized tcm componentExpr-                                   ; case normalizedM of-                                       Right normalized -> mkUniqueNormalized normalized-                                       Left err         -> throw (CLaSHException sp err Nothing)-                                   }--  let ids = HashMap.fromList-          $ map (\(Id v (Embed t)) -> (v,t))-          $ arguments ++ map fst binders--  gamma <- (ids `HashMap.union`) . HashMap.map (^. _1)-           <$> Lens.use bindings--  varEnv .= gamma--  typeTrans    <- Lens.use typeTranslator-  let resType  = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm $ HashMap.lookupDefault (error $ $(curLoc) ++ "resType" ++ show (result,HashMap.keys ids)) result ids-      argTypes = map (\(Id _ (Embed t)) -> unsafeCoreTypeToHWType $(curLoc) typeTrans tcm t) arguments--  let netDecls = map (\(id_,_) ->-                        NetDecl (Text.pack . name2String $ varName id_)-                                (unsafeCoreTypeToHWType $(curLoc) typeTrans tcm . unembed $ varType id_)-                     ) $ filter ((/= result) . varName . fst) binders-  (decls,clks) <- listen $ concat <$> mapM (uncurry mkDeclarations . second unembed) binders--  let compInps       = zip (map (Text.pack . name2String . varName) arguments) argTypes-      compOutp       = (Text.pack $ name2String result, resType)-      component      = Component componentName' (toList clks) compInps [compOutp] (netDecls ++ decls)-  return (sp,component)---genComponentName :: [Identifier] -> (Identifier -> Identifier) -> String -> TmName -> Identifier-genComponentName seen mkId prefix nm =-  let i = mkId . stripDollarPrefixes . last-        . Text.splitOn (Text.pack ".") . Text.pack-        $ name2String nm-      i' = if Text.null i-              then Text.pack "Component"-              else i-      i'' = mkId (Text.pack (prefix ++ "_") `Text.append` i')-  in  if i'' `elem` seen-         then go 0 i''-         else i''-  where-    go :: Integer -> Identifier -> Identifier-    go n i =-      let i' = mkId (i `Text.append` Text.pack ('_':show n))-      in  if i' `elem` seen-             then go (n+1) i-             else i'---- | Generate a list of Declarations for a let-binder-mkDeclarations :: Id -- ^ LHS of the let-binder-               -> Term -- ^ RHS of the let-binder-               -> NetlistMonad [Declaration]-mkDeclarations bndr (Var _ v) = mkFunApp bndr v []--mkDeclarations _ e@(Case _ _ []) = do-  (_,sp) <- Lens.use curCompNm-  throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Case-decompositions with an empty list of alternatives not supported:\n\n" ++ showDoc e) Nothing)--mkDeclarations bndr e@(Case scrut _ [alt]) = do-  (pat,v) <- unbind alt-  (_,sp) <- Lens.use curCompNm-  (varTy,varTm) <- case v of-                     (Var t n) -> return (t,n)-                     _ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: RHS of case-projection is not a variable:\n\n" ++ showDoc e) Nothing)-  typeTrans    <- Lens.use typeTranslator-  tcm          <- Lens.use tcCache-  scrutTy      <- termType tcm scrut-  let sHwTy = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm scrutTy-      vHwTy = unsafeCoreTypeToHWType $(curLoc) typeTrans tcm varTy-  (selId,decls) <- case scrut of-    (Var _ scrutNm) -> return (Text.pack $ name2String scrutNm,[])-    _ -> do-       let scrutId = Text.pack . (++ "_case_scrut") . name2String $ varName bndr-       (newExpr, newDecls) <- mkExpr False (Left scrutId) scrutTy scrut-       case newExpr of-         (Identifier newId Nothing) -> return (newId,newDecls)-         _ -> do-          scrutId' <- mkUniqueIdentifier scrutId-          let scrutDecl = NetDecl scrutId' sHwTy-              scrutAssn = Assignment scrutId' newExpr-          return (scrutId',newDecls ++ [scrutDecl,scrutAssn])-  let dstId    = Text.pack . name2String $ varName bndr-      altVarId = Text.pack $ name2String varTm-      modifier = case pat of-        DataPat (Embed dc) ids -> let (exts,tms) = unrebind ids-                                      tmsTys     = map (unembed . varType) tms-                                      tmsFVs     = concatMap (Lens.toListOf typeFreeVars) tmsTys-                                      extNms     = map varName exts-                                      tms'       = if any (`elem` tmsFVs) extNms-                                                      then throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Pattern binds existential variables:\n\n" ++ showDoc e) Nothing)-                                                      else tms-                                  in case elemIndex (Id varTm (Embed varTy)) tms' of-                                       Nothing -> Nothing-                                       Just fI-                                        | sHwTy /= vHwTy -> Just (Indexed (sHwTy,dcTag dc - 1,fI))-                                        -- When element and subject have the same HW-type,-                                        -- then the projections is just the identity-                                        | otherwise      -> Just (DC (Void,0))-        _ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection:\n\n" ++ showDoc e) Nothing)-      extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier-  return (decls ++ [Assignment dstId extractExpr])--mkDeclarations bndr (Case scrut altTy alts) = do-  alts'                  <- reorderPats <$> mapM unbind alts-  tcm                    <- Lens.use tcCache-  scrutTy                <- termType tcm scrut-  scrutHTy               <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy-  altHTy                 <- unsafeCoreTypeToHWTypeM $(curLoc) altTy-  let scrutId = Text.pack . (++ "_case_scrut") . name2String $ varName bndr-  (_,sp) <- Lens.use curCompNm-  (scrutExpr,scrutDecls) <- first (mkScrutExpr sp scrutHTy (fst (head alts'))) <$> mkExpr True (Left scrutId) scrutTy scrut-  (exprs,altsDecls)      <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts'--  let dstId = Text.pack . name2String $ varName bndr-  return $! scrutDecls ++ altsDecls ++ [CondAssignment dstId altHTy scrutExpr scrutHTy exprs]-  where-    mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe HW.Literal,Expr),[Declaration])-    mkCondExpr scrutHTy (pat,alt) = do-      let altId = Text.pack . (++ "_case_alt") . name2String $ varName bndr-      (altExpr,altDecls) <- mkExpr False (Left altId) altTy alt-      (,altDecls) <$> case pat of-        DefaultPat           -> return (Nothing,altExpr)-        DataPat (Embed dc) _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr)-        LitPat  (Embed (IntegerLiteral i)) -> return (Just (NumLit i),altExpr)-        LitPat  (Embed (IntLiteral i)) -> return (Just (NumLit i), altExpr)-        LitPat  (Embed (WordLiteral w)) -> return (Just (NumLit w), altExpr)-        LitPat  (Embed (CharLiteral c)) -> return (Just (NumLit . toInteger $ ord c), altExpr)-        LitPat  (Embed (Int64Literal i)) -> return (Just (NumLit i), altExpr)-        LitPat  (Embed (Word64Literal w)) -> return (Just (NumLit w), altExpr)-        _  -> do-          (_,sp) <- Lens.use curCompNm-          throw (CLaSHException sp ($(curLoc) ++ "Not an integer literal in LitPat:\n\n" ++ showDoc pat) Nothing)--    mkScrutExpr :: SrcSpan -> HWType -> Pat -> Expr -> Expr-    mkScrutExpr sp scrutHTy pat scrutE = case pat of-      DataPat (Embed dc) _ -> let modifier = Just (DC (scrutHTy,dcTag dc - 1))-                              in case scrutE of-                                  Identifier scrutId _ -> Identifier scrutId modifier-                                  _ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement:\n\n" ++ show scrutE) Nothing)-      _ -> scrutE--    -- GHC puts default patterns in the first position, we want them in the-    -- last position.-    reorderPats :: [(Pat,Term)] -> [(Pat,Term)]-    reorderPats ((DefaultPat,e):alts') = alts' ++ [(DefaultPat,e)]-    reorderPats alts'                  = alts'--mkDeclarations bndr app =-  let (appF,(args,tyArgs)) = second partitionEithers $ collectArgs app-  in case appF of-    Var _ f-      | null tyArgs -> mkFunApp bndr f args-      | otherwise   -> do-        (_,sp) <- Lens.use curCompNm-        throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showDoc app) Nothing)-    _ -> do-      (exprApp,declsApp) <- mkExpr False (Right bndr) (unembed $ varType bndr) app-      let dstId = Text.pack . name2String $ varName bndr-          assn  = case exprApp of-                    Identifier _ Nothing -> []-                    _ -> [Assignment dstId exprApp]-      return (declsApp ++ assn)---- | Generate a list of Declarations for a let-binder where the RHS is a function application-mkFunApp :: Id -- ^ LHS of the let-binder-         -> TmName -- ^ Name of the applied function-         -> [Term] -- ^ Function arguments-         -> NetlistMonad [Declaration]-mkFunApp dst fun args = do-  normalized <- Lens.use bindings-  case HashMap.lookup fun normalized of-    Just _ -> do-      (_,Component compName hidden compInps [compOutp] _) <- preserveVarEnv $ genComponent fun Nothing-      if length args == length compInps-        then do tcm <- Lens.use tcCache-                argTys                <- mapM (termType tcm) args-                let dstId = Text.pack . name2String $ varName dst-                (argExprs,argDecls)   <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr False (Left dstId) t e) (zip args argTys)-                (argExprs',argDecls') <- (second concat . unzip) <$> mapM (toSimpleVar dst) (zip argExprs argTys)-                let hiddenAssigns = map (\(i,t) -> (i,In,t,Identifier i Nothing)) hidden-                    inpAssigns    = zipWith (\(i,t) e -> (i,In,t,e)) compInps argExprs'-                    outpAssign    = (fst compOutp,Out,snd compOutp,Identifier dstId Nothing)-                    instLabel     = Text.concat [compName, Text.pack "_", dstId]-                    instDecl      = InstDecl compName instLabel (outpAssign:hiddenAssigns ++ inpAssigns)-                tell (fromList hidden)-                return (argDecls ++ argDecls' ++ [instDecl])-        else error $ $(curLoc) ++ "under-applied normalized function"-    Nothing -> case args of-      [] -> do-        let dstId = Text.pack . name2String $ varName dst-        return [Assignment dstId (Identifier (Text.pack $ name2String fun) Nothing)]-      _ -> error $ $(curLoc) ++ "Unknown function: " ++ showDoc fun--toSimpleVar :: Id-            -> (Expr,Type)-            -> NetlistMonad (Expr,[Declaration])-toSimpleVar _ (e@(Identifier _ _),_) = return (e,[])-toSimpleVar dst (e,ty) = do-  let argNm = Text.pack . (++ "_app_arg") . name2String $ varName dst-  argNm' <- mkUniqueIdentifier argNm-  hTy <- unsafeCoreTypeToHWTypeM $(curLoc) ty-  let argDecl = NetDecl argNm' hTy-      argAssn = Assignment argNm' e-  return (Identifier argNm' Nothing,[argDecl,argAssn])---- | Generate an expression for a term occurring on the RHS of a let-binder-mkExpr :: Bool -- ^ Treat BlackBox expression as declaration-       -> (Either Identifier Id) -- ^ Id to assign the result to-       -> Type -- ^ Type of the LHS of the let-binder-       -> Term -- ^ Term to convert to an expression-       -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations-mkExpr _ _ _ (Core.Literal l) = do-  iw <- Lens.use intWidth-  case l of-    IntegerLiteral i -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, [])-    IntLiteral i     -> return (HW.Literal (Just (Signed iw,iw)) $ NumLit i, [])-    WordLiteral w    -> return (HW.Literal (Just (Unsigned iw,iw)) $ NumLit w, [])-    Int64Literal i   -> return (HW.Literal (Just (Signed 64,64)) $ NumLit i, [])-    Word64Literal w  -> return (HW.Literal (Just (Unsigned 64,64)) $ NumLit w, [])-    CharLiteral c    -> return (HW.Literal (Just (Unsigned 21,21)) . NumLit . toInteger $ ord c, [])-    FloatLiteral r   -> let f = fromRational r :: Float-                            i = toInteger (floatToWord f)-                        in  return (HW.Literal (Just (BitVector 32,32)) (NumLit i), [])-    DoubleLiteral r  -> let d = fromRational r :: Double-                            i = toInteger (doubleToWord d)-                        in  return (HW.Literal (Just (BitVector 64,64)) (NumLit i), [])-    _ -> error $ $(curLoc) ++ "not an integer or char literal"--mkExpr bbEasD bndr ty app = do-  let (appF,args) = collectArgs app-      tmArgs      = lefts args-  hwTy    <- unsafeCoreTypeToHWTypeM $(curLoc) ty-  (_,sp) <- Lens.use curCompNm-  case appF of-    Data dc-      | all (\e -> isConstant e || isVar e) tmArgs -> mkDcApplication hwTy bndr dc tmArgs-      | otherwise                                  ->-        throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: DataCon-application with non-Simple arguments:\n\n" ++ showDoc app) Nothing)-    Prim nm _ -> mkPrimitive False bbEasD bndr nm args ty-    Var _ f-      | null tmArgs -> return (Identifier (Text.pack $ name2String f) Nothing,[])-      | otherwise ->-        throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: top-level binder in argument position:\n\n" ++ showDoc app) Nothing)-    _ -> throw (CLaSHException sp ($(curLoc) ++ "Not in normal form: application of a Let/Lam/Case:\n\n" ++ showDoc app) Nothing)---- | Generate an expression for a DataCon application occurring on the RHS of a let-binder-mkDcApplication :: HWType -- ^ HWType of the LHS of the let-binder-                -> (Either Identifier Id) -- ^ Id to assign the result to-                -> DataCon -- ^ Applied DataCon-                -> [Term] -- ^ DataCon Arguments-                -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations-mkDcApplication dstHType bndr dc args = do-  tcm                 <- Lens.use tcCache-  argTys              <- mapM (termType tcm) args-  let isSP (SP _ _) = True-      isSP _        = False-  let argNm = either id (Text.pack . (++ "_app_arg") . name2String . varName) bndr-  (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr (isSP dstHType) (Left argNm) t e) (zip args argTys)-  argHWTys            <- mapM coreTypeToHWTypeM argTys-  fmap (,argDecls) $! case (argHWTys,argExprs) of-    -- Is the DC just a newtype wrapper?-    ([Just argHwTy],[argExpr]) | argHwTy == dstHType ->-      return (HW.DataCon dstHType (DC (Void,-1)) [argExpr])-    _ -> case dstHType of-      SP _ dcArgPairs -> do-        let dcI      = dcTag dc - 1-            dcArgs   = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI-        case compare (length dcArgs) (length argExprs) of-          EQ -> return (HW.DataCon dstHType (DC (dstHType,dcI)) argExprs)-          LT -> error $ $(curLoc) ++ "Over-applied constructor"-          GT -> error $ $(curLoc) ++ "Under-applied constructor"-      Product _ dcArgs ->-        case compare (length dcArgs) (length argExprs) of-          EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprs)-          LT -> error $ $(curLoc) ++ "Over-applied constructor"-          GT -> error $ $(curLoc) ++ "Under-applied constructor"-      Sum _ _ ->-        return (HW.DataCon dstHType (DC (dstHType,dcTag dc - 1)) [])-      Bool ->-        let dc' = case dcTag dc of-                   1  -> HW.Literal Nothing (BoolLit False)-                   2  -> HW.Literal Nothing (BoolLit True)-                   tg -> error $ $(curLoc) ++ "unknown bool literal: " ++ showDoc dc ++ "(tag: " ++ show tg ++ ")"-        in  return dc'-      Vector 0 _ -> return (HW.DataCon dstHType VecAppend [])-      Vector 1 _ -> case argExprs of-                      [_,e,_] -> return (HW.DataCon dstHType VecAppend [e])-                      _       -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showDoc args-      Vector _ _ -> case argExprs of-                      [_,e1,e2] -> return (HW.DataCon dstHType VecAppend [e1,e2])-                      _         -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showDoc args-      RTree 0 _ -> case argExprs of-                      [_,e] -> return (HW.DataCon dstHType RTreeAppend [e])-                      _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `LR`: " ++ showDoc args-      RTree _ _ -> case argExprs of-                      [_,e1,e2] -> return (HW.DataCon dstHType RTreeAppend [e1,e2])-                      _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `BR`: " ++ showDoc args-      String ->-        let dc' = case dcTag dc of-                    1 -> HW.Literal Nothing (StringLit "")-                    _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,dcTag dc,args,argHWTys)-        in  return dc'-      _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys)
− src/CLaSH/Netlist.hs-boot 
@@ -1,31 +0,0 @@-{-|-  Copyright   :  (C) 2015-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--module CLaSH.Netlist (genComponent,mkExpr,mkDcApplication) where--import CLaSH.Core.DataCon   (DataCon)-import CLaSH.Core.Term      (Term,TmName)-import CLaSH.Core.Type      (Type)-import CLaSH.Core.Var       (Id)-import CLaSH.Driver.Types   (SrcSpan)-import CLaSH.Netlist.Types  (Expr, HWType, Identifier, NetlistMonad, Component,-                             Declaration)--genComponent :: TmName-             -> Maybe Int-             -> NetlistMonad (SrcSpan,Component)--mkExpr :: Bool-       -> Either Identifier Id-       -> Type-       -> Term-       -> NetlistMonad (Expr,[Declaration])--mkDcApplication :: HWType-                -> Either Identifier Id-                -> DataCon-                -> [Term]-                -> NetlistMonad (Expr,[Declaration])
− src/CLaSH/Netlist/BlackBox.hs 
@@ -1,319 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Functions to create BlackBox Contexts and fill in BlackBox templates--}--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE TupleSections     #-}--module CLaSH.Netlist.BlackBox where--import           Control.Exception             (throw)-import           Control.Lens                  ((.=),(<<%=))-import qualified Control.Lens                  as Lens-import           Data.Char                     (ord)-import           Data.Either                   (lefts)-import qualified Data.HashMap.Lazy             as HashMap-import qualified Data.IntMap                   as IntMap-import           Data.Text.Lazy                (append,fromStrict, pack)-import qualified Data.Text.Lazy                as Text-import           Data.Text                     (unpack)-import qualified Data.Text                     as TextS-import           Unbound.Generics.LocallyNameless (embed, name2String, string2Name,-                                                unembed)---- import           CLaSH.Backend                 as N-import           CLaSH.Core.DataCon            as D (dcTag)-import           CLaSH.Core.Literal            as L (Literal (..))-import           CLaSH.Core.Pretty             (showDoc)-import           CLaSH.Core.Term               as C (Term (..))-import           CLaSH.Core.Type               as C (Type (..), ConstTy (..),-                                                splitFunTys)-import           CLaSH.Core.TyCon              as C (tyConDataCons)-import           CLaSH.Core.Util               (collectArgs, isFun, termType)-import           CLaSH.Core.Var                as V (Id, Var (..))-import           CLaSH.Driver.Types            (CLaSHException (..))-import {-# SOURCE #-} CLaSH.Netlist            (genComponent, mkDcApplication,-                                                mkExpr)-import           CLaSH.Netlist.BlackBox.Types  as B-import           CLaSH.Netlist.BlackBox.Util   as B-import           CLaSH.Netlist.Types           as N-import           CLaSH.Netlist.Util            as N-import           CLaSH.Normalize.Util          (isConstant)-import           CLaSH.Primitives.Types        as P-import           CLaSH.Util---- | Generate the context for a BlackBox instantiation.-mkBlackBoxContext :: Id -- ^ Identifier binding the primitive/blackbox application-                  -> [Term] -- ^ Arguments of the primitive/blackbox application-                  -> NetlistMonad (BlackBoxContext,[Declaration])-mkBlackBoxContext resId args = do-    -- Make context inputs-    tcm             <- Lens.use tcCache-    let resNm = Text.pack . name2String $ varName resId-    (imps,impDecls) <- unzip <$> mapM (mkArgument resNm) args-    (funs,funDecls) <- mapAccumLM (addFunction tcm) IntMap.empty (zip args [0..])--    -- Make context result-    res   <- case synchronizedClk tcm (unembed $ V.varType resId) of-                Just clk -> Right . (,clk) . (`N.Identifier` Nothing) <$> mkBasicId (pack $ name2String (V.varName resId))-                Nothing  -> Left . (`N.Identifier` Nothing)  <$> mkBasicId (pack $ name2String (V.varName resId))-    resTy <- unsafeCoreTypeToHWTypeM $(curLoc) (unembed $ V.varType resId)--    return ( Context (res,resTy) imps funs Nothing-           , concat impDecls ++ concat funDecls-           )-  where-    addFunction tcm im (arg,i) = do-      isF <- isFun tcm arg-      if isF-         then do (f,d) <- mkFunInput resId arg-                 let im' = IntMap.insert i f im-                 return (im',d)-         else return (im,[])--prepareBlackBox :: TextS.Text-                -> BlackBoxTemplate-                -> BlackBoxContext-                -> NetlistMonad BlackBoxTemplate-prepareBlackBox pNm templ bbCtx =-  if verifyBlackBoxContext bbCtx templ-     then instantiateCompName >=>-          setSym >=>-          setClocks bbCtx >=>-          collectFilePaths bbCtx $ templ-     else do-       (_,sp) <- Lens.use curCompNm-       templ' <- prettyBlackBox templ-       let msg = $(curLoc) ++ "Can't match template for " ++ show pNm ++ " :\n\n" ++ Text.unpack templ' ++-                "\n\nwith context:\n\n" ++ show bbCtx-       throw (CLaSHException sp msg Nothing)--mkArgument :: Identifier -- ^ LHS of the original let-binder-           -> Term-           -> NetlistMonad ( (SyncExpr,HWType,Bool)-                           , [Declaration]-                           )-mkArgument bndr e = do-    tcm   <- Lens.use tcCache-    ty    <- termType tcm e-    iw    <- Lens.use intWidth-    hwTyM <- N.termHWTypeM e-    ((e',t,l),d) <- case hwTyM of-      Nothing   -> return ((Identifier "__VOID__" Nothing,Void,False),[])-      Just hwTy -> case collectArgs e of-        (Var _ v,[]) -> do vT <- (`Identifier` Nothing) <$> mkBasicId (pack $ name2String v)-                           return ((vT,hwTy,False),[])-        (C.Literal (IntegerLiteral i),[]) -> return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[])-        (C.Literal (IntLiteral i), []) -> return ((N.Literal (Just (Signed iw,iw)) (N.NumLit i),hwTy,True),[])-        (C.Literal (WordLiteral w), []) -> return ((N.Literal (Just (Unsigned iw,iw)) (N.NumLit w),hwTy,True),[])-        (C.Literal (CharLiteral c), []) -> return ((N.Literal (Just (Unsigned 21,21)) (N.NumLit . toInteger $ ord c),hwTy,True),[])-        (C.Literal (StringLiteral s),[]) -> return ((N.Literal Nothing (N.StringLit s),hwTy,True),[])-        (C.Literal (Int64Literal i), []) -> return ((N.Literal (Just (Signed 64,64)) (N.NumLit i),hwTy,True),[])-        (C.Literal (Word64Literal i), []) -> return ((N.Literal (Just (Unsigned 64,64)) (N.NumLit i),hwTy,True),[])-        (Prim f _,args) -> do-          (e',d) <- mkPrimitive True False (Left bndr) f args ty-          case e' of-            (Identifier _ _) -> return ((e',hwTy,False), d)-            _                -> return ((e',hwTy,isConstant e), d)-        (Data dc, args) -> do-          (exprN,dcDecls) <- mkDcApplication hwTy (Left bndr) dc (lefts args)-          return ((exprN,hwTy,isConstant e),dcDecls)-        _ -> return ((Identifier "__VOID__" Nothing,hwTy,False),[])-    return ((addClock tcm ty e',t,l),d)-  where-    addClock tcm ty e' = case synchronizedClk tcm ty of-                           Just clk -> Right (e',clk)-                           _        -> Left  e'--mkPrimitive :: Bool -- ^ Put BlackBox expression in parenthesis-            -> Bool -- ^ Treat BlackBox expression as declaration-            -> (Either Identifier Id) -- ^ Id to assign the result to-            -> TextS.Text-            -> [Either Term Type]-            -> Type-            -> NetlistMonad (Expr,[Declaration])-mkPrimitive bbEParen bbEasD dst nm args ty = do-  bbM <- HashMap.lookup nm <$> Lens.use primitives-  case bbM of-    Just p@(P.BlackBox {}) -> do-      case template p of-        (Left tempD) -> do-          let pNm = name p-          (dst',dstNm,dstDecl) <- resBndr True dst-          (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args)-          bbDecl <- N.BlackBoxD pNm (library p) (imports p) (qsysInclude p) <$> prepareBlackBox pNm tempD bbCtx <*> pure bbCtx-          return (Identifier dstNm Nothing,dstDecl ++ ctxDcls ++ [bbDecl])-        (Right tempE) -> do-          let pNm = name p-          if bbEasD-            then do-              (dst',dstNm,dstDecl) <- resBndr True dst-              (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args)-              bbTempl <- prepareBlackBox pNm tempE bbCtx-              let tmpAssgn = Assignment dstNm (BlackBoxE pNm (library p) (imports p) (qsysInclude p) bbTempl bbCtx bbEParen)-              return (Identifier dstNm Nothing, dstDecl ++ ctxDcls ++ [tmpAssgn])-            else do-              (dst',_,_) <- resBndr False dst-              (bbCtx,ctxDcls) <- mkBlackBoxContext dst' (lefts args)-              bbTempl <- prepareBlackBox pNm tempE bbCtx-              return (BlackBoxE pNm (library p) (imports p) (qsysInclude p) bbTempl bbCtx bbEParen,ctxDcls)-    Just (P.Primitive pNm _)-      | pNm == "GHC.Prim.tagToEnum#" -> do-          hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty-          case args of-            [Right (ConstTy (TyCon tcN)), Left (C.Literal (IntLiteral i))] -> do-              tcm <- Lens.use tcCache-              let dcs = tyConDataCons (tcm HashMap.! tcN)-                  dc  = dcs !! fromInteger i-              (exprN,dcDecls) <- mkDcApplication hwTy dst dc []-              return (exprN,dcDecls)-            [Right _, Left scrut] -> do-              tcm     <- Lens.use tcCache-              scrutTy <- termType tcm scrut-              (scrutExpr,scrutDecls) <- mkExpr False (Left "tte_rhs") scrutTy scrut-              case scrutExpr of-                Identifier id_ Nothing -> return (DataTag hwTy (Left id_),scrutDecls)-                _ -> do-                  scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy-                  tmpRhs <- mkUniqueIdentifier (pack "tte_rhs")-                  let netDeclRhs   = NetDecl tmpRhs scrutHTy-                      netAssignRhs = Assignment tmpRhs scrutExpr-                  return (DataTag hwTy (Left tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls)-            _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showDoc showDoc) args)-      | pNm == "GHC.Prim.dataToTag#" -> case args of-          [Right _,Left (Data dc)] -> do-            iw <- Lens.use intWidth-            return (N.Literal (Just (Signed iw,iw)) (NumLit $ toInteger $ dcTag dc - 1),[])-          [Right _,Left scrut] -> do-            tcm      <- Lens.use tcCache-            scrutTy  <- termType tcm scrut-            scrutHTy <- unsafeCoreTypeToHWTypeM $(curLoc) scrutTy-            (scrutExpr,scrutDecls) <- mkExpr False (Left "dtt_rhs") scrutTy scrut-            case scrutExpr of-              Identifier id_ Nothing -> return (DataTag scrutHTy (Right id_),scrutDecls)-              _ -> do-                tmpRhs  <- mkUniqueIdentifier "dtt_rhs"-                let netDeclRhs   = NetDecl tmpRhs scrutHTy-                    netAssignRhs = Assignment tmpRhs scrutExpr-                return (DataTag scrutHTy (Right tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls)-          _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showDoc showDoc) args)-      | otherwise -> return (BlackBoxE "" [] [] Nothing [C $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]] emptyBBContext False,[])-    _ -> do-      (_,sp) <- Lens.use curCompNm-      throw (CLaSHException sp ($(curLoc) ++ "No blackbox found for: " ++ unpack nm) Nothing)-  where-    resBndr :: Bool -> (Either Identifier Id) -> NetlistMonad (Id,Identifier,[Declaration])-    resBndr mkDec dst' = case dst' of-      Left dstL -> case mkDec of-        False -> do-          let nm' = Text.unpack dstL-              id_ = Id (string2Name nm') (embed ty)-          return (id_,dstL,[])-        True -> do-          let nm' = append dstL "_app_arg"-          nm'' <- mkUniqueIdentifier nm'-          hwTy <- N.unsafeCoreTypeToHWTypeM $(curLoc) ty-          let id_ = Id (string2Name (Text.unpack nm'')) (embed ty)-              idDecl = NetDecl nm'' hwTy-          return (id_,nm'',[idDecl])-      Right dstR -> return (dstR,Text.pack . name2String . varName $ dstR,[])---- | Create an template instantiation text and a partial blackbox content for an--- argument term, given that the term is a function. Errors if the term is not--- a function-mkFunInput :: Id   -- ^ Identifier binding the encompassing primitive/blackbox application-           -> Term -- ^ The function argument term-           -> NetlistMonad ((Either BlackBoxTemplate Declaration,BlackBoxContext),[Declaration])-mkFunInput resId e = do-  let (appE,args) = collectArgs e-  (bbCtx,dcls) <- mkBlackBoxContext resId (lefts args)-  templ <- case appE of-            Prim nm _ -> do-              bbM <- fmap (HashMap.lookup nm) $ Lens.use primitives-              (_,sp) <- Lens.use curCompNm-              let templ = case bbM of-                            Just p@(P.BlackBox {}) -> Left (name p, template p)-                            _ -> throw (CLaSHException sp ($(curLoc) ++ "No blackbox found for: " ++ unpack nm) Nothing)-              return templ-            Data dc -> do-              tcm <- Lens.use tcCache-              eTy <- termType tcm e-              let (_,resTy) = splitFunTys tcm eTy-              resHTyM <- coreTypeToHWTypeM resTy-              case resHTyM of-                Just resHTy@(SP _ dcArgPairs) -> do-                  let dcI      = dcTag dc - 1-                      dcArgs   = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI-                      dcInps   = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..(length dcArgs - 1)]]-                      dcApp    = DataCon resHTy (DC (resHTy,dcI)) dcInps-                      dcAss    = Assignment (pack "~RESULT") dcApp-                  return (Right dcAss)-                Just resHTy@(Product _ dcArgs) -> do-                  let dcInps = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..(length dcArgs - 1)]]-                      dcApp  = DataCon resHTy (DC (resHTy,0)) dcInps-                      dcAss  = Assignment (pack "~RESULT") dcApp-                  return (Right dcAss)-                Just resHTy@(Vector _ _) -> do-                  let dcInps = [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(1::Int)..2] ]-                      dcApp  = DataCon resHTy (DC (resHTy,1)) dcInps-                      dcAss  = Assignment (pack "~RESULT") dcApp-                  return (Right dcAss)-                _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e-            Var _ fun -> do-              normalized <- Lens.use bindings-              case HashMap.lookup fun normalized of-                Just _ -> do-                  (_,Component compName hidden compInps [compOutp] _) <- preserveVarEnv $ genComponent fun Nothing-                  let hiddenAssigns = map (\(i,t) -> (i,In,t,Identifier i Nothing)) hidden-                      inpAssigns    = zipWith (\(i,t) e' -> (i,In,t,e')) compInps [ Identifier (pack ("~ARG[" ++ show x ++ "]")) Nothing | x <- [(0::Int)..] ]-                      outpAssign    = (fst compOutp,Out,snd compOutp,Identifier (pack "~RESULT") Nothing)-                  i <- varCount <<%= (+1)-                  let instLabel     = Text.concat [compName,pack ("_" ++ show i)]-                      instDecl      = InstDecl compName instLabel (outpAssign:hiddenAssigns ++ inpAssigns)-                  return (Right instDecl)-                Nothing -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e-            _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showDoc e-  case templ of-    Left (_, Left templ') -> do-      l   <- instantiateCompName templ'-      l'  <- setSym l-      l'' <- setClocks bbCtx l'-      l3  <- collectFilePaths bbCtx l''-      return ((Left l3,bbCtx),dcls)-    Left (_, Right templ') -> do-      templ'' <- prettyBlackBox templ'-      let ass = Assignment (pack "~RESULT") (Identifier templ'' Nothing)-      return ((Right ass, bbCtx),dcls)-    Right decl ->-      return ((Right decl,bbCtx),dcls)---- | Instantiate symbols references with a new symbol and increment symbol counter---instantiateSym :: BlackBoxTemplate---               -> NetlistMonad BlackBoxTemplate---instantiateSym l = do---  i <- Lens.use varCount---  ids <- Lens.use seenIds---  let (l',(ids',i')) = setSym ids i l---  varCount .= i'---  seenIds .= ids'---  return l'--instantiateCompName :: BlackBoxTemplate-                    -> NetlistMonad BlackBoxTemplate-instantiateCompName l = do-  (nm,_) <- Lens.use curCompNm-  return (setCompName nm l)--collectFilePaths :: BlackBoxContext-                 -> BlackBoxTemplate-                 -> NetlistMonad BlackBoxTemplate-collectFilePaths bbCtx l = do-  fs <- Lens.use dataFiles-  let (fs',l') = findAndSetDataFiles bbCtx fs l-  dataFiles .= fs'-  return l'
− src/CLaSH/Netlist/BlackBox/Parser.hs 
@@ -1,128 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Parser definitions for BlackBox templates--}--module CLaSH.Netlist.BlackBox.Parser-  (runParse)-where--import           Data.Text.Lazy                           (Text, pack)-import qualified Data.Text.Lazy                           as Text-import           Text.ParserCombinators.UU-import           Text.ParserCombinators.UU.BasicInstances hiding (Parser)-import qualified Text.ParserCombinators.UU.Core           as PCC (parse)-import           Text.ParserCombinators.UU.Utils          hiding (pBrackets)--import           CLaSH.Netlist.BlackBox.Types--type Parser a = P (Str Char Text LineColPos) a----- | Parse a text as a BlackBoxTemplate, returns a list of errors in case--- parsing fails-runParse :: Text -> (BlackBoxTemplate, [Error LineColPos])-runParse = PCC.parse ((,) <$> pBlackBoxD <*> pEnd)-         . createStr (LineColPos 0 0 0)---- | Parse a BlackBoxTemplate (Declarations and Expressions)-pBlackBoxD :: Parser BlackBoxTemplate-pBlackBoxD = pSome pElement---- | Parse a single Template Element-pElement :: Parser Element-pElement  =  pTagD-         <|> C <$> pText-         <|> C <$> (pack <$> pToken "~ ")---- | Parse the Text part of a Template-pText :: Parser Text-pText = pack <$> pList1 (pRange ('\000','\125'))---- | Parse a Declaration or Expression element-pTagD :: Parser Element-pTagD =  IF <$> (pTokenWS "~IF" *> pTagE)-            <*> (pSpaces *> (pToken "~THEN" *> pBlackBoxD))-            <*> (pToken "~ELSE" *> pBlackBoxD <* pToken "~FI")-     <|> D <$> pDecl-     <|> pTagE---- | Parse a Declaration-pDecl :: Parser Decl-pDecl = Decl <$> (pTokenWS "~INST" *> pNatural) <*>-        ((:) <$> pOutput <*> pList pInput) <* pToken "~INST"---- | Parse the output tag of Declaration-pOutput :: Parser (BlackBoxTemplate,BlackBoxTemplate)-pOutput = pTokenWS "~OUTPUT" *> pTokenWS "<=" *> ((,) <$> (pBlackBoxE <* pTokenWS "~") <*> pBlackBoxE) <* pTokenWS "~"---- | Parse the input tag of Declaration-pInput :: Parser (BlackBoxTemplate,BlackBoxTemplate)-pInput = pTokenWS "~INPUT" *> pTokenWS "<=" *> ((,) <$> (pBlackBoxE <* pTokenWS "~") <*> pBlackBoxE) <* pTokenWS "~"---- | Parse an Expression element-pTagE :: Parser Element-pTagE =  O                 <$  pToken "~RESULT"-     <|> I                 <$> (pToken "~ARG" *> pBrackets pNatural)-     <|> L                 <$> (pToken "~LIT" *> pBrackets pNatural)-     <|> (Clk . Just)      <$> (pToken "~CLK" *> pBrackets pNatural)-     <|> Clk Nothing       <$  pToken "~CLKO"-     <|> (Rst . Just)      <$> (pToken "~RST" *> pBrackets pNatural)-     <|> Rst Nothing       <$  pToken "~RSTO"-     <|> (Sym Text.empty)  <$> (pToken "~SYM" *> pBrackets pNatural)-     <|> Typ Nothing       <$  pToken "~TYPO"-     <|> (Typ . Just)      <$> (pToken "~TYP" *> pBrackets pNatural)-     <|> TypM Nothing      <$  pToken "~TYPMO"-     <|> (TypM . Just)     <$> (pToken "~TYPM" *> pBrackets pNatural)-     <|> Err Nothing       <$  pToken "~ERRORO"-     <|> (Err . Just)      <$> (pToken "~ERROR" *> pBrackets pNatural)-     <|> TypElem           <$> (pToken "~TYPEL" *> pBrackets pTagE)-     <|> IndexType         <$> (pToken "~INDEXTYPE" *> pBrackets pTagE)-     <|> CompName          <$  pToken "~COMPNAME"-     <|> QSysIncludeName   <$  pToken "~QSYSINCLUDENAME"-     <|> Size              <$> (pToken "~SIZE" *> pBrackets pTagE)-     <|> Length            <$> (pToken "~LENGTH" *> pBrackets pTagE)-     <|> Depth             <$> (pToken "~DEPTH" *> pBrackets pTagE)-     <|> FilePath          <$> (pToken "~FILE" *> pBrackets pTagE)-     <|> Gen               <$> (True <$ pToken "~GENERATE")-     <|> Gen               <$> (False <$ pToken "~ENDGENERATE")-     <|> SigD              <$> (pToken "~SIGD" *> pBrackets pSigD) <*> (Just <$> (pBrackets pNatural))-     <|> (`SigD` Nothing)  <$> (pToken "~SIGDO" *> pBrackets pSigD)-     <|> IW64              <$  pToken "~IW64"-     <|> (HdlSyn Vivado)   <$  pToken "~VIVADO"-     <|> (HdlSyn Other)    <$  pToken "~OTHERSYN"-     <|> (BV True)         <$> (pToken "~TOBV" *> pBrackets pSigD) <*> pBrackets pTagE-     <|> (BV False)        <$> (pToken "~FROMBV" *> pBrackets pSigD) <*> pBrackets pTagE-     <|> IsLit             <$> (pToken "~ISLIT" *> pBrackets pNatural)-     <|> IsVar             <$> (pToken "~ISVAR" *> pBrackets pNatural)-     <|> GenSym            <$> (pToken "~GENSYM" *> pBrackets pSigD) <*> pBrackets pNatural-     <|> And               <$> (pToken "~AND" *> listParser pTagE)-     <|> Vars              <$> (pToken "~VARS" *> pBrackets pNatural)----- | Parse a bracketed text-pBrackets :: Parser a -> Parser a-pBrackets p = pSym '[' *> p <* pSym ']'---- | Parse a token and eat trailing whitespace-pTokenWS :: String -> Parser String-pTokenWS keyw = pToken keyw <* pSpaces---- | Parse the expression part of Blackbox Templates-pBlackBoxE :: Parser BlackBoxTemplate-pBlackBoxE = pSome pElemE---- | Parse an Expression or Text-pElemE :: Parser Element-pElemE = pTagE-      <|> C <$> pText---- | Parse SigD-pSigD :: Parser [Element]-pSigD = pSome (pTagE <|> (C (pack "[") <$ (pack <$> pToken "[\\"))-                     <|> (C (pack "]") <$ (pack <$> pToken "\\]"))-                     <|> (C <$> (pack <$> pList1 (pRange ('\000','\90'))))-                     <|> (C <$> (pack <$> pList1 (pRange ('\94','\125')))))
− src/CLaSH/Netlist/BlackBox/Types.hs 
@@ -1,66 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Types used in BlackBox modules--}--module CLaSH.Netlist.BlackBox.Types where--import Data.Text.Lazy (Text)---- | A BlackBox Template is a List of Elements-type BlackBoxTemplate = [Element]---- | Elements of a blackbox context-data Element = C   !Text         -- ^ Constant-             | D   !Decl         -- ^ Component instantiation hole-             | O                 -- ^ Output hole-             | I   !Int          -- ^ Input hole-             | L   !Int          -- ^ Literal hole-             | Sym !Text !Int    -- ^ Symbol hole-             | Clk !(Maybe Int)  -- ^ Clock hole (Maybe clk corresponding to-                                 -- input, clk corresponding to output if Nothing)-             | Rst !(Maybe Int)  -- ^ Reset hole-             | Typ !(Maybe Int)  -- ^ Type declaration hole-             | TypM !(Maybe Int) -- ^ Type root hole-             | Err !(Maybe Int)  -- ^ Error value hole-             | TypElem !Element  -- ^ Select element type from a vector type-             | CompName          -- ^ Hole for the name of the component in which-                                 -- the blackbox is instantiated-             | QSysIncludeName-             | IndexType !Element -- ^ Index data type hole, the field is the-                                  -- (exclusive) maximum index-             | Size !Element     -- ^ Size of a type hole-             | Length !Element   -- ^ Length of a vector hole-             | Depth !Element    -- ^ Depth of a tree hole-             | FilePath !Element -- ^ Hole containing a filepath for a data file-             | Gen !Bool         -- ^ Hole marking beginning (True) or end (False)-                                 -- of a generative construct-             | IF !Element [Element] [Element]-             | And [Element]-             | IW64              -- ^ Hole indicating whether Int/Word/Integer-                                 -- are 64-Bit-             | HdlSyn HdlSyn     -- ^ Hole indicating which synthesis tool we're-                                 -- generating HDL for-             | BV !Bool [Element] !Element -- ^ Convert to (True)/from(False) a bit-vector-             | IsLit !Int-             | IsVar !Int-             | Vars !Int-             | GenSym [Element] !Int-             | SigD [Element] !(Maybe Int)-  deriving Show---- | Component instantiation hole. First argument indicates which function argument--- to instantiate. Second argument corresponds to output and input assignments,--- where the first element is the output assignment, and the subsequent elements--- are the consecutive input assignments.------ The LHS of the tuple is the name of the signal, while the RHS of the tuple--- is the type of the signal-data Decl = Decl !Int [(BlackBoxTemplate,BlackBoxTemplate)]-  deriving Show--data HdlSyn = Vivado | Other-  deriving (Eq,Show,Read)
− src/CLaSH/Netlist/BlackBox/Util.hs 
@@ -1,507 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Utilties to verify blackbox contexts against templates and rendering filled-  in templates--}--{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE ViewPatterns      #-}--module CLaSH.Netlist.BlackBox.Util where----import           Control.Lens                         (at, use, (%=), (+=), _1,---                                                       _2)-import           Control.Exception                    (throw)-import           Control.Monad.State                  (State, StateT, evalStateT,-                                                       lift, modify, get)-import           Control.Monad.Writer.Strict          (MonadWriter, tell)-import           Data.Bool                            (bool)-import           Data.Foldable                        (foldrM)-import qualified Data.IntMap                          as IntMap-import           Data.List                            (mapAccumL, nub)-import           Data.Set                             (Set,singleton)-import           Data.Text.Lazy                       (Text)-import qualified Data.Text.Lazy                       as Text-import           System.FilePath                      (replaceBaseName,-                                                       takeBaseName,-                                                       takeFileName)-import           Text.PrettyPrint.Leijen.Text.Monadic (displayT, renderCompact,-                                                       renderOneLine, brackets,-                                                       int, (<>), text, (<+>),-                                                       vcat, (<$$>), nest)-import qualified Text.PrettyPrint.Leijen.Text.Monadic as PP--import           CLaSH.Backend                        (Backend (..))-import           CLaSH.Driver.Types                   (CLaSHException (..))-import           CLaSH.Netlist.BlackBox.Parser-import           CLaSH.Netlist.BlackBox.Types-import           CLaSH.Netlist.Types                  (HWType (..), Identifier,-                                                       BlackBoxContext (..),-                                                       SyncExpr, Expr (..),-                                                       Literal (..), NetlistMonad,-                                                       Modifier (..))-import qualified CLaSH.Netlist.Types                  as N-import           CLaSH.Netlist.Util                   (mkUniqueIdentifier,typeSize)-import           CLaSH.Util---- | Determine if the number of normal/literal/function inputs of a blackbox--- context at least matches the number of argument that is expected by the--- template.-verifyBlackBoxContext :: BlackBoxContext -- ^ Blackbox to verify-                      -> BlackBoxTemplate -- ^ Template to check against-                      -> Bool-verifyBlackBoxContext bbCtx = all verify'-  where-    verify' (I n)           = n < length (bbInputs bbCtx)-    verify' (L n)           = case indexMaybe (bbInputs bbCtx) n of-                                Just (_,_,b) -> b-                                _            -> False-    verify' (Clk (Just n))  = n < length (bbInputs bbCtx)-    verify' (Rst (Just n))  = n < length (bbInputs bbCtx)-    verify' (Typ (Just n))  = n < length (bbInputs bbCtx)-    verify' (TypM (Just n)) = n < length (bbInputs bbCtx)-    verify' (Err (Just n))  = n < length (bbInputs bbCtx)-    verify' (D (Decl n l')) = case IntMap.lookup n (bbFunctions bbCtx) of-                                Just _ -> all (\(x,y) -> verifyBlackBoxContext bbCtx x &&-                                                         verifyBlackBoxContext bbCtx y) l'-                                _      -> False-    verify' _               = True--extractLiterals :: BlackBoxContext-                -> [Expr]-extractLiterals = map (\case (e,_,_) -> either id fst e)-                . filter (\case (_,_,b) -> b)-                . bbInputs---- | Update all the symbol references in a template, and increment the symbol--- counter for every newly encountered symbol.-setSym :: BlackBoxTemplate-       -> NetlistMonad BlackBoxTemplate---setSym l = second fst---  $ runState (setSym' l) ((ids,i),IntMap.empty)-setSym l = evalStateT (mapM setSym' l) IntMap.empty-  where-    setSym' :: Element-            -> StateT (IntMap.IntMap Identifier)-                      NetlistMonad-                      Element-    setSym' e = case e of-      Sym _ i -> do-        symM <- IntMap.lookup i <$> get-        case symM of-          Nothing -> do-            t <- lift (mkUniqueIdentifier (Text.pack "n"))-            modify (IntMap.insert i t)-            return (Sym t i)-          Just t -> return (Sym t i)-      GenSym t i -> do-        symM <- IntMap.lookup i <$> get-        case symM of-          Nothing -> do-            t' <- lift (mkUniqueIdentifier (concatT t))-            modify (IntMap.insert i t')-            return (GenSym [C t'] i)-          Just _ -> error ("Symbol #" ++ show (t,i) ++ " is already defined")-      D (Decl n l') -> D <$> (Decl n <$> mapM (combineM (mapM setSym') (mapM setSym')) l')-      IF c t f      -> IF <$> pure c <*> mapM setSym' t <*> mapM setSym' f-      SigD e' m     -> SigD <$> (mapM setSym' e') <*> pure m-      BV t e' m     -> BV <$> pure t <*> mapM setSym' e' <*> pure m-      _             -> pure e--    concatT :: [Element] -> Text-    concatT = Text.concat-            . map (\case {C t -> t; _ -> error "unexpected element in GENSYM"})--setCompName :: Identifier -> BlackBoxTemplate -> BlackBoxTemplate-setCompName nm = map setCompName'-  where-    setCompName' CompName       = C nm-    setCompName' (D (Decl n l)) = D (Decl n (map (setCompName nm *** setCompName nm) l))-    setCompName' (IF c t f)     = IF c (setCompName nm t) (setCompName nm f)-    setCompName' (GenSym es i)  = GenSym (setCompName nm es) i-    setCompName' (BV t e m)     = BV t (setCompName nm e) (setCompName' m)-    setCompName' e              = e--setClocks :: MonadWriter (Set (Identifier,HWType)) m-          => BlackBoxContext-          -> BlackBoxTemplate-          -> m BlackBoxTemplate-setClocks bc bt = mapM setClocks' bt-  where-    setClocks' (D (Decl n l)) = D <$> (Decl n <$> mapM (combineM (setClocks bc) (setClocks bc)) l)-    setClocks' (IF c t f)     = IF <$> pure c <*> setClocks bc t <*> setClocks bc f-    setClocks' (SigD e m)     = SigD <$> (setClocks bc e) <*> pure m-    setClocks' (BV t e m)     = BV <$> pure t <*> setClocks bc e <*> pure m--    setClocks' (Clk Nothing)  = let (clk,rate) = clkSyncId $ fst $ bbResult bc-                                    clkName    = Text.append clk (Text.pack (show rate))-                                in  tell (singleton (clkName,Clock clk rate)) >> return (C clkName)-    setClocks' (Clk (Just n)) = let (e,_,_)    = bbInputs bc !! n-                                    (clk,rate) = clkSyncId e-                                    clkName    = Text.append clk (Text.pack (show rate))-                                in  tell (singleton (clkName,Clock clk rate)) >> return (C clkName)--    setClocks' (Rst Nothing)  = let (rst,rate) = clkSyncId $ fst $ bbResult bc-                                    rstName    = Text.concat [rst,Text.pack (show rate),"_rstn"]-                                in  tell (singleton (rstName,Reset rst rate)) >> return (C rstName)-    setClocks' (Rst (Just n)) = let (e,_,_)    = bbInputs bc !! n-                                    (rst,rate) = clkSyncId e-                                    rstName    = Text.concat [rst,Text.pack (show rate),"_rstn"]-                                in  tell (singleton (rstName,Reset rst rate)) >> return (C rstName)--    setClocks' e = return e--findAndSetDataFiles :: BlackBoxContext -> [(String,FilePath)] -> BlackBoxTemplate -> ([(String,FilePath)],BlackBoxTemplate)-findAndSetDataFiles bbCtx fs = mapAccumL findAndSet fs-  where-    findAndSet fs' (FilePath e) = case e of-      (L n) ->-        let (s,_,_) = bbInputs bbCtx !! n-            e'      = either id fst s-        in case e' of-          BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ bbCtx' _ -> case bbInputs bbCtx' of-            [(Left (Literal Nothing (StringLit s')),_,_)] -> renderFilePath fs s'-            _ -> (fs',FilePath e)-          Literal Nothing (StringLit s') -> renderFilePath fs s'-          _ -> (fs',FilePath e)-      _ -> (fs',FilePath e)-    findAndSet fs' l = (fs',l)--renderFilePath :: [(String,FilePath)] -> String -> ([(String,FilePath)],Element)-renderFilePath fs f = ((f'',f):fs,C (Text.pack $ show f''))-  where-    f'  = takeFileName f-    f'' = selectNewName (map fst fs) f'--    selectNewName as a-      | elem a as = selectNewName as (replaceBaseName a (takeBaseName a ++ "_"))-      | otherwise = a----- | Get the name of the clock of an identifier-clkSyncId :: SyncExpr -> (Identifier,Integer)-clkSyncId (Right (_,clk)) = clk-clkSyncId (Left i) = error $ $(curLoc) ++ "No clock for: " ++ show i---- | Render a blackbox given a certain context. Returns a filled out template--- and a list of 'hidden' inputs that must be added to the encompassing component.-renderBlackBox :: Backend backend-               => BlackBoxTemplate -- ^ Blackbox template-               -> BlackBoxContext -- ^ Context used to fill in the hole-               -> State backend Text-renderBlackBox l bbCtx-  = fmap Text.concat-  $ mapM (renderElem bbCtx) l---- | Render a single template element-renderElem :: Backend backend-           => BlackBoxContext-           -> Element-           -> State backend Text-renderElem b (D (Decl n (l:ls))) = do-    (o,oTy,_) <- syncIdToSyncExpr <$> combineM (lineToIdentifier b) (return . lineToType b) l-    is <- mapM (fmap syncIdToSyncExpr . combineM (lineToIdentifier b) (return . lineToType b)) ls-    let Just (templ,pCtx)    = IntMap.lookup n (bbFunctions b)-        b' = pCtx { bbResult = (o,oTy), bbInputs = bbInputs pCtx ++ is }-    templ' <- case templ of-                Left t  -> return t-                Right d -> do Just inst' <- inst d-                              return . parseFail . displayT $ renderCompact inst'-    if verifyBlackBoxContext b' templ'-      then Text.concat <$> mapM (renderElem b') templ'-      else do-        sp <- getSrcSpan-        throw (CLaSHException sp ($(curLoc) ++ "\nCan't match context:\n" ++ show b' ++ "\nwith template:\n" ++ show templ) Nothing)--renderElem b (SigD e m) = do-  e' <- Text.concat <$> mapM (renderElem b) e-  let ty = case m of-             Nothing -> snd $ bbResult b-             Just n  -> let (_,ty',_) = bbInputs b !! n-                        in  ty'-  t  <- hdlSig e' ty-  return (displayT $ renderOneLine t)--renderElem b (IF c t f) = do-  iw <- iwWidth-  syn <- hdlSyn-  let c' = check iw syn c-  if c' > 0 then renderBlackBox t b else renderBlackBox f b-  where-    check iw syn c' = case c' of-      (Size e)   -> typeSize (lineToType b [e])-      (Length e) -> case lineToType b [e] of-                       (Vector n _) -> n-                       _ -> error $ $(curLoc) ++ "IF: veclen of a non-vector type"-      (L n) -> case bbInputs b !! n of-        (l,_,_)-          | Literal _ l' <- either id fst l ->-            case l' of-              NumLit i -> fromInteger i-              BitLit bl -> case bl of-                N.H -> 1-                N.L -> 0-                _   -> error $ $(curLoc) ++ "IF: LIT bit literal must be high or low"-              BoolLit bl -> bool 0 1 bl-              _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit"-          | DataCon (Signed _) _ [Literal _ (NumLit i)] <- either id fst l-            -> fromInteger i-        k -> error $ $(curLoc) ++ ("IF: LIT must be a numeric lit:" ++ show k)-      (Depth e)  -> case lineToType b [e] of-                      (RTree n _) -> n-                      _ -> error $ $(curLoc) ++ "IF: treedepth of non-tree type"-      IW64       -> if iw == 64 then 1 else 0-      (HdlSyn s) -> if s == syn then 1 else 0-      (IsVar n)  -> let (s,_,_) = bbInputs b !! n-                        e       = either id fst s-                    in case e of-                      Identifier _ Nothing -> 1-                      _ -> 0-      (IsLit n)  -> let (s,_,_) = bbInputs b !! n-                        e       = either id fst s-                    in case e of-                      DataCon {} -> 1-                      Literal {} -> 1-                      BlackBoxE {} -> 1-                      _ -> 0-      (And es)   -> if all (==1) (map (check iw syn) es)-                       then 1-                       else 0-      _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGTH, IW64, LIT, ISLIT, or ISARG"--renderElem b e = renderTag b e--parseFail :: Text -> BlackBoxTemplate-parseFail t = case runParse t of-                    (templ,err) | null err  -> templ-                                | otherwise -> error $ $(curLoc) ++ "\nTemplate:\n" ++ show t ++ "\nHas errors:\n" ++ show err--syncIdToSyncExpr :: (Text,HWType)-                 -> (SyncExpr,HWType,Bool)-syncIdToSyncExpr (t,ty) = (Left (Identifier t Nothing),ty,False)---- | Fill out the template corresponding to an output/input assignment of a--- component instantiation, and turn it into a single identifier so it can--- be used for a new blackbox context.-lineToIdentifier :: Backend backend-                 => BlackBoxContext-                 -> BlackBoxTemplate-                 -> State backend Text-lineToIdentifier b = foldrM (\e a -> do-                              e' <- renderTag b e-                              return (e' `Text.append` a)-                   ) Text.empty--lineToType :: BlackBoxContext-           -> BlackBoxTemplate-           -> HWType-lineToType b [(Typ Nothing)]  = snd $ bbResult b-lineToType b [(Typ (Just n))] = let (_,ty,_) = bbInputs b !! n-                                in  ty-lineToType b [(TypElem t)]    = case lineToType b [t] of-                                  Vector _ elTy -> elTy-                                  _ -> error $ $(curLoc) ++ "Element type selection of a non-vector type"-lineToType b [(IndexType (L n))] =-  case bbInputs b !! n of-    (Left (Literal _ (NumLit n')),_,_) -> Index (fromInteger n')-    x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x--lineToType _ _ = error $ $(curLoc) ++ "Unexpected type manipulation"---- | Give a context and a tagged hole (of a template), returns part of the--- context that matches the tag of the hole.-renderTag :: Backend backend-          => BlackBoxContext-          -> Element-          -> State backend Text-renderTag _ (C t)           = return t-renderTag b O               = fmap (displayT . renderOneLine) . expr False . either id fst . fst $ bbResult b-renderTag b (I n)           = let (s,_,_) = bbInputs b !! n-                                  e       = either id fst s-                              in  (displayT . renderOneLine) <$> expr False e-renderTag b (L n)           = let (s,_,_) = bbInputs b !! n-                                  e       = either id fst s-                              in  (displayT . renderOneLine) <$> expr False (mkLit e)-  where-    mkLit (Literal (Just (Signed _,_)) i) = Literal Nothing i-    mkLit (DataCon _ (DC (Void, _)) [Literal (Just (Signed _,_)) i]) = Literal Nothing i-    mkLit i                               = i--renderTag _ (Sym t _) = return t--renderTag b (BV True es e) = do-  e' <- Text.concat <$> mapM (renderElem b) es-  let ty = lineToType b [e]-  (displayT . renderOneLine) <$> toBV ty e'-renderTag b (BV False es e) = do-  e' <- Text.concat <$> mapM (renderElem b) es-  let ty = lineToType b [e]-  (displayT . renderOneLine) <$> fromBV ty e'--renderTag b (Typ Nothing)   = fmap (displayT . renderOneLine) . hdlType . snd $ bbResult b-renderTag b (Typ (Just n))  = let (_,ty,_) = bbInputs b !! n-                              in  (displayT . renderOneLine) <$> hdlType ty-renderTag b (TypM Nothing)  = fmap (displayT . renderOneLine) . hdlTypeMark . snd $ bbResult b-renderTag b (TypM (Just n)) = let (_,ty,_) = bbInputs b !! n-                              in  (displayT . renderOneLine) <$> hdlTypeMark ty-renderTag b (Err Nothing)   = fmap (displayT . renderOneLine) . hdlTypeErrValue . snd $ bbResult b-renderTag b (Err (Just n))  = let (_,ty,_) = bbInputs b !! n-                              in  (displayT . renderOneLine) <$> hdlTypeErrValue ty-renderTag b (Size e)        = return . Text.pack . show . typeSize $ lineToType b [e]-renderTag b (Length e)      = return . Text.pack . show . vecLen $ lineToType b [e]-  where-    vecLen (Vector n _) = n-    vecLen _            = error $ $(curLoc) ++ "vecLen of a non-vector type"-renderTag b (Depth e)      = return . Text.pack . show . treeDepth $ lineToType b [e]-  where-    treeDepth (RTree n _) = n-    treeDepth _           = error $ $(curLoc) ++ "treeDepth of a non-tree type"-renderTag b e@(TypElem _)   = let ty = lineToType b [e]-                              in  (displayT . renderOneLine) <$> hdlType ty-renderTag _ (Gen b)         = displayT . renderOneLine <$> genStmt b-renderTag _ (GenSym [C t] _) = return t-renderTag b (Vars n)        =-  let (s,_,_) = bbInputs b !! n-      e       = either id fst s--      go (Identifier i _) = [i]-      go (DataCon _ _ es) = concatMap go es-      go (DataTag _ e')   = [either id id e']-      go _                = []--      vars    = go e-  in  case vars of-        [] -> return Text.empty-        _  -> return (Text.concat $ map (Text.cons ',') vars)-renderTag b (IndexType (L n)) =-  case bbInputs b !! n of-    (Left (Literal _ (NumLit n')),_,_) ->-      let hty = Index (fromInteger n')-      in  fmap (displayT . renderOneLine) (hdlType hty)-    x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x-renderTag b (FilePath e)    = case e of-  L n -> do-    let (s,_,_) = bbInputs b !! n-        e'      = either id fst s-    e2  <- prettyElem e-    case e' of-      BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ bbCtx' _ -> case bbInputs bbCtx' of-        [(Left (Literal Nothing (StringLit _)),_,_)] -> error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++  "does not reduce to a string"-        _ ->  error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++  "does not reduce to a string"-      _ -> error $ $(curLoc) ++ "argument of ~FILEPATH:" ++ show e2 ++  "does not reduce to a string"-  _ -> do e' <- prettyElem e-          error $ $(curLoc) ++ "~FILEPATH expects a ~LIT[N] argument, but got: " ++ show e'-renderTag b QSysIncludeName = case bbQsysIncName b of-  Just nm -> return nm-  _ -> error $ $(curLoc) ++ "~QSYSINCLUDENAME used where no 'qysInclude' was specified in the primitive definition"-renderTag _ e = do e' <- prettyElem e-                   error $ $(curLoc) ++ "Unable to evaluate: " ++ show e'--prettyBlackBox :: Monad m-               => BlackBoxTemplate-               -> m Text-prettyBlackBox bbT = Text.concat <$> mapM prettyElem bbT--prettyElem :: Monad m-           => Element-           -> m Text-prettyElem (C t) = return t-prettyElem (D (Decl i args)) = do-  args' <- mapM (\(a,b) -> (,) <$> prettyBlackBox a <*> prettyBlackBox b) args-  (displayT . renderOneLine) <$>-    (nest 2 (text "~INST" <+> int i <$$>-        text "~OUTPUT" <+> text "=>" <+> text (fst (head args')) <+> text (snd (head args')) <+> text "~" <$$>-        vcat (mapM (\(a,b) -> text "~INPUT" <+> text "=>" <+> text a <+> text b <+> text "~") (tail args')))-      PP.<$$> text "~INST")-prettyElem O = return "~RESULT"-prettyElem (I i) = (displayT . renderOneLine) <$> (text "~ARG" <> brackets (int i))-prettyElem (L i) = (displayT . renderOneLine) <$> (text "~LIT" <> brackets (int i))-prettyElem (Sym _ i) = (displayT . renderOneLine) <$> (text "~SYM" <> brackets (int i))-prettyElem (Clk Nothing) = return "~CLKO"-prettyElem (Clk (Just i)) = (displayT . renderOneLine) <$> (text "~CLK" <> brackets (int i))-prettyElem (Rst Nothing) = return "~RSTO"-prettyElem (Rst (Just i)) = (displayT . renderOneLine) <$> (text "~RSTO" <> brackets (int i))-prettyElem (Typ Nothing) = return "~TYPO"-prettyElem (Typ (Just i)) = (displayT . renderOneLine) <$> (text "~TYP" <> brackets (int i))-prettyElem (TypM Nothing) = return "~TYPMO"-prettyElem (TypM (Just i)) = (displayT . renderOneLine) <$> (text "~TYPM" <> brackets (int i))-prettyElem (Err Nothing) = return "~ERRORO"-prettyElem (Err (Just i)) = (displayT . renderOneLine) <$> (text "~ERROR" <> brackets (int i))-prettyElem (TypElem e) = do-  e' <- prettyElem e-  (displayT . renderOneLine) <$> (text "~TYPEL" <> brackets (text e'))-prettyElem CompName = return "~COMPNAME"-prettyElem QSysIncludeName = return "~QSYSINCLUDENAME"-prettyElem (IndexType e) = do-  e' <- prettyElem e-  (displayT . renderOneLine) <$> (text "~INDEXTYPE" <> brackets (text e'))-prettyElem (Size e) = do-  e' <- prettyElem e-  (displayT . renderOneLine) <$> (text "~SIZE" <> brackets (text e'))-prettyElem (Length e) = do-  e' <- prettyElem e-  (displayT . renderOneLine) <$> (text "~LENGTH" <> brackets (text e'))-prettyElem (Depth e) = do-  e' <- prettyElem e-  (displayT . renderOneLine) <$> (text "~DEPTH" <> brackets (text e'))-prettyElem (FilePath e) = do-  e' <- prettyElem e-  (displayT . renderOneLine) <$> (text "~FILE" <> brackets (text e'))-prettyElem (Gen b) = if b then return "~GENERATE" else return "~ENDGENERATE"-prettyElem (IF b esT esF) = do-  b' <- prettyElem b-  esT' <- prettyBlackBox esT-  esF' <- prettyBlackBox esF-  (displayT . renderCompact) <$>-    (text "~IF" <+> text b' <+> text "~THEN" <>-     text esT' <>-     text "~ELSE" <>-     text esF' <>-     text "~FI")-prettyElem (And es) =-  (displayT . renderCompact) <$>-  (PP.brackets (PP.tupled $ mapM (text <=< prettyElem) es))-prettyElem IW64 = return "~IW64"-prettyElem (HdlSyn s) = case s of-  Vivado -> return "~VIVADO"-  _ -> return "~OTHERSYN"-prettyElem (BV b es e) = do-  es' <- prettyBlackBox es-  e'  <- prettyBlackBox [e]-  (displayT . renderOneLine) <$>-    if b-       then text "~TOBV" <> brackets (text es') <> brackets (text e')-       else text "~FROMBV" <> brackets (text es') <> brackets (text e')-prettyElem (IsLit i) = (displayT . renderOneLine) <$> (text "~ISLIT" <> brackets (int i))-prettyElem (IsVar i) = (displayT . renderOneLine) <$> (text "~ISVAR" <> brackets (int i))-prettyElem (GenSym es i) = do-  es' <- prettyBlackBox es-  (displayT . renderOneLine) <$> (text "~GENSYM" <> brackets (text es') <> brackets (int i))-prettyElem (SigD es mI) = do-  es' <- prettyBlackBox es-  (displayT . renderOneLine) <$>-    (maybe (text "~SIGDO" <> brackets (text es'))-           (((text "~SIGD" <> brackets (text es')) <>) . int)-           mI)-prettyElem (Vars i) = (displayT . renderOneLine) <$> (text "~VARS" <> brackets (int i))--usedArguments :: BlackBoxTemplate-              -> [Int]-usedArguments = nub . concatMap go-  where-    go x = case x of-      D (Decl i args) -> i : concatMap (\(a,b) -> usedArguments a ++ usedArguments b) args-      I i -> [i]-      L i -> [i]-      IndexType e -> go e-      FilePath e -> go e-      IF b esT esF -> go b ++ usedArguments esT ++ usedArguments esF-      SigD es _ -> usedArguments es-      BV _ es _ -> usedArguments es-      _ -> []
− src/CLaSH/Netlist/Id.hs 
@@ -1,115 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier--}--{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns      #-}--module CLaSH.Netlist.Id-  ( mkBasicId'-  , stripDollarPrefixes-  )-where--#ifndef MIN_VERSION_text-#error MIN_VERSION_text undefined-#endif--import Data.Char      (isAsciiLower,isAsciiUpper,isDigit)-import Data.Text.Lazy as Text--mkBasicId' :: Bool-           -> Text-           -> Text-mkBasicId' tupEncode = stripMultiscore . stripLeading . zEncode tupEncode-  where-    stripLeading    = Text.dropWhile (`elem` ('_':['0'..'9']))-    stripMultiscore = Text.concat-                    . Prelude.map (\cs -> case Text.head cs of-                                            '_' -> "_"-                                            _   -> cs-                                  )-                    . Text.group--stripDollarPrefixes :: Text -> Text-stripDollarPrefixes = stripWorkerPrefix . stripSpecPrefix . stripConPrefix-                    . stripWorkerPrefix . stripDictFunPrefix-  where-    stripDictFunPrefix t = case Text.stripPrefix "$f" t of-                             Just k  -> takeWhileEnd (/= '_') k-                             Nothing -> t--#if !MIN_VERSION_text(1,2,2)-    takeWhileEnd p = Text.reverse . Text.takeWhile p . Text.reverse-#endif--    stripWorkerPrefix t = case Text.stripPrefix "$w" t of-                              Just k  -> k-                              Nothing -> t--    stripConPrefix t = case Text.stripPrefix "$c" t of-                         Just k  -> k-                         Nothing -> t--    stripSpecPrefix t = case Text.stripPrefix "$s" t of-                          Just k -> k-                          Nothing -> t -- snd (Text.breakOnEnd "$s" t)---type UserString    = Text -- As the user typed it-type EncodedString = Text -- Encoded form--zEncode :: Bool -> UserString -> EncodedString-zEncode False cs = go (uncons cs)-  where-    go Nothing         = empty-    go (Just (c,cs'))  = append (encodeDigitCh c) (go' $ uncons cs')-    go' Nothing        = empty-    go' (Just (c,cs')) = append (encodeCh c) (go' $ uncons cs')--zEncode True cs = case maybeTuple cs of-                    Just (n,cs') -> append n (go' (uncons cs'))-                    Nothing      -> go (uncons cs)-  where-    go Nothing         = empty-    go (Just (c,cs'))  = append (encodeDigitCh c) (go' $ uncons cs')-    go' Nothing        = empty-    go' (Just (c,cs')) = case maybeTuple (cons c cs') of-                           Just (n,cs2) -> append n (go' $ uncons cs2)-                           Nothing      -> append (encodeCh c) (go' $ uncons cs')--encodeDigitCh :: Char -> EncodedString-encodeDigitCh c | isDigit c = Text.empty -- encodeAsUnicodeChar c-encodeDigitCh c             = encodeCh c--encodeCh :: Char -> EncodedString-encodeCh c | unencodedChar c = singleton c     -- Common case first-           | otherwise       = Text.empty--unencodedChar :: Char -> Bool   -- True for chars that don't need encoding-unencodedChar c  = or [ isAsciiLower c-                      , isAsciiUpper c-                      , isDigit c-                      , c == '_']--maybeTuple :: UserString -> Maybe (EncodedString,UserString)-maybeTuple "(# #)" = Just ("Unit",empty)-maybeTuple "()"    = Just ("Unit",empty)-maybeTuple (uncons -> Just ('(',uncons -> Just ('#',cs))) =-  case countCommas 0 cs of-    (n,uncons -> Just ('#',uncons -> Just (')',cs'))) -> Just (pack ("Tup" ++ show (n+1)),cs')-    _ -> Nothing-maybeTuple (uncons -> Just ('(',cs)) =-  case countCommas 0 cs of-    (n,uncons -> Just (')',cs')) -> Just (pack ("Tup" ++ show (n+1)),cs')-    _ -> Nothing-maybeTuple _  = Nothing--countCommas :: Int -> UserString -> (Int,UserString)-countCommas n (uncons -> Just (',',cs)) = countCommas (n+1) cs-countCommas n cs                        = (n,cs)
− src/CLaSH/Netlist/Types.hs 
@@ -1,196 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Type and instance definitions for Netlist modules--}--{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell            #-}--module CLaSH.Netlist.Types where--import Control.DeepSeq-import Control.Monad.State.Strict           (MonadIO, MonadState, StateT)-import Control.Monad.Writer.Strict          (MonadWriter, WriterT)-import Data.Hashable-import Data.HashMap.Lazy                    (HashMap)-import Data.IntMap.Lazy                     (IntMap, empty)-import Data.Set                             (Set)-import qualified Data.Text                  as S-import Data.Text.Lazy                       (Text, pack)-import GHC.Generics                         (Generic)-import Unbound.Generics.LocallyNameless              (Fresh, FreshMT)--import SrcLoc                               (SrcSpan)--import CLaSH.Core.Term                      (Term, TmName)-import CLaSH.Core.Type                      (Type)-import CLaSH.Core.TyCon                     (TyCon, TyConName)-import CLaSH.Core.Util                      (Gamma)-import CLaSH.Netlist.BlackBox.Types-import CLaSH.Primitives.Types               (PrimMap)-import CLaSH.Util---- | Monad that caches generated components (StateT) and remembers hidden inputs--- of components that are being generated (WriterT)-newtype NetlistMonad a =-  NetlistMonad { runNetlist :: WriterT-                               (Set (Identifier,HWType))-                               (StateT NetlistState (FreshMT IO))-                               a-               }-  deriving (Functor, Monad, Applicative, MonadWriter (Set (Identifier,HWType)),-            MonadState NetlistState, Fresh, MonadIO)---- | State of the NetlistMonad-data NetlistState-  = NetlistState-  { _bindings       :: HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders-  , _varEnv         :: Gamma -- ^ Type environment/context-  , _varCount       :: !Int -- ^ Number of signal declarations-  , _components     :: HashMap TmName (SrcSpan,Component) -- ^ Cached components-  , _primitives     :: PrimMap BlackBoxTemplate -- ^ Primitive Definitions-  , _typeTranslator :: HashMap TyConName TyCon -> Type -> Maybe (Either String HWType) -- ^ Hardcoded Type -> HWType translator-  , _tcCache        :: HashMap TyConName TyCon -- ^ TyCon cache-  , _curCompNm      :: !(Identifier,SrcSpan)-  , _dataFiles      :: [(String,FilePath)]-  , _intWidth       :: Int-  , _mkBasicIdFn    :: Identifier -> Identifier-  , _seenIds        :: [Identifier]-  , _seenComps      :: [Identifier]-  , _componentNames :: HashMap TmName Identifier-  }---- | Signal reference-type Identifier = Text---- | Component: base unit of a Netlist-data Component-  = Component-  { componentName :: !Identifier -- ^ Name of the component-  , hiddenPorts   :: [(Identifier,HWType)] -- ^ Ports that have no correspondence the original function definition-  , inputs        :: [(Identifier,HWType)] -- ^ Input ports-  , outputs       :: [(Identifier,HWType)] -- ^ Output ports-  , declarations  :: [Declaration] -- ^ Internal declarations-  }-  deriving Show--instance NFData Component where-  rnf c = case c of-    Component nm hi inps outps decls -> rnf nm `seq` rnf hi `seq` rnf inps `seq`-                                        rnf outps `seq` rnf decls---- | Size indication of a type (e.g. bit-size or number of elements)-type Size = Int---- | Representable hardware types-data HWType-  = Void -- ^ Empty type-  | String -- ^ String type-  | Bool -- ^ Boolean type-  | BitVector !Size -- ^ BitVector of a specified size-  | Index    !Integer -- ^ Unsigned integer with specified (exclusive) upper bounder-  | Signed   !Size -- ^ Signed integer of a specified size-  | Unsigned !Size -- ^ Unsigned integer of a specified size-  | Vector   !Size       !HWType -- ^ Vector type-  | RTree    !Size       !HWType -- ^ RTree type-  | Sum      !Identifier [Identifier] -- ^ Sum type: Name and Constructor names-  | Product  !Identifier [HWType] -- ^ Product type: Name and field types-  | SP       !Identifier [(Identifier,[HWType])] -- ^ Sum-of-Product type: Name and Constructor names + field types-  | Clock    !Identifier !Integer -- ^ Clock type with specified name and period-  | Reset    !Identifier !Integer -- ^ Reset type corresponding to clock with a specified name and period-  deriving (Eq,Ord,Show,Generic)--instance Hashable HWType-instance NFData HWType---- | Internals of a Component-data Declaration-  = Assignment !Identifier !Expr-  -- ^ Signal assignment:-  ---  -- * Signal to assign-  ---  -- * Assigned expression-  | CondAssignment !Identifier !HWType !Expr !HWType [(Maybe Literal,Expr)]-  -- ^ Conditional signal assignment:-  ---  -- * Signal to assign-  ---  -- * Type of the result/alternatives-  ---  -- * Scrutinized expression-  ---  -- * Type of the scrutinee-  ---  -- * List of: (Maybe expression scrutinized expression is compared with,RHS of alternative)-  | InstDecl !Identifier !Identifier [(Identifier,PortDirection,HWType,Expr)] -- ^ Instantiation of another component-  | BlackBoxD !S.Text [S.Text] [S.Text] (Maybe (S.Text,BlackBoxTemplate)) !BlackBoxTemplate BlackBoxContext -- ^ Instantiation of blackbox declaration-  | NetDecl !Identifier !HWType -- ^ Signal declaration-  deriving Show--data PortDirection = In | Out-  deriving Show--instance NFData Declaration where-  rnf a = a `seq` ()---- | Expression Modifier-data Modifier-  = Indexed (HWType,Int,Int) -- ^ Index the expression: (Type of expression,DataCon tag,Field Tag)-  | DC (HWType,Int) -- ^ See expression in a DataCon context: (Type of the expression, DataCon tag)-  | VecAppend -- ^ See the expression in the context of a Vector append operation-  | RTreeAppend -- ^ See the expression in the context of a Tree append operation-  deriving Show---- | Expression used in RHS of a declaration-data Expr-  = Literal    !(Maybe (HWType,Size)) !Literal -- ^ Literal expression-  | DataCon    !HWType       !Modifier  [Expr] -- ^ DataCon application-  | Identifier !Identifier   !(Maybe Modifier) -- ^ Signal reference-  | DataTag    !HWType       !(Either Identifier Identifier) -- ^ @Left e@: tagToEnum#, @Right e@: dataToTag#-  | BlackBoxE !S.Text [S.Text] [S.Text] (Maybe (S.Text,BlackBoxTemplate)) !BlackBoxTemplate !BlackBoxContext !Bool -- ^ Instantiation of a BlackBox expression-  deriving Show---- | Literals used in an expression-data Literal-  = NumLit    !Integer   -- ^ Number literal-  | BitLit    !Bit       -- ^ Bit literal-  | BoolLit   !Bool      -- ^ Boolean literal-  | VecLit    [Literal] -- ^ Vector literal-  | StringLit !String    -- ^ String literal-  deriving (Eq,Show)---- | Bit literal-data Bit-  = H -- ^ High-  | L -- ^ Low-  | U -- ^ Undefined-  | Z -- ^ High-impedance-  deriving (Eq,Show)---- | Context used to fill in the holes of a BlackBox template-data BlackBoxContext-  = Context-  { bbResult    :: (SyncExpr,HWType) -- ^ Result name and type-  , bbInputs    :: [(SyncExpr,HWType,Bool)] -- ^ Argument names, types, and whether it is a literal-  , bbFunctions :: IntMap (Either BlackBoxTemplate Declaration,BlackBoxContext)-  -- ^ Function arguments (subset of inputs):-  ---  -- * (Blackbox Template,Partial Blackbox Concext)-  , bbQsysIncName :: Maybe Identifier-  }-  deriving Show--emptyBBContext :: BlackBoxContext-emptyBBContext = Context (Left $ Identifier (pack "__EMPTY__") Nothing, Void) [] empty Nothing---- | Either the name of the identifier, or a tuple of the identifier and the--- corresponding clock-type SyncIdentifier = Either Identifier (Identifier,(Identifier,Int))-type SyncExpr       = Either Expr       (Expr,(Identifier,Integer))--makeLenses ''NetlistState
− src/CLaSH/Netlist/Util.hs 
@@ -1,366 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Utilities for converting Core Type/Term to Netlist datatypes--}--{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ViewPatterns    #-}--module CLaSH.Netlist.Util where--import           Control.Error           (hush)-import           Control.Lens            ((.=),(%=))-import qualified Control.Lens            as Lens-import qualified Control.Monad           as Monad-import           Control.Monad.Trans.Except (runExcept)-import           Data.Either             (partitionEithers)-import           Data.HashMap.Strict     (HashMap)-import qualified Data.HashMap.Strict     as HashMap-import           Data.Maybe              (catMaybes,fromMaybe)-import           Data.Text.Lazy          (append,pack,unpack)-import qualified Data.Text.Lazy          as Text-import           Unbound.Generics.LocallyNameless (Embed, Fresh, bind, embed, makeName,-                                          name2Integer, name2String, unbind,-                                          unembed, unrec)--import           CLaSH.Core.DataCon      (DataCon (..))-import           CLaSH.Core.FreeVars     (termFreeIds, typeFreeVars)-import           CLaSH.Core.Pretty       (showDoc)-import           CLaSH.Core.Subst        (substTys)-import           CLaSH.Core.Term         (LetBinding, Term (..), TmName)-import           CLaSH.Core.TyCon        (TyCon (..), TyConName, tyConDataCons)-import           CLaSH.Core.Type         (Type (..), TypeView (..), LitTy (..),-                                          coreView, splitTyConAppM, tyView)-import           CLaSH.Core.Util         (collectBndrs, termType, tyNatSize)-import           CLaSH.Core.Var          (Id, Var (..), modifyVarName)-import           CLaSH.Netlist.Types     as HW-import           CLaSH.Util--mkBasicId :: Identifier -> NetlistMonad Identifier-mkBasicId n = do-  f  <- Lens.use mkBasicIdFn-  let n' = f n-  if Text.null n'-     then return (pack "x")-     else return n'---- | Split a normalized term into: a list of arguments, a list of let-bindings,--- and a variable reference that is the body of the let-binding. Returns a--- String containing the error is the term was not in a normalized form.-splitNormalized :: Fresh m-                => HashMap TyConName TyCon-                -> Term-                -> m (Either String ([Id],[LetBinding],Id))-splitNormalized tcm expr = do-  (args,letExpr) <- fmap (first partitionEithers) $ collectBndrs expr-  case letExpr of-    Letrec b-      | (tmArgs,[]) <- args -> do-          (xes,e) <- unbind b-          case e of-            Var t v -> return $! Right (tmArgs,unrec xes,Id v (embed t))-            _ -> return $! Left ($(curLoc) ++ "Not in normal form: res not simple var")-      | otherwise -> return $! Left ($(curLoc) ++ "Not in normal form: tyArgs")-    _ -> do-      ty <- termType tcm expr-      return $! Left ($(curLoc) ++ "Not in normal from: no Letrec:\n\n" ++ showDoc expr ++ "\n\nWhich has type:\n\n"  ++ showDoc ty)---- | Converts a Core type to a HWType given a function that translates certain--- builtin types. Errors if the Core type is not translatable.-unsafeCoreTypeToHWType :: String-                       -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))-                       -> HashMap TyConName TyCon-                       -> Type-                       -> HWType-unsafeCoreTypeToHWType loc builtInTranslation m = either (error . (loc ++)) id . coreTypeToHWType builtInTranslation m---- | Converts a Core type to a HWType within the NetlistMonad; errors on failure-unsafeCoreTypeToHWTypeM :: String-                        -> Type-                        -> NetlistMonad HWType-unsafeCoreTypeToHWTypeM loc ty = unsafeCoreTypeToHWType loc <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure ty---- | Converts a Core type to a HWType within the NetlistMonad; 'Nothing' on failure-coreTypeToHWTypeM :: Type-                  -> NetlistMonad (Maybe HWType)-coreTypeToHWTypeM ty = hush <$> (coreTypeToHWType <$> Lens.use typeTranslator <*> Lens.use tcCache <*> pure ty)---- | Returns the name and period of the clock corresponding to a type-synchronizedClk :: HashMap TyConName TyCon -- ^ TyCon cache-                -> Type-                -> Maybe (Identifier,Integer)-synchronizedClk tcm ty-  | not . null . Lens.toListOf typeFreeVars $ ty = Nothing-  | Just (tyCon,args) <- splitTyConAppM ty-  = case name2String tyCon of-      "CLaSH.Sized.Vector.Vec"        -> synchronizedClk tcm (args!!1)-      "CLaSH.Signal.Internal.SClock" -> case splitTyConAppM (head args) of-        Just (_,[LitTy (SymTy s),litTy])-          | Right i <- runExcept (tyNatSize tcm litTy) -> Just (pack s,i)-        _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty-      "CLaSH.Signal.Internal.Signal'" -> case splitTyConAppM (head args) of-        Just (_,[LitTy (SymTy s),litTy])-          | Right i <- runExcept (tyNatSize tcm litTy) -> Just (pack s,i)-        _ -> error $ $(curLoc) ++ "Clock period not a simple literal: " ++ showDoc ty-      _                               -> case tyConDataCons (tcm HashMap.! tyCon) of-                                           [dc] -> let argTys   = dcArgTys dc-                                                       argTVs   = dcUnivTyVars dc-                                                       argSubts = zip argTVs args-                                                       args'    = map (substTys argSubts) argTys-                                                   in case args' of-                                                      (arg:_) -> synchronizedClk tcm arg-                                                      _ -> Nothing-                                           _    -> Nothing-  | otherwise-  = Nothing---- | Converts a Core type to a HWType given a function that translates certain--- builtin types. Returns a string containing the error message when the Core--- type is not translatable.-coreTypeToHWType :: (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))-                 -> HashMap TyConName TyCon-                 -> Type-                 -> Either String HWType-coreTypeToHWType builtInTranslation m (builtInTranslation m -> Just hty) = hty-coreTypeToHWType builtInTranslation m (coreView m -> Just ty) = coreTypeToHWType builtInTranslation m ty-coreTypeToHWType builtInTranslation m ty@(tyView -> TyConApp tc args) = mkADT builtInTranslation m (showDoc ty) tc args-coreTypeToHWType _ _ ty = Left $ "Can't translate non-tycon type: " ++ showDoc ty---- | Converts an algebraic Core type (split into a TyCon and its argument) to a HWType.-mkADT :: (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType)) -- ^ Hardcoded Type -> HWType translator-      -> HashMap TyConName TyCon -- ^ TyCon cache-      -> String -- ^ String representation of the Core type for error messages-      -> TyConName -- ^ The TyCon-      -> [Type] -- ^ Its applied arguments-      -> Either String HWType-mkADT _ m tyString tc _-  | isRecursiveTy m tc-  = Left $ $(curLoc) ++ "Can't translate recursive type: " ++ tyString--mkADT builtInTranslation m tyString tc args = case tyConDataCons (m HashMap.! tc) of-  []  -> Left $ $(curLoc) ++ "Can't translate empty type: " ++ tyString-  dcs -> do-    let tcName       = pack $ name2String tc-        argTyss      = map dcArgTys dcs-        argTVss      = map dcUnivTyVars dcs-        argSubts     = map (`zip` args) argTVss-        substArgTyss = zipWith (\s tys -> map (substTys s) tys) argSubts argTyss-    argHTyss         <- mapM (mapM (coreTypeToHWType builtInTranslation m)) substArgTyss-    case (dcs,argHTyss) of-      (_:[],[[elemTy]])      -> return elemTy-      (_:[],[elemTys@(_:_)]) -> return $ Product tcName elemTys-      (_   ,concat -> [])    -> return $ Sum tcName $ map (pack . name2String . dcName) dcs-      (_   ,elemHTys)        -> return $ SP tcName-                                      $ zipWith (\dc tys ->-                                                  ( pack . name2String $ dcName dc-                                                  , tys-                                                  )-                                                ) dcs elemHTys---- | Simple check if a TyCon is recursively defined.-isRecursiveTy :: HashMap TyConName TyCon -> TyConName -> Bool-isRecursiveTy m tc = case tyConDataCons (m HashMap.! tc) of-    []  -> False-    dcs -> let argTyss      = map dcArgTys dcs-               argTycons    = (map fst . catMaybes) $ (concatMap . map) splitTyConAppM argTyss-           in tc `elem` argTycons---- | Determines if a Core type is translatable to a HWType given a function that--- translates certain builtin types.-representableType :: (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))-                  -> Bool -- ^ Allow zero-bit things-                  -> HashMap TyConName TyCon-                  -> Type-                  -> Bool-representableType builtInTranslation allowZero m = either (const False) isRepresentable . coreTypeToHWType builtInTranslation m-  where-    isRepresentable hty = case hty of-      String          -> True-      Bool            -> True-      BitVector n     -> (n > 0) || allowZero-      Index n         -> (n > 0) || allowZero-      Signed n        -> (n > 0) || allowZero-      Unsigned  n     -> (n > 0) || allowZero-      Vector n elTy-        | n > 0 || allowZero -> isRepresentable elTy-      RTree _n elTy   -> isRepresentable elTy-      Sum {}          -> True-      Product _ elTys -> all isRepresentable elTys-      SP _ elTyss     -> all (all isRepresentable . snd) elTyss-      Clock {}        -> True-      Reset {}        -> True-      _               -> False---- | Determines the bitsize of a type-typeSize :: HWType-         -> Int-typeSize Void = 0-typeSize String = 1-typeSize Bool = 1-typeSize (Clock _ _) = 1-typeSize (Reset _ _) = 1-typeSize (BitVector i) = i-typeSize (Index 0) = 0-typeSize (Index 1) = 1-typeSize (Index u) = fromMaybe 0 (clogBase 2 u)-typeSize (Signed i) = i-typeSize (Unsigned i) = i-typeSize (Vector n el) = n * typeSize el-typeSize (RTree d el) = (2^d) * typeSize el-typeSize t@(SP _ cons) = conSize t +-  maximum (map (sum . map typeSize . snd) cons)-typeSize (Sum _ dcs) = max 1 (fromMaybe 0 . clogBase 2 . toInteger $ length dcs)-typeSize (Product _ tys) = sum $ map typeSize tys---- | Determines the bitsize of the constructor of a type-conSize :: HWType-        -> Int-conSize (SP _ cons) = fromMaybe 0 . clogBase 2 . toInteger $ length cons-conSize t           = typeSize t---- | Gives the length of length-indexed types-typeLength :: HWType-           -> Int-typeLength (Vector n _) = n-typeLength _            = 0---- | Gives the HWType corresponding to a term. Returns an error if the term has--- a Core type that is not translatable to a HWType.-termHWType :: String-           -> Term-           -> NetlistMonad HWType-termHWType loc e = do-  m  <- Lens.use tcCache-  ty <- termType m e-  unsafeCoreTypeToHWTypeM loc ty---- | Gives the HWType corresponding to a term. Returns 'Nothing' if the term has--- a Core type that is not translatable to a HWType.-termHWTypeM :: Term-            -> NetlistMonad (Maybe HWType)-termHWTypeM e = do-  m  <- Lens.use tcCache-  ty <- termType m e-  coreTypeToHWTypeM ty---- | Uniquely rename all the variables and their references in a normalized--- term-mkUniqueNormalized :: ([Id],[LetBinding],Id)-                   -> NetlistMonad ([Id],[LetBinding],TmName)-mkUniqueNormalized (args,binds,res) = do-  -- Make arguments unique-  (args',subst)   <- mkUnique []    args-  -- Make result unique-  ([res1],subst') <- mkUnique subst [res]-  let bndrs = map fst binds-      exprs = map (unembed . snd) binds-      usesOutput = concatMap (filter (== varName res) . Lens.toListOf termFreeIds) exprs-  -- If the let-binder carrying the result is used in a feedback loop-  -- rename the let-binder to "<X>_rec", and assign the "<X>_rec" to-  -- "<X>". We do this because output ports in most HDLs cannot be read.-  (res2,subst'',extraBndr) <- case usesOutput of-    [] -> return (varName res1,(res,res1):subst',[] :: [(Id, Embed Term)])-    _  -> do-      ([res3],_) <- mkUnique [] [modifyVarName (`appendToName` "_rec") res1]-      return (varName res3,(res,res3):subst'-             ,[(res1,embed $ Var (unembed $ varType res) (varName res3))])-  -- Replace occurences of "<X>" by "<X>_rec"-  let resN    = varName res-      bndrs'  = map (\i -> if varName i == resN then modifyVarName (const res2) i else i) bndrs-      (bndrsL,r:bndrsR) = break ((== res2).varName) bndrs'-  -- Make let-binders unique-  (bndrsL',substL) <- mkUnique subst'' bndrsL-  (bndrsR',substR) <- mkUnique substL  bndrsR-  -- Replace old IDs by update unique IDs in the RHSs of the let-binders-  exprs' <- fmap (map embed) $ Monad.foldM subsBndrs exprs substR-  -- Return the uniquely named arguments, let-binders, and result-  return (args',zip (bndrsL' ++ r:bndrsR') exprs' ++ extraBndr,varName res1)-  where-    subsBndrs :: [Term] -> (Id,Id) -> NetlistMonad [Term]-    subsBndrs es (f,r) = mapM (subsBndr f r) es--    subsBndr :: Id -> Id -> Term -> NetlistMonad Term-    subsBndr f r e = case e of-      Var t v | v == varName f -> return . Var t $ varName r-      App e1 e2                -> App <$> subsBndr f r e1-                                      <*> subsBndr f r e2-      Case scrut ty alts       -> Case <$> subsBndr f r scrut-                                       <*> pure ty-                                       <*> mapM ( return-                                                . uncurry bind-                                                <=< secondM (subsBndr f r)-                                                <=< unbind-                                                ) alts-      _ -> return e---- | Make a set of IDs unique; also returns a substitution from old ID to new--- updated unique ID.-mkUnique :: [(Id,Id)] -- ^ Existing substitution-         -> [Id]      -- ^ IDs to make unique-         -> NetlistMonad ([Id],[(Id,Id)])-         -- ^ (Unique IDs, update substitution)-mkUnique = go []-  where-    go :: [Id] -> [(Id,Id)] -> [Id] -> NetlistMonad ([Id],[(Id,Id)])-    go processed subst []     = return (reverse processed,subst)-    go processed subst (i:is) = do-      iN <- mkUniqueIdentifier . pack . name2String $ varName i-      let iN_unpacked = unpack iN-          i'          = modifyVarName (repName iN_unpacked) i-      go (i':processed) ((i,i'):subst) is--    repName s n = makeName s (name2Integer n)--mkUniqueIdentifier :: Identifier-                   -> NetlistMonad Identifier-mkUniqueIdentifier nm = do-  seen  <- Lens.use seenIds-  seenC <- Lens.use seenComps-  i     <- mkBasicId nm-  let s = seenC ++ seen-  if i `elem` s-     then go 0 s i-     else do-      seenIds %= (i:)-      return i-  where-    go :: Integer -> [Identifier] -> Identifier -> NetlistMonad Identifier-    go n s i = do-      i' <- mkBasicId (i `append` pack ('_':show n))-      if i' `elem` s-         then go (n+1) s i-         else do-          seenIds %= (i':)-          return i'---- | Append a string to a name-appendToName :: TmName-             -> String-             -> TmName-appendToName n s = makeName (name2String n ++ s) (name2Integer n)---- | Preserve the Netlist '_varEnv' and '_varCount' when executing a monadic action-preserveVarEnv :: NetlistMonad a-               -> NetlistMonad a-preserveVarEnv action = do-  -- store state-  vCnt  <- Lens.use varCount-  vEnv  <- Lens.use varEnv-  vComp <- Lens.use curCompNm-  vSeen <- Lens.use seenIds-  -- perform action-  val <- action-  -- restore state-  varCount  .= vCnt-  varEnv    .= vEnv-  curCompNm .= vComp-  seenIds   .= vSeen-  return val--dcToLiteral :: HWType -> Int -> Literal-dcToLiteral Bool 1 = BoolLit False-dcToLiteral Bool 2 = BoolLit True-dcToLiteral _ i    = NumLit (toInteger i-1)
− src/CLaSH/Normalize.hs 
@@ -1,276 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Turn CoreHW terms into normalized CoreHW Terms--}--{-# LANGUAGE TemplateHaskell #-}--module CLaSH.Normalize where--import           Control.Concurrent.Supply        (Supply)-import           Control.Lens                     ((.=),(^.),_1,_3)-import qualified Control.Lens                     as Lens-import           Data.Either                      (partitionEithers)-import           Data.HashMap.Strict              (HashMap)-import qualified Data.HashMap.Strict              as HashMap-import           Data.IntMap.Strict               (IntMap)-import           Data.List                        (mapAccumL,intersect)-import qualified Data.Map                         as Map-import qualified Data.Maybe                       as Maybe-import qualified Data.Set                         as Set-import qualified Data.Set.Lens                    as Lens-import           Unbound.Generics.LocallyNameless (unembed)--import           SrcLoc                           (SrcSpan,noSrcSpan)--import           CLaSH.Core.FreeVars              (termFreeIds)-import           CLaSH.Core.Pretty                (showDoc)-import           CLaSH.Core.Subst                 (substTms)-import           CLaSH.Core.Term                  (Term (..), TmName)-import           CLaSH.Core.Type                  (Type, splitCoreFunForallTy)-import           CLaSH.Core.TyCon                 (TyCon, TyConName)-import           CLaSH.Core.Util                  (collectArgs, mkApps, termType)-import           CLaSH.Core.Var                   (Id,varName)-import           CLaSH.Driver.Types               (CLaSHOpts (..))-import           CLaSH.Netlist.BlackBox.Types     (BlackBoxTemplate)-import           CLaSH.Netlist.Types              (HWType)-import           CLaSH.Netlist.Util               (splitNormalized)-import           CLaSH.Normalize.Strategy-import           CLaSH.Normalize.Transformations  (bindConstantVar, caseCon,-                                                   reduceConst, topLet )-import           CLaSH.Normalize.Types-import           CLaSH.Normalize.Util-import           CLaSH.Primitives.Types           (PrimMap)-import           CLaSH.Rewrite.Combinators        ((>->),(!->),repeatR,topdownR)-import           CLaSH.Rewrite.Types              (DebugLevel (..), RewriteEnv (..), RewriteState (..),-                                                   bindings, curFun, dbgLevel,-                                                   tcCache, extra)-import           CLaSH.Rewrite.Util               (isUntranslatableType,-                                                   runRewrite,-                                                   runRewriteSession)-import           CLaSH.Util---- | Run a NormalizeSession in a given environment-runNormalization :: CLaSHOpts-                 -- ^ Level of debug messages to print-                 -> Supply-                 -- ^ UniqueSupply-                 -> HashMap TmName (Type,SrcSpan,Term)-                 -- ^ Global Binders-                 -> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))-                 -- ^ Hardcoded Type -> HWType translator-                 -> HashMap TyConName TyCon-                 -- ^ TyCon cache-                 -> IntMap TyConName-                 -- ^ Tuple TyCon cache-                 -> (HashMap TyConName TyCon -> Bool -> Term -> Term)-                 -- ^ Hardcoded evaluator (delta-reduction)-                 -> PrimMap BlackBoxTemplate-                 -- ^ Primitive Definitions-                 -> HashMap TmName Bool-                 -- ^ Map telling whether a components is part of a recursive group-                 -> NormalizeSession a-                 -- ^ NormalizeSession to run-                 -> a-runNormalization opts supply globals typeTrans tcm tupTcm eval primMap rcsMap-  = runRewriteSession rwEnv rwState-  where-    rwEnv     = RewriteEnv-                  (opt_dbgLevel opts)-                  typeTrans-                  tcm-                  tupTcm-                  eval-                  (opt_allowZero opts)--    rwState   = RewriteState-                  0-                  globals-                  supply-                  (error $ $(curLoc) ++ "Report as bug: no curFun",noSrcSpan)-                  0-                  normState--    normState = NormalizeState-                  HashMap.empty-                  Map.empty-                  HashMap.empty-                  (opt_specLimit opts)-                  HashMap.empty-                  (opt_inlineLimit opts)-                  (opt_inlineBelow opts)-                  primMap-                  rcsMap---normalize :: [TmName]-          -> NormalizeSession (HashMap TmName (Type,SrcSpan,Term))-normalize []  = return HashMap.empty-normalize top = do-  (new,topNormalized) <- unzip <$> mapM normalize' top-  newNormalized <- normalize (concat new)-  return (HashMap.union (HashMap.fromList topNormalized) newNormalized)--normalize' :: TmName-           -> NormalizeSession ([TmName],(TmName,(Type,SrcSpan,Term)))-normalize' nm = do-  exprM <- HashMap.lookup nm <$> Lens.use bindings-  let nmS = showDoc nm-  case exprM of-    Just (ty,sp,tm) -> do-      tcm <- Lens.view tcCache-      let (_,resTy) = splitCoreFunForallTy tcm ty-      resTyRep <- not <$> isUntranslatableType resTy-      if resTyRep-         then do-            tmNorm <- makeCached nm (extra.normalized) $ do-                        curFun .= (nm,sp)-                        tm' <- rewriteExpr ("normalization",normalization) (nmS,tm)-                        ty' <- termType tcm tm'-                        return (ty',sp,tm')-            let usedBndrs = Lens.toListOf termFreeIds (tmNorm ^. _3)-            traceIf (nm `elem` usedBndrs)-                    (concat [ $(curLoc),"Expr belonging to bndr: ",nmS ," (:: "-                            , showDoc (tmNorm ^. _1)-                            , ") remains recursive after normalization:\n"-                            , showDoc (tmNorm ^. _3) ])-                    (return ())-            prevNorm <- fmap HashMap.keys $ Lens.use (extra.normalized)-            let toNormalize = filter (`notElem` (nm:prevNorm)) usedBndrs-            return (toNormalize,(nm,tmNorm))-         else do-            let usedBndrs = Lens.toListOf termFreeIds tm-            prevNorm <- fmap HashMap.keys $ Lens.use (extra.normalized)-            let toNormalize = filter (`notElem` (nm:prevNorm)) usedBndrs-            lvl <- Lens.view dbgLevel-            traceIf (lvl >= DebugFinal)-                    (concat [$(curLoc), "Expr belonging to bndr: ", nmS, " (:: "-                            , showDoc ty-                            , ") has a non-representable return type."-                            , " Not normalising:\n", showDoc tm] )-                    (return (toNormalize,(nm,(ty,sp,tm))))-    Nothing -> error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " not found"---- | Rewrite a term according to the provided transformation-rewriteExpr :: (String,NormRewrite) -- ^ Transformation to apply-            -> (String,Term) -- ^ Term to transform-            -> NormalizeSession Term-rewriteExpr (nrwS,nrw) (bndrS,expr) = do-  lvl <- Lens.view dbgLevel-  let before = showDoc expr-  let expr' = traceIf (lvl >= DebugFinal)-                (bndrS ++ " before " ++ nrwS ++ ":\n\n" ++ before ++ "\n")-                expr-  rewritten <- runRewrite nrwS nrw expr'-  let after = showDoc rewritten-  traceIf (lvl >= DebugFinal)-    (bndrS ++ " after " ++ nrwS ++ ":\n\n" ++ after ++ "\n") $-    return rewritten---- | Check if the call graph (second argument), starting at the @topEnity@--- (first argument) is non-recursive. Returns the list of normalized terms if--- call graph is indeed non-recursive, errors otherwise.-checkNonRecursive :: TmName -- ^ @topEntity@-                  -> HashMap TmName (Type,SrcSpan,Term) -- ^ List of normalized binders-                  -> HashMap TmName (Type,SrcSpan,Term)-checkNonRecursive topEntity norm =-  let cg = callGraph [] norm topEntity-  in  case mkRecursiveComponents cg of-       []  -> norm-       rcs -> error $ $(curLoc) ++ "Callgraph after normalisation contains following recursive cycles: " ++ show rcs---- | Perform general \"clean up\" of the normalized (non-recursive) function--- hierarchy. This includes:------   * Inlining functions that simply \"wrap\" another function-cleanupGraph :: TmName-             -> (HashMap TmName (Type,SrcSpan,Term))-             -> NormalizeSession (HashMap TmName (Type,SrcSpan,Term))-cleanupGraph topEntity norm = do-  let ct = mkCallTree [] norm topEntity-  ctFlat <- flattenCallTree ct-  return (HashMap.fromList $ snd $ callTreeToList [] ctFlat)---data CallTree = CLeaf   (TmName,(Type,SrcSpan,Term))-              | CBranch (TmName,(Type,SrcSpan,Term)) [CallTree]--mkCallTree :: [TmName] -- ^ Visited-           -> HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders-           -> TmName -- ^ Root of the call graph-           -> CallTree-mkCallTree visited bindingMap root = case used of-                            [] -> CLeaf   (root,rootTm)-                            _  -> CBranch (root,rootTm) other-  where-    rootTm = Maybe.fromMaybe (error $ $(curLoc) ++ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap-    used   = Set.toList $ Lens.setOf termFreeIds $ (rootTm ^. _3)-    other  = map (mkCallTree (root:visited) bindingMap) (filter (`notElem` visited) used)--stripArgs :: [TmName]-          -> [Id]-          -> [Either Term Type]-          -> Maybe [Either Term Type]-stripArgs _      (_:_) []   = Nothing-stripArgs allIds []    args = if any mentionsId args-                                then Nothing-                                else Just args-  where-    mentionsId t = not $ null (either (Lens.toListOf termFreeIds) (const []) t-                              `intersect`-                              allIds)--stripArgs allIds (id_:ids) (Left (Var _ nm):args)-      | varName id_ == nm = stripArgs allIds ids args-      | otherwise         = Nothing-stripArgs _ _ _ = Nothing--flattenNode :: CallTree-            -> NormalizeSession (Either CallTree ((TmName,Term),[CallTree]))-flattenNode c@(CLeaf (nm,(_,_,e))) = do-  tcm  <- Lens.view tcCache-  norm <- splitNormalized tcm e-  case norm of-    Right (ids,[(_,bExpr)],_) -> do-      let (fun,args) = collectArgs (unembed bExpr)-      case stripArgs (map varName ids) (reverse ids) (reverse args) of-        Just remainder -> return (Right ((nm,mkApps fun (reverse remainder)),[]))-        Nothing        -> return (Left c)-    _ -> return (Left c)-flattenNode b@(CBranch (nm,(_,_,e)) us) = do-  tcm  <- Lens.view tcCache-  norm <- splitNormalized tcm e-  case norm of-    Right (ids,[(_,bExpr)],_) -> do-      let (fun,args) = collectArgs (unembed bExpr)-      case stripArgs (map varName ids) (reverse ids) (reverse args) of-        Just remainder -> return (Right ((nm,mkApps fun (reverse remainder)),us))-        Nothing        -> return (Left b)-    _ -> return (Left b)--flattenCallTree :: CallTree-                -> NormalizeSession CallTree-flattenCallTree c@(CLeaf _) = return c-flattenCallTree (CBranch (nm,(ty,sp,tm)) used) = do-  flattenedUsed   <- mapM flattenCallTree used-  (newUsed,il_ct) <- partitionEithers <$> mapM flattenNode flattenedUsed-  let (toInline,il_used) = unzip il_ct-  newExpr <- case toInline of-               [] -> return tm-               _  -> rewriteExpr ("bindConstants",(repeatR (topdownR $ (bindConstantVar >-> caseCon >-> reduceConst))) !-> topdownSucR topLet) (showDoc nm, substTms toInline tm)-  return (CBranch (nm,(ty,sp,newExpr)) (newUsed ++ (concat il_used)))--callTreeToList :: [TmName]-               -> CallTree-               -> ([TmName],[(TmName,(Type,SrcSpan,Term))])-callTreeToList visited (CLeaf (nm,(ty,sp,tm)))-  | nm `elem` visited = (visited,[])-  | otherwise         = (nm:visited,[(nm,(ty,sp,tm))])-callTreeToList visited (CBranch (nm,(ty,sp,tm)) used)-  | nm `elem` visited = (visited,[])-  | otherwise         = (visited',(nm,(ty,sp,tm)):(concat others))-  where-    (visited',others) = mapAccumL callTreeToList (nm:visited) used
− src/CLaSH/Normalize/DEC.hs 
@@ -1,471 +0,0 @@-{-|-  Copyright  :  (C) 2015-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Helper functions for the 'disjointExpressionConsolidation' transformation--  The 'disjointExpressionConsolidation' transformation lifts applications of-  global binders out of alternatives of case-statements.--  e.g. It converts:--  > case x of-  >   A -> f 3 y-  >   B -> f x x-  >   C -> h x--  into:--  > let f_arg0 = case x of {A -> 3; B -> x}-  >     f_arg1 = case x of {A -> y; B -> x}-  >     f_out  = f f_arg0 f_arg1-  > in  case x of-  >       A -> f_out-  >       B -> f_out-  >       C -> h x--}--{-# LANGUAGE DeriveFoldable    #-}-{-# LANGUAGE DeriveFunctor     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecursiveDo       #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE ViewPatterns      #-}--module CLaSH.Normalize.DEC-  (collectGlobals-  ,isDisjoint-  ,mkDisjointGroup-  )-where---- external-import qualified Control.Lens                     as Lens-import           Data.Bits                        ((.&.),complement)-import qualified Data.Either                      as Either-import qualified Data.Foldable                    as Foldable-import qualified Data.HashMap.Strict              as HashMap-import qualified Data.IntMap.Strict               as IM-import qualified Data.List                        as List-import qualified Data.Map.Strict                  as Map-import qualified Data.Maybe                       as Maybe-import           Data.Set                         (Set)-import qualified Data.Set                         as Set-import qualified Data.Set.Lens                    as Lens--import           Unbound.Generics.LocallyNameless (Bind, bind, embed, fv, unbind,-                                                   unembed, unrec)-import qualified Unbound.Generics.LocallyNameless as Unbound---- internal-import CLaSH.Core.DataCon    (DataCon, dcTag)-import CLaSH.Core.FreeVars   (termFreeIds, typeFreeVars)-import CLaSH.Core.Literal    (Literal (..))-import CLaSH.Core.Term       (LetBinding, Pat (..), Term (..), TmName)-import CLaSH.Core.TyCon      (tyConDataCons)-import CLaSH.Core.Type       (Type, isPolyFunTy, mkTyConApp, splitFunForallTy)-import CLaSH.Core.Util       (collectArgs, mkApps, termType)-import CLaSH.Normalize.Types (NormalizeState)-import CLaSH.Normalize.Util  (isConstant)-import CLaSH.Rewrite.Types   (RewriteMonad, evaluator, tcCache, tupleTcCache)-import CLaSH.Rewrite.Util    (mkInternalVar, mkSelectorCase,-                              isUntranslatableType)-import CLaSH.Util--data CaseTree a-  = Leaf a-  | LB [LetBinding] (CaseTree a)-  | Branch Term [(Pat,CaseTree a)]-  deriving (Eq,Show,Functor,Foldable)---- | Test if a 'CaseTree' collected from an expression indicates that--- application of a global binder is disjoint: occur in separate branches of a--- case-expression.-isDisjoint :: CaseTree ([Either Term Type])-           -> Bool-isDisjoint (Branch _ [_]) = False-isDisjoint ct = go ct-  where-    go (Leaf _)             = False-    go (LB _ ct')           = go ct'-    go (Branch _ [])        = False-    go (Branch _ [(_,x)])   = go x-    go b@(Branch _ (_:_:_)) = allEqual (map Either.rights (Foldable.toList b))---- Remove empty branches from a 'CaseTree'-removeEmpty :: Eq a => CaseTree [a] -> CaseTree [a]-removeEmpty l@(Leaf _) = l-removeEmpty (LB lb ct) =-  case removeEmpty ct of-    Leaf [] -> Leaf []-    ct'     -> LB lb ct'-removeEmpty (Branch s bs) =-  case filter ((/= (Leaf [])) . snd) (map (second removeEmpty) bs) of-    []  -> Leaf []-    bs' -> Branch s bs'---- | Test if all elements in a list are equal to each other.-allEqual :: Eq a => [a] -> Bool-allEqual []     = True-allEqual (x:xs) = all (== x) xs---- | Collect 'CaseTree's for (potentially) disjoint applications of globals out--- of an expression. Also substitute truly disjoint applications of globals by a--- reference to a lifted out application.-collectGlobals ::-     Set TmName-  -> [(Term,Term)] -- ^ Substitution of (applications of) a global-                   -- binder by a reference to a lifted term.-  -> [Term] -- ^ List of already seen global binders-  -> Term -- ^ The expression-  -> RewriteMonad NormalizeState-                  (Term,[(Term,([Term],CaseTree [(Either Term Type)]))])-collectGlobals inScope substitution seen (Case scrut ty alts) = do-  rec (alts' ,collected)  <- collectGlobalsAlts inScope substitution seen scrut'-                                                alts-      (scrut',collected') <- collectGlobals inScope substitution-                                            (map fst collected ++ seen) scrut-  return (Case scrut' ty alts',collected ++ collected')--collectGlobals inScope substitution seen e@(collectArgs -> (fun, args@(_:_)))-  | not (isConstant e) = do-    tcm <- Lens.view tcCache-    eval <- Lens.view evaluator-    eTy <- termType tcm e-    untran <- isUntranslatableType eTy-    case untran of-      -- Don't lift out non-representable values, because they cannot be let-bound-      -- in our desired normal form.-      False -> case interestingToLift inScope (eval tcm False) fun args of-        Just fun' | fun' `notElem` seen -> do-          (args',collected) <- collectGlobalsArgs inScope substitution-                                                  (fun':seen) args-          let e' = Maybe.fromMaybe (mkApps fun' args') (List.lookup fun' substitution)-          -- This function is lifted out an environment with the currently 'seen'-          -- binders. When we later apply substitution, we need to start with this-          -- environment, otherwise we perform incorrect substitutions in the-          -- arguments.-          return (e',(fun',(seen,Leaf args')):collected)-        _ -> do (args',collected) <- collectGlobalsArgs inScope substitution-                                                        seen args-                return (mkApps fun args',collected)-      _ -> return (e,[])---- FIXME: This duplicates A LOT of let-bindings, where I just pray that after--- the ANF, CSE, and DeadCodeRemoval pass all duplicates are removed.------ I think we should be able to do better, but perhaps we cannot fix it here.-collectGlobals inScope substitution seen (Letrec b) = do-  (unrec -> lbs,body) <- unbind b-  (body',collected)   <- collectGlobals    inScope substitution seen body-  (lbs',collected')   <- collectGlobalsLbs inScope substitution-                                           (map fst collected ++ seen)-                                           lbs-  return (Letrec (bind (Unbound.rec lbs') body')-         ,map (second (second (LB lbs'))) (collected ++ collected')-         )--collectGlobals _ _ _ e = return (e,[])---- | Collect 'CaseTree's for (potentially) disjoint applications of globals out--- of a list of application arguments. Also substitute truly disjoint--- applications of globals by a reference to a lifted out application.-collectGlobalsArgs ::-     Set TmName-  -> [(Term,Term)] -- ^ Substitution of (applications of) a global-                   -- binder by a reference to a lifted term.-  -> [Term] -- ^ List of already seen global binders-  -> [Either Term Type] -- ^ The list of arguments-  -> RewriteMonad NormalizeState-                  ([Either Term Type]-                  ,[(Term,([Term],CaseTree [(Either Term Type)]))]-                  )-collectGlobalsArgs inScope substitution seen args = do-    (_,(args',collected)) <- second unzip <$> mapAccumLM go seen args-    return (args',concat collected)-  where-    go s (Left tm) = do-      (tm',collected) <- collectGlobals inScope substitution s tm-      return (map fst collected ++ s,(Left tm',collected))-    go s (Right ty) = return (s,(Right ty,[]))---- | Collect 'CaseTree's for (potentially) disjoint applications of globals out--- of a list of alternatives. Also substitute truly disjoint applications of--- globals by a reference to a lifted out application.-collectGlobalsAlts ::-     Set TmName-  -> [(Term,Term)] -- ^ Substitution of (applications of) a global-                   -- binder by a reference to a lifted term.-  -> [Term] -- ^ List of already seen global binders-  -> Term -- ^ The subject term-  -> [Bind Pat Term] -- ^ The list of alternatives-  -> RewriteMonad NormalizeState-                  ([Bind Pat Term]-                  ,[(Term,([Term],CaseTree [(Either Term Type)]))]-                  )-collectGlobalsAlts inScope substitution seen scrut alts = do-    (alts',collected) <- unzip <$> mapM go alts-    let collectedM  = map (Map.fromList . map (second (second (:[])))) collected-        collectedUN = Map.unionsWith (\(l1,r1) (l2,r2) -> (List.nub (l1 ++ l2),r1 ++ r2)) collectedM-        collected'  = map (second (second (Branch scrut))) (Map.toList collectedUN)-    return (alts',collected')-  where-    go pe = do (p,e) <- unbind pe-               (e',collected) <- collectGlobals inScope substitution seen e-               return (bind p e',map (second (second (p,))) collected)---- | Collect 'CaseTree's for (potentially) disjoint applications of globals out--- of a list of let-bindings. Also substitute truly disjoint applications of--- globals by a reference to a lifted out application.-collectGlobalsLbs ::-     Set TmName-  -> [(Term,Term)] -- ^ Substitution of (applications of) a global-                   -- binder by a reference to a lifted term.-  -> [Term] -- ^ List of already seen global binders-  -> [LetBinding] -- ^ The list let-bindings-  -> RewriteMonad NormalizeState-                  ([LetBinding]-                  ,[(Term,([Term],CaseTree [(Either Term Type)]))]-                  )-collectGlobalsLbs inScope substitution seen lbs = do-    (_,(lbs',collected)) <- second unzip <$> mapAccumLM go seen lbs-    return (lbs',concat collected)-  where-    go :: [Term] -> LetBinding-       -> RewriteMonad NormalizeState-                  ([Term]-                  ,(LetBinding-                   ,[(Term,([Term],CaseTree [(Either Term Type)]))]-                   )-                  )-    go s (id_,unembed -> e) = do-      (e',collected) <- collectGlobals inScope substitution s e-      return (map fst collected ++ s,((id_,embed e'),collected))---- | Given a case-tree corresponding to a disjoint interesting \"term-in-a---- function-position\", return a let-expression: where the let-binding holds--- a case-expression selecting between the uncommon arguments of the case-tree,--- and the body is an application of the term applied to the common arguments of--- the case tree, and projections of let-binding corresponding to the uncommon--- argument positions.-mkDisjointGroup :: Set TmName -- ^ Current free variables.-                -> (Term,([Term],CaseTree [(Either Term Type)]))-                   -- ^ Case-tree of arguments belonging to the applied term.-                -> RewriteMonad NormalizeState (Term,[Term])-mkDisjointGroup fvs (fun,(seen,cs)) = do-    let argss    = Foldable.toList cs-        argssT   = zip [0..] (List.transpose argss)-        (commonT,uncommonT) = List.partition (isCommon fvs . snd) argssT-        common   = map (second head) commonT-        uncommon = map (Either.lefts) (List.transpose (map snd uncommonT))-        cs'      = fmap (zip [0..]) cs-        cs''     = removeEmpty-                 $ fmap (Either.lefts . map snd)-                        (if null common-                           then cs'-                           else fmap (filter (`notElem` common)) cs')-    tcm <- Lens.view tcCache-    (uncommonCaseM,uncommonProjections) <- case uncommon of-      -- only common arguments: do nothing.-      [] -> return (Nothing,[])-      -- Create selectors and projections-      (uc:_) -> do-        argTys <- mapM (termType tcm) uc-        disJointSelProj argTys cs''-    let newArgs = mkDJArgs 0 common uncommonProjections-    case uncommonCaseM of-      Just lb -> return (Letrec (bind (Unbound.rec [lb]) (mkApps fun newArgs)), seen)-      Nothing -> return (mkApps fun newArgs, seen)---- | Create a single selector for all the representable uncommon arguments by--- selecting between tuples. This selector is only ('Just') created when the--- number of representable uncommmon arguments is larger than one, otherwise it--- is not ('Nothing').------ It also returns:------ * For all the non-representable uncommon arguments: a selector--- * For all the representable uncommon arguments: a projection out of the tuple---   created by the larger selector. If this larger selector does not exist, a---   single selector is created for the single representable uncommon argument.-disJointSelProj :: [Type] -- ^ Types of the arguments-                -> CaseTree [Term] -- The case-tree of arguments-                -> RewriteMonad NormalizeState (Maybe LetBinding,[Term])-disJointSelProj _ (Leaf []) = return (Nothing,[])-disJointSelProj argTys cs = do-    let maxIndex = length argTys - 1-        css = map (\i -> fmap ((:[]) . (!!i)) cs) [0..maxIndex]-    (untran,tran) <- partitionM (isUntranslatableType . snd) (zip [0..] argTys)-    let untranCs   = map (css!!) (map fst untran)-        untranSels = zipWith (\(_,ty) cs' -> genCase ty Nothing []  cs')-                             untran untranCs-    (lbM,projs) <- case tran of-      []       -> return (Nothing,[])-      [(i,ty)] -> return (Nothing,[genCase ty Nothing [] (css!!i)])-      tys      -> do-        tcm    <- Lens.view tcCache-        tupTcm <- Lens.view tupleTcCache-        let m            = length tys-            Just tupTcNm = IM.lookup m tupTcm-            Just tupTc   = HashMap.lookup tupTcNm tcm-            [tupDc]      = tyConDataCons tupTc-            (tyIxs,tys') = unzip tys-            tupTy        = mkTyConApp tupTcNm tys'-            cs'          = fmap (\es -> map (es !!) tyIxs) cs-            djCase       = genCase tupTy (Just tupDc) tys' cs'-        (scrutId,scrutVar) <- mkInternalVar "tupIn" tupTy-        projections <- mapM (mkSelectorCase ($(curLoc) ++ "disJointSelProj")-                                            tcm scrutVar (dcTag tupDc)) [0..m-1]-        return (Just (scrutId,embed djCase),projections)-    let selProjs = tranOrUnTran 0 (zip (map fst untran) untranSels) projs--    return (lbM,selProjs)-  where-    tranOrUnTran _ []       projs     = projs-    tranOrUnTran _ sels     []        = map snd sels-    tranOrUnTran n ((ut,s):uts) (p:projs)-      | n == ut   = s : tranOrUnTran (n+1) uts          (p:projs)-      | otherwise = p : tranOrUnTran (n+1) ((ut,s):uts) projs---isCommon :: Set TmName -> [Either Term Type] -> Bool-isCommon _   []             = True-isCommon _   (Right ty:tys) = Set.null (Lens.setOf typeFreeVars ty) &&-                              allEqual (Right ty:tys)-isCommon fvs (Left tm:tms)  = Set.null (Lens.setOf termFreeIds tm Set.\\ fvs) &&-                              allEqual (Left tm:tms)---- | Create a list of arguments given a map of positions to common arguments,--- and a list of arguments-mkDJArgs :: Int -- ^ Current position-         -> [(Int,Either Term Type)] -- ^ map from position to common argument-         -> [Term] -- ^ (projections for) uncommon arguments-         -> [Either Term Type]-mkDJArgs _ cms []   = map snd cms-mkDJArgs _ [] uncms = map Left uncms-mkDJArgs n ((m,x):cms) (y:uncms)-  | n == m    = x       : mkDJArgs (n+1) cms (y:uncms)-  | otherwise = Left y  : mkDJArgs (n+1) ((m,x):cms) uncms---- | Create a case-expression that selects between the uncommon arguments given--- a case-tree-genCase :: Type -- ^ Type of the alternatives-        -> Maybe DataCon -- ^ DataCon to pack multiple arguments-        -> [Type] -- ^ Types of the arguments-        -> CaseTree [Term] -- ^ CaseTree of arguments-        -> Term-genCase ty dcM argTys = go-  where-    go (Leaf tms) =-      case dcM of-        Just dc -> mkApps (Data dc) (map Right argTys ++ map Left tms)-        _ -> head tms--    go (LB lb ct) =-      Letrec (bind (Unbound.rec lb) (go ct))--    go (Branch scrut [(p,ct)]) =-      let ct' = go ct-          alt = bind p ct'-      in  case Lens.setOf termFreeIds ct' == Lens.setOf fv alt of-            True -> ct'-            _    -> Case scrut ty [alt]--    go (Branch scrut pats) =-      Case scrut ty (map (\(p,ct) -> bind p (go ct)) pats)---- | Determine if a term in a function position is interesting to lift out of--- of a case-expression.------ This holds for all global functions, and certain primitives. Currently those--- primitives are:------ * All non-power-of-two multiplications--- * All division-like operations with a non-power-of-two divisor-interestingToLift :: Set TmName -- ^ in scope-                  -> (Term -> Term) -- ^ Evaluator-                  -> Term -- ^ Term in function position-                  -> [Either Term Type] -- ^ Arguments-                  -> Maybe Term-interestingToLift inScope _ e@(Var _ nm) _ =-  if nm `Set.member` inScope-     then Just e-     else Nothing-interestingToLift inScope eval e@(Prim nm pty) args =-    case List.lookup nm interestingPrims of-      Just t | t || not (all isConstant lArgs) -> Just e-      _ -> if isHOTy pty-              then if not . null . Maybe.catMaybes $-                      map (uncurry (interestingToLift inScope eval) .-                           collectArgs-                          ) lArgs-                      then Just e-                      else Nothing-              else Nothing--  where-    interestingPrims =-      [("CLaSH.Sized.Internal.BitVector.*#",tailNonPow2)-      ,("CLaSH.Sized.Internal.BitVector.times#",tailNonPow2)-      ,("CLaSH.Sized.Internal.BitVector.quot#",lastNotPow2)-      ,("CLaSH.Sized.Internal.BitVector.rem#",lastNotPow2)-      ,("CLaSH.Sized.Internal.Index.*#",tailNonPow2)-      ,("CLaSH.Sized.Internal.Index.quot#",lastNotPow2)-      ,("CLaSH.Sized.Internal.Index.rem#",lastNotPow2)-      ,("CLaSH.Sized.Internal.Signed.*#",tailNonPow2)-      ,("CLaSH.Sized.Internal.Signed.times#",tailNonPow2)-      ,("CLaSH.Sized.Internal.Signed.rem#",lastNotPow2)-      ,("CLaSH.Sized.Internal.Signed.quot#",lastNotPow2)-      ,("CLaSH.Sized.Internal.Signed.div#",lastNotPow2)-      ,("CLaSH.Sized.Internal.Signed.mod#",lastNotPow2)-      ,("CLaSH.Sized.Internal.Unsigned.*#",tailNonPow2)-      ,("CLaSH.Sized.Internal.Unsigned.times#",tailNonPow2)-      ,("CLaSH.Sized.Internal.Unsigned.quot#",lastNotPow2)-      ,("CLaSH.Sized.Internal.Unsigned.rem#",lastNotPow2)-      ,("GHC.Base.quotInt",lastNotPow2)-      ,("GHC.Base.remInt",lastNotPow2)-      ,("GHC.Base.divInt",lastNotPow2)-      ,("GHC.Base.modInt",lastNotPow2)-      ,("GHC.Classes.divInt#",lastNotPow2)-      ,("GHC.Classes.modInt#",lastNotPow2)-      ,("GHC.Integer.Type.timesInteger",allNonPow2)-      ,("GHC.Integer.Type.divInteger",lastNotPow2)-      ,("GHC.Integer.Type.modInteger",lastNotPow2)-      ,("GHC.Integer.Type.quotInteger",lastNotPow2)-      ,("GHC.Integer.Type.remInteger",lastNotPow2)-      ,("GHC.Prim.*#",allNonPow2)-      ,("GHC.Prim.quotInt#",lastNotPow2)-      ,("GHC.Prim.remInt#",lastNotPow2)-      ]--    lArgs       = Either.lefts args--    allNonPow2  = all (not . termIsPow2) lArgs-    tailNonPow2 = case lArgs of-                    [] -> True-                    _  -> all (not . termIsPow2) (tail lArgs)-    lastNotPow2 = case lArgs of-                    [] -> True-                    _  -> not (termIsPow2 (last lArgs))--    termIsPow2 e' = case eval e' of-      Literal (IntegerLiteral n) -> isPow2 n-      a -> case collectArgs a of-        (Prim nm' _,[Right _,Left _,Left (Literal (IntegerLiteral n))])-          | isFromInteger nm' -> isPow2 n-        _ -> False--    isPow2 x = x /= 0 && (x .&. (complement x + 1)) == x--    isFromInteger x = x `elem` ["CLaSH.Sized.Internal.BitVector.fromInteger#"-                               ,"CLaSH.Sized.Integer.Index.fromInteger"-                               ,"CLaSH.Sized.Internal.Signed.fromInteger#"-                               ,"CLaSH.Sized.Internal.Unsigned.fromInteger#"-                               ]--    isHOTy t = case splitFunForallTy t of-      (args',_) -> any isPolyFunTy (Either.rights args')--interestingToLift _ _ _ _ = Nothing
− src/CLaSH/Normalize/PrimitiveReductions.hs 
@@ -1,678 +0,0 @@-{-|-  Copyright  :  (C) 2015-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Reductions of primitives--  Currently, it contains reductions for:--    * CLaSH.Sized.Vector.map-    * CLaSH.Sized.Vector.zipWith-    * CLaSH.Sized.Vector.traverse#-    * CLaSH.Sized.Vector.foldr-    * CLaSH.Sized.Vector.fold-    * CLaSH.Sized.Vector.dfold-    * CLaSH.Sized.Vector.(++)-    * CLaSH.Sized.Vector.head-    * CLaSH.Sized.Vector.tail-    * CLaSH.Sized.Vector.unconcatBitVector#-    * CLaSH.Sized.Vector.replicate-    * CLaSH.Sized.Vector.imap-    * CLaSH.Sized.Vector.dtfold-    * CLaSH.Sized.RTree.tfold--  Partially handles:--    * CLaSH.Sized.Vector.unconcat-    * CLaSH.Sized.Vector.transpose--}--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE ViewPatterns      #-}--module CLaSH.Normalize.PrimitiveReductions where--import qualified Control.Lens                     as Lens-import qualified Data.HashMap.Lazy                as HashMap-import qualified Data.Maybe                       as Maybe-import           Unbound.Generics.LocallyNameless (bind, embed, rec, rebind,-                                                   string2Name)--import           CLaSH.Core.DataCon               (DataCon, dataConInstArgTys)-import           CLaSH.Core.Literal               (Literal (..))-import           CLaSH.Core.Pretty                (showDoc)-import           CLaSH.Core.Term                  (Term (..), Pat (..))-import           CLaSH.Core.Type                  (LitTy (..), Type (..),-                                                   TypeView (..), coreView,-                                                   mkFunTy, mkTyConApp,-                                                   splitFunForallTy, tyView,-                                                   undefinedTy)-import           CLaSH.Core.TyCon                 (TyConName, tyConDataCons)-import           CLaSH.Core.TysPrim               (integerPrimTy, typeNatKind)-import           CLaSH.Core.Util                  (appendToVec, extractElems,-                                                   extractTElems, idToVar,-                                                   mkApps, mkRTree, mkVec,-                                                   termType)-import           CLaSH.Core.Var                   (Var (..))--import           CLaSH.Normalize.Types-import           CLaSH.Rewrite.Types-import           CLaSH.Rewrite.Util-import           CLaSH.Util---- | Replace an application of the @CLaSH.Sized.Vector.zipWith@ primitive on--- vectors of a known length @n@, by the fully unrolled recursive "definition"--- of @CLaSH.Sized.Vector.zipWith@-reduceZipWith :: Integer  -- ^ Length of the vector(s)-              -> Type -- ^ Type of the lhs of the function-              -> Type -- ^ Type of the rhs of the function-              -> Type -- ^ Type of the result of the function-              -> Term -- ^ The zipWith'd functions-              -> Term -- ^ The 1st vector argument-              -> Term -- ^ The 2nd vector argument-              -> NormalizeSession Term-reduceZipWith n lhsElTy rhsElTy resElTy fun lhsArg rhsArg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm lhsArg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- HashMap.lookup vecTcNm tcm-      , [nilCon,consCon] <- tyConDataCons vecTc-      = let (varsL,elemsL)   = second concat . unzip-                             $ extractElems consCon lhsElTy 'L' n lhsArg-            (varsR,elemsR)   = second concat . unzip-                             $ extractElems consCon rhsElTy 'R' n rhsArg-            funApps          = zipWith (\l r -> mkApps fun [Left l,Left r]) varsL varsR-            lbody            = mkVec nilCon consCon resElTy n funApps-            lb               = Letrec (bind (rec (init elemsL ++ init elemsR)) lbody)-        in  changed lb-    go _ ty = error $ $(curLoc) ++ "reduceZipWith: argument does not have a vector type: " ++ showDoc ty---- | Replace an application of the @CLaSH.Sized.Vector.map@ primitive on vectors--- of a known length @n@, by the fully unrolled recursive "definition" of--- @CLaSH.Sized.Vector.map@-reduceMap :: Integer  -- ^ Length of the vector-          -> Type -- ^ Argument type of the function-          -> Type -- ^ Result type of the function-          -> Term -- ^ The map'd function-          -> Term -- ^ The map'd over vector-          -> NormalizeSession Term-reduceMap n argElTy resElTy fun arg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm arg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc)     <- HashMap.lookup vecTcNm tcm-      , [nilCon,consCon] <- tyConDataCons vecTc-      = let (vars,elems)     = second concat . unzip-                             $ extractElems consCon argElTy 'A' n arg-            funApps          = map (fun `App`) vars-            lbody            = mkVec nilCon consCon resElTy n funApps-            lb               = Letrec (bind (rec (init elems)) lbody)-        in  changed lb-    go _ ty = error $ $(curLoc) ++ "reduceMap: argument does not have a vector type: " ++ showDoc ty---- | Replace an application of the @CLaSH.Sized.Vector.imap@ primitive on vectors--- of a known length @n@, by the fully unrolled recursive "definition" of--- @CLaSH.Sized.Vector.imap@-reduceImap :: Integer  -- ^ Length of the vector-           -> Type -- ^ Argument type of the function-           -> Type -- ^ Result type of the function-           -> Term -- ^ The imap'd function-           -> Term -- ^ The imap'd over vector-           -> NormalizeSession Term-reduceImap n argElTy resElTy fun arg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm arg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc)     <- HashMap.lookup vecTcNm tcm-      , [nilCon,consCon] <- tyConDataCons vecTc-      = do-        let (vars,elems)     = second concat . unzip-                             $ extractElems consCon argElTy 'I' n arg-        (Right idxTy:_,_) <- splitFunForallTy <$> termType tcm fun-        let (TyConApp idxTcNm _) = tyView idxTy-            nTv              = string2Name "n"-            -- fromInteger# :: KnownNat n => Integer -> Index n-            idxFromIntegerTy = ForAllTy (bind (TyVar nTv (embed typeNatKind))-                                         (foldr mkFunTy-                                                (mkTyConApp idxTcNm-                                                            [VarTy typeNatKind nTv])-                                                [integerPrimTy,integerPrimTy]))-            idxFromInteger   = Prim "CLaSH.Sized.Internal.Index.fromInteger#"-                                    idxFromIntegerTy-            idxs             = map (App (App (TyApp idxFromInteger (LitTy (NumTy n)))-                                             (Literal (IntegerLiteral (toInteger n))))-                                   . Literal . IntegerLiteral . toInteger) [0..(n-1)]--            funApps          = zipWith (\i v -> App (App fun i) v) idxs vars-            lbody            = mkVec nilCon consCon resElTy n funApps-            lb               = Letrec (bind (rec (init elems)) lbody)-        changed lb-    go _ ty = error $ $(curLoc) ++ "reduceImap: argument does not have a vector type: " ++ showDoc ty---- | Replace an application of the @CLaSH.Sized.Vector.traverse#@ primitive on--- vectors of a known length @n@, by the fully unrolled recursive "definition"--- of @CLaSH.Sized.Vector.traverse#@-reduceTraverse :: Integer  -- ^ Length of the vector-               -> Type -- ^ Element type of the argument vector-               -> Type -- ^ The type of the applicative-               -> Type -- ^ Element type of the result vector-               -> Term -- ^ The @Applicative@ dictionary-               -> Term -- ^ The function to traverse with-               -> Term -- ^ The argument vector-               -> NormalizeSession Term-reduceTraverse n aTy fTy bTy dict fun arg = do-    tcm <- Lens.view tcCache-    (TyConApp apDictTcNm _) <- tyView <$> termType tcm dict-    ty <- termType tcm arg-    go tcm apDictTcNm ty-  where-    go tcm apDictTcNm (coreView tcm -> Just ty') = go tcm apDictTcNm ty'-    go tcm apDictTcNm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- HashMap.lookup vecTcNm tcm-      , [nilCon,consCon] <- tyConDataCons vecTc-      = let (Just apDictTc)    = HashMap.lookup apDictTcNm tcm-            [apDictCon]        = tyConDataCons apDictTc-            (Just apDictIdTys) = dataConInstArgTys apDictCon [fTy]-            apDictIds          = zipWith Id (map string2Name ["functorDict"-                                                             ,"pure"-                                                             ,"ap"-                                                             ,"apConstL"-                                                             ,"apConstR"])-                                            (map embed apDictIdTys)--            (TyConApp funcDictTcNm _) = tyView (head apDictIdTys)-            (Just funcDictTc) = HashMap.lookup funcDictTcNm tcm-            [funcDictCon] = tyConDataCons funcDictTc-            (Just funcDictIdTys) = dataConInstArgTys funcDictCon [fTy]-            funcDicIds    = zipWith Id (map string2Name ["fmap","fmapConst"])-                                       (map embed funcDictIdTys)--            apPat    = DataPat (embed apDictCon) (rebind [] apDictIds)-            fnPat    = DataPat (embed funcDictCon) (rebind [] funcDicIds)--            -- Extract the 'pure' function from the Applicative dictionary-            pureTy = apDictIdTys!!1-            pureTm = Case dict pureTy [bind apPat (Var pureTy (string2Name "pure"))]--            -- Extract the '<*>' function from the Applicative dictionary-            apTy   = apDictIdTys!!2-            apTm   = Case dict apTy [bind apPat (Var apTy (string2Name "ap"))]--            -- Extract the Functor dictionary from the Applicative dictionary-            funcTy = (head apDictIdTys)-            funcTm = Case dict funcTy-                               [bind apPat (Var funcTy (string2Name "functorDict"))]--            -- Extract the 'fmap' function from the Functor dictionary-            fmapTy = (head funcDictIdTys)-            fmapTm = Case (Var funcTy (string2Name "functorDict")) fmapTy-                          [bind fnPat (Var fmapTy (string2Name "fmap"))]--            (vars,elems) = second concat . unzip-                         $ extractElems consCon aTy 'T' n arg--            funApps = map (fun `App`) vars--            lbody   = mkTravVec vecTcNm nilCon consCon (idToVar (apDictIds!!1))-                                                       (idToVar (apDictIds!!2))-                                                       (idToVar (funcDicIds!!0))-                                                       bTy n funApps--            lb      = Letrec (bind (rec ([((apDictIds!!0),embed funcTm)-                                         ,((apDictIds!!1),embed pureTm)-                                         ,((apDictIds!!2),embed apTm)-                                         ,((funcDicIds!!0),embed fmapTm)-                                         ] ++ init elems)) lbody)-          in  changed lb-    go _ _ ty = error $ $(curLoc) ++ "reduceTraverse: argument does not have a vector type: " ++ showDoc ty---- | Create the traversable vector------ e.g. for a length '2' input vector, we get------ > (:>) <$> x0 <*> ((:>) <$> x1 <*> pure Nil)-mkTravVec :: TyConName -- ^ Vec tcon-          -> DataCon   -- ^ Nil con-          -> DataCon   -- ^ Cons con-          -> Term      -- ^ 'pure' term-          -> Term      -- ^ '<*>' term-          -> Term      -- ^ 'fmap' term-          -> Type      -- ^ 'b' ty-          -> Integer       -- ^ Length of the vector-          -> [Term]    -- ^ Elements of the vector-          -> Term-mkTravVec vecTc nilCon consCon pureTm apTm fmapTm bTy = go-  where-    go :: Integer -> [Term] -> Term-    go _ [] = mkApps pureTm [Right (mkTyConApp vecTc [LitTy (NumTy 0),bTy])-                            ,Left  (mkApps (Data nilCon)-                                           [Right (LitTy (NumTy 0))-                                           ,Right bTy-                                           ,Left  (Prim "_CO_" nilCoTy)])]--    go n (x:xs) = mkApps apTm-      [Right (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy])-      ,Right (mkTyConApp vecTc [LitTy (NumTy n),bTy])-      ,Left (mkApps fmapTm [Right bTy-                           ,Right (mkFunTy (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy])-                                           (mkTyConApp vecTc [LitTy (NumTy n),bTy]))-                           ,Left  (mkApps (Data consCon)-                                          [Right (LitTy (NumTy n))-                                          ,Right bTy-                                          ,Right (LitTy (NumTy (n-1)))-                                          ,Left  (Prim "_CO_" (consCoTy n))-                                          ])-                           ,Left  x])-      ,Left (go (n-1) xs)]--    nilCoTy = head (Maybe.fromJust (dataConInstArgTys nilCon [(LitTy (NumTy 0))-                                                             ,bTy]))--    consCoTy n = head (Maybe.fromJust (dataConInstArgTys consCon-                                                         [(LitTy (NumTy n))-                                                         ,bTy-                                                         ,(LitTy (NumTy (n-1)))]))---- | Replace an application of the @CLaSH.Sized.Vector.foldr@ primitive on--- vectors of a known length @n@, by the fully unrolled recursive "definition"--- of @CLaSH.Sized.Vector.foldr@-reduceFoldr :: Integer  -- ^ Length of the vector-            -> Type -- ^ Element type of the argument vector-            -> Term -- ^ The function to fold with-            -> Term -- ^ The starting value-            -> Term -- ^ The argument vector-            -> NormalizeSession Term-reduceFoldr n aTy fun start arg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm arg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- HashMap.lookup vecTcNm tcm-      , [_,consCon] <- tyConDataCons vecTc-      = let (vars,elems)     = second concat . unzip-                             $ extractElems consCon aTy 'G' n arg-            lbody            = foldr (\l r -> mkApps fun [Left l,Left r]) start vars-            lb               = Letrec (bind (rec (init elems)) lbody)-        in  changed lb-    go _ ty = error $ $(curLoc) ++ "reduceFoldr: argument does not have a vector type: " ++ showDoc ty---- | Replace an application of the @CLaSH.Sized.Vector.fold@ primitive on--- vectors of a known length @n@, by the fully unrolled recursive "definition"--- of @CLaSH.Sized.Vector.fold@-reduceFold :: Integer  -- ^ Length of the vector-           -> Type -- ^ Element type of the argument vector-           -> Term -- ^ The function to fold with-           -> Term -- ^ The argument vector-           -> NormalizeSession Term-reduceFold n aTy fun arg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm arg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- HashMap.lookup vecTcNm tcm-      , [_,consCon]  <- tyConDataCons vecTc-      = let (vars,elems)     = second concat . unzip-                             $ extractElems consCon aTy 'F' n arg-            lbody            = foldV vars-            lb               = Letrec (bind (rec (init elems)) lbody)-        in  changed lb-    go _ ty = error $ $(curLoc) ++ "reduceFold: argument does not have a vector type: " ++ showDoc ty--    foldV [a] = a-    foldV as  = let (l,r) = splitAt (length as `div` 2) as-                    lF    = foldV l-                    rF    = foldV r-                in  mkApps fun [Left lF, Left rF]---- | Replace an application of the @CLaSH.Sized.Vector.dfold@ primitive on--- vectors of a known length @n@, by the fully unrolled recursive "definition"--- of @CLaSH.Sized.Vector.dfold@-reduceDFold :: Integer  -- ^ Length of the vector-            -> Type -- ^ Element type of the argument vector-            -> Term -- ^ Function to fold with-            -> Term -- ^ Starting value-            -> Term -- ^ The vector to fold-            -> NormalizeSession Term-reduceDFold n aTy fun start arg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm arg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- HashMap.lookup vecTcNm tcm-      , [_,consCon]  <- tyConDataCons vecTc-      = do-        let  (vars,elems)     = second concat . unzip-                         $ extractElems consCon aTy 'D' n arg-        (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm fun-        let (TyConApp snatTcNm _) = tyView snTy-            (Just snatTc)         = HashMap.lookup snatTcNm tcm-            [snatDc]              = tyConDataCons snatTc-            buildSNat i = mkApps (Data snatDc)-                                 [Right (LitTy (NumTy i))-                                 ,Left (Literal (IntegerLiteral (toInteger i)))-                                 ]-            lbody = doFold buildSNat (n-1) vars-            lb    = Letrec (bind (rec (init elems)) lbody)-        changed lb-    go _ ty = error $ $(curLoc) ++ "reduceDFold: argument does not have a vector type: " ++ showDoc ty--    doFold _    _ []     = start-    doFold snDc k (x:xs) = mkApps fun-                                 [Right (LitTy (NumTy k))-                                 ,Left (snDc k)-                                 ,Left x-                                 ,Left (doFold snDc (k-1) xs)-                                 ]---- | Replace an application of the @CLaSH.Sized.Vector.head@ primitive on--- vectors of a known length @n@, by a projection of the first element of a--- vector.-reduceHead :: Integer  -- ^ Length of the vector-           -> Type -- ^ Element type of the vector-           -> Term -- ^ The argument vector-           -> NormalizeSession Term-reduceHead n aTy vArg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm vArg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- HashMap.lookup vecTcNm tcm-      , [_,consCon]  <- tyConDataCons vecTc-      = let (vars,elems)  = second concat . unzip-                          $ extractElems consCon aTy 'H' n vArg-            lb = Letrec (bind (rec [head elems]) (head vars))-        in  changed lb-    go _ ty = error $ $(curLoc) ++ "reduceHead: argument does not have a vector type: " ++ showDoc ty---- | Replace an application of the @CLaSH.Sized.Vector.tail@ primitive on--- vectors of a known length @n@, by a projection of the tail of a--- vector.-reduceTail :: Integer  -- ^ Length of the vector-           -> Type -- ^ Element type of the vector-           -> Term -- ^ The argument vector-           -> NormalizeSession Term-reduceTail n aTy vArg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm vArg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- HashMap.lookup vecTcNm tcm-      , [_,consCon]  <- tyConDataCons vecTc-      = let (_,elems)    = second concat . unzip-                         $ extractElems consCon aTy 'L' n vArg-            b@(tB,_)     = elems !! 1-            lb           = Letrec (bind (rec [b]) (idToVar tB))-        in  changed lb-    go _ ty = error $ $(curLoc) ++ "reduceTail: argument does not have a vector type: " ++ showDoc ty---- | Replace an application of the @CLaSH.Sized.Vector.last@ primitive on--- vectors of a known length @n@, by a projection of the last element of a--- vector.-reduceLast :: Integer  -- ^ Length of the vector-           -> Type -- ^ Element type of the vector-           -> Term -- ^ The argument vector-           -> NormalizeSession Term-reduceLast n aTy vArg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm vArg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- HashMap.lookup vecTcNm tcm-      , [_,consCon]  <- tyConDataCons vecTc-      = let (_,elems)    = unzip-                         $ extractElems consCon aTy 'L' n vArg-            (tB,_)       = head (last elems)-        in case n of-            0 -> changed (mkApps (Prim "CLaSH.Transformations.undefined" undefinedTy) [Right aTy])-            _ -> changed (Letrec (bind (rec (init (concat elems))) (idToVar tB)))-    go _ ty = error $ $(curLoc) ++ "reduceLast: argument does not have a vector type: " ++ showDoc ty---- | Replace an application of the @CLaSH.Sized.Vector.init@ primitive on--- vectors of a known length @n@, by a projection of the init of a--- vector.-reduceInit :: Integer  -- ^ Length of the vector-           -> Type -- ^ Element type of the vector-           -> Term -- ^ The argument vector-           -> NormalizeSession Term-reduceInit n aTy vArg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm vArg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- HashMap.lookup vecTcNm tcm-      , [nilCon,consCon]  <- tyConDataCons vecTc-      = let (_,elems)    = unzip-                         $ extractElems consCon aTy 'L' n vArg-        in case n of-            0 -> changed (mkApps (Prim "CLaSH.Transformations.undefined" undefinedTy) [Right aTy])-            1 -> changed (mkVec nilCon consCon aTy 0 [])-            _ -> let el = init elems-                     iv = mkVec nilCon consCon aTy (n-1) (map (idToVar . fst . head) el)-                     lb = rec (init (concat el))-                 in  changed (Letrec (bind lb iv))--    go _ ty = error $ $(curLoc) ++ "reduceInit: argument does not have a vector type: " ++ showDoc ty---- | Replace an application of the @CLaSH.Sized.Vector.(++)@ primitive on--- vectors of a known length @n@, by the fully unrolled recursive "definition"--- of @CLaSH.Sized.Vector.(++)@-reduceAppend :: Integer  -- ^ Length of the LHS arg-             -> Integer  -- ^ Lenght of the RHS arg-             -> Type -- ^ Element type of the vectors-             -> Term -- ^ The LHS argument-             -> Term -- ^ The RHS argument-             -> NormalizeSession Term-reduceAppend n m aTy lArg rArg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm lArg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- HashMap.lookup vecTcNm tcm-      , [_,consCon]  <- tyConDataCons vecTc-      = let (vars,elems) = second concat . unzip-                         $ extractElems consCon aTy 'C' n lArg-            lbody        = appendToVec consCon aTy rArg (n+m) vars-            lb           = Letrec (bind (rec (init elems)) lbody)-        in  changed lb-    go _ ty = error $ $(curLoc) ++ "reduceAppend: argument does not have a vector type: " ++ showDoc ty---- | Replace an application of the @CLaSH.Sized.Vector.unconcat@ primitive on--- vectors of a known length @n@, by the fully unrolled recursive "definition"--- of @CLaSH.Sized.Vector.unconcat@-reduceUnconcat :: Integer  -- ^ Length of the result vector-               -> Integer  -- ^ Length of the elements of the result vector-               -> Type -- ^ Element type-               -> Term -- ^ Argument vector-               -> NormalizeSession Term-reduceUnconcat n 0 aTy arg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm arg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc)     <- HashMap.lookup vecTcNm tcm-      , [nilCon,consCon] <- tyConDataCons vecTc-      = let nilVec           = mkVec nilCon consCon aTy 0 []-            innerVecTy       = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy]-            retVec           = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec)-        in  changed retVec-    go _ ty = error $ $(curLoc) ++ "reduceUnconcat: argument does not have a vector type: " ++ showDoc ty--reduceUnconcat _ _ _ _ = error $ $(curLoc) ++ "reduceUnconcat: unimplemented"---- | Replace an application of the @CLaSH.Sized.Vector.transpose@ primitive on--- vectors of a known length @n@, by the fully unrolled recursive "definition"--- of @CLaSH.Sized.Vector.transpose@-reduceTranspose :: Integer  -- ^ Length of the result vector-                -> Integer  -- ^ Length of the elements of the result vector-                -> Type -- ^ Element type-                -> Term -- ^ Argument vector-                -> NormalizeSession Term-reduceTranspose n 0 aTy arg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm arg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc)     <- HashMap.lookup vecTcNm tcm-      , [nilCon,consCon] <- tyConDataCons vecTc-      = let nilVec           = mkVec nilCon consCon aTy 0 []-            innerVecTy       = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy]-            retVec           = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec)-        in  changed retVec-    go _ ty = error $ $(curLoc) ++ "reduceTranspose: argument does not have a vector type: " ++ showDoc ty--reduceTranspose _ _ _ _ = error $ $(curLoc) ++ "reduceTranspose: unimplemented"--reduceReplicate :: Integer-                -> Type-                -> Type-                -> Term-                -> NormalizeSession Term-reduceReplicate n aTy eTy arg = do-    tcm <- Lens.view tcCache-    go tcm eTy-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc)     <- HashMap.lookup vecTcNm tcm-      , [nilCon,consCon] <- tyConDataCons vecTc-      = let retVec = mkVec nilCon consCon aTy n (replicate (fromInteger n) arg)-        in  changed retVec-    go _ ty = error $ $(curLoc) ++ "reduceReplicate: argument does not have a vector type: " ++ showDoc ty---- | Replace an application of the @CLaSH.Sized.Vector.dtfold@ primitive on--- vectors of a known length @n@, by the fully unrolled recursive "definition"--- of @CLaSH.Sized.Vector.dtfold@-reduceDTFold :: Integer  -- ^ Length of the vector-             -> Type     -- ^ Element type of the argument vector-             -> Term     -- ^ Function to convert elements with-             -> Term     -- ^ Function to combine branches with-             -> Term     -- ^ The vector to fold-             -> NormalizeSession Term-reduceDTFold n aTy lrFun brFun arg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm arg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp vecTcNm _)-      | (Just vecTc) <- HashMap.lookup vecTcNm tcm-      , [_,consCon]  <- tyConDataCons vecTc-      = do let (vars,elems) = second concat . unzip-                            $ extractElems consCon aTy 'T' (2^n) arg-           (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm brFun-           let (TyConApp snatTcNm _) = tyView snTy-               (Just snatTc)         = HashMap.lookup snatTcNm tcm-               [snatDc]              = tyConDataCons snatTc-               buildSNat i = mkApps (Data snatDc)-                                    [Right (LitTy (NumTy i))-                                    ,Left (Literal (IntegerLiteral i))-                                    ]-               lbody = doFold buildSNat (n-1) vars-               lb    = Letrec (bind (rec (init elems)) lbody)-           changed lb-    go _ ty = error $ $(curLoc) ++ "reduceDTFold: argument does not have a vector type: " ++ showDoc ty--    doFold :: (Integer -> Term) -> Integer -> [Term] -> Term-    doFold _    _ [x] = mkApps lrFun [Left x]-    doFold snDc k xs  =-      let (xsL,xsR) = splitAt (2^k) xs-          k'        = k-1-          eL        = doFold snDc k' xsL-          eR        = doFold snDc k' xsR-      in  mkApps brFun [Right (LitTy (NumTy k))-                       ,Left  (snDc k)-                       ,Left  eL-                       ,Left  eR-                       ]---- | Replace an application of the @CLaSH.Sized.RTree.tdfold@ primitive on--- trees of a known depth @n@, by the fully unrolled recursive "definition"--- of @CLaSH.Sized.RTree.tdfold@-reduceTFold :: Integer -- ^ Depth of the tree-            -> Type    -- ^ Element type of the argument tree-            -> Term    -- ^ Function to convert elements with-            -> Term    -- ^ Function to combine branches with-            -> Term    -- ^ The tree to fold-            -> NormalizeSession Term-reduceTFold n aTy lrFun brFun arg = do-    tcm <- Lens.view tcCache-    ty  <- termType tcm arg-    go tcm ty-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp treeTcNm _)-      | (Just treeTc) <- HashMap.lookup treeTcNm tcm-      , [lrCon,brCon] <- tyConDataCons treeTc-      = do let (vars,elems)     = extractTElems lrCon brCon aTy 'T' n arg-           (_ltv:Right snTy:_,_) <- splitFunForallTy <$> termType tcm brFun-           let (TyConApp snatTcNm _) = tyView snTy-               (Just snatTc)         = HashMap.lookup snatTcNm tcm-               [snatDc]              = tyConDataCons snatTc-               buildSNat i = mkApps (Data snatDc)-                                    [Right (LitTy (NumTy i))-                                    ,Left (Literal (IntegerLiteral i))-                                    ]-               lbody = doFold buildSNat (n-1) vars-               lb    = Letrec (bind (rec elems) lbody)-           changed lb-    go _ ty = error $ $(curLoc) ++ "reduceTFold: argument does not have a tree type: " ++ showDoc ty--    doFold _    _ [x] = mkApps lrFun [Left x]-    doFold snDc k xs  =-      let (xsL,xsR) = splitAt (length xs `div` 2) xs-          k'        = k-1-          eL        = doFold snDc k' xsL-          eR        = doFold snDc k' xsR-      in  mkApps brFun [Right (LitTy (NumTy k))-                       ,Left (snDc k)-                       ,Left eL-                       ,Left eR-                       ]--reduceTReplicate :: Integer -- ^ Depth of the tree-                 -> Type    -- ^ Element type-                 -> Type    -- ^ Result type-                 -> Term    -- ^ Element-                 -> NormalizeSession Term-reduceTReplicate n aTy eTy arg = do-    tcm <- Lens.view tcCache-    go tcm eTy-  where-    go tcm (coreView tcm -> Just ty') = go tcm ty'-    go tcm (tyView -> TyConApp treeTcNm _)-      | (Just treeTc) <- HashMap.lookup treeTcNm tcm-      , [lrCon,brCon] <- tyConDataCons treeTc-      = let retVec = mkRTree lrCon brCon aTy n (replicate (2^n) arg)-        in  changed retVec-    go _ ty = error $ $(curLoc) ++ "reduceTReplicate: argument does not have a vector type: " ++ showDoc ty
− src/CLaSH/Normalize/Strategy.hs 
@@ -1,218 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Transformation process for normalization--}--module CLaSH.Normalize.Strategy where--import CLaSH.Normalize.Transformations-import CLaSH.Normalize.Types-import CLaSH.Rewrite.Combinators-import CLaSH.Rewrite.Types-import CLaSH.Rewrite.Util---- | Normalisation transformation-normalization :: NormRewrite-normalization = rmDeadcode >-> constantPropgation >-> etaTL >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >->-                bindConst >-> letTL >-> evalConst >-!-> cse >-!-> recLetRec-  where-    etaTL      = apply "etaTL" etaExpansionTL !-> innerMost (apply "applicationPropagation" appProp)-    anf        = topdownR (apply "nonRepANF" nonRepANF) >-> apply "ANF" makeANF-    letTL      = topdownSucR (apply "topLet" topLet)-    recLetRec  = apply "recToLetRec" recToLetRec-    rmUnusedExpr = bottomupR (apply "removeUnusedExpr" removeUnusedExpr)-    rmDeadcode = bottomupR (apply "deadcode" deadCode)-    bindConst  = topdownR (apply "bindConstantVar" bindConstantVar)-    evalConst  = topdownR (apply "evalConst" reduceConst)-    cse        = topdownR (apply "CSE" simpleCSE)---constantPropgation :: NormRewrite-constantPropgation = propagate >-> repeatR inlineAndPropagate >->-                     caseFlattening >-> dec >-> spec >-> dec >->-                     conSpec-  where-    propagate          = innerMost (applyMany transPropagate)-    inlineAndPropagate = (topdownR (applyMany transInlineSafe) >-> inlineNR)-                         !-> propagate-    spec               = bottomupR (applyMany specTransformations)-    caseFlattening     = repeatR (topdownR (apply "caseFlat" caseFlat))-    dec                = repeatR (topdownR (apply "DEC" disjointExpressionConsolidation))-    conSpec            = bottomupR (apply "constantSpec" constantSpec)--    transPropagate :: [(String,NormRewrite)]-    transPropagate =-      [ ("applicationPropagation", appProp        )-      , ("bindConstantVar"       , bindConstantVar)-      , ("caseLet"               , caseLet        )-      , ("caseCase"              , caseCase       )-      , ("caseCon"               , caseCon        )-      ]--    -- These transformations can safely be applied in a top-down traversal as-    -- they themselves check whether the to-be-inlined binder is recursive or not.-    transInlineSafe :: [(String,NormRewrite)]-    transInlineSafe =-       [ ("inlineClosed"    , inlineClosed)-       , ("inlineSmall"     , inlineSmall)-       , ("bindOrLiftNonRep", inlineOrLiftNonRep) -- See: [Note] bindNonRep before liftNonRep-                                                  -- See: [Note] bottom-up traversal for liftNonRep-       , ("reduceNonRepPrim", reduceNonRepPrim)-       ]--    -- InlineNonRep cannot be applied in a top-down traversal, as the non-representable-    -- binder might be recursive. The idea is, is that if the recursive-    -- non-representable binder is inlined once, we can get rid of the recursive-    -- aspect using the case-of-known-constructor-    inlineNR :: NormRewrite-    inlineNR = bottomupR (apply "inlineNonRep" inlineNonRep)--    specTransformations :: [(String,NormRewrite)]-    specTransformations =-      [ ("typeSpec"    , typeSpec)-      , ("nonRepSpec"  , nonRepSpec)-      ]--{- [Note] bottom-up traversal for liftNonRep-We used to say:--"The liftNonRep transformation must be applied in a topDown traversal because-of what CLaSH considers tail calls in its join-point analysis."--Consider:--> let fail = \x -> ...-> in  case ... of->       A -> let fail1 = \y -> case ... of->                                 X -> fail ...->                                 Y -> ...->            in case ... of->                 P -> fail1 ...->                 Q -> ...->       B -> fail ...--under "normal" tail call rules, the local 'fail' functions is not a join-point-because it is used in a let-binding. However, we apply "special" tail call rules-in CLaSH. Because 'fail' is used in a TC position within 'fail1', and 'fail1' is-only used in a TC position, in CLaSH, we consider 'tail' also only to be used-in a TC position.--Now image we apply 'liftNonRep' in a bottom up traversal, we will end up with:--> fail1 = \fail y -> case ... of->   X -> fail ...->   Y -> ...--> let fail = \x -> ...-> in  case ... of->       A -> case ... of->                 P -> fail1 fail ...->                 Q -> ...->       B -> fail ...--Suddenly, 'fail' ends up in an argument position, because it occurred as a-_locally_ bound variable within 'fail1'. And because of that 'fail' stops being-a join-point.--However, when we apply 'liftNonRep' in a top down traversal we end up with:--> fail = \x -> ...->-> fail1 = \y -> case ... of->   X -> fail ...->   Y -> ...->-> let ...-> in  case ... of->       A -> let->            in case ... of->                 P -> fail1 ...->                 Q -> ...->       B -> fail ...--and all is well with the world.--UPDATE:-We can now just perform liftNonRep in a bottom-up traversal again, because-liftNonRep no longer checks that if the binding that is lifted is a join-point.-However, for this to work, bindNonRep must always have been exhaustively applied-before liftNonRep. See also: [Note] bindNonRep before liftNonRep.--}--{- [Note] bindNonRep before liftNonRep-The combination of liftNonRep and nonRepSpec can lead to non-termination in an-unchecked rewrite system (without termination measures in place) on the-following:--> main = f not-> f    = \a x -> (a x) && (f a x)--nonRepSpec will lead to:--> main = f'-> f    = \a x -> (a x) && (f a x)-> f'   = (\a x -> (a x) && (f a x)) not--then lamApp leads to:--> main = f'-> f    = \a x -> (a x) && (f a x)-> f'   = let a = not in (\x -> (a x) && (f a x))--then liftNonRep leads to:--> main = f'-> f    = \a x -> (a x) && (f a x)-> f'   = \x -> (g x) && (f g x)-> g    = not--and nonRepSepc leads to:--> main = f'-> f    = \a x -> (a x) && (f a x)-> f'   = \x -> (g x) && (f'' g x)-> g    = not-> f''  = (\a x -> (a x) && (f a x)) g--This cycle continues indefinitely, as liftNonRep creates a new global variable,-which is never alpha-equivalent to the previous global variable introduced by-liftNonRep.--That is why bindNonRep must always be applied before liftNonRep. When we end up-in the situation after lamApp:--> main = f'-> f    = \a x -> (a x) && (f a x)-> f'   = let a = not in (\x -> (a x) && (f a x))--bindNonRep will now lead to:--> main = f'-> f    = \a x -> (a x) && (f a x)-> f'   = \x -> (not x) && (f not x)--Because `f` has already been specialised on the alpha-equivalent-to-itself `not`-function, liftNonRep leads to:--> main = f'-> f    = \a x -> (a x) && (f a x)-> f'   = \x -> (not x) && (f' x)--And there is no non-terminating rewriting cycle.--That is why bindNonRep must always be exhaustively applied before we apply-liftNonRep.--}---- | Topdown traversal, stops upon first success-topdownSucR :: Rewrite extra -> Rewrite extra-topdownSucR r = r >-! (allR True (topdownSucR r))--innerMost :: Rewrite extra -> Rewrite extra-innerMost r = bottomupR (r !-> innerMost r)--applyMany :: [(String,Rewrite extra)] -> Rewrite extra-applyMany = foldr1 (>->) . map (uncurry apply)
− src/CLaSH/Normalize/Transformations.hs 
@@ -1,1244 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Transformations of the Normalization process--}--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE ViewPatterns      #-}--module CLaSH.Normalize.Transformations-  ( appProp-  , caseLet-  , caseCon-  , caseCase-  , inlineNonRep-  , inlineOrLiftNonRep-  , typeSpec-  , nonRepSpec-  , etaExpansionTL-  , nonRepANF-  , bindConstantVar-  , constantSpec-  , makeANF-  , deadCode-  , topLet-  , recToLetRec-  , inlineClosed-  , inlineHO-  , inlineSmall-  , simpleCSE-  , reduceConst-  , reduceNonRepPrim-  , caseFlat-  , disjointExpressionConsolidation-  , removeUnusedExpr-  )-where--import qualified Control.Lens                as Lens-import qualified Control.Monad               as Monad-import           Control.Monad.Writer        (WriterT (..), lift, tell)-import           Control.Monad.Trans.Except  (runExcept)-import           Data.Bits                   ((.&.), complement)-import qualified Data.Either                 as Either-import qualified Data.HashMap.Lazy           as HashMap-import qualified Data.List                   as List-import qualified Data.Maybe                  as Maybe-import qualified Data.Set                    as Set-import qualified Data.Set.Lens               as Lens-import           Data.Text                   (Text, unpack)-import           Unbound.Generics.LocallyNameless (Bind, Embed (..), bind, embed,-                                              rec, unbind, unembed, unrebind,-                                              unrec, name2String)-import           Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind)--import           CLaSH.Core.DataCon          (DataCon (..))-import           CLaSH.Core.FreeVars         (termFreeIds, termFreeTyVars,-                                              typeFreeVars)-import           CLaSH.Core.Pretty           (showDoc)-import           CLaSH.Core.Subst            (substTm, substTms, substTyInTm,-                                              substTysinTm)-import           CLaSH.Core.Term             (LetBinding, Pat (..), Term (..))-import           CLaSH.Core.Type             (TypeView (..), applyFunTy,-                                              applyTy, isPolyFunCoreTy,-                                              splitFunTy, typeKind,-                                              tyView, undefinedTy)-import           CLaSH.Core.TyCon            (tyConDataCons)-import           CLaSH.Core.Util             (collectArgs, idToVar, isCon,-                                              isFun, isLet, isPolyFun, isPrim,-                                              isSignalType, isVar, mkApps,-                                              mkLams, mkTmApps, mkVec,-                                              termSize, termType, tyNatSize)-import           CLaSH.Core.Var              (Id, Var (..))-import           CLaSH.Netlist.BlackBox.Util (usedArguments)-import           CLaSH.Netlist.Util          (representableType,-                                              splitNormalized)-import           CLaSH.Normalize.DEC-import           CLaSH.Normalize.PrimitiveReductions-import           CLaSH.Normalize.Types-import           CLaSH.Normalize.Util-import           CLaSH.Primitives.Types      (Primitive (..))-import           CLaSH.Rewrite.Combinators-import           CLaSH.Rewrite.Types-import           CLaSH.Rewrite.Util-import           CLaSH.Util--inlineOrLiftNonRep :: NormRewrite-inlineOrLiftNonRep = inlineOrLiftBinders nonRepTest inlineTest-  where-    nonRepTest :: (Var Term, Embed Term) -> RewriteMonad extra Bool-    nonRepTest ((Id _ tyE), _)-      = not <$> (representableType <$> Lens.view typeTranslator-                                   <*> Lens.view allowZero-                                   <*> Lens.view tcCache-                                   <*> pure (unembed tyE))-    nonRepTest _ = return False--    inlineTest :: Term -> (Var Term, Embed Term) -> RewriteMonad extra Bool-    inlineTest e (id_@(Id idName _), exprE)-      = let e' = unembed exprE-        in  not <$> ((||) <$> (elem idName <$> (Lens.toListOf <$> localFreeIds <*> pure e'))-                          -- See: [Note] join points and void wrappers-                          <*> pure (isJoinPointIn id_ e && not (isVoidWrapper e')))--    inlineTest _ _ = return True--{- [Note] join points and void wrappers-Join points are functions that only occur in tail-call positions within an-expression, and only when they occur in a tail-call position more than once.--Normally bindNonRep binds/inlines all non-recursive local functions. However,-doing so for join points would significantly increase compilation time, so we-avoid it. The only exception to this rule are so-called void wrappers. Void-wrappers are functions of the form:--> \(w :: Void) -> f a b c--i.e. a wrapper around the function 'f' where the argument 'w' is not used. We-do bind/line these join-points because these void-wrappers interfere with the-'disjoint expression consolidation' (DEC) and 'common sub-expression elimination'-(CSE) transformation, sometimes resulting in circuits that are twice as big-as they'd need to be.--}---- | Specialize functions on their type-typeSpec :: NormRewrite-typeSpec ctx e@(TyApp e1 ty)-  | (Var _ _,  args) <- collectArgs e1-  , null $ Lens.toListOf typeFreeVars ty-  , (_, []) <- Either.partitionEithers args-  = specializeNorm ctx e--typeSpec _ e = return e---- | Specialize functions on their non-representable argument-nonRepSpec :: NormRewrite-nonRepSpec ctx e@(App e1 e2)-  | (Var _ _, args) <- collectArgs e1-  , (_, [])     <- Either.partitionEithers args-  , null $ Lens.toListOf termFreeTyVars e2-  = do tcm <- Lens.view tcCache-       e2Ty <- termType tcm e2-       localVar <- isLocalVar e2-       nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view allowZero <*> Lens.view tcCache <*> pure e2Ty)-       if nonRepE2 && not localVar-         then specializeNorm ctx e-         else return e--nonRepSpec _ e = return e---- | Lift the let-bindings out of the subject of a Case-decomposition-caseLet :: NormRewrite-caseLet _ (Case (Letrec b) ty alts) = do-  (xes,e) <- unbind b-  changed (Letrec (bind xes (Case e ty alts)))--caseLet _ e = return e---- | Move a Case-decomposition from the subject of a Case-decomposition to the alternatives-caseCase :: NormRewrite-caseCase _ e@(Case (Case scrut alts1Ty alts1) alts2Ty alts2)-  = do-    ty1Rep  <- representableType <$> Lens.view typeTranslator <*> Lens.view allowZero <*> Lens.view tcCache <*> pure alts1Ty-    if not ty1Rep-      then do newAlts <- mapM ( return-                                  . uncurry bind-                                  . second (\altE -> Case altE alts2Ty alts2)-                                  <=< unbind-                                  ) alts1-              changed $ Case scrut alts2Ty newAlts-      else return e--caseCase _ e = return e---- | Inline function with a non-representable result if it's the subject--- of a Case-decomposition-inlineNonRep :: NormRewrite-inlineNonRep _ e@(Case scrut altsTy alts)-  | (Var _ f, args) <- collectArgs scrut-  = do-    (cf,_)    <- Lens.use curFun-    isInlined <- zoomExtra (alreadyInlined f cf)-    limit     <- Lens.use (extra.inlineLimit)-    tcm       <- Lens.view tcCache-    scrutTy   <- termType tcm scrut-    let noException = not (exception tcm scrutTy)-    if noException && (Maybe.fromMaybe 0 isInlined) > limit-      then do-        ty <- termType tcm scrut-        traceIf True (concat [$(curLoc) ++ "InlineNonRep: " ++ show f-                             ," already inlined " ++ show limit ++ " times in:"-                             , show cf-                             , "\nType of the subject is: " ++ showDoc ty-                             , "\nFunction " ++ show cf-                             , " will not reach a normal form, and compilation"-                             , " might fail."-                             , "\nRun with '-clash-inline-limit=N' to increase"-                             , " the inlining limit to N."-                             ])-                     (return e)-      else do-        bodyMaybe   <- fmap (HashMap.lookup f) $ Lens.use bindings-        nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator <*> Lens.view allowZero <*> Lens.view tcCache <*> pure scrutTy)-        case (nonRepScrut, bodyMaybe) of-          (True,Just (_,_,scrutBody)) -> do-            Monad.when noException (zoomExtra (addNewInline f cf))-            changed $ Case (mkApps scrutBody args) altsTy alts-          _ -> return e-  where-    exception tcm ((tyView . typeKind tcm) -> TyConApp (name2String -> "GHC.Types.Constraint") _) = True-    exception _ _ = False--inlineNonRep _ e = return e---- | Specialize a Case-decomposition (replace by the RHS of an alternative) if--- the subject is (an application of) a DataCon; or if there is only a single--- alternative that doesn't reference variables bound by the pattern.-caseCon :: NormRewrite-caseCon _ (Case scrut ty alts)-  | (Data dc, args) <- collectArgs scrut-  = do-    alts' <- mapM unbind alts-    let dcAltM = List.find (equalCon dc . fst) alts'-    case dcAltM of-      Just (DataPat _ pxs, e) ->-        let (tvs,xs) = unrebind pxs-            fvs = Lens.toListOf termFreeIds e-            (binds,_) = List.partition ((`elem` fvs) . varName . fst)-                      $ zip xs (Either.lefts args)-            e' = case binds of-                  [] -> e-                  _  -> Letrec $ bind (rec $ map (second embed) binds) e-            substTyMap = zip (map varName tvs) (drop (length $ dcUnivTyVars dc) (Either.rights args))-        in  changed (substTysinTm substTyMap e')-      _ -> case alts' of-             ((DefaultPat,e):_) -> changed e-             _ -> changed (mkApps (Prim "CLaSH.Transformations.undefined" undefinedTy) [Right ty])-  where-    equalCon dc (DataPat dc' _) = dcTag dc == dcTag (unembed dc')-    equalCon _  _               = False--caseCon _ c@(Case (Literal l) _ alts) = do-  alts' <- mapM unbind alts-  let ltAltsM = List.find (equalLit . fst) alts'-  case ltAltsM of-    Just (LitPat _,e) -> changed e-    _ -> case alts' of-           ((DefaultPat,e):_) -> changed e-           _ -> error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showDoc c-  where-    equalLit (LitPat l')     = l == (unembed l')-    equalLit _               = False--caseCon ctx e@(Case subj ty alts)-  | isConstant subj = do-    tcm <- Lens.view tcCache-    lvl <- Lens.view dbgLevel-    reduceConstant <- Lens.view evaluator-    case reduceConstant tcm True subj of-      Literal l -> caseCon ctx (Case (Literal l) ty alts)-      subj' -> case collectArgs subj' of-        (Data _,_) -> caseCon ctx (Case subj' ty alts)-        (Prim nm ty',repTy:_:msgOrCallStack:_)-          | nm `elem` ["Control.Exception.Base.patError"-                      ,"Control.Exception.Base.absentError"-                      ,"GHC.Err.undefined"] ->-            let e' = mkApps (Prim nm ty') [repTy,Right ty,msgOrCallStack]-            in  changed e'-        (Prim nm ty',[_])-          | nm `elem` ["CLaSH.Transformations.undefined"] ->-            let e' = mkApps (Prim nm ty') [Right ty]-            in changed e'-        (Prim nm _,[])-          | nm `elem` ["EmptyCase"] ->-            changed (Prim nm ty)-        _ -> traceIf (lvl > DebugNone)-                     ("Irreducible constant as case subject: " ++ showDoc subj ++ "\nCan be reduced to: " ++ showDoc subj')-                     (caseOneAlt e)--caseCon _ e = caseOneAlt e--caseOneAlt :: Term -> RewriteMonad extra Term-caseOneAlt e@(Case _ _ [alt]) = do-  (pat,altE) <- unbind alt-  case pat of-    DefaultPat    -> changed altE-    LitPat _      -> changed altE-    DataPat _ pxs -> let (tvs,xs)   = unrebind pxs-                         ftvs       = Lens.toListOf termFreeTyVars altE-                         fvs        = Lens.toListOf termFreeIds altE-                         usedTvs    = filter ((`elem` ftvs) . varName) tvs-                         usedXs     = filter ((`elem` fvs) . varName) xs-                     in  case (usedTvs,usedXs) of-                           ([],[]) -> changed altE-                           _       -> return e--caseOneAlt e = return e---- | Bring an application of a DataCon or Primitive in ANF, when the argument is--- is considered non-representable-nonRepANF :: NormRewrite-nonRepANF ctx e@(App appConPrim arg)-  | (conPrim, _) <- collectArgs e-  , isCon conPrim || isPrim conPrim-  = do-    untranslatable <- isUntranslatable arg-    case (untranslatable,arg) of-      (True,Letrec b) -> do (binds,body) <- unbind b-                            changed (Letrec (bind binds (App appConPrim body)))-      (True,Case {})  -> specializeNorm ctx e-      (True,Lam _)    -> specializeNorm ctx e-      (True,TyLam _)  -> specializeNorm ctx e-      _               -> return e--nonRepANF _ e = return e---- | Ensure that top-level lambda's eventually bind a let-expression of which--- the body is a variable-reference.-topLet :: NormRewrite-topLet ctx e-  | all isLambdaBodyCtx ctx && not (isLet e)-  = do-  untranslatable <- isUntranslatable e-  if untranslatable-    then return e-    else do tcm <- Lens.view tcCache-            (argId,argVar) <- mkTmBinderFor tcm "result" e-            changed . Letrec $ bind (rec [(argId,embed e)]) argVar--topLet ctx e@(Letrec b)-  | all isLambdaBodyCtx ctx-  = do-    (binds,body)   <- unbind b-    localVar       <- isLocalVar body-    untranslatable <- isUntranslatable body-    if localVar || untranslatable-      then return e-      else do tcm <- Lens.view tcCache-              (argId,argVar) <- mkTmBinderFor tcm "result" body-              changed . Letrec $ bind (rec $ unrec binds ++ [(argId,embed body)]) argVar--topLet _ e = return e---- Misc rewrites---- | Remove unused let-bindings-deadCode :: NormRewrite-deadCode _ e@(Letrec binds) = do-    (xes, body) <- fmap (first unrec) $ unbind binds-    let bodyFVs = Lens.toListOf termFreeIds body-        (xesUsed,xesOther) = List.partition-                               ( (`elem` bodyFVs )-                               . varName-                               . fst-                               ) xes-        xesUsed' = findUsedBndrs [] xesUsed xesOther-    if length xesUsed' /= length xes-      then case xesUsed' of-              [] -> changed body-              _  -> changed . Letrec $ bind (rec xesUsed') body-      else return e-  where-    findUsedBndrs :: [(Var Term, Embed Term)] -> [(Var Term, Embed Term)]-                  -> [(Var Term, Embed Term)] -> [(Var Term, Embed Term)]-    findUsedBndrs used []      _     = used-    findUsedBndrs used explore other =-      let fvsUsed = concatMap (Lens.toListOf termFreeIds . unembed . snd) explore-          (explore',other') = List.partition-                                ( (`elem` fvsUsed)-                                . varName-                                . fst-                                ) other-      in findUsedBndrs (used ++ explore) explore' other'--deadCode _ e = return e--removeUnusedExpr :: NormRewrite-removeUnusedExpr _ e@(collectArgs -> (p@(Prim nm _),args)) = do-  bbM <- HashMap.lookup nm <$> Lens.use (extra.primitives)-  case bbM of-    Just (BlackBox pNm _ _ inc templ) -> do-      let usedArgs = if pNm `elem` ["CLaSH.Sized.Internal.Signed.fromInteger#"-                                   ,"CLaSH.Sized.Internal.Unsigned.fromInteger#"-                                   ,"CLaSH.Sized.Internal.BitVector.fromInteger#"-                                   ,"CLaSH.Sized.Internal.Index.fromInteger#"-                                   ]-                        then [0,1]-                        else either usedArguments usedArguments templ ++-                             maybe [] (usedArguments . snd) inc-      tcm <- Lens.view tcCache-      args' <- go tcm 0 usedArgs args-      if args == args'-         then return e-         else changed (mkApps p args')-    _ -> return e-  where-    go _ _ _ [] = return []-    go tcm n used (Right ty:args') = do-      args'' <- go tcm n used args'-      return (Right ty : args'')-    go tcm n used (Left tm : args') = do-      args'' <- go tcm (n+1) used args'-      ty <- termType tcm tm-      let p' = mkApps (Prim "CLaSH.Transformations.removedArg" undefinedTy) [Right ty]-      if n `elem` used-         then return (Left tm : args'')-         else return (Left p' : args'')--removeUnusedExpr _ e@(Case _ _ [alt]) = do-  (pat,altExpr) <- unbind alt-  case pat of-    DataPat _ (unrebind -> ([],xs)) -> do-      let altFreeIds = Lens.setOf termFreeIds altExpr-      if Set.null (Set.intersection (Set.fromList (map varName xs)) altFreeIds)-         then changed altExpr-         else return e-    _ -> return e---- Replace any expression that creates a Vector of size 0 within the application--- of the Cons constructor, by the Nil constructor.-removeUnusedExpr _ e@(collectArgs -> (Data dc, [_,Right aTy,Right nTy,_,Left a,Left nil]))-  | name2String (dcName dc) == "CLaSH.Sized.Vector.Cons"-  = do-    tcm <- Lens.view tcCache-    case runExcept (tyNatSize tcm nTy) of-      Right 0-        | (con, _) <- collectArgs nil-        , not (isCon con)-        -> do eTy <- termType tcm e-              let (TyConApp vecTcNm _) = tyView eTy-                  (Just vecTc) = HashMap.lookup vecTcNm tcm-                  [nilCon,consCon] = tyConDataCons vecTc-                  v = mkVec nilCon consCon aTy 1 [a]-              changed v-      _ -> return e--removeUnusedExpr _ e = return e---- | Inline let-bindings when the RHS is either a local variable reference or--- is constant-bindConstantVar :: NormRewrite-bindConstantVar = inlineBinders test-  where-    test _ (_,Embed e) = (||) <$> isLocalVar e <*> pure (isConstant e)---- | Inline nullary/closed functions-inlineClosed :: NormRewrite-inlineClosed _ e@(collectArgs -> (Var _ f,args))-  | all (either isConstant (const True)) args-  = do-    tcm <- Lens.view tcCache-    eTy <- termType tcm e-    untranslatable <- isUntranslatableType eTy-    let isSignal = isSignalType tcm eTy-    if untranslatable || isSignal-      then return e-      else do-        bndrs <- Lens.use bindings-        case HashMap.lookup f bndrs of-          -- Don't inline recursive expressions-          Just (_,_,body) -> do-            isRecBndr <- isRecursiveBndr f-            if isRecBndr-               then return e-               else changed (mkApps body args)-          _ -> return e--inlineClosed _ e@(Var fTy f) = do-  tcm <- Lens.view tcCache-  let closed   = not (isPolyFunCoreTy tcm fTy)-      isSignal = isSignalType tcm fTy-  untranslatable <- isUntranslatableType fTy-  if closed && not untranslatable && not isSignal-    then do-      bndrs <- Lens.use bindings-      case HashMap.lookup f bndrs of-        -- Don't inline recursive expressions-        Just (_,_,body) -> do-          isRecBndr <- isRecursiveBndr f-          if isRecBndr-             then return e-             else changed body-        _ -> return e-    else return e--inlineClosed _ e = return e---- | Inline small functions-inlineSmall :: NormRewrite-inlineSmall _ e@(collectArgs -> (Var _ f,args)) = do-  untranslatable <- isUntranslatable e-  if untranslatable-    then return e-    else do-      bndrs <- Lens.use bindings-      sizeLimit <- Lens.use (extra.inlineBelow)-      case HashMap.lookup f bndrs of-        -- Don't inline recursive expressions-        Just (_,_,body) -> do-          isRecBndr <- isRecursiveBndr f-          if not isRecBndr && termSize body < sizeLimit-             then changed (mkApps body args)-             else return e-        _ -> return e--inlineSmall _ e = return e---- | Specialise functions on arguments which are constant-constantSpec :: NormRewrite-constantSpec ctx e@(App e1 e2)-  | (Var _ _, args) <- collectArgs e1-  , (_, [])     <- Either.partitionEithers args-  , null $ Lens.toListOf termFreeTyVars e2-  , isConstant e2-  = specializeNorm ctx e--constantSpec _ e = return e----- Experimental---- | Propagate arguments of application inwards; except for 'Lam' where the--- argument becomes let-bound.-appProp :: NormRewrite-appProp _ (App (Lam b) arg) = do-  (v,e) <- unbind b-  if isConstant arg || isVar arg-    then changed $ substTm (varName v) arg e-    else changed . Letrec $ bind (rec [(v,embed arg)]) e--appProp _ (App (Letrec b) arg) = do-  (v,e) <- unbind b-  changed . Letrec $ bind v (App e arg)--appProp ctx (App (Case scrut ty alts) arg) = do-  tcm <- Lens.view tcCache-  argTy <- termType tcm arg-  let ty' = applyFunTy tcm ty argTy-  if isConstant arg || isVar arg-    then do-      alts' <- mapM ( return-                    . uncurry bind-                    . second (`App` arg)-                    <=< unbind-                    ) alts-      changed $ Case scrut ty' alts'-    else do-      (boundArg,argVar) <- mkTmBinderFor tcm (mkDerivedName ctx "app_arg") arg-      alts' <- mapM ( return-                    . uncurry bind-                    . second (`App` argVar)-                    <=< unbind-                    ) alts-      changed . Letrec $ bind (rec [(boundArg,embed arg)]) (Case scrut ty' alts')--appProp _ (TyApp (TyLam b) t) = do-  (tv,e) <- unbind b-  changed $ substTyInTm (varName tv) t e--appProp _ (TyApp (Letrec b) t) = do-  (v,e) <- unbind b-  changed . Letrec $ bind v (TyApp e t)--appProp _ (TyApp (Case scrut altsTy alts) ty) = do-  alts' <- mapM ( return-                . uncurry bind-                . second (`TyApp` ty)-                <=< unbind-                ) alts-  tcm <- Lens.view tcCache-  ty' <- applyTy tcm altsTy ty-  changed $ Case scrut ty' alts'--appProp _ e = return e---- | Flatten ridiculous case-statements generated by GHC------ For case-statements in haskell of the form:------ @--- f :: Unsigned 4 -> Unsigned 4--- f x = case x of---   0 -> 3---   1 -> 2---   2 -> 1---   3 -> 0--- @------ GHC generates Core that looks like:------ @--- f = \(x :: Unsigned 4) -> case x == fromInteger 3 of---                             False -> case x == fromInteger 2 of---                               False -> case x == fromInteger 1 of---                                 False -> case x == fromInteger 0 of---                                   False -> error "incomplete case"---                                   True  -> fromInteger 3---                                 True -> fromInteger 2---                               True -> fromInteger 1---                             True -> fromInteger 0--- @------ Which would result in a priority decoder circuit where a normal decoder--- circuit was desired.------ This transformation transforms the above Core to the saner:------ @--- f = \(x :: Unsigned 4) -> case x of---        _ -> error "incomplete case"---        0 -> fromInteger 3---        1 -> fromInteger 2---        2 -> fromInteger 1---        3 -> fromInteger 0--- @-caseFlat :: NormRewrite-caseFlat _ e@(Case (collectArgs -> (Prim nm _,args)) ty _)-  | isEq nm-  = do let (Left scrut') = args !! 1-       case collectFlat scrut' e of-         Just alts' -> changed (Case scrut' ty (last alts' : init alts'))-         Nothing    -> return e--caseFlat _ e = return e--collectFlat :: Term -> Term -> Maybe [Bind Pat Term]-collectFlat scrut (Case (collectArgs -> (Prim nm _,args)) _ty [lAlt,rAlt])-  | isEq nm-  , scrut' == scrut-  = case collectArgs val of-      (Prim nm' _,args') | isFromInt nm'-        -> case last args' of-            Left (Literal i) -> case (unsafeUnbind lAlt,unsafeUnbind rAlt) of-              ((pl,el),(pr,er))-                | isFalseDcPat pl || isTrueDcPat pr ->-                   case collectFlat scrut el of-                     Just alts' -> Just (bind (LitPat (embed i)) er : alts')-                     Nothing    -> Just [bind (LitPat (embed i)) er-                                        ,bind DefaultPat el-                                        ]-                | otherwise ->-                   case collectFlat scrut er of-                     Just alts' -> Just (bind (LitPat (embed i)) el : alts')-                     Nothing    -> Just [bind (LitPat (embed i)) el-                                        ,bind DefaultPat er-                                        ]-            _ -> Nothing-      _ -> Nothing-  where-    (Left scrut') = args !! 1-    (Left val)    = args !! 2--    isFalseDcPat (DataPat p _)-      = ((== "GHC.Types.False") . name2String . dcName . unembed) p-    isFalseDcPat _ = False--    isTrueDcPat (DataPat p _)-      = ((== "GHC.Types.True") . name2String . dcName . unembed) p-    isTrueDcPat _ = False--collectFlat _ _ = Nothing--isEq :: Text -> Bool-isEq nm = nm == "CLaSH.Sized.Internal.BitVector.eq#" ||-          nm == "CLaSH.Sized.Internal.Index.eq#" ||-          nm == "CLaSH.Sized.Internal.Signed.eq#" ||-          nm == "CLaSH.Sized.Internal.Unsigned.eq#"--isFromInt :: Text -> Bool-isFromInt nm = nm == "CLaSH.Sized.Internal.BitVector.fromInteger#" ||-               nm == "CLaSH.Sized.Internal.Index.fromInteger#" ||-               nm == "CLaSH.Sized.Internal.Signed.fromInteger#" ||-               nm == "CLaSH.Sized.Internal.Unsigned.fromInteger#"--type NormRewriteW = Transform (WriterT [LetBinding] (RewriteMonad NormalizeState))---- NOTE [unsafeUnbind]: Use unsafeUnbind (which doesn't freshen pattern--- variables). Reason: previously collected expression still reference--- the 'old' variable names created by the traversal!---- | Turn an expression into a modified ANF-form. As opposed to standard ANF,--- constants do not become let-bound.-makeANF :: NormRewrite-makeANF ctx (Lam b) = do-  -- See NOTE [unsafeUnbind]-  let (bndr,e) = unsafeUnbind b-  e' <- makeANF (LamBody bndr:ctx) e-  return $ Lam (bind bndr e')--makeANF _ (TyLam b) = return (TyLam b)--makeANF ctx e-  = do-    (e',bndrs) <- runWriterT $ bottomupR collectANF ctx e-    case bndrs of-      [] -> return e-      _  -> changed . Letrec $ bind (rec bndrs) e'--collectANF :: NormRewriteW-collectANF ctx e@(App appf arg)-  | (conVarPrim, _) <- collectArgs e-  , isCon conVarPrim || isPrim conVarPrim || isVar conVarPrim-  = do-    untranslatable <- lift (isUntranslatable arg)-    localVar       <- lift (isLocalVar arg)-    case (untranslatable,localVar || isConstant arg,arg) of-      (False,False,_) -> do tcm <- Lens.view tcCache-                            (argId,argVar) <- lift (mkTmBinderFor tcm (mkDerivedName ctx "app_arg") arg)-                            tell [(argId,embed arg)]-                            return (App appf argVar)-      (True,False,Letrec b) -> do (binds,body) <- unbind b-                                  tell (unrec binds)-                                  return (App appf body)-      _ -> return e--collectANF _ (Letrec b) = do-  -- See NOTE [unsafeUnbind]-  let (binds,body) = unsafeUnbind b-  tell (unrec binds)-  untranslatable <- lift (isUntranslatable body)-  localVar       <- lift (isLocalVar body)-  if localVar || untranslatable-    then return body-    else do-      tcm <- Lens.view tcCache-      (argId,argVar) <- lift (mkTmBinderFor tcm "result" body)-      tell [(argId,embed body)]-      return argVar---- TODO: The code below special-cases ANF for the ':-' constructor for the--- 'Signal' type. The 'Signal' type is essentially treated as a "transparent"--- type by the CLaSH compiler, so observing its constructor leads to all kinds--- of problems. In this case that "CLaSH.Rewrite.Util.mkSelectorCase" will--- try to project the LHS and RHS of the ':-' constructor, however,--- 'mkSelectorCase' uses 'coreView' to find the "real" data-constructor.--- 'coreView' however looks through the 'Signal' type, and hence 'mkSelector'--- finds the data constructors for the element type of Signal. This resulted in--- error #24 (https://github.com/christiaanb/clash2/issues/24), where we--- try to get the first field out of the 'Vec's 'Nil' constructor.------ Ultimately we should stop treating Signal as a "transparent" type and deal--- handling of the Signal type, and the involved co-recursive functions,--- properly. At the moment, CLaSH cannot deal with this recursive type and the--- recursive functions involved, hence the need for special-casing code. After--- everything is done properly, we should remove the two lines below.-collectANF _ e@(Case _ _ [unsafeUnbind -> (DataPat dc _,_)])-  | name2String (dcName $ unembed dc) == "CLaSH.Signal.Internal.:-" = return e--collectANF ctx (Case subj ty alts) = do-    localVar     <- lift (isLocalVar subj)-    (bndr,subj') <- if localVar || isConstant subj-      then return ([],subj)-      else do tcm <- Lens.view tcCache-              (argId,argVar) <- lift (mkTmBinderFor tcm (mkDerivedName ctx "case_scrut") subj)-              return ([(argId,embed subj)],argVar)--    (binds,alts') <- fmap (first concat . unzip) $ mapM (lift . doAlt subj') alts--    tell (bndr ++ binds)-    return (Case subj' ty alts')-  where-    doAlt :: Term -> Bind Pat Term -> RewriteMonad NormalizeState ([LetBinding],Bind Pat Term)-    -- See NOTE [unsafeUnbind]-    doAlt subj' = fmap (second (uncurry bind)) . doAlt' subj' . unsafeUnbind--    doAlt' :: Term -> (Pat,Term) -> RewriteMonad NormalizeState ([LetBinding],(Pat,Term))-    doAlt' subj' alt@(DataPat dc pxs@(unrebind -> ([],xs)),altExpr) = do-      lv      <- isLocalVar altExpr-      patSels <- Monad.zipWithM (doPatBndr subj' (unembed dc)) xs [0..]-      let usesXs (Var _ n) = any ((== n) . varName) xs-          usesXs _         = False-      if (lv && not (usesXs altExpr)) || isConstant altExpr-        then return (patSels,alt)-        else do tcm <- Lens.view tcCache-                (altId,altVar) <- mkTmBinderFor tcm (mkDerivedName ctx "case_alt") altExpr-                return ((altId,embed altExpr):patSels,(DataPat dc pxs,altVar))-    doAlt' _ alt@(DataPat _ _, _) = return ([],alt)-    doAlt' _ alt@(pat,altExpr) = do-      lv <- isLocalVar altExpr-      if lv || isConstant altExpr-        then return ([],alt)-        else do tcm <- Lens.view tcCache-                (altId,altVar) <- mkTmBinderFor tcm (mkDerivedName ctx "case_alt") altExpr-                return ([(altId,embed altExpr)],(pat,altVar))--    doPatBndr :: Term -> DataCon -> Id -> Int -> RewriteMonad NormalizeState LetBinding-    doPatBndr subj' dc pId i-      = do tcm <- Lens.view tcCache-           patExpr <- mkSelectorCase ($(curLoc) ++ "doPatBndr") tcm subj' (dcTag dc) i-           return (pId,embed patExpr)--collectANF _ e = return e---- | Eta-expand top-level lambda's (DON'T use in a traversal!)-etaExpansionTL :: NormRewrite-etaExpansionTL ctx (Lam b) = do-  (bndr,e) <- unbind b-  e' <- etaExpansionTL (LamBody bndr:ctx) e-  return $ Lam (bind bndr e')--etaExpansionTL ctx (Letrec b) = do-  (xesR,e) <- unbind b-  let xes   = unrec xesR-      bndrs = map fst xes-  e' <- etaExpansionTL (LetBody bndrs:ctx) e-  e'' <- stripLambda e'-  case e'' of-    (bs@(_:_),e2) -> do-      let e3 = Letrec (bind xesR e2)-      changed (mkLams e3 bs)-    _ -> return (Letrec (bind xesR e'))-  where-    stripLambda :: Term -> RewriteMonad NormalizeState ([Id],Term)-    stripLambda (Lam b') = do-      (bndr,e)   <- unbind b'-      (bndrs,e') <- stripLambda e-      return (bndr:bndrs,e')-    stripLambda e = return ([],e)--etaExpansionTL ctx e-  = do-    tcm <- Lens.view tcCache-    isF <- isFun tcm e-    if isF-      then do-        argTy <- ( return-                 . fst-                 . Maybe.fromMaybe (error $ $(curLoc) ++ "etaExpansion splitFunTy")-                 . splitFunTy tcm-                 <=< termType tcm-                 ) e-        (newIdB,newIdV) <- mkInternalVar "arg" argTy-        e' <- etaExpansionTL (LamBody newIdB:ctx) (App e newIdV)-        changed . Lam $ bind newIdB e'-      else return e---- | Turn a  normalized recursive function, where the recursive calls only pass--- along the unchanged original arguments, into let-recursive function. This--- means that all recursive calls are replaced by the same variable reference as--- found in the body of the top-level let-expression.-recToLetRec :: NormRewrite-recToLetRec [] e = do-  (fn,_)      <- Lens.use curFun-  bodyM       <- fmap (HashMap.lookup fn) $ Lens.use bindings-  tcm         <- Lens.view tcCache-  normalizedE <- splitNormalized tcm e-  case (normalizedE,bodyM) of-    (Right (args,bndrs,res), Just (bodyTy,_,_)) -> do-      let appF              = mkTmApps (Var bodyTy fn) (map idToVar args)-          (toInline,others) = List.partition ((==) appF . unembed . snd) bndrs-          resV              = idToVar res-      case (toInline,others) of-        (_:_,_:_) -> do-          let substsInline = map (\(id_,_) -> (varName id_,resV)) toInline-              others'      = map (second (embed . substTms substsInline . unembed)) others-          changed $ mkLams (Letrec $ bind (rec others') resV) args-        _ -> return e-    _ -> return e--recToLetRec _ e = return e---- | Inline a function with functional arguments-inlineHO :: NormRewrite-inlineHO _ e@(App _ _)-  | (Var _ f, args) <- collectArgs e-  = do-    tcm <- Lens.view tcCache-    hasPolyFunArgs <- or <$> mapM (either (isPolyFun tcm) (const (return False))) args-    if hasPolyFunArgs-      then do (cf,_)    <- Lens.use curFun-              isInlined <- zoomExtra (alreadyInlined f cf)-              limit     <- Lens.use (extra.inlineLimit)-              if (Maybe.fromMaybe 0 isInlined) > limit-                then do-                  lvl <- Lens.view dbgLevel-                  traceIf (lvl > DebugNone) ($(curLoc) ++ "InlineHO: " ++ show f ++ " already inlined " ++ show limit ++ " times in:" ++ show cf) (return e)-                else do-                  bodyMaybe <- fmap (HashMap.lookup f) $ Lens.use bindings-                  case bodyMaybe of-                    Just (_,_,body) -> do-                      zoomExtra (addNewInline f cf)-                      changed (mkApps body args)-                    _ -> return e-      else return e--inlineHO _ e = return e---- | Simplified CSE, only works on let-bindings, works from top to bottom-simpleCSE :: NormRewrite-simpleCSE _ e@(Letrec b) = do-  (binders,body) <- first unrec <$> unbind b-  let (reducedBindings,body') = reduceBindersFix binders body-  if length binders /= length reducedBindings-     then changed (Letrec (bind (rec reducedBindings) body'))-     else return e--simpleCSE _ e = return e--reduceBindersFix :: [LetBinding]-                 -> Term-                 -> ([LetBinding],Term)-reduceBindersFix binders body = if length binders /= length reduced-                                   then reduceBindersFix reduced body'-                                   else (binders,body)-  where-    (reduced,body') = reduceBinders [] body binders--reduceBinders :: [LetBinding]-              -> Term-              -> [LetBinding]-              -> ([LetBinding],Term)-reduceBinders processed body [] = (processed,body)-reduceBinders processed body ((id_,expr):binders) = case List.find ((== expr) . snd) processed of-    Just (id2,_) ->-      let var        = Var (unembed (varType id2)) (varName id2)-          idName     = varName id_-          processed' = map (second (Embed . (substTm idName var) . unembed)) processed-          binders'   = map (second (Embed . (substTm idName var) . unembed)) binders-          body'      = substTm idName var body-      in  reduceBinders processed' body' binders'-    Nothing -> reduceBinders ((id_,expr):processed) body binders--reduceConst :: NormRewrite-reduceConst _ e@(App _ _)-  | isConstant e-  , (conPrim, _) <- collectArgs e-  , isPrim conPrim-  = do-    tcm <- Lens.view tcCache-    reduceConstant <- Lens.view evaluator-    case reduceConstant tcm False e of-      e'@(Literal _) -> changed e'-      e'@(collectArgs -> (Data _,_)) -> changed e'-      _              -> return e--reduceConst _ e = return e---- | Replace primitives by their "definition" if they would lead to let-bindings--- with a non-representable type when a function is in ANF. This happens for--- example when CLaSH.Size.Vector.map consumes or produces a vector of--- non-representable elements.------ Basically what this transformation does is replace a primitive the completely--- unrolled recursive definition that it represents. e.g.------ > zipWith ($) (xs :: Vec 2 (Int -> Int)) (ys :: Vec 2 Int)------ is replaced by:------ > let (x0  :: (Int -> Int))       = case xs  of (:>) _ x xr -> x--- >     (xr0 :: Vec 1 (Int -> Int)) = case xs  of (:>) _ x xr -> xr--- >     (x1  :: (Int -> Int)(       = case xr0 of (:>) _ x xr -> x--- >     (y0  :: Int)                = case ys  of (:>) _ y yr -> y--- >     (yr0 :: Vec 1 Int)          = case ys  of (:>) _ y yr -> xr--- >     (y1  :: Int                 = case yr0 of (:>) _ y yr -> y--- > in  (($) x0 y0 :> ($) x1 y1 :> Nil)------ Currently, it only handles the following functions:------ * CLaSH.Sized.Vector.map--- * CLaSH.Sized.Vector.zipWith--- * CLaSH.Sized.Vector.traverse#--- * CLaSH.Sized.Vector.foldr--- * CLaSH.Sized.Vector.fold--- * CLaSH.Sized.Vector.dfold--- * CLaSH.Sized.Vector.(++)--- * CLaSH.Sized.Vector.head--- * CLaSH.Sized.Vector.tail--- * CLaSH.Sized.Vector.unconcat--- * CLaSH.Sized.Vector.transpose--- * CLaSH.Sized.Vector.replicate--- * CLaSH.Sized.Vector.dtfold-reduceNonRepPrim :: NormRewrite-reduceNonRepPrim _ e@(App _ _) | (Prim f _, args) <- collectArgs e = do-  tcm <- Lens.view tcCache-  eTy <- termType tcm e-  case tyView eTy of-    (TyConApp vecTcNm@(name2String -> "CLaSH.Sized.Vector.Vec")-              [runExcept . tyNatSize tcm -> Right 0, aTy]) -> do-      let (Just vecTc) = HashMap.lookup vecTcNm tcm-          [nilCon,consCon] = tyConDataCons vecTc-          nilE = mkVec nilCon consCon aTy 0 []-      changed nilE-    tv -> case f of-      "CLaSH.Sized.Vector.zipWith" | length args == 7 -> do-        let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args-        case runExcept (tyNatSize tcm nTy) of-          Right n -> do-            untranslatableTys <- mapM isUntranslatableType_not_poly [lhsElTy,rhsElty,resElTy]-            if or untranslatableTys-               then let [fun,lhsArg,rhsArg] = Either.lefts args-                    in  reduceZipWith n lhsElTy rhsElty resElTy fun lhsArg rhsArg-               else return e-          _ -> return e-      "CLaSH.Sized.Vector.map" | length args == 5 -> do-        let [argElTy,resElTy,nTy] = Either.rights args-        case runExcept (tyNatSize tcm nTy) of-          Right n -> do-            untranslatableTys <- mapM isUntranslatableType_not_poly [argElTy,resElTy]-            if or untranslatableTys-               then let [fun,arg] = Either.lefts args-                    in  reduceMap n argElTy resElTy fun arg-               else return e-          _ -> return e-      "CLaSH.Sized.Vector.traverse#" | length args == 7 ->-        let [aTy,fTy,bTy,nTy] = Either.rights args-        in  case runExcept (tyNatSize tcm nTy) of-          Right n ->-            let [dict,fun,arg] = Either.lefts args-            in  reduceTraverse n aTy fTy bTy dict fun arg-          _ -> return e-      "CLaSH.Sized.Vector.fold" | length args == 4 -> do-        let [aTy,nTy] = Either.rights args-            isPow2 x  = x /= 0 && (x .&. (complement x + 1)) == x-        untranslatableTy <- isUntranslatableType_not_poly aTy-        case runExcept (tyNatSize tcm nTy) of-          Right n | not (isPow2 (n + 1)) || untranslatableTy ->-            let [fun,arg] = Either.lefts args-            in  reduceFold (n + 1) aTy fun arg-          _ -> return e-      "CLaSH.Sized.Vector.foldr" | length args == 6 ->-        let [aTy,bTy,nTy] = Either.rights args-        in  case runExcept (tyNatSize tcm nTy) of-          Right n -> do-            untranslatableTys <- mapM isUntranslatableType_not_poly [aTy,bTy]-            if or untranslatableTys-              then let [fun,start,arg] = Either.lefts args-                   in  reduceFoldr n aTy fun start arg-              else return e-          _ -> return e-      "CLaSH.Sized.Vector.dfold" | length args == 8 ->-        let ([_kn,_motive,fun,start,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args-        in  case runExcept (tyNatSize tcm nTy) of-          Right n -> reduceDFold n aTy fun start arg-          _ -> return e-      "CLaSH.Sized.Vector.++" | length args == 5 ->-        let [nTy,aTy,mTy] = Either.rights args-            [lArg,rArg]   = Either.lefts args-        in case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of-              (Right n, Right m)-                | n == 0 -> changed rArg-                | m == 0 -> changed lArg-                | otherwise -> do-                    untranslatableTy <- isUntranslatableType_not_poly aTy-                    if untranslatableTy-                       then reduceAppend n m aTy lArg rArg-                       else return e-              _ -> return e-      "CLaSH.Sized.Vector.head" | length args == 3 -> do-        let [nTy,aTy] = Either.rights args-            [vArg]    = Either.lefts args-        case runExcept (tyNatSize tcm nTy) of-          Right n -> do-            untranslatableTy <- isUntranslatableType_not_poly aTy-            if untranslatableTy-               then reduceHead n aTy vArg-               else return e-          _ -> return e-      "CLaSH.Sized.Vector.tail" | length args == 3 -> do-        let [nTy,aTy] = Either.rights args-            [vArg]    = Either.lefts args-        case runExcept (tyNatSize tcm nTy) of-          Right n -> do-            untranslatableTy <- isUntranslatableType_not_poly aTy-            if untranslatableTy-               then reduceTail n aTy vArg-               else return e-          _ -> return e-      "CLaSH.Sized.Vector.last" | length args == 3 -> do-        let [nTy,aTy] = Either.rights args-            [vArg]    = Either.lefts args-        case runExcept (tyNatSize tcm nTy) of-          Right n -> do-            untranslatableTy <- isUntranslatableType_not_poly aTy-            if untranslatableTy-               then reduceLast n aTy vArg-               else return e-          _ -> return e-      "CLaSH.Sized.Vector.init" | length args == 3 -> do-        let [nTy,aTy] = Either.rights args-            [vArg]    = Either.lefts args-        case runExcept (tyNatSize tcm nTy) of-          Right n -> do-            untranslatableTy <- isUntranslatableType_not_poly aTy-            if untranslatableTy-               then reduceInit n aTy vArg-               else return e-          _ -> return e-      "CLaSH.Sized.Vector.unconcat" | length args == 6 -> do-        let ([_knN,_sm,arg],[mTy,nTy,aTy]) = Either.partitionEithers args-        case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of-          (Right n, Right 0) -> reduceUnconcat n 0 aTy arg-          _ -> return e-      "CLaSH.Sized.Vector.transpose" | length args == 5 -> do-        let ([_knN,arg],[mTy,nTy,aTy]) = Either.partitionEithers args-        case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of-          (Right n, Right 0) -> reduceTranspose n 0 aTy arg-          _ -> return e-      "CLaSH.Sized.Vector.replicate" | length args == 4 -> do-        let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args-        case runExcept (tyNatSize tcm nTy) of-          Right n -> do-            untranslatableTy <- isUntranslatableType_not_poly aTy-            if untranslatableTy-               then reduceReplicate n aTy eTy vArg-               else return e-          _ -> return e-      "CLaSH.Sized.Vector.imap" | length args == 6 -> do-        let [nTy,argElTy,resElTy] = Either.rights args-        case runExcept (tyNatSize tcm nTy) of-          Right n -> do-            untranslatableTys <- mapM isUntranslatableType_not_poly [argElTy,resElTy]-            if or untranslatableTys-               then let [_,fun,arg] = Either.lefts args-                    in  reduceImap n argElTy resElTy fun arg-               else return e-          _ -> return e-      "CLaSH.Sized.Vector.dtfold" | length args == 8 ->-        let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args-        in  case runExcept (tyNatSize tcm nTy) of-          Right n -> reduceDTFold n aTy lrFun brFun arg-          _ -> return e-      "CLaSH.Sized.RTree.tdfold" | length args == 8 ->-        let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args-        in  case runExcept (tyNatSize tcm nTy) of-          Right n -> reduceTFold n aTy lrFun brFun arg-          _ -> return e-      "CLaSH.Sized.RTree.treplicate" | length args == 4 -> do-        let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args-        case runExcept (tyNatSize tcm nTy) of-          Right n -> do-            untranslatableTy <- isUntranslatableType aTy-            if untranslatableTy-               then reduceReplicate n aTy eTy vArg-               else return e-          _ -> return e-      "CLaSH.Sized.Internal.BitVector.split#" | length args == 4 -> do-        let ([_knArg,bvArg],[nTy,mTy]) = Either.partitionEithers args-        case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy), tv) of-          (Right n, Right m, TyConApp tupTcNm [lTy,rTy])-            | n == 0 -> do-              let (Just tupTc) = HashMap.lookup tupTcNm tcm-                  [tupDc]      = tyConDataCons tupTc-                  tup          = mkApps (Data tupDc)-                                    [Right lTy-                                    ,Right rTy-                                    ,Left  bvArg-                                    ,Left  (mkApps (Prim "CLaSH.Transformations.removedArg" undefinedTy)-                                                   [Right rTy])-                                    ]--              changed tup-            | m == 0 -> do-              let (Just tupTc) = HashMap.lookup tupTcNm tcm-                  [tupDc]      = tyConDataCons tupTc-                  tup          = mkApps (Data tupDc)-                                    [Right lTy-                                    ,Right rTy-                                    ,Left  (mkApps (Prim "CLaSH.Transformations.removedArg" undefinedTy)-                                                   [Right lTy])-                                    ,Left  bvArg-                                    ]--              changed tup-          _ -> return e-      "CLaSH.Sized.Internal.BitVector.eq#"-        | ([_,_],[nTy]) <- Either.partitionEithers args-        , Right 0 <- runExcept (tyNatSize tcm nTy)-        , TyConApp boolTcNm [] <- tv-        -> let (Just boolTc) = HashMap.lookup boolTcNm tcm-               [_falseDc,trueDc] = tyConDataCons boolTc-           in  changed (Data trueDc)-      _ -> return e-  where-    isUntranslatableType_not_poly t = do-      u <- isUntranslatableType t-      if u-         then return (null $ Lens.toListOf typeFreeVars t)-         else return False--reduceNonRepPrim _ e = return e---- | This transformation lifts applications of global binders out of--- alternatives of case-statements.------ e.g. It converts:------ @--- case x of---   A -> f 3 y---   B -> f x x---   C -> h x--- @------ into:------ @--- let f_arg0 = case x of {A -> 3; B -> x}---     f_arg1 = case x of {A -> y; B -> x}---     f_out  = f f_arg0 f_arg1--- in  case x of---       A -> f_out---       B -> f_out---       C -> h x--- @-disjointExpressionConsolidation :: NormRewrite-disjointExpressionConsolidation ctx e@(Case _scrut _ty _alts@(_:_:_)) = do-    let eFreeIds = Lens.setOf termFreeIds e-    (_,collected) <- collectGlobals eFreeIds [] [] e-    let disJoint = filter (isDisjoint . snd. snd) collected-    if null disJoint-       then return e-       else do-         exprs <- mapM (mkDisjointGroup eFreeIds) disJoint-         tcm <- Lens.view tcCache-         (lids,lvs) <- unzip <$> Monad.zipWithM (mkFunOut tcm) disJoint exprs-         let substitution = zip (map fst disJoint) lvs-             subsMatrix   = l2m substitution-         (exprs',_) <- unzip <$> Monad.zipWithM (\s (e',seen) -> collectGlobals eFreeIds s seen e')-                                                subsMatrix-                                                exprs-         (e',_) <- collectGlobals eFreeIds substitution [] e-         let lb = Letrec (bind (rec (zip lids (map embed exprs'))) e')-         lb' <- bottomupR deadCode ctx lb-         changed lb'-  where-    mkFunOut tcm (fun,_) (e',_) = do-      ty <- termType tcm e'-      let nm  = case collectArgs fun of-                   (Var _ nm',_)  -> name2String nm'-                   (Prim nm' _,_) -> unpack nm'-                   _             -> "complex_expression_"-          nm'' = (reverse . List.takeWhile (/='.') . reverse) nm ++ "Out"-      mkInternalVar nm'' ty--    l2m = go []-      where-        go _  []     = []-        go xs (y:ys) = (xs ++ ys) : go (xs ++ [y]) ys--disjointExpressionConsolidation _ e = return e
− src/CLaSH/Normalize/Types.hs 
@@ -1,66 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Types used in Normalize modules--}--{-# LANGUAGE TemplateHaskell #-}--module CLaSH.Normalize.Types where--import Control.Monad.State.Strict (State)-import Data.HashMap.Strict (HashMap)-import Data.Map            (Map)--import SrcLoc (SrcSpan)--import CLaSH.Core.Term        (Term, TmName)-import CLaSH.Core.Type        (Type)-import CLaSH.Netlist.BlackBox.Types (BlackBoxTemplate)-import CLaSH.Primitives.Types (PrimMap)-import CLaSH.Rewrite.Types    (Rewrite, RewriteMonad)-import CLaSH.Util---- | State of the 'NormalizeMonad'-data NormalizeState-  = NormalizeState-  { _normalized          :: HashMap TmName (Type,SrcSpan,Term)-  -- ^ Global binders-  , _specialisationCache :: Map (TmName,Int,Either Term Type) (TmName,Type)-  -- ^ Cache of previously specialised functions:-  ---  -- * Key: (name of the original function, argument position, specialised term/type)-  ---  -- * Elem: (name of specialised function,type of specialised function)-  , _specialisationHistory :: HashMap TmName Int-  -- ^ Cache of how many times a function was specialized-  , _specialisationLimit :: !Int-  -- ^ Number of time a function 'f' can be specialized-  , _inlineHistory   :: HashMap TmName (HashMap TmName Int)-  -- ^ Cache of function where inlining took place:-  ---  -- * Key: function where inlining took place-  ---  -- * Elem: (functions which were inlined, number of times inlined)-  , _inlineLimit     :: !Int-  -- ^ Number of times a function 'f' can be inlined in a function 'g'-  , _inlineBelow     :: !Int-  -- ^ Size of a function below which it is always inlined if it is not-  -- recursive-  , _primitives :: PrimMap BlackBoxTemplate -- ^ Primitive Definitions-  , _recursiveComponents :: HashMap TmName Bool-  -- ^ Map telling whether a components is part of a recursive group-  }--makeLenses ''NormalizeState---- | State monad that stores specialisation and inlining information-type NormalizeMonad = State NormalizeState---- | RewriteSession with extra Normalisation information-type NormalizeSession = RewriteMonad NormalizeState---- | A 'Transform' action in the context of the 'RewriteMonad' and 'NormalizeMonad'-type NormRewrite = Rewrite NormalizeState
− src/CLaSH/Normalize/Util.hs 
@@ -1,167 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Utility functions used by the normalisation transformations--}--{-# LANGUAGE LambdaCase      #-}-{-# LANGUAGE TemplateHaskell #-}--module CLaSH.Normalize.Util where--import           Control.Lens            ((%=),(^.),_3)-import qualified Control.Lens            as Lens-import           Data.Function           (on)-import qualified Data.Graph              as Graph-import           Data.Graph.Inductive    (Gr,LNode,lsuc,mkGraph,iDom)-import           Data.HashMap.Lazy       (HashMap)-import qualified Data.HashMap.Lazy       as HashMap-import qualified Data.List               as List-import qualified Data.Maybe              as Maybe-import qualified Data.Set                as Set-import qualified Data.Set.Lens           as Lens-import           Unbound.Generics.LocallyNameless (Fresh, bind, embed, rec)--import           SrcLoc                  (SrcSpan)--import           CLaSH.Core.FreeVars     (termFreeIds)-import           CLaSH.Core.Var          (Var (Id))-import           CLaSH.Core.Term         (Term (..), TmName)-import           CLaSH.Core.Type         (Type)-import           CLaSH.Core.TyCon        (TyCon, TyConName)-import           CLaSH.Core.Util         (collectArgs, isPolyFun)-import           CLaSH.Normalize.Types-import           CLaSH.Rewrite.Types     (bindings,extra)-import           CLaSH.Rewrite.Util      (specialise)-import           CLaSH.Util              (curLoc)---- | Determine if a function is already inlined in the context of the 'NetlistMonad'-alreadyInlined :: TmName -- ^ Function we want to inline-               -> TmName -- ^ Function in which we want to perform the inlining-               -> NormalizeMonad (Maybe Int)-alreadyInlined f cf = do-  inlinedHM <- Lens.use inlineHistory-  case HashMap.lookup cf inlinedHM of-    Nothing       -> return Nothing-    Just inlined' -> return (HashMap.lookup f inlined')--addNewInline :: TmName -- ^ Function we want to inline-             -> TmName -- ^ Function in which we want to perform the inlining-             -> NormalizeMonad ()-addNewInline f cf =-  inlineHistory %= HashMap.insertWith-                     (\_ hm -> HashMap.insertWith (+) f 1 hm)-                     cf-                     (HashMap.singleton f 1)---- | Specialize under the Normalization Monad-specializeNorm :: NormRewrite-specializeNorm = specialise specialisationCache specialisationHistory specialisationLimit---- | Determine if a term is closed-isClosed :: Fresh m-         => HashMap TyConName TyCon-         -> Term-         -> m Bool-isClosed tcm = fmap not . isPolyFun tcm---- | Determine if a term represents a constant-isConstant :: Term -> Bool-isConstant e = case collectArgs e of-  (Data _, args)   -> all (either isConstant (const True)) args-  (Prim _ _, args) -> all (either isConstant (const True)) args-  (Literal _,_)    -> True-  _                -> False--isRecursiveBndr :: TmName -> NormalizeSession Bool-isRecursiveBndr f = do-  cg <- Lens.use (extra.recursiveComponents)-  case HashMap.lookup f cg of-    Just isR -> return isR-    Nothing -> do-      bndrs <- Lens.use bindings-      let cg'  = callGraph [] bndrs f-          rcs  = concat $ mkRecursiveComponents cg'-          isR  = f `elem` rcs-          cg'' = HashMap.fromList-               $ map (\(t,_) -> (t,t `elem` rcs)) cg'-      (extra.recursiveComponents) %= HashMap.union cg''-      return isR---- | Create a call graph for a set of global binders, given a root-callGraph :: [TmName] -- ^ List of functions that should not be inspected-          -> HashMap TmName (Type,SrcSpan,Term) -- ^ Global binders-          -> TmName -- ^ Root of the call graph-          -> [(TmName,[TmName])]-callGraph visited bindingMap root = node:other-  where-    rootTm = Maybe.fromMaybe (error $ show root ++ " is not a global binder") $ HashMap.lookup root bindingMap-    used   = Set.toList $ Lens.setOf termFreeIds (rootTm ^. _3)-    node   = (root,used)-    other  = concatMap (callGraph (root:visited) bindingMap) (filter (`notElem` visited) used)---- | Determine the sets of recursive components given the edges of a callgraph-mkRecursiveComponents :: [(TmName,[TmName])] -- ^ [(calling function,[called function])]-                    -> [[TmName]]-mkRecursiveComponents cg = map (List.sortBy (compare `on` (`List.elemIndex` fs)))-                         . Maybe.catMaybes-                         . map (\case {Graph.CyclicSCC vs -> Just vs; _ -> Nothing})-                         . Graph.stronglyConnComp-                         $ map (\(n,es) -> (n,n,es)) cg-  where-    fs = map fst cg--lambdaDropPrep :: HashMap TmName (Type,SrcSpan,Term)-               -> TmName-               -> HashMap TmName (Type,SrcSpan,Term)-lambdaDropPrep bndrs topEntity = bndrs'-  where-    depGraph = callGraph [] bndrs topEntity-    used     = HashMap.fromList depGraph-    rcs      = mkRecursiveComponents depGraph-    dropped  = map (lambdaDrop bndrs used) rcs-    bndrs'   = foldr (\(k,v) b -> HashMap.insert k v b) bndrs dropped--lambdaDrop :: HashMap TmName (Type,SrcSpan,Term) -- ^ Original Binders-           -> HashMap TmName [TmName]    -- ^ Dependency Graph-           -> [TmName]                   -- ^ Recursive block-           -> (TmName,(Type,SrcSpan,Term))       -- ^ Lambda-dropped Binders-lambdaDrop bndrs depGraph cyc@(root:_) = block-  where-    doms  = dominator depGraph cyc-    block = blockSink bndrs doms (0,root)--lambdaDrop _ _ [] = error $ $(curLoc) ++ "Can't lambdadrop empty cycle"--dominator :: HashMap TmName [TmName] -- ^ Dependency Graph-          -> [TmName]                -- ^ Recursive block-          -> Gr TmName TmName        -- ^ Recursive block dominator-dominator cfg cyc = mkGraph nodes (map (\(e,b) -> (b,e,nodesM HashMap.! e)) doms)-  where-    nodes    = zip [0..] cyc-    nodesM   = HashMap.fromList nodes-    nodesI   = HashMap.fromList $ zip cyc [0..]-    cycEdges = HashMap.map ( map (nodesI HashMap.!)-                           . filter (`elem` cyc)-                           )-             $ HashMap.filterWithKey (\k _ -> k `elem` cyc) cfg-    edges    = concatMap (\(i,n) -> zip3 (repeat i) (cycEdges HashMap.! n) (repeat ())-                         ) nodes-    graph    = mkGraph nodes edges :: Gr TmName ()-    doms     = iDom graph 0--blockSink :: HashMap TmName (Type,SrcSpan,Term) -- ^ Original Binders-          -> Gr TmName TmName           -- ^ Recursive block dominator-          -> LNode TmName               -- ^ Recursive block dominator root-          -> (TmName,(Type,SrcSpan,Term))       -- ^ Block sank binder-blockSink bndrs doms (nId,tmName) = (tmName,(ty,sp,newTm))-  where-    (ty,sp,tm) = bndrs HashMap.! tmName-    sucTm   = lsuc doms nId-    tmS     = map (blockSink bndrs doms) sucTm-    bnds    = map (\(tN,(ty',_,tm')) -> (Id tN (embed ty'),embed tm')) tmS-    newTm   = case sucTm of-                [] -> tm-                _  -> Letrec (bind (rec bnds) tm)
− src/CLaSH/Primitives/Types.hs 
@@ -1,57 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Type and instance definitions for Primitive--}--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedStrings #-}--module CLaSH.Primitives.Types where--import           Control.Applicative  ((<|>))-import           Data.Aeson           (FromJSON (..), Value (..), (.:), (.:?), (.!=))-import           Data.HashMap.Lazy    (HashMap)-import qualified Data.HashMap.Strict  as H-import qualified Data.Text            as S-import           Data.Text.Lazy       (Text)---- | Primitive Definitions-type PrimMap a = HashMap S.Text (Primitive a)---- | Externally defined primitive-data Primitive a-  -- | A primitive that has a template that can be filled out by the backend render-  = BlackBox-  { name     :: !S.Text -- ^ Name of the primitive-  , library  :: [S.Text]-  , imports  :: [S.Text]-  , qsysInclude :: Maybe (S.Text,a)-  , template :: !(Either a a) -- ^ Either a /declaration/ or an /expression/ template.-  }-  -- | A primitive that carries additional information-  | Primitive-  { name     :: !S.Text -- ^ Name of the primitive-  , primType :: !Text -- ^ Additional information-  }-  deriving Show--instance FromJSON (Primitive Text) where-  parseJSON (Object v) = case H.toList v of-    [(conKey,Object conVal)] -> case conKey of-      "BlackBox"  -> BlackBox <$> conVal .: "name"-                              <*> conVal .:? "libraries" .!= []-                              <*> conVal .:? "imports" .!= []-                              <*> (conVal .:? "qsysInclude" >>= parseInclude)-                              <*> ((Left <$> conVal .: "templateD") <|> (Right <$> conVal .: "templateE"))-      "Primitive" -> Primitive <$> conVal .: "name" <*> conVal .: "primType"-      _ -> error "Expected: BlackBox or Primitive object"-    _ -> error "Expected: BlackBox or Primitive object"-    where-      parseInclude Nothing  = pure Nothing-      parseInclude (Just c) =-        Just <$> ((,) <$> c .: "name" <*> c .: "content")-  parseJSON _ = error "Expected: BlackBox or Primitive object"
− src/CLaSH/Primitives/Util.hs 
@@ -1,49 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Utility functions to generate Primitives--}--module CLaSH.Primitives.Util where--import           Data.Aeson.Extra       (decodeAndReport)-import qualified Data.ByteString.Lazy   as LZ-import qualified Data.HashMap.Lazy      as HashMap-import           Data.List              (isSuffixOf)-import           Data.Maybe             (fromMaybe)-import           Data.Text.Lazy         (Text)-import qualified System.Directory       as Directory-import qualified System.FilePath        as FilePath--import           CLaSH.Primitives.Types-import           CLaSH.Util---- | Generate a set of primitives that are found in the primitive definition--- files in the given directories.-generatePrimMap :: [FilePath] -- ^ Directories to search for primitive definitions-                -> IO (PrimMap Text)-generatePrimMap filePaths = do-  primitiveFiles <- fmap concat $ mapM-     (\filePath -> do-         fpExists <- Directory.doesDirectoryExist filePath-         if fpExists-           then-             fmap ( map (FilePath.combine filePath)-                  . filter (isSuffixOf ".json")-                  ) (Directory.getDirectoryContents filePath)-           else-             return []-     ) filePaths--  primitives <- fmap concat $ mapM-                  ( return-                  . fromMaybe []-                  . decodeAndReport-                  <=< LZ.readFile-                  ) primitiveFiles--  let primMap = HashMap.fromList $ zip (map name primitives) primitives--  return primMap
− src/CLaSH/Rewrite/Combinators.hs 
@@ -1,150 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Rewriting combinators and traversals--}--{-# LANGUAGE ScopedTypeVariables #-}--module CLaSH.Rewrite.Combinators where--import           Control.DeepSeq             (deepseq)-import           Control.Monad               ((<=<), (>=>))-import qualified Control.Monad.Writer        as Writer-import qualified Data.Monoid                 as Monoid-import           Unbound.Generics.LocallyNameless (Embed, Fresh, bind, embed,-                                                   rec, unbind, unembed, unrec)-import           Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind)--import           CLaSH.Core.Term             (Pat, Term (..))-import           CLaSH.Core.Util             (patIds)-import           CLaSH.Core.Var              (Id)-import           CLaSH.Rewrite.Types---- | Apply a transformation on the subtrees of an term-allR :: forall m . (Monad m, Fresh m)-     => Bool -- ^ Freshen variable references in abstracted terms-     -> Transform m -- ^ The transformation to apply to the subtrees-     -> Transform m-allR _ _ _ (Var t x)   = return (Var t x)-allR _ _ _ (Data dc)   = return (Data dc)-allR _ _ _ (Literal l) = return (Literal l)-allR _ _ _ (Prim nm t) = return (Prim nm t)--allR rf trans c (Lam b) = do-  (v,e) <- if rf then unbind b else return (unsafeUnbind b)-  e'    <- trans (LamBody v:c) e-  return . Lam $ bind v e'--allR rf trans c (TyLam b) = do-  (tv, e) <- if rf then unbind b else return (unsafeUnbind b)-  e' <- trans (TyLamBody tv:c) e-  return . TyLam $ bind tv e'--allR _ trans c (App e1 e2) = do-  e1' <- trans (AppFun:c) e1-  e2' <- trans (AppArg:c) e2-  return $ App e1' e2'--allR _ trans c (TyApp e ty) = do-  e' <- trans (TyAppC:c) e-  return $ TyApp e' ty--allR rf trans c (Letrec b) = do-  (xesR,e) <- if rf then unbind b else return (unsafeUnbind b)-  let xes   = unrec xesR-  let bndrs = map fst xes-  e' <- trans (LetBody bndrs:c) e-  xes' <- mapM (rewriteBind bndrs) xes-  return . Letrec $ bind (rec xes') e'-  where-    rewriteBind :: [Id] -> (Id,Embed Term) -> m (Id,Embed Term)-    rewriteBind bndrs (b', e) = do-      e' <- trans (LetBinding b' bndrs:c) (unembed e)-      return (b',embed e')--allR rf trans c (Case scrut ty alts) = do-  scrut' <- trans (CaseScrut:c) scrut-  alts'  <- if rf then mapM (fmap (uncurry bind) . rewriteAlt <=< unbind) alts-                  else mapM (fmap (uncurry bind) . rewriteAlt . unsafeUnbind) alts-  return $ Case scrut' ty alts'-  where-    rewriteAlt :: (Pat, Term) -> m (Pat, Term)-    rewriteAlt (p,e) = do-      e' <- trans (CaseAlt (patIds p):c) e-      return (p,e')--infixr 6 >->--- | Apply two transformations in succession-(>->) :: Monad m => Transform m -> Transform m -> Transform m-(>->) r1 r2 c = r1 c >=> r2 c--infixr 6 >-!->--- | Apply two transformations in succession, and perform a deepseq in between.-(>-!->) :: Monad m => Transform m -> Transform m -> Transform m-(>-!->) r1 r2 c e = do-  e' <- r1 c e-  deepseq e' (r2 c e')---- | Apply a transformation in a topdown traversal-topdownR :: Fresh m => Transform m -> Transform m-topdownR r = r >-> allR True (topdownR r)---- | Apply a transformation in a topdown traversal. Doesn't freshen bound--- variables-unsafeTopdownR :: Fresh m => Transform m -> Transform m-unsafeTopdownR r = r >-> allR False (unsafeTopdownR r)---- | Apply a transformation in a bottomup traversal-bottomupR :: Fresh m => Transform m -> Transform m-bottomupR r = allR True (bottomupR r) >-> r---- | Apply a transformation in a bottomup traversal. Doesn't freshen bound--- variables-unsafeBottomupR :: Fresh m => Transform m -> Transform m-unsafeBottomupR r = allR False (unsafeBottomupR r) >-> r--infixr 5 !->--- | Only apply the second transformation if the first one succeeds.-(!->) :: Rewrite m -> Rewrite m -> Rewrite m-(!->) r1 r2 c expr = do-  (expr',changed) <- Writer.listen $ r1 c expr-  if Monoid.getAny changed-    then r2 c expr'-    else return expr'--infixr 5 >-!--- | Only apply the second transformation if the first one fails.-(>-!) :: Rewrite m -> Rewrite m -> Rewrite m-(>-!) r1 r2 c expr = do-  (expr',changed) <- Writer.listen $ r1 c expr-  if Monoid.getAny changed-    then return expr'-    else r2 c expr'---- | Keep applying a transformation until it fails.-repeatR :: Rewrite m -> Rewrite m-repeatR r = r !-> repeatR r--whenR :: Monad m-      => ([CoreContext] -> Term -> m Bool)-      -> Transform m-      -> Transform m-whenR f r1 ctx expr = do-  b <- f ctx expr-  if b-    then r1 ctx expr-    else return expr---- | Only traverse downwards when the assertion evaluates to true-bottomupWhenR :: Fresh m-              => ([CoreContext] -> Term -> m Bool)-              -> Transform m-              -> Transform m-bottomupWhenR f r ctx expr = do-  b <- f ctx expr-  if b-    then (allR True (bottomupWhenR f r) >-> r) ctx expr-    else r ctx expr
− src/CLaSH/Rewrite/Types.hs 
@@ -1,158 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Type and instance definitions for Rewrite modules--}--{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell            #-}--module CLaSH.Rewrite.Types where--import Control.Concurrent.Supply             (Supply, freshId)-import Control.Lens                          (use, (.=), (<<%=))-import Control.Monad-import Control.Monad.Fix                     (MonadFix (..), fix)-import Control.Monad.Reader                  (MonadReader (..))-import Control.Monad.State                   (MonadState (..))-import Control.Monad.Writer                  (MonadWriter (..))-import Data.HashMap.Strict                   (HashMap)-import Data.IntMap.Strict                    (IntMap)-import Data.Monoid                           (Any)-import Unbound.Generics.LocallyNameless      (Fresh (..))-import Unbound.Generics.LocallyNameless.Name (Name (..))--import SrcLoc (SrcSpan)--import CLaSH.Core.Term           (Term, TmName)-import CLaSH.Core.Type           (Type)-import CLaSH.Core.TyCon          (TyCon, TyConName)-import CLaSH.Core.Var            (Id, TyVar)-import CLaSH.Netlist.Types       (HWType)-import CLaSH.Util---- | Context in which a term appears-data CoreContext-  = AppFun           -- ^ Function position of an application-  | AppArg           -- ^ Argument position of an application-  | TyAppC           -- ^ Function position of a type application-  | LetBinding Id [Id] -- ^ RHS of a Let-binder with the sibling LHS'-  | LetBody    [Id]  -- ^ Body of a Let-binding with the bound LHS'-  | LamBody    Id    -- ^ Body of a lambda-term with the abstracted variable-  | TyLamBody  TyVar -- ^ Body of a TyLambda-term with the abstracted-                     -- type-variable-  | CaseAlt    [Id]  -- ^ RHS of a case-alternative with the variables bound by-                     -- the pattern on the LHS-  | CaseScrut        -- ^ Subject of a case-decomposition-  deriving (Eq,Show)---- | State of a rewriting session-data RewriteState extra-  = RewriteState-  { _transformCounter :: {-# UNPACK #-} !Int-  -- ^ Number of applied transformations-  , _bindings         :: !(HashMap TmName (Type,SrcSpan,Term))-  -- ^ Global binders-  , _uniqSupply       :: !Supply-  -- ^ Supply of unique numbers-  , _curFun           :: (TmName,SrcSpan) -- Initially set to undefined: no strictness annotation-  -- ^ Function which is currently normalized-  , _nameCounter      :: {-# UNPACK #-} !Int-  -- ^ Used for 'Fresh'-  , _extra            :: !extra-  -- ^ Additional state-  }--makeLenses ''RewriteState---- | Debug Message Verbosity-data DebugLevel-  = DebugNone    -- ^ Don't show debug messages-  | DebugFinal   -- ^ Show completely normalized expressions-  | DebugName    -- ^ Names of applied transformations-  | DebugApplied -- ^ Show sub-expressions after a successful rewrite-  | DebugAll     -- ^ Show all sub-expressions on which a rewrite is attempted-  deriving (Eq,Ord,Read)---- | Read-only environment of a rewriting session-data RewriteEnv-  = RewriteEnv-  { _dbgLevel       :: DebugLevel-  -- ^ Lvl at which we print debugging messages-  , _typeTranslator :: HashMap TyConName TyCon -> Type-                    -> Maybe (Either String HWType)-  -- ^ Hardcode Type -> HWType translator-  , _tcCache        :: HashMap TyConName TyCon-  -- ^ TyCon cache-  , _tupleTcCache   :: IntMap TyConName-  -- ^ Tuple TyCon cache-  , _evaluator      :: HashMap TyConName TyCon -> Bool -> Term -> Term-  -- ^ Hardcoded evaluator (delta-reduction)}-  , _allowZero      :: Bool-  -- ^ Zero bit wide things are representable-  }--makeLenses ''RewriteEnv---- | Monad that keeps track how many transformations have been applied and can--- generate fresh variables and unique identifiers. In addition, it keeps track--- if a transformation/rewrite has been successfully applied.-newtype RewriteMonad extra a = R-  { runR :: RewriteEnv -> RewriteState extra -> (a,RewriteState extra,Any) }--instance Functor (RewriteMonad extra) where-  fmap f m = R (\r s -> case runR m r s of (a,s',w) -> (f a,s',w))--instance Applicative (RewriteMonad extra) where-  pure  = return-  (<*>) = ap--instance Monad (RewriteMonad extra) where-  return a = R (\_ s -> (a, s, mempty))-  m >>= k  = R (\r s -> case runR m r s of-                          (a,s',w) -> case runR (k a) r s' of-                                        (b,s'',w') -> let w'' = mappend w w'-                                                      in seq w'' (b,s'',w''))--instance MonadState (RewriteState extra) (RewriteMonad extra) where-  get     = R (\_ s -> (s,s,mempty))-  put s   = R (\_ _ -> ((),s,mempty))-  state f = R (\_ s -> case f s of (a,s') -> (a,s',mempty))--instance Fresh (RewriteMonad extra) where-  fresh (Fn s _) = do-    n <- nameCounter <<%= (+1)-    let n' = toInteger n-    n' `seq` return (Fn s n')-  fresh nm@(Bn {}) = return nm--instance MonadUnique (RewriteMonad extra) where-  getUniqueM = do-    sup <- use uniqSupply-    let (a,sup') = freshId sup-    uniqSupply .= sup'-    a `seq` return a--instance MonadWriter Any (RewriteMonad extra) where-  writer (a,w) = R (\_ s -> (a,s,w))-  tell   w     = R (\_ s -> ((),s,w))-  listen m     = R (\r s -> case runR m r s of (a,s',w) -> ((a,w),s',w))-  pass   m     = R (\r s -> case runR m r s of ((a,f),s',w) -> (a, s', f w))--instance MonadReader RewriteEnv (RewriteMonad extra) where-   ask       = R (\r s -> (r,s,mempty))-   local f m = R (\r s -> runR m (f r) s)-   reader f  = R (\r s -> (f r,s,mempty))--instance MonadFix (RewriteMonad extra) where-  mfix f = R (\r s -> fix $ \ ~(a,_,_) -> runR (f a) r s)---- | Monadic action that transforms a term given a certain context-type Transform m = [CoreContext] -> Term -> m Term---- | A 'Transform' action in the context of the 'RewriteMonad'-type Rewrite extra = Transform (RewriteMonad extra)
− src/CLaSH/Rewrite/Util.hs 
@@ -1,638 +0,0 @@-{-|-  Copyright  :  (C) 2012-2016, University of Twente-  License    :  BSD2 (see the file LICENSE)-  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Utilities for rewriting: e.g. inlining, specialisation, etc.--}--{-# LANGUAGE Rank2Types        #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE ViewPatterns      #-}--module CLaSH.Rewrite.Util where--import           Control.DeepSeq-import           Control.Exception           (throw)-import           Control.Lens                (Lens', (%=), (+=), (^.),_1,_3)-import qualified Control.Lens                as Lens-import qualified Control.Monad               as Monad-import qualified Control.Monad.State.Strict  as State-import qualified Control.Monad.Writer        as Writer-import           Data.HashMap.Strict         (HashMap)-import qualified Data.HashMap.Lazy           as HML-import qualified Data.HashMap.Strict         as HMS-import qualified Data.List                   as List-import qualified Data.Map                    as Map-import           Data.Maybe                  (catMaybes,isJust,mapMaybe)-import qualified Data.Monoid                 as Monoid-import qualified Data.Set                    as Set-import qualified Data.Set.Lens               as Lens-import           Unbound.Generics.LocallyNameless     (Fresh, bind,-                                              embed, makeName, name2String,-                                              rebind, rec, string2Name, unbind,-                                              unembed, unrec)-import           Unbound.Generics.LocallyNameless.Unsafe (unsafeUnbind)--import           SrcLoc                      (SrcSpan)--import           CLaSH.Core.DataCon          (dataConInstArgTys)-import           CLaSH.Core.FreeVars         (termFreeIds, termFreeTyVars,-                                              typeFreeVars)-import           CLaSH.Core.Pretty           (showDoc)-import           CLaSH.Core.Subst            (substTm)-import           CLaSH.Core.Term             (LetBinding, Pat (..), Term (..),-                                              TmName)-import           CLaSH.Core.TyCon            (TyCon, TyConName, tyConDataCons)-import           CLaSH.Core.Type             (KindOrType, Type (..),-                                              TypeView (..), coreView,-                                              typeKind, tyView)-import           CLaSH.Core.Util             (Delta, Gamma, collectArgs,-                                              mkAbstraction, mkApps, mkId,-                                              mkLams, mkTmApps, mkTyApps,-                                              mkTyLams, mkTyVar, termType)-import           CLaSH.Core.Var              (Id, TyVar, Var (..))-import           CLaSH.Driver.Types          (CLaSHException (..))-import           CLaSH.Netlist.Util          (representableType)-import           CLaSH.Rewrite.Types-import           CLaSH.Util---- | Lift an action working in the '_extra' state to the 'RewriteMonad'-zoomExtra :: State.State extra a-          -> RewriteMonad extra a-zoomExtra m = R (\_ s -> case State.runState m (s ^. extra) of-                           (a,s') -> (a,s {_extra = s'},mempty))---- | Record if a transformation is succesfully applied-apply :: String -- ^ Name of the transformation-      -> Rewrite extra -- ^ Transformation to be applied-      -> Rewrite extra-apply name rewrite ctx expr = do-  lvl <- Lens.view dbgLevel-  let before = showDoc expr-  (expr', anyChanged) <- traceIf (lvl >= DebugAll) ("Trying: " ++ name ++ " on:\n" ++ before) $ Writer.listen $ rewrite ctx expr-  let hasChanged = Monoid.getAny anyChanged-  Monad.when hasChanged $ transformCounter += 1-  let after  = showDoc expr'-  let expr'' = if hasChanged then expr' else expr--  Monad.when (lvl > DebugNone && hasChanged) $ do-    tcm                  <- Lens.view tcCache-    beforeTy             <- termType tcm expr-    let beforeFTV        = Lens.setOf termFreeTyVars expr-    beforeFV             <- Lens.setOf <$> localFreeIds <*> pure expr-    afterTy              <- termType tcm expr'-    let afterFTV         = Lens.setOf termFreeTyVars expr-    afterFV              <- Lens.setOf <$> localFreeIds <*> pure expr'-    let newFV = Set.size afterFTV > Set.size beforeFTV ||-                Set.size afterFV > Set.size beforeFV-    Monad.when newFV $-            error ( concat [ $(curLoc)-                           , "Error when applying rewrite ", name-                           , " to:\n" , before-                           , "\nResult:\n" ++ after ++ "\n"-                           , "Changes free variables from: ", show (beforeFTV,beforeFV)-                           , "\nto: ", show (afterFTV,afterFV)-                           ]-                  )-    traceIf ( beforeTy /= afterTy)-            ( concat [ $(curLoc)-                     , "Error when applying rewrite ", name-                     , " to:\n" , before-                     , "\nResult:\n" ++ after ++ "\n"-                     , "Changes type from:\n", showDoc beforeTy-                     , "\nto:\n", showDoc afterTy-                     ]-            ) (return ())--  Monad.when (lvl >= DebugApplied && not hasChanged && expr /= expr') $-    error $ $(curLoc) ++ "Expression changed without notice(" ++ name ++  "): before" ++ before ++ "\nafter:\n" ++ after--  traceIf (lvl >= DebugName && hasChanged) name $-    traceIf (lvl >= DebugApplied && hasChanged) ("Changes when applying rewrite to:\n" ++ before ++ "\nResult:\n" ++ after ++ "\n") $-      traceIf (lvl >= DebugAll && not hasChanged) ("No changes when applying rewrite " ++ name ++ " to:\n" ++ after ++ "\n") $-        return expr''---- | Perform a transformation on a Term-runRewrite :: String -- ^ Name of the transformation-           -> Rewrite extra -- ^ Transformation to perform-           -> Term  -- ^ Term to transform-           -> RewriteMonad extra Term-runRewrite name rewrite expr = apply name rewrite [] expr---- | Evaluate a RewriteSession to its inner monad-runRewriteSession :: RewriteEnv-                  -> RewriteState extra-                  -> RewriteMonad extra a-                  -> a-runRewriteSession r s m = traceIf True ("Applied " ++-                                        show (s' ^. transformCounter) ++-                                        " transformations")-                                  a-  where-    (a,s',_) = runR m r s---- | Notify that a transformation has changed the expression-setChanged :: RewriteMonad extra ()-setChanged = Writer.tell (Monoid.Any True)---- | Identity function that additionally notifies that a transformation has--- changed the expression-changed :: a -> RewriteMonad extra a-changed val = do-  Writer.tell (Monoid.Any True)-  return val---- | Create a type and kind context out of a transformation context-contextEnv :: [CoreContext]-           -> (Gamma, Delta)-contextEnv = go HML.empty HML.empty-  where-    go gamma delta []                   = (gamma,delta)-    go gamma delta (LetBinding _ ids:ctx) = go gamma' delta ctx-      where-        gamma' = foldl addToGamma gamma ids--    go gamma delta (LetBody ids:ctx)    = go gamma' delta ctx-      where-        gamma' = foldl addToGamma gamma ids--    go gamma delta (LamBody lId:ctx)    = go gamma' delta ctx-      where-        gamma' = addToGamma gamma lId--    go gamma delta (TyLamBody tv:ctx)   = go gamma delta' ctx-      where-        delta' = addToDelta delta tv--    go gamma delta (CaseAlt ids:ctx)    = go gamma' delta ctx-      where-        gamma' = foldl addToGamma gamma ids--    go gamma delta (_:ctx) = go gamma delta ctx--    addToGamma gamma (Id idName ty) = HML.insert idName (unembed ty) gamma-    addToGamma _     _              = error $ $(curLoc) ++ "Adding TyVar to Gamma"--    addToDelta delta (TyVar tvName ki) = HML.insert tvName (unembed ki) delta-    addToDelta _     _                 = error $ $(curLoc) ++ "Adding Id to Delta"--closestLetBinder :: [CoreContext] -> Maybe Id-closestLetBinder [] = Nothing-closestLetBinder (LetBinding id_ _:_) = Just id_-closestLetBinder (_:ctx)              = closestLetBinder ctx--mkDerivedName :: [CoreContext] -> String -> String-mkDerivedName ctx sf = case closestLetBinder ctx of-  Just id_ -> ((++ ('_':sf)) . name2String . varName) id_-  _ -> sf---- | Create a complete type and kind context out of the global binders and the--- transformation context-mkEnv :: [CoreContext]-      -> RewriteMonad extra (Gamma, Delta)-mkEnv ctx = do-  let (gamma,delta) = contextEnv ctx-  tsMap             <- fmap (HML.map (^. _1)) $ Lens.use bindings-  let gamma'        = tsMap `HML.union` gamma-  return (gamma',delta)---- | Make a new binder and variable reference for a term-mkTmBinderFor :: (Fresh m, MonadUnique m)-              => HashMap TyConName TyCon -- ^ TyCon cache-              -> String -- ^ Name of the new binder-              -> Term -- ^ Term to bind-              -> m (Id, Term)-mkTmBinderFor tcm name e = do-  (Left r) <- mkBinderFor tcm name (Left e)-  return r---- | Make a new binder and variable reference for either a term or a type-mkBinderFor :: (Monad m, MonadUnique m, Fresh m)-            => HashMap TyConName TyCon -- ^ TyCon cache-            -> String -- ^ Name of the new binder-            -> Either Term Type -- ^ Type or Term to bind-            -> m (Either (Id,Term) (TyVar,Type))-mkBinderFor tcm name (Left term) =-  Left <$> (mkInternalVar name =<< termType tcm term)--mkBinderFor tcm name (Right ty) = do-  name'     <- fmap (makeName name . toInteger) getUniqueM-  let kind  = typeKind tcm ty-  return $ Right (TyVar name' (embed kind), VarTy kind name')---- | Make a new, unique, identifier and corresponding variable reference-mkInternalVar :: (Monad m, MonadUnique m)-              => String -- ^ Name of the identifier-              -> KindOrType-              -> m (Id,Term)-mkInternalVar name ty = do-  name' <- fmap (makeName name . toInteger) getUniqueM-  return (Id name' (embed ty),Var ty name')---- | Inline the binders in a let-binding that have a certain property-inlineBinders :: (Term -> LetBinding -> RewriteMonad extra Bool) -- ^ Property test-              -> Rewrite extra-inlineBinders condition _ expr@(Letrec b) = do-  (xes,res)        <- unbind b-  let expr' = Letrec (bind xes res)-  (replace,others) <- partitionM (condition expr') (unrec xes)-  case replace of-    [] -> return expr-    _  -> do-      let (others',res') = substituteBinders replace others res-          newExpr = case others' of-                          [] -> res'-                          _  -> Letrec (bind (rec others') res')--      changed newExpr--inlineBinders _ _ e = return e---- | Determine whether a binder is a join-point created for a complex case--- expression.------ A join-point is when a local function only occurs in tail-call positions,--- and when it does, more than once.-isJoinPointIn :: Id   -- ^ 'Id' of the local binder-              -> Term -- ^ Expression in which the binder is bound-              -> Bool-isJoinPointIn id_ e = case tailCalls id_ e of-                      Just n | n > 1 -> True-                      _              -> False---- | Count the number of (only) tail calls of a function in an expression.--- 'Nothing' indicates that the function was used in a non-tail call position.-tailCalls :: Id   -- ^ Function to check-          -> Term -- ^ Expression to check it in-          -> Maybe Int-tailCalls id_ expr = case expr of-  Var _ nm | varName id_ == nm -> Just 1-           | otherwise       -> Just 0-  Lam b -> let (_,expr') = unsafeUnbind b-           in  tailCalls id_ expr'-  TyLam b -> let (_,expr') = unsafeUnbind b-             in  tailCalls id_ expr'-  App l r  -> case tailCalls id_ r of-                Just 0 -> tailCalls id_ l-                _      -> Nothing-  TyApp l _ -> tailCalls id_ l-  Letrec b ->-    let (bsR,expr')     = unsafeUnbind b-        (bsIds,bsExprs) = unzip (unrec bsR)-        bsTls           = map (tailCalls id_ . unembed) bsExprs-        bsIdsUsed       = mapMaybe (\(l,r) -> pure l <* r) (zip bsIds bsTls)-        bsIdsTls        = map (`tailCalls` expr') bsIdsUsed-        bsCount         = pure . sum $ catMaybes bsTls-    in  case (all isJust bsTls) of-          False -> Nothing-          True  -> case (all (==0) $ catMaybes bsTls) of-            False  -> case all isJust bsIdsTls of-              False -> Nothing-              True  -> (+) <$> bsCount <*> tailCalls id_ expr'-            True -> tailCalls id_ expr'-  Case scrut _ alts ->-    let scrutTl = tailCalls id_ scrut-        altsTl  = map (tailCalls id_ . snd . unsafeUnbind) alts-    in  case scrutTl of-          Just 0 | all (/= Nothing) altsTl -> Just (sum (catMaybes altsTl))-          _ -> Nothing-  _ -> Just 0---- | Determines whether a function has the following shape:------ > \(w :: Void) -> f a b c------ i.e. is a wrapper around a (partially) applied function 'f', where the--- introduced argument 'w' is not used by 'f'-isVoidWrapper :: Term -> Bool-isVoidWrapper (Lam b) = case unsafeUnbind b of-  (bndr,e@(collectArgs -> (Var _ _,_))) -> varName bndr `notElem` Lens.toListOf termFreeIds e-  _ -> False-isVoidWrapper _ = False---- | Substitute the RHS of the first set of Let-binders for references to the--- first set of Let-binders in: the second set of Let-binders and the additional--- term-substituteBinders :: [LetBinding] -- ^ Let-binders to substitute-                  -> [LetBinding] -- ^ Let-binders where substitution takes place-                  -> Term -- ^ Expression where substitution takes place-                  -> ([LetBinding],Term)-substituteBinders [] others res = (others,res)-substituteBinders ((bndr,valE):rest) others res = substituteBinders rest' others' res'-  where-    val      = unembed valE-    bndrName = varName bndr-    selfRef  = bndrName `elem` Lens.toListOf termFreeIds val-    (res',rest',others') = if selfRef-      then (res,rest,(bndr,valE):others)-      else ( substTm (varName bndr) val res-           , map (second ( embed-                         . substTm bndrName val-                         . unembed)-                 ) rest-           , map (second ( embed-                         . substTm bndrName val-                         . unembed)-                 ) others-           )---- | Calculate the /local/ free variable of an expression: the free variables--- that are not bound in the global environment.-localFreeIds :: (Applicative f, Lens.Contravariant f)-             => RewriteMonad extra ((TmName -> f TmName) -> Term -> f Term)-localFreeIds = do-  globalBndrs <- Lens.use bindings-  return ((termFreeIds . Lens.filtered (not . (`HML.member` globalBndrs))))--inlineOrLiftBinders :: (LetBinding -> RewriteMonad extra Bool) -- ^ Property test-                    -> (Term -> LetBinding -> RewriteMonad extra Bool)-                       -- ^ Test whether to lift or inline-                       ---                       -- * True: inline-                       -- * False: lift-                    -> Rewrite extra-inlineOrLiftBinders condition inlineOrLift ctx expr@(Letrec b) = do-  (xesR,res) <- unbind b-  let xes = unrec xesR-  (replace,others) <- partitionM condition xes-  case replace of-    [] -> return expr-    _  -> do-      -- Because 'unbind b' refreshes binders in xes, we must recreate-      -- the let expression, and _not_ reuse 'expr'-      let expr' = Letrec (bind xesR res)-      (doInline,doLift) <- partitionM (inlineOrLift expr') replace-      -- We first substitute the binders that we can inline both the binders-      -- that we intend to lift, the other binders, and the body-      let (others',res')     = substituteBinders doInline (doLift ++ others) res-          (doLift',others'') = splitAt (length doLift) others'-      (gamma,delta) <- mkEnv (LetBinding undefined (map fst xes) : ctx)-      doLift'' <- mapM (liftBinding gamma delta) doLift'-      -- We then substitute the lifted binders in the other binders and the body-      let (others3,res'') = substituteBinders doLift'' others'' res'-          newExpr = case others3 of-                      [] -> res''-                      _  -> Letrec (bind (rec others3) res'')-      changed newExpr--inlineOrLiftBinders _ _ _ e = return e---- | Create a global function for a Let-binding and return a Let-binding where--- the RHS is a reference to the new global function applied to the free--- variables of the original RHS-liftBinding :: Gamma-            -> Delta-            -> LetBinding-            -> RewriteMonad extra LetBinding-liftBinding gamma delta (Id idName tyE,eE) = do-  let e  = unembed eE-  -- Get all local FVs, excluding the 'idName' from the let-binding-  let localFTVs = List.nub $ Lens.toListOf termFreeTyVars e-  localFVs <- List.nub <$> (Lens.toListOf <$> localFreeIds <*> pure e)-  let localFTVkinds = map (\k -> HML.lookupDefault (error $ $(curLoc) ++ show k ++ " not found") k delta) localFTVs-      localFVs'     = filter (/= idName) localFVs-      localFVtys'   = map (\k -> HML.lookupDefault (error $ $(curLoc) ++ show k ++ " not found") k gamma) localFVs'-  -- Abstract expression over its local FVs-      boundFTVs = zipWith mkTyVar localFTVkinds localFTVs-      boundFVs  = zipWith mkId localFVtys' localFVs'-  -- Make a new global ID-  tcm       <- Lens.view tcCache-  newBodyTy <- termType tcm $ mkTyLams (mkLams e boundFVs) boundFTVs-  (cf,sp)   <- Lens.use curFun-  newBodyId <- fmap (makeName (name2String cf ++ "_" ++ name2String idName) . toInteger) getUniqueM-  -- Make a new expression, consisting of the the lifted function applied to-  -- its free variables-  let newExpr = mkTmApps-                  (mkTyApps (Var newBodyTy newBodyId)-                            (zipWith VarTy localFTVkinds localFTVs))-                  (zipWith Var localFVtys' localFVs')-  -- Substitute the recursive calls by the new expression-      e' = substTm idName newExpr e-  -- Create a new body that abstracts over the free variables-      newBody = mkTyLams (mkLams e' boundFVs) boundFTVs--  -- Check if an alpha-equivalent global binder already exists-  aeqExisting <- (HMS.toList . HMS.filter ((== newBody) . (^. _3))) <$> Lens.use bindings-  case aeqExisting of-    -- If it doesn't, create a new binder-    [] -> do -- Add the created function to the list of global bindings-             bindings %= HMS.insert newBodyId (newBodyTy,sp,newBody)-             -- Return the new binder-             return (Id idName tyE, embed newExpr)-    -- If it does, use the existing binder-    ((k,(aeqTy,_,_)):_) ->-      let newExpr' = mkTmApps-                      (mkTyApps (Var aeqTy k)-                                (zipWith VarTy localFTVkinds localFTVs))-                      (zipWith Var localFVtys' localFVs')-      in  return (Id idName tyE, embed newExpr')--liftBinding _ _ _ = error $ $(curLoc) ++ "liftBinding: invalid core, expr bound to tyvar"---- | Make a global function for a name-term tuple-mkFunction :: TmName -- ^ Name of the function-           -> SrcSpan-           -> Term -- ^ Term bound to the function-           -> RewriteMonad extra (TmName,Type) -- ^ Name with a proper unique and the type of the function-mkFunction bndr sp body = do-  tcm    <- Lens.view tcCache-  bodyTy <- termType tcm body-  bodyId <- cloneVar bndr-  addGlobalBind bodyId bodyTy sp body-  return (bodyId,bodyTy)---- | Add a function to the set of global binders-addGlobalBind :: TmName-              -> Type-              -> SrcSpan-              -> Term-              -> RewriteMonad extra ()-addGlobalBind vId ty sp body = (ty,body) `deepseq` bindings %= HMS.insert vId (ty,sp,body)---- | Create a new name out of the given name, but with another unique-cloneVar :: TmName-         -> RewriteMonad extra TmName-cloneVar name = fmap (makeName (name2String name) . toInteger) getUniqueM----- | Test whether a term is a variable reference to a local binder-isLocalVar :: Term-           -> RewriteMonad extra Bool-isLocalVar (Var _ name)-  = fmap (not . HML.member name)-  $ Lens.use bindings-isLocalVar _ = return False--{-# INLINE isUntranslatable #-}--- | Determine if a term cannot be represented in hardware-isUntranslatable :: Term-                 -> RewriteMonad extra Bool-isUntranslatable tm = do-  tcm <- Lens.view tcCache-  not <$> (representableType <$> Lens.view typeTranslator-                             <*> Lens.view allowZero-                             <*> pure tcm-                             <*> termType tcm tm)--{-# INLINE isUntranslatableType #-}--- | Determine if a type cannot be represented in hardware-isUntranslatableType :: Type-                     -> RewriteMonad extra Bool-isUntranslatableType ty =-  not <$> (representableType <$> Lens.view typeTranslator-                             <*> Lens.view allowZero-                             <*> Lens.view tcCache-                             <*> pure ty)---- | Is the Context a Lambda/Term-abstraction context?-isLambdaBodyCtx :: CoreContext-                -> Bool-isLambdaBodyCtx (LamBody _) = True-isLambdaBodyCtx _           = False---- | Make a binder that should not be referenced-mkWildValBinder :: (Monad m, MonadUnique m)-                => Type-                -> m Id-mkWildValBinder = fmap fst . mkInternalVar "wild"---- | Make a case-decomposition that extracts a field out of a (Sum-of-)Product type-mkSelectorCase :: (Functor m, Monad m, MonadUnique m, Fresh m)-               => String -- ^ Name of the caller of this function-               -> HashMap TyConName TyCon -- ^ TyCon cache-               -> Term -- ^ Subject of the case-composition-               -> Int -- n'th DataCon-               -> Int -- n'th field-               -> m Term-mkSelectorCase caller tcm scrut dcI fieldI = do-    scrutTy <- termType tcm scrut-    go scrutTy-  where-    go (coreView tcm -> Just ty')   = go ty'-    go scrutTy@(tyView -> TyConApp tc args) =-      case tyConDataCons (tcm HMS.! tc) of-        [] -> cantCreate $(curLoc) ("TyCon has no DataCons: " ++ show tc ++ " " ++ showDoc tc) scrutTy-        dcs | dcI > length dcs -> cantCreate $(curLoc) "DC index exceeds max" scrutTy-            | otherwise -> do-          let dc = indexNote ($(curLoc) ++ "No DC with tag: " ++ show (dcI-1)) dcs (dcI-1)-          let (Just fieldTys) = dataConInstArgTys dc args-          if fieldI >= length fieldTys-            then cantCreate $(curLoc) "Field index exceed max" scrutTy-            else do-              wildBndrs <- mapM mkWildValBinder fieldTys-              let ty = indexNote ($(curLoc) ++ "No DC field#: " ++ show fieldI) fieldTys fieldI-              selBndr <- mkInternalVar "sel" ty-              let bndrs  = take fieldI wildBndrs ++ [fst selBndr] ++ drop (fieldI+1) wildBndrs-                  pat    = DataPat (embed dc) (rebind [] bndrs)-                  retVal = Case scrut ty [ bind pat (snd selBndr) ]-              return retVal-    go scrutTy = cantCreate $(curLoc) ("Type of subject is not a datatype: " ++ showDoc scrutTy) scrutTy--    cantCreate loc info scrutTy = error $ loc ++ "Can't create selector " ++ show (caller,dcI,fieldI) ++ " for: (" ++ showDoc scrut ++ " :: " ++ showDoc scrutTy ++ ")\nAdditional info: " ++ info---- | Specialise an application on its argument-specialise :: Lens' extra (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations-           -> Lens' extra (HashMap TmName Int) -- ^ Lens into the specialisation history-           -> Lens' extra Int -- ^ Lens into the specialisation limit-           -> Rewrite extra-specialise specMapLbl specHistLbl specLimitLbl ctx e = case e of-  (TyApp e1 ty) -> specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Right ty)-  (App e1 e2)   -> specialise' specMapLbl specHistLbl specLimitLbl ctx e (collectArgs e1) (Left  e2)-  _             -> return e---- | Specialise an application on its argument-specialise' :: Lens' extra (Map.Map (TmName, Int, Either Term Type) (TmName,Type)) -- ^ Lens into previous specialisations-            -> Lens' extra (HashMap TmName Int) -- ^ Lens into specialisation history-            -> Lens' extra Int -- ^ Lens into the specialisation limit-            -> [CoreContext] -- Transformation context-            -> Term -- ^ Original term-            -> (Term, [Either Term Type]) -- ^ Function part of the term, split into root and applied arguments-            -> Either Term Type -- ^ Argument to specialize on-            -> RewriteMonad extra Term-specialise' specMapLbl specHistLbl specLimitLbl ctx e (Var _ f, args) specArg = do-  lvl <- Lens.view dbgLevel-  -- Create binders and variable references for free variables in 'specArg'-  (specBndrs,specVars) <- specArgBndrsAndVars ctx specArg-  let argLen  = length args-      specAbs = either (Left . (`mkAbstraction` specBndrs)) (Right . id) specArg-  -- Determine if 'f' has already been specialized on 'specArg'-  specM <- Map.lookup (f,argLen,specAbs) <$> Lens.use (extra.specMapLbl)-  case specM of-    -- Use previously specialized function-    Just (fname,fty) ->-      traceIf (lvl >= DebugApplied) ("Using previous specialization of " ++ showDoc f ++ " on " ++ (either showDoc showDoc) specAbs ++ ": " ++ showDoc fname) $-        changed $ mkApps (Var fty fname) (args ++ specVars)-    -- Create new specialized function-    Nothing -> do-      -- Determine if we can specialize f-      bodyMaybe <- fmap (HML.lookup f) $ Lens.use bindings-      case bodyMaybe of-        Just (_,sp,bodyTm) -> do-          -- Determine if we see a sequence of specialisations on a growing argument-          specHistM <- HML.lookup f <$> Lens.use (extra.specHistLbl)-          specLim   <- Lens.use (extra . specLimitLbl)-          if maybe False (> specLim) specHistM-            then throw (CLaSHException-                        sp-                        (unlines [ "Hit specialisation limit " ++ show specLim ++ " on function `" ++ showDoc f ++ "'.\n"-                                 , "The function `" ++ showDoc f ++ "' is most likely recursive, and looks like it is being indefinitely specialized on a growing argument.\n"-                                 , "Body of `" ++ showDoc f ++ "':\n" ++ showDoc bodyTm ++ "\n"-                                 , "Argument (in position: " ++ show argLen ++ ") that triggered termination:\n" ++ (either showDoc showDoc) specArg-                                 , "Run with '-clash-spec-limit=N' to increase the specialisation limit to N."-                                 ])-                        Nothing)-            else do-              -- Make new binders for existing arguments-              tcm                 <- Lens.view tcCache-              (boundArgs,argVars) <- fmap (unzip . map (either (Left *** Left) (Right *** Right))) $-                                     mapM (mkBinderFor tcm "pTS") args-              -- Create specialized functions-              let newBody = mkAbstraction (mkApps bodyTm (argVars ++ [specArg])) (boundArgs ++ specBndrs)-              newf <- mkFunction f sp newBody-              -- Remember specialization-              (extra.specHistLbl) %= HML.insertWith (+) f 1-              (extra.specMapLbl)  %= Map.insert (f,argLen,specAbs) newf-              -- use specialized function-              let newExpr = mkApps ((uncurry . flip) Var newf) (args ++ specVars)-              newf `deepseq` changed newExpr-        Nothing -> return e--specialise' _ _ _ ctx _ (appE,args) (Left specArg) = do-  -- Create binders and variable references for free variables in 'specArg'-  (specBndrs,specVars) <- specArgBndrsAndVars ctx (Left specArg)-  -- Create specialized function-  let newBody = mkAbstraction specArg specBndrs-  -- See if there's an existing binder that's alpha-equivalent to the-  -- specialised function-  existing <- HML.filter ((== newBody) . (^. _3)) <$> Lens.use bindings-  -- Create a new function if an alpha-equivalent binder doesn't exist-  newf <- case HML.toList existing of-    [] -> do (cf,sp) <- Lens.use curFun-             mkFunction (string2Name (name2String cf ++ "_" ++ "specF")) sp newBody-    ((k,(kTy,_,_)):_) -> return (k,kTy)-  -- cf <- Lens.use curFun-  -- newf <- mkFunction (string2Name (name2String cf ++ "_" ++ "specF")) newBody-  -- Create specialized argument-  let newArg  = Left $ mkApps ((uncurry . flip) Var newf) specVars-  -- Use specialized argument-  let newExpr = mkApps appE (args ++ [newArg])-  changed newExpr--specialise' _ _ _ _ e _ _ = return e---- | Create binders and variable references for free variables in 'specArg'-specArgBndrsAndVars :: [CoreContext]-                    -> Either Term Type-                    -> RewriteMonad extra ([Either Id TyVar],[Either Term Type])-specArgBndrsAndVars ctx specArg = do-  let specFTVs = List.nub $ either (Lens.toListOf termFreeTyVars) (Lens.toListOf typeFreeVars) specArg-  specFVs <- List.nub <$> either ((Lens.toListOf <$> localFreeIds <*>) . pure) (const (pure [])) specArg-  (gamma,delta) <- mkEnv ctx-  let (specTyBndrs,specTyVars) = unzip-                 $ map (\tv -> let ki = HML.lookupDefault (error $ $(curLoc) ++ show tv ++ " not found") tv delta-                               in  (Right $ TyVar tv (embed ki), Right $ VarTy ki tv)) specFTVs-      (specTmBndrs,specTmVars) = unzip-                 $ map (\tm -> let ty = HML.lookupDefault (error $ $(curLoc) ++ show tm ++ " not found") tm gamma-                               in  (Left $ Id tm (embed ty), Left $ Var ty tm)) specFVs-  return (specTyBndrs ++ specTmBndrs,specTyVars ++ specTmVars)
− src/CLaSH/Util.hs 
@@ -1,243 +0,0 @@-{-|-  Copyright   :  (C) 2012-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--  Assortment of utility function used in the CLaSH library--}--{-# LANGUAGE CPP                  #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE MagicHash            #-}-{-# LANGUAGE Rank2Types           #-}-{-# LANGUAGE TupleSections        #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module CLaSH.Util-  ( module CLaSH.Util-  , module X-  , makeLenses-  )-where--import Control.Applicative            as X (Applicative,(<$>),(<*>),pure)-import Control.Arrow                  as X ((***),first,second)-import Control.DeepSeq-import Control.Monad                  as X ((<=<),(>=>))-import Control.Monad.State            (MonadState,State,StateT,runState)-import qualified Control.Monad.State  as State-import Control.Monad.Trans.Class      (MonadTrans,lift)-import Data.Function                  as X (on)-import Data.Hashable                  (Hashable)-import Data.HashMap.Lazy              (HashMap)-import qualified Data.HashMap.Lazy    as HashMapL-import qualified Data.HashMap.Strict  as HashMapS-import Data.Maybe                     (fromMaybe)-import Data.Version                   (Version)-import Control.Lens-import Debug.Trace                    (trace)-import GHC.Base                       (Int(..),isTrue#,(==#),(+#))-import GHC.Integer.Logarithms         (integerLogBase#)-import qualified Language.Haskell.TH  as TH--#ifdef CABAL-import qualified Paths_clash_lib      (version)-#endif---- | A class that can generate unique numbers-class MonadUnique m where-  -- | Get a new unique-  getUniqueM :: m Int--instance Monad m => MonadUnique (StateT Int m) where-  getUniqueM = do-    supply <- State.get-    State.modify (+1)-    return supply---- | Create a TH expression that returns the a formatted string containing the--- name of the module 'curLoc' is spliced into, and the line where it was spliced.-curLoc :: TH.Q TH.Exp-curLoc = do-  (TH.Loc _ _ modName (startPosL,_) _) <- TH.location-  TH.litE (TH.StringL $ modName ++ "(" ++ show startPosL ++ "): ")---- | Cache the result of a monadic action-makeCached :: (MonadState s m, Hashable k, Eq k)-           => k -- ^ The key the action is associated with-           -> Lens' s (HashMap k v) -- ^ The Lens to the HashMap that is the cache-           -> m v -- ^ The action to cache-           -> m v-makeCached key l create = do-  cache <- use l-  case HashMapL.lookup key cache of-    Just value -> return value-    Nothing -> do-      value <- create-      l %= HashMapL.insert key value-      return value---- | Cache the result of a monadic action in a State 3 transformer layers down-makeCachedT3 :: ( MonadTrans t2, MonadTrans t1, MonadTrans t-                , Eq k, Hashable k-                , MonadState s m-                , Monad (t2 m), Monad (t1 (t2 m)), Monad (t (t1 (t2 m))))-             => k -- ^ The key the action is associated with-             -> Lens' s (HashMap k v) -- ^ The Lens to the HashMap that is the cache-             -> (t (t1 (t2 m))) v -- ^ The action to cache-             -> (t (t1 (t2 m))) v-makeCachedT3 key l create = do-  cache <- (lift . lift . lift) $ use l-  case HashMapL.lookup key cache of-    Just value -> return value-    Nothing -> do-      value <- create-      (lift . lift . lift) $ l %= HashMapL.insert key value-      return value---- | Spine-strict cache variant of 'mkCachedT3'-makeCachedT3S :: ( MonadTrans t2, MonadTrans t1, MonadTrans t-                 , Eq k, Hashable k-                 , MonadState s m-                 , Monad (t2 m), Monad (t1 (t2 m)), Monad (t (t1 (t2 m)))-                 , NFData v)-              => k-              -> Lens' s (HashMap k v)-              -> (t (t1 (t2 m))) v-              -> (t (t1 (t2 m))) v-makeCachedT3S key l create = do-  cache <- (lift . lift . lift) $ use l-  case HashMapS.lookup key cache of-    Just value -> return value-    Nothing -> do-      value <- create-      value `deepseq` ((lift . lift . lift) $ l %= HashMapS.insert key value)-      return value---- | Run a State-action using the State that is stored in a higher-layer Monad-liftState :: (MonadState s m)-          => Lens' s s' -- ^ Lens to the State in the higher-layer monad-          -> State s' a -- ^ The State-action to perform-          -> m a-liftState l m = do-  s <- use l-  let (a,s') = runState m s-  l .= s'-  return a---- | Functorial version of 'Control.Arrow.first'-firstM :: Functor f-       => (a -> f c)-       -> (a, b)-       -> f (c, b)-firstM f (x,y) = (,y) <$> f x---- | Functorial version of 'Control.Arrow.second'-secondM :: Functor f-        => (b -> f c)-        -> (a, b)-        -> f (a, c)-secondM f (x,y) = (x,) <$> f y--combineM :: (Applicative f)-         => (a -> f b)-         -> (c -> f d)-         -> (a,c)-         -> f (b,d)-combineM f g (x,y) = (,) <$> f x <*> g y---- | Performs trace when first argument evaluates to 'True'-traceIf :: Bool -> String -> a -> a-traceIf True  msg = trace msg-traceIf False _   = id---- | Monadic version of 'Data.List.partition'-partitionM :: Monad m-           => (a -> m Bool)-           -> [a]-           -> m ([a], [a])-partitionM _ []     = return ([], [])-partitionM p (x:xs) = do-  test      <- p x-  (ys, ys') <- partitionM p xs-  return $ if test then (x:ys, ys') else (ys, x:ys')---- | Monadic version of 'Data.List.mapAccumL'-mapAccumLM :: (Monad m)-           => (acc -> x -> m (acc,y))-           -> acc-           -> [x]-           -> m (acc,[y])-mapAccumLM _ acc [] = return (acc,[])-mapAccumLM f acc (x:xs) = do-  (acc',y) <- f acc x-  (acc'',ys) <- mapAccumLM f acc' xs-  return (acc'',y:ys)---- | Composition of a unary function with a binary function-dot :: (c -> d) -> (a -> b -> c) -> a -> b -> d-dot = (.) . (.)---- | if-then-else as a function on an argument-ifThenElse :: (a -> Bool)-           -> (a -> b)-           -> (a -> b)-           -> a-           -> b-ifThenElse t f g a = if t a then f a else g a--infixr 5 <:>--- | Applicative version of 'GHC.Types.(:)'-(<:>) :: Applicative f-      => f a-      -> f [a]-      -> f [a]-x <:> xs = (:) <$> x <*> xs---- | Safe indexing, returns a 'Nothing' if the index does not exist-indexMaybe :: [a]-           -> Int-           -> Maybe a-indexMaybe [] _     = Nothing-indexMaybe (x:_)  0 = Just x-indexMaybe (_:xs) n = indexMaybe xs (n-1)---- | Unsafe indexing, return a custom error message when indexing fails-indexNote :: String-          -> [a]-          -> Int-          -> a-indexNote note = fromMaybe (error note) `dot` indexMaybe---- | Split the second list at the length of the first list-splitAtList :: [b] -> [a] -> ([a], [a])-splitAtList [] xs         = ([], xs)-splitAtList _ xs@[]       = (xs, xs)-splitAtList (_:xs) (y:ys) = (y:ys', ys'')-    where-      (ys', ys'') = splitAtList xs ys--clashLibVersion :: Version-#ifdef CABAL-clashLibVersion = Paths_clash_lib.version-#else-clashLibVersion = error "development version"-#endif---- | \x y -> floor (logBase x y), x > 1 && y > 0-flogBase :: Integer -> Integer -> Maybe Int-flogBase x y | x > 1 && y > 0 = Just (I# (integerLogBase# x y))-flogBase _ _ = Nothing---- | \x y -> ceiling (logBase x y), x > 1 && y > 0-clogBase :: Integer -> Integer -> Maybe Int-clogBase x y | x > 1 && y > 0 =-  case y of-    1 -> Just 0-    _ -> let z1 = integerLogBase# x y-             z2 = integerLogBase# x (y-1)-         in  if isTrue# (z1 ==# z2)-                then Just (I# (z1 +# 1#))-                else Just (I# z1)-clogBase _ _ = Nothing
+ src/Clash/Annotations/BitRepresentation/ClashLib.hs view
@@ -0,0 +1,59 @@+{-|+Copyright  :  (C) 2018, Google Inc.+                  2022, LUMI GUIDE FIETSDETECTIE B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++Houses internal BitRepresentation code which cannot be housed in clash-prelude+due to its dependencies.+-}++{-# LANGUAGE TemplateHaskell #-}++module Clash.Annotations.BitRepresentation.ClashLib+  ( coreToType'+  , bitsToBits+  ) where++import           Clash.Annotations.BitRepresentation.Internal+  (Type'(..))+import qualified Clash.Annotations.BitRepresentation.Util as BitRepresentation+import qualified Clash.Core.Type                          as C+import           Clash.Core.Name                          (nameOcc)+import qualified Clash.Netlist.Types                      as Netlist+import           Clash.Util                               (curLoc)+import qualified Data.Text as T                           (pack)++-- Convert Core type to BitRepresentation type+coreToType'+  :: C.Type+  -- ^ Type to convert to bit representation type+  -> Either+       String+       -- Error message+       Type'+       -- Bit representation type+coreToType' (C.AppTy t1 t2) =+  AppTy' <$> coreToType' t1 <*> coreToType' t2+coreToType' (C.ConstTy (C.TyCon name)) =+  return $ ConstTy' (nameOcc name)+coreToType' (C.LitTy (C.NumTy n)) =+  return $ LitTy' n+coreToType' (C.LitTy (C.SymTy lit)) =+  return $ SymLitTy' (T.pack lit)+coreToType' e =+  Left $ $(curLoc) ++ "Unexpected type: " ++ show e+++bitToBit+  :: BitRepresentation.Bit+  -> Netlist.Bit+bitToBit BitRepresentation.H = Netlist.H+bitToBit BitRepresentation.L = Netlist.L+bitToBit BitRepresentation.U = Netlist.U++-- | Converts a list of /BitRepresentation.Bit/s to their Netlist counterpart.+bitsToBits+  :: [BitRepresentation.Bit]+  -> [Netlist.Bit]+bitsToBits = map bitToBit
+ src/Clash/Annotations/TopEntity/Extra.hs view
@@ -0,0 +1,50 @@+{-|+  Copyright   :  (C) 2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Clash.Annotations.TopEntity.Extra where++import Clash.Annotations.TopEntity (TopEntity, PortName)+import Clash.Netlist.Types (TopEntityT)+import Language.Haskell.TH.Syntax+  (ModName, Name, NameFlavour, NameSpace, PkgName, OccName)+import Data.Binary                 (Binary)+import Data.Hashable               (Hashable)+import Control.DeepSeq             (NFData)++instance Binary TopEntityT+instance Binary TopEntity+instance Binary PortName++instance Binary Name+instance Binary OccName+instance Binary NameFlavour+instance Binary ModName+instance Binary NameSpace+instance Binary PkgName++instance Hashable TopEntityT+instance Hashable TopEntity+instance Hashable PortName++instance Hashable ModName+instance Hashable Name+instance Hashable NameFlavour+instance Hashable NameSpace+instance Hashable PkgName+instance Hashable OccName++instance NFData TopEntityT+instance NFData TopEntity+instance NFData PortName++instance NFData ModName+instance NFData Name+instance NFData NameFlavour+instance NFData NameSpace+instance NFData PkgName+instance NFData OccName
+ src/Clash/Backend.hs view
@@ -0,0 +1,170 @@+{-|+  Copyright  :  (C) 2015-2016, University of Twente,+                    2017     , Myrtle Software Ltd, Google Inc.,+                    2021-2022, QBayLogic B.V.+                    2022     , Google Inc.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Backend where++import Data.HashMap.Strict                  (HashMap, empty)+import Data.HashSet                         (HashSet)+import Control.Lens                         (Lens')+import Data.Monoid                          (Ap)+import Data.Text                            (Text)+import qualified Data.Text.Lazy             as LT+import Control.Monad.State                  (State)+import Data.Text.Prettyprint.Doc.Extra      (Doc)++import GHC.Types.SrcLoc (SrcSpan)++import Clash.Driver.Types (ClashOpts)+import {-# SOURCE #-} Clash.Netlist.Types+  (Component, Declaration, Expr, HWType, Identifier, IdentifierSet, HasIdentifierSet, UsageMap)+import Clash.Netlist.BlackBox.Types++import Clash.Signal.Internal                (VDomainConfiguration)+import Clash.Annotations.Primitive          (HDL)++#ifdef CABAL+import qualified Paths_clash_lib+import qualified Data.Version+#else+import qualified System.FilePath+#endif++primsRoot :: IO FilePath+#ifdef CABAL+primsRoot = Paths_clash_lib.getDataFileName "prims"+#else+primsRoot = return ("clash-lib" System.FilePath.</> "prims")+#endif++clashVer :: String+#ifdef CABAL+clashVer = Data.Version.showVersion Paths_clash_lib.version+#else+clashVer = "development"+#endif++type ModName = Text++-- | Is a type used for internal or external use+data Usage+  = Internal+  -- ^ Internal use+  | External Text+  -- ^ External use, field indicates the library name++-- | Is '-fclash-aggresive-x-optimization-blackbox' set?+newtype AggressiveXOptBB = AggressiveXOptBB Bool++-- | Is '-fclash-render-enums' set?+newtype RenderEnums = RenderEnums Bool++-- | Kind of a HDL type. Used to determine whether types need conversions in+-- order to cross top entity boundaries.+data HWKind+  = PrimitiveType+  -- ^ A type defined in an HDL spec. Usually types such as: bool, bit, ..+  | SynonymType+  -- ^ A user defined type that's simply a synonym for another type, very much+  -- like a type synonym in Haskell. As long as two synonym types refer to the+  -- same type, they can be used interchangeably. E.g., a subtype in VHDL.+  | UserType+  -- ^ User defined type that's not interchangeable with any others, even if+  -- the underlying structures are the same. Similar to an ADT in Haskell.++type DomainMap = HashMap Text VDomainConfiguration++emptyDomainMap :: DomainMap+emptyDomainMap = empty++class HasUsageMap s where+  usageMap :: Lens' s UsageMap++class (HasUsageMap state, HasIdentifierSet state) => Backend state where+  -- | Initial state for state monad+  initBackend :: ClashOpts -> state++  -- | What HDL is the backend generating+  hdlKind :: state -> HDL++  -- | Location for the primitive definitions+  primDirs :: state -> IO [FilePath]++  -- | Name of backend, used for directory to put output files in. Should be+  --   constant function / ignore argument.+  name :: state -> String++  -- | File extension for target langauge+  extension :: state -> String++  -- | Get the set of types out of state+  extractTypes     :: state -> HashSet HWType++  -- | Generate HDL for a Netlist component+  genHDL           :: ClashOpts -> ModName -> SrcSpan -> IdentifierSet -> UsageMap -> Component -> Ap (State state) ((String, Doc),[(String,Doc)])+  -- | Generate a HDL package containing type definitions for the given HWTypes+  mkTyPackage      :: ModName -> [HWType] -> Ap (State state) [(String, Doc)]+  -- | Convert a Netlist HWType to a target HDL type+  hdlType          :: Usage -> HWType -> Ap (State state) Doc+  -- | Query what kind of type a given HDL type is+  hdlHWTypeKind :: HWType -> State state HWKind+  -- | Convert a Netlist HWType to an HDL error value for that type+  hdlTypeErrValue  :: HWType       -> Ap (State state) Doc+  -- | Convert a Netlist HWType to the root of a target HDL type+  hdlTypeMark      :: HWType       -> Ap (State state) Doc+  -- | Create a record selector+  hdlRecSel        :: HWType -> Int -> Ap (State state) Doc+  -- | Create a signal declaration from an identifier (Text) and Netlist HWType+  hdlSig           :: LT.Text -> HWType -> Ap (State state) Doc+  -- | Create a generative block statement marker+  genStmt          :: Bool -> State state Doc+  -- | Turn a Netlist Declaration to a HDL concurrent block+  inst             :: Declaration  -> Ap (State state) (Maybe Doc)+  -- | Turn a Netlist expression into a HDL expression+  expr             :: Bool -- ^ Enclose in parentheses?+                   -> Expr -- ^ Expr to convert+                   -> Ap (State state) Doc+  -- | Bit-width of Int,Word,Integer+  iwWidth          :: State state Int+  -- | Convert to a bit-vector+  toBV             :: HWType -> LT.Text -> Ap (State state) Doc+  -- | Convert from a bit-vector+  fromBV           :: HWType -> LT.Text -> Ap (State state) Doc+  -- | Synthesis tool we're generating HDL for+  hdlSyn           :: State state HdlSyn+  -- | setModName+  setModName       :: ModName -> state -> state+  -- | Set the name of the current top entity+  setTopName       :: Identifier -> state -> state+  -- | Get the name of the current top entity+  getTopName       :: State state Identifier+  -- | setSrcSpan+  setSrcSpan       :: SrcSpan -> State state ()+  -- | getSrcSpan+  getSrcSpan       :: State state SrcSpan+  -- | Block of declarations+  blockDecl        :: Identifier -> [Declaration] -> Ap (State state) Doc+  addIncludes      :: [(String, Doc)] -> State state ()+  addLibraries     :: [LT.Text] -> State state ()+  addImports       :: [LT.Text] -> State state ()+  addAndSetData    :: FilePath -> State state String+  getDataFiles     :: State state [(String,FilePath)]+  addMemoryDataFile  :: (String,String) -> State state ()+  getMemoryDataFiles :: State state [(String,String)]+  ifThenElseExpr :: state -> Bool+  -- | Whether -fclash-aggressive-x-optimization-blackboxes was set+  aggressiveXOptBB :: State state AggressiveXOptBB+  -- | Whether -fclash-no-render-enums was set+  renderEnums :: State state RenderEnums+  -- | All the domain configurations of design+  domainConfigurations :: State state DomainMap+  -- | Set the domain configurations+  setDomainConfigurations :: DomainMap -> state -> state
+ src/Clash/Backend/SystemVerilog.hs view
@@ -0,0 +1,1549 @@+{-|+  Copyright   :  (C) 2015-2016, University of Twente,+                     2017-2018, Google Inc.,+                     2021-2024, QBayLogic B.V.,+                     2022     , Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Generate SystemVerilog for assorted Netlist datatypes+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Backend.SystemVerilog (SystemVerilogState) where++import qualified Control.Applicative                  as A+import           Control.Lens                         hiding (Indexed)+import           Control.Monad                        (forM,liftM,zipWithM)+import           Control.Monad.State                  (State)+import           Data.Bifunctor                       (first)+import           Data.Bits                            (Bits, testBit)+import qualified Data.ByteString.Char8                as B8+import           Data.Coerce                          (coerce)+import           Data.Function                        (on)+import           Data.HashMap.Lazy                    (HashMap)+import qualified Data.HashMap.Lazy                    as HashMap+import           Data.HashSet                         (HashSet)+import qualified Data.HashSet                         as HashSet+import qualified Data.Map                             as Map+import           Data.Map                             (Map)+import           Data.List                            (nub, nubBy)+import           Data.List.Extra                      ((<:>), zipEqual)+import           Data.Maybe                           (catMaybes,fromMaybe,mapMaybe)+import           Data.Monoid                          (Ap(Ap))+import           Data.Monoid.Extra                    ()+import qualified Data.Text.Lazy                       as Text+import qualified Data.Text                            as TextS+import           Data.Text.Prettyprint.Doc.Extra+import qualified Data.Text.Prettyprint.Doc.Extra      as PP+import           Data.Tuple                           (swap)+import qualified System.FilePath++import           Clash.Annotations.Primitive          (HDL (..))+import           Clash.Annotations.BitRepresentation.Internal+  (ConstrRepr'(..), DataRepr'(..))+import           Clash.Annotations.BitRepresentation.ClashLib+  (bitsToBits)+import           Clash.Annotations.BitRepresentation.Util+  (BitOrigin(Lit, Field), bitOrigins, bitRanges)+import           Clash.Annotations.SynthesisAttributes (Attr(..))+import           Clash.Debug                          (traceIf)+import           Clash.Backend+import           Clash.Backend.Verilog+  (bits, bit_char, encodingNote, exprLit, include, noEmptyInit, uselibs)+import           Clash.Backend.Verilog.Time           (periodToString)+import           Clash.Driver.Types                   (ClashOpts(..))+import           Clash.Explicit.BlockRam.Internal     (unpackNats)+import           Clash.Netlist.BlackBox.Types         (HdlSyn (..))+import           Clash.Netlist.BlackBox.Util+  (extractLiterals, renderBlackBox, addFilePath)+import qualified Clash.Netlist.Id                     as Id+import           Clash.Netlist.Types                  hiding (intWidth, usages, _usages)+import           Clash.Netlist.Util+import           Clash.Signal.Internal                (ActiveEdge (..))+import           Clash.Util+  (SrcSpan, clogBase, noSrcSpan, curLoc, makeCached, indexNote)+import           Clash.Util.Graph                     (reverseTopSort)++-- | State for the 'Clash.Backend.SystemVerilog.SystemVerilogM' monad:+data SystemVerilogState =+  SystemVerilogState+    { _tyCache   :: HashSet HWType -- ^ Previously encountered  HWTypes+    , _nameCache :: HashMap HWType Identifier -- ^ Cache for previously generated product type names+    , _genDepth  :: Int -- ^ Depth of current generative block+    , _modNm     :: ModName+    , _topNm     :: Identifier+    , _idSeen    :: IdentifierSet+    , _oports    :: [Identifier]+    , _srcSpan   :: SrcSpan+    , _includes  :: [(String,Doc)]+    , _imports   :: [Text.Text]+    , _libraries :: [Text.Text]+    , _dataFiles :: Map FilePath String+    -- ^ Files to be copied: (path to file, file name). The file name stored in+    -- the map might differ from the file name in the path, to prevent name+    -- collisions.+    , _includeDirs :: [FilePath]+    -- ^ Import directories passed in with @-i@+    , _memoryDataFiles:: [(String,String)]+    -- ^ Files to be stored: (filename, contents). These files are generated+    -- during the execution of 'genNetlist'.+    , _tyPkgCtx  :: Bool+    -- ^ Are we in the context of generating the @_types@  package?+    , _intWidth  :: Int -- ^ Int/Word/Integer bit-width+    , _hdlsyn    :: HdlSyn+    , _undefValue :: Maybe (Maybe Int)+    , _aggressiveXOptBB_ :: AggressiveXOptBB+    , _renderEnums_ :: RenderEnums+    , _domainConfigurations_ :: DomainMap+    , _usages :: UsageMap+    }++makeLenses ''SystemVerilogState++instance HasIdentifierSet SystemVerilogState where+  identifierSet = idSeen++instance HasUsageMap SystemVerilogState where+  usageMap = usages++instance Backend SystemVerilogState where+  initBackend opts = SystemVerilogState+    { _tyCache=HashSet.empty+    , _nameCache=HashMap.empty+    , _genDepth=0+    , _modNm=""+    , _topNm=Id.unsafeMake ""+    , _idSeen=Id.emptyIdentifierSet (opt_escapedIds opts) (opt_lowerCaseBasicIds opts) SystemVerilog+    , _oports=[]+    , _srcSpan=noSrcSpan+    , _includes=[]+    , _imports=[]+    , _libraries=[]+    , _dataFiles=mempty+    , _includeDirs = opt_importPaths opts+    , _memoryDataFiles=[]+    , _tyPkgCtx=False+    , _intWidth=opt_intWidth opts+    , _hdlsyn=opt_hdlSyn opts+    , _undefValue=opt_forceUndefined opts+    , _aggressiveXOptBB_=coerce (opt_aggressiveXOptBB opts)+    , _renderEnums_=coerce (opt_renderEnums opts)+    , _domainConfigurations_=emptyDomainMap+    , _usages=mempty+    }+  hdlKind         = const SystemVerilog+  primDirs        = const $ do root <- primsRoot+                               return [ root System.FilePath.</> "common"+                                      , root System.FilePath.</> "commonverilog"+                                      , root System.FilePath.</> "systemverilog"+                                      ]+  extractTypes    = _tyCache+  name            = const "systemverilog"+  extension       = const ".sv"++  genHDL          = genSystemVerilog+  mkTyPackage     = mkTyPackage_+  hdlHWTypeKind = \case+    Vector {} -> pure UserType+    RTree {} -> pure UserType+    Product {} -> pure UserType+    MemBlob {} -> pure UserType+    BiDirectional _ ty -> hdlHWTypeKind ty+    Annotated _ ty -> hdlHWTypeKind ty+    _ -> pure PrimitiveType+  hdlType _       = verilogType+  hdlTypeErrValue = verilogTypeErrValue+  hdlTypeMark     = verilogTypeMark+  hdlRecSel       = verilogRecSel+  hdlSig t ty     = sigDecl (string t) ty+  genStmt True    = do cnt <- use genDepth+                       genDepth += 1+                       if cnt > 0+                          then emptyDoc+                          else "generate"+  genStmt False   = do genDepth -= 1+                       cnt <- use genDepth+                       if cnt > 0+                          then emptyDoc+                          else "endgenerate"+  inst            = inst_+  expr            = expr_+  iwWidth         = use intWidth+  toBV hty id_    = toSLV hty (Identifier (Id.unsafeMake (Text.toStrict id_)) Nothing)+  fromBV hty id_  = simpleFromSLV hty (Text.toStrict id_)+  hdlSyn          = use hdlsyn+  setModName nm s = s {_modNm = nm}+  setTopName nm s = s {_topNm = nm}+  getTopName      = use topNm+  setSrcSpan      = (srcSpan .=)+  getSrcSpan      = use srcSpan+  blockDecl _ ds  = do+    decs <- decls ds+    if isEmpty decs+      then insts ds+      else+        pure decs <> line <>+        insts ds+  addIncludes inc = includes %= (inc++)+  addLibraries libs = libraries %= (libs ++)+  addImports inps = imports %= (inps ++)+  addAndSetData f = do+    fs <- use dataFiles+    iDirs <- use includeDirs+    let (fs',f') = addFilePath iDirs fs f+    dataFiles .= fs'+    return f'+  getDataFiles :: State SystemVerilogState [(String, FilePath)]+  getDataFiles = map swap . Map.assocs <$> use dataFiles+  addMemoryDataFile f = memoryDataFiles %= (f:)+  getMemoryDataFiles = use memoryDataFiles+  ifThenElseExpr _ = True+  aggressiveXOptBB = use aggressiveXOptBB_+  renderEnums = use renderEnums_+  domainConfigurations = use domainConfigurations_+  setDomainConfigurations confs s = s {_domainConfigurations_ = confs}++type SystemVerilogM a = Ap (State SystemVerilogState) a++-- | Generate SystemVerilog for a Netlist component+genSystemVerilog+  :: ClashOpts+  -> ModName+  -> SrcSpan+  -> IdentifierSet+  -> UsageMap+  -> Component+  -> SystemVerilogM ((String, Doc), [(String, Doc)])+genSystemVerilog opts _ sp seen us c = do+    -- Don't have type names conflict with module names or with previously+    -- generated type names.+    --+    -- TODO: Collect all type names up front, to prevent relatively costly union.+    -- TODO: Investigate whether type names / signal names collide in the first place+    Ap $ do+      idSeen %= Id.union seen+      usages .= us+      setSrcSpan sp++    v    <- verilog+    incs <- Ap $ use includes+    return ((TextS.unpack (Id.toText cName), v), incs)+  where+    cName   = componentName c+    verilog = commentHeader <> line <>+              nettypeNone <> line <>+              timescale <> line <>+              module_ c <> line <>+              nettypeDefault++    commentHeader+         = "/* AUTOMATICALLY GENERATED SYSTEMVERILOG-2005 SOURCE CODE."+      <> line <> "** GENERATED BY CLASH " <> string (Text.pack clashVer) <> ". DO NOT MODIFY."+      <> line <> "*/"+    nettypeNone = "`default_nettype none"+    nettypeDefault = "`default_nettype wire"+    timescale = "`timescale 100fs/" <> string (Text.pack precision)+    precision = periodToString (opt_timescalePrecision opts)++-- | Generate a SystemVerilog package containing type definitions for the given HWTypes+mkTyPackage_ :: TextS.Text -> [HWType] -> SystemVerilogM [(String,Doc)]+mkTyPackage_ modName hwtys = do+    Ap (tyPkgCtx .= True)+    normTys <- nub <$> mapM (normaliseType) (hwtys ++ usedTys)+    let+      needsDec    = nubBy eqReprTy $ normTys+      hwTysSorted = topSortHWTys needsDec+      packageDec  = vcat $ fmap catMaybes $ mapM tyDec hwTysSorted+      funDecs     = vcat $ fmap catMaybes $ mapM funDec hwTysSorted++    pkg <- (:[]) A.<$> (TextS.unpack modName ++ "_types",) A.<$>+       "package" <+> modNameD <> "_types" <> semi <> line <>+         indent 2 packageDec <> line <>+         indent 2 funDecs <> line <>+       "endpackage" <+> colon <+> modNameD <> "_types"+    Ap (tyPkgCtx .= False)+    return pkg+  where+    modNameD    = stringS modName+    usedTys     = concatMap mkUsedTys hwtys++    eqReprTy :: HWType -> HWType -> Bool+    eqReprTy (Vector n ty1) (Vector m ty2)+      | m == n    = eqReprTy ty1 ty2+      | otherwise = False+    eqReprTy (RTree n ty1) (RTree m ty2)+      | m == n    = eqReprTy ty1 ty2+      | otherwise = False+    eqReprTy Bit  ty2 = ty2 `elem` [Bit,Bool]+    eqReprTy Bool ty2 = ty2 `elem` [Bit,Bool]+    eqReprTy ty1 ty2+      | isUnsigned ty1 && isUnsigned ty2 = typeSize ty1 == typeSize ty2+      | otherwise                        = ty1 == ty2++    isUnsigned :: HWType -> Bool+    isUnsigned (Unsigned _)        = True+    isUnsigned (BitVector _)       = True+    isUnsigned (Index _)           = True+    isUnsigned (Sum _ _)           = True+    isUnsigned (CustomSum _ _ _ _) = True+    isUnsigned (SP _ _)            = True+    isUnsigned (CustomSP _ _ _ _)  = True+    isUnsigned _                   = False++mkUsedTys :: HWType+        -> [HWType]+mkUsedTys v@(Vector _ elTy)     = v : mkUsedTys elTy+mkUsedTys t@(RTree _ elTy)      = t : mkUsedTys elTy+mkUsedTys p@(Product _ _ elTys) = p : concatMap mkUsedTys elTys+mkUsedTys sp@(SP _ elTys)       = sp : concatMap mkUsedTys (concatMap snd elTys)+mkUsedTys t                     = [t]++topSortHWTys :: [HWType]+             -> [HWType]+topSortHWTys hwtys = sorted+  where+    nodes  = zip [0..] hwtys+    nodesI = HashMap.fromList (zip hwtys [0..])+    edges  = concatMap edge hwtys+    sorted =+      case reverseTopSort nodes edges of+        Left err -> error ("[BUG IN CLASH] topSortHWTys: " ++ err)+        Right ns -> ns++    edge t@(Vector _ elTy) = maybe [] ((:[]) . (HashMap.lookupDefault (error $ $(curLoc) ++ "Vector") t nodesI,))+                                      (HashMap.lookup elTy nodesI)+    edge t@(RTree _ elTy)  = maybe [] ((:[]) . (HashMap.lookupDefault (error $ $(curLoc) ++ "RTree") t nodesI,))+                                      (HashMap.lookup elTy nodesI)+    edge t@(Product _ _ tys) = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "Product") t nodesI+                               in mapMaybe (\ty -> liftM (ti,) (HashMap.lookup ty nodesI)) tys+    edge t@(SP _ ctys)     = let ti = HashMap.lookupDefault (error $ $(curLoc) ++ "SP") t nodesI+                             in concatMap (\(_,tys) -> mapMaybe (\ty -> liftM (ti,) (HashMap.lookup ty nodesI)) tys) ctys+    edge _                 = []++normaliseType :: HWType -> SystemVerilogM HWType+normaliseType (Annotated _ ty) = normaliseType ty+normaliseType (Vector n ty)    = Vector n <$> (normaliseType ty)+normaliseType (MemBlob n m)    = return (Vector n (BitVector m))+normaliseType (RTree d ty)     = RTree d <$> (normaliseType ty)+normaliseType (Product nm lbls tys) = Product nm lbls <$> (mapM normaliseType tys)+normaliseType ty@(SP _ elTys)      = do+  Ap $ mapM_ ((tyCache %=) . HashSet.insert) (concatMap snd elTys)+  return (BitVector (typeSize ty))+normaliseType (CustomSP _ _dataRepr size elTys) = do+  Ap $ mapM_ ((tyCache %=) . HashSet.insert) [ty | (_, _, subTys) <- elTys, ty <- subTys]+  return (BitVector size)+normaliseType ty@(Index _) = return (Unsigned (typeSize ty))+normaliseType ty@(Sum _ _) = return (BitVector (typeSize ty))+normaliseType ty@(CustomSum _ _ _ _) = return (BitVector (typeSize ty))+normaliseType (Clock _) = return Bit+normaliseType (ClockN _) = return Bit+normaliseType (Reset _) = return Bit+normaliseType (Enable _) = return Bool+normaliseType (BiDirectional dir ty) = BiDirectional dir <$> normaliseType ty+normaliseType ty = return ty+++range :: Either Int Int -> SystemVerilogM Doc+range (Left n)  = brackets (int (n-1) <> colon <> int 0)+range (Right n) = brackets (int 0 <> colon <> int (n-1))++tyDec :: HWType -> SystemVerilogM (Maybe Doc)+tyDec ty@(Vector n elTy) | typeSize ty > 0 = Just A.<$> do+  syn <- Ap hdlSyn+  case syn of+    Vivado -> case splitVecTy ty of+      Just ([Right n',Left n''],elTy') ->+        "typedef" <+> elTy' <+> brackets (int (n''-1) <> colon <> int 0) <+>+        tyName ty <+> brackets (int 0 <> colon <> int (n'-1)) <> semi+      _ ->+        "typedef" <+> "logic" <+> brackets (int (typeSize elTy - 1) <> colon <> int 0) <+>+        tyName ty <+> brackets (int 0 <> colon <> int (n-1)) <> semi+    _ -> case splitVecTy ty of+      Just (Right n':ns,elTy') ->+        "typedef" <+> elTy' <+> hcat (mapM range ns) <+> tyName ty <+>+        brackets (int 0 <> colon <> int (n' - 1)) <> semi+      _ -> error $ $(curLoc) ++ "impossible"+tyDec ty@(RTree n elTy) | typeSize elTy > 0 = Just A.<$> do+  syn <- Ap hdlSyn+  case syn of+    Vivado -> case splitVecTy ty of+      Just ([Right n',Left n''],elTy') -> -- n' == 2^n+        "typedef" <+> elTy' <+> brackets (int 0 <> colon <> int (n''-1)) <+>+        tyName ty <+> brackets (int 0 <> colon <> int (n'-1)) <> semi+      _ ->+        "typedef" <+> "logic" <+> brackets (int (typeSize elTy - 1) <> colon <> int 0) <+>+        tyName ty <+> brackets (int 0 <> colon <> int (2^n-1)) <> semi+    _ -> case splitVecTy ty of+      Just (Right n':ns,elTy') -> -- n' == 2^n+        "typedef" <+> elTy' <+> hcat (mapM range ns) <+> tyName ty <+>+        brackets (int 0 <> colon <> int (n' - 1)) <> semi+      _ -> error $ $(curLoc) ++ "impossible"+tyDec ty@(Product _ _ tys) | typeSize ty > 0 = Just A.<$> prodDec+  where+    prodDec = "typedef struct packed {" <> line <>+                indent 2 (vcat $ fmap catMaybes $ zipWithM combineM selNames tys) <> line <>+              "}" <+> tName <> semi++    combineM x y = do+      yM <- lvType y+      case yM of+        Nothing -> pure Nothing+        Just y' -> Just A.<$> (pure y' <+> x <> semi)+    tName    = tyName ty+    selNames = map (\i -> tName <> "_sel" <> int i) [0..]++tyDec _ = pure Nothing++splitVecTy :: HWType -> Maybe ([Either Int Int],SystemVerilogM Doc)+splitVecTy = fmap splitElemTy . go+  where+    splitElemTy (ns,t) = case t of+      Product {} -> (ns, verilogType t)+      Vector {}  -> error $ $(curLoc) ++ "impossible"+      Clock {}   -> (ns, verilogType t)+      ClockN {}  -> (ns, verilogType t)+      Reset {}   -> (ns, "logic")+      Enable {}  -> (ns, "logic")+      Bool       -> (ns, "logic")+      Bit        -> (ns, "logic")+      String     -> (ns, "string")+      Signed n   -> (ns ++ [Left n],"logic signed")+      _          -> (ns ++ [Left (typeSize t)], "logic")++    go (Vector n elTy) = case go elTy of+      Just (ns,elTy') -> Just (Right n:ns,elTy')+      _               -> Just ([Right n],elTy)++    go (RTree n elTy) = let n' = 2^n in case go elTy of+      Just (ns,elTy') -> Just (Right n':ns,elTy')+      _               -> Just ([Right n'],elTy)++    go _ = Nothing++lvType :: HWType -> SystemVerilogM (Maybe Doc)+lvType ty@(Vector n elTy) | typeSize ty > 0 = Just A.<$> do+  syn <- Ap hdlSyn+  case syn of+    Vivado -> "logic" <+> brackets (int 0 <> colon <> int (n-1)) <> brackets (int (typeSize elTy - 1) <> colon <> int 0)+    _ -> case splitVecTy ty of+      Just (ns,elTy') -> elTy' <> hcat (mapM range ns)+      _ -> error $ $(curLoc) ++ "impossible"+lvType ty@(RTree n elTy) | typeSize elTy > 0 = Just A.<$> do+  syn <- Ap hdlSyn+  case syn of+    Vivado -> "logic" <+> brackets (int 0 <> colon <> int (2^n-1)) <> brackets (int (typeSize elTy - 1) <> colon <> int 0)+    _ -> case splitVecTy ty of+      Just (ns,elTy') -> elTy' <> hcat (mapM range ns)+      _ -> error $ $(curLoc) ++ "impossible"+lvType ty | typeSize ty > 0 = Just A.<$> verilogType ty+lvType _ = pure Nothing++funDec :: HWType -> SystemVerilogM (Maybe Doc)+funDec ty@(Vector n elTy) | typeSize ty > 0 = Just A.<$>+  "function" <+> "automatic" <+> "logic" <+> ranges <+> tName <> "_to_lv" <> parens (sigDecl "i" ty) <> semi <> line <>+  indent 2+    ("for" <+> parens ("int n = 0" <> semi <+> "n <" <+> int n <> semi <+> "n=n+1") <> line <>+      indent 2 (tName <> "_to_lv" <> brackets "n" <+> "=" <+> "i[n]" <> semi)) <> line <>+  "endfunction" <> line <>+  "function" <+> "automatic" <+> tName <+> tName <> "_from_lv" <> parens ("logic" <+> ranges <+> "i") <> semi <> line <>+  indent 2+    ("for" <+> parens ("int n = 0" <> semi <+> "n <" <+> int n <> semi <+> "n=n+1") <> line <>+      indent 2 (tName <> "_from_lv" <> brackets "n" <+> "=" <+> "i[n]" <> semi)) <> line <>+  "endfunction" <> line <>+  if n > 1 then+    "function" <+> "automatic" <+> tName <+> tName <> "_cons" <> parens (sigDecl "x" elTy <> comma <> vecSigDecl "xs") <> semi <> line <>+    indent 2+      (tName <> "_cons" <> brackets (int 0) <+> "=" <+> (toSLV elTy (Identifier (Id.unsafeMake "x") Nothing)) <> semi <> line <>+       tName <> "_cons" <> brackets (int 1 <> colon <> int (n-1)) <+> "=" <+> "xs" <> semi) <> line <>+    "endfunction"+  else+    "function" <+> "automatic" <+> tName <+> tName <> "_cons" <> parens (sigDecl "x" elTy) <> semi <> line <>+    indent 2+      (tName <> "_cons" <> brackets (int 0) <+> "=" <+> (toSLV elTy (Identifier (Id.unsafeMake "x") Nothing)) <> semi) <> line <>+    "endfunction"+  where+    tName  = tyName ty+    ranges = brackets (int 0 <> colon <> int (n-1)) <>+             brackets (int (typeSize elTy - 1) <> colon <> int 0)++    vecSigDecl :: SystemVerilogM Doc -> SystemVerilogM Doc+    vecSigDecl d = do+      syn <- Ap hdlSyn+      case syn of+        Vivado -> case splitVecTy ty of+          Just ([Right n',Left n''],elTy') ->+            elTy' <+> brackets (int 0 <> colon <> int (n''-1)) <+>+            d <+> brackets (int 0 <> colon <> int (n'-2))+          _ ->+            "logic" <+> brackets (int (typeSize elTy - 1) <> colon <> int 0) <+>+            d <+> brackets (int 0 <> colon <> int (n-2))+        _ -> case splitVecTy ty of+         Just (Right n':ns,elTy') ->+           elTy' <+> hcat (mapM range ns) <+> d <+>+           brackets (int 0 <> colon <> int (n' - 2))+         _ -> error $ $(curLoc) ++ "impossible"+++funDec ty@(RTree n elTy) | typeSize elTy > 0 = Just A.<$>+  "function" <+> "automatic" <+> "logic" <+> ranges <+> tName <> "_to_lv" <> parens (sigDecl "i" ty) <> semi <> line <>+  indent 2+    ("for" <+> parens ("int n = 0" <> semi <+> "n <" <+> int (2^n) <> semi <+> "n=n+1") <> line <>+      indent 2 (tName <> "_to_lv" <> brackets "n" <+> "=" <+> "i[n]" <> semi)) <> line <>+  "endfunction" <> line <>+  "function" <+> "automatic" <+> tName <+> tName <> "_from_lv" <> parens ("logic" <+> ranges <+> "i") <> semi <> line <>+  indent 2+    ("for" <+> parens ("int n = 0" <> semi <+> "n <" <+> int (2^n) <> semi <+> "n=n+1") <> line <>+      indent 2 (tName <> "_from_lv" <> brackets "n" <+> "=" <+> "i[n]" <> semi)) <> line <>+  "endfunction" <> line <>+  (if n > 0+      then+        "function" <+> "automatic" <+> tName <+> tName <> "_br" <> parens (treeSigDecl "l" <> comma <> treeSigDecl "r") <> semi <> line <>+        indent 2+          (tName <> "_br" <> brackets (int 0 <> colon <> int (2^(n-1)-1)) <+> "=" <+> "l" <> semi <> line <>+           tName <> "_br" <> brackets (int (2^(n-1)) <> colon <> int (2^n-1)) <+> "=" <+> "r" <> semi) <> line <>+        "endfunction"+      else+        emptyDoc)+  where+    treeSigDecl :: SystemVerilogM Doc -> SystemVerilogM Doc+    treeSigDecl d = do+      syn <- Ap hdlSyn+      case syn of+        Vivado -> case splitVecTy (RTree (n-1) elTy) of+          Just ([Right n',Left n''],elTy') -> -- n' == 2 ^ (n-1)+            elTy' <+> brackets (int 0 <> colon <> int (n''-1)) <+>+            d <+> brackets (int 0 <> colon <> int (n' - 1))+          _ ->+            "logic" <+> brackets (int (typeSize elTy - 1) <> colon <> int 0) <+>+            d <+> brackets (int 0 <> colon <> int (2^(n-1)-1))+        _ -> case splitVecTy (RTree (n-1) elTy) of+          Just (Right n':ns,elTy') -> -- n' == 2 ^ (n-1)+            elTy' <+> hcat (mapM range ns) <+> d <+>+            brackets (int 0 <> colon <> int (n' - 1))+          _ -> error $ $(curLoc) ++ "impossible"++    tName  = tyName ty+    ranges = brackets (int 0 <> colon <> int (2^n-1)) <>+             brackets (int (typeSize elTy - 1) <> colon <> int 0)++funDec _ = pure Nothing++module_ :: Component -> SystemVerilogM Doc+module_ c =+  modVerilog <* Ap (imports .= [] >> oports .= [])+ where+  modVerilog = do+    body <- modBody+    imps <- Ap $ use imports+    libs <- Ap $ use libraries+    modHeader <> line <> modPorts <> line <> include (nub imps) <> uselibs (nub libs) <> pure body <> line <> modEnding++  modHeader  = "module" <+> pretty (componentName c)+  modPorts   = indent 4 (tupleInputs inPorts <> line <> tupleOutputs outPorts <> semi)+  modBody    = indent 2 (decls (declarations c)) <> line <> line <> indent 2 (insts (declarations c))+  modEnding  = "endmodule"++  inPorts  = sequence [ sigPort (Nothing,isBiSignalIn ty) (i,ty) Nothing | (i,ty)  <- inputs c  ]+  outPorts = sequence [ sigPort (Just u,False) p iEM | (u, p, iEM) <- outputs c ]++  -- NOTE [net types and data types]+  --+  -- SystemVerilog makes a distinction between the type of a net and the data+  -- type of a signal. For output ports / inout ports this is fine, as there+  -- is only one possible type. For input ports when using `default_nettype none+  -- we have to specify the net type as wire explicitly (or vendor tools will+  -- claim the net from the port declaration is implicitly defined).++  wr2ty (Nothing,isBidirectional)+    | isBidirectional+    = "inout" -- no net type here, it gets added by verilogType.+    | otherwise+    = "input wire" -- See NOTE [net types and data types]+  wr2ty (Just _,_)+    = "output"++  -- map a port to its verilog type, port name, and any encoding notes+  sigPort (wr2ty -> portTy) (nm, hwTy) iEM+    = addAttrs (hwTypeAttrs hwTy)+        (portTy <+> sigDecl (pretty nm) hwTy <> iE <+> encodingNote hwTy)+    where+      iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM+  -- slightly more readable than 'tupled', makes the output Haskell-y-er+  commafy v = (comma <> space) <> pure v++  tupleInputs v = v >>= \case+    []     -> lparen <+> string "// No inputs" <> line+    (x:xs) -> lparen <+> string "// Inputs"+                    <> line <> (string "  " <> pure x)+                    <> line <> vcat (forM xs commafy)+                    <> line++  tupleOutputs v = v >>= \case+    []     -> string "  // No outputs" <> line <> rparen+    (x:xs) -> string "  // Outputs"+                <> line <> (if (length (inputs c)) > 0+                       then comma <> space <> pure x+                       else string "  " <> pure x)+                <> (if null xs then emptyDoc else line <> vcat (forM xs commafy))+                <> line <> rparen++verilogType :: HWType -> SystemVerilogM Doc+verilogType t_ = do+  t <- normaliseType t_+  Ap (tyCache %= HashSet.insert t)+  let logicOrWire | isBiSignalIn t = "wire"+                  | otherwise      = "logic"+  pkgCtx <- Ap $ use tyPkgCtx+  nm <- Ap $ use modNm+  let pvrType = if pkgCtx+                then tyName t+                else stringS nm <> "_types::" <> tyName t+  case t of+    Product {}    -> pvrType+    Vector {}     -> pvrType+    RTree {}      -> pvrType+    Signed n      -> logicOrWire <+> "signed" <+> brackets (int (n-1) <> colon <> int 0)+    Clock _       -> "logic"+    ClockN _      -> "logic"+    Reset _       -> "logic"+    Enable _      -> "logic"+    Bit           -> "logic"+    Bool          -> "logic"+    String        -> "string"+    FileType      -> "integer"+    _ -> logicOrWire <+> brackets (int (typeSize t -1) <> colon <> int 0)++sigDecl :: SystemVerilogM Doc -> HWType -> SystemVerilogM Doc+sigDecl d t = verilogType t <+> d++-- | Convert a Netlist HWType to the root of a Verilog type+verilogTypeMark :: HWType -> SystemVerilogM Doc+verilogTypeMark t_ = do+  t <- normaliseType t_+  Ap (tyCache %= HashSet.insert t)+  pkgCtx <- Ap $ use tyPkgCtx+  nm <- Ap $ use modNm+  let pvrType = if pkgCtx+                then tyName t+                else stringS nm <> "_types::" <> tyName t+  case t of+    Product {} -> pvrType+    Vector {}  -> pvrType+    RTree {}   -> pvrType+    _ -> emptyDoc++tyName :: HWType -> SystemVerilogM Doc+tyName Bool                  = "logic"+tyName Bit                   = "logic"+tyName (Vector n elTy)       = "array_of_" <> int n <> "_" <> tyName elTy+tyName (MemBlob n m)         = tyName (Vector n (BitVector m))+tyName (RTree n elTy)        = "tree_of_" <> int n <> "_" <> tyName elTy+tyName (BitVector n)         = "logic_vector_" <> int n+tyName t@(Index _)           = "logic_vector_" <> int (typeSize t)+tyName (Signed n)            = "signed_" <> int n+tyName (Unsigned n)          = "logic_vector_" <> int n+tyName t@(Sum _ _)           = "logic_vector_" <> int (typeSize t)+tyName t@(CustomSum _ _ _ _) = "logic_vector_" <> int (typeSize t)+tyName t@(CustomSP _ _ _ _)  = "logic_vector_" <> int (typeSize t)+tyName t@(Product nm _ _)      = do+  tN <- normaliseType t+  PP.pretty =<< Ap (makeCached tN nameCache prodName)+ where+  prodName :: State SystemVerilogState Identifier+  prodName = Id.makeBasicOr (last (TextS.splitOn "." nm)) "product"++tyName t@(SP _ _) = "logic_vector_" <> int (typeSize t)+tyName (Clock _)  = "logic"+tyName (ClockN _) = "logic"+tyName (Reset _)  = "logic"+tyName (Enable _) = "logic"+tyName t =  error $ $(curLoc) ++ "tyName: " ++ show t++-- | Convert a Netlist HWType to an error SystemVerilog value for that type+verilogTypeErrValue :: HWType -> SystemVerilogM Doc+verilogTypeErrValue (Vector n elTy) = do+  syn <- Ap hdlSyn+  case syn of+    Vivado -> char '\'' <> braces (int n <+> braces (singularErrValue elTy))+    _ -> char '\'' <> braces (int n <+> braces (verilogTypeErrValue elTy))+verilogTypeErrValue (RTree n elTy) = do+  syn <- Ap hdlSyn+  case syn of+    Vivado -> char '\'' <> braces (int (2^n) <+> braces (singularErrValue elTy))+    _ -> char '\'' <> braces (int (2^n) <+> braces (verilogTypeErrValue elTy))+verilogTypeErrValue String = "\"ERROR\""+verilogTypeErrValue ty = singularErrValue ty++singularErrValue :: HWType -> SystemVerilogM Doc+singularErrValue ty = do+  udf <- Ap (use undefValue)+  case udf of+    Nothing       -> braces (int (typeSize ty) <+> braces "1'bx")+    Just Nothing  -> int (typeSize ty) <> "'d0 /* undefined */"+    Just (Just x) -> braces (int (typeSize ty) <+> braces ("1'b" <> int x)) <+> "/* undefined */"++verilogRecSel+  :: HWType+  -> Int+  -> SystemVerilogM Doc+verilogRecSel ty i = tyName ty <> "_sel" <> int i++decls :: [Declaration] -> SystemVerilogM Doc+decls [] = emptyDoc+decls ds = do+    dsDoc <- catMaybes A.<$> mapM decl ds+    case dsDoc of+      [] -> emptyDoc+      _  -> punctuate' semi (A.pure dsDoc)++decl :: Declaration -> SystemVerilogM (Maybe Doc)+decl (NetDecl' noteM id_ tyE iEM) =+  Just A.<$> maybe id addNote noteM (addAttrs attrs (typ tyE))+  where+    typ ty = sigDecl (pretty id_) ty <> iE+    addNote n = mappend ("//" <+> stringS n <> line)+    attrs = fromMaybe [] (hwTypeAttrs A.<$> Just tyE)+    iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM++decl _ = return Nothing++-- | Convert single attribute to systemverilog syntax+renderAttr :: Attr TextS.Text -> TextS.Text+renderAttr (StringAttr  key value) = TextS.concat [key, " = ", TextS.pack (show value)]+renderAttr (IntegerAttr key value) = TextS.concat [key, " = ", TextS.pack (show value)]+renderAttr (BoolAttr    key True ) = TextS.concat [key, " = ", "1"]+renderAttr (BoolAttr    key False) = TextS.concat [key, " = ", "0"]+renderAttr (Attr        key      ) = key++-- | Add attribute notation to given declaration+addAttrs+  :: [Attr TextS.Text]+  -> SystemVerilogM Doc+  -> SystemVerilogM Doc+addAttrs []     t = t+addAttrs attrs' t =+  "(*" <+> attrs'' <+> "*)" <+> t+    where+      attrs'' = stringS $ TextS.intercalate ", " (map renderAttr attrs')++insts :: [Declaration] -> SystemVerilogM Doc+insts [] = emptyDoc+insts (TickDecl (Comment c):ds) = comment "//" c <> line <> insts ds+insts (TickDecl (Directive d):ds) = pretty d <> ";" <> line <> insts ds+insts (d:ds) = do+  docM <- inst_ d+  case docM of+    Nothing -> insts ds+    Just doc -> pure doc <> line <> line <> insts ds++stdMatch+  :: Bits a+  => Int+  -> a+  -> a+  -> String+stdMatch 0 _mask _value = []+stdMatch size mask value =+  symbol : stdMatch (size - 1) mask value+  where+    symbol =+      if testBit mask (size - 1) then+        if testBit value (size - 1) then+          '1'+        else+          '0'+      else+        '?'++patLitCustom'+  :: Int+  -> ConstrRepr'+  -> SystemVerilogM Doc+patLitCustom' size (ConstrRepr' _name _n mask value _anns) =+  int size <> squote <> "b" <> (string $ Text.pack $ stdMatch size mask value)++patLitCustom+  :: HWType+  -> Literal+  -> SystemVerilogM Doc+patLitCustom (CustomSum _name _dataRepr size reprs) (NumLit (fromIntegral -> i)) =+  patLitCustom' size (fst $ reprs !! i)++patLitCustom (CustomSP _name _dataRepr size reprs) (NumLit (fromIntegral -> i)) =+  let (cRepr, _id, _tys) = reprs !! i in+  patLitCustom' size cRepr++patLitCustom x y = error $ $(curLoc) ++ unwords+  [ "You can only pass CustomSP / CustomSum / CustomProduct and a NumLit to"+  , "this function, not", show x, "and", show y]++patMod :: HWType -> Literal -> Literal+patMod hwTy (NumLit i) = NumLit (i `mod` (2 ^ typeSize hwTy))+patMod _ l = l++-- | Helper function for inst_, handling CustomSP and CustomSum+inst_' :: Identifier -> Expr -> HWType -> [(Maybe Literal, Expr)] -> SystemVerilogM (Maybe Doc)+inst_' id_ scrut scrutTy es = fmap Just $+  "always_comb begin" <> line <> indent 2 casez <> line <> "end"+    where+      casez =+        "casez" <+> parens var <> line <>+          indent 2 (conds esNub) <> line <>+        "endcase"++      esMod = map (first (fmap (patMod scrutTy))) es+      esNub = nubBy ((==) `on` fst) esMod+      var   = expr_ True scrut++      conds :: [(Maybe Literal,Expr)] -> SystemVerilogM Doc+      conds []                = error $ $(curLoc) ++ "Empty list of conditions invalid."+      conds [(_,e)]           = "default" <+> ":" <+> pretty id_ <+> "=" <+> expr_ False e <> ";"+      conds ((Nothing,e):_)   = "default" <+> ":" <+> pretty id_ <+> "=" <+> expr_ False e <> ";"+      conds ((Just c ,e):es') =+        mask' <+> ":" <+> pretty id_ <+> "=" <+> expr_ False e <> ";" <> line <> conds es'+          where+            mask' = patLitCustom scrutTy c++-- | Turn a Netlist Declaration to a SystemVerilog concurrent block+inst_ :: Declaration -> SystemVerilogM (Maybe Doc)+inst_ (TickDecl {}) = return Nothing++inst_ (CompDecl {}) = return Nothing++inst_ (Assignment id_ Cont e) = fmap Just $+  "assign" <+> pretty id_ <+> equals <+> align (expr_ False e <> semi)++inst_ (CondAssignment id_ ty scrut _ [(Just (BoolLit b), l),(_,r)]) = fmap Just $ do+    { syn <- Ap hdlSyn+    ; p   <- Ap $ use oports+    ; if syn == Vivado && id_ `elem` p+         then do+              { regId <- Id.suffix id_ "reg"+              ; verilogType ty <+> pretty regId <> semi <> line <>+                "always_comb begin" <> line <>+                indent 2 ("if" <> parens (expr_ True scrut) <> line <>+                            (indent 2 $ pretty regId <+> equals <+> expr_ False t <> semi) <> line <>+                         "else" <> line <>+                            (indent 2 $ pretty regId <+> equals <+> expr_ False f <> semi)) <> line <>+                "end" <> line <>+                "assign" <+> pretty id_ <+> equals <+> pretty regId <> semi+              }+         else "always_comb begin" <> line <>+              indent 2 ("if" <> parens (expr_ True scrut) <> line <>+                          (indent 2 $ pretty id_ <+> equals <+> expr_ False t <> semi) <> line <>+                       "else" <> line <>+                          (indent 2 $ pretty id_ <+> equals <+> expr_ False f <> semi)) <> line <>+              "end"+    }+  where+    (t,f) = if b then (l,r) else (r,l)++inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSP {}) es) =+  inst_' id_ scrut scrutTy es++inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSum {}) es) =+  inst_' id_ scrut scrutTy es++inst_ (CondAssignment id_ _ scrut scrutTy@(CustomProduct {}) es) =+  inst_' id_ scrut scrutTy es++inst_ (CondAssignment id_ ty scrut scrutTy es) = fmap Just $ do+    { syn <- Ap hdlSyn+    ; p <- Ap $ use oports+    ; if syn == Vivado && id_ `elem` p+         then do+           { regId <- Id.suffix id_ "reg"+           ; verilogType ty <+> pretty regId <> semi <> line <>+             "always_comb begin" <> line <>+             indent 2 ("case" <> parens (expr_ True scrut) <> line <>+                         (indent 2 $ vcat $ punctuate semi (conds regId es)) <> semi <> line <>+                       "endcase") <> line <>+             "end" <> line <>+             "assign" <+> pretty id_ <+> equals <+> pretty regId <> semi+           }+         else "always_comb begin" <> line <>+              indent 2 ("case" <> parens (expr_ True scrut) <> line <>+                          (indent 2 $ vcat $ punctuate semi (conds id_ es)) <> semi <> line <>+                        "endcase") <> line <>+              "end"+    }+  where+    conds :: Identifier -> [(Maybe Literal,Expr)] -> SystemVerilogM [Doc]+    conds _ []                = return []+    conds i [(_,e)]           = ("default" <+> colon <+> pretty i <+> equals <+> expr_ False e) <:> return []+    conds i ((Nothing,e):_)   = ("default" <+> colon <+> pretty i <+> equals <+> expr_ False e) <:> return []+    conds i ((Just c ,e):es') = (exprLitSV (Just (scrutTy,conSize scrutTy)) c <+> colon <+> pretty i <+> equals <+> expr_ False e) <:> conds i es'++inst_ (InstDecl _ _ attrs nm lbl ps pms0) = fmap Just $+    attrs' <> nest 2 (pretty nm <> params <> pretty lbl <> line <> pms2 <> semi)+  where+    pms2 = case pms0 of+      NamedPortMap pms1 ->+        let pm i e = dot <> expr_ False i <+> parens (expr_ False e) in+        tupled $ sequence [pm i e | (i,_,_,e) <- pms1]+      IndexedPortMap pms1 ->+        tupled $ sequence [expr_ False e | (_,_,e) <- pms1]++    params+      | null ps   = space+      | otherwise = line <> "#" <> tupled (sequence [dot <> expr_ False i <+> parens (expr_ False e) | (i,_,e) <- ps]) <> line+    attrs'+      | null attrs = emptyDoc+      | otherwise  = addAttrs attrs line++inst_ (BlackBoxD _ libs imps inc bs bbCtx) =+  fmap Just (Ap (column (renderBlackBox libs imps inc bs bbCtx)))++inst_ (Seq ds) = Just <$> seqs ds++inst_ (NetDecl' {}) = return Nothing++inst_ (ConditionalDecl cond ds) = Just <$>+  "`ifdef" <+> pretty cond <> line <> indent 2 (insts ds) <> line <> "`endif"++inst_ d =+  error ("inst_: " ++ show d)++-- | Render a data constructor application for data constructors having a+-- custom bit representation.+customReprDataCon+  :: DataRepr'+  -- ^ Custom representation of data type+  -> ConstrRepr'+  -- ^ Custom representation of a specific constructor of @dataRepr@+  -> [(HWType, Expr)]+  -- ^ Arguments applied to constructor+  -> SystemVerilogM Doc+customReprDataCon dataRepr constrRepr args =+  braces $ hcat $ punctuate ", " $ mapM range' origins+    where+      size = drSize dataRepr++      -- Build bit representations for all constructor arguments+      argExprs = map (uncurry toSLV) args :: [SystemVerilogM Doc]++      -- Spread bits of constructor arguments using masks+      origins = bitOrigins dataRepr constrRepr :: [BitOrigin]++      range'+        :: BitOrigin+        -> SystemVerilogM Doc+      range' (Lit (bitsToBits -> ns)) =+        int (length ns) <> squote <> "b" <> hcat (mapM (bit_char undefValue) ns)+      range' (Field n start end) =+        -- We want to select the bits starting from 'start' downto and including+        -- 'end'. We cannot use slice notation in Verilog, as the preceding+        -- expression might not be an identifier.+        let fsize = start - end + 1 in+        let expr' = argExprs !! n in++        if | fsize == size ->+               -- If sizes are equal, rotating / resizing amounts to doing nothing+               expr'+           | end == 0 ->+               -- Rotating is not necessary if relevant bits are already at the end+               int fsize <> squote <> parens expr'+           | otherwise ->+               -- Select bits 'start' downto and including 'end'+               let rotated  = parens expr' <+> ">>" <+> int end in+               int fsize <> squote <> parens rotated++seq_ :: Seq -> SystemVerilogM Doc+seq_ (AlwaysClocked edge clk ds) =+  "always @" <>+    parens (case edge of {Rising -> "posedge"; _ -> "negedge"} <+>+            expr_ False clk) <+> "begin" <> line <>+    indent 2 (seqs ds) <> line <>+  "end"++seq_ (Initial ds) =+  "initial begin" <> line <>+  indent 2 (seqs ds) <> line <>+  "end"++seq_ (AlwaysComb ds) =+  "always @* begin" <> line <>+  indent 2 (seqs ds) <> line <>+  "end"++seq_ (Branch scrut scrutTy es) =+    "case" <> parens (expr_ True scrut) <> line <>+      (indent 2 $ vcat $ conds es) <> line <>+    "endcase"+   where+        conds :: [(Maybe Literal,[Seq])] -> SystemVerilogM [Doc]+        conds [] =+          return []+        conds [(_,sq)] =+          ("default" <+> colon <+> "begin" <> line <>+            indent 2 (seqs sq) <> line <>+          "end") <:> return []+        conds ((Nothing,sq):_) =+          ("default" <+> colon <+> "begin" <> line <>+            indent 2 (seqs sq) <> line <>+          "end") <:> return []+        conds ((Just c ,sq):es') =+          (exprLitSV (Just (scrutTy,conSize scrutTy)) c <+> colon <+> "begin" <> line <>+            indent 2 (seqs sq) <> line <>+          "end") <:> conds es'++seq_ (SeqDecl sd) = case sd of+  Assignment id_ (Proc b) e ->+    let sym = case b of { Blocking -> equals; NonBlocking -> "<=" }+     in pretty id_ <+> sym <+> expr_ False e <> semi++  BlackBoxD {} ->+    fromMaybe <$> emptyDoc <*> inst_ sd++  Seq ds ->+    seqs ds++  _ -> error (show sd)++seqs :: [Seq] -> SystemVerilogM Doc+seqs [] = emptyDoc+seqs (SeqDecl (TickDecl (Comment c)):ds) = comment "//" c <> line <> seqs ds+seqs (SeqDecl (TickDecl (Directive d)):ds) = pretty d <> ";" <> line <> seqs ds+seqs (d:ds) = seq_ d <> line <> line <> seqs ds++-- | Turn a Netlist expression into a SystemVerilog expression+expr_ :: Bool -- ^ Enclose in parentheses?+      -> Expr -- ^ Expr to convert+      -> SystemVerilogM Doc+expr_ _ (Literal sizeM lit) = exprLitSV sizeM lit+expr_ _ (Identifier id_ Nothing) = pretty id_+expr_ _ (Identifier id_ (Just (Indexed (CustomSP _id dataRepr _size args,dcI,fI)))) =+  case fieldTy of+    Void {} ->+      error (unexpectedProjectionErrorMsg dataRepr dcI fI)+    _ ->+      expFromSLV fieldTy (braces $ hcat $ punctuate ", " $ sequence ranges)+ where+  (ConstrRepr' _name _n _mask _value anns, _, fieldTypes) = args !! dcI+  ranges = map range' $ bitRanges (anns !! fI)+  range' (start, end) = pretty id_ <> brackets (int start <> ":" <> int end)+  fieldTy = indexNote ($(curLoc) ++ "panic") fieldTypes fI++expr_ _ (Identifier id_ (Just (Indexed (CustomProduct _id dataRepr _size _maybeFieldNames args,dcI,fI)))) =+  case fieldTy of+    Void {} ->+      error (unexpectedProjectionErrorMsg dataRepr dcI fI)+    _ ->+      expFromSLV fieldTy (braces $ hcat $ punctuate ", " $ sequence ranges)+ where+  (anns, fieldTypes) = unzip args+  ranges = map range' $ bitRanges (anns !! fI)+  range' (start, end) = pretty id_ <> brackets (int start <> ":" <> int end)+  fieldTy = indexNote ($(curLoc) ++ "panic") fieldTypes fI++expr_ _ (Identifier id_ (Just (Indexed (ty@(SP _ args),dcI,fI)))) =+    fromSLV argTy (Id.toText id_) start end+  where+    argTys   = snd $ args !! dcI+    argTy    = argTys !! fI+    argSize  = typeSize argTy+    other    = otherSize argTys (fI-1)+    start    = typeSize ty - 1 - conSize ty - other+    end      = start - argSize + 1++expr_ _ (Identifier id_ (Just (Indexed (ty@(Product _ _ tys),_,fI)))) = do+  id'<- fmap (Text.toStrict . renderOneLine) (pretty id_ <> dot <> tyName ty <> "_sel" <> int fI)+  simpleFromSLV (tys !! fI) id'++expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),1,0)))) = do+  id' <- fmap (Text.toStrict . renderOneLine) (pretty id_ <> brackets (int 0))+  simpleFromSLV elTy id'++expr_ _ (Identifier id_ (Just (Indexed ((Vector n _),1,1)))) = pretty id_ <> brackets (int 1 <> colon <> int (n-1))++-- This is a "Hack", we cannot construct trees with a negative depth. This is+-- here so that we can recognise merged RTree modifiers. See the code in+-- @Clash.Backend.nestM@ which construct these tree modifiers.+expr_ _ (Identifier id_ (Just (Indexed (RTree (-1) _,l,r)))) =+  pretty id_ <> brackets (int l <> colon <> int (r-1))++expr_ _ (Identifier id_ (Just (Indexed ((RTree 0 elTy),0,0)))) = do+  id' <- fmap (Text.toStrict . renderOneLine) (pretty id_ <> brackets (int 0))+  simpleFromSLV elTy id'++expr_ _ (Identifier id_ (Just (Indexed ((RTree n _),1,0)))) =+  let z = 2^(n-1)+  in  pretty id_ <> brackets (int 0 <> colon <> int (z-1))++expr_ _ (Identifier id_ (Just (Indexed ((RTree n _),1,1)))) =+  let z  = 2^(n-1)+      z' = 2^n+  in pretty id_ <> brackets (int z <> colon <> int (z'-1))++-- This is a HACK for Clash.Netlist.Util.mkTopOutput+-- Vector's don't have a 10'th constructor, this is just so that we can+-- recognize the particular case+expr_ _ (Identifier id_ (Just (Indexed ((Vector _ elTy),10,fI)))) = do+  id' <- fmap (Text.toStrict . renderOneLine) (pretty id_ <> brackets (int fI))+  simpleFromSLV elTy id'++-- This is a HACK for Clash.Netlist.Util.mkTopOutput+-- RTree's don't have a 10'th constructor, this is just so that we can+-- recognize the particular case+expr_ _ (Identifier id_ (Just (Indexed ((RTree _ elTy),10,fI)))) = do+  id' <- fmap (Text.toStrict . renderOneLine) (pretty id_ <> brackets (int fI))+  simpleFromSLV elTy id'++expr_ _ (Identifier id_ (Just (DC (ty@(SP _ _),_)))) = pretty id_ <> brackets (int start <> colon <> int end)+  where+    start = typeSize ty - 1+    end   = typeSize ty - conSize ty++expr_ _ (Identifier id_ (Just m@Nested {})) = case modifier 0 [] m of+  Nothing -> pretty id_+  Just (mods,resTy) -> do+    nm <- Ap $ use modNm+    pkgCtx <- Ap $ use tyPkgCtx+    let prefix = if pkgCtx then emptyDoc else stringS nm <> "_types::"+    let e = pretty id_ <> hcat (mapM (either bracketNMod bracketNMod) (reverse mods))+    case resTy of+      Signed _ -> "$signed" <> parens e+      Vector {}+        | Left (NRange {}):_ <- mods+        -> e+        | otherwise  -> do+        Ap (tyCache %= HashSet.insert resTy)+        prefix <> tyName resTy <> "_from_lv" <> parens e+      RTree {}+        | Left (NRange {}):_ <- mods+        -> e+        | otherwise -> do+        Ap (tyCache %= HashSet.insert resTy)+        prefix <> tyName resTy <> "_from_lv" <> parens e+      _ -> e+ where+  bracketNMod (NElem i)    = brackets (int i)+  bracketNMod (NRange s e) = brackets (int s <> colon <> int e)++-- See [Note] integer projection+expr_ _ (Identifier id_ (Just (Indexed ((Signed w),_,_))))  = do+  iw <- Ap $ use intWidth+  traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $+    pretty id_++-- See [Note] integer projection+expr_ _ (Identifier id_ (Just (Indexed ((Unsigned w),_,_))))  = do+  iw <- Ap $ use intWidth+  traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $+    pretty id_++-- See [Note] mask projection+expr_ _ (Identifier _ (Just (Indexed ((BitVector _),_,0)))) = do+  iw <- Ap $ use intWidth+  traceIf True ($(curLoc) ++ "WARNING: synthesizing bitvector mask to dontcare") $+    verilogTypeErrValue (Unsigned iw)++-- See [Note] bitvector projection+expr_ _ (Identifier id_ (Just (Indexed ((BitVector w),_,1)))) = do+  iw <- Ap $ use intWidth+  traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $+    pretty id_++expr_ _ (Identifier id_ (Just (Sliced ((BitVector _,start,end))))) =+  pretty id_ <> brackets (int start <> ":" <> int end)++expr_ _ (Identifier id_ (Just _)) = pretty id_++expr_ b (DataCon _ (DC (Void {}, -1)) [e]) =  expr_ b e++expr_ _ (DataCon ty@(Vector 0 _) _ _) = verilogTypeErrValue ty++expr_ _ (DataCon (Vector 1 elTy) _ [e]) = "'" <> braces (int 0 <> colon <+> toSLV elTy e)++expr_ _ e@(DataCon ty@(Vector _ elTy) _ [e1,e2]) = case vectorChain e of+  Just es -> "'" <> listBraces (zipWithM (\i e3 -> int i <> colon <+> toSLV elTy e3) [0..] es)+  Nothing -> verilogTypeMark ty <> "_cons" <> parens (expr_ False e1 <> comma <+> expr_ False e2)++expr_ _ (DataCon (MemBlob n m) _ [n0, m0, _, runs, _, ends])+  | Literal _ (NumLit n1) <- n0+  , n == fromInteger n1+  , Literal _ (NumLit m1) <- m0+  , m == fromInteger m1+  , Literal Nothing (StringLit runs0) <- runs+  , Literal Nothing (StringLit ends0) <- ends+  , es <- unpackNats n m (B8.pack runs0) (B8.pack ends0) =+    let el val = exprLitSV (Just (BitVector m, m))+                           (BitVecLit 0 $ toInteger val)+    in "'" <> listBraces (mapM el es)++expr_ _ (DataCon (RTree 0 elTy) _ [e]) = "'" <> braces (toSLV elTy e)++expr_ _ e@(DataCon ty@(RTree _ elTy) _ [e1,e2]) = case rtreeChain e of+  Just es -> "'" <> listBraces (mapM (toSLV elTy) es)+  Nothing -> verilogTypeMark ty <> "_br" <> parens (expr_ False e1 <> comma <+> expr_ False e2)++expr_ _ (DataCon (SP {}) (DC (BitVector _,_)) es) = assignExpr+  where+    argExprs   = map (expr_ False) es+    assignExpr = braces (hcat $ punctuate comma $ sequence argExprs)++expr_ _ (DataCon ty@(SP _ args) (DC (_,i)) es) = assignExpr+  where+    argTys     = snd $ args !! i+    dcSize     = conSize ty + sum (map typeSize argTys)+    dcExpr     = expr_ False (dcToExpr ty i)+    argExprs   = zipWith toSLV argTys es+    extraArg   = case typeSize ty - dcSize of+                   0 -> []+                   n -> [int n <> "'b" <> bits undefValue (replicate n U)]+    assignExpr = braces (hcat $ punctuate comma $ sequence (dcExpr:argExprs ++ extraArg))++expr_ _ (DataCon ty@(Sum _ _) (DC (_,i)) []) = int (typeSize ty) <> "'d" <> int i+expr_ _ (DataCon ty@(CustomSum _ _ _ tys) (DC (_,i)) []) =+  let (ConstrRepr' _ _ _ value _) = fst $ tys !! i in+  int (typeSize ty) <> squote <> "d" <> int (fromIntegral value)+expr_ _ (DataCon (CustomSP _ dataRepr _size args) (DC (_,i)) es) =+  let (cRepr, _, argTys) = args !! i in+  customReprDataCon dataRepr cRepr (zipEqual argTys es)+expr_ _ (DataCon (CustomProduct _ dataRepr _size _labels tys) _ es) |+  DataRepr' _typ _size [cRepr] <- dataRepr =+  customReprDataCon dataRepr cRepr (zipEqual (map snd tys) es)++expr_ _ (DataCon (Product _ _ tys) _ es) = listBraces (zipWithM toSLV tys es)++expr_ _ (DataCon (Enable _) _ [e]) =+  expr_ False e++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.Signed.fromInteger#"+  , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx+  = exprLitSV (Just (Signed (fromInteger n),fromInteger n)) i++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.Unsigned.fromInteger#"+  , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx+  = exprLitSV (Just (Unsigned (fromInteger n),fromInteger n)) i++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.BitVector.fromInteger#"+  , [Literal _ (NumLit n), Literal _ (NumLit m), Literal _ (NumLit i)] <- extractLiterals bbCtx+  = exprLitSV (Just (BitVector (fromInteger n),fromInteger n)) (BitVecLit m i)++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.BitVector.fromInteger##"+  , [Literal _ m, Literal _ i] <- extractLiterals bbCtx+  , NumLit m' <- m+  , NumLit i' <- i+  = exprLitSV (Just (Bit,1)) (BitLit $ toBit m' i')++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.Index.fromInteger#"+  , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx+  , Just k <- clogBase 2 n+  , let k' = max 1 k+  = exprLitSV (Just (Index (fromInteger n),k')) i++expr_ b (BlackBoxE _ libs imps inc bs bbCtx b') =+  parenIf (b || b') (Ap (renderBlackBox libs imps inc bs bbCtx <*> pure 0))++expr_ _ (DataTag Bool (Left id_))          = pretty id_ <> brackets (int 0)+expr_ _ (DataTag Bool (Right id_))         = do+  iw <- Ap $ use intWidth+  "$unsigned" <> parens (listBraces (sequence [braces (int (iw-1) <+> braces "1'b0"),pretty id_]))++expr_ _ (DataTag (Sum _ _) (Left id_))     = "$unsigned" <> parens (pretty id_)+expr_ _ (DataTag (Sum _ _) (Right id_))    = "$unsigned" <> parens (pretty id_)++expr_ _ (DataTag (Product {}) (Right _))  = do+  iw <- Ap $ use intWidth+  int iw <> "'sd0"++expr_ _ (DataTag hty@(SP _ _) (Right id_)) = "$unsigned" <> parens+                                               (pretty id_ <> brackets+                                               (int start <> colon <> int end))+  where+    start = typeSize hty - 1+    end   = typeSize hty - conSize hty++expr_ _ (DataTag (Vector 0 _) (Right _)) = do+  iw <- Ap $ use intWidth+  int iw <> "'sd0"+expr_ _ (DataTag (Vector _ _) (Right _)) = do+  iw <- Ap $ use intWidth+  int iw <> "'sd1"++expr_ _ (DataTag (RTree 0 _) (Right _)) = do+  iw <- Ap $ use intWidth+  int iw <> "'sd0"+expr_ _ (DataTag (RTree _ _) (Right _)) = do+  iw <- Ap $ use intWidth+  int iw <> "'sd1"++expr_ b (ToBv topM t e) = do+  nm <- Ap $ use modNm+  pkgCtx <- Ap $ use tyPkgCtx+  let prefix = if pkgCtx then emptyDoc else stringS nm <> "_types::"+  case t of+    Vector {} -> do+      Ap (tyCache %= HashSet.insert t)+      maybe prefix ((<> "_types::") . pretty) topM <>+        tyName t <> "_to_lv" <> parens (expr_ False e)+    RTree {} -> do+      Ap (tyCache %= HashSet.insert t)+      maybe prefix ((<> "_types::") . pretty) topM <>+        tyName t <> "_to_lv" <> parens (expr_ False e)+    _ -> expr b e++expr_ b (FromBv topM t e) = do+  nm <- Ap $ use modNm+  pkgCtx <- Ap $ use tyPkgCtx+  let prefix = if pkgCtx then emptyDoc else stringS nm <> "_types::"+  case t of+    Vector {} -> do+      Ap (tyCache %= HashSet.insert t)+      maybe prefix ((<> "_types::") . pretty) topM <>+        tyName t <> "_from_lv" <> parens (expr_ False e)+    RTree {} -> do+      Ap (tyCache %= HashSet.insert t)+      maybe prefix ((<> "_types::") . pretty) topM <>+        tyName t <> "_from_lv" <> parens (expr_ False e)+    _ -> expr b e++expr_ b (IfThenElse c t e) =+  parenIf b (expr_ True c <+> "?" <+> expr_ True t <+> ":" <+> expr_ True e)++expr_ _ e = error $ $(curLoc) ++ (show e) -- empty++exprLitSV :: Maybe (HWType,Size) -> Literal -> SystemVerilogM Doc+exprLitSV = exprLit undefValue++otherSize :: [HWType] -> Int -> Int+otherSize _ n | n < 0 = 0+otherSize []     _    = 0+otherSize (a:as) n    = typeSize a + otherSize as (n-1)++vectorChain :: Expr -> Maybe [Expr]+vectorChain (DataCon (Vector 0 _) _ _)        = Just []+vectorChain (DataCon (Vector 1 _) _ [e])     = Just [e]+vectorChain (DataCon (Vector _ _) _ [e1,e2]) = Just e1 <:> vectorChain e2+vectorChain _                                       = Nothing++rtreeChain :: Expr -> Maybe [Expr]+rtreeChain (DataCon (RTree 0 _) _ [e])     = Just [e]+rtreeChain (DataCon (RTree _ _) _ [e1,e2]) = A.liftA2 (++) (rtreeChain e1)+                                                           (rtreeChain e2)+rtreeChain _                               = Nothing++toSLV :: HWType -> Expr -> SystemVerilogM Doc+toSLV t e = case t of+  Vector _ _ -> braces (verilogTypeMark t <> "_to_lv" <> parens (expr_ False e))+  RTree _ _ -> braces (verilogTypeMark t <> "_to_lv" <> parens (expr_ False e))+  MemBlob n m -> toSLV (Vector n (BitVector m)) e+  _ -> expr_ False e++fromSLV :: HWType -> IdentifierText -> Int -> Int -> SystemVerilogM Doc+fromSLV t@(Vector _ _) id_ start end = verilogTypeMark t <> "_from_lv" <> parens (pretty id_ <> brackets (int start <> colon <> int end))+fromSLV t@(RTree _ _) id_ start end = verilogTypeMark t <> "_from_lv" <> parens (pretty id_ <> brackets (int start <> colon <> int end))+fromSLV (Signed _) id_ start end = "$signed" <> parens (pretty id_ <> brackets (int start <> colon <> int end))+fromSLV (MemBlob n m) id_ start end = fromSLV (Vector n (BitVector m)) id_ start end+fromSLV _ id_ start end = pretty id_ <> brackets (int start <> colon <> int end)++simpleFromSLV :: HWType -> IdentifierText -> SystemVerilogM Doc+simpleFromSLV t@(Vector _ _) id_ = verilogTypeMark t <> "_from_lv" <> parens (pretty id_)+simpleFromSLV t@(RTree _ _) id_ = verilogTypeMark t <> "_from_lv" <> parens (pretty id_)+simpleFromSLV (Signed _) id_ = "$signed" <> parens (pretty id_)+simpleFromSLV (MemBlob n m) id_ = simpleFromSLV (Vector n (BitVector m)) id_+simpleFromSLV _ id_ = pretty id_++expFromSLV :: HWType -> SystemVerilogM Doc -> SystemVerilogM Doc+expFromSLV t@(Vector _ _) exp_ = verilogTypeMark t <> "_from_lv" <> parens exp_+expFromSLV t@(RTree _ _) exp_ = verilogTypeMark t <> "_from_lv" <> parens exp_+expFromSLV (Signed _) exp_ = "$signed" <> parens exp_+expFromSLV _ exp_ = exp_++dcToExpr :: HWType -> Int -> Expr+dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i))++listBraces :: Monad m => m [Doc] -> m Doc+listBraces = align . encloseSep lbrace rbrace comma++parenIf :: Monad m => Bool -> m Doc -> m Doc+parenIf True  = parens+parenIf False = id++punctuate' :: Monad m => Ap m Doc -> Ap m [Doc] -> Ap m Doc+punctuate' s d = vcat (punctuate s d) <> s+++data NMod+  = NRange Int Int+  | NElem Int++-- | Calculate the beginning and end index into a variable, to get the+-- desired field. Also returns the HWType of the result.+--+-- NB: returns a list of slices and indices when selections are into vectors and+-- rtrees. Left -> index/slice from an unpacked array; Right -> slice from a+-- packed type+modifier+  :: Int+  -- ^ Offset, only used when we have nested modifiers+  -> [Either NMod NMod]+  -- ^ Ranges selected so far+  -> Modifier+  -> Maybe ([Either NMod NMod],HWType)+modifier offset mods (Sliced (BitVector _,start,end)) =+  let m = Right (NRange (start+offset) (end+offset)) in+  case mods of+    Right {}:rest -> Just (m:rest, BitVector (start-end+1))+    _ -> Just (m:mods, BitVector (start-end+1))++modifier offset mods (Indexed (ty@(SP _ args),dcI,fI)) =+  case mods of+    Right {}:rest -> Just (m:rest, argTy)+    _ -> Just (m:mods,argTy)+  where+    argTys   = snd $ args !! dcI+    argTy    = argTys !! fI+    argSize  = typeSize argTy+    other    = otherSize argTys (fI-1)+    start    = typeSize ty - 1 - conSize ty - other+    end      = start - argSize + 1+    m        = Right (NRange (start+offset) (end+offset))++modifier offset mods (Indexed (ty@(Product _ _ argTys),_,fI)) =+  let m = Right (NRange (start+offset) (end+offset)) in+  case mods of+    Right {}:rest -> Just (m:rest, argTy)+    _ -> Just (m:mods,argTy)+  where+    argTy   = argTys !! fI+    argSize = typeSize argTy+    otherSz = otherSize argTys (fI - 1)+    start   = typeSize ty - 1 - otherSz+    end     = start - argSize + 1++modifier offset mods (Indexed (ty@(Vector _ argTy),1,0)) = case mods of+    Right {}:rest -> Just (Right (NRange (start+offset) (end+offset)):rest, argTy)+    Left (NRange b _):rest -> Just (Left (NElem b):rest,argTy)+    _ -> Just (Left (NElem 0):mods,argTy)+  where+    argSize = typeSize argTy+    start   = typeSize ty - 1+    end     = start - argSize + 1++modifier offset mods (Indexed (ty@(Vector n argTy),1,1)) = case mods of+    Right {}:rest -> Just (Right (NRange (start+offset) offset):rest, Vector (n-1) argTy)+    Left (NRange b e):rest -> Just (Left (NRange (b+1) e):rest, Vector (n-1) argTy)+    _ -> Just (Left (NRange 1 (n-1)):mods, Vector (n-1) argTy)+  where+    argSize = typeSize argTy+    start   = typeSize ty - argSize - 1++modifier offset mods (Indexed (ty@(RTree 0 argTy),0,0)) = case mods of+    Right {}:rest -> Just (Right (NRange (start+offset) offset):rest, argTy)+    Left (NRange b _):rest -> Just (Left (NElem b):rest,argTy)+    _ -> Just (Left (NElem 0):mods,argTy)+  where+    start   = typeSize ty - 1++modifier offset mods (Indexed (ty@(RTree d argTy),1,0)) = case mods of+    Right {}:rest -> Just (Right (NRange (start+offset) (end+offset)):rest, RTree (d-1) argTy)+    Left (NRange b _):rest -> Just (Left (NRange b (b+lhsSz-1)):rest,RTree (d-1) argTy)+    _ -> Just (Left (NRange 0 (lhsSz-1)):mods,RTree (d-1) argTy)+  where+    start   = typeSize ty - 1+    end     = typeSize ty `div` 2+    lhsSz   = (d-1)^(2 :: Int)++modifier offset mods (Indexed (ty@(RTree d argTy),1,1)) = case mods of+    Right {}:rest -> Just (Right (NRange (start+offset) offset):rest, RTree  (d-1) argTy)+    Left (NRange _ e):rest -> Just (Left (NRange (e+1-rhsS) e):rest,RTree (d-1) argTy)+    _ -> Just (Left (NRange rhsS rhsE):mods,RTree (d-1) argTy)+  where+    start   = (typeSize ty `div` 2) - 1+    rhsS    = (d-1)^(2 :: Int)+    rhsE    = d^(2 :: Int)-1++-- This is a HACK for Clash.Netlist.Util.mkTopOutput+-- Vector's don't have a 10'th constructor, this is just so that we can+-- recognize the particular case+modifier offset mods (Indexed (ty@(Vector _ argTy),10,fI)) = case mods of+    Right {}:rest -> Just (Right (NRange (start+offset) (end+offset)):rest, argTy)+    Left (NRange b _):rest -> Just (Left (NElem (fI+b)):rest, argTy)+    _ -> Just (Left (NElem fI):mods,argTy)+  where+    argSize = typeSize argTy+    start   = typeSize ty - (fI * argSize) - 1+    end     = start - argSize + 1++-- This is a HACK for Clash.Netlist.Util.mkTopOutput+-- RTree's don't have a 10'th constructor, this is just so that we can+-- recognize the particular case+modifier offset mods (Indexed (ty@(RTree _ argTy),10,fI)) = case mods of+    Right {}:rest -> Just (Right (NRange (start+offset) (end+offset)):rest, argTy)+    Left (NRange b _):rest -> Just (Left (NElem (b+fI)):rest, argTy)+    _ -> Just (Left (NElem fI):mods, argTy)+  where+    argSize = typeSize argTy+    start   = typeSize ty - (fI * argSize) - 1+    end     = start - argSize + 1++modifier offset mods (Indexed (CustomSP typName _dataRepr _size args,dcI,fI)) =+  case bitRanges (anns !! fI) of+    [(start,end)] ->+      let m = Right (NRange (start+offset) (end+offset)) in+      case mods of+        Right {}:rest -> Just (m:rest, argTy)+        _ -> Just (m:mods, argTy)+    _ ->+      error $ $(curLoc) ++ "Cannot handle projection out of a "+           ++ "non-contiguously or zero-width encoded field. Tried to project "+           ++ "field " ++ show fI ++ " of constructor " ++ show dcI ++ " of "+           ++ "data type " ++ show typName ++  "."+ where+  (ConstrRepr' _name _n _mask _value anns, _, argTys) = args !! dcI+  argTy = argTys !! fI++modifier offset mods (Indexed (CustomProduct typName dataRepr _size _maybeFieldNames args,dcI,fI))+  | DataRepr' _typ _size [cRepr] <- dataRepr+  , ConstrRepr' _cName _pos _mask _val fieldAnns <- cRepr =+  case bitRanges (fieldAnns !! fI) of+    [(start,end)] ->+      let m = Right (NRange (start+offset) (end+offset)) in+      case mods of+        Right {}:rest -> Just (m:rest, argTy)+        _ -> Just (m:mods,argTy)+    _ ->+      error $ $(curLoc) ++ "Cannot handle projection out of a "+           ++ "non-contiguously or zero-width encoded field. Tried to project "+           ++ "field " ++ show fI ++ " of constructor " ++ show dcI ++ " of "+           ++ "data type " ++ show typName ++ "."+ where+  argTy = map snd args !! fI++modifier offset mods (DC (ty@(SP _ _),_)) =+    let m = Right (NRange (start+offset) (end+offset)) in+    case mods of+      Right {}:rest -> Just (m:rest, ty)+      _ -> Just (m:mods,ty)+  where+    start = typeSize ty - 1+    end   = typeSize ty - conSize ty++modifier offset mods (Nested m1 m2) = do+  case modifier offset mods m1 of+    Nothing -> modifier offset mods m2+    Just (mods1,argTy) ->+      let m3 = case mods1 of+                 Right (NRange _ e):_ -> modifier e mods1 m2+                 _ -> modifier 0 mods1 m2+      in case m3 of+        -- In case the second modifier is `Nothing` that means we want the entire+        -- thing calculated by the first modifier+        Nothing -> Just (mods1,argTy)+        m       -> m++modifier _ _ _ = Nothing
+ src/Clash/Backend/VHDL.hs view
@@ -0,0 +1,2424 @@+{-|+  Copyright   :  (C) 2015-2016, University of Twente,+                     2017-2018, Google Inc.,+                     2021-2024, QBayLogic B.V.+                     2022     , Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Generate VHDL for assorted Netlist datatypes+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}++module Clash.Backend.VHDL (VHDLState) where++import           Control.Arrow                        (second)+import           Control.Lens                         hiding (Indexed, Empty)+import           Control.Monad                        (forM,join,zipWithM)+import           Control.Monad.State                  (State, StateT)+import           Data.Bifunctor                       (first)+import           Data.Bits                            (testBit, Bits)+import qualified Data.ByteString.Char8                as B8+import           Data.Coerce                          (coerce)+import           Data.Function                        (on)+import           Data.HashMap.Lazy                    (HashMap)+import qualified Data.HashMap.Lazy                    as HashMap+import qualified Data.HashMap.Strict                  as HashMapS+import           Data.HashSet                         (HashSet)+import qualified Data.HashSet                         as HashSet+import qualified Data.Map                             as Map+import           Data.Map                             (Map)+import           Data.List+  (mapAccumL, nub, nubBy, intersperse, group, sort)+import           Data.List.Extra                      ((<:>), equalLength, zipEqual)+import           Data.Maybe                           (catMaybes,mapMaybe)+import           Data.Monoid                          (Ap(Ap))+import           Data.Monoid.Extra                    ()+import qualified Data.Text.Lazy                       as T+import qualified Data.Text                            as TextS+import           Data.Text.Extra+import           Data.Tuple                           (swap)++#if MIN_VERSION_prettyprinter(1,7,0)+import qualified Prettyprinter                        as PP+#else+import qualified Data.Text.Prettyprint.Doc            as PP+#endif++import           Data.Text.Prettyprint.Doc.Extra+import           GHC.Stack                            (HasCallStack)+import qualified System.FilePath+import           Text.Printf++import           Clash.Annotations.Primitive          (HDL (..))+import           Clash.Annotations.BitRepresentation.Internal+  (ConstrRepr'(..), DataRepr'(..))+import           Clash.Annotations.BitRepresentation.ClashLib+  (bitsToBits)+import           Clash.Annotations.BitRepresentation.Util+  (BitOrigin(Lit, Field), bitOrigins, bitRanges)+import           Clash.Annotations.SynthesisAttributes (Attr(..))+import           Clash.Backend+import           Clash.Debug                          (traceIf)+import           Clash.Driver.Types                   (ClashOpts(..))+import           Clash.Explicit.BlockRam.Internal     (unpackNats)+import           Clash.Netlist.BlackBox.Types         (HdlSyn (..))+import           Clash.Netlist.BlackBox.Util+  (extractLiterals, renderBlackBox, addFilePath)+import qualified Clash.Netlist.Id                     as Id+import           Clash.Netlist.Types                  hiding (intWidth, usages, _usages)+import           Clash.Netlist.Util+import           Clash.Util+  (SrcSpan, noSrcSpan, clogBase, curLoc, makeCached, indexNote)+import qualified Clash.Util.Interpolate               as I+import           Clash.Util.Graph                     (reverseTopSort)++import           Clash.Backend.Verilog (Range (..), continueWithRange)+import           Debug.Trace (traceM)++-- | State for the 'Clash.Netlist.VHDL.VHDLM' monad:+data VHDLState =+  VHDLState+  { _tyCache   :: HashSet HWType+  -- ^ Previously encountered HWTypes+  , _nameCache :: (HashMap (HWType, Bool) TextS.Text)+  -- ^ Cache for type names. Bool indicates whether this name includes length+  -- information in its first "part". See `tyName'` for more information.+  , _modNm     :: ModName+  , _topNm     :: Identifier+  , _srcSpan   :: SrcSpan+  , _libraries :: [T.Text]+  , _packages  :: [T.Text]+  , _includes  :: [(String,Doc)]+  , _dataFiles :: Map FilePath String+  -- ^ Files to be copied: (path to file, file name). The file name stored in+  -- the map might differ from the file name in the path, to prevent name+  -- collisions.+  , _includeDirs :: [FilePath]+  -- ^ Import directories passed in with @-i@+  , _memoryDataFiles:: [(String,String)]+  -- ^ Files to be stored: (filename, contents). These files are generated+  -- during the execution of 'genNetlist'.+  , _idSeen    :: IdentifierSet+  , _tyPkgCtx :: Bool+  -- ^ Are we in the context of generating the @_types@ package?+  , _intWidth  :: Int+  -- ^ Int/Word/Integer bit-width+  , _hdlsyn    :: HdlSyn+  -- ^ For which HDL synthesis tool are we generating VHDL+  , _undefValue :: Maybe (Maybe Int)+  , _productFieldNameCache :: HashMap (Maybe [TextS.Text], [HWType]) [TextS.Text]+  -- ^ Caches output of 'productFieldNames'.+  , _enumNameCache :: HashMap HWType [TextS.Text]+  -- ^ Cache for enum variant names.+  , _aggressiveXOptBB_ :: AggressiveXOptBB+  , _renderEnums_ :: RenderEnums+  , _domainConfigurations_ :: DomainMap+  , _usages :: UsageMap+  }++makeLenses ''VHDLState++instance HasIdentifierSet VHDLState where+  identifierSet = idSeen++instance HasUsageMap VHDLState where+  usageMap = usages++instance Backend VHDLState where+  initBackend opts = VHDLState+    { _tyCache=mempty+    , _nameCache=mempty+    , _modNm=""+    , _topNm=Id.unsafeMake ""+    , _srcSpan=noSrcSpan+    , _libraries=[]+    , _packages=[]+    , _includes=[]+    , _dataFiles=mempty+    , _includeDirs = opt_importPaths opts+    , _memoryDataFiles=[]+    , _idSeen=Id.emptyIdentifierSet (opt_escapedIds opts) (opt_lowerCaseBasicIds opts) VHDL+    , _tyPkgCtx=False+    , _intWidth=opt_intWidth opts+    , _hdlsyn=opt_hdlSyn opts+    , _undefValue=opt_forceUndefined opts+    , _productFieldNameCache=mempty+    , _enumNameCache=mempty+    , _aggressiveXOptBB_=coerce (opt_aggressiveXOptBB opts)+    , _renderEnums_=coerce (opt_renderEnums opts)+    , _domainConfigurations_=emptyDomainMap+    , _usages=mempty+    }+  hdlKind         = const VHDL+  primDirs        = const $ do root <- primsRoot+                               return [ root System.FilePath.</> "common"+                                      , root System.FilePath.</> "vhdl"+                                      ]+  extractTypes    = _tyCache+  name            = const "vhdl"+  extension       = const ".vhdl"++  genHDL          = genVHDL+  mkTyPackage     = mkTyPackage_+  hdlHWTypeKind = \case+    Vector {} -> pure UserType+    RTree {} -> pure UserType+    Product {} -> pure UserType+    MemBlob {} -> pure UserType++    Sum {} -> do+      -- If an enum is rendered, it is a user type. If not, an std_logic_vector+      -- is rendered, and it is a synonym.+      RenderEnums enums <- renderEnums+      if enums then pure UserType else pure SynonymType++    Clock {} -> pure SynonymType+    ClockN {} -> pure SynonymType+    Reset {} -> pure SynonymType+    Enable {} -> pure SynonymType+    Index {} -> pure SynonymType+    CustomSP {} -> pure SynonymType+    SP {} -> pure SynonymType+    -- TODO This could possibly be changed to a VHDL enum as well, provided the+    -- enum_encoding attribute behaves as desired in different tools+    CustomSum {} -> pure SynonymType+    CustomProduct {} -> pure SynonymType++    BitVector _ -> pure PrimitiveType+    Bool -> pure PrimitiveType+    Bit -> pure PrimitiveType+    Unsigned {} -> pure PrimitiveType+    Signed {} -> pure PrimitiveType+    String -> pure PrimitiveType+    Integer -> pure PrimitiveType+    FileType -> pure PrimitiveType++    -- Transparent types:+    BiDirectional _ ty -> hdlHWTypeKind ty+    Annotated _ ty -> hdlHWTypeKind ty++    -- Shouldn't be printed?+    Void {} -> pure PrimitiveType+    KnownDomain {} -> pure PrimitiveType++  hdlType Internal      (filterTransparent -> ty) = sizedQualTyName ty+  hdlType (External nm) (filterTransparent -> ty) =+    let sized = sizedQualTyName ty in+    case ty of+      Bit         -> sized+      Bool        -> sized+      Signed _    -> sized+      Unsigned _  -> sized+      BitVector _ -> sized+      _           -> pretty nm <> dot <> sized+  hdlTypeErrValue = sizedQualTyNameErrValue+  hdlTypeMark     = qualTyName+  hdlRecSel       = vhdlRecSel+  hdlSig t ty     = sigDecl (pretty t) ty+  genStmt         = const emptyDoc+  inst            = inst_+  expr            = expr_+  iwWidth         = use intWidth++  toBV t id_ = do+    enums <- Ap renderEnums+    if isBV enums t then pretty id_ else do+      nm <- Ap $ use modNm+      -- TODO: restore hack+--      seen <- use seenIdentifiers+      -- This is a bit hacky, as id_ is just a rendered expression.+      -- But if it's a bare identifier that we've seen before,+      -- then this identifier has a defined type and we can skip the explicit type qualification.+--      let e | T.toStrict id_ `HashMapS.member` seen = pretty id_+--            | otherwise =+      let e = hdlTypeMark t <> squote <> parens (pretty id_)+      pretty nm <> "_types.toSLV" <> parens e+  fromBV t id_ = do+    enums <- Ap renderEnums+    if isBV enums t then pretty id_ else do+      nm <- Ap $ use modNm+      qualTyName t <> "'" <> parens (pretty nm <> "_types.fromSLV" <> parens (pretty id_))+  hdlSyn          = use hdlsyn+  setModName nm s = s {_modNm = nm}+  setTopName nm s = s {_topNm = nm}+  getTopName      = use topNm+  setSrcSpan      = (srcSpan .=)+  getSrcSpan      = use srcSpan+  blockDecl nm ds = do+    decs <- decls ds+    let attrs = [ (id_, attr)+                | NetDecl' _ id_ hwtype _ <- ds+                , attr <- hwTypeAttrs hwtype]+    if isEmpty decs+       then insts ds+       else nest 2+              (pretty nm <+> colon <+> "block" <> line <>+               pure decs <>+               (if null attrs+                then emptyDoc+                else line <> line <> renderAttrs (TextS.pack "signal") attrs)) <> line <>+            "begin" <>+            nest 2 (line <> insts ds)+            <> line <>+            "end block" <> semi++  addIncludes inc = includes %= (inc++)+  addLibraries libs = libraries %= (libs ++)+  addImports imps = packages %= (imps ++)+  addAndSetData f = do+    fs <- use dataFiles+    iDirs <- use includeDirs+    let (fs',f') = addFilePath iDirs fs f+    dataFiles .= fs'+    return f'+  getDataFiles = map swap . Map.assocs <$> use dataFiles+  addMemoryDataFile f = memoryDataFiles %= (f:)+  getMemoryDataFiles = use memoryDataFiles+  ifThenElseExpr _ = False+  aggressiveXOptBB = use aggressiveXOptBB_+  renderEnums = use renderEnums_+  domainConfigurations = use domainConfigurations_+  setDomainConfigurations confs s = s {_domainConfigurations_ = confs}++type VHDLM a = Ap (State VHDLState) a++-- Check if the underlying type is a BitVector+isBV :: RenderEnums -> HWType -> Bool+isBV e (normaliseType e -> BitVector _) = True+isBV _ _ = False++-- | Generate unique (partial) names for product fields. Example:+--+-- > productFieldNames Nothing [Unsigned 6, Unsigned 6, Bit, Bool]+-- ["unsigned6_0", "unsigned6_1", "bit", "boolean"]+productFieldNames+  :: HasCallStack+  => Maybe [IdentifierText]+  -- ^ Label hints. From user records, for example.+  -> [HWType]+  -- ^ Field types+  -> VHDLM [IdentifierText]+productFieldNames labels0 fields = do+  let labels1 = sequence labels0 ++ repeat Nothing+  hFields <- zipWithM hName labels1 fields++  let grouped = group $ sort $ hFields+      countGroup [] = error "productFIeldNames.countGroup: group of zero elements"+      countGroup (g:gs) = (g, succ (length gs))+      counted = HashMapS.fromList (map countGroup grouped)+      names   = snd $ mapAccumL (name' counted) HashMapS.empty hFields++  return names+ where+  hName+    :: Maybe IdentifierText+    -> HWType+    -> VHDLM IdentifierText+  hName Nothing field = tyName' False field+  hName (Just label) _field = Id.toText <$> Id.makeBasic label++  name'+    :: HashMap IdentifierText Int+    -> HashMap IdentifierText Int+    -> IdentifierText+    -> (HashMap IdentifierText Int, IdentifierText)+  name' counted countMap fieldName+    | counted HashMapS.! fieldName > 1 =+        -- Seen this fieldname more than once, so we need to add a number+        -- as a postfix:+        let succ' n = Just (maybe (0 :: Int) (+1) n) in+        let countMap' = HashMapS.alter succ' fieldName countMap in+        -- Each field will get a distinct number:+        let count = countMap' HashMapS.! fieldName in+        (countMap', TextS.concat [fieldName, "_", showt count])+    | otherwise =+        -- This fieldname has only been seen once, so we don't need to add+        -- a number as a postfix:+        (countMap, fieldName)++productFieldName+  :: HasCallStack+  => Maybe [IdentifierText]+  -- ^ Label hints. From user records, for example.+  -> [HWType]+  -- ^ Field types+  -> Int+  -- ^ Index of field+  -> VHDLM Doc+productFieldName labels fields fieldIndex = do+  names <-+    makeCached+      (labels, fields)+      productFieldNameCache+      (productFieldNames labels fields)+  return (PP.pretty (names !! fieldIndex))++selectProductField+  :: HasCallStack+  => Maybe [IdentifierText]+  -- ^ Label hints. From user records, for example.+  -> [HWType]+  -- ^ Field types+  -> Int+  -- ^ Index of field+  -> VHDLM Doc+selectProductField fieldLabels fieldTypes fieldIndex =+  "_sel" <> int fieldIndex <> "_" <> productFieldName fieldLabels fieldTypes fieldIndex++enumVariantName+  :: HasCallStack+  => HWType+  -> Int+  -> VHDLM Doc+enumVariantName ty@(Sum _ vs) i = do+  names <- makeCached ty enumNameCache (traverse variantName vs)+  pure (PP.pretty (names !! i))+ where+  -- Make a basic identifier from the last part of a qualified name+  variantName = fmap Id.toText . Id.makeBasic . snd . TextS.breakOnEnd "."++enumVariantName _ _ =+  error $ $(curLoc) ++ "enumVariantName called on non-enum type"++-- | Generate VHDL for a Netlist component+genVHDL+  :: ClashOpts+  -> ModName+  -> SrcSpan+  -> IdentifierSet+  -> UsageMap+  -> Component+  -> VHDLM ((String, Doc), [(String, Doc)])+genVHDL _ nm sp seen us c = do+    -- Don't have type names conflict with module names or with previously+    -- generated type names.+    --+    -- TODO: Collect all type names up front, to prevent relatively costly union.+    -- TODO: Investigate whether type names / signal names collide in the first place+    Ap $ do+      idSeen %= Id.union seen+      usages .= us+      setSrcSpan sp++    v <- vhdl+    i <- Ap $ use includes+    Ap $ libraries .= []+    Ap $ packages  .= []+    return ((TextS.unpack (Id.toText cName), v), i)+  where+    cName   = componentName c+    vhdl    = do+      ent  <- entity c+      arch <- architecture c+      imps <- tyImports nm+      ("-- Automatically generated VHDL-93" <> line <>+       pure imps <> line <> line <>+       pure ent <> line <> line <>+       pure arch)++-- | Generate a VHDL package containing type definitions for the given HWTypes+mkTyPackage_ :: ModName -> [HWType] -> VHDLM [(String,Doc)]+mkTyPackage_ modName (map filterTransparent -> hwtys) = do+    { Ap (tyPkgCtx .= True)+    ; syn <- Ap hdlSyn+    ; enums <- Ap renderEnums+    ; let usedTys     = concatMap mkUsedTys hwtys+    ; let normTys0    = nub (map mkVecZ (hwtys ++ usedTys))+    ; let sortedTys0  = topSortHWTys normTys0+          packageDec  = vcat $ mapM tyDec (nubBy eqTypM sortedTys0)+          (funDecs,funBodies) = unzip . mapMaybe (funDec enums syn) $ nubBy eqTypM (normaliseType enums <$> sortedTys0)++    ; pkg <- (:[]) <$> (TextS.unpack (modName `TextS.append` "_types"),) <$>+      "library IEEE;" <> line <>+      "use IEEE.STD_LOGIC_1164.ALL;" <> line <>+      "use IEEE.NUMERIC_STD.ALL;" <> line <> line <>+      "package" <+> pretty (modName `TextS.append` "_types") <+> "is" <> line <>+         indent 2 ( packageDec <> line <>+                    vcat (sequence funDecs)+                  ) <> line <>+      "end" <> semi <> packageBodyDec funBodies+    ; Ap (tyPkgCtx .= False)+    ; return pkg+    }+  where+    packageBodyDec :: [VHDLM Doc] -> VHDLM Doc+    packageBodyDec funBodies = case funBodies of+      [] -> emptyDoc+      _  -> do+        { line <> line <>+         "package" <+> "body" <+> pretty (modName `TextS.append` "_types") <+> "is" <> line <>+           indent 2 (vcat (sequence funBodies)) <> line <>+         "end" <> semi+        }++    eqTypM :: HWType -> HWType -> Bool+    eqTypM (Signed _) (Signed _)         = True+    eqTypM (Unsigned _) (Unsigned _)     = True+    eqTypM (BitVector _) (BitVector _)   = True+    eqTypM ty1 ty2                       = ty1 == ty2++mkUsedTys :: HWType -> [HWType]+mkUsedTys hwty = hwty : case hwty of+  Vector _ elTy        -> mkUsedTys elTy+  RTree _ elTy         -> mkUsedTys elTy+  Product _ _ elTys    -> concatMap mkUsedTys elTys+  SP _ elTys           -> concatMap mkUsedTys (concatMap snd elTys)+  BiDirectional _ elTy -> mkUsedTys elTy+  Annotated _ elTy     -> mkUsedTys elTy+  CustomProduct _ _ _ _ tys0 ->+    concatMap mkUsedTys (map snd tys0)+  CustomSP _ _ _ tys0 ->+    let tys1 = concat [tys | (_repr, _id, tys) <- tys0] in+    concatMap mkUsedTys tys1+  _ ->+    []++topSortHWTys+  :: [HWType]+  -> [HWType]+topSortHWTys hwtys = sorted+  where+    nodes  = zip [0..] hwtys+    nodesI = HashMap.fromList (zip hwtys [0..])+    edges  = concatMap edge hwtys++    sorted =+      case reverseTopSort nodes edges of+        Left err -> error $ $(curLoc) ++ "[BUG IN CLASH] topSortHWTys: " ++ err+        Right ns -> ns++    -- `elTy` needs to be rendered before `t`+    edge t@(Vector _ elTy) =+      case HashMap.lookup (mkVecZ elTy) nodesI of+        Just node ->+          [(nodesI HashMap.! t, node)]+        Nothing ->+          []++    -- `elTy` needs to be rendered before `t`+    edge t@(RTree _ elTy) =+      let vecZ = mkVecZ elTy in+      case HashMap.lookup vecZ nodesI of+        Just node ->+          [(nodesI HashMap.! t, node)] ++ edge elTy+        Nothing ->+          []++    -- `tys` need to be rendered before `t`+    edge t@(Product _ _ tys0) =+      let tys1 = [HashMap.lookup (mkVecZ ty) nodesI | ty <- tys0] in+      map (nodesI HashMap.! t,) (catMaybes tys1)++    edge t@(SP _ tys0) =+      let tys1 = concat (map snd tys0) in+      let tys2 = [HashMap.lookup (mkVecZ ty) nodesI | ty <- tys1] in+      map (nodesI HashMap.! t,) (catMaybes tys2)++    edge t@(CustomSP _ _ _ tys0) =+      let tys1 = concat [tys | (_repr, _id, tys) <- tys0] in+      let tys2 = [HashMap.lookup (mkVecZ ty) nodesI | ty <- tys1] in+      map (nodesI HashMap.! t,) (catMaybes tys2)++    edge t@(CustomProduct _ _ _ _ (map snd -> tys0)) =+      let tys1 = [HashMap.lookup (mkVecZ ty) nodesI | ty <- tys0] in+      map (nodesI HashMap.! t,) (catMaybes tys1)++    edge _ = []++mkVecZ :: HWType -> HWType+mkVecZ (Vector _ elTy) = Vector 0 elTy+mkVecZ (RTree _ elTy)  = RTree 0 elTy+mkVecZ t               = t++typAliasDec :: HasCallStack => HWType -> VHDLM Doc+typAliasDec hwty = do+  enums <- Ap renderEnums+  "subtype" <+> tyName hwty+            <+> "is"+            <+> sizedTyName (normaliseType enums hwty)+            <> semi++tyDec :: HasCallStack => HWType -> VHDLM Doc+tyDec hwty = do+  syn <- Ap hdlSyn+  RenderEnums enums <- Ap renderEnums++  case hwty of+    -- "Proper" custom types:+    Vector _ elTy ->+      case syn of+        Vivado ->+          "type" <+> tyName hwty+                 <+> "is array (integer range <>) of std_logic_vector"+                 <> parens (int (typeSize elTy - 1) <+> "downto 0")+                 <> semi++        _ ->+          "type" <+> tyName hwty+                 <+> "is array (integer range <>) of"+                 <+> sizedQualTyName elTy+                 <> semi++    RTree _ elTy ->+      case syn of+        Vivado ->+          "type" <+> tyName hwty+                 <+> "is array (integer range <>) of"+                 <+> "std_logic_vector"+                 <> parens (int (typeSize elTy - 1) <+> "downto 0")+                 <> semi++        _ ->+          "type" <+> tyName hwty+                 <+> "is array (integer range <>) of"+                 <+> sizedQualTyName elTy+                 <> semi++    Product _ labels tys@(_:_:_) ->+      let selNames = map (\i -> tyName hwty <> selectProductField labels tys i) [0..] in+      let selTys   = map sizedQualTyName tys in+      "type" <+> tyName hwty <+> "is record" <> line  <>+        indent 2 (vcat $ zipWithM (\x y -> x <+> colon <+> y <> semi) selNames selTys) <> line <>+      "end record" <> semi++    Sum _ vs | enums ->+        let variantNames = traverse (enumVariantName hwty) [0..length vs - 1] in+          "type" <+> tyName hwty+                 <+> "is"+                 <+> parens (hsep (punctuate comma variantNames))+                 <> semi++    MemBlob n m -> tyDec (Vector n (BitVector m))++    -- Type aliases:+    Clock _           -> typAliasDec hwty+    ClockN _          -> typAliasDec hwty+    Reset _           -> typAliasDec hwty+    Enable _          -> typAliasDec hwty+    Index _           -> typAliasDec hwty+    CustomSP _ _ _ _  -> typAliasDec hwty+    Sum _ _           -> typAliasDec hwty+    SP _ _            -> typAliasDec hwty+    CustomSum _ _ _ _ -> typAliasDec hwty+    CustomProduct {}  -> typAliasDec hwty++    -- VHDL builtin types:+    BitVector _ -> emptyDoc+    Bool        -> emptyDoc+    Bit         -> emptyDoc+    Unsigned _  -> emptyDoc+    Signed _    -> emptyDoc+    String      -> emptyDoc+    Integer     -> emptyDoc+    FileType    -> emptyDoc++    -- Transparent types:+    BiDirectional _ ty -> tyDec ty+    Annotated _ ty -> tyDec ty++    Void {} -> emptyDoc+    KnownDomain {} -> emptyDoc++    -- Unexpected arguments:+    Product _ _ _ -> error $ $(curLoc) ++ [I.i|+      Unexpected Product with fewer than 2 fields: #{hwty}+    |]+++++funDec :: RenderEnums -> HdlSyn -> HWType -> Maybe (VHDLM Doc,VHDLM Doc)+funDec _ _ Bool = Just+  ( "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <> semi <> line <>+    "function" <+> "tagToEnum" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "boolean" <> semi <> line <>+    "function" <+> "dataToTag" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "signed" <> semi+  , "function" <+> "toSLV" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "std_logic_vector" <+> "is" <> line <>+    "begin" <> line <>+      indent 2 (vcat $ sequence ["if" <+> "b" <+> "then"+                                ,  indent 2 ("return" <+> dquotes (int 1) <> semi)+                                ,"else"+                                ,  indent 2 ("return" <+> dquotes (int 0) <> semi)+                                ,"end" <+> "if" <> semi+                                ]) <> line <>+    "end" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("sl" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "boolean" <+> "is" <> line <>+    "begin" <> line <>+      indent 2 (vcat $ sequence ["if" <+> "sl" <+> "=" <+> dquotes (int 1) <+> "then"+                                ,   indent 2 ("return" <+> "true" <> semi)+                                ,"else"+                                ,   indent 2 ("return" <+> "false" <> semi)+                                ,"end" <+> "if" <> semi+                                ]) <> line <>+    "end" <> semi <> line <>+    "function" <+> "tagToEnum" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "boolean" <+> "is" <> line <>+    "begin" <> line <>+      indent 2 (vcat $ sequence ["if" <+> "s" <+> "=" <+> "to_signed" <> parens (int 0 <> comma <> (Ap (use intWidth) >>= int)) <+> "then"+                                ,   indent 2 ("return" <+> "false" <> semi)+                                ,"else"+                                ,   indent 2 ("return" <+> "true" <> semi)+                                ,"end" <+> "if" <> semi+                                ]) <> line <>+    "end" <> semi <> line <>+    "function" <+> "dataToTag" <+> parens ("b" <+> colon <+> "in" <+> "boolean") <+> "return" <+> "signed" <+> "is" <> line <>+    "begin" <> line <>+      indent 2 (vcat $ sequence ["if" <+> "b" <+> "then"+                                ,  indent 2 ("return" <+> "to_signed" <> parens (int 1 <> comma <> (Ap (use intWidth) >>= int)) <> semi)+                                ,"else"+                                ,  indent 2 ("return" <+> "to_signed" <> parens (int 0 <> comma <> (Ap (use intWidth) >>= int)) <> semi)+                                ,"end" <+> "if" <> semi+                                ]) <> line <>+    "end" <> semi+  )++funDec _ _ bit@Bit = Just+  ( "function" <+> "toSLV" <+> parens ("sl" <+> colon <+> "in" <+> tyName bit) <+> "return" <+> "std_logic_vector" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> tyName bit <> semi+  , "function" <+> "toSLV" <+> parens ("sl" <+> colon <+> "in" <+> tyName bit) <+> "return" <+> "std_logic_vector" <+> "is" <> line <>+    "begin" <> line <>+      indent 2 ("return" <+> "std_logic_vector'" <> parens (int 0 <+> rarrow <+> "sl") <> semi) <> line <>+    "end" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> tyName bit <+> "is" <> line <>+      indent 2+        ( "alias islv : std_logic_vector (0 to slv'length - 1) is slv;"+        ) <> line <>+    "begin" <> line <>+      indent 2 ("return" <+> "islv" <> parens (int 0) <> semi) <> line <>+    "end" <> semi+  )++funDec _ _ (Signed _) = Just+  ( "function" <+> "toSLV" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "std_logic_vector" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "signed" <> semi+  , "function" <+> "toSLV" <+> parens ("s" <+> colon <+> "in" <+> "signed") <+> "return" <+> "std_logic_vector" <+> "is" <> line <>+    "begin" <> line <>+      indent 2 ("return" <+> "std_logic_vector" <> parens ("s") <> semi) <> line <>+    "end" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "signed" <+> "is" <> line <>+      indent 2 ("alias islv : std_logic_vector(0 to slv'length - 1) is slv;") <> line <>+    "begin" <> line <>+      indent 2 ("return" <+> "signed" <> parens ("islv") <> semi) <> line <>+    "end" <> semi+  )++funDec _ _ (Unsigned _) = Just+  ( "function" <+> "toSLV" <+> parens ("u" <+> colon <+> "in" <+> "unsigned") <+> "return" <+> "std_logic_vector" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "unsigned" <> semi+  , "function" <+> "toSLV" <+> parens ("u" <+> colon <+> "in" <+> "unsigned") <+> "return" <+> "std_logic_vector" <+> "is"  <> line <>+    "begin" <> line <>+      indent 2 ("return" <+> "std_logic_vector" <> parens ("u") <> semi) <> line <>+    "end" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "unsigned" <+> "is"  <> line <>+      indent 2 "alias islv : std_logic_vector(0 to slv'length - 1) is slv;" <> line <>+    "begin" <> line <>+      indent 2 ("return" <+> "unsigned" <> parens ("islv") <> semi) <> line <>+    "end" <> semi++  )++funDec _ _ t@(Product _ labels elTys) = Just+  ( "function" <+> "toSLV" <+> parens ("p :" <+> sizedTyName t) <+> "return std_logic_vector" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> sizedTyName t <> semi+  , "function" <+> "toSLV" <+> parens ("p :" <+> sizedTyName t) <+> "return std_logic_vector" <+> "is" <> line <>+    "begin" <> line <>+    indent 2 ("return" <+> parens (hcat (punctuate " & " elTyToSLV)) <> semi) <> line <>+    "end" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> sizedTyName t <+> "is" <> line <>+      "alias islv : std_logic_vector(0 to slv'length - 1) is slv;" <> line <>+    "begin" <> line <>+    indent 2 ("return" <+> parens (hcat (punctuate "," elTyFromSLV)) <> semi) <> line <>+    "end" <> semi+  )+  where+    elTyToSLV = forM [0..(length elTys - 1)]+                     (\i -> "toSLV" <>+                            parens ("p." <> tyName t <> selectProductField labels elTys i))++    argLengths = map typeSize elTys+    starts1    = snd (mapAccumL ((join (,) .) . (+)) 0 argLengths)+    starts     = 0 : starts1+    ends       = map (subtract 1) starts1++    elTyFromSLV = forM (zip starts ends)+                       (\(s,e) -> "fromSLV" <>+                          parens ("islv" <> parens (int s <+> "to" <+> int e)))++funDec (RenderEnums enums) _ t@(Sum _ _) | enums = Just+  ( "function" <+> "toSLV" <+> parens("value" <+> colon <+> "in" <+> qualTyName t) <+> "return std_logic_vector" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> qualTyName t <> semi+  , "function" <+> "toSLV" <+> parens ("value" <+> colon <+> "in" <+> qualTyName t) <+> "return std_logic_vector" <+> "is" <> line <>+    "begin" <> line <>+    indent 2+      ( "return" <+> "std_logic_vector" <>+        parens ("to_unsigned" <>+          parens (qualTyName t <> "'pos(value)" <> comma <+> int (typeSize t))+        )) <> semi <> line <>+    "end" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> qualTyName t <+> "is" <> line <>+    "begin" <> line <>+    indent 2+      (+      translate_off (+      "if unsigned(slv) <= " <> qualTyName t <> "'pos("<> qualTyName t <> "'high) then"+      ) <> line <>+        indent 2+          ( "return" <+> qualTyName t <> "'val" <>+            parens ("to_integer" <>+              parens ("unsigned" <> parens "slv"))) <> semi <> line <>+      translate_off (+        "else" <> line <>+        indent 2+          ( "return" <+> qualTyName t <> "'val(0)") <> semi <> line <>+        "end if" <> semi+      )+      ) <> line <>+    "end" <> semi+  )+  where+    translate_off body = "-- pragma translate_off" <> line <> body <> line <> "-- pragma translate_on"++funDec _ syn t@(Vector _ elTy) = Just+  ( "function" <+> "toSLV" <+> parens ("value : " <+> qualTyName t) <+> "return std_logic_vector" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> qualTyName t <> semi+  , "function" <+> "toSLV" <+> parens ("value : " <+> qualTyName t) <+> "return std_logic_vector" <+> "is" <> line <>+      indent 2+        ( "alias ivalue    :" <+> qualTyName t <> "(1 to value'length) is value;" <> line <>+          "variable result :" <+> "std_logic_vector" <> parens ("1 to value'length * " <> int (typeSize elTy)) <> semi+        ) <> line <>+    "begin" <> line <>+      indent 2+        ("for i in ivalue'range loop" <> line <>+            indent 2+              (  "result" <> parens (parens ("(i - 1) * " <> int (typeSize elTy)) <+> "+ 1" <+>+                                             "to i*" <> int (typeSize elTy)) <+>+                          ":=" <+> (case syn of+                                      Vivado -> "ivalue" <> parens ("i")+                                      _  -> "toSLV" <> parens ("ivalue" <> parens ("i"))) <> semi+              ) <> line <>+         "end" <+> "loop" <> semi <> line <>+         "return" <+> "result" <> semi+        ) <> line <>+    "end" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> qualTyName t <+> "is" <> line <>+      indent 2+        ( "alias islv      :" <+> "std_logic_vector" <> "(0 to slv'length - 1) is slv;" <> line <>+          "variable result :" <+> qualTyName t <> parens ("0 to slv'length / " <> eSz <+> "- 1") <> semi+        ) <> line <>+    "begin" <> line <>+      indent 2+        ("for i in result'range loop" <> line <>+            indent 2+              ( "result" <> parens "i" <+> ":=" <+> case syn of+                    Vivado -> getElem <> semi+                    _ | BitVector _ <- elTy -> getElem <> semi+                      | otherwise           -> "fromSLV" <> parens getElem <> semi++              ) <> line <>+         "end" <+> "loop" <> semi <> line <>+         "return" <+> "result" <> semi+        ) <> line <>+    "end" <> semi+  )+  where+    eSz     = int (typeSize elTy)+    getElem = "islv" <> parens ("i * " <> eSz <+> "to (i+1) * " <> eSz <+> "- 1")++funDec _ _ (BitVector _) = Just+  ( "function" <+> "toSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <> semi+  , "function" <+> "toSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <+> "is" <> line <>+    "begin" <> line <>+      indent 2 ("return" <+> "slv" <> semi) <> line <>+    "end" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> "std_logic_vector" <+> "is" <> line <>+    "begin" <> line <>+      indent 2 ("return" <+> "slv" <> semi) <> line <>+    "end" <> semi+  )++funDec _ syn t@(RTree _ elTy) = Just+  ( "function" <+> "toSLV" <+> parens ("value : " <+> qualTyName t) <+> "return std_logic_vector" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> qualTyName t <> semi+  , "function" <+> "toSLV" <+> parens ("value : " <+> qualTyName t) <+> "return std_logic_vector" <+> "is" <> line <>+      indent 2+        ( "alias ivalue    :" <+> qualTyName t <> "(1 to value'length) is value;" <> line <>+          "variable result :" <+> "std_logic_vector" <> parens ("1 to value'length * " <> int (typeSize elTy)) <> semi+        ) <> line <>+    "begin" <> line <>+      indent 2+        ("for i in ivalue'range loop" <> line <>+            indent 2+              (  "result" <> parens (parens ("(i - 1) * " <> int (typeSize elTy)) <+> "+ 1" <+>+                                             "to i*" <> int (typeSize elTy)) <+>+                          ":=" <+> (case syn of+                                      Vivado -> "ivalue" <> parens ("i")+                                      _ -> "toSLV" <> parens ("ivalue" <> parens ("i"))) <> semi+              ) <> line <>+         "end" <+> "loop" <> semi <> line <>+         "return" <+> "result" <> semi+        ) <> line <>+    "end" <> semi <> line <>+    "function" <+> "fromSLV" <+> parens ("slv" <+> colon <+> "in" <+> "std_logic_vector") <+> "return" <+> qualTyName t <+> "is" <> line <>+      indent 2+        ( "alias islv      :" <+> "std_logic_vector" <> "(0 to slv'length - 1) is slv;" <> line <>+          "variable result :" <+> qualTyName t <> parens ("0 to slv'length / " <> eSz <+> "- 1") <> semi+        ) <> line <>+    "begin" <> line <>+      indent 2+        ("for i in result'range loop" <> line <>+            indent 2+              ( "result" <> parens "i" <+> ":=" <+> case syn of+                    Vivado -> getElem <> semi+                    _ | BitVector _ <- elTy -> getElem <> semi+                      | otherwise           -> "fromSLV" <> parens getElem <> semi++              ) <> line <>+         "end" <+> "loop" <> semi <> line <>+         "return" <+> "result" <> semi+        ) <> line <>+    "end" <> semi+  )+  where+    eSz     = int (typeSize elTy)+    getElem = "islv" <> parens ("i * " <> eSz <+> "to (i+1) * " <> eSz <+> "- 1")++funDec _ _ _ = Nothing++tyImports :: ModName -> VHDLM Doc+tyImports nm = do+  libs <- Ap $ use libraries+  packs <- Ap $ use packages+  punctuate' semi $ sequence+    ([ "library IEEE"+     , "use IEEE.STD_LOGIC_1164.ALL"+     , "use IEEE.NUMERIC_STD.ALL"+     , "use IEEE.MATH_REAL.ALL"+     , "use std.textio.all"+     , "use work.all"+     , "use work." <> pretty (nm `TextS.append` "_types") <> ".all"+     ] ++ (map (("library" <+>) . pretty) (nub libs))+       ++ (map (("use" <+>) . pretty) (nub packs)))+++-- TODO: Way too much happening on a single line+port :: Num t+     => Identifier+     -> HWType+     -> VHDLM Doc+     -> Int+     -> Maybe Expr+     -> VHDLM (Doc, t)+port (Id.toText -> elName) hwType portDirection fillToN iEM =+  (,fromIntegral $ TextS.length elName) <$>+  (encodingNote hwType <> fill fillToN (pretty elName) <+> colon <+> direction+   <+> sizedQualTyName hwType <> iE)+ where+  direction | isBiSignalIn hwType = "inout"+            | otherwise           = portDirection++  iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM++-- [Note] Hack entity attributes in architecture+--+-- By default we print attributes inside the entity block. This conforms+-- to the VHDL standard (IEEE Std 1076-1993, 5.1 Attribute specification,+-- paragraph 9), and is subsequently implemented in this way by open-source+-- simulators such as GHDL.+---+-- Intel and Xilinx use their own annotation schemes unfortunately, which+-- require attributes in the architecture.+--+-- References:+--  * https://www.mail-archive.com/ghdl-discuss@gna.org/msg03175.html+--  * https://forums.xilinx.com/t5/Simulation-and-Verification/wrong-attribute-decorations-of-port-signals-generated-by-write/m-p/704905#M16265+--  * http://quartushelp.altera.com/15.0/mergedProjects/hdl/vhdl/vhdl_file_dir_chip.htm++entity :: Component -> VHDLM Doc+entity c = do+    syn <- Ap hdlSyn+    rec (p,ls) <- fmap unzip (ports (maximum ls))+    "entity" <+> pretty (componentName c) <+> "is" <> line <>+      (case p of+         [] -> emptyDoc+         _  -> case syn of+          -- See: [Note] Hack entity attributes in architecture+          Other -> indent 2 (rports p <> if null attrs then emptyDoc else+                              line <> line <> rattrs) <> line <> "end" <> semi+          _     -> indent 2 (rports p) <> line <> "end" <> semi+      )+  where+    ports l = sequence $ [port iName hwType "in" l Nothing | (iName, hwType) <- inputs c]+                      ++ [port oName hwType "out" l iEM | (_, (oName, hwType), iEM) <- outputs c]++    rports p = "port" <> (parens (align (vcat (punctuate semi (pure p))))) <> semi++    rattrs      = renderAttrs (TextS.pack "signal") attrs+    attrs       = inputAttrs ++ outputAttrs+    inputAttrs  = [(id_, attr) | (id_, hwtype) <- inputs c, attr <- hwTypeAttrs hwtype]+    outputAttrs = [(id_, attr) | (_, (id_, hwtype), _) <- outputs c, attr <- hwTypeAttrs hwtype]+++architecture :: Component -> VHDLM Doc+architecture c = do {+  ; syn <- Ap hdlSyn+  ; let attrs = case syn of+                  -- See: [Note] Hack entity attributes in architecture+                  Other -> declAttrs+                  _     -> inputAttrs ++ outputAttrs ++ declAttrs+  ; nest 2+      (("architecture structural of" <+> pretty (componentName c) <+> "is" <> line <>+       decls (declarations c)) <> line <>+       if null attrs then emptyDoc else line <> line <> renderAttrs (TextS.pack "signal") attrs) <> line <>+    nest 2+      ("begin" <> line <>+       insts (declarations c)) <> line <>+      "end" <> semi+  }+ where+   netdecls    = filter isNetDecl (declarations c)+   declAttrs   = [(id_, attr) | NetDecl' _ id_ hwtype _ <- netdecls, attr <- hwTypeAttrs hwtype]+   inputAttrs  = [(id_, attr) | (id_, hwtype) <- inputs c, attr <- hwTypeAttrs hwtype]+   outputAttrs = [(id_, attr) | (_, (id_, hwtype), _) <- outputs c, attr <- hwTypeAttrs hwtype]++   isNetDecl :: Declaration -> Bool+   isNetDecl NetDecl'{} = True+   isNetDecl _          = False++attrType ::+  HashMap TextS.Text TextS.Text ->+  Attr TextS.Text ->+  HashMap TextS.Text TextS.Text+attrType types attr =+  case HashMap.lookup name' types of+    Nothing    -> HashMap.insert name' type' types+    Just type'' | type'' == type' -> types+                | otherwise -> error $+                      $(curLoc) ++ unwords [ TextS.unpack name', "already assigned"+                                           , TextS.unpack type'', "while we tried to"+                                           , "add", TextS.unpack type' ]+ where+  name' = attrName attr+  type' = case attr of+            BoolAttr _ _    -> "boolean"+            IntegerAttr _ _ -> "integer"+            StringAttr _ _  -> "string"+            Attr _          -> "boolean"++attrName :: Attr a -> a+attrName = \case+  BoolAttr a _ -> a+  IntegerAttr a _ -> a+  StringAttr a _ -> a+  Attr a -> a++-- | Create 'attrname -> type' mapping for given attributes. Will err if multiple+-- types are assigned to the same name.+attrTypes :: [Attr TextS.Text] -> HashMap TextS.Text TextS.Text+attrTypes = foldl attrType HashMap.empty++-- | Create a 'attrname -> (type, [(signalname, value)]). Will err if multiple+-- types are assigned to the same name.+attrMap+  :: forall t+   . t ~ HashMap TextS.Text (TextS.Text, [(TextS.Text, TextS.Text)])+  => [(Identifier, Attr TextS.Text)]+  -> t+attrMap attrs0 = foldl go empty' attrs1+ where+  attrs1 = map (first Id.toText) attrs0++  empty' = HashMap.fromList+           [(k, (types HashMap.! k, [])) | k <- HashMap.keys types]+  types = attrTypes (map snd attrs1)++  go :: t -> (TextS.Text, Attr TextS.Text) -> t+  go map' attr = HashMap.adjust (go' attr) (attrName $ snd attr) map'++  go'+    :: (TextS.Text, Attr TextS.Text)+    -> (TextS.Text, [(TextS.Text, TextS.Text)])+    -> (TextS.Text, [(TextS.Text, TextS.Text)])+  go' (signalName, attr) (typ, elems) =+    (typ, (signalName, renderAttr attr) : elems)++renderAttrs+  :: TextS.Text+  -> [(Identifier, Attr TextS.Text)]+  -> VHDLM Doc+renderAttrs what (attrMap -> attrs) =+  vcat $ sequence $ intersperse " " $ map renderAttrGroup (HashMap.toList attrs)+ where+  renderAttrGroup+    :: (TextS.Text, (TextS.Text, [(TextS.Text, TextS.Text)]))+    -> VHDLM Doc+  renderAttrGroup (attrname, (typ, elems)) =+    ("attribute" <+> stringS attrname <+> colon <+> stringS typ <> semi)+    <> line <>+    (vcat $ sequence $ map (renderAttrDecl attrname) elems)++  renderAttrDecl+    :: TextS.Text+    -> (TextS.Text, TextS.Text)+    -> VHDLM Doc+  renderAttrDecl attrname (signalName, value) =+        "attribute"+    <+> stringS attrname+    <+> "of"+    <+> stringS signalName -- or component name+    <+> colon+    <+> stringS what <+> "is" -- "signal is" or "component is"+    <+> stringS value+    <> semi++-- | Convert single attribute to VHDL syntax+renderAttr :: Attr TextS.Text -> TextS.Text+renderAttr (StringAttr  _key value) = wrap '"' $ TextS.replace "\"" "\"\"" value+renderAttr (IntegerAttr _key value) = TextS.pack (show value)+renderAttr (BoolAttr    _key True ) = "true"+renderAttr (BoolAttr    _key False) = "false"+renderAttr (Attr        _key      ) = "true"++-- | Prepend and append a character to a string+wrap :: Char -> TextS.Text -> TextS.Text+wrap c = cons c . (`snoc` c)++sigDecl :: VHDLM Doc -> HWType -> VHDLM Doc+sigDecl d t = d <+> colon <+> sizedQualTyName t++-- | Append size information to given type string+appendSize :: VHDLM Doc -> HWType -> VHDLM Doc+appendSize baseType sizedType = case sizedType of+  BitVector n -> baseType <> parens (int (n-1) <+> "downto 0")+  Signed n    -> baseType <> parens (int (n-1) <+> "downto 0")+  Unsigned n  -> baseType <> parens (int (n-1) <+> "downto 0")+  Vector n _  -> baseType <> parens ("0 to" <+> int (n-1))+  RTree d _   -> baseType <> parens ("0 to" <+> int ((2^d)-1))+  MemBlob n _ -> baseType <> parens ("0 to" <+> int (n-1))+  Annotated _ elTy -> appendSize baseType elTy+  _           -> baseType++-- | Same as @qualTyName@, but instantiate generic types with their size.+sizedQualTyName :: HWType -> VHDLM Doc+sizedQualTyName (filterTransparent -> hwty) = appendSize (qualTyName hwty) hwty++-- | Same as @tyName@, but instantiate generic types with their size.+sizedTyName :: HWType -> VHDLM Doc+sizedTyName (filterTransparent -> hwty) = appendSize (tyName hwty) hwty++-- | Same as @tyName@, but return fully qualified name (name, including module)+qualTyName :: HWType -> VHDLM Doc+qualTyName (filterTransparent -> hwty) = case hwty of+  -- Builtin types:+  Bit -> tyName hwty+  Bool -> tyName hwty+  Signed _ -> tyName hwty+  Unsigned _ -> tyName hwty+  BitVector _ -> tyName hwty++  -- Transparent types:+  BiDirectional _ elTy -> qualTyName elTy+  Annotated _ elTy -> qualTyName elTy++  -- Custom types:+  _ -> do+    pkgCtx <- Ap (use tyPkgCtx)+    modName <- Ap (use modNm)++    if pkgCtx+      then tyName hwty+      else pretty modName <> "_types." <> tyName hwty++-- | Generates a unique name for a given type. This action will cache its+-- results, thus returning the same answer for the same @HWType@ argument.+-- Some type names do not have specific names, but are instead basic types+-- in VHDL.+tyName+  :: HWType+  -- ^ Type to name+  -> VHDLM Doc+tyName t = do+  nm <- tyName' False t+  pretty nm++-- | Generates a unique name for a given type. This action will cache its+-- results, thus returning the same answer for the same @HWType@ argument.+-- Some type names do not have specific names, but are instead basic types+-- in VHDL.+tyName'+  :: HasCallStack+  => Bool+  -- ^ Include length information in first part of name. For example, say we+  -- want to generate a name for a vector<signed>, where the vector is of length+  -- 5, and signed has 64 bits. When given `True`, this function would+  -- generate `array_of_5_signed_64`. When given `False` it would generate+  -- `array_of_signed_64`. Note that parts other than the first part will always+  -- have length information. This option is useful for generating names in+  -- VHDL, where the `False` case is needed to create generic types.+  -> HWType+  -- ^ Type to name+  -> VHDLM TextS.Text+tyName' rec0 (filterTransparent -> t) = do+  Ap (tyCache %= HashSet.insert t)+  case t of+    KnownDomain {} ->+      return (error ($(curLoc) ++ "Forced to print KnownDomain tyName"))+    Void _ ->+      return (error ($(curLoc) ++ "Forced to print Void tyName: " ++ show t))+    Bool          -> return "boolean"+    Signed n      ->+      let app = if rec0 then ["_", showt n] else [] in+      return $ TextS.concat $ "signed" : app+    Unsigned n    ->+      let app = if rec0 then ["_", showt n] else [] in+      return $ TextS.concat $ "unsigned" : app+    BitVector n   ->+      let app = if rec0 then ["_", showt n] else [] in+      return $ TextS.concat $ "std_logic_vector" : app+    String        -> return "string"+    Integer       -> return "integer"+    Bit           -> return "std_logic"+    Vector n elTy -> do+      elTy' <- tyName' True elTy+      let nm = TextS.concat [ "array_of_"+                            , if rec0 then showt n `TextS.append` "_" else ""+                            , elTy']+      Ap $ makeCached (t, rec0) nameCache (return nm)+    RTree n elTy  -> do+      elTy' <- tyName' True elTy+      let nm = TextS.concat [ "tree_of_"+                            , if rec0 then showt n `TextS.append` "_" else ""+                            , elTy']+      Ap $ makeCached (t, rec0) nameCache (return nm)+    -- TODO: nice formatting for Index. I.e., 2000 = 2e3, 1024 = 2pow10+    Index n ->+      return ("index_" `TextS.append` showt n)+    Clock nm0 ->+      let nm1 = "clk_" `TextS.append` nm0 in+      Ap $ makeCached (t, False) nameCache (userTyName "clk" nm1 t)+    ClockN nm0 ->+      let nm1 = "clk_n_" `TextS.append` nm0 in+      Ap $ makeCached (t, False) nameCache (userTyName "clk" nm1 t)+    Reset nm0 ->+      let nm1 = "rst_" `TextS.append` nm0 in+      Ap $ makeCached (t, False) nameCache (userTyName "rst" nm1 t)+    Enable nm0 ->+      let nm1 = "en_" `TextS.append` nm0 in+      Ap $ makeCached (t, False) nameCache (userTyName "en" nm1 t)+    Sum nm _  ->+      Ap $ makeCached (t, False) nameCache (userTyName "sum" nm t)+    CustomSum nm _ _ _ ->+      Ap $ makeCached (t, False) nameCache (userTyName "sum" nm t)+    SP nm _ ->+      Ap $ makeCached (t, False) nameCache (userTyName "sp" nm t)+    CustomSP nm _ _ _ ->+      Ap $ makeCached (t, False) nameCache (userTyName "sp" nm t)+    Product nm _ _ ->+      Ap $ makeCached (t, False) nameCache (userTyName "product" nm t)+    CustomProduct nm _ _ _ _ ->+      Ap $ makeCached (t, False) nameCache (userTyName "product" nm t)+    Annotated _ hwTy ->+      tyName' rec0 hwTy+    BiDirectional _ hwTy ->+      tyName' rec0 hwTy+    FileType -> return "file"+    ty -> return (error ($(curLoc) ++  show ty +++                         " not filtered by filterTransparent"))++-- | Returns underlying type of given HWType. That is, the type by which it+-- eventually will be represented in VHDL.+normaliseType :: RenderEnums -> HWType -> HWType+normaliseType enums@(RenderEnums e) hwty = case hwty of+  Void {} -> hwty+  KnownDomain {} -> hwty++  -- Base types:+  Bool          -> hwty+  Signed _      -> hwty+  Unsigned _    -> hwty+  BitVector _   -> hwty+  String        -> hwty+  Integer       -> hwty+  Bit           -> hwty+  FileType      -> hwty++  -- Complex types, for which a user defined type is made in VHDL:+  Vector _ _    -> hwty+  RTree _ _     -> hwty+  Product _ _ _ -> hwty+  Sum _ _       -> if e then hwty else BitVector (typeSize hwty)+  MemBlob n m   -> Vector n (BitVector m)++  -- Simple types, for which a subtype (without qualifiers) will be made in VHDL:+  Clock _           -> Bit+  ClockN _          -> Bit+  Reset _           -> Bit+  Enable _          -> Bool+  Index _           -> Unsigned (typeSize hwty)+  CustomSP _ _ _ _  -> BitVector (typeSize hwty)+  SP _ _            -> BitVector (typeSize hwty)+  CustomSum _ _ _ _ -> BitVector (typeSize hwty)+  CustomProduct {}  -> BitVector (typeSize hwty)++  -- Transparent types:+  Annotated _ elTy -> normaliseType enums elTy+  BiDirectional _ elTy -> normaliseType enums elTy++-- | Recursively remove transparent types from given type+filterTransparent :: HWType -> HWType+filterTransparent hwty = case hwty of+  Bool              -> hwty+  Signed _          -> hwty+  Unsigned _        -> hwty+  BitVector _       -> hwty+  String            -> hwty+  Integer           -> hwty+  Bit               -> hwty+  Clock _           -> hwty+  ClockN _          -> hwty+  Reset _           -> hwty+  Enable _          -> hwty+  Index _           -> hwty+  Sum _ _           -> hwty+  CustomSum _ _ _ _ -> hwty+  FileType          -> hwty++  MemBlob n m       -> Vector n (BitVector m)++  Vector n elTy     -> Vector n (filterTransparent elTy)+  RTree n elTy      -> RTree n (filterTransparent elTy)+  Product nm labels elTys  ->+    Product nm labels (map filterTransparent elTys)++  SP nm0 constrs ->+    SP nm0+      (map (\(nm1, tys) -> (nm1, map filterTransparent tys)) constrs)++  CustomSP nm0 drepr size constrs ->+    CustomSP nm0 drepr size+      (map (\(repr, nm1, tys) -> (repr, nm1, map filterTransparent tys)) constrs)++  CustomProduct nm0 drepr size maybeFieldNames constrs ->+    CustomProduct nm0 drepr size maybeFieldNames+      (map (second filterTransparent) constrs)++  -- Transparent types:+  Annotated _ elTy -> filterTransparent elTy+  BiDirectional _ elTy -> filterTransparent elTy++  Void {} -> hwty+  KnownDomain {} -> hwty++-- | Create a unique type name for user defined types+userTyName+  :: IdentifierText+  -- ^ Default name+  -> IdentifierText+  -- ^ Identifier stored in @hwTy@+  -> HWType+  -- ^ Type to give a (unique) name+  -> StateT VHDLState Identity IdentifierText+userTyName dflt nm0 hwTy = do+  tyCache %= HashSet.insert hwTy+  Id.toText <$> Id.makeBasicOr (last (TextS.splitOn "." nm0)) dflt++-- | Convert a Netlist HWType to an error VHDL value for that type+sizedQualTyNameErrValue :: HWType -> VHDLM Doc+sizedQualTyNameErrValue Bool                = do+  udf <- Ap (use undefValue)+  case udf of+    Just (Just 0) -> "false"+    _             -> "true"+sizedQualTyNameErrValue Bit                 = singularErrValue+sizedQualTyNameErrValue t@(Vector n elTy)   = do+  syn <-Ap hdlSyn+  case syn of+    Vivado -> qualTyName t <> "'" <> parens (int 0 <+> "to" <+> int (n-1) <+> rarrow <+>+                "std_logic_vector'" <> parens (int 0 <+> "to" <+> int (typeSize elTy - 1) <+>+                 rarrow <+> singularErrValue))+    _ -> qualTyName t <> "'" <> parens (int 0 <+> "to" <+> int (n-1) <+> rarrow <+> sizedQualTyNameErrValue elTy)+sizedQualTyNameErrValue t@(RTree n elTy)    = do+  syn <-Ap hdlSyn+  case syn of+    Vivado -> qualTyName t <> "'" <>  parens (int 0 <+> "to" <+> int (2^n - 1) <+> rarrow <+>+                "std_logic_vector'" <> parens (int 0 <+> "to" <+> int (typeSize elTy - 1) <+>+                 rarrow <+> singularErrValue))+    _ -> qualTyName t <> "'" <>  parens (int 0 <+> "to" <+> int (2^n - 1) <+> rarrow <+> sizedQualTyNameErrValue elTy)+sizedQualTyNameErrValue t@(Product _ _ elTys) =+  qualTyName t <> "'" <> tupled (mapM sizedQualTyNameErrValue elTys)+sizedQualTyNameErrValue t@(Sum _ _)  = do+  -- No undefined / don't care for enums, so just set it to the first value+  RenderEnums enums <- Ap renderEnums+  if enums then+    tyName t <> "'val" <> parens (int 0)+  else+    qualTyName t <> "'" <> parens (int 0 <+> "to" <+> int (typeSize t - 1) <+> rarrow <+> singularErrValue)+sizedQualTyNameErrValue (Clock _)  = singularErrValue+sizedQualTyNameErrValue (ClockN _) = singularErrValue+sizedQualTyNameErrValue (Reset _)  = singularErrValue+sizedQualTyNameErrValue (Enable _) = singularErrValue+sizedQualTyNameErrValue (Void {})  =+  return (error ($(curLoc) ++ "[CLASH BUG] Forced to print Void error value"))+sizedQualTyNameErrValue String              = "\"ERROR\""+sizedQualTyNameErrValue t =+  qualTyName t <> "'" <> parens (int 0 <+> "to" <+> int (typeSize t - 1) <+> rarrow <+> singularErrValue)++singularErrValue :: VHDLM Doc+singularErrValue = do+  udf <- Ap (use undefValue)+  case udf of+    Nothing       -> "'-'"+    Just Nothing  -> "'0'"+    Just (Just x) -> "'" <> int x <> "'"++vhdlRecSel+  :: HWType+  -> Int+  -> VHDLM Doc+vhdlRecSel p@(Product _ labels tys) i =+  tyName p <> selectProductField labels tys i+vhdlRecSel ty i =+  tyName ty <> "_sel" <> int i++decls :: [Declaration] -> VHDLM Doc+decls [] = emptyDoc+decls ds = do+    rec (dsDoc,ls) <- fmap (unzip . catMaybes) $ mapM (decl (maximum ls)) ds+    case dsDoc of+      [] -> emptyDoc+      _  -> vcat (pure dsDoc)++decl :: Int ->  Declaration -> VHDLM (Maybe (Doc,Int))+decl l (NetDecl' noteM id_ ty iEM) = Just <$> (,fromIntegral (TextS.length (Id.toText id_))) <$>+  maybe id addNote noteM ("signal" <+> fill l (pretty id_) <+> colon <+> sizedQualTyName ty <> iE <> semi)+  where+    addNote n = mappend ("--" <+> pretty n <> line)+    iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM++decl _ (InstDecl Comp _ attrs nm _ gens (NamedPortMap pms)) = fmap (Just . (,0)) $ do+  { rec (p,ls) <- fmap unzip $ sequence [ (,formalLength i) <$> fill (maximum ls) (expr_ False i) <+> colon <+> portDir dir <+> sizedQualTyName ty | (i,dir,ty,_) <- pms ]+  ; rec (g,lsg) <- fmap unzip $ sequence [ (,formalLength i) <$> fill (maximum lsg) (expr_ False i) <+> colon <+> tyName ty | (i,ty,_) <- gens]+  ; "component" <+> pretty nm <> line <>+    ( if null g then emptyDoc+        else indent 2 ("generic" <> line <> tupledSemi (pure g) <> semi) <> line+    )+    <> indent 2 ("port" <+> tupledSemi (pure p) <> semi) <> line <>+    "end component" <> semi <> line+    <> attrs'+  }+ where+    formalLength (Identifier i _) = fromIntegral (TextS.length (Id.toText i))+    formalLength _                = 0++    portDir In  = "in"+    portDir Out = "out"++    attrs'+      | null attrs = emptyDoc+      | otherwise = renderAttrs (TextS.pack "component") [(nm, a) | a <- attrs]++decl _ (CompDecl nm ps0) =+  fmap (Just . (,0)) $ "component" <+> pretty nm <+>+    ("port" <> line <> indent 2 (tupledSemi ps <> semi))+    <> line <> "end component" <> semi+  where ps = traverse (\(t,pd,ty) -> pretty t <+> ":" <+> ppd pd <+> sizedQualTyName ty) ps0+        ppd = \case { In -> "in"; Out -> "out"}++decl _ _ = return Nothing++noEmptyInit :: VHDLM Doc -> VHDLM Doc+noEmptyInit d = do+  d1 <- d+  if isEmpty d1+     then emptyDoc+     else (space <> ":=" <+> d)++stdMatch+  :: Bits a+  => Int+  -> a+  -> a+  -> String+stdMatch 0 _mask _value = []+stdMatch size mask value =+  symbol : stdMatch (size - 1) mask value+  where+    symbol =+      if testBit mask (size - 1) then+        if testBit value (size - 1) then+          '1'+        else+          '0'+      else+        '-'++patLitCustom'+  :: Bits a+  => VHDLM Doc+  -> Int+  -> a+  -> a+  -> VHDLM Doc+patLitCustom' var size mask value =+  let mask' = string $ T.pack $ stdMatch size mask value in+  "std_match" <> parens (dquotes mask' <> comma <+> var)++patLitCustom+  :: VHDLM Doc+  -> HWType+  -> Literal+  -> VHDLM Doc+patLitCustom var (CustomSum _name _dataRepr size reprs) (NumLit (fromIntegral -> i)) =+  patLitCustom' var size mask value+    where+      ((ConstrRepr' _name _n mask value _anns), _id) = reprs !! i++patLitCustom var (CustomSP _name _dataRepr size reprs) (NumLit (fromIntegral -> i)) =+  patLitCustom' var size mask value+    where+      ((ConstrRepr' _name _n mask value _anns), _id, _tys) = reprs !! i++patLitCustom _ x y = error $ $(curLoc) ++ unwords+  [ "You can only pass CustomSP / CustomSum and a NumLit to this function,"+  , "not", show x, "and", show y]++insts :: [Declaration] -> VHDLM Doc+insts [] = emptyDoc+insts (TickDecl (Comment c):ds) = comment "--" c <> line <> insts ds+insts (TickDecl (Directive d):ds) = pretty d <> ";" <> line <> insts ds+insts (d:ds) = do+  d' <- inst_ d+  case d' of+    Just doc -> pure doc <> line <> line <> insts ds+    _ -> insts ds++-- | Helper function for inst_, handling CustomSP and CustomSum+inst_'+  :: Identifier+  -> Expr+  -> HWType+  -> [(Maybe Literal, Expr)]+  -> VHDLM (Maybe Doc)+inst_' id_ scrut scrutTy es = fmap Just $+  (pretty id_ <+> larrow <+> align (vcat (conds esNub) <> semi))+    where+      esMod = map (first (fmap (patMod scrutTy))) es+      esNub = nubBy ((==) `on` fst) esMod+      var   = expr_ True scrut++      conds :: [(Maybe Literal,Expr)] -> VHDLM [Doc]+      conds []                = return []+      conds [(_,e)]           = expr_ False e <:> return []+      conds ((Nothing,e):_)   = expr_ False e <:> return []+      conds ((Just c ,e):es') = expr_ False e <+> "when"+                                              <+> patLitCustom var scrutTy c+                                              <+> "else"+                                              <:> conds es'++-- | Turn a Netlist Declaration to a VHDL concurrent block+inst_ :: Declaration -> VHDLM (Maybe Doc)+inst_ (Assignment id_ Cont e) = fmap Just $+  pretty id_ <+> larrow <+> align (expr_ False e) <> semi++inst_ (CondAssignment id_ _ scrut _ [(Just (BoolLit b), l),(_,r)]) = fmap Just $+  pretty id_ <+> larrow+           <+> align (vsep (sequence [expr_ False t <+> "when" <+>+                                      expr_ False scrut <+> "else"+                                     ,expr_ False f <> semi+                                     ]))+  where+    (t,f) = if b then (l,r) else (r,l)++inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSP _ _ _ _) es) =+  inst_' id_ scrut scrutTy es++inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSum _ _ _ _) es) =+  inst_' id_ scrut scrutTy es++inst_ (CondAssignment id_ _ scrut scrutTy@(CustomProduct _ _ _ _ _) es) =+  inst_' id_ scrut scrutTy es++inst_ (CondAssignment id_ _sig scrut scrutTy es) = fmap Just $+    "with" <+> parens (expr_ True scrut) <+> "select" <> line <>+      indent 2 (pretty id_ <+> larrow <+> align (vcat (punctuate comma (conds esNub)) <> semi))+  where+    esMod = map (first (fmap (patMod scrutTy))) es+    esNub = nubBy ((==) `on` fst) esMod++    conds :: [(Maybe Literal,Expr)] -> VHDLM [Doc]+    conds []                = return []+    conds [(_,e)]           = expr_ False e <+> "when" <+> "others" <:> return []+    conds ((Nothing,e):_)   = expr_ False e <+> "when" <+> "others" <:> return []+    conds ((Just c ,e):es') = expr_ False e <+> "when" <+> patLit scrutTy c <:> conds es'++inst_ (InstDecl entOrComp libM _ nm lbl gens pms0) = do+    maybe (return ()) (\lib -> Ap (libraries %= (T.fromStrict lib:))) libM+    fmap Just $+      nest 2 $ pretty lbl <+> colon <> entOrComp'+                <+> maybe emptyDoc ((<> ".") . pretty) libM <> pretty nm <> line <> gms <> pms2 <> semi+  where+    gms | [] <- gens = emptyDoc+        | otherwise =  do+      rec (p,ls) <- fmap unzip $ sequence [ (,formalLength i) <$> fill (maximum ls) (expr_ False i) <+> "=>" <+> expr_ False e | (i,_,e) <- gens]+      nest 2 ("generic map" <> line <> tupled (pure p)) <> line+    pms2 = do+      rec (p,ls) <- case pms0 of+                      NamedPortMap pms1 -> fmap unzip $ sequence [pm ls i e | (i,_,_,e) <- pms1]+                      IndexedPortMap pms1 -> fmap unzip $ sequence [pmi e | (_,_,e) <- pms1]+      nest 2 $ "port map" <> line <> tupled (pure p)++    pm ls i e = (,formalLength i) <$> fill (maximum ls) (expr_ False i) <+> "=>" <+> expr_ False e+    pmi e = (,0) <$> expr_ False e++    formalLength (Identifier i _) = fromIntegral (TextS.length (Id.toText i))+    formalLength _                = 0+    entOrComp' = case entOrComp of { Entity -> " entity"; Comp -> " component"; Empty -> ""}++inst_ (BlackBoxD _ libs imps inc bs bbCtx) =+  fmap Just (Ap (column (renderBlackBox libs imps inc bs bbCtx)))++inst_ (ConditionalDecl cond _) = do+  traceM+    $ "WARNING: Conditional compilation is not supported in VHDL. Discarding code conditional on "+    <> TextS.unpack cond+  return Nothing++inst_ _ = return Nothing++-- | Render a data constructor application for data constructors having a+-- custom bit representation.+customReprDataCon+  :: DataRepr'+  -- ^ Custom representation of data type+  -> ConstrRepr'+  -- ^ Custom representation of a specific constructor of @dataRepr@+  -> [(HWType, Expr)]+  -- ^ Arguments applied to constructor+  -> VHDLM Doc+customReprDataCon dataRepr constrRepr args =+  "std_logic_vector'" <> parens (hcat $ punctuate " & " $ mapM range origins)+    where+      DataRepr' _typ size _constrs = dataRepr++      -- Build bit representations for all constructor arguments+      argSLVs = map (uncurry toSLV) args :: [VHDLM Doc]++      -- Spread bits of constructor arguments using masks+      origins = bitOrigins dataRepr constrRepr :: [BitOrigin]++      range+        :: BitOrigin+        -> VHDLM Doc+      range (Lit (bitsToBits -> ns)) =+        dquotes $ hcat $ mapM bit_char ns+      range (Field n start end) =+        -- We want to select the bits starting from 'start' downto and including+        -- 'end'. We cannot use "(start downto end)" in VHDL, as the preceeding+        -- expression might be anything. This notation only works on identifiers+        -- unfortunately.+        let fsize = start - end + 1 in+        let expr' = argSLVs !! n in++        -- HACK: While expr' is a std_logic_vector (see call `toSLV`), it cannot+        -- be cast to unsigned in case of literals. This is fixed by explicitly+        -- casting it to std_logic_vector.+        let unsigned = "unsigned" <> parens ("std_logic_vector'" <> parens expr') in++        if | fsize == size ->+               -- If sizes are equal, rotating / resizing amounts to doing nothing+               expr'+           | end == 0 ->+               -- Rotating is not necessary if relevant bits are already at the end+               let resized = "resize" <> parens (unsigned <> comma <> int fsize) in+               "std_logic_vector" <> parens resized+           | otherwise ->+               -- Select bits 'start' downto and including 'end'+               let rotated  = unsigned <+> "srl" <+> int end in+               let resized = "resize" <> parens (rotated <> comma <> int fsize) in+               "std_logic_vector" <> parens resized++-- | Turn a Netlist expression into a VHDL expression+expr_+  :: HasCallStack+  => Bool+  -- ^ Enclose in parentheses?+  -> Expr+  -- ^ Expr to convert+  -> VHDLM Doc+expr_ _ (Literal sizeM lit) = exprLit sizeM lit+expr_ _ (Identifier id_ Nothing) = pretty id_++expr_ _ (Identifier id_ (Just m)) = do+  syn <- Ap hdlSyn+  maybe (pretty id_) (foldr renderModifier (pretty id_)) (buildModifier syn [] m)++expr_ b (DataCon _ (DC (Void {}, -1)) [e]) =  expr_ b e++expr_ _ (DataCon ty@(Vector 0 _) _ _) = sizedQualTyNameErrValue ty++expr_ _ (DataCon ty@(Vector 1 elTy) _ [e])       = do+  syn <- Ap hdlSyn+  case syn of+    Vivado -> qualTyName ty <> "'" <> parens (int 0 <+> rarrow <+> toSLV elTy e)+    _ -> qualTyName ty <> "'" <> parens (int 0 <+> rarrow <+> expr_ False e)+expr_ _ e@(DataCon ty@(Vector _ elTy) _ [e1,e2]) = do+  syn <- Ap hdlSyn+  case syn of+    -- When targeting Vivado, arrays must use std_logic_vector for elements.+    Vivado -> qualTyName ty <> "'" <> case vectorChain e of+      Just es -> align (tupled (mapM (toSLV elTy) es))+      Nothing -> parens ("std_logic_vector'" <> parens (toSLV elTy e1) <+> "&" <+> expr_ False e2)+    _ -> qualTyName ty <> "'" <> case vectorChain e of+            Just es -> align (tupled (mapM (expr_ False) es))+            Nothing -> parens (qualTyName elTy <> "'" <> parens (expr_ False e1) <+> "&" <+> expr_ False e2)++expr_ _ (DataCon ty@(MemBlob n m) _ [n0, m0, _, runs, _, ends])+  | Literal _ (NumLit n1) <- n0+  , n == fromInteger n1+  , Literal _ (NumLit m1) <- m0+  , m == fromInteger m1+  , Literal Nothing (StringLit runs0) <- runs+  , Literal Nothing (StringLit ends0) <- ends+  , es <- unpackNats n m (B8.pack runs0) (B8.pack ends0) =+    let el val = exprLit (Just (BitVector m, m)) (BitVecLit 0 $ toInteger val)+    in qualTyName ty <> "'" <> (align $ tupled $ mapM el es)++expr_ _ (DataCon ty@(RTree 0 elTy) _ [e]) = do+  syn <- Ap hdlSyn+  case syn of+    Vivado -> qualTyName ty <> "'" <> parens (int 0 <+> rarrow <+> toSLV elTy e)+    _ -> qualTyName ty <> "'" <> parens (int 0 <+> rarrow <+> expr_ False e)+expr_ _ e@(DataCon ty@(RTree d elTy) _ [e1,e2]) = qualTyName ty <> "'" <> case rtreeChain e of+  Just es -> tupled (mapM (expr_ False) es)+  Nothing -> parens (qualTyName (RTree (d-1) elTy) <> "'" <> parens (expr_ False e1) <+>+                     "&" <+> expr_ False e2)++expr_ _ (DataCon (SP {}) (DC (BitVector _,_)) es) = assignExpr+  where+    argExprs   = map (parens . expr_ False) es+    assignExpr = "std_logic_vector'" <> parens (hcat $ punctuate " & " $ sequence argExprs)++expr_ _ (DataCon ty@(SP _ args) (DC (_,i)) es) = assignExpr+  where+    argTys     = snd $ args !! i+    dcSize     = conSize ty + sum (map typeSize argTys)+    dcExpr     = expr_ False (dcToExpr ty i)+    argExprs   = map parens (zipWith toSLV argTys es)+    extraArg   = case typeSize ty - dcSize of+                   0 -> []+                   n -> [bits (replicate n U)]+    assignExpr = "std_logic_vector'" <> parens (hcat $ punctuate " & " $ sequence (dcExpr:argExprs ++ extraArg))++expr_ _ (DataCon ty@(Sum _ _) (DC (_,i)) []) = do+  RenderEnums enums <- Ap renderEnums+  if enums then+    tyName ty <> "'" <> parens (enumVariantName ty i)+  else+    expr_ False (dcToExpr ty i)+expr_ _ (DataCon ty@(CustomSum _ _ _ tys) (DC (_,i)) []) =+  let (ConstrRepr' _ _ _ value _) = fst $ tys !! i in+  "std_logic_vector" <> parens ("to_unsigned" <> parens (int (fromIntegral value) <> comma <> int (typeSize ty)))+expr_ _ (DataCon (CustomSP _ dataRepr _size args) (DC (_,i)) es) =+  let (cRepr, _, argTys) = args !! i in+  customReprDataCon dataRepr cRepr (zipEqual argTys es)+expr_ _ (DataCon (CustomProduct _ dataRepr _size _labels tys) _ es) |+  DataRepr' _typ _size [cRepr] <- dataRepr =+  customReprDataCon dataRepr cRepr (zipEqual (map snd tys) es)++expr_ _ (DataCon ty@(Product _ labels tys) _ es) =+    tupled $ zipWithM (\i e' -> tyName ty <> selectProductField labels tys i <+> rarrow <+> expr_ False e') [0..] es++expr_ _ (DataCon (Enable _) _ [e]) =+  expr_ False e++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.Signed.fromInteger#"+  , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx+  = exprLit (Just (Signed (fromInteger n),fromInteger n)) i++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.Unsigned.fromInteger#"+  , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx+  = exprLit (Just (Unsigned (fromInteger n),fromInteger n)) i++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.BitVector.fromInteger#"+  , [Literal _ (NumLit n), Literal _ m, Literal _ i] <- extractLiterals bbCtx+  , NumLit m' <- m+  , NumLit i' <- i+  = exprLit (Just (BitVector (fromInteger n),fromInteger n)) (BitVecLit m' i')++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.BitVector.fromInteger##"+  , [Literal _ m, Literal _ i] <- extractLiterals bbCtx+  , NumLit m' <- m+  , NumLit i' <- i+  = exprLit (Just (Bit,1)) (BitLit $ toBit m' i')++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.Index.fromInteger#"+  , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx+  , Just k <- clogBase 2 n+  , let k' = max 1 k+  = exprLit (Just (Index n,k')) i++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.Index.maxBound#"+  , [Literal _ (NumLit n)] <- extractLiterals bbCtx+  , n > 0+  , Just k <- clogBase 2 n+  , let k' = max 1 k+  = exprLit (Just (Unsigned k',k')) (NumLit (n-1))++expr_ b (BlackBoxE _ libs imps inc bs bbCtx b') = do+  parenIf (b || b') (Ap (renderBlackBox libs imps inc bs bbCtx <*> pure 0))++expr_ _ (DataTag Bool (Left id_)) = "tagToEnum" <> parens (pretty id_)+expr_ _ (DataTag Bool (Right id_)) = "dataToTag" <> parens (pretty id_)++expr_ _ (DataTag hty@(Sum _ _) (Left id_)) = do+  RenderEnums enums <- Ap renderEnums+  nm <- Ap $ use modNm++  let inner = "std_logic_vector" <> parens ("resize" <> parens ("unsigned" <> parens ("std_logic_vector" <> parens (pretty id_)) <> "," <> int (typeSize hty)))+  if enums then pretty nm <> "_types.fromSLV" <> parens inner else inner++expr_ _ (DataTag (Sum _ _) (Right id_)) = do+  RenderEnums enums <- Ap renderEnums+  iw <- Ap $ use intWidth+  nm <- Ap $ use modNm++  let inner = if enums then pretty nm <> "_types.toSLV" <> parens (pretty id_) else pretty id_+  "signed" <> parens ("std_logic_vector" <> parens ("resize" <> parens ("unsigned" <> parens inner <> "," <> int iw)))++expr_ _ (DataTag (Product {}) (Right _))  = do+  iw <- Ap $ use intWidth+  "to_signed" <> parens (int 0 <> "," <> int iw)+expr_ _ (DataTag hty@(SP _ _) (Right id_)) = do {+    ; iw <- Ap $ use intWidth+    ; "signed" <> parens ("std_logic_vector" <> parens (+      "resize" <> parens ("unsigned" <> parens (pretty id_ <> parens (int start <+> "downto" <+> int end))+                          <> "," <> int iw)))+    }+  where+    start = typeSize hty - 1+    end   = typeSize hty - conSize hty++expr_ _ (DataTag (Vector 0 _) (Right _)) = do+  iw <- Ap $ use intWidth+  "to_signed" <> parens (int 0 <> "," <> int iw)+expr_ _ (DataTag (Vector _ _) (Right _)) = do+  iw <- Ap $ use intWidth+  "to_signed" <> parens (int 1 <> "," <> int iw)++expr_ _ (DataTag (RTree 0 _) (Right _)) = do+  iw <- Ap $ use intWidth+  "to_signed" <> parens (int 0 <> "," <> int iw)+expr_ _ (DataTag (RTree _ _) (Right _)) = do+  iw <- Ap $ use intWidth+  "to_signed" <> parens (int 1 <> "," <> int iw)++expr_ _ (ToBv topM hwty e) = do+  nm <- Ap $ use modNm+  case topM of+    Nothing -> pretty nm <> "_types" <> dot <> "toSLV" <>+               parens (qualTyName hwty <> "'" <> parens (expr_ False e))+    Just t  -> pretty t <> dot <> pretty t <> "_types" <> dot <> "toSLV" <> parens (expr_ False e)++expr_ _ (FromBv topM hwty e) = do+  nm <- Ap $ use modNm+  qualTyName hwty <> "'" <> parens+    (maybe (pretty nm <> "_types" ) (\t -> pretty t <> dot <> pretty t <> "_types") topM <>+     dot <> "fromSLV" <> parens (expr_ False e))++expr_ _ e = error $ $(curLoc) ++ (show e) -- empty++otherSize :: [HWType] -> Int -> Int+otherSize _ n | n < 0 = 0+otherSize []     _    = 0+otherSize (a:as) n    = typeSize a + otherSize as (n-1)++vectorChain :: Expr -> Maybe [Expr]+vectorChain (DataCon (Vector 0 _) _ _)        = Just []+vectorChain (DataCon (Vector 1 _) _ [e])     = Just [e]+vectorChain (DataCon (Vector _ _) _ [e1,e2]) = Just e1 <:> vectorChain e2+vectorChain _                                       = Nothing++rtreeChain :: Expr -> Maybe [Expr]+rtreeChain (DataCon (RTree 1 _) _ [e])     = Just [e]+rtreeChain (DataCon (RTree _ _) _ [e1,e2]) = liftA2 (++) (rtreeChain e1) (rtreeChain e2)+rtreeChain _ = Nothing++exprLit :: Maybe (HWType,Size) -> Literal -> VHDLM Doc+exprLit Nothing (NumLit i) = integer i++exprLit (Just (hty,sz)) (NumLit i) = case hty of+  Unsigned n+    | i <= (-2^(31 :: Integer))-> "unsigned" <> parens ("std_logic_vector" <> parens ("signed'" <> parens lit))+    | i < 0                    -> "unsigned" <> parens ("std_logic_vector" <> parens ("to_signed" <> parens(integer i <> "," <> int n)))+    | i < 2^(31 :: Integer) -> "to_unsigned" <> parens (integer i <> "," <> int n)+    | otherwise -> "unsigned'" <> parens lit+  Index n+   | 0 <= i && i < n -> exprLit (Just (Unsigned sz, sz)) (NumLit i)  -- reuse Unsigned implementation above+   | otherwise       -> hdlTypeErrValue hty+  Signed n+    | i < 2^(31 :: Integer) && i > (-2^(31 :: Integer)) -> "to_signed" <> parens (integer i <> "," <> int n)+    | otherwise -> "signed'" <> parens lit+  BitVector _ -> "std_logic_vector'" <> parens lit+  Bit         -> squotes (int (fromInteger i `mod` 2))+  _           -> blit++  where+    validHexLit = sz `mod` 4 == 0 && sz /= 0+    lit = if validHexLit then hlit else blit+    blit = bits (toBits sz i)+    i'   = case hty of+             Signed _ -> let mask = 2^(sz-1) in case divMod i mask of+                (s,i'') | even s    -> i''+                        | otherwise -> i'' - mask+             _ -> i `mod` 2^sz+    hlit = (if i' < 0 then "-" else emptyDoc) <> hex (toHex sz i')++exprLit (Just (hty,sz)) (BitVecLit m i) = case m of+  0 -> exprLit (Just (hty,sz)) (NumLit i)+  _ -> "std_logic_vector'" <> parens bvlit+  where+    bvlit = bits (toBits' sz m i)+++exprLit _             (BoolLit t)   = if t then "true" else "false"+exprLit _             (BitLit b)    = squotes $ bit_char b+exprLit _             (StringLit s) = pretty . T.pack $ show s+exprLit _             l             = error $ $(curLoc) ++ "exprLit: " ++ show l++patLit :: HWType -> Literal -> VHDLM Doc+patLit Bit (NumLit i) = if i == 0 then "'0'" else "'1'"+patLit hwty (NumLit i) = do+  RenderEnums enums <- Ap renderEnums++  case hwty of+    Sum{} | enums ->+      tyName hwty <> "'" <> parens (enumVariantName hwty (fromInteger i))++    _ ->+      let sz = conSize hwty+       in case sz `mod` 4 of+            0 -> hex  (toHex sz i)+            _ -> bits (toBits sz i)++patLit _    l          = exprLit Nothing l++patMod :: HWType -> Literal -> Literal+patMod hwTy (NumLit i) = NumLit (i `mod` (2 ^ typeSize hwTy))+patMod _ l = l++toBits :: Integral a => Int -> a -> [Bit]+toBits size val = map (\x -> if odd x then H else L)+                $ reverse+                $ take size+                $ map (`mod` 2)+                $ iterate (`div` 2) val++toBits' :: Integral a => Int -> a -> a -> [Bit]+toBits' size msk val = map (\(m,i) -> if odd m then U else (if odd i then H else L))+                $+                ( reverse . take size)+                $ zip+                  ( map (`mod` 2) $ iterate (`div` 2) msk)+                  ( map (`mod` 2) $ iterate (`div` 2) val)++bits :: [Bit] -> VHDLM Doc+bits = dquotes . hcat . mapM bit_char++toHex :: Int -> Integer -> String+toHex sz i = case clogBase 16 (2^sz) of+  Just d -> printf ("%0" ++ show d ++ "X") (abs i)+  _ -> error "toHex: impossible"++hex :: String -> VHDLM Doc+hex s = char 'x' <> dquotes (pretty (T.pack s))++bit_char :: Bit -> VHDLM Doc+bit_char H = char '1'+bit_char L = char '0'+bit_char U = do+  udf <- Ap (use undefValue)+  case udf of+    Nothing -> char '-'+    Just Nothing -> char '0'+    Just (Just i) -> int i+bit_char Z = char 'Z'++toSLV :: HasCallStack => HWType -> Expr -> VHDLM Doc+toSLV Bool         e = do+  nm <- Ap $ use modNm+  pretty nm <> "_types.toSLV" <> parens (expr_ False e)+toSLV Bit          e = do+  nm <- Ap $ use modNm+  pretty nm <> "_types.toSLV" <> parens (expr_ False e)+toSLV (Clock {})    e = do+  nm <- Ap $ use modNm+  pretty nm <> "_types.toSLV" <> parens (expr_ False e)+toSLV (ClockN {})   e = do+  nm <- Ap $ use modNm+  pretty nm <> "_types.toSLV" <> parens (expr_ False e)+toSLV (Reset {})    e = do+  nm <- Ap $ use modNm+  pretty (TextS.toLower nm) <> "_types.toSLV" <> parens (expr_ False e)+toSLV (Enable _)    e = do+  nm <- Ap $ use modNm+  pretty nm <> "_types.toSLV" <> parens (expr_ False e)+toSLV (BitVector _) e = expr_ True e+toSLV (Signed _)   e = "std_logic_vector" <> parens (expr_ False e)+toSLV (Unsigned _) e = "std_logic_vector" <> parens (expr_ False e)+toSLV (Index _)    e = "std_logic_vector" <> parens (expr_ False e)+toSLV (Sum _ _)    e = do+  RenderEnums enums <- Ap renderEnums+  if enums then do+    nm <- Ap $ use modNm+    pretty nm <> "_types.toSLV" <> parens (expr_ False e)+  else+    expr_ False e+toSLV (CustomSum _ _dataRepr size reprs) (DataCon _ (DC (_,i)) _) =+  let (ConstrRepr' _ _ _ value _) = fst $ reprs !! i in+  let unsigned = "to_unsigned" <> parens (int (fromIntegral value) <> comma <> int size) in+  "std_logic_vector" <> parens unsigned+toSLV (CustomSum {}) e = "std_logic_vector" <> parens (expr_ False e)+toSLV t@(Product _ labels tys) (Identifier id_ Nothing) = do+    selIds' <- sequence selIds+    encloseSep lparen rparen " & " (zipWithM toSLV tys selIds')+  where+    tName    = tyName t+    selNames = map (fmap (Id.unsafeMake . T.toStrict . renderOneLine) ) [pretty id_ <> dot <> tName <> selectProductField labels tys i | i <- [0..(length tys)-1]]+    selIds   = map (fmap (\n -> Identifier n Nothing)) selNames+toSLV (Product _ _ tys) (DataCon _ _ es) | equalLength tys es =+  -- Need equalLenght for code seen in ZipWithUnitVector+  encloseSep lparen rparen " & " (zipWithM toSLV tys es)+toSLV (CustomProduct _ _ _ _ _) e = do+  -- Custom representations are represented as bitvectors in HDL, so we don't+  -- need to do anything.+  expr_ False e+toSLV t@(Product _ _ _) e = do+  nm <- Ap $ use modNm+  pretty nm <> "_types.toSLV" <> parens (qualTyName t <> "'" <> parens (expr_ False e))+toSLV (SP _ _) e       = expr_ False e+toSLV (CustomSP _ _ _ _) e =+  -- Custom representations are represented as bitvectors in HDL, so we don't+  -- need to do anything.+  expr_ False e+toSLV (Vector n elTy) (Identifier id_ Nothing) = do+    selIds' <- sequence selIds+    syn <- Ap hdlSyn+    parens (vcat $ punctuate " & "+      (case syn of+        Vivado -> mapM (expr_ False) selIds'+        _ -> mapM (toSLV elTy) selIds'))+  where+    selNames = map (fmap (Id.unsafeMake . T.toStrict . renderOneLine) ) $ [pretty id_ <> parens (int i) | i <- [0 .. (n-1)]]+    selIds   = map (fmap (`Identifier` Nothing)) selNames+-- Don't split up newtype wrappers, or void-filtered types+toSLV (Vector _ _) e@(DataCon _ (DC (Void Nothing, -1)) _) = do+  nm <- Ap $ use modNm+  pretty nm <> "_types.toSLV" <> parens (expr_ False e)+toSLV (Vector n elTy) (DataCon _ _ es) =+  "std_logic_vector'" <> (parens $ vcat $ punctuate " & " (zipWithM toSLV [elTy,Vector (n-1) elTy] es))+toSLV (Vector _ _) e = do+  nm <- Ap $ use modNm+  pretty nm <> "_types.toSLV" <> parens (expr_ False e)+toSLV (RTree _ _) e = do+  nm <- Ap (use modNm)+  pretty (TextS.toLower nm) <> "_types.toSLV" <> parens (expr_ False e)+toSLV hty e = error $ $(curLoc) ++  "toSLV:\n\nType: " ++ show hty ++ "\n\nExpression: " ++ show e++dcToExpr :: HWType -> Int -> Expr+dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i))++larrow :: VHDLM Doc+larrow = "<="++rarrow :: VHDLM Doc+rarrow = "=>"++parenIf :: Monad m => Bool -> Ap m Doc -> Ap m Doc+parenIf True  = parens+parenIf False = id++punctuate' :: Monad m => Ap m Doc -> Ap m [Doc] -> Ap m Doc+punctuate' s d = vcat (punctuate s d) <> s++encodingNote :: HWType -> VHDLM Doc+encodingNote (Clock _)  = "-- clock" <> line+encodingNote (ClockN _) = "-- clock (neg phase)" <> line+encodingNote (Reset _)  = "-- reset" <> line+encodingNote (Enable _) = "-- enable" <> line+encodingNote (Annotated _ t) = encodingNote t+encodingNote _          = emptyDoc++tupledSemi :: Applicative f => f [Doc] -> f Doc+tupledSemi = align . encloseSep (flatAlt (lparen <+> emptyDoc) lparen)+                                (flatAlt (emptyDoc <+> rparen) rparen)+                                (semi <+> emptyDoc)++-- | VHDL name modifiers+data VHDLModifier+  -- | SLV slice (descending index)+  = Range    Range+  -- | Element selection+  | Idx      Int+  -- | Array slice (ascending index)+  | Slice    Int Int+  -- | Selected names+  | Select   (VHDLM Doc)+  -- | Projecting a 'Word#' out of a 'Word8', or 'Int#' ouf of an 'Int8', see+  -- [Note] integer projection+  | Resize+  -- | Projecting a 'Natural' out of a 'BitVector', see [Note] bitvector projection+  | ResizeAndConvert+  -- | Projecting the mask out of a 'BitVector', see [Note] mask projection+  | DontCare++-- | Create a sequence of VHDL name modifiers from our internal 'Modifier'+-- data type. Note that the modifiers are in "reverse" order, so build a+-- complete modified name using 'foldr' over the list by this function.+--+-- [Note] Continuing from an SLV slice+-- SOP and custom products are represented as std_logic_vector, this means that+-- their elements are also std_logic_vector. So when we project an element out+-- of an SOP or custom project, and want to do a further projection on that,+-- we have to do further SLV slicing; instead of e.g. creating a 'selected'+-- modifier. Finally, when we render the modified name, we have to check+-- whether the ultimately projected type needs to be converted from this SLV+-- slice, to the proper type.+buildModifier+  :: HasCallStack+  => HdlSyn+  -> [(VHDLModifier,HWType)]+  -- ^ The list of modifiers so far, note that this list is in reverse order+  -- in which they should eventually be applied to the name we want to modify+  -> Modifier+  -> Maybe [(VHDLModifier,HWType)]+  -- ^ 'Nothing' indicates that the 'Modifier' does not result into a VHDL name+  -- modifier. i.e. we can use the identifier as is; this happens when we get+  -- projections out of product types with only one non-zero field.+buildModifier _ prevM (Sliced (_,start,end)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      Just (first Range (continueWithRange [(start,end)] hty r) : rest)+  _ ->+      Just ((Range (Contiguous start end),hty) : prevM)+ where+  hty = BitVector (start-end+1)++buildModifier _ prevM (Indexed (ty@(SP _ args),dcI,fI)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      Just (first Range (continueWithRange [(start,end)] argTy r) : rest)+  _ ->+      Just ((Range (Contiguous start end),argTy) : prevM)+ where+  argTys   = snd (indexNote "SOP type: invalid constructor index" args dcI)+  argTy    = indexNote "SOP type: invalid field index" argTys fI+  argSize  = typeSize argTy+  other    = otherSize argTys (fI-1)+  start    = typeSize ty - 1 - conSize ty - other+  end      = start - argSize + 1++buildModifier _ prevM (Indexed (ty@(Product _ labels tys),_,fI)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let argSize = typeSize argTy+          otherSz = otherSize tys (fI - 1)+          start   = typeSize ty - 1 - otherSz+          end     = start - argSize + 1+      in  Just (first Range (continueWithRange [(start,end)] argTy r) : rest)+  _ ->+      let d = dot <> tyName ty <> selectProductField labels tys fI+      in  Just ((Select d,argTy):prevM)+ where+  argTy = indexNote "Product type: invalid field index" tys fI++buildModifier syn prevM (Indexed (ty@(Vector _ argTy),1,0)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let argSize = typeSize argTy+          start   = typeSize ty - 1+          end     = start - argSize + 1+      in  Just (first Range (continueWithRange [(start,end)] argTy r) : rest)+    | (Slice start _,Vector _ argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we just pick its first element+      Just (vivadoRange syn argTy ((Idx start,argTy):rest))+  _ ->+      Just (vivadoRange syn argTy ((Idx 0,argTy):prevM))++buildModifier _ prevM (Indexed (ty@(Vector n argTy),1,1)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let argSize = typeSize argTy+          start   = typeSize ty - argSize - 1+      in  Just (first Range (continueWithRange [(start,0)] tyN r) : rest)+    | (Slice start end,Vector _ argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we just pick the tail of that slice+      Just ((Slice (start + 1) end,tyN) : rest)+  _ ->+      Just ((Slice 1 (n-1),tyN) : prevM)+ where+  tyN = Vector (n-1) argTy++buildModifier syn prevM (Indexed (ty@(RTree _ argTy),0,0)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let start = typeSize ty - 1+      in  Just (first Range (continueWithRange [(start,0)] argTy r) : rest)+    | (Slice start _,RTree _ argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we just pick its first element+      Just (vivadoRange syn argTy ((Idx start,argTy):rest))+  _ ->+      Just (vivadoRange syn argTy ((Idx 0,argTy):prevM))++buildModifier _ prevM (Indexed (ty@(RTree d argTy),1,0)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let start = typeSize ty - 1+          end   = typeSize ty `div` 2+      in  Just (first Range (continueWithRange [(start,end)] tyN r) : rest)+    | (Slice start _,RTree _ argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we just pick the left half+      Just ((Slice start (start+z-1),tyN) : rest)+  _ ->+      Just ((Slice 0 (z-1),tyN) : prevM)+ where+  tyN = RTree (d-1) argTy+  z   = 2^(d - 1)++buildModifier _ prevM (Indexed (ty@(RTree d argTy),1,1)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let start = typeSize ty `div` 2 - 1+      in  Just (first Range (continueWithRange [(start,0)] tyN r) : rest)+    | (Slice _ end,RTree _ argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we just pick the right half+      Just ((Slice (end - z + 1) end,tyN) : rest)+  _ ->+      Just ((Slice z (z'-1),tyN) : prevM)+ where+  tyN = RTree (d-1) argTy+  z   = 2^(d - 1)+  z'  = 2^d++-- This is a HACK for Clash.Netlist.Util.mkTopOutput+-- Vector's don't have a 10'th constructor, this is just so that we can+-- recognize the particular case+buildModifier syn prevM (Indexed (ty@(Vector _ argTy),10,fI)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let argSize = typeSize argTy+          start   = typeSize ty - (fI * argSize) - 1+          end     = start - argSize + 1+      in  Just (first Range (continueWithRange [(start,end)] argTy r) : rest)+    | (Slice start _,Vector _ argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we offset from its starting element+      Just (vivadoRange syn argTy ((Idx (start+fI),argTy):rest))+  _ ->+      Just (vivadoRange syn argTy (((Idx fI,argTy):prevM)))++-- This is a HACK for Clash.Netlist.Util.mkTopOutput+-- RTree's don't have a 10'th constructor, this is just so that we can+-- recognize the particular case+buildModifier syn prevM (Indexed (ty@(RTree _ argTy),10,fI)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      let argSize = typeSize argTy+          start   = typeSize ty - (fI * argSize) - 1+          end     = start - argSize + 1+      in  Just (first Range (continueWithRange [(start,end)] argTy r) : rest)+    | (Slice start _,RTree 1 argTyP) <- prev+    , argTy == argTyP ->+      -- If the last modifier was an array slice, we offset from its starting element+      Just (vivadoRange syn argTy ((Idx (start+fI),argTy):rest))+  _ ->+      Just (vivadoRange syn argTy ((Idx fI,argTy):prevM))++buildModifier _ prevM (Indexed (CustomSP _ dataRepr size args,dcI,fI))+  | Void {} <- argTy+  = error (unexpectedProjectionErrorMsg dataRepr dcI fI)+  | otherwise+  = case prevM of+    (prev:rest)+      | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+        Just (first Range (continueWithRange ses argTy r) : rest)+    _ ->+        Just (first Range (continueWithRange ses argTy (Contiguous (size-1) 0)) : prevM)+ where+  (ConstrRepr' _name _n _mask _value anns, _, argTys) =+    indexNote "Custom SOP type: invalid constructor index" args dcI+  ses = bitRanges (indexNote "Custom SOP type: invalid annotation index" anns fI)+  argTy = indexNote "Custom SOP type: invalid field index" argTys fI++buildModifier _ prevM (Indexed (CustomProduct _ dataRepr size _ args,dcI,fI))+  | Void {} <- argTy+  = error (unexpectedProjectionErrorMsg dataRepr dcI fI)+  | DataRepr' _typ _size [cRepr] <- dataRepr+  , ConstrRepr' _cName _pos _mask _val fieldAnns <- cRepr+  , let ses = bitRanges (indexNote "Custom product type: invalid annotation index"+                         fieldAnns fI)+  = case prevM of+      (prev:rest)+        | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+          Just (first Range (continueWithRange ses argTy r) : rest)+      _ ->+          Just (first Range (continueWithRange ses argTy (Contiguous (size-1) 0)):prevM)+ where+  argTy = snd (indexNote "Custom product type: invalid field index" args fI)++buildModifier _ prevM (DC (ty@(SP _ _),_)) = case prevM of+  (prev:rest)+    | (Range r,_) <- prev -> -- See [Note] Continuing from an SLV slice+      Just (first Range (continueWithRange [(start,end)] tyN r) : rest)+  _ ->+      Just ((Range (Contiguous start end),tyN):prevM)+ where+  start = typeSize ty - 1+  end   = typeSize ty - conSize ty+  tyN   = BitVector (start - end + 1)++buildModifier syn prevM (Nested m1 m2) = case buildModifier syn prevM m1 of+  Nothing -> buildModifier syn prevM m2+  Just prevM1 -> case buildModifier syn prevM1 m2 of+      -- In case the second modifier is `Nothing` that means we want the entire+      -- thing calculated by the first modifier+      Nothing -> Just prevM1+      m       -> m++-- [Note] integer projection+--+-- The idea behind these expressions is to translate cases like:+--+-- > :: Int8 -> Int#+-- > \case I8# i -> i+--+-- Which is fine, because no bits are lost. However, these expression might+-- also be the result of the W/W transformation (or uses of unsafeToInteger)+-- for:+--+-- > :: Signed 128 -> Integer+-- > \case S i -> i+--+-- which is very bad because `Integer` is represented by 64 bits meaning we+-- we lose the top 64 bits in the above translation.+--+-- Just as bad is that+--+-- > :: Word8 -> Word#+-- > \case W8# w -> w+--+-- > :: Unsigned 8 -> Integer+-- > \case U i -> i+--+-- result in the same expression... even though their resulting types are+-- different. TODO: this needs  to be fixed!+buildModifier _ prevM (Indexed (ty@(Signed _),_,_)) = Just ((Resize,ty):prevM)+buildModifier _ prevM (Indexed (ty@(Unsigned _),_,_)) = Just ((Resize,ty):prevM)++-- [Note] mask projection+--+-- This covers the case of either:+--+-- `Clash.Sized.Internal.BitVector.unsafeToMask` or+--+-- > :: BitVector 8 -> Integer+-- > \case BV m wild -> m+--+-- introduced by the W/W transformation. Both of which we prefer not to see+-- but will allow. Since the mask is pretty much a simulation artifact we+-- emit don't cares so stuff gets optimised away.+buildModifier _ prevM (Indexed (ty@(BitVector _),_,0)) = Just ((DontCare,ty):prevM)++-- [Note] bitvector projection+--+-- This covers the case of either:+--+-- `Clash.Sized.Internal.BitVector.unsafeToNatural` or+--+-- > :: BitVector 8 -> Integer+-- > \case BV wild i -> i+--+-- introduced by the W/W transformation. Both of which we prefer not to see+-- but will allow.+buildModifier _ prevM (Indexed (ty@(BitVector _),_,1)) = Just ((ResizeAndConvert,ty):prevM)++buildModifier _ _ _ = Nothing++-- | Add an SLV slice for the entire element when we're in the Vivado code-path.+-- This is needed after an element projection from an array (Vec or RTree), as+-- elements are stored as SLVs in the Vivado code-path. This enabled two things:+--+-- 1. Nested modifiers treat the projected element as an SLV, and adjust their+--    projection behavior accordingly.+-- 2. Projected elements are converted from SLV to the proper VHDL type.+vivadoRange+  :: HdlSyn+  -> HWType+  -> [(VHDLModifier, HWType)]+  -> [(VHDLModifier, HWType)]+vivadoRange syn ty mods = case syn of+  Vivado -> (Range (Contiguous (typeSize ty - 1) 0),ty):mods+  _ -> mods++-- | Render a VHDL modifier on to of a (potentially modified) VHDL name+renderModifier+  :: (VHDLModifier,HWType)+  -> VHDLM Doc+  -- ^ (Potentially modified) VHDL name+  -> VHDLM Doc+  -- ^ Modified VHDL name+renderModifier (Idx n,_) doc = doc <> parens (int n)+renderModifier (Slice start end,_) doc = doc <> parens (int start <+> "to" <+> int end)+renderModifier (Select sel,_) doc = doc <> sel+-- See [Note] integer projection+renderModifier (Resize,ty) doc = do+  iw <- Ap (use intWidth)+  -- These integer projections always come last, so it's safe not to return a+  -- modified name, but an expression instead.+  traceIf (iw < typeSize ty) ($(curLoc) ++ "WARNING: result smaller than argument") $+    "resize" <> parens (doc <> "," <> int iw)+renderModifier (ResizeAndConvert,ty) doc = do+  iw <- Ap (use intWidth)+  -- These natural projections always come last, so it's safe not to return a+  -- modified name, but an expression instead.+  traceIf (iw < typeSize ty) ($(curLoc) ++ "WARNING: result smaller than argument") $+    "resize" <> parens ("unsigned" <> parens doc <> "," <> int iw)+-- See [Note] mask projection+renderModifier (DontCare,_) _ = do+  iw <- Ap (use intWidth)+  -- These mask projections always come last, so it's safe not to return a+  -- modified name, but an expression instead.+  traceIf True ($(curLoc) ++ "WARNING: rendering bitvector mask as dontcare") $+    sizedQualTyNameErrValue (Unsigned iw)+renderModifier (Range r,t) doc = do+  nm <- Ap (use modNm)+  enums <- Ap renderEnums+  let doc1 = case r of+        Contiguous start end -> slice start end+        Split rs -> parens (hcat (punctuate " & " (mapM (\(s,e,_) -> slice s e) rs)))+  case normaliseType enums t of+    BitVector _ -> doc1+    -- See [Note] Continuing from an SLV slice+    _ ->+      qualTyName t <> "'" <>+      parens (pretty (TextS.toLower nm) <> "_types.fromSLV" <> parens doc1)+ where+  slice s e = doc <> parens (int s <+> "downto" <+> int e)
+ src/Clash/Backend/Verilog.hs view
@@ -0,0 +1,1317 @@+{-|+  Copyright   :  (C) 2015-2016, University of Twente,+                     2017-2018, Google Inc.,+                     2021-2024, QBayLogic B.V.+                     2022     , Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Generate Verilog for assorted Netlist datatypes+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Backend.Verilog+  ( VerilogState+  , include+  , uselibs+  , encodingNote+  , exprLit+  , bits+  , bit_char+  , noEmptyInit+  -- * split ranges+  , Range (..)+  , continueWithRange+  )+where++import qualified Control.Applicative                  as A+import           Control.Lens                         (Lens',(+=),(-=),(.=),(%=), makeLenses, use)+import           Control.Monad                        (forM)+import           Control.Monad.State                  (State)+import           Data.Bifunctor                       (first, second)+import           Data.Bits                            (Bits, testBit)+import qualified Data.ByteString.Char8                as B8+import           Data.Coerce                          (coerce)+import           Data.Function                        (on)+import           Data.HashMap.Strict                  (HashMap)+import qualified Data.HashMap.Strict                  as HashMap+import           Data.HashSet                         (HashSet)+import qualified Data.HashSet                         as HashSet+import qualified Data.Map                             as Map+import           Data.Map                             (Map)+import           Data.Maybe                           (catMaybes, fromMaybe)+import           Data.Monoid                          (Ap(Ap))+import           Data.Monoid.Extra                    ()+import           Data.List+  (mapAccumL, mapAccumR, nubBy)+#if !MIN_VERSION_base(4,20,0)+import           Data.List                            (foldl')+#endif+import           Data.List.Extra                      ((<:>))+import           Data.Text.Lazy                       (pack)+import qualified Data.Text.Lazy                       as Text+import qualified Data.Text                            as TextS+import           Data.Text.Prettyprint.Doc.Extra+import           Data.Tuple                           (swap)+import qualified System.FilePath+import           GHC.Stack                            (HasCallStack)++import           Clash.Annotations.Primitive          (HDL (..))+import           Clash.Annotations.BitRepresentation.ClashLib+  (bitsToBits)+import           Clash.Annotations.BitRepresentation.Internal+  (ConstrRepr'(..), DataRepr'(..), ConstrRepr'(..))+import           Clash.Annotations.BitRepresentation.Util+  (BitOrigin(Lit, Field), bitOrigins, bitRanges)+import           Clash.Annotations.SynthesisAttributes (Attr(..))+import           Clash.Backend+import           Clash.Backend.Verilog.Time           (periodToString)+import           Clash.Debug                          (traceIf)+import           Clash.Driver.Types                   (ClashOpts(..))+import           Clash.Explicit.BlockRam.Internal     (unpackNats)+import           Clash.Netlist.BlackBox.Types         (HdlSyn)+import           Clash.Netlist.BlackBox.Util+  (extractLiterals, renderBlackBox, addFilePath)+import qualified Clash.Netlist.Id                     as Id+import           Clash.Netlist.Types as N             hiding (intWidth, usages, _usages)+import           Clash.Netlist.Util+import           Clash.Signal.Internal                (ActiveEdge (..))+import           Clash.Util+  (SrcSpan, clogBase, noSrcSpan, curLoc, indexNote, makeCached)++-- | State for the 'Clash.Backend.Verilog.VerilogM' monad:+data VerilogState =+  VerilogState+    { _genDepth  :: Int -- ^ Depth of current generative block+    , _idSeen    :: IdentifierSet+    , _topNm     :: Identifier+    , _srcSpan   :: SrcSpan+    , _includes  :: [(String,Doc)]+    , _imports   :: HashSet Text.Text+    , _libraries :: HashSet Text.Text+    , _dataFiles :: Map FilePath String+    -- ^ Files to be copied: (path to file, file name). The file name stored in+    -- the map might differ from the file name in the path, to prevent name+    -- collisions.+    , _includeDirs :: [FilePath]+    -- ^ Import directories passed in with @-i@+    , _memoryDataFiles:: [(String,String)]+    -- ^ Files to be stored: (filename, contents). These files are generated+    -- during the execution of 'genNetlist'.+    , _customConstrs :: HashMap TextS.Text Identifier+    -- ^ Custom data constructor => Verilog function name+    , _intWidth  :: Int -- ^ Int/Word/Integer bit-width+    , _hdlsyn    :: HdlSyn+    , _undefValue :: Maybe (Maybe Int)+    , _aggressiveXOptBB_ :: AggressiveXOptBB+    , _domainConfigurations_ :: DomainMap+    , _usages :: UsageMap+    }++makeLenses ''VerilogState++instance HasIdentifierSet VerilogState where+  identifierSet = idSeen++instance HasUsageMap VerilogState where+  usageMap = usages++instance Backend VerilogState where+  initBackend opts = VerilogState+    { _genDepth=0+    , _idSeen=Id.emptyIdentifierSet (opt_escapedIds opts) (opt_lowerCaseBasicIds opts) Verilog+    , _topNm=Id.unsafeMake ""+    , _srcSpan=noSrcSpan+    , _includes=[]+    , _imports=HashSet.empty+    , _libraries=HashSet.empty+    , _dataFiles=mempty+    , _includeDirs = opt_importPaths opts+    , _memoryDataFiles=[]+    , _customConstrs=HashMap.empty+    , _intWidth=opt_intWidth opts+    , _hdlsyn=opt_hdlSyn opts+    , _undefValue=opt_forceUndefined opts+    , _aggressiveXOptBB_=coerce (opt_aggressiveXOptBB opts)+    , _domainConfigurations_=emptyDomainMap+    , _usages=mempty+    }+  hdlKind         = const Verilog+  primDirs        = const $ do root <- primsRoot+                               return [ root System.FilePath.</> "common"+                                      , root System.FilePath.</> "commonverilog"+                                      , root System.FilePath.</> "verilog"+                                      ]+  extractTypes    = const HashSet.empty+  name            = const "verilog"+  extension       = const ".v"++  genHDL          = genVerilog+  mkTyPackage _ _ = return []+  hdlType _       = verilogType+  hdlHWTypeKind _ = pure PrimitiveType -- Everything is a bitvector!+  hdlTypeErrValue = verilogTypeErrValue+  hdlTypeMark     = verilogTypeMark+  hdlRecSel       = verilogRecSel+  hdlSig t ty     = sigDecl (string t) ty+  genStmt True    = do cnt <- use genDepth+                       genDepth += 1+                       if cnt > 0+                          then emptyDoc+                          else "generate"+  genStmt False   = do genDepth -= 1+                       cnt <- use genDepth+                       if cnt > 0+                          then emptyDoc+                          else "endgenerate"+  inst            = inst_+  expr            = expr_+  iwWidth         = use intWidth+  toBV ty e       = case ty of+    Signed _ -> "$unsigned" <> parens (string e)+    _ -> string e+  fromBV ty e     = case ty of+    Signed _ -> "$signed" <> parens (string e)+    _ -> string e+  hdlSyn          = use hdlsyn+  setModName _    = id+  setTopName nm s = s {_topNm = nm}+  getTopName      = use topNm+  setSrcSpan      = (srcSpan .=)+  getSrcSpan      = use srcSpan+  blockDecl _ ds  = do+    decs <- decls ds+    if isEmpty decs+      then insts ds+      else+        pure decs <> line <>+        insts ds+  addIncludes inc = includes %= (inc ++)+  addLibraries libs = libraries %= (\s -> foldl' (flip HashSet.insert) s libs)+  addImports inps = imports %= (\s -> foldl' (flip HashSet.insert) s inps)+  addAndSetData f = do+    fs <- use dataFiles+    iDirs <- use includeDirs+    let (fs',f') = addFilePath iDirs fs f+    dataFiles .= fs'+    return f'+  getDataFiles = map swap . Map.assocs <$> use dataFiles+  addMemoryDataFile f = memoryDataFiles %= (f:)+  getMemoryDataFiles = use memoryDataFiles+  ifThenElseExpr _ = True+  aggressiveXOptBB = use aggressiveXOptBB_+  renderEnums = pure (RenderEnums False)+  domainConfigurations = use domainConfigurations_+  setDomainConfigurations confs s = s {_domainConfigurations_ = confs}++type VerilogM a = Ap (State VerilogState) a++-- | Generate Verilog for a Netlist component+genVerilog+  :: ClashOpts+  -> ModName+  -> SrcSpan+  -> IdentifierSet+  -> UsageMap+  -> Component+  -> VerilogM ((String, Doc), [(String, Doc)])+genVerilog opts  _ sp seen usage c = do+    -- Don't have type names conflict with module names or with previously+    -- generated type names.+    --+    -- TODO: Collect all type names up front, to prevent relatively costly union.+    -- TODO: Investigate whether type names / signal names collide in the first place+    Ap $ do+      idSeen %= Id.union seen+      usages .= usage+      setSrcSpan sp++    v    <- commentHeader <> line <>+            nettypeNone <> line <>+            timescale <> line <>+            module_ c <> line <>+            nettypeDefault+    incs <- Ap $ use includes+    return ((TextS.unpack (Id.toText cName), v), incs)+  where+    cName    = componentName c+    commentHeader+         = "/* AUTOMATICALLY GENERATED VERILOG-2001 SOURCE CODE."+      <> line <> "** GENERATED BY CLASH " <> string (Text.pack clashVer) <> ". DO NOT MODIFY."+      <> line <> "*/"+    nettypeNone = "`default_nettype none"+    nettypeDefault = "`default_nettype wire"+    timescale = "`timescale 100fs/" <> string (Text.pack precision)+    precision = periodToString (opt_timescalePrecision opts)++sigPort+  :: VerilogM Doc+  -> Maybe N.Usage+  -> Identifier+  -> HWType+  -> Maybe Expr+  -> VerilogM Doc+sigPort def mu (Id.toText -> pName) hwType iEM = do+    addAttrs (hwTypeAttrs hwType)+      (portType <+> verilogType hwType <+> stringS pName <> iE <> encodingNote hwType)+  where+    portType =+      -- See NOTE [net and variable ports]+      case mu of+        Just Cont ->+          "output wire"++        Just Proc{} ->+          "output reg"++        Nothing ->+          if isBiSignalIn hwType then "inout wire" else def <+> "wire"++    iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM++{-+NOTE [net and variable ports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Verilog, ports are typically seen written with the default implicit net type+of wire, i.e.++  input foo,+  output bar,++which is really a shorthand for++  input wire foo,+  output wire bar,++When we use `default_nettype none however, this is no longer allowed as all+nets must be explicitly given their type. When generating code we must include+the additional word wire (the net type).++What is the benefit of this? When we have a default net type, any variable+generated which is not declared is given an implicit declaration of this+default type. This can obscure clash errors, i.e. if Clash generated++  wire foo;+  fo <= ...;++Then simulators would act as though this was written:++  wire foo;+  wire fo;+  fo <= ...;++Which should never be the desired behaviour for code generated by Clash.++One final point, Verilog allows output to also be a variable type, i.e.++  output reg foo;++If a port is an input or an inout then it can only be a net and not a variable+according to the standard, so input reg and inout reg are impossible.+-}++module_ :: Component -> VerilogM Doc+module_ c =+  modVerilog <* Ap (imports .= HashSet.empty >> libraries .= HashSet.empty)+  where+    modVerilog = do+      body <- modBody+      imps <- Ap $ use imports+      libs <- Ap $ use libraries+      modHeader <> line <> modPorts <> line <>+        include (HashSet.toList imps) <>+        uselibs (HashSet.toList libs) <>+        pure body <> line <> modEnding++    modHeader  = "module" <+> pretty (componentName c)+    modPorts   = indent 4 (tupleInputs inPorts <> line <> tupleOutputs outPorts <> semi)+    modBody    = indent 2 (decls (declarations c)) <> line <> line <> indent 2 (insts (declarations c))+    modEnding  = "endmodule"++    inPorts  = sequence [ sigPort "input" Nothing id_ hwType Nothing | (id_, hwType) <- inputs c  ]+    outPorts = do+      us <- use usages+      let useOf i u = lookupUsage i us <> Just u+      sequence [ sigPort "output" (useOf id_ u) id_ hwType iEM | (u,(id_, hwType), iEM) <- outputs c ]++    -- slightly more readable than 'tupled', makes the output Haskell-y-er+    commafy v = (comma <> space) <> pure v++    tupleInputs v = v >>= \case+      []     -> lparen <+> string "// No inputs" <> line+      (x:xs) -> lparen <+> string "// Inputs"+                      <> line <> (string "  " <> pure x)+                      <> line <> vcat (forM xs commafy)+                      <> line++    tupleOutputs v = v >>= \case+      []     -> string "  // No outputs" <> line <> rparen+      (x:xs) -> string "  // Outputs"+                  <> line <> (if (length (inputs c)) > 0+                         then comma <> space <> pure x+                         else string "  " <> pure x)+                  <> (if null xs then emptyDoc else line <> vcat (forM xs commafy))+                  <> line <> rparen++include :: Monad m => [Text.Text] -> Ap m Doc+include [] = emptyDoc+include xs = line <>+  indent 2 (vcat (mapM (\i -> string "`include" <+> dquotes (string i)) xs))+  <> line <> line++uselibs :: Monad m => [Text.Text] -> Ap m Doc+uselibs [] = emptyDoc+uselibs xs = line <>+  -- NOTE: We must produce a single uselib directive as later ones overwrite earlier ones.+  indent 2 (string "`uselib" <+> (hsep (mapM (\l -> ("lib=" <> string l)) xs)))+  <> line <> line++usageFileDoc :: Maybe N.Usage -> HWType -> VerilogM Doc+usageFileDoc _             FileType  = "integer"+usageFileDoc (Just Proc{}) _         = "reg"+usageFileDoc _             _         = "wire"++verilogType :: HWType -> VerilogM Doc+verilogType t = case t of+  Signed n -> "signed" <+> brackets (int (n-1) <> colon <> int 0)+  Clock {} -> emptyDoc+  ClockN {} -> emptyDoc+  Reset {} -> emptyDoc+  Enable {} -> emptyDoc+  Bit      -> emptyDoc+  Bool     -> emptyDoc+  FileType -> emptyDoc+  Annotated _ ty -> verilogType ty+  BiDirectional _ ty -> verilogType ty+  _        -> brackets (int (typeSize t -1) <> colon <> int 0)++sigDecl :: VerilogM Doc -> HWType -> VerilogM Doc+sigDecl d t = verilogType t <+> d++-- | Convert a Netlist HWType to the root of a Verilog type+verilogTypeMark :: HWType -> VerilogM Doc+verilogTypeMark = const emptyDoc++-- | Convert a Netlist HWType to an error Verilog value for that type+verilogTypeErrValue :: HWType -> VerilogM Doc+verilogTypeErrValue ty = do+  udf <- Ap (use undefValue)+  case udf of+    Nothing       -> braces (int (typeSize ty) <+> braces "1'bx")+    Just Nothing  -> int (typeSize ty) <> "'d0 /* undefined */"+    Just (Just x) -> braces (int (typeSize ty) <+> braces ("1'b" <> int x)) <+> "/* undefined */"++verilogRecSel+  :: HWType+  -> Int+  -> VerilogM Doc+verilogRecSel ty i = case modifier (Contiguous 0 0) (Indexed (ty,0,i)) of+  Just (Contiguous start end,_resTy) -> brackets (int start <> colon <> int end)+  _ -> error "Can't make a record selector"++decls :: [Declaration] -> VerilogM Doc+decls [] = emptyDoc+decls ds = do+    dsDoc <- catMaybes <$> (mapM decl ds)+    case dsDoc of+      [] -> emptyDoc+      _  -> punctuate' semi (A.pure dsDoc)++-- | Add attribute notation to given declaration+addAttrs+  :: [Attr TextS.Text]+  -> VerilogM Doc+  -> VerilogM Doc+addAttrs []     t = t+addAttrs attrs' t =+  "(*" <+> attrs'' <+> "*)" <+> t+ where+  attrs'' = stringS $ TextS.intercalate ", " (map renderAttr attrs')++-- | Convert single attribute to verilog syntax+renderAttr :: Attr TextS.Text -> TextS.Text+renderAttr (StringAttr  key value) = TextS.concat [key, " = ", TextS.pack (show value)]+renderAttr (IntegerAttr key value) = TextS.concat [key, " = ", TextS.pack (show value)]+renderAttr (BoolAttr    key True ) = TextS.concat [key, " = ", "1"]+renderAttr (BoolAttr    key False) = TextS.concat [key, " = ", "0"]+renderAttr (Attr        key      ) = key++decl :: Declaration -> VerilogM (Maybe Doc)+decl (NetDecl' noteM id_ tyE iEM) = do+  us <- use usages+  let u = lookupUsage id_ us+  Just A.<$> maybe id addNote noteM (addAttrs attrs (usageFileDoc u tyE <+> tyDec tyE))+  where+    tyDec ty = sigDecl (pretty id_) ty <> iE+    addNote n = mappend ("//" <+> stringS n <> line)+    attrs = fromMaybe [] (hwTypeAttrs A.<$> Just tyE)+    iE    = maybe emptyDoc (noEmptyInit . expr_ False) iEM++decl _ = return Nothing++noEmptyInit :: (Monad m, Semigroup (m Doc)) => m Doc -> m Doc+noEmptyInit d = do+  d1 <- d+  if isEmpty d1+     then emptyDoc+     else (space <> string "=" <+> d)++insts :: [Declaration] -> VerilogM Doc+insts [] = emptyDoc+insts (TickDecl (Comment c):ds) = comment "//" c <> line <> insts ds+insts (TickDecl (Directive d):ds) = pretty d <> ";" <> line <> insts ds+insts (d:ds) = do+  docM <- inst_ d+  case docM of+    Nothing -> insts ds+    Just doc -> pure doc <> line <> line <> insts ds++stdMatch+  :: Bits a+  => Int+  -> a+  -> a+  -> String+stdMatch 0 _mask _value = []+stdMatch size mask value =+  symbol : stdMatch (size - 1) mask value+  where+    symbol =+      if testBit mask (size - 1) then+        if testBit value (size - 1) then+          '1'+        else+          '0'+      else+        '?'++patLitCustom'+  :: Int+  -> ConstrRepr'+  -> VerilogM Doc+patLitCustom' size (ConstrRepr' _name _n mask value _anns) =+  int size <> squote <> "b" <> (string $ Text.pack $ stdMatch size mask value)++patLitCustom+  :: HWType+  -> Literal+  -> VerilogM Doc+patLitCustom (CustomSum _name _dataRepr size reprs) (NumLit (fromIntegral -> i)) =+  patLitCustom' size (fst $ reprs !! i)++patLitCustom (CustomSP _name _dataRepr size reprs) (NumLit (fromIntegral -> i)) =+  let (cRepr, _id, _tys) = reprs !! i in+  patLitCustom' size cRepr++patLitCustom hwTy _+  | CustomProduct _name dataRepr size _maybeFieldNames _reprs <- hwTy+  , DataRepr' _typ _size [cRepr] <- dataRepr =+  patLitCustom' size cRepr++patLitCustom x y = error $ $(curLoc) ++ unwords+  [ "You can only pass CustomSP / CustomSum / CustomProduct and a NumLit to "+  , "this function, not", show x, "and", show y ]++patMod :: HWType -> Literal -> Literal+patMod hwTy (NumLit i) = NumLit (i `mod` (2 ^ typeSize hwTy))+patMod _ l = l++-- | Helper function for inst_, handling CustomSP and CustomSum+inst_'+  :: TextS.Text+  -> Expr+  -> HWType+  -> [(Maybe Literal, Expr)]+  -> VerilogM (Maybe Doc)+inst_' id_ scrut scrutTy es = fmap Just $+  "always @(*) begin" <> line <>+    indent 2 casez <> line <>+  "end"+    where+      casez =+        "casez" <+> parens var <> line <>+          indent 2 (conds esNub) <> line <>+        "endcase"++      esMod = map (first (fmap (patMod scrutTy))) es+      esNub = nubBy ((==) `on` fst) esMod+      var   = expr_ True scrut++      conds :: [(Maybe Literal,Expr)] -> VerilogM Doc+      conds []                = error $ $(curLoc) ++ "Empty list of conditions invalid."+      conds [(_,e)]           = "default" <+> ":" <+> stringS id_ <+> "=" <+> expr_ False e <> ";"+      conds ((Nothing,e):_)   = "default" <+> ":" <+> stringS id_ <+> "=" <+> expr_ False e <> ";"+      conds ((Just c ,e):es') =+        mask' <+> ":" <+> stringS id_ <+> "=" <+> expr_ False e <> ";" <> line <> conds es'+          where+            mask' = patLitCustom scrutTy c++-- | Turn a Netlist Declaration to a Verilog concurrent block+inst_ :: Declaration -> VerilogM (Maybe Doc)+inst_ (TickDecl {}) = return Nothing+inst_ (CompDecl {}) = return Nothing+inst_ (Assignment id_ Cont e) = fmap Just $+  "assign" <+> pretty id_ <+> equals <+> expr_ False e <> semi++inst_ (CondAssignment id_ _ scrut _ [(Just (BoolLit b), l),(_,r)]) = fmap Just $+   "always @(*) begin" <> line <>+   indent 2 ("if" <> parens (expr_ True scrut) <> line <>+               (indent 2 $ pretty id_ <+> equals <+> expr_ False t <> semi) <> line <>+            "else" <> line <>+               (indent 2 $ pretty id_ <+> equals <+> expr_ False f <> semi)) <> line <>+   "end"+  where+    (t,f) = if b then (l,r) else (r,l)++inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSP {}) es) =+  inst_' (Id.toText id_) scrut scrutTy es++inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSum {}) es) =+  inst_' (Id.toText id_) scrut scrutTy es++inst_ (CondAssignment id_ _ scrut scrutTy@(CustomProduct {}) es) =+  inst_' (Id.toText id_) scrut scrutTy es++inst_ (CondAssignment id_ _ scrut scrutTy es) = fmap Just $+    "always @(*) begin" <> line <>+    indent 2 ("case" <> parens (expr_ True scrut) <> line <>+                (indent 2 $ vcat $ punctuate semi (conds (Id.toText id_) es)) <> semi <> line <>+              "endcase") <> line <>+    "end"+  where+    conds :: IdentifierText -> [(Maybe Literal,Expr)] -> VerilogM [Doc]+    conds _ []                = return []+    conds i [(_,e)]           = ("default" <+> colon <+> stringS i <+> equals <+> expr_ False e) <:> return []+    conds i ((Nothing,e):_)   = ("default" <+> colon <+> stringS i <+> equals <+> expr_ False e) <:> return []+    conds i ((Just c ,e):es') = (exprLitV (Just (scrutTy,conSize scrutTy)) c <+> colon <+> stringS i <+> equals <+> expr_ False e) <:> conds i es'++inst_ (InstDecl _ _ attrs nm lbl ps pms0) = fmap Just $+    attrs' <> nest 2 (pretty nm <> params <> pretty lbl <> line <> pms2 <> semi)+  where+    pms2 = case pms0 of+      NamedPortMap pms1 ->+        -- ( .clk (clk_0), .arst (arst_0), ........ )+        let pm i e = dot <> expr_ False i <+> parens (expr_ False e) in+        tupled $ sequence [pm i e | (i,_,_,e) <- pms1]+      IndexedPortMap pms1 ->+         -- ( clk_0, arst_0, ..... )+        tupled $ sequence [expr_ False e | (_,_,e) <- pms1]++    params+      | null ps   = space+      | otherwise = line <> "#" <> tupled (sequence [dot <> expr_ False i <+> parens (expr_ False e) | (i,_,e) <- ps]) <> line+    attrs'+      | null attrs = emptyDoc+      | otherwise  = addAttrs attrs line++inst_ (BlackBoxD _ libs imps inc bs bbCtx) =+  fmap Just (Ap (column (renderBlackBox libs imps inc bs bbCtx)))++inst_ (Seq ds) = Just <$> seqs ds++inst_ (NetDecl' {}) = return Nothing++inst_ (ConditionalDecl cond ds) = Just <$>+  "`ifdef" <+> pretty cond <> line <> indent 2 (insts ds) <> line <> "`endif"++inst_ d =+  error ("inst_: " ++ show d)++seq_ :: Seq -> VerilogM Doc+seq_ (AlwaysClocked edge clk ds) =+  "always @" <>+    parens (case edge of {Rising -> "posedge"; _ -> "negedge"} <+>+            expr_ False clk) <+> "begin" <> line <>+    indent 2 (seqs ds) <> line <>+  "end"++seq_ (Initial ds) =+  "initial begin" <> line <>+  indent 2 (seqs ds) <> line <>+  "end"++seq_ (AlwaysComb ds) =+  "always @* begin" <> line <>+  indent 2 (seqs ds) <> line <>+  "end"++seq_ (Branch scrut scrutTy es) =+    "case" <> parens (expr_ True scrut) <> line <>+      (indent 2 $ vcat $ conds es) <> line <>+    "endcase"+   where+    conds :: [(Maybe Literal,[Seq])] -> VerilogM [Doc]+    conds [] =+      return []+    conds [(_,sq)] =+      ("default" <+> colon <+> "begin" <> line <>+        indent 2 (seqs sq) <> line <>+      "end") <:> return []+    conds ((Nothing,sq):_) =+      ("default" <+> colon <+> "begin" <> line <>+        indent 2 (seqs sq) <> line <>+      "end") <:> return []+    conds ((Just c ,sq):es') =+      (exprLitV (Just (scrutTy,conSize scrutTy)) c <+> colon <+> "begin" <> line <>+        indent 2 (seqs sq) <> line <>+      "end") <:> conds es'++seq_ (SeqDecl sd) = case sd of+  Assignment id_ (Proc b) e ->+    let op = case b of { Blocking -> equals; NonBlocking -> "<=" }+     in pretty id_ <+> op <+> expr_ False e <> semi++  BlackBoxD {} ->+    fromMaybe <$> emptyDoc <*> inst_ sd++  Seq ds ->+    seqs ds++  _ -> error ("seq_: " ++ show sd)++seqs :: [Seq] -> VerilogM Doc+seqs [] = emptyDoc+seqs (SeqDecl (TickDecl (Comment c)):ds) = comment "//" c <> line <> seqs ds+seqs (SeqDecl (TickDecl (Directive d)):ds) = pretty d <> ";" <> line <> seqs ds+seqs (d:ds) = seq_ d <> line <> line <> seqs ds++-- | Range slice, can be contiguous, or split into multiple sub-ranges+data Range+  = Contiguous Int Int+  | Split [(Int,Int,Provenance)]++-- | Original index range of a split range element+data Provenance+  = Provenance Int Int++-- | Slice ranges out of a split-range element+inRange+  :: [(Int,Int)]+  -- ^ start and end indexes into the original data type+  -> (Int,Int,Provenance)+  -- ^ Element of a split range+  -> ([(Int,Int)],[(Int,Int,Provenance)])+  -- ^+  -- 1. stand and end indexes to be sliced from the rest of the split range elements+  -- 2. Subset of the current split range for the projected data type+inRange [] _ = ([],[])+inRange ((start,end):ses) orig@(_,endRange,Provenance _ endProvenance) =+{-+The following explains the index calculations++== Start ==+-----------------------------------+|     2     | |    1   | |   0    |  <- split range element number+|15|14|13|12| |10| 9| 8| | 4| 3| 2|  <- split range indexes+-----------------------------------+| 9| 8| 7| 6| | 5| 4| 3| | 2| 1| 0|  <- original indexes of the data type (provenance)+-----------------------------------+                   4          1      <- `start` and `end` index that we want to slice++== split range element 2 ==+startOffset: start(4) - endProvenance(6) = -2++next start: 4+next end:   1++== split range element 1 ==+startOffset: start(4) - endProvenance(3) = 1+endOffSet  : end(1) - endProvenance(3) = -2++startRangeNew: endRange(8) + startOffSet(1) = 9+endRangeNew  : endRange(8)++startProvenanceNew: start(4) - end(1)                    = 3+endProvenanceNew  : startProvenanceNew(3)-startOffset(1) = 2++newSplitRange:+-------+|  1  |+| 9| 8| <- new split range element+-------+| 3| 2| <- index into the projected data type++next start: endProvenance(3) - 1 = 2+next end  : 1++== split range element 0 ==+startOffset: start(2) - endProvenance(0) = 2+endOffset  : end(1) - endProvenance(0)   = 1++startRangeNew: endRange(2) + startOffSet(2) = 4+endRangeNew  : endRange(2) + endOffSet(1)   = 3++startProvenanceNew: start(2) - end(1) = 1+endProvenanceNew  :                   = 0++newSplitRange:+-------+|  0  |+| 4| 3| <- new split range element+-------+| 1| 0| <- index into the projected data type+-}+  let startOffset = start - endProvenance+      endOffset   = end   - endProvenance+  in+  if startOffset >= 0 then+    let startRangeNew = endRange + startOffset+        endRangeNew =+          if endOffset >= 0 then+             endRange + endOffset+          else+            endRange++        startProvenanceNew = start - end+        endProvenanceNew =+          if endOffset >= 0 then+            0+          else+            startProvenanceNew - startOffset++        newSplitRange =+          ( startRangeNew+          , endRangeNew+          , Provenance startProvenanceNew endProvenanceNew)+    in+    if endOffset >= 0 then+      -- try to slice the next start+end in the current split range element+      second (newSplitRange:) (inRange ses orig)+    else+      -- continue the slice in the next split range element+      ((endProvenance-1,end):ses,[newSplitRange])+  else+    -- start offset beyond last bit in the element of the split range+    ((start,end):ses,[])++-- | Create an Split range element+buildSplitRange+  :: Int+  -- ^ Offset+  -> Int+  -- ^ End index into the original data type+  -> (Int,Int)+  -- ^ start and end index for this sub-range+  -> (Int,(Int,Int,Provenance))+buildSplitRange offset eP (s,e) =+  let d = s-e in+  (eP+d+1,(s + offset, e + offset, Provenance (eP+d) eP))++-- | Select a sub-range from a range+continueWithRange+  :: [(Int,Int)]+  -- ^ Starts and ends+  -> HWType+  -- ^ Type of the projection+  -> Range+  -- ^ Range selected so far+  -> (Range, HWType)+continueWithRange ses hty r = case r of+  Contiguous _ offset -> case ses of+    [(start,end)] ->+      (Contiguous (start+offset) (end+offset), hty)+    ses1 ->+      let ses2 = snd (mapAccumR (buildSplitRange offset) 0 ses1) in+      (Split ses2, hty)+  Split rs -> case concat (snd (mapAccumL inRange ses rs)) of+    [] -> error "internal error"+    [(s1,e1,_)] -> (Contiguous s1 e1,hty)+    rs1 -> (Split rs1,hty)++-- | Calculate the beginning and end index into a variable, to get the+-- desired field.+-- Also returns the HWType of the result.+modifier+  :: HasCallStack+  => Range+  -- ^ Range selected so far+  -> Modifier+  -> Maybe (Range,HWType)+modifier r (Sliced (BitVector _,start,end)) =+  Just (continueWithRange [(start,end)] hty r)+  where+    hty = BitVector (start-end-1)+++modifier r (Indexed (ty@(SP _ args),dcI,fI)) =+  Just (continueWithRange [(start,end)] argTy r)+  where+    argTys   = snd $ args !! dcI+    argTy    = argTys !! fI+    argSize  = typeSize argTy+    other    = otherSize argTys (fI-1)+    start    = typeSize ty - 1 - conSize ty - other+    end      = start - argSize + 1++modifier r (Indexed (ty@(Product _ _ argTys),_,fI)) =+  Just (continueWithRange [(start,end)] argTy r)+  where+    argTy   = argTys !! fI+    argSize = typeSize argTy+    otherSz = otherSize argTys (fI - 1)+    start   = typeSize ty - 1 - otherSz+    end     = start - argSize + 1++modifier r (Indexed (ty@(Vector _ argTy),1,0)) =+  Just (continueWithRange [(start,end)] argTy r)+  where+    argSize = typeSize argTy+    start   = typeSize ty - 1+    end     = start - argSize + 1++modifier r (Indexed (ty@(Vector n argTy),1,1)) =+  Just (continueWithRange [(start,0)] hty r)+  where+    argSize = typeSize argTy+    start   = typeSize ty - argSize - 1+    hty     = Vector (n-1) argTy++modifier r (Indexed (ty@(RTree 0 argTy),0,0)) =+  Just (continueWithRange [(start,0)] argTy r)+  where+    start   = typeSize ty - 1++modifier r (Indexed (ty@(RTree d argTy),1,0)) =+  Just (continueWithRange [(start,end)] hty r)+  where+    start   = typeSize ty - 1+    end     = typeSize ty `div` 2+    hty     = RTree (d-1) argTy++modifier r (Indexed (ty@(RTree d argTy),1,1)) =+  Just (continueWithRange [(start,0)] hty r)+  where+    start   = (typeSize ty `div` 2) - 1+    hty     = RTree (d-1) argTy++-- This is a HACK for Clash.Netlist.Util.mkTopOutput+-- Vector's don't have a 10'th constructor, this is just so that we can+-- recognize the particular case+modifier r (Indexed (ty@(Vector _ argTy),10,fI)) =+  Just (continueWithRange [(start,end)] argTy r)+  where+    argSize = typeSize argTy+    start   = typeSize ty - (fI * argSize) - 1+    end     = start - argSize + 1++-- This is a HACK for Clash.Netlist.Util.mkTopOutput+-- RTree's don't have a 10'th constructor, this is just so that we can+-- recognize the particular case+modifier r (Indexed (ty@(RTree _ argTy),10,fI)) =+  Just (continueWithRange [(start,end)] argTy r)+  where+    argSize = typeSize argTy+    start   = typeSize ty - (fI * argSize) - 1+    end     = start - argSize + 1++modifier r (Indexed (CustomSP _typName _dataRepr _size args,dcI,fI)) =+  Just (continueWithRange ses argTy r)+  where+    ses = bitRanges (anns !! fI)+    (ConstrRepr' _name _n _mask _value anns, _, argTys) = args !! dcI+    argTy = argTys !! fI++modifier r (Indexed (CustomProduct _typName dataRepr _size _maybeFieldNames args,_,fI))+  | DataRepr' _typ _size [cRepr] <- dataRepr+  , ConstrRepr' _cName _pos _mask _val fieldAnns <- cRepr+  = let ses = bitRanges (fieldAnns !! fI) in Just (continueWithRange ses argTy r)+ where+  argTy = map snd args !! fI++modifier r (DC (ty@(SP _ _),_)) =+  Just (continueWithRange [(start,end)] ty r)+  where+    start = typeSize ty - 1+    end   = typeSize ty - conSize ty++modifier r (Nested m1 m2) = do+  case modifier r m1 of+    Nothing -> modifier r m2+    Just (r1,argTy) -> case modifier r1 m2 of+      -- In case the second modifier is `Nothing` that means we want the entire+      -- thing calculated by the first modifier+      Nothing -> Just (r1,argTy)+      m       -> m++modifier _ _ = Nothing++-- | Render a data constructor application for data constructors having a+-- custom bit representation.+customReprDataCon+  :: DataRepr'+  -- ^ Custom representation of data type+  -> ConstrRepr'+  -- ^ Custom representation of a specific constructor of @dataRepr@+  -> [(HWType, Expr)]+  -- ^ Arguments applied to constructor+  -> VerilogM Doc+customReprDataCon dataRepr constrRepr [] =+  let origins = bitOrigins dataRepr constrRepr :: [BitOrigin] in+  case origins of+    [Lit (bitsToBits -> ns)] ->+      int (length ns) <> squote <> "b" <> hcat (mapM (bit_char undefValue) ns)+    _ -> error "internal error"+customReprDataCon dataRepr constrRepr args = do+  funId <- mkConstrFunction+  Ap (imports %= HashSet.insert (Text.pack (TextS.unpack (Id.toText funId) ++ ".inc")))+  pretty funId <> tupled (mapM (expr_ False . snd) nzArgs)+ where+  nzArgs = filter ((/=0) . typeSize . fst) args++  mkConstrFunction :: Ap (State VerilogState) Identifier+  mkConstrFunction = makeCached (crName constrRepr) customConstrs $ do+    let size    = drSize dataRepr+        aTys    = map fst args+        origins = bitOrigins dataRepr constrRepr :: [BitOrigin]+    let mkId nm = Id.makeBasic nm+    ids <- mapM (\n -> mkId (TextS.pack ('v':show n))) [1..length args]+    fId <- mkId (crName constrRepr)+    let fInps =+          [ case typeSize t of+              0 -> emptyDoc+              1 -> "input" <+> pretty i <> semi <> line+              n -> "input" <+> brackets (int (n-1) <> colon <> int 0) <+>+                               pretty i <> semi <> line+          | (i,t) <- zip ids aTys+          ]++    let range' (Lit (bitsToBits -> ns)) =+          int (length ns) <> squote <> "b" <> hcat (mapM (bit_char undefValue) ns)+        range' (Field n start end) =+          let v   = ids !! n+              aTy = aTys !! n+          in case typeSize aTy of+               0 -> error "internal error"+               1 -> if start == 0 && end == 0 then+                      pretty v+                    else+                      error "internal error"+               _ -> pretty v <> brackets (int start <> colon <> int end)++    let val = case origins of+                []  -> error "internal error"+                [r] -> range' r+                rs  -> listBraces (mapM range' rs)++    let oSz = case size of+                0 -> error "internal error"+                1 -> emptyDoc+                n -> brackets (int (n-1) <> colon <> int 0)++    funDoc <-+      "function" <+> oSz <+> pretty fId <> semi <> line <>+      hcat (sequence fInps) <>+      "begin" <> line <>+      indent 2 (pretty fId <+> "=" <+> val <> semi) <> line <>+      "end" <> line <>+      "endfunction"+    Ap (includes %= ((TextS.unpack (Id.toText fId) ++ ".inc",funDoc):))+    return fId++-- | Turn a Netlist expression into a Verilog expression+expr_ :: Bool -- ^ Enclose in parentheses?+      -> Expr -- ^ Expr to convert+      -> VerilogM Doc+expr_ _ (Literal sizeM lit) = exprLitV sizeM lit++expr_ _ (Identifier id_ Nothing) = pretty id_++expr_ _ (Identifier id_ (Just (Indexed (CustomSP _id dataRepr _size args,dcI,fI)))) =+  case fieldTy of+    Void {} -> error (unexpectedProjectionErrorMsg dataRepr dcI fI)+    _       -> braces $ hcat $ punctuate ", " $ sequence ranges+ where+  (ConstrRepr' _name _n _mask _value anns, _, fieldTypes) = args !! dcI+  ranges = map range' $ bitRanges (anns !! fI)+  range' (start, end) = pretty id_ <> brackets (int start <> ":" <> int end)+  fieldTy = indexNote ($(curLoc) ++ "panic") fieldTypes fI++expr_ _ (Identifier d_ (Just (Indexed (CustomProduct _id dataRepr _size _maybeFieldNames tys, dcI, fI))))+  | DataRepr' _typ _size [cRepr] <- dataRepr+  , ConstrRepr' _cName _pos _mask _val anns <- cRepr =+  let ranges = map range' (bitRanges (anns !! fI)) in+  case fieldTy of+    Void {} -> error (unexpectedProjectionErrorMsg dataRepr dcI fI)+    _       -> braces $ hcat $ punctuate ", " $ sequence ranges+ where+  (_fieldAnn, fieldTy) = indexNote ($(curLoc) ++ "panic") tys fI+  range' (start, end) = pretty d_ <> brackets (int start <> ":" <> int end)++-- See [Note] integer projection+expr_ _ (Identifier id_ (Just (Indexed ((Signed w),_,_))))  = do+  iw <- Ap $ use intWidth+  traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $+    pretty id_++-- See [Note] integer projection+expr_ _ (Identifier id_ (Just (Indexed ((Unsigned w),_,_))))  = do+  iw <- Ap $ use intWidth+  traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $+    pretty id_++-- See [Note] mask projection+expr_ _ (Identifier _ (Just (Indexed ((BitVector _),_,0)))) = do+  iw <- Ap $ use intWidth+  traceIf True ($(curLoc) ++ "WARNING: synthesizing bitvector mask to dontcare") $+    verilogTypeErrValue (Unsigned iw)++-- See [Note] bitvector projection+expr_ _ (Identifier id_ (Just (Indexed ((BitVector w),_,1)))) = do+  iw <- Ap $ use intWidth+  traceIf (iw < w) ($(curLoc) ++ "WARNING: result smaller than argument") $+    pretty id_++expr_ _ (Identifier id_ (Just m)) = case modifier (Contiguous 0 0) m of+  Nothing -> pretty id_+  Just (Contiguous start end,resTy) -> case resTy of+    Signed _ -> "$signed" <> parens (slice start end)+    _        -> slice start end+  Just (Split rs,resTy) ->+    let rs1 = listBraces (mapM (\(start,end,_) -> slice start end) rs) in+    case resTy of+      Signed _ -> "$signed" <> parens rs1+      _ -> rs1++ where+  slice s e = pretty id_ <> brackets (int s <> colon <> int e)++expr_ b (DataCon _ (DC (Void {}, -1)) [e]) = expr_ b e++expr_ _ (DataCon ty@(Vector 0 _) _ _) = verilogTypeErrValue ty++expr_ _ (DataCon (Vector 1 _) _ [e]) = expr_ False e+expr_ _ e@(DataCon (Vector _ _) _ es@[_,_]) =+    listBraces $ mapM (expr_ False) $ fromMaybe es $ vectorChain e++expr_ _ (DataCon (MemBlob n m) _ [n0, m0, _, runs, _, ends])+  | Literal _ (NumLit n1) <- n0+  , n == fromInteger n1+  , Literal _ (NumLit m1) <- m0+  , m == fromInteger m1+  , Literal Nothing (StringLit runs0) <- runs+  , Literal Nothing (StringLit ends0) <- ends+  , es <- unpackNats n m (B8.pack runs0) (B8.pack ends0) =+    let el val = exprLitV (Just (BitVector m, m)) (BitVecLit 0 $ toInteger val)+    in listBraces $ mapM el es++expr_ _ (DataCon (RTree 0 _) _ [e]) = expr_ False e+expr_ _ e@(DataCon (RTree _ _) _ es@[_,_]) =+    listBraces $ mapM (expr_ False) $ fromMaybe es $ rtreeChain e++expr_ _ (DataCon (SP {}) (DC (BitVector _,_)) es) = assignExpr+  where+    argExprs   = map (expr_ False) es+    assignExpr = braces (hcat $ punctuate comma $ sequence argExprs)++expr_ _ (DataCon ty@(SP _ args) (DC (_,i)) es) = assignExpr+  where+    argTys     = snd $ args !! i+    dcSize     = conSize ty + sum (map typeSize argTys)+    dcExpr     = expr_ False (dcToExpr ty i)+    argExprs   = map (expr_ False) es+    extraArg   = case typeSize ty - dcSize of+                   0 -> []+                   n -> [int n <> "'b" <> bits undefValue (replicate n U)]+    assignExpr = braces (hcat $ punctuate comma $ sequence (dcExpr:argExprs ++ extraArg))++expr_ _ (DataCon ty@(Sum _ _) (DC (_,i)) []) = int (typeSize ty) <> "'d" <> int i++expr_ _ (DataCon ty@(CustomSum _ _ _ tys) (DC (_,i)) []) =+  let (ConstrRepr' _ _ _ value _) = fst $ tys !! i in+  int (typeSize ty) <> squote <> "d" <> int (fromIntegral value)+expr_ _ (DataCon (CustomSP _name dataRepr _size constrs) (DC (_,constrNr)) es) =+  let (cRepr, _, argTys) = constrs !! constrNr in+  customReprDataCon dataRepr cRepr (zip argTys es)+expr_ _ (DataCon (CustomProduct _ dataRepr _size _labels tys) _ es) |+  DataRepr' _typ _size [cRepr] <- dataRepr =+  customReprDataCon dataRepr cRepr (zip (map snd tys) es)+expr_ _ (DataCon (Product {}) _ es) = listBraces (mapM (expr_ False) es)++expr_ _ (DataCon (Enable _) _ [e]) =+  expr_ False e++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.Signed.fromInteger#"+  , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx+  = exprLitV (Just (Signed (fromInteger n),fromInteger n)) i++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.Unsigned.fromInteger#"+  , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx+  = exprLitV (Just (Unsigned (fromInteger n),fromInteger n)) i++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.BitVector.fromInteger#"+  , [Literal _ (NumLit n), Literal _ m, Literal _ i] <- extractLiterals bbCtx+  , NumLit m' <- m+  , NumLit i' <- i+  = exprLitV (Just (BitVector (fromInteger n),fromInteger n)) (BitVecLit m' i')++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.BitVector.fromInteger##"+  , [Literal _ m, Literal _ i] <- extractLiterals bbCtx+  , NumLit m' <- m+  , NumLit i' <- i+  = exprLitV (Just (Bit,1)) (BitLit $ toBit m' i')++expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)+  | pNm == "Clash.Sized.Internal.Index.fromInteger#"+  , [Literal _ (NumLit n), Literal _ i] <- extractLiterals bbCtx+  , Just k <- clogBase 2 n+  , let k' = max 1 k+  = exprLitV (Just (Index (fromInteger n),k')) i++expr_ b (BlackBoxE _ libs imps inc bs bbCtx b') = do+  parenIf (b || b') (Ap (renderBlackBox libs imps inc bs bbCtx <*> pure 0))++expr_ _ (DataTag Bool (Left id_)) = pretty id_ <> brackets (int 0)+expr_ _ (DataTag Bool (Right id_)) = do+  iw <- Ap (use intWidth)+  "$unsigned" <> parens (listBraces (sequence [braces (int (iw-1) <+> braces "1'b0"),pretty id_]))++expr_ _ (DataTag (Sum _ _) (Left id_))     = "$unsigned" <> parens (pretty id_)+expr_ _ (DataTag (Sum _ _) (Right id_))    = "$unsigned" <> parens (pretty id_)++expr_ _ (DataTag (Product {}) (Right _))  = do+  iw <- Ap (use intWidth)+  int iw <> "'sd0"++expr_ _ (DataTag hty@(SP _ _) (Right id_)) = "$unsigned" <> parens+                                               (pretty id_ <> brackets+                                               (int start <> colon <> int end))+  where+    start = typeSize hty - 1+    end   = typeSize hty - conSize hty++expr_ _ (DataTag (Vector 0 _) (Right _)) = do+  iw <- Ap $ use intWidth+  int iw <> "'sd0"+expr_ _ (DataTag (Vector _ _) (Right _)) = do+  iw <- Ap $ use intWidth+  int iw <> "'sd1"++expr_ _ (DataTag (RTree 0 _) (Right _)) = do+  iw <- Ap $ use intWidth+  int iw <> "'sd0"+expr_ _ (DataTag (RTree _ _) (Right _)) = do+  iw <- Ap $ use intWidth+  int iw <> "'sd1"++expr_ b (ToBv _ _ e) = expr_ b e+expr_ b (FromBv _ _ e) = expr_ b e++expr_ b (IfThenElse c t e) =+  parenIf b (expr_ True c <+> "?" <+> expr_ True t <+> ":" <+> expr_ True e)++expr_ _ e = error $ $(curLoc) ++ (show e) -- empty++otherSize :: [HWType] -> Int -> Int+otherSize _ n | n < 0 = 0+otherSize []     _    = 0+otherSize (a:as) n    = typeSize a + otherSize as (n-1)++vectorChain :: Expr -> Maybe [Expr]+vectorChain (DataCon (Vector 0 _) _ _)        = Just []+vectorChain (DataCon (Vector 1 _) _ [e])     = Just [e]+vectorChain (DataCon (Vector _ _) _ [e1,e2]) = Just e1 <:> vectorChain e2+vectorChain _                                       = Nothing++rtreeChain :: Expr -> Maybe [Expr]+rtreeChain (DataCon (RTree 0 _) _ [e])     = Just [e]+rtreeChain (DataCon (RTree _ _) _ [e1,e2]) = Just e1 <:> rtreeChain e2+rtreeChain _                               = Nothing++exprLitV :: Maybe (HWType,Size) -> Literal -> VerilogM Doc+exprLitV = exprLit undefValue++exprLit :: Backend s => Lens' s (Maybe (Maybe Int)) -> Maybe (HWType,Size) -> Literal -> Ap (State s) Doc+exprLit _ Nothing (NumLit i) = integer i++exprLit k (Just (hty,sz)) (NumLit i0) = case hty of+  Unsigned _+   | i < 0     -> string "-" <> int sz <> string "'d" <> integer (abs i)+   | otherwise -> int sz <> string "'d" <> integer i+  Index n+   | 0 <= i0 && i0 < n -> int (typeSize hty) <> string "'d" <> integer i0+   | otherwise         -> hdlTypeErrValue hty+  Signed _+   | i < 0     -> string "-" <> int sz <> string "'sd" <> integer (abs i)+   | otherwise -> int sz <> string "'sd" <> integer i+  _ -> int sz <> string "'b" <> blit+  where+    blit = bits k (toBits sz i)+    i = case hty of+             Signed _ -> let mask = 2^(sz-1) in case divMod i0 mask of+                (s,i'') | even s    -> i''+                        | otherwise -> i'' - mask+             _ -> i0 `mod` 2^sz+exprLit k (Just (_,sz)) (BitVecLit m i) = int sz <> string "'b" <> bvlit+  where+    bvlit = bits k (toBits' sz m i)++exprLit _ _             (BoolLit t)   = string $ if t then "1'b1" else "1'b0"+exprLit k _             (BitLit b)    = string "1'b" <> bit_char k b+exprLit _ _             (StringLit s) = string . pack $ show s+exprLit _ _             l             = error $ $(curLoc) ++ "exprLit: " ++ show l++toBits :: Integral a => Int -> a -> [Bit]+toBits size val = map (\x -> if odd x then H else L)+                $ reverse+                $ take size+                $ map (`mod` 2)+                $ iterate (`div` 2) val++toBits' :: Integral a => Int -> a -> a -> [Bit]+toBits' size msk val = map (\(m,i) -> if odd m then U else (if odd i then H else L))+                $+                ( reverse . take size)+                $ zip+                  ( map (`mod` 2) $ iterate (`div` 2) msk)+                  ( map (`mod` 2) $ iterate (`div` 2) val)+++bits :: Lens' s (Maybe (Maybe Int)) -> [Bit] -> Ap (State s) Doc+bits k = hcat . traverse (bit_char k)++bit_char' :: Bit -> Char+bit_char' H = '1'+bit_char' L = '0'+bit_char' U = 'x'+bit_char' Z = 'z'++bit_char :: Lens' s (Maybe (Maybe Int)) -> Bit -> Ap (State s) Doc+bit_char k b = do+  udf <- Ap (use k)+  case (udf,b) of+    (Just Nothing,U)  -> char '0'+    (Just (Just i),U) -> int i+    _                 -> char (bit_char' b)++dcToExpr :: HWType -> Int -> Expr+dcToExpr ty i = Literal (Just (ty,conSize ty)) (NumLit (toInteger i))++listBraces :: Monad m => m [Doc] -> m Doc+listBraces = align . enclose lbrace rbrace . hsep . punctuate (comma <+> softline)++parenIf :: Monad m => Bool -> m Doc -> m Doc+parenIf True  = parens+parenIf False = id++punctuate' :: Monad m => Ap m Doc -> Ap m [Doc] -> Ap m Doc+punctuate' s d = vcat (punctuate s d) <> s++encodingNote :: Applicative m => HWType -> m Doc+encodingNote (Clock _) = string " // clock"+encodingNote (ClockN _) = string " // clock (neg phase)"+encodingNote (Reset _) = string " // reset"+encodingNote (Enable _) = string " // enable"+encodingNote (Annotated _ t) = encodingNote t+encodingNote _         = emptyDoc
+ src/Clash/Backend/Verilog/Time.hs view
@@ -0,0 +1,130 @@+{-|+Copyright  :  (C) 2022,      Google Inc.,+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Utilities and definitions to deal with Verilog's time unit. These definitions+are here mostly to deal with varying @`timescale@ defintions, see:++  https://www.chipverify.com/verilog/verilog-timescale++-}++{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-}++-- TryDomain instance+{-# OPTIONS_GHC -Wno-deprecations #-}++module Clash.Backend.Verilog.Time where++import Clash.Class.HasDomain.HasSingleDomain+  (TryDomain, TryDomainResult(NotFound))++import Control.DeepSeq (NFData)+import Data.Char (toLower, isDigit)+import Data.Hashable (Hashable)+import Data.List (find)+import Data.Word (Word64)+import GHC.Generics (Generic)+import Text.Read (readMaybe)++-- | Verilog time units+data Unit = Fs | Ps | Ns | Us | Ms | S+  deriving (Show, Enum, Bounded, Eq, Ord, Generic, Hashable, NFData)++type instance TryDomain t Unit = 'NotFound++-- | Verilog time period. A combination of a length and a unit.+data Period = Period Word64 Unit+  deriving (Show, Generic, Hashable, Eq, NFData)++-- | Verilog timescale. Influences simulation precision.+data Scale = Scale+  { -- | Time step in wait statements, e.g. `#1`.+    step :: Period++    -- | Simulator precision - all units will get rounded to this period.+  , precision :: Period+  }+  deriving (Show, Generic, Hashable, Eq, NFData)++-- | Pretty print 'Scale' to Verilog `timescale+--+-- >>> scaleToString (Scale (Period 100 Ps) (Period 10 Fs))+-- "`timescale 100ps/10fs"+--+scaleToString :: Scale -> String+scaleToString (Scale{step, precision}) =+  "`timescale " <> periodToString step <> "/" <> periodToString precision++-- | Convert 'Unit' to Verilog time unit+--+-- >>> periodToString (Period 100 Fs)+-- "100fs"+--+periodToString :: Period -> String+periodToString (Period len unit) = show len <> unitToString unit++-- | Convert 'Unit' to Verilog time unit+--+-- >>> unitToString Ms+-- "ms"+--+unitToString :: Unit -> String+unitToString = map toLower . show++-- | Parse string representing a Verilog time unit to 'Unit'.+--+-- >>> parseUnit "ms"+-- Just Ms+-- >>> parseUnit "xs"+-- Nothing+--+parseUnit :: String -> Maybe Unit+parseUnit s = find tryUnit [minBound..]+ where+  tryUnit :: Unit -> Bool+  tryUnit u = unitToString u == s++-- | Parse a Verilog+--+-- >>> parsePeriod "100ms"+-- Just (Period 100 Ms)+-- >>> parsePeriod "100xs"+-- Nothing+-- >>> parsePeriod "100"+-- Nothing+-- >>> parsePeriod "ms"+-- Nothing+--+parsePeriod :: String -> Maybe Period+parsePeriod s =+  case span isDigit s of+    (len0, unit0) -> do+      len1 <- readMaybe len0+      unit1 <- parseUnit unit0+      pure (Period len1 unit1)++-- | Convert a period to a specific time unit. Will always output a minimum+-- of 1, even if the given 'Period' is already of the right 'Unit'.+--+-- >>> convertUnit Ps (Period 100 Ps)+-- 100+-- >>> convertUnit Fs (Period 100 Ps)+-- 100000+-- >>> convertUnit Ns (Period 100 Ps)+-- 1+-- >>> convertUnit Ms (Period 0 Ms)+-- 1+--+convertUnit :: Unit -> Period -> Word64+convertUnit targetUnit = go+ where+  go (Period len unit) =+    case compare unit targetUnit of+      LT -> go (Period (len `div` 1000) (succ unit))+      EQ -> max 1 len+      GT -> go (Period (len * 1000) (pred unit))
+ src/Clash/Core/DataCon.hs view
@@ -0,0 +1,83 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                          2017, Google Inc.,+                          2021, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Data Constructors in CoreHW+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Clash.Core.DataCon+  ( DataCon (..)+  , DcName+  , ConTag+  , DcStrictness(..)+  )+where++import Control.DeepSeq                        (NFData(..))+import Data.Binary                            (Binary)+import Data.Function                          (on)+import Data.Hashable                          (Hashable)+import qualified Data.Text                    as Text+import GHC.Generics                           (Generic)++import Clash.Core.Name                        (Name (..))+import {-# SOURCE #-} Clash.Core.Type         (Type)+import Clash.Core.Var                         (TyVar)+import Clash.Unique++-- | Data Constructor+data DataCon+  = MkData+  { dcName :: !DcName+  -- ^ Name of the DataCon+  , dcUniq :: {-# UNPACK #-} !Unique+  -- ^ Invariant: forall x . dcUniq x ~ nameUniq (dcName x)+  , dcTag :: !ConTag+  -- ^ Syntactical position in the type definition+  , dcType :: !Type+  -- ^ Type of the 'DataCon+  , dcUnivTyVars :: [TyVar]+  -- ^ Universally quantified type-variables, these type variables are also part+  -- of the result type of the DataCon+  , dcExtTyVars :: [TyVar]+  -- ^ Existentially quantified type-variables, these type variables are not+  -- part of the result of the DataCon, but only of the arguments.+  , dcArgTys :: [Type]+  -- ^ Argument types+  , dcArgStrict :: [DcStrictness]+  -- ^ Argument strictness+  , dcFieldLabels :: [Text.Text]+  -- ^ Names of fields. Used when data constructor is referring to a record type.+  } deriving (Generic,NFData,Binary)++instance Show DataCon where+  show = show . dcName++instance Eq DataCon where+  (==) = (==) `on` dcUniq+  (/=) = (/=) `on` dcUniq++instance Ord DataCon where+  compare = compare `on` dcUniq++instance Uniquable DataCon where+  getUnique = dcUniq+  setUnique dc u = dc {dcUniq=u, dcName=(dcName dc){nameUniq=u}}++-- | Syntactical position of the DataCon in the type definition+type ConTag = Int+-- | DataCon reference+type DcName = Name DataCon++data DcStrictness+  = Strict+  | Lazy+  deriving (Generic, NFData, Eq, Hashable, Binary)
+ src/Clash/Core/EqSolver.hs view
@@ -0,0 +1,182 @@+{-|+  Copyright  :  (C) 2021-2024 QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Core.EqSolver where++import Data.List.Extra (zipEqual)+import Data.Maybe (catMaybes, mapMaybe)++import Clash.Core.Name (Name(nameUniq))+import Clash.Core.Term+import Clash.Core.TyCon+import Clash.Core.Type+import Clash.Core.Var+import Clash.Core.VarEnv (VarSet, elemVarSet, emptyVarSet, mkVarSet)+import Clash.Unique (fromGhcUnique)+import Clash.Core.DataCon (dcUniq)+import GHC.Builtin.Names (unsafeReflDataConKey, eqPrimTyConKey, typeNatAddTyFamNameKey)++-- | Data type that indicates what kind of solution (if any) was found+data TypeEqSolution+  = Solution (TyVar, Type)+  -- ^ Solution was found. Variable equals some integer.+  | AbsurdSolution+  -- ^ A solution was found, but it involved negative naturals.+  | NoSolution+  -- ^ Given type wasn't an equation, or it was unsolvable.+    deriving (Show, Eq)++catSolutions :: [TypeEqSolution] -> [(TyVar, Type)]+catSolutions = mapMaybe getSol+ where+  getSol (Solution s) = Just s+  getSol _ = Nothing++-- | Solve given equations and return all non-absurd solutions+solveNonAbsurds :: TyConMap -> VarSet -> [(Type, Type)] -> [(TyVar, Type)]+solveNonAbsurds _tcm _ [] = []+solveNonAbsurds tcm solveSet (eq:eqs) =+  solved ++ solveNonAbsurds tcm solveSet eqs+ where+  solvers = [pure . solveAdd solveSet, solveEq tcm solveSet]+  solved = catSolutions (concat [s eq | s <- solvers])++-- | Solve simple equalities such as:+--+--   * a ~ 3+--   * 3 ~ a+--   * SomeType a b ~ SomeType 3 5+--   * SomeType 3 5 ~ SomeType a b+--   * SomeType a 5 ~ SomeType 3 b+--+solveEq :: TyConMap -> VarSet -> (Type, Type) -> [TypeEqSolution]+solveEq tcm solveSet (coreView tcm -> left, coreView tcm -> right) =+  case (left, right) of+    (VarTy tyVar, ConstTy {}) | elemVarSet tyVar solveSet ->+      -- a ~ 3+      [Solution (tyVar, right)]+    (ConstTy {}, VarTy tyVar) | elemVarSet tyVar solveSet ->+      -- 3 ~ a+      [Solution (tyVar, left)]+    (ConstTy {}, ConstTy {}) ->+      -- Int /= Char+      if left /= right then [AbsurdSolution] else []+    (LitTy {}, LitTy {}) ->+      -- 3 /= 5+      if left /= right then [AbsurdSolution] else []+    _ ->+      -- The call to 'coreView' at the start of 'solveEq' should have reduced+      -- all solvable type families. If we encounter one here that means the+      -- type family is stuck (and that we shouldn't compare it to anything!).+      if any (isTypeFamilyApplication tcm) [left, right] then+        []+      else+        case (tyView left, tyView right) of+          (TyConApp leftNm leftTys, TyConApp rightNm rightTys) ->+            -- SomeType a b ~ SomeType 3 5 (or other way around)+            if leftNm == rightNm then+              concat (map (solveEq tcm solveSet) (zipEqual leftTys rightTys))+            else+              [AbsurdSolution]+          _ ->+            []++-- | Solve equations supported by @normalizeAdd@. See documentation of+-- 'TypeEqSolution' to understand the return value.+solveAdd+  :: VarSet+  -> (Type, Type)+  -> TypeEqSolution+solveAdd solveSet ab =+  case normalizeAdd ab of+    Just (n, m, VarTy tyVar) | elemVarSet tyVar solveSet ->+      if n >= 0 && m >= 0 && n - m >= 0 then+        Solution (tyVar, (LitTy (NumTy (n - m))))+      else+        AbsurdSolution+    _ ->+      NoSolution++-- | Given the left and right side of an equation, normalize it such that+-- equations of the following forms:+--+--     * 5     ~ n + 2+--     * 5     ~ 2 + n+--     * n + 2 ~ 5+--     * 2 + n ~ 5+--+-- are returned as (5, 2, n)+normalizeAdd+  :: (Type, Type)+  -> Maybe (Integer, Integer, Type)+normalizeAdd (a, b) = do+  (n, rhs) <- lhsLit a b+  case tyView rhs of+    TyConApp tc [left, right]+      | nameUniq tc == fromGhcUnique typeNatAddTyFamNameKey -> do+      (m, o) <- lhsLit left right+      return (n, m, o)+    _ ->+      Nothing+ where+  lhsLit x                 (LitTy (NumTy n)) = Just (n, x)+  lhsLit (LitTy (NumTy n)) y                 = Just (n, y)+  lhsLit _                 _                 = Nothing++-- | Tests for nonsencical patterns due to types being "absurd". See+-- 'isAbsurdEq' for more info.+isAbsurdPat+  :: TyConMap+  -> Pat+  -> Bool+isAbsurdPat _tcm (DataPat dc _ _)+  -- unsafeCoerce is not absurd in the way intended by /isAbsurdPat/+  | dcUniq dc == fromGhcUnique unsafeReflDataConKey+  = False+isAbsurdPat tcm pat =+  any (isAbsurdEq tcm exts) (patEqs tcm pat)+ where+  exts = case pat of+    DataPat _dc extNms _ids -> mkVarSet extNms+    _ -> emptyVarSet++-- | Determines if an "equation" obtained through 'patEqs' or 'typeEq' is+-- absurd. That is, it tests if two types that are definitely not equal are+-- asserted to be equal OR if the computation of the types yield some absurd+-- (intermediate) result such as -1.+isAbsurdEq+  :: TyConMap+  -> VarSet -- ^ existential tvs+  -> (Type, Type)+  -> Bool+isAbsurdEq tcm exts ((left0, right0)) =+  case (coreView tcm left0, coreView tcm right0) of+    (solveAdd exts -> AbsurdSolution) -> True+    lr -> any (==AbsurdSolution) (solveEq tcm exts lr)++-- | Get constraint equations+patEqs+  :: TyConMap+  -> Pat+  -> [(Type, Type)]+patEqs tcm pat =+ catMaybes (map (typeEq tcm . varType) (snd (patIds pat)))++-- | If type is an equation, return LHS and RHS.+typeEq+  :: TyConMap+  -> Type+  -> Maybe (Type, Type)+typeEq tcm ty =+ case tyView (coreView tcm ty) of+  TyConApp tc [_, _, left, right]+    | nameUniq tc == fromGhcUnique eqPrimTyConKey ->+    Just (coreView tcm left, coreView tcm right)+  _ ->+    Nothing
+ src/Clash/Core/Evaluator/Types.hs view
@@ -0,0 +1,390 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+  Copyright     : (C) 2020-2024, QBayLogic B.V.+  License       : BSD2 (see the file LICENSE)+  Maintainer    : QBayLogic B.V. <devops@qbaylogic.com>++  Types for the Partial Evaluator+-}+module Clash.Core.Evaluator.Types where++import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap (insert, lookup)+#if !MIN_VERSION_base(4,20,0)+import Data.List (foldl')+#endif+import Data.Maybe (fromMaybe, isJust)++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter (hsep)+#else+import Data.Text.Prettyprint.Doc (hsep)+#endif++import Clash.Core.DataCon (DataCon, dcType)+import Clash.Core.HasType+import Clash.Core.Literal (Literal(CharLiteral))+import Clash.Core.Pretty (fromPpr, ppr, showPpr)+import Clash.Core.Term (Term(..), PrimInfo(..), TickInfo, Alt, mkApps)+import Clash.Core.TyCon (TyConMap)+import Clash.Core.Type (Type (..), mkFunTy)+import Clash.Core.Var (Id, IdScope(..), TyVar)+import Clash.Core.VarEnv+import Clash.Driver.Types (BindingMap, bindingTerm)+import Clash.Pretty (ClashPretty(..), fromPretty, showDoc)+import Clash.Util.Supply (Supply)++whnf'+  :: Evaluator+  -> BindingMap+  -> VarEnv Term+  -> TyConMap+  -> PrimHeap+  -> Supply+  -> InScopeSet+  -> Bool+  -> Term+  -> (PrimHeap, PureHeap, Term)+whnf' eval bm lh tcm ph ids is isSubj e =+  toResult $ whnf eval tcm isSubj m+ where+  toResult x = (mHeapPrim x, mHeapLocal x, mTerm x)++  m  = Machine ph gh lh [] ids is e+  gh = mapVarEnv bindingTerm bm++-- | Evaluate to WHNF given an existing Heap and Stack+whnf+  :: Evaluator+  -> TyConMap+  -> Bool+  -> Machine+  -> Machine+whnf eval tcm isSubj m+  | isSubj =+      -- See [Note: empty case expressions]+      let ty = inferCoreTypeOf tcm (mTerm m)+       in go (stackPush (Scrutinise ty []) m)+  | otherwise = go m+  where+    go :: Machine -> Machine+    go s = case step eval s tcm of+      Just s' -> go s'+      Nothing -> fromMaybe (error . showDoc . ppr $ mTerm m) (unwindStack s)+++-- | An evaluator is a collection of basic building blocks which are used to+-- define partial evaluation. In this implementation, it consists of two types+-- of function:+--+--   * steps, which applies the reduction relation to the current term+--   * unwindings, which pop the stack and evaluate the stack frame+--+-- Variants of these functions also exist for evaluating primitive operations.+-- This is because there may be multiple frontends to the compiler which can+-- reuse a common step and unwind, but have different primitives.+--+data Evaluator = Evaluator+  { step        :: Step+  , unwind      :: Unwind+  , primStep    :: PrimStep+  , primUnwind  :: PrimUnwind+  }++-- | Completely unwind the stack to get back the complete term+unwindStack :: Machine -> Maybe Machine+unwindStack m+  | stackNull m = Just m+  | otherwise = do+      (m', kf) <- stackPop m++      case kf of+        PrimApply p tys vs tms ->+          let term = foldl' App+                       (foldl' App+                         (foldl' TyApp (Prim p) tys)+                         (fmap valToTerm vs))+                       (mTerm m' : tms)+           in unwindStack (setTerm term m')++        Instantiate ty ->+          let term = TyApp (getTerm m') ty+           in unwindStack (setTerm term m')++        Apply n ->+          case heapLookup LocalId n m' of+            Just e ->+              let term = App (getTerm m') e+               in unwindStack (setTerm term m')++            Nothing -> error $ unlines $+              [ "Clash.Core.Evaluator.unwindStack:"+              , "Stack:"+              ] <>+              [ "  " <> showDoc (clashPretty frame) | frame <- mStack m] <>+              [ ""+              , "Expression:"+              , showPpr (mTerm m)+              , ""+              , "Heap:"+              , showDoc (clashPretty $ mHeapLocal m)+              ]++        Scrutinise _ [] ->+          unwindStack m'++        Scrutinise ty alts ->+          let term = Case (getTerm m') ty alts+           in unwindStack (setTerm term m')++        Update LocalId x ->+          unwindStack (heapInsert LocalId x (mTerm m') m')++        Update GlobalId _ ->+          unwindStack m'++        Tickish sp ->+          let term = Tick sp (getTerm m')+           in unwindStack (setTerm term m')++-- | A single step in the partial evaluator. The result is the new heap and+-- stack, and the next expression to be reduced.+--+type Step = Machine -> TyConMap -> Maybe Machine++type Unwind = Value -> Step++type PrimStep+  =  TyConMap+  -> Bool+  -> PrimInfo+  -> [Type]+  -> [Value]+  -> Machine+  -> Maybe Machine++type PrimUnwind+  =  TyConMap+  -> PrimInfo+  -> [Type]+  -> [Value]+  -> Value+  -> [Term]+  -> Machine+  -> Maybe Machine++-- | A machine represents the current state of the abstract machine used to+-- evaluate terms. A machine has a term under evaluation, a stack, and three+-- heaps:+--+--  * a primitive heap to store IO values from primitives (like ByteArrays)+--  * a global heap to store top-level bindings in scope+--  * a local heap to store local bindings in scope+--+-- Machines also include a unique supply and InScopeSet. These are needed when+-- new heap bindings are created, and are just an implementation detail.+--+data Machine = Machine+  { mHeapPrim   :: PrimHeap+  , mHeapGlobal :: PureHeap+  , mHeapLocal  :: PureHeap+  , mStack      :: Stack+  , mSupply     :: Supply+  , mScopeNames :: InScopeSet+  , mTerm       :: Term+  }++instance Show Machine where+  show (Machine ph gh lh s _ _ x) =+    unlines+      [ "Machine:"+      , ""+      , "Heap (Prim):"+      , show ph+      , ""+      , "Heap (Globals):"+      , show gh+      , ""+      , "Heap (Locals):"+      , show lh+      , ""+      , "Stack:"+      , show (fmap clashPretty s)+      , ""+      , "Term:"+      , show x+      ]++type PrimHeap = (IntMap Term, Int)+type PureHeap = VarEnv Term++type Stack = [StackFrame]++data StackFrame+  = Update IdScope Id+  | Apply  Id+  | Instantiate Type+  | PrimApply  PrimInfo [Type] [Value] [Term]+  | Scrutinise Type [Alt]+  | Tickish TickInfo+  deriving Show++instance ClashPretty StackFrame where+  clashPretty (Update GlobalId i) = hsep ["Update(Global)", fromPpr i]+  clashPretty (Update LocalId i)  = hsep ["Update(Local)", fromPpr i]+  clashPretty (Apply i) = hsep ["Apply", fromPpr i]+  clashPretty (Instantiate t) = hsep ["Instantiate", fromPpr t]+  clashPretty (PrimApply p tys vs ts) =+    hsep ["PrimApply", fromPretty (primName p), "::", fromPpr (coreTypeOf p),+          "; type args=", fromPpr tys,+          "; val args=", fromPpr (map valToTerm vs),+          "term args=", fromPpr ts]+  clashPretty (Scrutinise a b) =+    hsep ["Scrutinise ", fromPpr a,+          fromPpr (Case (Literal (CharLiteral '_')) a b)]+  clashPretty (Tickish sp) =+    hsep ["Tick", fromPpr sp]++-- Values+data Value+  = Lambda Id Term+  -- ^ Functions+  | TyLambda TyVar Term+  -- ^ Type abstractions+  | DC DataCon [Either Term Type]+  -- ^ Data constructors+  | Lit Literal+  -- ^ Literals+  | PrimVal  PrimInfo [Type] [Value]+  -- ^ Clash's number types are represented by their "fromInteger#" primitive+  -- function. So some primitives are values.+  | Suspend Term+  -- ^ Used by lazy primitives+  | TickValue TickInfo Value+  -- ^ Preserve ticks from Terms in Values+  | CastValue Value Type Type+  -- ^ Preserve casts from Terms in Values+  deriving Show++instance InferType Value where+  inferCoreTypeOf tcm = go+   where+    go = \case+      Lambda i t -> mkFunTy (coreTypeOf i) (inferCoreTypeOf tcm t)+      TyLambda v t -> ForAllTy v (inferCoreTypeOf tcm t)+      DC dc args -> applyTypeToArgs (mkApps (Data dc) args) tcm (dcType dc) args+      Lit l -> coreTypeOf l+      PrimVal p tys vals ->+        let args = map Right tys ++ map (Left . valToTerm) vals+         in applyTypeToArgs+              (mkApps (Prim p) args)+              tcm+              (primType p)+              args+      Suspend t -> inferCoreTypeOf tcm t+      TickValue _ v -> go v+      CastValue _ _ t -> t++valToTerm :: Value -> Term+valToTerm v = case v of+  Lambda x e           -> Lam x e+  TyLambda x e         -> TyLam x e+  DC dc pxs            -> foldl' (\e a -> either (App e) (TyApp e) a)+                                 (Data dc) pxs+  Lit l                -> Literal l+  PrimVal ty tys vs    -> foldl' App (foldl' TyApp (Prim ty) tys)+                                 (map valToTerm vs)+  Suspend e            -> e+  TickValue t x        -> Tick t (valToTerm x)+  CastValue x t1 t2    -> Cast (valToTerm x) t1 t2++-- Collect all the ticks from a value, exposing the ticked value.+--+collectValueTicks+  :: Value+  -> (Value, [TickInfo])+collectValueTicks = go []+ where+  go ticks (TickValue t v) = go (t:ticks) v+  go ticks v = (v, ticks)++-- | Are we in a context where special primitives must be forced.+--+-- See [Note: forcing special primitives]+forcePrims :: Machine -> Bool+forcePrims = go . mStack+ where+  -- When do we need to force the compile-time evaluation of a primitive?+  --+  -- 1. When they are the subject of a case-expression+  go (Scrutinise{}:_) = True+  -- 2. When they are in the argument position of another primitive:+  --    primitives are assumed to be strict in their arguments+  go (PrimApply{}:_)  = True+  -- We look through ticks+  go (Tickish{}:xs)   = go xs+  -- We are in a context where we dereferenced a heap-binding, hence the+  -- update fram on the stack. So now we need to check whether that variable+  -- reference was in a position where the result must be evaluated to WHNF+  go (Update{}:xs)    = go xs+  go _                = False++primCount :: Machine -> Int+primCount = snd . mHeapPrim++primLookup :: Int -> Machine -> Maybe Term+primLookup i = IntMap.lookup i . fst . mHeapPrim++primInsert :: Int -> Term -> Machine -> Machine+primInsert i x m =+  let (gh, c) = mHeapPrim m+   in m { mHeapPrim = (IntMap.insert i x gh, c + 1) }++primUpdate :: Int -> Term -> Machine -> Machine+primUpdate i x m =+  let (gh, c) = mHeapPrim m+   in m { mHeapPrim = (IntMap.insert i x gh, c) }++heapLookup :: IdScope -> Id -> Machine -> Maybe Term+heapLookup GlobalId i m =+  lookupVarEnv i $ mHeapGlobal m+heapLookup LocalId i m =+  lookupVarEnv i $ mHeapLocal m++heapContains :: IdScope -> Id -> Machine -> Bool+heapContains scope i = isJust . heapLookup scope i++heapInsert :: IdScope -> Id -> Term -> Machine -> Machine+heapInsert GlobalId i x m =+  m { mHeapGlobal = extendVarEnv i x (mHeapGlobal m) }+heapInsert LocalId i x m =+  m { mHeapLocal = extendVarEnv i x (mHeapLocal m) }++heapDelete :: IdScope -> Id -> Machine -> Machine+heapDelete GlobalId i m =+  m { mHeapGlobal = delVarEnv (mHeapGlobal m) i }+heapDelete LocalId i m =+  m { mHeapLocal = delVarEnv (mHeapLocal m) i }++stackPush :: StackFrame -> Machine -> Machine+stackPush f m = m { mStack = f : mStack m }++stackPop :: Machine -> Maybe (Machine, StackFrame)+stackPop m = case mStack m of+  [] -> Nothing+  (x:xs) -> Just (m { mStack = xs }, x)++stackClear :: Machine -> Machine+stackClear m = m { mStack = [] }++stackNull :: Machine -> Bool+stackNull = null . mStack++getTerm :: Machine -> Term+getTerm = mTerm++setTerm :: Term -> Machine -> Machine+setTerm x m = m { mTerm = x }
+ src/Clash/Core/FreeVars.hs view
@@ -0,0 +1,294 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente+                     2021,      QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Free variable calculations+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}++module Clash.Core.FreeVars+  (-- * Free variable calculation+    typeFreeVars+  , freeIds+  , freeLocalVars+  , freeLocalIds+  , globalIds+  , termFreeTyVars+  -- * occurrence check+  , globalIdOccursIn+  , localVarsDoNotOccurIn+  , countFreeOccurances+  -- * Internal+  , typeFreeVars'+  , termFreeVars'+  )+where++#if MIN_VERSION_ghc(9,8,4) || (MIN_VERSION_ghc(9,6,7) && !MIN_VERSION_ghc(9,8,0))+#define UNIQUE_IS_WORD64+#endif++import qualified Control.Lens           as Lens+import Control.Lens.Fold                (Fold)+import Control.Lens.Getter              (Contravariant)+import Data.Coerce+#ifdef UNIQUE_IS_WORD64+import qualified GHC.Data.Word64Set     as IntSet+#else+import qualified Data.IntSet            as IntSet+#endif+import Data.Monoid                      (All (..), Any (..))++import Clash.Core.Term                  (Pat (..), Term (..), TickInfo (..), Bind(..))+import Clash.Core.Type                  (Type (..))+import Clash.Core.Var+  (Id, IdScope (..), TyVar, Var (..), isLocalId)+import Clash.Core.VarEnv+  (VarEnv, emptyVarEnv, unionVarEnvWith, unitVarEnv)++-- | Gives the free type-variables in a Type, implemented as a 'Fold'+--+-- The 'Fold' is closed over the types of its variables, so:+--+-- @+-- foldMapOf typeFreeVars unitVarSet ((a:* -> k) Int) = {a, k}+-- @+typeFreeVars :: Fold Type TyVar+typeFreeVars = typeFreeVars' (const True) IntSet.empty++-- | Gives the "interesting" free variables in a Type, implemented as a 'Fold'+--+-- The 'Fold' is closed over the types of variables, so:+--+-- @+-- foldMapOf (typeFreeVars' (const True) IntSet.empty) unitVarSet ((a:* -> k) Int) = {a, k}+-- @+--+-- Note [Closing over kind variables]+--+-- Consider the type+--+-- > forall k . b -> k+--+-- where+--+-- > b :: k -> Type+--+-- When we close over the free variables of @forall k . b -> k@, i.e. @b@, then+-- the @k@ in @b :: k -> Type@ is most definitely /not/ the @k@ in+-- @forall k . b -> k@. So when a type variable is free, i.e. not in the inScope+-- set, its kind variables also aren´t; so in order to prevent collisions due to+-- shadowing we close using an empty inScope set.+--+-- See also: https://gitlab.haskell.org/ghc/ghc/-/commit/503514b94f8dc7bd9eab5392206649aee45f140b+typeFreeVars'+  :: (Contravariant f, Applicative f)+  => (forall b . Var b -> Bool)+  -- ^ Predicate telling whether a variable is interesting+#ifdef UNIQUE_IS_WORD64+  -> IntSet.Word64Set+#else+  -> IntSet.IntSet+#endif+  -- ^ Uniques of the variables in scope, used by 'termFreeVars''+  -> (Var a -> f (Var a))+  -> Type+  -> f Type+typeFreeVars' interesting is f = go is where+  go inScope = \case+    VarTy tv -> tv1 <* go inScope1 (varType tv)+      where+        isInteresting = interesting tv+        tvInScope     = varUniq tv `IntSet.member` inScope+        inScope1+          | tvInScope = inScope+          | otherwise = IntSet.empty -- See Note [Closing over type variables]++        tv1 | isInteresting+            , not tvInScope+            = VarTy . coerce <$> f (coerce tv)+            | otherwise+            = pure (VarTy tv)++    ForAllTy tv ty -> ForAllTy <$> goBndr inScope tv+                               <*> go (IntSet.insert (varUniq tv) inScope) ty+    AppTy l r -> AppTy <$> go inScope l <*> go inScope r+    ty -> pure ty++  goBndr inScope tv = (\t -> tv {varType = t}) <$> go inScope (varType tv)++-- | Check whether a set of variables does not occur free in a term+localVarsDoNotOccurIn+  :: [Var a]+  -> Term+  -> Bool+localVarsDoNotOccurIn vs e =+  getAll (Lens.foldMapOf freeLocalVars (All . (`notElem` vs)) e)++-- | Check whether a local identifier occurs free in a term+globalIdOccursIn+  :: Id+  -> Term+  -> Bool+globalIdOccursIn v e = getAny (Lens.foldMapOf globalIds (Any . (== v)) e)++-- | Calculate the /local/ free variable of an expression: the free type+-- variables and the free identifiers that are not bound in the global+-- environment.+freeLocalVars :: Fold Term (Var a)+freeLocalVars = termFreeVars' isLocalVar where+  isLocalVar (Id {idScope = GlobalId}) = False+  isLocalVar _ = True++-- | Gives the free identifiers of a Term, implemented as a 'Fold'+freeIds :: Fold Term Id+freeIds = termFreeVars' isId where+  isId (Id {}) = True+  isId _       = False++-- | Calculate the /local/ free identifiers of an expression: the free+-- identifiers that are not bound in the global environment.+freeLocalIds :: Fold Term Id+freeLocalIds = termFreeVars' isLocalId++-- | Calculate the /global/ free identifiers of an expression: the free+-- identifiers that are bound in the global environment.+globalIds :: Fold Term Id+globalIds = termFreeVars' isGlobalId where+  isGlobalId (Id {idScope = GlobalId}) = True+  isGlobalId _ = False++-- | Gives the free type-variables of a Term, implemented as a 'Fold'+--+-- The 'Fold' is closed over the types of variables, so:+--+-- @+-- foldMapOf termFreeTyVars unitVarSet (case (x : (a:* -> k) Int)) of {}) = {a, k}+-- @+termFreeTyVars :: Fold Term TyVar+termFreeTyVars = termFreeVars' isTV where+  isTV (TyVar {}) = True+  isTV _          = False++-- | Gives the "interesting" free variables in a Term, implemented as a 'Fold'+--+-- The 'Fold' is closed over the types of variables, so:+--+-- @+-- foldMapOf (termFreeVars' (const True)) unitVarSet (case (x : (a:* -> k) Int)) of {}) = {x, a, k}+-- @+--+-- Note [Closing over type variables]+--+-- Consider the term+--+-- > /\(k :: Type) -> \(b :: k) -> a+--+-- where+--+-- > a :: k+--+-- When we close over the free variables of @/\k -> \(b :: k) -> (a :: k)@, i.e.+-- @a@, then the @k@ in @a :: k@ is most definitely /not/ the @k@ in introduced+-- by the @/\k ->@. So when a term variable is free, i.e. not in the inScope+-- set, its type variables also aren´t; so in order to prevent collisions due to+-- shadowing we close using an empty inScope set.+--+-- See also: https://gitlab.haskell.org/ghc/ghc/-/commit/503514b94f8dc7bd9eab5392206649aee45f140b+termFreeVars'+  :: (Contravariant f, Applicative f)+  => (forall b . Var b -> Bool)+  -- ^ Predicate telling whether a variable is interesting+  -> (Var a -> f (Var a))+  -> Term+  -> f Term+termFreeVars' interesting f = go IntSet.empty where+  go inLocalScope = \case+    Var v -> v1 <* typeFreeVars' interesting inLocalScope1 f (varType v)+      where+        isInteresting = interesting v+        vInScope      = isLocalId v && varUniq v `IntSet.member` inLocalScope+        inLocalScope1+          | vInScope  = inLocalScope+          | otherwise = IntSet.empty -- See Note [Closing over type variables]++        v1 | isInteresting+           , not vInScope+           = Var . coerce <$> f (coerce v)+           | otherwise+           = pure (Var v)++    Lam id_ tm ->+      Lam <$> goBndr inLocalScope id_+          <*> go (IntSet.insert (varUniq id_) inLocalScope) tm+    TyLam tv tm ->+      TyLam <$> goBndr inLocalScope tv+            <*> go (IntSet.insert (varUniq tv) inLocalScope) tm++    App l r ->+      App <$> go inLocalScope l <*> go inLocalScope r++    TyApp l r ->+      TyApp <$> go inLocalScope l+            <*> typeFreeVars' interesting inLocalScope f r++    Let (NonRec i x) e ->+      Let <$> (NonRec <$> goBndr inLocalScope i <*> go inLocalScope x)+          <*> go (IntSet.insert (varUniq i) inLocalScope) e++    Let (Rec bs) e ->+      Let <$> (Rec <$> traverse (goBind inLocalScope') bs)+          <*> go inLocalScope' e+     where+      inLocalScope' = foldr (IntSet.insert . varUniq . fst) inLocalScope bs++    Case subj ty alts ->+      Case <$> go inLocalScope subj+           <*> typeFreeVars' interesting inLocalScope f ty+           <*> traverse (goAlt inLocalScope) alts++    Cast tm t1 t2 ->+      Cast <$> go inLocalScope tm+           <*> typeFreeVars' interesting inLocalScope f t1+           <*> typeFreeVars' interesting inLocalScope f t2++    Tick tick tm ->+      Tick <$> goTick inLocalScope tick+      <*> go inLocalScope tm++    tm -> pure tm++  goBndr inLocalScope v =+    (\t -> v  {varType = t}) <$> typeFreeVars' interesting inLocalScope f (varType v)++  goBind inLocalScope (l,r) = (,) <$> goBndr inLocalScope l <*> go inLocalScope r++  goAlt inLocalScope (pat,alt) = case pat of+    DataPat dc tvs ids -> (,) <$> (DataPat <$> pure dc+                                           <*> traverse (goBndr inLocalScope') tvs+                                           <*> traverse (goBndr inLocalScope') ids)+                              <*> go inLocalScope' alt+      where+        inLocalScope' = foldr IntSet.insert+                         (foldr IntSet.insert inLocalScope (map varUniq tvs))+                         (map varUniq ids)+    _ -> (,) <$> pure pat <*> go inLocalScope alt++  goTick inLocalScope = \case+    NameMod m ty -> NameMod m <$> typeFreeVars' interesting inLocalScope f ty+    Attributes ty tm -> Attributes <$> typeFreeVars' interesting inLocalScope f ty+                                   <*> go inLocalScope tm+    tick         -> pure tick++-- | Get the free variables of an expression and count the number of occurrences+countFreeOccurances+  :: Term+  -> VarEnv Int+countFreeOccurances =+  Lens.foldMapByOf freeLocalIds (unionVarEnvWith (+)) emptyVarEnv+                   (`unitVarEnv` (1 :: Int))
+ src/Clash/Core/HasFreeVars.hs view
@@ -0,0 +1,93 @@+{-|+Copyright   : (C) 2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>++Utility class to extract free variables from data which has variables.+-}++{-# LANGUAGE FlexibleInstances #-}++module Clash.Core.HasFreeVars+  ( HasFreeVars(..)+  ) where++import Control.Lens as Lens (foldMapOf)+import Data.Monoid (All(..), Any(..))++import Clash.Core.FreeVars+import Clash.Core.Term (Term)+import Clash.Core.Type (Type(..))+import Clash.Core.Var (Var)+import Clash.Core.VarEnv++class HasFreeVars a where+  {-# MINIMAL freeVarsOf #-}++  freeVarsOf :: a -> VarSet++  {-# INLINE isClosed #-}+  -- | Something is closed if it has no free variables.+  -- This function may be replaced with a more efficient implementation.+  isClosed :: a -> Bool+  isClosed = nullVarSet . freeVarsOf++  {-# INLINE elemFreeVars #-}+  -- | Check if a variable is free in the given value.+  -- This function may be replaced with a more efficient implementation.+  elemFreeVars :: Var a -> a -> Bool+  elemFreeVars v = elemVarSet v . freeVarsOf++  {-# INLINE notElemFreeVars #-}+  -- | Check if a variable is not free in the given value.+  -- This function may be replaced with a more efficient implementation.+  notElemFreeVars :: Var a -> a -> Bool+  notElemFreeVars x = notElemVarSet x . freeVarsOf++  {-# INLINE subsetFreeVars #-}+  -- | Check if all variables in a set are free in the given value.+  -- This function may be replaced with a more efficient implementation.+  subsetFreeVars :: VarSet -> a -> Bool+  subsetFreeVars xs = subsetVarSet xs . freeVarsOf++  {-# INLINE disjointFreeVars #-}+  -- | Check if no variables in a set are free in the given value.+  -- This function may be replaced with a more efficient implementation.+  disjointFreeVars :: VarSet -> a -> Bool+  disjointFreeVars xs = disjointVarSet xs . freeVarsOf++instance HasFreeVars Term where+  {-# INLINE freeVarsOf #-}+  freeVarsOf =+    Lens.foldMapOf freeLocalVars unitVarSet++  elemFreeVars v e =+    getAny (Lens.foldMapOf freeLocalVars (Any . (== v)) e)++  notElemFreeVars v e =+    getAll (Lens.foldMapOf freeLocalVars (All . (/= v)) e)++  disjointFreeVars vs e =+    getAll (Lens.foldMapOf freeLocalVars (All . (`notElem` vs)) e)++instance HasFreeVars Type where+  {-# INLINE freeVarsOf #-}+  freeVarsOf =+    Lens.foldMapOf typeFreeVars unitVarSet++  isClosed ty =+    case ty of+      VarTy{} -> False+      ForAllTy{} -> getAll (Lens.foldMapOf typeFreeVars (const (All False)) ty)+      AppTy l r -> isClosed l && isClosed r+      _ -> True++  elemFreeVars v ty =+    getAny (Lens.foldMapOf typeFreeVars (Any . (== v)) ty)++  notElemFreeVars v ty =+    getAll (Lens.foldMapOf typeFreeVars (All . (/= v)) ty)++instance (Foldable f, HasFreeVars a) => HasFreeVars (f a) where+  {-# INLINE freeVarsOf #-}+  freeVarsOf = foldMap freeVarsOf
+ src/Clash/Core/HasType.hs view
@@ -0,0 +1,268 @@+{-|+Copyright   : (C) 2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>++Utility class to extract type information from data which has a type.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Core.HasType+  ( HasType(..)+  , coreKindOf+  , InferType(..)+  , inferCoreKindOf+  , applyTypeToArgs+  , piResultTy+  , piResultTys+  ) where++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter (line)+#else+import Data.Text.Prettyprint.Doc (line)+#endif++import GHC.Stack (HasCallStack)++import Clash.Core.DataCon (DataCon(dcType))+import Clash.Core.HasFreeVars+import Clash.Core.Literal (Literal(..))+import Clash.Core.Pretty+import Clash.Core.Subst+import Clash.Core.Term (Term(..), IsMultiPrim(..), PrimInfo(..), collectArgs)+import Clash.Core.TyCon (TyCon(tyConKind), TyConMap, isTupleTyConLike)+import Clash.Core.Type+import Clash.Core.TysPrim+import Clash.Core.Var (Var(varType))+import Clash.Core.VarEnv+import qualified Clash.Data.UniqMap as UniqMap+import Clash.Debug (debugIsOn)+import Clash.Util (curLoc, pprPanic)+import qualified Clash.Util.Interpolate as I++class HasType a where+  coreTypeOf :: a -> Type++coreKindOf :: (HasType a) => a -> Kind+coreKindOf = coreTypeOf+{-# INLINE coreKindOf #-}++instance HasType DataCon where+  coreTypeOf = dcType++instance HasType Literal where+  coreTypeOf = \case+    IntegerLiteral _ -> integerPrimTy+    IntLiteral _ -> intPrimTy+    WordLiteral _ -> wordPrimTy+    StringLiteral _ -> stringPrimTy+    FloatLiteral _ -> floatPrimTy+    DoubleLiteral _ -> doublePrimTy+    CharLiteral _ -> charPrimTy+    Int64Literal _ -> int64PrimTy+    Word64Literal _ -> word64PrimTy+    Int8Literal _ -> int8PrimTy+    Int16Literal _ -> int16PrimTy+    Int32Literal _ -> int32PrimTy+    Word8Literal _ -> word8PrimTy+    Word16Literal _ -> word16PrimTy+    Word32Literal _ -> word32PrimTy+    NaturalLiteral _ -> naturalPrimTy+    ByteArrayLiteral _ -> byteArrayPrimTy++instance HasType PrimInfo where+  coreTypeOf pr =+    case primMultiResult pr of+      SingleResult -> primType pr++      -- See Note [MultiResult type] in Clash.Normalize.Transformations.MultiPrim+      MultiResult+        | let (primArgs, primResTy) = splitFunForallTy (primType pr)+        , TyConApp tupTcNm tupArgs <- tyView primResTy+        , isTupleTyConLike tupTcNm+        -> mkPolyFunTy primResTy (primArgs <> fmap Right tupArgs)++        | otherwise+        -> error "PrimInfo.coreTypeOf: MultiResult primitive without tuple type"++instance HasType TyCon where+  coreTypeOf = tyConKind++instance HasType Type where+  coreTypeOf = id++instance HasType (Var a) where+  coreTypeOf = varType++class InferType a where+  inferCoreTypeOf :: TyConMap -> a -> Type++inferCoreKindOf :: (InferType a) => TyConMap -> a -> Kind+inferCoreKindOf = inferCoreTypeOf+{-# INLINE inferCoreKindOf #-}++instance InferType Type where+  inferCoreTypeOf tcm ty =+    case tyView ty of+      FunTy{} ->+        liftedTypeKind++      TyConApp tc args ->+        piResultTys tcm (tyConKind (UniqMap.find tc tcm)) args++      OtherType{} ->+        case ty of+          ConstTy c -> error $ $(curLoc) ++ "inferCoreTypeOf: naked ConstTy: " ++ show c+          VarTy k -> varType k+          ForAllTy _ a -> inferCoreTypeOf tcm a+          LitTy NumTy{} -> typeNatKind+          LitTy SymTy{} -> typeSymbolKind+          LitTy CharTy{} -> charPrimTy+          AnnType _ a -> inferCoreTypeOf tcm a+          AppTy a b -> go a [b]+           where+            go (AppTy c d) args = go c (d : args)+            go c args = piResultTys tcm (inferCoreTypeOf tcm c) args++instance InferType Term where+  inferCoreTypeOf tcm = go+   where+    go = \case+      Var i -> coreTypeOf i+      Data dc -> coreTypeOf dc+      Literal l -> coreTypeOf l+      Prim pr -> coreTypeOf pr+      Lam i x -> mkFunTy (coreTypeOf i) (go x)+      TyLam i x -> ForAllTy i (go x)++      x@App{} ->+        case collectArgs x of+          (fun, args) -> applyTypeToArgs x tcm (go fun) args++      x@TyApp{} ->+        case collectArgs x of+          (fun, args) -> applyTypeToArgs x tcm (go fun) args++      Let _ x -> go x+      Case _ ty _ -> ty+      Cast _ _ a -> a+      Tick _ x -> go x++-- | Get the result type of a polymorphic function given a list of arguments+applyTypeToArgs+  :: Term+  -- ^ The complete term, used for error messages.+  -> TyConMap+  -> Type+  -> [Either Term Type]+  -> Type+applyTypeToArgs e m opTy args = go opTy args+ where+  go opTy' []               = opTy'+  go opTy' (Right ty:args') = goTyArgs opTy' [ty] args'+  go opTy' (Left a:args')   = case splitFunTy m opTy' of+    Just (_,resTy) -> go resTy args'+    _ -> error [I.i|+        Unexpected application. The term++          #{showPpr e}++        applied an argument++          #{showPpr a}++        to something with the non-function type++          #{showPpr opTy'}+      |]++  goTyArgs opTy' revTys (Right ty:args') = goTyArgs opTy' (ty:revTys) args'+  goTyArgs opTy' revTys args'            = go (piResultTys m opTy' (reverse revTys)) args'++-- | Like 'piResultTys', but only applies a single type. If multiple types are+-- being applied use 'piResultTys', as it is more efficient to only substitute+-- once with many types.+piResultTy+  :: HasCallStack+  => TyConMap+  -> Type+  -> Type+  -> Type+piResultTy m ty arg =+  piResultTys m ty [arg]++-- | @(piResultTys f_ty [ty1, ..., tyn])@ gives the type of @(f ty1 .. tyn)@+-- where @f :: f_ty@+--+-- 'piResultTys' is interesting because:+--+--    1. 'f_ty' may have more foralls than there are args+--    2. Less obviously, it may have fewer foralls+--+-- Fore case 2. think of:+--+--   piResultTys (forall a . a) [forall b.b, Int]+--+-- This really can happen, such as situations involving 'undefined's type:+--+--   undefined :: forall a. a+--+--   undefined (forall b. b -> b) Int+--+-- This term should have the type @(Int -> Int)@, but notice that there are+-- more type args than foralls in 'undefined's type.+--+-- For efficiency reasons, when there are no foralls, we simply drop arrows from+-- a function type/kind.+piResultTys+  :: HasCallStack+  => TyConMap+  -> Type+  -> [Type]+  -> Type+piResultTys _ ty [] = ty+piResultTys m ty origArgs@(arg:args)+  | Just ty' <- coreView1 m ty+  = piResultTys m ty' origArgs+  | FunTy a res <- tyView ty+  -- TODO coreView is used here because the partial evaluator will sometimes+  -- encounter / not encounter a Signal as an argument unexpectedly. When PR+  -- #1064 is merged the coreView calls should be removed again.+  = if debugIsOn && not (aeqType (coreView m a) (coreView m arg)) then error [I.i|+      Unexpected application. A function with type:++        #{showPpr ty}++      Got applied to an argument of type:++        #{showPpr arg}+    |]+    else+      piResultTys m res args+  | ForAllTy tv res <- ty+  = go (extendVarEnv tv arg emptyVarEnv) res args+  | otherwise+  = pprPanic "piResultTys1" (ppr ty <> line <> ppr origArgs)+ where+  inScope = mkInScopeSet (freeVarsOf (ty:origArgs))++  go env ty' [] = substTy (mkTvSubst inScope env) ty'+  go env ty' allArgs@(arg':args')+    | Just ty'' <- coreView1 m ty'+    = go env ty'' allArgs+    | FunTy _ res <- tyView ty'+    = go env res args'+    | ForAllTy tv res <- ty'+    = go (extendVarEnv tv arg' env) res args'+    | VarTy tv <- ty'+    , Just ty'' <- lookupVarEnv tv env+      -- Deals with (piResultTys  (forall a.a) [forall b.b, Int])+    = piResultTys m ty'' allArgs+    | otherwise+    = pprPanic "piResultTys2" (ppr ty' <> line <> ppr origArgs <> line <> ppr allArgs)
+ src/Clash/Core/Literal.hs view
@@ -0,0 +1,66 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                     2016     , Myrtle Software Ltd,+                     2017     , Google Inc.,+                     2021     , QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Term Literal+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Clash.Core.Literal+  ( Literal (..)+  ) where++import Control.DeepSeq                        (NFData (..))+import Data.Binary                            (Binary)+import Data.Hashable                          (Hashable)+import Data.Primitive.ByteArray               (ByteArray)+import Data.Primitive.ByteArray.Extra         ()+import Data.Word                              (Word32, Word64)+import GHC.Generics                           (Generic)++{-+Note [Storage of floating point in Literal]+-------------------------------------------++GHC stores literals of 'Float' and 'Double' as 'Rational'. However, unlike+GHC, we also need to store transfinite "literals". We need to preserve all+information there is in a specific code word representing a floating point+value.++Storing them as 'Float' and 'Double' here introduces issues with 'Eq' and+'Hashable'. 0.0 == -0.0, and NaN compares unequal to everything including+itself.++Also unlike GHC, we already assume that 'Float' is single-precision IEEE-754,+and 'Double' is double-precision IEEE-754. So we can store them as 'Word32'+and 'Word64' and get the 'Eq' and hashing properties we require.+-}++-- | Term Literal+data Literal+  = IntegerLiteral  !Integer+  | IntLiteral      !Integer+  | WordLiteral     !Integer+  | Int64Literal    !Integer+  | Word64Literal   !Integer+  | Int8Literal     !Integer+  | Int16Literal    !Integer+  | Int32Literal    !Integer+  | Word8Literal    !Integer+  | Word16Literal   !Integer+  | Word32Literal   !Integer+  | StringLiteral   !String+  | FloatLiteral    !Word32+  | DoubleLiteral   !Word64+  | CharLiteral     !Char+  | NaturalLiteral  !Integer+  | ByteArrayLiteral !ByteArray+  deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary)
+ src/Clash/Core/Name.hs view
@@ -0,0 +1,87 @@+{-|+  Copyright   :  (C) 2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  Names+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Core.Name+  ( module Clash.Core.Name+  , noSrcSpan+  )+where++import           Control.DeepSeq                        (NFData)+import           Data.Binary                            (Binary)+import           Data.Function                          (on)+import           Data.Hashable                          (Hashable (..))+import           Data.Text                              (Text, append)+import           GHC.BasicTypes.Extra                   ()+import           GHC.Generics                           (Generic)+import           GHC.SrcLoc.Extra                       ()+import           GHC.Types.SrcLoc                       (SrcSpan, noSrcSpan)++import           Clash.Unique++data Name a+  = Name+  { nameSort :: NameSort+  , nameOcc  :: !OccName+  , nameUniq :: {-# UNPACK #-} !Unique+  , nameLoc  :: !SrcSpan+  }+  deriving (Show,Generic,NFData,Binary)++instance Eq (Name a) where+  (==) = (==) `on` nameUniq+  (/=) = (/=) `on` nameUniq++instance Ord (Name a) where+  compare = compare `on` nameUniq++instance Hashable (Name a) where+  hashWithSalt salt nm = hashWithSalt salt (nameUniq nm)++instance Uniquable (Name a) where+  getUnique = nameUniq+  setUnique nm u = nm {nameUniq=u}++type OccName = Text++data NameSort+  = User+  | System+  | Internal+  deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary)++mkUnsafeName+  :: NameSort+  -> Text+  -> Unique+  -> Name a+mkUnsafeName ns s i = Name ns s i noSrcSpan++mkUnsafeSystemName+  :: Text+  -> Unique+  -> Name a+mkUnsafeSystemName s i = Name System s i noSrcSpan++mkUnsafeInternalName+  :: Text+  -> Unique+  -> Name a+mkUnsafeInternalName s i = Name Internal ("c$" `append` s) i noSrcSpan++appendToName :: Name a -> Text -> Name a+appendToName (Name sort nm uniq loc) s = Name Internal nm2 uniq loc+  where+    nm1 = case sort of {Internal -> nm; _ -> "c$" `append` nm}+    nm2 = nm1 `append` s
+ src/Clash/Core/PartialEval.hs view
@@ -0,0 +1,98 @@+{-|+Copyright   : (C) 2020 QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>++The main API of the partial evaluator. This exposes the main functions needed+to call the evaluator, and the type of evaluators. A concrete implementation+of an evaluator is required to use this module: this can be imported from the+library for the compiler front-end, e.g. Clash.GHC.PartialEval in clash-ghc.+-}++module Clash.Core.PartialEval where++import Data.IntMap.Strict (IntMap)++import Clash.Core.PartialEval.AsTerm+import Clash.Core.PartialEval.Monad+import Clash.Core.PartialEval.NormalForm+import Clash.Core.Term (Term)+import Clash.Core.TyCon (TyConMap)+import Clash.Core.Var (Id)+import Clash.Core.VarEnv (InScopeSet)+import Clash.Driver.Types (Binding(..), BindingMap)+import Clash.Util.Supply (Supply)++-- | An evaluator for Clash core. This consists of two functions: one to+-- evaluate a term to weak-head normal form (WHNF) and another to recursively+-- evaluate sub-terms to obtain beta-normal eta-long form (NF).+--+data Evaluator = Evaluator+  { evalWhnf :: Term  -> Eval Value+  , quoteNf  :: Value -> Eval Normal+  }++-- | Evaluate a term to WHNF, converting the result back to a Term.+-- The global environment at the end of evaluation is also returned, callers+-- should preserve any parts of the global environment needed for later calls.+--+whnf+  :: Evaluator+  -- ^ The evaluator implementation to use.+  -> GlobalEnv+  -- ^ The initial global environment.+  -> Bool+  -- ^ Whether evaluation should keep lifted data constructors.+  -- See NOTE [Lifted Constructors] in Clash.Core.PartialEval.NormalForm.+  -> Id+  -- ^ The id of the term under evaluation.+  -> Term+  -- ^ The term under evaluation.+  -> IO (Term, GlobalEnv)+  -- ^ The term evalated to WHNF, and the final global environment.+whnf e g isSubj i x =+  let l = LocalEnv i mempty mempty (genvFuel g) isSubj+   in runEval g l (asTerm <$> evalWhnf e x)++-- | Evaluate a term to NF, converting the result back to a Term.+-- See `whnf` for more details.+--+nf+  :: Evaluator+  -- ^ The evaluator implementation to use.+  -> GlobalEnv+  -- ^ The initial global environment.+  -> Bool+  -- ^ Whether evaluation should keep lifted data constructors.+  -- See NOTE [Lifted Constructors] in Clash.Core.PartialEval.NormalForm.+  -> Id+  -- ^ The id of the term under evaluation.+  -> Term+  -- ^ The term under evaluation.+  -> IO (Term, GlobalEnv)+  -- ^ The term evalated to NF, and the final global environment.+nf e g isSubj i x =+  let l = LocalEnv i mempty mempty (genvFuel g) isSubj+   in runEval g l (asTerm <$> (evalWhnf e x >>= quoteNf e))++mkGlobalEnv+  :: BindingMap+  -- ^ Global bindings available to the evaluator.+  -> TyConMap+  -- ^ The type constructors known by Clash.+  -> InScopeSet+  -- ^ The set of variables in scope during evaluation.+  -> Supply+  -- ^ The supply of fresh names for variables.+  -> Word+  -- ^ The initial supply of fuel.+  -> IntMap Value+  -- ^ The initial IO heap.+  -> Int+  -- ^ The address of the next heap element.+  -> GlobalEnv+mkGlobalEnv bm tcm iss ids fuel heap addr =+  GlobalEnv (fmap asThunk bm) tcm iss ids fuel heap addr mempty+ where+  asThunk b@Binding{bindingId=i,bindingTerm=t} =+    b { bindingTerm = VThunk t (LocalEnv i mempty mempty fuel False) }
+ src/Clash/Core/PartialEval/AsTerm.hs view
@@ -0,0 +1,76 @@+{-|+Copyright   : (C) 2020-2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>++The AsTerm class and relevant instances for the partial evaluator. This+defines how to convert normal forms back into Terms which can be given as the+result of evaluation.+-}++{-# LANGUAGE LambdaCase #-}++module Clash.Core.PartialEval.AsTerm+  ( AsTerm(..)+  ) where++import Data.Bifunctor (first, second)++import Clash.Core.HasFreeVars+import Clash.Core.PartialEval.NormalForm+import Clash.Core.Term (Bind(..), Term(..), Pat, Alt, mkApps)+import Clash.Core.VarEnv (elemVarSet)++-- | Convert a term in some normal form back into a Term. This is important,+-- as it may perform substitutions which have not yet been performed (i.e. when+-- converting from WHNF where heads contain the environment at that point).+--+class AsTerm a where+  asTerm:: a -> Term++instance (AsTerm a) => AsTerm (Neutral a) where+  asTerm = \case+    NeVar i -> Var i+    NePrim pr args -> mkApps (Prim pr) (argsToTerms args)+    NeApp x y -> App (asTerm x) (asTerm y)+    NeTyApp x ty -> TyApp (asTerm x) ty+    NeLet bs x -> removeUnusedBindings (fmap asTerm bs) (asTerm x)+    NeCase x ty alts -> Case (asTerm x) ty (altsToTerms alts)++removeUnusedBindings :: Bind Term -> Term -> Term+removeUnusedBindings bs x+  | isUsed bs = Let bs x+  | otherwise = x+ where+  free = freeVarsOf x++  isUsed = \case+    NonRec i _ -> elemVarSet i free+    Rec xs -> any (flip elemVarSet free . fst) xs++instance AsTerm Value where+  asTerm = \case+    VNeutral neu -> asTerm neu+    VLiteral lit -> Literal lit+    VData dc args _env -> mkApps (Data dc) (argsToTerms args)+    VLam i x _env -> Lam i x+    VTyLam i x _env -> TyLam i x+    VCast x a b -> Cast (asTerm x) a b+    VTick x tick -> Tick tick (asTerm x)+    VThunk x _env -> x++instance AsTerm Normal where+  asTerm = \case+    NNeutral neu -> asTerm neu+    NLiteral lit -> Literal lit+    NData dc args -> mkApps (Data dc) (argsToTerms args)+    NLam i x _env -> Lam i (asTerm x)+    NTyLam i x _env -> TyLam i (asTerm x)+    NCast x a b -> Cast (asTerm x) a b+    NTick x tick -> Tick tick (asTerm x)++argsToTerms :: (AsTerm a) => Args a -> Args Term+argsToTerms = fmap $ first asTerm++altsToTerms :: (AsTerm a) => [(Pat, a)] -> [Alt]+altsToTerms = fmap $ second asTerm
+ src/Clash/Core/PartialEval/Monad.hs view
@@ -0,0 +1,313 @@+{-|+Copyright   : (C) 2020-2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>++The monad for partial evaluation, and its API. This should contain all+auxiliary functions needed to define new evaluator implementations. This+module is only needed to define new evaluators, for calling an existing+evaluator see Clash.Core.PartialEval.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}++module Clash.Core.PartialEval.Monad+  ( -- * Partial Evaluation Monad+    Eval+  , runEval+    -- * Local and Global Environments+  , getLocalEnv+  , setLocalEnv+  , modifyLocalEnv+  , getGlobalEnv+  , modifyGlobalEnv+    -- * Evaluation Context+  , getContext+  , withContext+    -- * Local Type Bindings+  , getTvSubst+  , findTyVar+  , withTyVar+  , withTyVars+    -- * Local Term Bindings+  , findId+  , withId+  , withIds+  , withoutId+    -- * Global Term Bindings+  , findBinding+  , replaceBinding+    -- * IO Heap Bindings+  , getRef+  , setRef+    -- * Lifted Data Constructors+  , isKeepingLifted+  , keepLifted+    -- * Fuel+  , getFuel+  , withFuel+  , preserveFuel+    -- * Accessing Global State+  , getTyConMap+  , getInScope+    -- * Fresh Variable Generation+  , getUniqueId+  , getUniqueTyVar+    -- * Work free check+  , workFreeValue+  ) where++import           Control.Applicative (Alternative)+import           Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)+import           Control.Monad.IO.Class (MonadIO)++import           Control.Monad.RWS.Strict (RWST, MonadReader, MonadState)+import qualified Control.Monad.RWS.Strict as RWS+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map.Strict as Map++import           Clash.Core.HasFreeVars+import           Clash.Core.Name (OccName)+import           Clash.Core.PartialEval.AsTerm+import           Clash.Core.PartialEval.NormalForm+import           Clash.Core.Subst (Subst, mkTvSubst)+import           Clash.Core.TyCon (TyConMap)+import           Clash.Core.Type (Kind, KindOrType, Type)+import           Clash.Core.Util (mkUniqSystemId, mkUniqSystemTyVar)+import           Clash.Core.Var (Id, TyVar, Var)+import           Clash.Core.VarEnv+import           Clash.Driver.Types (Binding(..))+import           Clash.Rewrite.WorkFree (isWorkFree)+import           Clash.Util.Supply (Supply)++{-+NOTE [RWS monad]+~~~~~~~~~~~~~~~~+Local bindings are kept in the Reader monad and global bindings in the State+monad. This ensures that global changes are propagated to later evaluation+actions whereas local changes only exist when evaluating a particular sub-term.+For example, consider the term++   (let ... in f) (let ... in x)++When evaluating this, the let bindings in the left sub-term should not be in+scope when evaluating the right sub-term. By using only the State monad for+local and global state, too much care needs to be given to ensuring that local+bindings are saved and restored when evaluating different sub-terms.++The MonadWriter instance is deliberately not derived here, as the Writer monad+functionality of RWST is not wanted.+-}++-- TODO The inner monad here could be changed to STM to allow the evaluator+-- to work on evaluating sub-terms concurrently. That would require slightly+-- different environment types, where data can be stored in STM types.++-- | The monad of partial evaluation. The inner monad is IO, as primitive+-- evaluation can attempt to evaluate IO actions.+--+newtype Eval a = Eval+  { unEval :: RWST LocalEnv () GlobalEnv IO a }+  deriving+    ( Functor+    , Applicative+    , Alternative+    , Monad+    , MonadFail+    , MonadIO+    , MonadReader LocalEnv+    , MonadState GlobalEnv+    , MonadThrow+    , MonadCatch+    , MonadMask+    )++-- | Evaluate an action in the partial evaluator, returning the result,+-- and the final state of the global environment.+--+runEval :: GlobalEnv -> LocalEnv -> Eval a -> IO (a, GlobalEnv)+runEval g l x =+  let extract (a, g', _) = (a, g')+   in extract <$> RWS.runRWST (unEval x) l g+{-# INLINE runEval #-}++getLocalEnv :: Eval LocalEnv+getLocalEnv = RWS.ask+{-# INLINE getLocalEnv #-}++setLocalEnv :: LocalEnv -> Eval a -> Eval a+setLocalEnv = RWS.local . const+{-# INLINE setLocalEnv #-}++modifyLocalEnv :: (LocalEnv -> LocalEnv) -> Eval a -> Eval a+modifyLocalEnv = RWS.local+{-# INLINE modifyLocalEnv #-}++getGlobalEnv :: Eval GlobalEnv+getGlobalEnv = RWS.get+{-# INLINE getGlobalEnv #-}++modifyGlobalEnv :: (GlobalEnv -> GlobalEnv) -> Eval ()+modifyGlobalEnv = RWS.modify'+{-# INLINE modifyGlobalEnv #-}++getContext :: Eval Id+getContext = lenvContext <$> getLocalEnv++withContext :: Id -> Eval a -> Eval a+withContext i = modifyLocalEnv go+ where+  go env = env { lenvContext = i }++findTyVar :: TyVar -> Eval (Maybe Type)+findTyVar i = Map.lookup i . lenvTypes <$> getLocalEnv++withTyVar :: TyVar -> Type -> Eval a -> Eval a+withTyVar i a x = do+  modifyGlobalEnv goGlobal+  modifyLocalEnv goLocal x+ where+  goGlobal env@GlobalEnv{genvInScope=inScope} =+    let fvs = unitVarSet i `unionVarSet` freeVarsOf a+        iss = mkInScopeSet fvs `unionInScope` inScope+     in env { genvInScope = iss }++  goLocal env@LocalEnv{lenvTypes=types} =+    env { lenvTypes = Map.insert i a types }++withTyVars :: [(TyVar, Type)] -> Eval a -> Eval a+withTyVars = flip $ foldr (uncurry withTyVar)++getTvSubst :: Eval Subst+getTvSubst = do+  inScope <- getInScope+  tys <- lenvTypes <$> getLocalEnv+  let vars = mkVarEnv (Map.toList tys)++  pure (mkTvSubst inScope vars)++findId :: Id -> Eval (Maybe Value)+findId i = Map.lookup i . lenvValues <$> getLocalEnv++withId :: Id -> Value -> Eval a -> Eval a+withId i v x = do+  modifyGlobalEnv goGlobal+  modifyLocalEnv goLocal x+ where+  goGlobal env@GlobalEnv{genvInScope=inScope} =+    -- TODO Change this to use an instance HasFreeVars Value+    let fvs = unitVarSet i `unionVarSet` freeVarsOf (asTerm v)+        iss = mkInScopeSet fvs `unionInScope` inScope+     in env { genvInScope = iss }++  goLocal env@LocalEnv{lenvValues=values} =+    env { lenvValues = Map.insert i v values }++withIds :: [(Id, Value)] -> Eval a -> Eval a+withIds = flip $ foldr (uncurry withId)++withoutId :: Id -> Eval a -> Eval a+withoutId i = modifyLocalEnv go+ where+  go env@LocalEnv{lenvValues=values} =+    env { lenvValues = Map.delete i values }++findBinding :: Id -> Eval (Maybe (Binding Value))+findBinding i = lookupVarEnv i . genvBindings <$> getGlobalEnv++replaceBinding :: Binding Value -> Eval ()+replaceBinding b = modifyGlobalEnv go+ where+  go env@GlobalEnv{genvBindings=bindings} =+    env { genvBindings = extendVarEnv (bindingId b) b bindings }++getRef :: Int -> Eval Value+getRef addr = do+  heap <- genvHeap <$> getGlobalEnv++  case IntMap.lookup addr heap of+    Just val -> pure val+    Nothing  -> error ("getHeap: Address " <> show addr <> " out of bounds")++setRef :: Int -> Value -> Eval ()+setRef addr val = modifyGlobalEnv go+ where+  go env@GlobalEnv{genvHeap=heap,genvAddr=next}+    | addr == next =+        env { genvHeap = IntMap.insert addr val heap, genvAddr = addr + 1 }++    | otherwise =+        env { genvHeap = IntMap.insert addr val heap }++isKeepingLifted :: Eval Bool+isKeepingLifted = lenvKeepLifted <$> getLocalEnv++keepLifted :: Eval a -> Eval a+keepLifted = modifyLocalEnv forceLifted+ where+  forceLifted env = env { lenvKeepLifted = True }++getFuel :: Eval Word+getFuel = do+  lenv <- getLocalEnv+  genv <- getGlobalEnv++  pure (min (lenvFuel lenv) (genvFuel genv))++withFuel :: Eval a -> Eval a+withFuel x = modifyGlobalEnv go >> x+ where+  go env@GlobalEnv{genvFuel=fuel} =+    env { genvFuel = fuel - 1 }++preserveFuel :: Eval a -> Eval a+preserveFuel x = do+  fuel <- getFuel+  res  <- x++  modifyGlobalEnv (go fuel)+  pure res+ where+  go fuel env = env { genvFuel = fuel }++getTyConMap :: Eval TyConMap+getTyConMap = genvTyConMap <$> getGlobalEnv++getInScope :: Eval InScopeSet+getInScope = genvInScope <$> getGlobalEnv++getUniqueId :: OccName -> Type -> Eval Id+getUniqueId = getUniqueVar mkUniqSystemId++getUniqueTyVar :: OccName -> Kind -> Eval TyVar+getUniqueTyVar = getUniqueVar mkUniqSystemTyVar++getUniqueVar+  :: ((Supply, InScopeSet)+         -> (OccName, KindOrType)+         -> ((Supply, InScopeSet), Var a))+  -> OccName+  -> KindOrType+  -> Eval (Var a)+getUniqueVar f name ty = do+  env <- getGlobalEnv+  let iss = genvInScope env+      ids = genvSupply env+      ((ids', iss'), i) = f (ids, iss) (name, ty)++  modifyGlobalEnv (go ids' iss')+  pure i+ where+  go ids iss env =+    env { genvInScope = iss, genvSupply = ids }++workFreeValue :: Value -> Eval Bool+workFreeValue = \case+  VNeutral _ -> pure False+  VThunk x _ -> do+    bindings <- fmap (fmap asTerm) . genvBindings <$> getGlobalEnv+    isWorkFree workFreeCache bindings x++  _ -> pure True
+ src/Clash/Core/PartialEval/NormalForm.hs view
@@ -0,0 +1,204 @@+{-|+Copyright   : (C) 2020-2021, QBayLogic B.V.,+                  2022     , Google Inc.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>++Normal forms for the partial evaluator. These provide a restricted model of+how terms can be constructed (compared to the more liberal Term type) which+give a stronger guarantee that evaluation does not produce invalid results.+This module is only needed to define new evaluators, for calling an existing+evaluator see Clash.Core.PartialEval.+-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}++module Clash.Core.PartialEval.NormalForm+  ( Arg+  , Args+  , Neutral(..)+  , Value(..)+  , mkValueTicks+  , stripValue+  , collectValueTicks+  , isUndefined+  , isUndefinedX+  , Normal(..)+  , LocalEnv(..)+  , GlobalEnv(..)+  , workFreeCache+  ) where++import Control.Lens (Lens', lens)+import Data.IntMap.Strict (IntMap)+import Data.Map.Strict (Map)++import Clash.Core.DataCon (DataCon)+import Clash.Core.Literal+import Clash.Core.Term (Bind, Term(..), PrimInfo(primName), TickInfo, Pat)+import Clash.Core.TyCon (TyConMap)+import Clash.Core.Type (Type, TyVar)+import Clash.Core.Util (undefinedPrims, undefinedXPrims)+import Clash.Core.Var (Id)+import Clash.Core.VarEnv (VarEnv, InScopeSet)+import Clash.Driver.Types (Binding(..))+import Clash.Util.Supply (Supply)++type Args a+  = [Arg a]++-- | An argument applied to a function / data constructor / primitive.+--+type Arg a+  = Either a Type++-- | Neutral terms cannot be reduced, as they represent things like variables+-- which are unknown, partially applied functions, or case expressions where+-- the subject cannot be inspected. Consider:+--+-- v              Stuck if "v" is a free variable+-- p x1 ... xn    Stuck if "p" is a primitive that cannot be reduced+-- x $ y          Stuck if "x" is not known to be a lambda+-- x @ A          Stuck if "x" is not known to be a type lambda+-- case x of ...  Stuck if "x" is neutral (cannot choose an alternative)+--+-- Neutral terms can also be let expressions which preserve required bindings+-- in the normal form representation. Examples of bindings that may be kept are+-- bindings which perform work (and should not be copied) or bindings that+-- are recursive and are still referred to by the body of the let expression.+--+-- let ... in ... Preserved bindings are needed by the body+--+data Neutral a+  = NeVar    !Id+  | NePrim   !PrimInfo !(Args a)+  | NeApp    !(Neutral a) !a+  | NeTyApp  !(Neutral a) !Type+  | NeLet    !(Bind a) !a+  | NeCase   !a !Type ![(Pat, a)]+  deriving (Show)++-- TODO Write an instance (InferType a) => InferType (Neutral a)+-- TODO Write an instance (HasFreeVars a) => HasFreeVars (Neutral a)++-- | A term which has been potentially evaluated to WHNF. If evaluation has+-- occurred, then there will be no redexes at the head of the Value, but+-- sub-terms may still have redexes. Data constructors are only considered to+-- be values when fully applied, if partially applied they should be+-- eta-expanded during evaluation.+--+-- Thunks are included so that lazy evaluation can be modelled without needing+-- to store Either Term Value in the environment. This makes the presentation+-- simpler, with the caveat that values must be forced when they are required+-- to not be thunks.+--+data Value+  = VNeutral  !(Neutral Value)+  | VLiteral  !Literal+  | VData     !DataCon !(Args Value) !LocalEnv+  | VLam      !Id !Term !LocalEnv+  | VTyLam    !TyVar !Term !LocalEnv+  | VCast     !Value !Type !Type+  | VTick     !Value !TickInfo+  | VThunk    !Term !LocalEnv+  deriving (Show)++-- TODO Write an instance InferType Value+-- TODO Write an instance HasFreeVars Value++mkValueTicks :: Value -> [TickInfo] -> Value+mkValueTicks = foldl VTick++stripValue :: Value -> Value+stripValue = fst . collectValueTicks++collectValueTicks :: Value -> (Value, [TickInfo])+collectValueTicks = go []+ where+  go !acc = \case+    VTick v tick -> go (tick : acc) v+    value -> (value, acc)++isUndefined :: Value -> Bool+isUndefined = \case+  VNeutral (NePrim pr _) ->+    primName pr `elem` undefinedPrims++  _ -> False++isUndefinedX :: Value -> Bool+isUndefinedX = \case+  VNeutral (NePrim pr _) ->+    primName pr `elem` undefinedXPrims++  _ -> False++-- | A term which is in beta-normal eta-long form (NF). This has no redexes,+-- and all partially applied functions in sub-terms are eta-expanded.+--+-- While not strictly necessary, NLam includes the environment at the point the+-- original term was evaluated. This makes it easier for the AsTerm instance+-- for Normal to reintroduce let expressions before lambdas without+-- accidentally floating a let using a lambda bound variable outwards.+--+data Normal+  = NNeutral  !(Neutral Normal)+  | NLiteral  !Literal+  | NData     !DataCon !(Args Normal)+  | NLam      !Id !Normal !LocalEnv+  | NTyLam    !TyVar !Normal !LocalEnv+  | NCast     !Normal !Type !Type+  | NTick     !Normal !TickInfo+  deriving (Show)++data LocalEnv = LocalEnv+  { lenvContext :: Id+    -- ^ The id of the term currently under evaluation.+  , lenvTypes :: Map TyVar Type+    -- ^ Local type environment. These are types that are introduced while+    -- evaluating the current term (i.e. by type applications)+  , lenvValues :: Map Id Value+    -- ^ Local term environment. These are WHNF terms or unevaluated thunks+    -- introduced while evaluating the current term (i.e. by applications)+  , lenvFuel :: Word+    -- ^ The amount of fuel left in the local environment when the previous+    -- head was reached. This is needed so resuming evaluation does not lead+    -- to additional fuel being available.+  , lenvKeepLifted :: Bool+    -- ^ When evaluating, keep data constructors for boxed data types (e.g. I#)+    -- instead of converting these back to their corresponding primitive. This+    -- is used when evaluating terms where the result is subject of a case+    -- expression (see note: lifted data types).+  } deriving (Show)++-- TODO Add recursion info to the global environment. Until then we are forced+-- to spend fuel on non-recursive (terminating) terms.++data GlobalEnv = GlobalEnv+  { genvBindings :: VarEnv (Binding Value)+    -- ^ Global term environment. These are the potentially evaluated bodies+    -- of the top level definitions which are forced on lookup.+  , genvTyConMap :: TyConMap+    -- ^ The type constructors known about by Clash.+  , genvInScope :: InScopeSet+    -- ^ The set of in scope variables during partial evaluation. This includes+    -- new variables introduced by the evaluator (such as the ids of binders+    -- introduced during eta expansion.)+  , genvSupply :: Supply+    -- ^ The supply of fresh names for generating identifiers.+  , genvFuel :: Word+    -- ^ The remaining fuel which can be spent inlining global variables. This+    -- is saved in the local environment, so when evaluation resumes from WHNF+    -- the amount of fuel used is preserved.+  , genvHeap :: IntMap Value+    -- ^ The heap containing the results of any evaluated IO primitives.+  , genvAddr :: Int+    -- ^ The address of the next element to be inserted into the heap.+  , genvWorkCache :: VarEnv Bool+    -- ^ Cache for the results of isWorkFree. This is required to use+    -- Clash.Rewrite.WorkFree.isWorkFree.+  }++workFreeCache :: Lens' GlobalEnv (VarEnv Bool)+workFreeCache = lens genvWorkCache (\env x -> env { genvWorkCache = x })
+ src/Clash/Core/Pretty.hs view
@@ -0,0 +1,597 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                     2016     , Myrtle Software Ltd,+                     2021-2022, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  PrettyPrec printing class and instances for CoreHW+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Clash.Core.Pretty+  ( PrettyPrec (..)+  , PrettyOptions (..)+  , ClashDoc+  , ClashAnnotation (..)+  , SyntaxElement (..)+  , ppr, ppr'+  , showPpr, showPpr'+  , tracePprId+  , tracePpr+  , fromPpr+  , unsafeLookupEnvBool+  )+where++import Data.Char                        (isSymbol, isUpper, ord)+import Data.Default                     (Default(..))+import Data.Text                        (Text)+import Control.Monad.Identity+import Data.Binary.IEEE754              (wordToDouble, wordToFloat)+import Data.List.Extra                  ((<:>))+import qualified Data.Text              as T+import Data.Maybe                       (fromMaybe)+#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter+import Prettyprinter.Internal+#else+import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Internal+#endif+import GHC.Show                         (showMultiLineString)+import GHC.Stack                        (HasCallStack)+import qualified GHC.Utils.Outputable   as GHC+import System.Environment               (lookupEnv)+import System.IO.Unsafe                 (unsafePerformIO)+import Text.Read                        (readMaybe)++import Clash.Core.DataCon               (DataCon (..))+import Clash.Core.Literal               (Literal (..))+import Clash.Core.Name                  (Name (..))+import Clash.Core.Term+  (Pat (..), Term (..), TickInfo (..), NameMod (..), CoreContext (..), primArg, PrimInfo(primName),Bind(..))+import Clash.Core.TyCon                 (TyCon (..), TyConName, isTupleTyConLike, AlgTyConRhs(..))+import Clash.Core.Type                  (ConstTy (..), Kind, LitTy (..),+                                         Type (..), TypeView (..), tyView,mkTyConApp)+import Clash.Core.Var                   (Id, TyVar, Var (..), IdScope(..))+import Clash.Debug                      (trace)+import Clash.Util+import qualified Clash.Util.Interpolate as I+import Clash.Pretty++unsafeLookupEnvBool :: HasCallStack =>  String -> Bool -> Bool+unsafeLookupEnvBool key dflt =+  case unsafePerformIO (lookupEnv key) of+    Nothing -> dflt+    Just a -> flip fromMaybe (readMaybe a) $ error [I.i|+      'unsafeLookupEnvBool' tried to lookup #{key} in the environment. It found+      it, but couldn't interpret it to as a Bool. Expected one of: True, False.+      But found:++        #{a}+    |]++-- | Options for the pretty-printer, controlling which elements to hide.+data PrettyOptions = PrettyOptions+  { displayUniques    :: Bool+  -- ^ whether to display unique identifiers+  , displayTypes      :: Bool+  -- ^ whether to display type information+  , displayQualifiers :: Bool+  -- ^ whether to display module qualifiers+  , displayTicks      :: Bool+  -- ^ whether to display ticks+  }++instance Default PrettyOptions where+  def = PrettyOptions+    { displayUniques    = unsafeLookupEnvBool "CLASH_PPR_UNIQUES" True+    , displayTypes      = unsafeLookupEnvBool "CLASH_PPR_TYPES" True+    , displayQualifiers = unsafeLookupEnvBool "CLASH_PPR_QUALIFIERS" True+    , displayTicks      = unsafeLookupEnvBool "CLASH_PPR_TICKS" True+    }++-- | Annotations carried on pretty-printed code.+data ClashAnnotation+  = AnnContext CoreContext+  -- ^ marking navigation to a different context+  | AnnSyntax  SyntaxElement+  -- ^ marking a specific sort of syntax+  deriving Eq++-- | Specific places in the program syntax.+data SyntaxElement = Keyword | LitS | Type | Unique | Qualifier | Ticky+  deriving (Eq, Show)++-- | Clash's specialized @Doc@ type holds metadata of type @ClashAnnotation@.+type ClashDoc = Doc ClashAnnotation++-- | PrettyPrec printing Show-like typeclass+class PrettyPrec p where++  -- default pretty-printing without hiding+  pprPrec :: Monad m => Rational -> p -> m ClashDoc++  -- pretty-printing with hiding options+  -- NB: we utilise the syntax annotations to hide the requested parts of syntax+  pprPrec' :: Monad m => PrettyOptions -> Rational -> p -> m ClashDoc+  pprPrec' opts p = fmap hide . pprPrec p+    where+      hide = \case+        FlatAlt d d'         -> FlatAlt (hide d) (hide d')+        Cat d d'             -> Cat (hide d) (hide d')+        Nest i d             -> Nest i (hide d)+        Union d d'           -> Union (hide d) (hide d')+        Column f             -> Column (hide . f)+        WithPageWidth f      -> WithPageWidth (hide . f)+        Nesting f            -> Nesting (hide . f)+        Annotated ann d'     ->+          if not (displayTypes opts)      && ann == AnnSyntax Type+          || not (displayUniques opts)    && ann == AnnSyntax Unique+          || not (displayQualifiers opts) && ann == AnnSyntax Qualifier+          || not (displayTicks opts)      && ann == AnnSyntax Ticky+            then Empty+            else Annotated ann (hide d')+        d -> d++pprM :: (Monad m, PrettyPrec p) => p -> m ClashDoc+pprM = pprPrec 0++pprM' :: (Monad m, PrettyPrec p) => PrettyOptions -> p -> m ClashDoc+pprM' opts = pprPrec' opts 0++ppr :: PrettyPrec p => p -> ClashDoc+ppr = runIdentity . pprM++ppr' :: PrettyPrec p => PrettyOptions -> p -> ClashDoc+ppr' opts = runIdentity . pprM' opts++fromPpr :: PrettyPrec a => a -> Doc ()+fromPpr = removeAnnotations . ppr++noPrec, opPrec, appPrec :: Num a => a+noPrec = 0+opPrec = 1+appPrec = 2++-- | Print a PrettyPrec thing to a String+showPpr :: PrettyPrec p => p -> String+showPpr = showPpr' def++showPpr' :: PrettyPrec p => PrettyOptions -> p -> String+showPpr' opts = showDoc . ppr' opts++tracePprId :: PrettyPrec p => p -> p+tracePprId p = trace (showPpr p) p++tracePpr :: PrettyPrec p => p -> a -> a+tracePpr p a = trace (showPpr p) a++parensIf :: Bool -> ClashDoc -> ClashDoc+parensIf False = id+parensIf True  = parens++tyParens :: ClashDoc -> ClashDoc+tyParens = enclose (annotate (AnnSyntax Type) lparen)+                   (annotate (AnnSyntax Type) rparen)++tyParensIf :: Bool -> ClashDoc -> ClashDoc+tyParensIf False = id+tyParensIf True  = tyParens++vsepHard :: [ClashDoc] -> ClashDoc+vsepHard = concatWith (\x y -> x <> hardline <> y)++viewName :: Name a -> (Text, Text, Text)+viewName n = (qual, occ, T.pack $ show $ nameUniq n)+  where (qual, occ) = T.breakOnEnd "." $ nameOcc n++instance PrettyPrec (Name a) where+  pprPrec p (viewName -> (qual, occ, uniq)) = do+    qual' <- annotate (AnnSyntax Qualifier) <$> pprPrec p qual+    occ'  <- pprPrec p occ+    uniq' <- annotate (AnnSyntax Unique) . brackets <$> (pprPrec p uniq)+    return $ qual' <> occ' <> uniq'++instance ClashPretty (Name a) where+  clashPretty = fromPpr++instance PrettyPrec a => PrettyPrec [a] where+  pprPrec prec = fmap vcat . mapM (pprPrec prec)++instance PrettyPrec (Id, Term) where+  pprPrec _ = pprTopLevelBndr++pprTopLevelBndr :: Monad m => (Id,Term) -> m ClashDoc+pprTopLevelBndr (bndr,expr) = do+  bndr'    <- pprM bndr+  bndrName <- pprM (varName bndr)+  expr'    <- pprM expr+  return $ bndr' <> line <> hang 2 (sep [(bndrName <+> equals), expr']) <> line++dcolon, rarrow, lam, tylam, at, cast, coerce, let_, letrec, in_, case_, of_, forall_,+  data_,newtype_,type_,family_,instance_+  :: ClashDoc+dcolon = annotate (AnnSyntax Keyword) "::"+rarrow = annotate (AnnSyntax Keyword) "->"+lam = annotate (AnnSyntax Keyword)  "λ"+tylam = annotate (AnnSyntax Keyword) "Λ"+at = annotate (AnnSyntax Keyword)  "@"+cast = annotate (AnnSyntax Keyword) "▷"+coerce = annotate (AnnSyntax Keyword) "~"+let_ = annotate (AnnSyntax Keyword) "let"+letrec = annotate (AnnSyntax Keyword) "letrec"+in_ = annotate (AnnSyntax Keyword) "in"+case_ = annotate (AnnSyntax Keyword) "case"+of_ = annotate (AnnSyntax Keyword) "of"+forall_ = annotate (AnnSyntax Keyword) "forall"+data_ = annotate (AnnSyntax Keyword) "data"+newtype_ = annotate (AnnSyntax Keyword) "newtype"+type_ = annotate (AnnSyntax Keyword) "type"+family_ = annotate (AnnSyntax Keyword) "family"+instance_ = annotate (AnnSyntax Keyword) "instance"++instance PrettyPrec Text where+  pprPrec _ = pure . pretty++instance PrettyPrec Type where+  pprPrec _ t = pprType t++instance ClashPretty Type where+  clashPretty = fromPpr++instance PrettyPrec TyCon where+  pprPrec prec t = case t of+    AlgTyCon _ nm kn _ (DataTyCon dcs) _ -> do+      name <- pprPrec prec nm+      kind <- pprKind kn+      let decl = name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind)++      cons <- traverse pprDataCon dcs+      pure (vsep (data_ <+> decl : cons))+     where+      pprDataCon dc = do+        name <- pprPrec prec dc+        ty <- pprType (dcType dc)++        pure (name <> annotate (AnnSyntax Type) (space <> dcolon <+> ty))++    AlgTyCon _ nm kn _ (NewTyCon dc _) _ -> do+      name <- pprPrec prec nm+      kind <- pprKind kn+      let decl = name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind)++      conName <- pprPrec prec (dcName dc)+      conType <- pprType (dcType dc)++      pure (vsep [newtype_ <+> decl, conName <> annotate (AnnSyntax Type) (space <> dcolon <+> conType)])++    PromotedDataCon _ _ _ _ dc ->+      fmap ("promoted" <+>) (pprPrec prec dc)++    FunTyCon _ nm kn _ ss -> do+      name <- pprPrec prec nm+      kind <- pprKind kn+      let decl = name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind)++      substs <- traverse pprSubst ss+      pure (vsep (type_ <+> family_ <+> decl : substs))+     where+      pprSubst (xs, y) = do+        lhs <- pprType (mkTyConApp (tyConName t) xs)+        rhs <- pprType y++        pure (type_ <+> instance_ <+> lhs <+> "=" <+> rhs)++    PrimTyCon _ nm kn _ -> do+      name <- pprPrec prec nm+      kind <- pprKind kn++      pure (name <> annotate (AnnSyntax Type) (space <> dcolon <+> kind))++instance Pretty LitTy where+  pretty (NumTy i) = pretty i+  pretty (SymTy s) = dquotes $ pretty s+  pretty (CharTy c) = squotes $ pretty c++instance PrettyPrec LitTy where+  pprPrec _ = return . annotate (AnnSyntax LitS) . pretty++instance PrettyPrec Term where+  pprPrec prec e = case e of+    Var x           -> do+      v <- pprPrec prec (varName x)+      s <- pprPrecIdScope x+      pure (v <> annotate (AnnSyntax Unique) (brackets s))+    Data dc         -> pprPrec prec dc+    Literal l       -> pprPrec prec l+    Prim p          -> pprPrecPrim prec (primName p)+    Lam  v e1       -> annotate (AnnContext $ LamBody v) <$>+                         pprPrecLam prec [v] e1+    TyLam tv e1     -> annotate (AnnContext $ TyLamBody tv) <$>+                         pprPrecTyLam prec [tv] e1+    App fun arg     -> pprPrecApp prec fun arg+    TyApp e' ty     -> annotate (AnnContext TyAppC) <$>+                         pprPrecTyApp prec e' ty+    Let (NonRec i x) e1 -> pprPrecLetrec prec False [(i,x)] e1+    Let (Rec xes) e1   -> pprPrecLetrec prec True xes e1+    Case e' _ alts  -> pprPrecCase prec e' alts+    Cast e' ty1 ty2 -> pprPrecCast prec e' ty1 ty2+    Tick t e'       -> do+      tDoc <- pprPrec prec t+      eDoc <- pprPrec prec e'+      return (annotate (AnnSyntax Ticky) (tDoc <> line') <> eDoc)++instance PrettyPrec TickInfo where+  pprPrec prec (SrcSpan sp)   = pprPrec prec sp+  pprPrec prec (NameMod PrefixName t) = ("<prefixName>" <>) <$> pprPrec prec t+  pprPrec prec (NameMod SuffixName t) = ("<suffixName>" <>) <$> pprPrec prec t+  pprPrec prec (NameMod SuffixNameP t) = ("<suffixNameP>" <>) <$> pprPrec prec t+  pprPrec prec (NameMod SetName t)    = ("<setName>" <>) <$> pprPrec prec t+  pprPrec _    DeDup                  = pure "<deDup>"+  pprPrec _    NoDeDup                = pure "<noDeDup>"+  pprPrec prec (Attributes _ attrs)   = ("<attributes>" <>) <$> pprPrec prec attrs++instance PrettyPrec SrcSpan where+  pprPrec _ sp = return ("<src>"<>pretty (GHC.showSDocUnsafe (GHC.ppr sp)))++instance ClashPretty Term where+  clashPretty = fromPpr++data BindingSite = LambdaBind | CaseBind | LetBind++instance PrettyPrec (Var a) where+  pprPrec _ v@(TyVar {}) = pprM $ varName v+  pprPrec _ v@(Id {})    = do+    v'  <- pprM (varName v)+    ty' <- pprM (varType v)+    return $ v' <> (annotate (AnnSyntax Type) $ align (space <> dcolon <+> ty'))++instance ClashPretty (Var a) where+  clashPretty = fromPpr++instance PrettyPrec DataCon where+  pprPrec _ = pprM . dcName++instance PrettyPrec Literal where+  pprPrec _ l = return $ annotate (AnnSyntax LitS) $ case l of+    IntegerLiteral i   -> parensIf (i < 0) (pretty i)+    IntLiteral i       -> parensIf (i < 0) (pretty i <> "#")+    Int64Literal i     -> parensIf (i < 0) (pretty i <> "#64")+    WordLiteral w      -> pretty w <> "##"+    Word64Literal w    -> pretty w <> "##64"+    Int8Literal i      -> parensIf (i < 0) (pretty i <> "#8")+    Int16Literal i     -> parensIf (i < 0) (pretty i <> "#16")+    Int32Literal i     -> parensIf (i < 0) (pretty i <> "#32")+    Word8Literal w     -> pretty w <> "##8"+    Word16Literal w    -> pretty w <> "##16"+    Word32Literal w    -> pretty w <> "##32"+    FloatLiteral w     -> pretty (wordToFloat w) <> "#"+    DoubleLiteral w    -> pretty (wordToDouble w) <> "##"+    CharLiteral c      -> pretty c <> "#"+    StringLiteral s    -> vcat $ map pretty $ showMultiLineString s+    NaturalLiteral n   -> pretty n+    ByteArrayLiteral s -> pretty $ show s++instance PrettyPrec Pat where+  pprPrec prec pat = case pat of+    DataPat dc txs xs -> do+      dc'  <- pprM dc+      txs' <- mapM (pprBndr LetBind) txs+      xs'  <- mapM (pprBndr CaseBind) xs+      return $ parensIf (prec >= appPrec) $+        sep [ hsep (dc':txs')+            , nest 2 (sep xs') ]+    LitPat l   -> pprM l+    DefaultPat -> return "_"++pprPrecIdScope :: Monad m => Var a -> m ClashDoc+pprPrecIdScope (TyVar {}) = pure "TyVar"+pprPrecIdScope (Id _ _ _ GlobalId) = pure "GlobalId"+pprPrecIdScope (Id _ _ _ LocalId) = pure "LocalId"++pprPrecPrim :: Monad m => Rational -> Text -> m ClashDoc+pprPrecPrim prec nm =+  (<>) <$> (annotate (AnnSyntax Qualifier) <$> pprPrec prec qual)+       <*> pprPrec prec occ+  where (qual, occ) = T.breakOnEnd "." nm++pprPrecLam :: Monad m => Rational -> [Id] -> Term -> m ClashDoc+pprPrecLam prec xs e = do+  xs' <- mapM (pprBndr LambdaBind) xs+  e'  <- pprPrec noPrec e+  return $ parensIf (prec > noPrec) $+    lam <> hsep xs' <+> rarrow <> line <> e'++pprPrecTyLam :: Monad m => Rational -> [TyVar] -> Term -> m ClashDoc+pprPrecTyLam prec tvs e = do+  tvs' <- mapM pprM tvs+  e'   <- pprPrec noPrec e+  return $ tyParensIf (prec > noPrec) $+    annotate (AnnSyntax Type) (tylam <> hsep tvs' <+> rarrow <> line) <> e'++pprPrecApp :: Monad m => Rational -> Term -> Term -> m ClashDoc+pprPrecApp prec e1 e2 = do+  e1' <- annotate (AnnContext AppFun) <$> pprPrec opPrec e1+  e2' <- annotate (AnnContext $ AppArg $ primArg e2) <$> pprPrec appPrec e2+  return $ parensIf (prec >= appPrec) $+    hang 2 (sep [e1',e2'])++pprPrecTyApp :: Monad m => Rational -> Term -> Type -> m ClashDoc+pprPrecTyApp prec e ty = do+  e'  <- pprPrec opPrec e+  ty' <- pprParendType ty+  return $ tyParensIf (prec >= appPrec) $+    hang 2 $ group $+      e' <> annotate (AnnSyntax Type) (line <> at <> ty')++pprPrecCast :: Monad m => Rational -> Term -> Type -> Type -> m ClashDoc+pprPrecCast prec e ty1 ty2 = do+  e'   <- annotate (AnnContext CastBody) <$> pprPrec appPrec e+  ty1' <- pprType ty1+  ty2' <- pprType ty2+  return $ tyParensIf (prec >= appPrec) $+    e' <> annotate (AnnSyntax Type)+                   (softline <> nest 2 (vsep [cast, ty1', coerce, ty2']))++-- TODO Since Clash now keeps non-recursive let expressions separately, the+-- result of normalization will contain more nested let expressions as the old+-- Letrec-based definitions are replaced by Let. As this happens, it may be a+-- good idea to change pprPrecLetrec to encourage more compact forms such as+-- printing the entire binding on one line if possible.++pprPrecLetrec :: Monad m => Rational -> Bool -> [(Id, Term)] -> Term -> m ClashDoc+pprPrecLetrec prec isRec xes body = do+  let bndrs = fst <$> xes+  body' <- annotate (AnnContext $ LetBody xes) <$> pprPrec noPrec body+  xes'  <- mapM (\(x,e) -> do+                  x' <- pprBndr LetBind x+                  e' <- pprPrec noPrec e+                  return $ annotate (AnnContext $ LetBinding x bndrs) $+                    vsepHard [x', equals <+> e']+                ) xes+  let xes'' = case xes' of { [] -> ["EmptyLetrec"]; _  -> xes' }+  let kw = if isRec then letrec else let_+  return $ parensIf (prec > noPrec) $+    vsepHard [hang 2 (vsepHard $ kw : xes''), in_ <+> body']++pprPrecCase :: Monad m => Rational -> Term -> [(Pat,Term)] -> m ClashDoc+pprPrecCase prec e alts = do+  e'    <- annotate (AnnContext CaseScrut) <$> pprPrec prec e+  alts' <- mapM (pprPrecAlt noPrec) alts+  return $ parensIf (prec > noPrec) $+    hang 2 $ vsepHard $ (case_ <+> e' <+> of_) : alts'++pprPrecAlt :: Monad m => Rational -> (Pat,Term) -> m ClashDoc+pprPrecAlt _ (altPat, altE) = do+  altPat' <- pprPrec noPrec altPat+  altE'   <- pprPrec noPrec altE+  return $ annotate (AnnContext $ CaseAlt altPat) $+    hang 2 $ vsepHard [(altPat' <+> rarrow), altE']++pprBndr :: (Monad m, PrettyPrec a) => BindingSite -> a -> m ClashDoc+pprBndr LetBind = pprM+pprBndr _       = fmap tyParens . pprM++data TypePrec = TopPrec | FunPrec | TyConPrec deriving (Eq,Ord)++maybeParen :: TypePrec -> TypePrec -> ClashDoc -> ClashDoc+maybeParen ctxt_prec inner_prec = parensIf (ctxt_prec >= inner_prec)++pprType :: Monad m => Type -> m ClashDoc+pprType = ppr_type TopPrec++pprParendType :: Monad m => Type -> m ClashDoc+pprParendType = ppr_type TyConPrec++ppr_type :: Monad m => TypePrec -> Type -> m ClashDoc+ppr_type _ (VarTy tv)                   = pprM tv+ppr_type _ (LitTy tyLit)                = pprM tyLit+ppr_type p ty@(ForAllTy {})             = pprForAllType p ty+ppr_type p (ConstTy (TyCon tc))         = pprTcApp p ppr_type tc []+ppr_type p (AnnType _ann typ)           = ppr_type p typ+ppr_type p (tyView -> TyConApp tc args) = pprTcApp p ppr_type tc args+ppr_type p (tyView -> FunTy ty1 ty2)+  = pprArrowChain <$> ppr_type FunPrec ty1 <:> pprFunTail ty2+  where+    pprFunTail (tyView -> FunTy ty1' ty2')+      = ppr_type FunPrec ty1' <:> pprFunTail ty2'+    pprFunTail otherTy+      = ppr_type TopPrec otherTy <:> pure []++    pprArrowChain []+      = emptyDoc+    pprArrowChain (arg:args)+      = maybeParen p FunPrec $ sep [arg, sep (map (rarrow <+>) args)]++ppr_type p (AppTy ty1 ty2) = maybeParen p TyConPrec <$> ((<+>) <$> pprType ty1+                                                               <*> ppr_type TyConPrec ty2)+ppr_type _ (ConstTy Arrow) = return (parens rarrow)++pprForAllType :: Monad m => TypePrec -> Type -> m ClashDoc+pprForAllType p ty = maybeParen p FunPrec <$> pprSigmaType True ty++pprSigmaType :: Monad m => Bool -> Type -> m ClashDoc+pprSigmaType showForalls ty = do+    (tvs, rho)     <- split1 [] ty+    sep <$> sequenceA [ if showForalls then pprForAll tvs else pure emptyDoc+                      , pprType rho+                      ]+  where+    split1 tvs (ForAllTy tv resTy) = split1 (tv:tvs) resTy+    split1 tvs resTy               = return (reverse tvs,resTy)++pprForAll :: Monad m => [TyVar] -> m ClashDoc+pprForAll []  = return emptyDoc+pprForAll tvs = do+  tvs' <- mapM pprTvBndr tvs+  return $ forall_ <+> sep tvs' <> dot++pprTvBndr :: Monad m => TyVar -> m ClashDoc+pprTvBndr tv = do+  tv'   <- pprM tv+  kind' <- pprKind (varType tv)+  return $ tyParens $ tv' <> (annotate (AnnSyntax Type) $ space <> dcolon <+> kind')++pprKind :: Monad m => Kind -> m ClashDoc+pprKind = pprType++pprTcApp :: Monad m => TypePrec -> (TypePrec -> Type -> m ClashDoc)+  -> TyConName -> [Type] -> m ClashDoc+pprTcApp p pp tc tys+  | null tys+  = pprM tc++  | isTupleTyConLike tc+  = do tys' <- mapM (pp TopPrec) tys+       return $ parens $ sep $ punctuate comma tys'++  | isSym+  , [ty1, ty2] <- tys+  = do ty1' <- pp FunPrec ty1+       ty2' <- pp FunPrec ty2+       tc' <- pprM tc+       return $ maybeParen p FunPrec $+         sep [ty1', enclose "`" "`" tc' <+> ty2']++  | otherwise+  = do tys' <- mapM (pp TyConPrec) tys+       tc' <- parensIf isSym <$> pprM tc+       return $ maybeParen p TyConPrec $+         hang 2 $ sep (tc':tys')++  where isSym = isSymName tc++isSymName :: Name a -> Bool+isSymName n = go (nameOcc n)+  where+    go s | T.null s           = False+         | isUpper $ T.head s = isLexConSym s+         | otherwise          = isLexSym s++isLexSym :: Text -> Bool+isLexSym cs = isLexConSym cs || isLexVarSym cs++isLexConSym :: Text -> Bool+isLexConSym "->" = True+isLexConSym cs   = startsConSym (T.head cs)++isLexVarSym :: Text -> Bool+isLexVarSym cs = startsVarSym (T.head cs)++startsConSym :: Char -> Bool+startsConSym c = c == ':'++startsVarSym :: Char -> Bool+startsVarSym c = isSymbolASCII c || (ord c > 0x7f && isSymbol c)++isSymbolASCII :: Char -> Bool+isSymbolASCII c = c `elem` ("!#$%&*+./<=>?@\\^|~-" :: String)
+ src/Clash/Core/Subst.hs view
@@ -0,0 +1,1040 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                          2017, Google Inc.+                          2021, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Capture-free substitution function for CoreHW+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++#include "../../ClashDebug.h"++module Clash.Core.Subst+  ( -- * Substitution into types+    -- ** Substitution environments+    TvSubst (..)+  , TvSubstEnv+  -- , mkTvSubst+  , extendTvSubst+  , extendTvSubstList+    -- ** Applying substitutions+  , substTy+  , substTyWith+  , substTyInVar+  , substGlobalsInExistentials+  , substInExistentials+  , substInExistentialsList+    -- * Substitution into terms+    -- ** Substitution environments+  , Subst (..)+  , mkSubst+  , mkTvSubst+  , extendInScopeId+  , extendInScopeIdList+  , extendIdSubst+  , extendIdSubstList+  , extendGblSubstList+    -- ** Applying substitutions+  , substTm+  , maybeSubstTm+  , substAlt+  , substId+    -- * Variable renaming+  , deShadowTerm+  , deShadowAlt+  , freshenTm+  , deshadowLetExpr+    -- * Alpha equivalence+  , aeqType+  , aeqTerm+  , acmpTerm+    -- * Structural equivalence+  , eqTerm+  , eqType+  )+where++import           Data.Coerce               (coerce)++#if MIN_VERSION_prettyprinter(1,7,0)+import           Prettyprinter+#else+import           Data.Text.Prettyprint.Doc+#endif++import           Data.Hashable             (Hashable (hashWithSalt))+import qualified Data.List                 as List+import qualified Data.List.Extra           as List+import           Data.Ord                  (comparing)+import           GHC.Stack                 (HasCallStack)+import           GHC.SrcLoc.Extra          ()+import           GHC.TypeLits+  (TypeError, ErrorMessage (Text, (:<>:)))++import           Clash.Core.HasFreeVars+import           Clash.Core.Pretty         (ppr, fromPpr)+import           Clash.Core.Term+  (Bind(..), Pat (..), Term (..), TickInfo (..), PrimInfo(primName))+import           Clash.Core.Type           (Type (..))+import           Clash.Core.VarEnv+import           Clash.Core.Var            (Id, Var (..), TyVar, isGlobalId)+import qualified Clash.Data.UniqMap as UniqMap+import           Clash.Debug               (debugIsOn)+import           Clash.Util+import           Clash.Pretty++-- * Subst++-- | A substitution of 'Type's for 'TyVar's+--+-- Note [Extending the TvSubstEnv]+-- See 'TvSubst' for the invariants that must hold+--+-- This invariant allows a short-cut when the subst env is empty: if the+-- TvSubstEnv is empty, i.e. @nullVarEnv TvSubstEnv@ holds, then+-- (substTy subst ty) does nothing.+--+-- For example, consider:+--+--    (/\a -> /\b(a ~ Int) -> ... b ...) Int+--+-- We substitute Int for 'a'. The Unique of 'b' does not change, but+-- nevertheless we add 'b' to the 'TvSubstEnv' because b's kind does change+--+-- This invariant has several consequences:+--+--   * In 'substTyVarBndr', we extend TvSubstEnv if the unique has changed, or+--     if the kind has changed+--+--   * In 'substTyVar', we do not need to consult the 'InScopeSet'; the+--     TvSubstEnv is enough+--+--   * In 'substTy', we can short-circuit when TvSubstEnv is empty+type TvSubstEnv = VarEnv Type++-- | Type substitution+--+-- The following invariants must hold:+--+--   1. The 'InScopeSet' is needed only to guide the generation of fresh uniques+--+--   2. In particular, the kind of the type variables in the 'InScopeSet' is not+--      relevant.+--+--   3. The substitution is only applied once+--+-- Note [Apply Once]+--+-- We might instantiate @forall a b. ty@ with the types @[a, b]@ or @[b, a]@.+-- So the substitution might go like @[a -> b, b -> a]@. A similar situation+-- arises in terms when we find a redex like @(/\a -> /\b -> e) b a@. Then we+-- also end up with a substitution that permutes variables. Other variations+-- happen to; for example @[a -> (a,b)]@.+--+-- SO A TvSubst MUST BE APPLIED PRECISELY ONCE, OR THINGS MIGHT LOOP+--+-- Note [The substitution invariant]+--+-- When calling (substTy subst ty) it should be the case that the 'InScopeSet'+-- is a superset of both:+--+--   * The free variables of the range of the substitution+--+--   * The free variables of /ty/ minus the domain of the substitution+data TvSubst+  = TvSubst InScopeSet -- Variable in scope /after/ substitution+            TvSubstEnv -- Substitution for types++instance ClashPretty TvSubst where+  clashPretty (TvSubst ins tenv) =+    brackets $ sep [ "TvSubst"+                   , nest 2 ("In scope:" <+> clashPretty ins)+                   , nest 2 ("Type env:" <+> clashPretty tenv)]++-- | A substitution  of 'Term's for 'Id's+--+-- Note [Extending the Subst]+--+-- For a term 'Subst', which binds 'Id's as well, we make a different choice for+-- Ids than we do for TyVars.+--+-- For TyVars see 'TvSubstEnv's Note [Extending the TvSubstEnv]+--+-- For Ids, we have a different invariant:+--+--   The IdSubstEnv is extended only when the Unique on an Id changes.+--   Otherwise, we just extend the InScopeSet+--+-- In consequence:+--+--   * If all subst envs are empty, substsTm would be a no-op+--+--     However, substTm still goes ahead and substitutes. Reason: we may want+--     to replace existing Ids with new ones from the in-scope set, to avoid+--     space leaks.+--+--   * In substIdBndr, we extend the 'IdSubstEnv' only when the unique changes+--+--   * If TvSubstEnv and IdSubstEnv are all empty, substExpr does nothing+--     (Note that the above rule for 'substIdBndr' maintains this property.)+--+--   * In 'lookupIdSubst', we must look up the Id in the in-scope set, because+--     it may contain non-trivial changes. Exmaple:+--+--     (/\a -> \x:a. ... x ...) Int+--+--     We extend the 'TvSubstEnv' with a @[a |-> Int]@; but x's unique does not+--     change so we only extend the in-scope set. Then we must look up in the+--     in-scope set when we find the occurrence of x.+--+--   * The requirement to look  up the Id in the in-scope set means that we+--     must not take no-op short cut when the 'IdSubstEnv' is empty. We must+--     still look up ever Id in the in-scope set.+--+--   * (However, we don't need to do so for the expression found in the+--     IdSubstEnv, whose range is assumed to be correct wrt the in-scope set)+type IdSubstEnv = VarEnv Term++-- | A substitution environment containing containing both 'Id' and 'TyVar'+-- substitutions.+--+-- Some invariants apply to how you use the substitution:+--+--   1. The 'InScopeSet' contains at least those 'Id's and 'TyVar's that will+--      be in scope /after/ applying the substitution  to a term. Precisely,+--      the in-scope set must be a superset of the free variables of the+--      substitution range that might possibly clash with locally-bound+--      variables in the thing being substituted in.+--+--   2. You may only apply the substitution once. See 'TvSubst'+--+-- There are various ways of setting up the in-scope set such that the first of+-- of these invariants holds:+--+--   * Arrange that the in-scope set really is all the things in scope+--+--   * Arrange that it's the  free vars of the range of the substitution+--+--   * Make it empty, if you know that all the free variables of the+--     substitution are fresh, and hence can´t possibly clash+data Subst+  = Subst+  { substInScope :: InScopeSet -- Variables in scope /after/ substitution+  , substTmEnv   :: IdSubstEnv -- Substitution for terms+  , substTyEnv   :: TvSubstEnv -- Substitution for types+  , substGblEnv  :: IdSubstEnv -- Substitution of globals (in terms)+  }++emptySubst+  :: Subst+emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv++-- | An empty substitution, starting the variables currently in scope+mkSubst+  :: InScopeSet+  -> Subst+mkSubst is = Subst is emptyVarEnv emptyVarEnv emptyVarEnv++-- | Create a type substitution+mkTvSubst+  :: InScopeSet+  -> VarEnv Type+  -> Subst+mkTvSubst is env = Subst is emptyVarEnv env emptyVarEnv++-- | Generates the in-scope set for the 'Subst' from the types in the incoming+-- environment.+--+-- Should only be used the type we're substituting into has no free variables+-- outside of the domain of substitution+zipTvSubst+  :: [TyVar]+  -> [Type]+  -> Subst+zipTvSubst tvs tys+  | debugIsOn+  , not (List.equalLength tvs tys)+  = pprTrace "zipTvSubst" (ppr tvs <> line <> ppr tys) emptySubst+  | otherwise+  = Subst (mkInScopeSet (freeVarsOf tys)) emptyVarEnv tenv emptyVarEnv+ where+  tenv = zipTyEnv tvs tys++zipTyEnv+  :: [TyVar]+  -> [Type]+  -> VarEnv Type+zipTyEnv tvs tys = mkVarEnv (List.zipEqual tvs tys)++-- | Extend the substitution environment with a new 'Id' substitution+extendIdSubst+  :: Subst+  -> Id+  -> Term+  -> Subst+extendIdSubst (Subst is env tenv genv) i e =+  Subst is (extendVarEnv i e env) tenv genv++-- | Extend the substitution environment with a list of 'Id' substitutions+extendIdSubstList+  :: Subst+  -> [(Id,Term)]+  -> Subst+extendIdSubstList (Subst is env tenv genv) es =+  Subst is (extendVarEnvList env es) tenv genv++-- | Extend the substitution environment with a list of global 'Id' substitutions+extendGblSubstList+  :: Subst+  -> [(Id,Term)]+  -> Subst+extendGblSubstList (Subst is env tenv genv) es =+  Subst is env tenv (extendVarEnvList genv es)++-- | Extend the substitution environment with a new 'TyVar' substitution+extendTvSubst+  :: Subst+  -> TyVar+  -> Type+  -> Subst+extendTvSubst (Subst is env tenv genv) tv t =+  Subst is env (extendVarEnv tv t tenv) genv++-- | Extend the substitution environment with a list of 'TyVar' substitutions+extendTvSubstList+  :: Subst+  -> [(TyVar, Type)]+  -> Subst+extendTvSubstList (Subst is env tenv genv) ts =+  Subst is env (extendVarEnvList tenv ts) genv++-- | Add an 'Id' to the in-scope set: as a side effect, remove any existing+-- substitutions for it.+extendInScopeId+  :: Subst+  -> Id+  -> Subst+extendInScopeId (Subst inScope env tenv genv) id' =+  Subst inScope' env' tenv genv+ where+  inScope' = extendInScopeSet inScope id'+  env'     = delVarEnv env id'++-- | Add 'Id's to the in-scope set. See also 'extendInScopeId'+extendInScopeIdList+  :: Subst+  -> [Id]+  -> Subst+extendInScopeIdList (Subst inScope env tenv genv) ids =+  Subst inScope' env' tenv genv+ where+  inScope' = extendInScopeSetList inScope ids+  env'     = delVarEnvList env ids++-- | Substitute within a 'Type'+--+-- The substitution has to satisfy the invariant described in+-- 'TvSubst's Note [The substitution environment]+substTy+  :: HasCallStack+  => Subst+  -> Type+  -> Type+substTy (Subst inScope _ tvS _) ty+  | nullVarEnv tvS+  = ty+  | otherwise+  = checkValidSubst s' [ty] (substTy' s' ty)+ where+  s' = TvSubst inScope tvS++-- | Substitute within a 'TyVar'. See 'substTy'.+substTyInVar+  :: HasCallStack+  => Subst+  -> Var a+  -> Var a+substTyInVar subst tyVar =+  tyVar { varType = (substTy subst (varType tyVar)) }++-- | Like 'substTy', but skips the checks for the invariants described in+-- 'TvSubts' Note [The substitution environment]. Should be used inside this+-- module only.+substTyUnchecked+  :: HasCallStack+  => TvSubst+  -> Type+  -> Type+substTyUnchecked subst@(TvSubst _ tvS) ty+  | nullVarEnv tvS+  = ty+  | otherwise+  = substTy' subst ty++-- Safely substitute global type variables in a list of potentially+-- shadowing type variables.+substGlobalsInExistentials+  :: HasCallStack+  => InScopeSet+  -- ^ Variables in scope+  -> [TyVar]+  -- ^ List of existentials to apply the substitution for+  -> [(TyVar, Type)]+  -- ^ Substitutions+  -> [TyVar]+substGlobalsInExistentials is exts substs0 = result+  -- TODO: Is is actually possible that existentials shadow each other? If they+  -- TODO: can't, we can remove this function+  where+    iss     = scanl extendInScopeSet is exts+    substs1 = map (\is_ -> extendTvSubstList (mkSubst is_) substs0) iss+    result  = zipWith substTyInVar substs1 exts++-- | Safely substitute type variables in a list of existentials. This function+-- will account for cases where existentials shadow each other.+substInExistentialsList+  :: HasCallStack+  => InScopeSet+  -- ^ Variables in scope+  -> [TyVar]+  -- ^ List of existentials to apply the substitution for+  -> [(TyVar, Type)]+  -- ^ Substitutions+  -> [TyVar]+substInExistentialsList is exts substs =+  foldl (substInExistentials is) exts substs++-- | Safely substitute a type variable in a list of existentials. This function+-- will account for cases where existentials shadow each other.+substInExistentials+  :: HasCallStack+  => InScopeSet+  -- ^ Variables in scope+  -> [TyVar]+  -- ^ List of existentials to apply the substitution for+  -> (TyVar, Type)+  -- ^ Substitution+  -> [TyVar]+substInExistentials is exts subst@(typeVar, _type) =+  -- TODO: Is is actually possible that existentials shadow each other? If they+  -- TODO: can't, we can remove this function+  case List.elemIndices typeVar exts of+    [] ->+      -- We're not replacing any of the existentials, but a global variable+      substGlobalsInExistentials is exts [subst]+    (last -> i) ->+      -- We're replacing an existential. That means we're not touching any+      -- variables that were introduced before it. For all variables after it,+      -- it is as we would replace global variables in them.+      take (i+1) exts ++ substGlobalsInExistentials is (drop (i+1) exts) [subst]++-- | This checks if the substitution satisfies the invariant from 'TvSubst's+-- Note [The substitution invariant].+checkValidSubst+  :: HasCallStack+  => TvSubst+  -> [Type]+  -> a+  -> a+checkValidSubst subst@(TvSubst inScope tenv) tys a =+  WARN( not (isValidSubst subst),+        "inScope" <+> clashPretty inScope <> line <>+        "tenv" <+> clashPretty tenv <> line <>+        "tenvFVs" <+> clashPretty (freeVarsOf tenv) <> line <>+        "tys" <+> fromPpr tys)+  WARN( not tysFVsInSope,+       "inScope" <+> clashPretty inScope <> line <>+       "tenv" <+> clashPretty tenv <> line <>+       "tys" <+> fromPpr tys <> line <>+       "needsInScope" <+> clashPretty needsInScope)+  a+ where+  needsInScope = UniqMap.foldrWithUnique (\k _ s -> delVarSetByKey k s)+                   (freeVarsOf tys)+                   tenv+  tysFVsInSope = needsInScope `varSetInScope` inScope++-- | When calling 'substTy' it should be the case that the in-scope set in the+-- substitution is a superset of the free variables of the range of the+-- substitution.+--+-- See also 'TvSubst's Note [The substitution invariant].+isValidSubst+  :: TvSubst+  -> Bool+isValidSubst (TvSubst inScope tenv) = tenvFVs `varSetInScope` inScope+ where+  tenvFVs = freeVarsOf tenv++-- | The work-horse of 'substTy'+substTy'+  :: HasCallStack+  => TvSubst+  -> Type+  -> Type+substTy' subst = go where+  go = \case+    VarTy tv -> substTyVar subst tv+    ForAllTy tv ty -> case substTyVarBndr subst tv of+      (subst', tv') -> ForAllTy tv' (substTy' subst' ty)+    AppTy fun arg -> AppTy (go fun) (go arg)+    ty -> ty++-- | Substitute a variable with a type if it's within the substitution's domain.+--+-- Does not substitute within the kind of free variables.+substTyVar+  :: TvSubst+  -> TyVar+  -> Type+substTyVar (TvSubst _ tenv) tv = case lookupVarEnv tv tenv of+  Just ty -> ty+  _       -> VarTy tv++-- | Substitute a type variable in a binding position, returning an extended+-- substitution environment and a new type variable.+--+-- Substitutes within the kind of the type variable+substTyVarBndr+  :: TvSubst+  -> TyVar+  -> (TvSubst, TyVar)+substTyVarBndr subst@(TvSubst inScope tenv) oldVar =+  ASSERT2( no_capture, clashPretty oldVar <> line+                    <> clashPretty newVar <> line+                    <> clashPretty subst )+  (TvSubst (inScope `extendInScopeSet` newVar) newEnv, newVar)+ where+  newEnv | noChange  = delVarEnv tenv oldVar+         | otherwise = extendVarEnv oldVar (VarTy newVar) tenv++  -- Assertion that we're not capturing something in the substitution+  no_capture = not (newVar `elemVarSet` freeVarsOf tenv)++  oldKi        = varType oldVar+  -- verify that the kind is closed+  noKindChange = isClosed oldKi+  -- noChange means that the new type variable is identical in all respects to+  -- the old type variable (same unique, same kind)+  -- See 'TvSubstEnv's Note [Extending the TvSubstEnv]+  --+  -- In that case we don't need to extend the substitution to map old to new.+  -- But instead we must zap any current substitution for the variable. For+  -- example+  --+  --   (\x.e) with subst = [x | -> e']+  --+  -- Here we must simply zap the substitution for x+  noChange     = noKindChange && (newVar == oldVar)++  -- uniqAway ensures that the new variable is not already in scope+  newVar | noKindChange = uniqAway inScope oldVar+         | otherwise    = uniqAway inScope+                            (oldVar {varType = substTyUnchecked subst oldKi})++-- | Substitute within a 'Term'. Just return original term if given+-- substitution is "Nothing".+maybeSubstTm+  :: HasCallStack+  => Doc ()+  -> Maybe Subst+  -> Term+  -> Term+maybeSubstTm _doc Nothing = id+maybeSubstTm doc (Just s) = substTm doc s++-- | Substitute within a 'Term'+substTm+  :: HasCallStack+  => Doc ()+  -> Subst+  -> Term+  -> Term+substTm doc subst = go where+  go = \case+    Var v -> lookupIdSubst (doc <> line <> "subsTm") subst v+    Lam v e -> case substIdBndr subst v of+      (subst',v') -> Lam v' (substTm doc subst' e)+    TyLam v e -> case substTyVarBndr' subst v of+      (subst',v') -> TyLam v' (substTm doc subst' e)+    App l r -> App (go l) (go r)+    TyApp l r -> TyApp (go l) (substTy subst r)+    Let bs e -> case substBind doc subst bs of+      (subst',bs') -> Let bs' (substTm doc subst' e)+    Case subj ty alts -> Case (go subj) (substTy subst ty) (map goAlt alts)+    Cast e t1 t2 -> Cast (go e) (substTy subst t1) (substTy subst t2)+    Tick tick e -> Tick (goTick tick) (go e)+    tm -> tm++  goAlt (pat,alt) = case pat of+    DataPat dc tvs ids -> case List.mapAccumL substTyVarBndr' subst tvs of+      (subst1,tvs') -> case List.mapAccumL substIdBndr subst1 ids of+        (subst2,ids') -> (DataPat dc tvs' ids',substTm doc subst2 alt)+    _ -> (pat,go alt)++  goTick t@(SrcSpan _)  = t+  goTick (NameMod m ty) = NameMod m (substTy subst ty)+  goTick t@DeDup        = t+  goTick t@NoDeDup      = t+  goTick (Attributes ty tm) = Attributes (substTy subst ty) (go tm)++-- | Substitute within a case-alternative+substAlt+  :: HasCallStack+  => Doc ()+  -> Subst+  -- ^ The substitution+  -> (Pat, Term)+  -- ^ The alternative in which to apply the substitution+  -> (Pat, Term)+substAlt doc subst (pat,alt) = case pat of+  DataPat dc tvs ids -> case List.mapAccumL substTyVarBndr' subst tvs of+    (subst1,tvs1) -> case List.mapAccumL substIdBndr subst1 ids of+      (subst2,ids1) -> (DataPat dc tvs1 ids1,substTm doc subst2 alt)+  _ -> (pat, substTm doc subst alt)++substId+  :: HasCallStack+  => Subst+  -> Id+  -> Id+substId subst oldId = snd $ substIdBndr subst oldId++-- | Find the substitution for an 'Id' in the 'Subst'+lookupIdSubst+  :: HasCallStack+  => Doc ()+  -> Subst+  -> Id+  -> Term+lookupIdSubst doc (Subst inScope tmS _ genv) v+  | isGlobalId v = case lookupVarEnv v genv of+                     Just e -> e+                     _      -> Var v+  | Just e <- lookupVarEnv v tmS = e+  -- Vital! See 'IdSubstEnv' Note [Extending the Subst]+  --+  -- TODO: We match on Id here to workaround an issue where type variables+  -- TODO: "shadow" term variables. Omitting the check would make 'lookupIdSubst'+  -- TODO: potentially replace an "Id" with a TyVar. For more information:+  -- TODO:+  -- TODO:   https://github.com/clash-lang/clash-compiler/issues/1046+  -- TODO:+  | Just v'@(Id {}) <- lookupInScope inScope v = Var (coerce v')+  | otherwise = WARN(True, "Subst.lookupIdSubst" <+> doc <+> fromPpr v)+                Var v++-- | Substitute an 'Id' for another one according to the 'Subst' given,+-- returning the result and an update 'Subst' that should be used in subsequent+-- substitutions.+substIdBndr+  :: HasCallStack+  => Subst+  -> Id+  -> (Subst,Id)+substIdBndr subst@(Subst inScope env tenv genv) oldId =+  (Subst (inScope `extendInScopeSet` newId) newEnv tenv genv, newId)+ where+  id1 = uniqAway inScope oldId+  newId | noTypeChange = id1+        | otherwise    = id1 {varType = substTy subst (varType id1)}++  oldTy = varType oldId+  noTypeChange = nullVarEnv tenv || isClosed oldTy++  -- Extend the substitution if the unique has changed.+  --+  -- In case it hasn't changed we don't need to extend the substitution to map+  -- old to new. But instead we must zap any current substitution for the+  -- variable. For example+  --+  --   (\x.e) with subst = [x | -> e']+  --+  -- Here we must simply zap the substitution for x+  newEnv | noChange  = delVarEnv env oldId+         | otherwise = extendVarEnv oldId (Var newId) env++  -- See Note [Extending the Subst] why it's not necessary to check noTypeChange+  noChange = id1 == oldId++-- | Like 'substTyVarBndr' but takes a 'Subst' instead of a 'TvSubst'+substTyVarBndr'+  :: HasCallStack+  => Subst+  -> TyVar+  -> (Subst,TyVar)+substTyVarBndr' (Subst inScope tmS tyS tgS) tv =+  case substTyVarBndr (TvSubst inScope tyS) tv of+    (TvSubst inScope' tyS',tv') -> (Subst inScope' tmS tyS' tgS, tv')++-- | Apply a substitution to an entire set of let-bindings, additionally+-- returning an updated 'Subst' that should be used by subsequent substitutions.+substBind+  :: HasCallStack+  => Doc ()+  -> Subst+  -> Bind Term+  -> (Subst, Bind Term)+substBind doc subst (NonRec i x) =+  (subst', NonRec i' x')+ where+  (subst', i') = substIdBndr subst i+  x' = substTm ("substBind" <+> doc) subst x++substBind doc subst (Rec xs) =+  (subst', Rec (zip bndrs' rhss'))+ where+  (bndrs,rhss)    = unzip xs+  (subst',bndrs') = List.mapAccumL substIdBndr subst bndrs+  rhss'           = map (substTm ("substBind" <+> doc) subst') rhss++-- | Type substitution, see 'zipTvSubst'+--+-- Works only if the domain of the substitution is superset of the type being+-- substituted into+substTyWith+  :: HasCallStack+  => [TyVar]+  -> [Type]+  -> Type+  -> Type+substTyWith tvs tys =+  ASSERT( List.equalLength tvs tys )+  substTy (zipTvSubst tvs tys)++-- | Ensure that non of the binders in an expression shadow each-other, nor+-- conflict with he in-scope set+deShadowTerm+  :: HasCallStack+  => InScopeSet+  -> Term+  -> Term+deShadowTerm is e = substTm "deShadowTerm" (mkSubst is) e++-- | Ensure that non of the binders in an alternative shadow each-other, nor+-- conflict with the in-scope set+deShadowAlt ::+  HasCallStack =>+  InScopeSet ->+  (Pat, Term) ->+  (Pat, Term)+deShadowAlt is = substAlt "deShadowAlt" (mkSubst is)++-- | Ensure that non of the let-bindings of a let-expression shadow w.r.t the+-- in-scope set+deshadowLetExpr+  :: HasCallStack+  => InScopeSet+  -- ^ Current InScopeSet+  -> Bind Term+  -- ^ Bindings of the let-expression+  -> Term+  -- ^ The body of the let-expression+  -> (Bind Term, Term)+  -- ^ Deshadowed let-bindings, where let-bound expressions and the let-body+  -- properly reference the renamed variables+deshadowLetExpr is bs e =+  case substBind "deshadowLetBindings" (mkSubst is) bs of+    (s1,bs1) -> (bs1, substTm "deShadowLetBody" s1 e)++-- | A much stronger variant of `deShadowTerm` that ensures that all bound+-- variables are unique.+--+-- Also returns an extended 'InScopeSet' additionally containing the (renamed)+-- unique bound variables of the term.+freshenTm+  :: InScopeSet+  -- ^ Current set of variables in scope+  -> Term+  -> (InScopeSet, Term)+freshenTm is0 = go (mkSubst is0) where+  go subst0 = \case+    Var v -> (substInScope subst0, lookupIdSubst "freshenTm" subst0 v)+    Lam v e -> case substIdBndr subst0 v of+      (subst1,v') -> case go subst1 e of+        (is2,e') -> (is2, Lam v' e')+    TyLam v e -> case substTyVarBndr' subst0 v of+      (subst1,v') -> case go subst1 e of+        (is2,e') -> (is2,TyLam v' e')+    App l r -> case go subst0 l of+      (is1,l') -> case go subst0 {substInScope = is1} r of+        (is2,r') -> (is2, App l' r')+    TyApp l r -> case go subst0 l of+      (is1,l') -> (is1, TyApp l' (substTy subst0 r))+    Let bs e -> case goBind subst0 bs of+      (subst1,bs') -> case go subst1 e of+        (is2,e') -> (is2,Let bs' e')+    Case subj ty alts -> case go subst0 subj of+      (is1,subj') -> case List.mapAccumL (\isN -> goAlt subst0 {substInScope = isN}) is1 alts of+        (is2,alts') -> (is2, Case subj' (substTy subst0 ty) alts')+    Cast e t1 t2 -> case go subst0 e of+      (is1, e') -> (is1, Cast e' (substTy subst0 t1) (substTy subst0 t2))+    Tick tick e -> case go subst0 e of+       (is1, e') -> (is1, Tick (goTick subst0 tick) e')+    tm -> (substInScope subst0, tm)++  goBind subst0 (NonRec i x) =+    let (subst1, i') = substIdBndr subst0 i+        (is2, x') = go subst0 x+     in (subst1 { substInScope = extendInScopeSet is2 i' }, NonRec i' x')++  goBind subst0 (Rec xs) =+    let (bndrs,rhss)    = unzip xs+        (subst1,bndrs') = List.mapAccumL substIdBndr subst0 bndrs+        (is2,rhss')     = List.mapAccumL (\isN -> go subst1 {substInScope = isN})+                                         (substInScope subst1)+                                         rhss+    in  (subst1 {substInScope = is2}, Rec $ zip bndrs' rhss')++  goAlt subst0 (pat,alt) = case pat of+    DataPat dc tvs ids -> case List.mapAccumL substTyVarBndr' subst0 tvs of+      (subst1,tvs') -> case List.mapAccumL substIdBndr subst1 ids of+        (subst2,ids') -> case go subst2 alt of+          (is3,alt') -> (is3,(DataPat dc tvs' ids',alt'))+    _ -> case go subst0 alt of+      (is1,alt') -> (is1,(pat,alt'))++  goTick subst0 (NameMod m ty) = NameMod m (substTy subst0 ty)+  goTick _      tick           = tick++-- * AEQ++-- | Alpha equality for types+aeqType+  :: Type+  -> Type+  -> Bool+aeqType t1 t2 = acmpType' rnEnv t1 t2 == EQ+ where+  rnEnv = mkRnEnv (mkInScopeSet (freeVarsOf [t1,t2]))++-- | Alpha comparison for types+acmpType+  :: Type+  -> Type+  -> Ordering+acmpType t1 t2 = acmpType' (mkRnEnv inScope) t1 t2+ where+  inScope = mkInScopeSet (freeVarsOf [t1,t2])++-- | Alpha comparison for types. Faster than 'acmpType' as it doesn't need to+-- calculate the free variables to create the 'InScopeSet'+acmpType'+  :: RnEnv+  -> Type+  -> Type+  -> Ordering+acmpType' = go+ where+  go env (VarTy tv1) (VarTy tv2) = compare (rnOccLTy env tv1) (rnOccRTy env tv2)+  go _   (ConstTy c1) (ConstTy c2) = compare c1 c2+  go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) =+    go env (varType tv1) (varType tv2) `thenCompare` go (rnTyBndr env tv1 tv2) t1 t2+  go env (AppTy s1 t1) (AppTy s2 t2) =+    go env s1 s2 `thenCompare` go env t1 t2+  go _ (LitTy l1) (LitTy l2) = compare l1 l2+  go env (AnnType a1 t1) (AnnType a2 t2) =+    compare a1 a2 `thenCompare` go env t1 t2+  go _ t1 t2 = compare (getRank t1) (getRank t2)++  getRank :: Type -> Word+  getRank (VarTy {})    = 0+  getRank (LitTy {})    = 1+  getRank (ConstTy {})  = 2+  getRank (AnnType {})  = 3+  getRank (AppTy {})    = 4+  getRank (ForAllTy {}) = 5++-- | Structural equality on 'Type'+eqType+  :: Type+  -> Type+  -> Bool+eqType = go+ where+  go (VarTy tv1) (VarTy tv2) = tv1 == tv2+  go (ConstTy c1) (ConstTy c2) = c1 == c2+  go (ForAllTy tv1 t1) (ForAllTy tv2 t2) =+    tv1 == tv2 && go (varType tv1) (varType tv2) && go t1 t2+  go (AppTy s1 t1) (AppTy s2 t2) = go s1 s2 && go t1 t2+  go (LitTy l1) (LitTy l2) = l1 == l2+  go (AnnType a1 t1) (AnnType a2 t2) = a1 == a2 && go t1 t2+  go _ _ = False++-- | Alpha equality for terms+aeqTerm+  :: Term+  -> Term+  -> Bool+aeqTerm t1 t2 = aeqTerm' inScope t1 t2+ where+  inScope = mkInScopeSet (freeVarsOf [t1,t2])++-- | Alpha equality for terms. Faster than 'aeqTerm' as it doesn't need to+-- calculate the free variables to create the 'InScopeSet'+aeqTerm'+  :: InScopeSet+  -- ^ Superset of variables in scope of the left and right term+  -> Term+  -> Term+  -> Bool+aeqTerm' inScope t1 t2 = acmpTerm' inScope t1 t2 == EQ++-- | Alpha comparison for types+acmpTerm+  :: Term+  -> Term+  -> Ordering+acmpTerm t1 t2 = acmpTerm' inScope t1 t2+ where+  inScope = mkInScopeSet (freeVarsOf [t1,t2])++-- | Alpha comparison for types. Faster than 'acmpTerm' as it doesn't need to+-- calculate the free variables to create the 'InScopeSet'+acmpTerm'+  :: InScopeSet+  -- ^ Superset of variables in scope of the left and right term+  -> Term+  -> Term+  -> Ordering+acmpTerm' inScope = go (mkRnEnv inScope)+ where+  thenCmpTm EQ  rel = rel+  thenCmpTm rel _   = rel++  go env (Var id1) (Var id2)   = compare (rnOccLId env id1) (rnOccRId env id2)+  go _   (Data dc1) (Data dc2) = compare dc1 dc2+  go _   (Literal l1) (Literal l2) = compare l1 l2+  go _   (Prim p1) (Prim p2) = comparing primName p1 p2+  go env (Lam b1 e1) (Lam b2 e2) =+    acmpType' env (varType b1) (varType b2) `thenCompare`+    go (rnTmBndr env b1 b2) e1 e2+  go env (TyLam b1 e1) (TyLam b2 e2) =+    acmpType' env (varType b1) (varType b2) `thenCompare`+    go (rnTyBndr env b1 b2) e1 e2+  go env (App l1 r1) (App l2 r2) =+    go env l1 l2 `thenCompare` go env r1 r2+  go env (TyApp l1 r1) (TyApp l2 r2) =+    go env l1 l2 `thenCompare` acmpType' env r1 r2+  go env (Let (NonRec i1 x1) e1) (Let (NonRec i2 x2) e2) =+    go env x1 x2 `thenCompare` go (rnTmBndr env i1 i2) e1 e2+  go env (Let (Rec bs1) e1) (Let (Rec bs2) e2) =+    compare (length bs1) (length bs2) `thenCompare`+    foldr thenCmpTm EQ (zipWith (go env') rhs1 rhs2) `thenCompare`+    go env' e1 e2+   where+    (ids1,rhs1) = unzip bs1+    (ids2,rhs2) = unzip bs2+    env' = rnTmBndrs env ids1 ids2+  go env (Case e1 _ a1) (Case e2 _ a2) =+    compare (length a1) (length a2) `thenCompare`+    go env e1 e2 `thenCompare`+    foldr thenCmpTm EQ (zipWith (goAlt env) a1 a2)+  go env (Cast e1 l1 r1) (Cast e2 l2 r2) =+    go env e1 e2 `thenCompare`+    acmpType' env l1 l2 `thenCompare`+    acmpType' env r1 r2+  go env (Tick t1 e1) (Tick t2 e2) =+    compare t1 t2 `thenCompare` go env e1 e2+  go _ e1 e2 = compare (getRank e1) (getRank e2)++  goAlt env (DataPat c1 tvs1 ids1,e1) (DataPat c2 tvs2 ids2,e2) =+    compare c1 c2 `thenCompare` go env' e1 e2+   where+    env' = rnTmBndrs (rnTyBndrs env tvs1 tvs2) ids1 ids2+  goAlt env (c1,e1) (c2,e2) =+    compare c1 c2 `thenCompare` go env e1 e2++  getRank :: Term -> Word+  getRank = \case+    Var {}     -> 0+    Data {}    -> 1+    Literal {} -> 2+    Prim {}    -> 3+    Cast {}    -> 4+    App {}     -> 5+    TyApp {}   -> 6+    Lam {}     -> 7+    TyLam {}   -> 8+    Let NonRec{} _ -> 9+    Let Rec{} _ -> 10+    Case {}    -> 11+    Tick {}    -> 12++-- | Structural equality on 'Term'+eqTerm :: Term -> Term -> Bool+eqTerm = go+ where+  go (Var id1) (Var id2) = id1 == id2+  go (Data dc1) (Data dc2) = dc1 == dc2+  go (Literal l1) (Literal l2) = l1 == l2+  go (Prim p1) (Prim p2) = primName p1 == primName p2+  go (Lam b1 e1) (Lam b2 e2) =+    b1 == b2 && eqType (varType b1) (varType b2) && go e1 e2+  go (TyLam b1 e1) (TyLam b2 e2) =+    b1 == b2 && eqType (varType b1) (varType b2) && go e1 e2+  go (App l1 r1) (App l2 r2) = go l1 l2 && go r1 r2+  go (TyApp l1 r1) (TyApp l2 r2) = go l1 l2 && eqType r1 r2+  go (Let bs1 e1) (Let bs2 e2) =+    go e1 e2 &&+    goBind bs1 bs2+   where+    goBind (NonRec b1 r1) (NonRec b2 r2) =+      -- No need to check types of NonRec bindings, when the RHSs match the+      -- types must be the same.+      b1 == b2 && go r1 r2+    goBind (Rec brs1) (Rec brs2) =+      List.all2+        (\(b1,r1) (b2,r2) ->+          b1 == b2 &&+          -- We need to check the types of Rec bindings, because:+          --+          -- letrec (x : Bool) = x in X+          --+          -- is not structurally equivalent to+          --+          -- letrec (x : Int) = x in x+          eqType (varType b1) (varType b2) &&+          go r1 r2)+        brs1 brs2+    goBind _ _ = False+  go (Case e1 _ a1) (Case e2 _ a2) =+    go e1 e2 &&+    List.all2 goAlt a1 a2+   where+    goAlt (p1,r1) (p2,r2) = p1 == p2 && go r1 r2+  go (Cast e1 l1 r1) (Cast e2 l2 r2) =+    go e1 e2 &&+    eqType l1 l2 &&+    eqType r1 r2+  go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && go e1 e2+  go _ _ = False++instance Eq Type where+  (==) = aeqType++instance Ord Type where+  compare = acmpType++instance Eq Term where+  (==) = aeqTerm++instance TypeError (+        'Text "A broken implementation of Hashable Term has been "+  ':<>: 'Text "removed in Clash 1.4.7. If this is an issue for you, please submit "+  ':<>: 'Text "an issue report at https://github.com/clash-lang/clash-compiler/issues."+  ) => Hashable Term where+    hashWithSalt = error "Term.hashWithSalt: unreachable"+++instance Ord Term where+  compare = acmpTerm
+ src/Clash/Core/Subst.hs-boot view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Clash.Core.Subst where++import GHC.Stack (HasCallStack)+import {-# SOURCE #-} Clash.Core.Term (Term)+import {-# SOURCE #-} Clash.Core.Type (Type)+import Clash.Core.Var (TyVar)++substTyWith+  :: HasCallStack+  => [TyVar]+  -> [Type]+  -> Type+  -> Type++aeqType+  :: Type+  -> Type+  -> Bool++instance Eq Type+instance Ord Type++acmpTerm :: Term -> Term -> Ordering++instance Eq Term
+ src/Clash/Core/Term.hs view
@@ -0,0 +1,453 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                          2017, Google Inc.+                     2021-2024, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Term representation in the CoreHW language: System F + LetRec + Case+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module Clash.Core.Term+  ( Term (.., Letrec)+  , mkAbstraction+  , mkTyLams+  , mkLams+  , mkApps+  , mkTyApps+  , mkTmApps+  , mkTicks+  , TmName+  , varToId+  , Bind(..)+  , LetBinding+  , Pat (..)+  , patIds+  , patVars+  , Alt+  , TickInfo (..)+  , stripTicks+  , stripAllTicks+  , partitionTicks+  , NameMod (..)+  , PrimInfo (..)+  , PrimUnfolding (..)+  , IsMultiPrim (..)+  , MultiPrimInfo (..)+  , WorkInfo (..)+  , CoreContext (..)+  , Context+  , isLambdaBodyCtx+  , isTickCtx+  , walkTerm+  , collectArgs+  , collectArgsTicks+  , collectTicks+  , collectTermIds+  , collectBndrs+  , primArg+  ) where++-- External Modules+import Control.DeepSeq+import Data.Binary                             (Binary)+import Data.Coerce                             (coerce)+import qualified Data.DList                    as DList+import Data.Either                             (lefts, rights)+#if !MIN_VERSION_base(4,20,0)+import Data.Foldable                           (foldl')+#endif+import Data.Hashable                           (Hashable)+import Data.Maybe                              (catMaybes)+import Data.List                               (nub, partition)+import Data.Text                               (Text)+import GHC.Generics+import GHC.Types.SrcLoc                        (SrcSpan, leftmost_smallest)++-- Internal Modules+import Clash.Core.DataCon                      (DataCon)+import Clash.Core.Literal                      (Literal)+import Clash.Core.Name                         (Name (..))+import {-# SOURCE #-} Clash.Core.Subst         (acmpTerm) -- instance Eq/Ord Type, Eq Term+import {-# SOURCE #-} Clash.Core.Type          (Type)+import Clash.Core.Var                          (Var, Id, TyVar)+import Clash.Util                              (curLoc, thenCompare)++-- | Term representation in the CoreHW language: System F + LetRec + Case+data Term+  = Var     !Id                             -- ^ Variable reference+  | Data    !DataCon                        -- ^ Datatype constructor+  | Literal !Literal                        -- ^ Literal+  | Prim    !PrimInfo                       -- ^ Primitive+  | Lam     !Id Term                        -- ^ Term-abstraction+  | TyLam   !TyVar Term                     -- ^ Type-abstraction+  | App     !Term !Term                     -- ^ Application+  | TyApp   !Term !Type                     -- ^ Type-application+  | Let     !(Bind Term) Term               -- ^ Recursive let-binding+  | Case    !Term !Type [Alt]               -- ^ Case-expression: subject, type of+                                            -- alternatives, list of alternatives+  | Cast    !Term !Type !Type               -- ^ Cast a term from one type to another+  | Tick    !TickInfo !Term                 -- ^ Annotated term+  deriving (Show, Generic, NFData, Binary)++-- TODO When it is possible, remove this pattern.+pattern Letrec :: [LetBinding] -> Term -> Term+pattern Letrec bs x <- Let (bindToList -> bs) x+ where+  Letrec bs x = Let (Rec bs) x++bindToList :: Bind a -> [(Id, a)]+bindToList (NonRec i x) = [(i, x)]+bindToList (Rec xs) = xs++data TickInfo+  = SrcSpan !SrcSpan+  -- ^ Source tick, will get added by GHC by running clash with `-g`+  | NameMod !NameMod !Type+  -- ^ Modifier for naming module instantiations and registers, are added by+  -- the user by using the functions @Clash.Magic.[prefixName,suffixName,setName]@+  | DeDup+  -- ^ Deduplicate, i.e. try to share expressions between multiple branches.+  | NoDeDup+  -- ^ Do not deduplicate, i.e. /keep/, an expression inside a case-alternative;+  -- do not try to share expressions between multiple branches.+  | Attributes Type Term+  -- ^ Synthesis attributes brough into scope by+  -- 'Clash.Annotations.SynthesisAttributes.annotateReg'+  deriving (Eq, Show, Generic, NFData, Binary)++instance Ord TickInfo where+  compare (SrcSpan s1) (SrcSpan s2) = leftmost_smallest s1 s2+  compare (NameMod m1 t1) (NameMod m2 t2) =+    compare m1 m2 `thenCompare` compare t1 t2+  compare (Attributes t1 a1) (Attributes t2 a2) =+    compare t1 t2 `thenCompare` acmpTerm a1 a2+  compare t1 t2 = compare (getRank t1) (getRank t2)+    where+      getRank :: TickInfo -> Word+      getRank SrcSpan{}     = 0+      getRank NameMod{}     = 1+      getRank DeDup         = 2+      getRank NoDeDup       = 3+      getRank Attributes {} = 4++-- | Tag to indicate which instance/register name modifier was used+data NameMod+  = PrefixName+  -- ^ @Clash.Magic.prefixName@+  | SuffixName+  -- ^ @Clash.Magic.suffixName@+  | SuffixNameP+  -- ^ @Clash.Magic.suffixNameP@+  | SetName+  -- ^ @Clash.Magic.setName@+  deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary)++data IsMultiPrim+  = SingleResult+  | MultiResult+  deriving (Show, Generic, NFData, Eq, Hashable, Binary)++data PrimInfo = PrimInfo+  { primName :: !Text+  , primType :: !Type+  , primWorkInfo :: !WorkInfo+  , primMultiResult :: !IsMultiPrim+  -- ^ Primitive with multiple return values. Useful for primitives that cannot+  -- return their results as a single product type, due to limitation of+  -- synthesis tooling. It will be applied to its normal arguments, followed by+  -- the variables it should assign its results to.+  --+  -- See: 'Clash.Normalize.Transformations.setupMultiResultPrim'+  , primUnfolding :: !PrimUnfolding+  } deriving (Show, Generic, NFData, Binary)++data PrimUnfolding+  = NoUnfolding+  | Unfolding !Id+  deriving (Show, Generic, NFData, Eq, Hashable, Binary)++data MultiPrimInfo = MultiPrimInfo+  { mpi_primInfo :: PrimInfo+  , mpi_resultDc :: DataCon+  , mpi_resultTypes :: [Type]+  }++data WorkInfo+  = WorkConstant+  -- ^ Ignores its arguments, and outputs a constant+  | WorkNever+  -- ^ Never adds any work+  | WorkVariable+  -- ^ Does work when the arguments are variable+  | WorkAlways+  -- ^ Performs work regardless of whether the variables are constant or+  -- variable; these are things like clock or reset generators+  | WorkIdentity Int [Int]+  -- ^ A more restrictive version of 'WorkNever', where the value is the+  -- argument at the given position if all arguments for the given list of+  -- positions are also 'WorkIdentity'+  deriving (Eq,Show,Generic,NFData,Hashable,Binary)++-- | Term reference+type TmName     = Name Term+-- | Binding in a LetRec construct+type LetBinding = (Id, Term)++data Bind a+  = NonRec Id a+  | Rec [(Id, a)]+  deriving (Eq, Show, Generic, NFData, Hashable, Binary, Functor)+  -- Structural equivalence instead of alpha equivalance++-- | Patterns in the LHS of a case-decomposition+data Pat+  = DataPat !DataCon [TyVar] [Id]+  -- ^ Datatype pattern, '[TyVar]' bind existentially-quantified+  -- type-variables of a DataCon+  | LitPat  !Literal+  -- ^ Literal pattern+  | DefaultPat+  -- ^ Default pattern+  deriving (Eq, Ord, Show, Generic, NFData, Binary)++type Alt = (Pat,Term)++-- | Get the list of term-binders out of a DataType pattern+patIds :: Pat -> ([TyVar],[Id])+patIds (DataPat _  tvs ids) = (tvs,ids)+patIds _                    = ([],[])++patVars :: Pat -> [Var a]+patVars (DataPat _ tvs ids) = coerce tvs ++ coerce ids+patVars _ = []++-- | Abstract a term over a list of term and type variables+mkAbstraction :: Term -> [Either Id TyVar] -> Term+mkAbstraction = foldr (either Lam TyLam)++-- | Abstract a term over a list of type variables+mkTyLams :: Term -> [TyVar] -> Term+mkTyLams tm = mkAbstraction tm . map Right++-- | Abstract a term over a list of variables+mkLams :: Term -> [Id] -> Term+mkLams tm = mkAbstraction tm . map Left++-- | Apply a list of types and terms to a term+mkApps :: Term -> [Either Term Type] -> Term+mkApps = foldl' (\e a -> either (App e) (TyApp e) a)++-- | Apply a list of terms to a term+mkTmApps :: Term -> [Term] -> Term+mkTmApps = foldl' App++-- | Apply a list of types to a term+mkTyApps :: Term -> [Type] -> Term+mkTyApps = foldl' TyApp++mkTicks :: Term -> [TickInfo] -> Term+mkTicks tm ticks = foldl' (\e s -> Tick s e) tm (nub ticks)++-- | Context in which a term appears+data CoreContext+  = AppFun+  -- ^ Function position of an application+  | AppArg (Maybe (Text, Int, Int))+  -- ^ Argument position of an application. If this is an argument applied to+  -- a primitive, a tuple is defined containing (name of the primitive, #type+  -- args, #term args)+  | TyAppC+  -- ^ Function position of a type application+  | LetBinding Id [Id]+  -- ^ RHS of a Let-binder with the sibling LHS'+  | LetBody [LetBinding]+  -- ^ Body of a Let-binding with the bound LHS'+  | LamBody Id+  -- ^ Body of a lambda-term with the abstracted variable+  | TyLamBody TyVar+  -- ^ Body of a TyLambda-term with the abstracted type-variable+  | CaseAlt Pat+  -- ^ RHS of a case-alternative with the bound pattern on the LHS+  | CaseScrut+  -- ^ Subject of a case-decomposition+  | CastBody+  -- ^ Body of a Cast+  | TickC TickInfo+  -- ^ Body of a Tick+  deriving (Show, Generic, NFData, Binary)++-- | A list of @CoreContext@ describes the complete navigation path from the+-- top-level to a specific sub-expression.+type Context = [CoreContext]++-- [Note] Custom @Eq@ instance for @CoreContext@+--+-- We need a manual equality instance here, due to the argument of `AppArg`.+-- Specifically, it is the only piece of information kept in `CoreContext`,+-- which references information about its children, breaking the invariant+-- that contexts represent a navigation to a specific sub-expression.+--+-- One would expect equal contexts to navigate to the same place, but if+-- these navigate to an argument position that contains different children,+-- we will get inequality from the derived `Eq`.+instance Eq CoreContext where+  c == c' = case (c, c') of+    (AppFun,          AppFun)            -> True+    (AppArg _,        AppArg _)          -> True+    -- NB: we do not see inside the argument here+    (TyAppC,          TyAppC)            -> True+    (LetBinding i is, LetBinding i' is') -> i == i' && is == is'+    (LetBody is,      LetBody is')       -> map fst is == map fst is'+    (LamBody i,       LamBody i')        -> i == i'+    (TyLamBody tv,    TyLamBody tv')     -> tv == tv'+    (CaseAlt p,       CaseAlt p')        -> p == p'+    (CaseScrut,       CaseScrut)         -> True+    (CastBody,        CastBody)          -> True+    (TickC sp,        TickC sp')         -> sp == sp'+    (_,               _)                 -> False++-- | Is the Context a Lambda/Term-abstraction context?+isLambdaBodyCtx :: CoreContext -> Bool+isLambdaBodyCtx (LamBody _) = True+isLambdaBodyCtx _           = False++-- | Is the Context a Tick context?+isTickCtx :: CoreContext -> Bool+isTickCtx (TickC _) = True+isTickCtx _         = False++stripTicks :: Term -> Term+stripTicks (Tick _ e) = stripTicks e+stripTicks e = e++-- | Like 'stripTicks' but removes all ticks from subexpressions.+stripAllTicks :: Term -> Term+stripAllTicks = go+ where+  go (Lam i x) = Lam i (go x)+  go (TyLam i x) = TyLam i (go x)+  go (App f x) = App (go f) (go x)+  go (TyApp f a) = TyApp (go f) a+  go (Let bs x) = Let (goBinds bs) (go x)+  go (Case x ty alts) = Case (go x) ty (fmap go <$> alts)+  go (Cast x a b) = Cast (go x) a b+  go (Tick _ x) = go x+  go x = x++  goBinds (NonRec i x) = NonRec i (go x)+  goBinds (Rec ixs) = Rec (fmap go <$> ixs)++-- | Split a (Type)Application in the applied term and it arguments+collectArgs :: Term -> (Term, [Either Term Type])+collectArgs = go []+  where+    go args (App e1 e2) = go (Left e2:args) e1+    go args (TyApp e t) = go (Right t:args) e+    go args (Tick _ e)  = go args e+    go args e           = (e, args)++collectTicks :: Term -> (Term, [TickInfo])+collectTicks = go []+ where+  go ticks (Tick s e) = go (s:ticks) e+  go ticks e          = (e,ticks)++collectArgsTicks :: Term -> (Term, [Either Term Type], [TickInfo])+collectArgsTicks = go [] []+ where+  go args ticks (App e1 e2) = go (Left e2:args) ticks     e1+  go args ticks (TyApp e t) = go (Right t:args) ticks     e+  go args ticks (Tick s e)  = go args           (s:ticks) e+  go args ticks e           = (e, args, ticks)++-- | Split a (Type)Abstraction in the bound variables and the abstracted term+collectBndrs :: Term -> ([Either Id TyVar], Term)+collectBndrs = go []+ where+  go bs (Lam v e')    = go (Left v:bs) e'+  go bs (TyLam tv e') = go (Right tv:bs) e'+  go bs e'            = (reverse bs,e')++-- | Given a function application, find the primitive it's applied. Yields+-- Nothing if given term is not an application or if it is not a primitive.+primArg+  :: Term+  -- ^ Function application+  -> Maybe (Text, Int, Int)+  -- ^ If @Term@ was a primitive: (name of primitive, #type args, #term args)+primArg (collectArgs -> t) =+  case t of+    (Prim p, args) ->+      Just (primName p, length (rights args), length (lefts args))+    _ ->+      Nothing++-- | Partition ticks in source ticks and nameMod ticks+partitionTicks+  :: [TickInfo]+  -> ([TickInfo], [TickInfo])+  -- ^ (source ticks, nameMod ticks)+partitionTicks = partition (\case {SrcSpan {} -> True; _ -> False})++-- | Visit all terms in a term, testing it with a predicate, and returning+-- a list of predicate yields.+walkTerm :: forall a . (Term -> Maybe a) -> Term -> [a]+walkTerm f = catMaybes . DList.toList . go+ where+  go :: Term -> DList.DList (Maybe a)+  go t = DList.cons (f t) $ case t of+    Var _ -> mempty+    Data _ -> mempty+    Literal _ -> mempty+    Prim _ -> mempty+    Lam _ t1 -> go t1+    TyLam _ t1 -> go t1+    App t1 t2 -> go t1 <> go t2+    TyApp t1 _ -> go t1+    Let (NonRec _ x) t1 -> go t1 <> go x+    Let (Rec bndrs) t1 -> go t1 <> mconcat (map (go . snd) bndrs)+    Case t1 _ alts -> go t1 <> mconcat (map (go . snd) alts)+    Cast t1 _ _ -> go t1+    Tick _ t1 -> go t1++-- Collect all term ids mentioned in a term+collectTermIds :: Term -> [Id]+collectTermIds = concat . walkTerm (Just . go)+ where+  go :: Term -> [Id]+  go (Var i) = [i]+  go (Lam i _) = [i]+  go (Let (NonRec i _) _) = [i]+  go (Let (Rec bndrs) _) = fmap fst bndrs+  go (Case _ _ alts) = concatMap (pat . fst) alts+  go (Data _) = []+  go (Literal _) = []+  go (Prim _) = []+  go (TyLam _ _) = []+  go (App _ _) = []+  go (TyApp _ _) = []+  go (Cast _ _ _) = []+  go (Tick _ _) = []++  pat :: Pat -> [Id]+  pat (DataPat _ _ ids) = ids+  pat (LitPat _) = []+  pat DefaultPat = []++-- | Make a term variable out of a variable reference or ticked variable+-- reference+varToId :: Term -> Id+varToId = \case+  Var i    -> i+  Tick _ e -> varToId e+  e        -> error $ $(curLoc) ++ "varToId: not a var: " ++ show e
+ src/Clash/Core/Term.hs-boot view
@@ -0,0 +1,18 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# OPTIONS_GHC -fno-warn-missing-methods #-}++module Clash.Core.Term where++import GHC.Generics    (Generic)+import Clash.Core.Name (Name)++data Term++type TmName = Name Term++instance Generic Term
+ src/Clash/Core/TermInfo.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Clash.Core.TermInfo where++import Data.Maybe (fromMaybe)+import GHC.Stack (HasCallStack)++import Clash.Core.HasType+import Clash.Core.Term+import Clash.Core.TyCon (tyConDataCons, isTupleTyConLike, TyConMap)+import Clash.Core.Type+import Clash.Core.Var+import qualified Clash.Data.UniqMap as UniqMap+import Clash.Util.Interpolate as I++termSize :: Term -> Word+termSize (Var {})     = 1+termSize (Data {})    = 1+termSize (Literal {}) = 1+termSize (Prim {})    = 1+termSize (Lam _ e)    = termSize e + 1+termSize (TyLam _ e)  = termSize e+termSize (App e1 e2)  = termSize e1 + termSize e2+termSize (TyApp e _)  = termSize e+termSize (Cast e _ _) = termSize e+termSize (Tick _ e)   = termSize e+termSize (Let (NonRec _ x) e) = termSize x + termSize e+termSize (Let (Rec xs) e) = sum (bodySz:bndrSzs)+ where+  bndrSzs = map (termSize . snd) xs+  bodySz  = termSize e+termSize (Case subj _ alts) = sum (subjSz:altSzs)+ where+  subjSz = termSize subj+  altSzs = map (termSize . snd) alts++multPrimErr :: PrimInfo -> String+multPrimErr primInfo =  [I.i|+  Internal error in multiPrimInfo': could not produce MultiPrimInfo. This+  probably means a multi result blackbox's result type was not a tuple.+  PrimInfo:++    #{primInfo}+|]++splitMultiPrimArgs ::+  HasCallStack =>+  MultiPrimInfo ->+  [Either Term Type] ->+  ([Either Term Type], [Id])+splitMultiPrimArgs MultiPrimInfo{mpi_resultTypes} args0 = (args1, resArgs1)+ where+  resArgs1 = [id_ | Left (Var id_) <- resArgs0]+  (args1, resArgs0) = splitAt (length args0 - length mpi_resultTypes) args0++-- | Same as 'multiPrimInfo', but produced an error if it could not produce a+-- 'MultiPrimInfo'.+multiPrimInfo' :: HasCallStack => TyConMap -> PrimInfo -> MultiPrimInfo+multiPrimInfo' tcm primInfo =+  fromMaybe (error (multPrimErr primInfo)) (multiPrimInfo tcm primInfo)++-- | Produce 'MutliPrimInfo' for given primitive+multiPrimInfo :: TyConMap -> PrimInfo -> Maybe MultiPrimInfo+multiPrimInfo tcm primInfo+  | (_primArgs, primResTy) <- splitFunForallTy (primType primInfo)+  , TyConApp tupTcNm tupEls <- tyView primResTy+    -- XXX: Hardcoded for tuples+  , isTupleTyConLike tupTcNm+  , Just tupTc <- UniqMap.lookup tupTcNm tcm+  , [tupDc] <- tyConDataCons tupTc+  = Just $ MultiPrimInfo+    { mpi_primInfo = primInfo+    , mpi_resultDc = tupDc+    , mpi_resultTypes = tupEls }+multiPrimInfo _ _ = Nothing++-- | Does a term have a function type?+isFun :: TyConMap -> Term -> Bool+isFun m t = isFunTy m (inferCoreTypeOf m t)++-- | Does a term have a function or polymorphic type?+isPolyFun :: TyConMap -> Term -> Bool+isPolyFun m t = isPolyFunCoreTy m (inferCoreTypeOf m t)++-- | Is a term a recursive let-binding?+isLet :: Term -> Bool+isLet Let{} = True+isLet _ = False++-- | Is a term a variable reference?+isVar :: Term -> Bool+isVar (Var {}) = True+isVar _        = False++isLocalVar :: Term -> Bool+isLocalVar (Var v) = isLocalId v+isLocalVar _ = False++-- | Is a term a datatype constructor?+isCon :: Term -> Bool+isCon (Data {}) = True+isCon _         = False++-- | Is a term a primitive?+isPrim :: Term -> Bool+isPrim (Prim {}) = True+isPrim _         = False++-- | Is a term a tick?+isTick :: Term -> Bool+isTick Tick{} = True+isTick _ = False++-- | Is a term a cast?+isCast :: Term -> Bool+isCast (Cast {}) = True+isCast _         = False
+ src/Clash/Core/TermLiteral.hs view
@@ -0,0 +1,248 @@+{-|+Copyright   :  (C) 2019, Myrtle Software Ltd,+                   2021, QBayLogic B.V.+                   2022, Google Inc.+License     :  BSD2 (see the file LICENSE)+Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++Tools to convert a 'Term' into its "real" representation+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NamedFieldPuns #-}++--{-# OPTIONS_GHC -ddump-splices #-}++module Clash.Core.TermLiteral+  ( TermLiteral+  , showsTypePrec+  , showType+  , termToData+  , termToDataError+  , deriveTermLiteral+  ) where++import           Data.Bifunctor                  (bimap)+import           Data.Either                     (lefts)+import           Data.Proxy                      (Proxy(..))+import           Data.Text                       (Text)+import qualified Data.Text                       as Text+import           Data.Text.Extra                 (showt)+import qualified Data.Text.Internal              as Text+import qualified Data.Text.Array                 as Text+import qualified Data.Primitive.ByteArray        as BA+import           Data.Typeable                   (Typeable, typeRep)+import           GHC.Natural+import           GHC.Stack+import           GHC.TypeNats (KnownNat)+import           Text.Show.Pretty                (ppShow)++import           Clash.Annotations.SynthesisAttributes (Attr)+import           Clash.Core.DataCon              (DataCon(..))+import           Clash.Core.Literal+import           Clash.Core.Name                 (Name(..))+import           Clash.Core.Pretty               (showPpr)+import           Clash.Core.Term                 (Term(Literal, Data, Tick), collectArgs)+import           Clash.Promoted.Nat+import           Clash.Promoted.Nat.Unsafe+import           Clash.Sized.Index               (Index)+import           Clash.Sized.Vector              (Vec (Nil, Cons), fromList)+import qualified Clash.Util.Interpolate          as I+import qualified Clash.Verification.Internal     as Cv++import           Clash.Core.TermLiteral.TH++-- | Pretty print type @a@+showType :: TermLiteral a => Proxy a -> String+showType proxy = showsTypePrec 0 proxy ""++-- | Tools to deal with literals encoded as a 'Term'.+class TermLiteral a where+  -- | Convert 'Term' to the constant it represents. Will return an error if+  -- (one of the subterms) fail to translate.+  termToData+    :: HasCallStack+    => Term+    -- ^ Term to convert+    -> Either Term a+    -- ^ 'Left' indicates a failure, containing the (sub)term that failed to+    -- translate. 'Right' indicates a success.++  -- | Pretty print the type of a term (for error messages). Its default implementation+  -- uses 'Typeable' to print the type. Note that this method is there to allow+  -- an instance for 'SNat' to exist (and other GADTs imposing+  -- t'GHC.TypeNats.KnownNat'). Without it, GHC would ask for a @KnownNat@+  -- constraint on the instance, which would defeat the purpose of it.+  showsTypePrec ::+    -- | The operator precedence of the enclosing context (a number from @0@ to+    -- @11@). Function application has precedence @10@. Used to determine whether+    -- the result should be wrapped in parentheses.+    Int ->+    -- | Proxy for a term whose type needs to be pretty printed+    Proxy a ->+    ShowS++  default showsTypePrec :: Typeable a => Int -> Proxy a -> ShowS+  showsTypePrec n _ = showsPrec n (typeRep (Proxy @a))++instance TermLiteral Term where+  termToData = pure++instance TermLiteral String where+  termToData (collectArgs -> (_, [Left (Literal (StringLiteral s))])) = Right s+  termToData t = Left t++instance TermLiteral Text where+  termToData (collectArgs -> (_, [Left (Literal (StringLiteral s))])) =+    Right (Text.pack s)+  termToData (collectArgs -> (_, [ Left (Literal (ByteArrayLiteral (BA.ByteArray ba)))+                                 , Left (Literal (IntLiteral off))+                                 , Left (Literal (IntLiteral len))])) =+    Right (Text.Text (Text.ByteArray ba) (fromInteger off) (fromInteger len))+  termToData t = Left t++instance KnownNat n => TermLiteral (Index n) where+  termToData t@(collectArgs -> (_, [_, _, Left (Literal (IntegerLiteral n))]))+    | n < 0 = Left t+    | n >= natToNum @n = Left t+    | otherwise = Right (fromInteger n)+  termToData t = Left t++instance TermLiteral Int where+  termToData (collectArgs -> (_, [Left (Literal (IntLiteral n))])) =+    Right (fromInteger n)+  termToData t = Left t++instance TermLiteral Word where+  termToData (collectArgs -> (_, [Left (Literal (WordLiteral n))])) =+    Right (fromInteger n)+  termToData t = Left t++instance TermLiteral Integer where+  termToData (Tick _ e) = termToData e+  termToData (Literal (IntegerLiteral n)) = Right n+  termToData (collectArgs -> (_, [Left (Literal (IntLiteral n))])) = Right n+  termToData (collectArgs -> (_, [Left (Literal (IntegerLiteral n))])) = Right n+  termToData t = Left t++instance TermLiteral Char where+  termToData (collectArgs -> (_, [Left (Literal (CharLiteral c))])) = Right c+  termToData t = Left t++instance TermLiteral Natural where+  termToData (Tick _ e) = termToData e+  termToData t@(Literal (NaturalLiteral n))+    | n < 0 = Left t+    | otherwise = Right (fromIntegral n)+  termToData (collectArgs -> (_, [Left (Literal (NaturalLiteral n))])) =+    Right (fromInteger n)+  termToData t = Left t++-- | Unsafe warning: If you use this instance in a monomorphic context (e.g.,+-- @TermLiteral (SNat 5)@), you need to make very sure that the term corresponds+-- to the literal. If you don't, there will be a mismatch between type level+-- variables and the proof carried in 'SNat's 'KnownNat'. Typical usage of this+-- instance will therefore leave the /n/ polymorphic.+--+instance TermLiteral (SNat n) where+  termToData = \case+    Tick _ e                   -> termToData e+    Literal (NaturalLiteral n) -> Right (unsafeSNat n)+    t                          -> Left t++  showsTypePrec n _+    -- We don't know the literal /n/ at this point. However, we can't simply put+    -- and /n/ here either, as it might collide with other type variables. To+    -- prevent confusion, we put an underscore. This is obviously "wrong", but+    -- good enough for error messages - the main purpose of this function.+    = showParen (n > 10) $ showString "SNat _"++instance (TermLiteral a, TermLiteral b) => TermLiteral (a, b) where+  termToData (collectArgs -> (_, lefts -> [a, b])) = do+    a' <- termToData a+    b' <- termToData b+    pure (a', b')+  termToData t = Left t++  showsTypePrec _ _ =+    -- XXX: We pass in 11 here, but should really be passing in 0. We never want+    --      any parentheses for fields in tuples. However, Typeable's show+    --      implementation does put parentheses around tuple fields - so we+    --      replicate that behavior here for ease of testing.+      showChar '('+    . showsTypePrec 11 (Proxy @a)+    . showString ","+    . showsTypePrec 11 (Proxy @b)+    . showChar ')'++instance (TermLiteral a, KnownNat n) => TermLiteral (Vec n a) where+  termToData term = do+    res <- fromList <$> go term+    -- Check whether length of list constructed in 'go' corresponds to the+    -- @KnownNat n@ we've been given+    case res of+      Nothing -> Left term+      Just v -> Right v+   where+    -- Construct a list from given term+    go t@(collectArgs -> (constr, args)) =+      case constr of+        Data (MkData{dcName=Name{nameOcc}})+          | nameOcc == showt 'Nil -> Right []+          | nameOcc == showt 'Cons ->+            case lefts args of+              [_gadtProof, c0, cs0] -> do+                c1 <- termToData @a c0+                cs1 <- go cs0+                Right (c1:cs1)+              _ -> Left t+        _ -> Left t++  showsTypePrec n _ =+    showParen (n > 10) $+        showString "Vec"+      . showChar ' '+      . showString (show (natToInteger @n))+      . showChar ' '+      . showsTypePrec 11 (Proxy @a)++deriveTermLiteral ''Bool+deriveTermLiteral ''Maybe+deriveTermLiteral ''Either+deriveTermLiteral ''Cv.RenderAs+deriveTermLiteral ''Cv.Assertion'+deriveTermLiteral ''Cv.Property'+deriveTermLiteral ''Attr++-- | Same as 'termToData', but returns printable error message if it couldn't+-- translate a term.+termToDataError :: forall a. TermLiteral a => Term -> Either String a+termToDataError term = bimap err id (termToData term)+ where+  -- XXX: If we put this construct in the quasiquoted part, it yields a parse+  --      error on some platforms. This is likely related to some older version+  --      of dependencies. In the interested of time yours truly just moved it+  --      outside of the quasiquoter.+  shownType = showType (Proxy @a)++  err failedTerm = [I.i|+    Failed to translate term to literal. Term that failed to translate:++      #{showPpr failedTerm}++    In its non-pretty-printed form:++      #{ppShow failedTerm}++    In the full term:++      #{showPpr term}++    While trying to interpret something to type:++      #{shownType}+  |]
+ src/Clash/Core/TermLiteral/TH.hs view
@@ -0,0 +1,223 @@+{-|+Copyright   :  (C) 2019, Myrtle Software Ltd,+                   2021, QBayLogic B.V.+                   2022, Google Inc+License     :  BSD2 (see the file LICENSE)+Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++Template Haskell utilities for "Clash.Core.TermLiteral".+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Core.TermLiteral.TH+  ( deriveTermToData+  , deriveShowsTypePrec+  , deriveTermLiteral+     -- Stop exporting @dcName'@  once `ghcide` stops type-checking expanded+     -- TH splices+  ,  dcName'+  ) where++import           Data.Either+import qualified Data.Text                       as Text+import           Data.List                       (intersperse)+import qualified Data.List.NonEmpty              as NE+import           Data.Proxy+import           Data.Maybe                      (isNothing)+import           Language.Haskell.TH.Syntax+import           Language.Haskell.TH.Lib         hiding (match)++import           Clash.Core.DataCon+import           Clash.Core.Term                 (collectArgs, Term(Data))+import           Clash.Core.Name                 (nameOcc)++-- Workaround for a strange GHC bug, where it complains about Subst only+-- existing as a boot file:+--+-- module Clash.Core.Subst cannot be linked; it is only available as a boot module+import Clash.Core.Subst ()++type CompatTyVarBndr = TyVarBndr ()++dcName' :: DataCon -> String+dcName' = Text.unpack . nameOcc . dcName++termToDataName :: Name+termToDataName =+  -- Note that we can't use a fully qualified name here: GHC disallows fully+  -- qualified names in instance function declarations.+  mkName "termToData"++showsTypePrecName :: Name+showsTypePrecName =+  -- Note that we can't use a fully qualified name here: GHC disallows fully+  -- qualified names in instance function declarations.+  mkName "showsTypePrec"++termLiteralName :: Name+termLiteralName = mkName "Clash.Core.TermLiteral.TermLiteral"++-- | Extracts variable names from a 'TyVarBndr'.+typeVarName :: CompatTyVarBndr -> Q (Name, Maybe Type)+typeVarName = \case+  PlainTV typVarName ()        -> pure (typVarName, Nothing)+  KindedTV typVarName () StarT -> pure (typVarName, Nothing)+  KindedTV typVarName () kind  -> pure (typVarName, Just kind)++-- | Derive a t'Clash.Core.TermLiteral.TermLiteral' instance for given type+deriveTermLiteral :: Name -> Q [Dec]+deriveTermLiteral typName = do+  TyConI (DataD _ _ typeVars _ _ _) <- reify typName+#if MIN_VERSION_template_haskell(2,21,0)+  typeVarNames <- mapM (typeVarName . fmap (const ())) typeVars+#else+  typeVarNames <- mapM typeVarName typeVars+#endif+  showsTypePrec <- deriveShowsTypePrec typName+  termToDataBody <- deriveTermToData typName+  let+    termToData = FunD termToDataName [Clause [] (NormalB termToDataBody) []]+    innerInstanceType = foldl AppT (ConT typName) (map (VarT . fst) typeVarNames)+    instanceType = ConT termLiteralName `AppT` innerInstanceType+    constraint typVarName = [t| $(conT termLiteralName) $(varT typVarName) |]+  constraints <- mapM (constraint . fst) (filter (isNothing . snd) typeVarNames)+  pure $ [InstanceD Nothing constraints instanceType [showsTypePrec, termToData]]++-- | For 'Maybe', constructs:+--+-- > showsTypePrec n _+-- >   = let+-- >       showSpace = showChar ' '+-- >       precCalls = [showsTypePrec 11 (Proxy @a)]+-- >       interspersedPrecCalls = intersperse showSpace precCalls+-- >       showType = foldl (.) (showString "Maybe") (showSpace : interspersedPrecCalls)+-- >     in+-- >       showParen (n > 10) showType+--+deriveShowsTypePrec :: Name -> Q Dec+deriveShowsTypePrec typName = do+  TyConI (DataD _ _ typeVars _ _ _) <- reify typName+#if MIN_VERSION_template_haskell(2,21,0)+  typeVarNames <- mapM (typeVarName . fmap (const ())) typeVars+#else+  typeVarNames <- mapM typeVarName typeVars+#endif+  showTypeBody <- mkShowTypeBody typeVarNames+  pure (FunD showsTypePrecName [Clause [VarP nName, WildP] (NormalB showTypeBody) []])+ where+  showTypeName = [| showString $(litE (StringL (nameBase typName))) |]++  -- Constructs:+  --+  -- > showsTypePrec 11 (Proxy @a)+  --+  -- where the 'a' is given as an argument. The surrounding operator precedence+  -- is set to indicate "function" application. I.e., it instructs the call to+  -- wrap the type string in parentheses.+  --+  mkTypePrecCall = \case+    (typVarName, Nothing) ->+      [| $(varE showsTypePrecName) 11 (Proxy @($(varT typVarName))) |]+    (_, Just _) ->+      -- XXX: Not sure how to deal with non-Type type variables so we do the dumb+      --      thing and insert an underscore.+      [| showString "_" |]++  -- Constructs:+  --+  -- > showString "Maybe" . showChar ' ' . showsTypePrec 11 (Proxy @a)+  --+  -- This is wrapped in an if-statement wrapping the result in parentheses if the+  -- incoming prec is more than 10 (function application).+  --+  mkShowTypeBody :: [(Name, Maybe Type)] -> Q Exp+  mkShowTypeBody typeVarNames =+    case typeVarNames of+      [] ->+        -- We seq on `n` here to prevent _unused variable_ warnings. This is a+        -- bit of a hack (the real solution would be to selectively pattern+        -- match).+        [| $(varE nName) `seq` $(showTypeName) |]+      _  -> [|+        let+          showSpace = showChar ' '+          precCalls = $(listE (map mkTypePrecCall typeVarNames))+          interspersedPrecCalls = intersperse showSpace precCalls+          showType = foldl (.) $(showTypeName) (showSpace : interspersedPrecCalls)+        in+          showParen ($(varE nName) > 10) showType+       |]++  nName = mkName "n"++deriveTermToData :: Name -> Q Exp+deriveTermToData typName = do+  TyConI (DataD _ _ _ _ constrs _) <- reify typName+  pure (deriveTermToData1 (map toConstr' constrs))+ where+  toConstr' (NormalC cName fields) = (cName, length fields)+  toConstr' (RecC cName fields) = (cName, length fields)+  toConstr' c = error $ "Unexpected constructor: " ++ show c++deriveTermToData1 :: [(Name, Int)] -> Exp+deriveTermToData1 constrs =+  LamCaseE+    [ Match pat (NormalB (if null args then theCase else LetE args theCase)) []+    , Match (VarP termName) (NormalB ((ConE 'Left `AppE` VarE termName))) []++    ]+ where+  nArgs = maximum (map snd constrs)++  args :: [Dec]+  args = zipWith (\n nm -> ValD (VarP nm) (NormalB (arg (toInteger n))) []) [0..nArgs-1] (NE.toList argNames)+  arg n = UInfixE (VarE argsName) (VarE '(!!)) (LitE (IntegerL n))++  -- case nm of {"ConstrOne" -> ConstOne <$> termToData arg0; "ConstrTwo" -> ...}+  theCase :: Exp+  theCase =+    CaseE+      (VarE nameName)+      (map match constrs ++ [emptyMatch])++  emptyMatch = Match WildP (NormalB (ConE 'Left `AppE` VarE termName)) []++  match :: (Name, Int) -> Match+  match (cName, nFields) =+    Match (LitP (StringL (show cName))) (NormalB (mkCall cName nFields)) []++  mkCall :: Name -> Int -> Exp+  mkCall cName 0  = ConE 'Right `AppE` ConE cName+  mkCall cName 1 =+    UInfixE+      (ConE cName)+      (VarE '(<$>))+      (VarE termToDataName `AppE` VarE (NE.head argNames))+  mkCall cName nFields =+    foldl+      (\e aName ->+        UInfixE+          e+          (VarE '(<*>))+          (VarE termToDataName `AppE` VarE aName))+      (mkCall cName 1)+      (take (nFields-1) (NE.tail argNames))++  -- term@(collectArgs -> (Data (dcName' -> nm), args))+  pat :: Pat+  pat =+    AsP+      termName+      (ViewP+        (VarE 'collectArgs)+        (TupP [ ConP 'Data [] [ViewP (VarE 'dcName') (VarP nameName)]+              , ViewP+                 (VarE 'lefts)+                 (if nArgs == 0 then WildP else VarP argsName)]))++  termName = mkName "term"+  argsName = mkName "args"+  argNames = fmap (mkName . ("arg" <>) . show) (NE.iterate (+1) (0 :: Word))+  nameName = mkName "nm"
+ src/Clash/Core/TyCon.hs view
@@ -0,0 +1,156 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente+                     2021-2024, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Type Constructors in CoreHW+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Clash.Core.TyCon+  ( TyCon (..)+  , TyConName+  , TyConMap+  , AlgTyConRhs (..)+  , mkKindTyCon+  , isTupleTyConLike+  , isPrimTc+  , isNewTypeTc+  , isPromotedDc+  , tyConDataCons+  )+where++-- External Import+import Control.DeepSeq+import Data.Binary                            (Binary)+import Data.Function                          (on)+import qualified Data.Text as T+import GHC.Generics++-- Internal Imports+import Clash.Core.DataCon                     (DataCon)+import Clash.Core.Name+import {-# SOURCE #-} Clash.Core.Type         (Kind, Type)+import Clash.Core.Var                         (TyVar)+import Clash.Data.UniqMap (UniqMap)+import Clash.Unique++-- | Type Constructor+data TyCon+  -- | Algorithmic DataCons+  = AlgTyCon+  { tyConUniq   :: {-# UNPACK #-} !Unique+  , tyConName   :: !TyConName   -- ^ Name of the TyCon+  , tyConKind   :: !Kind        -- ^ Kind of the TyCon+  , tyConArity  :: !Int         -- ^ Number of type arguments+  , algTcRhs    :: !AlgTyConRhs -- ^ DataCon definitions+  , isClassTc   :: !Bool        -- ^ Is this a class dictionary?+  }+  | PromotedDataCon+  { tyConUniq   :: {-# UNPACK #-} !Unique -- invariant (same as dcUniq)+  , tyConName   :: !TyConName   -- ^ Name of the TyCon+  , tyConKind   :: !Kind        -- ^ Kind of the TyCon+  , tyConArity  :: !Int         -- ^ Number of type arguments+  , tyConData   :: !DataCon     -- ^ DataCon which is promoted+  }+  -- | Function TyCons (e.g. type families)+  | FunTyCon+  { tyConUniq   :: {-# UNPACK #-} !Unique+  , tyConName   :: !TyConName      -- ^ Name of the TyCon+  , tyConKind   :: !Kind           -- ^ Kind of the TyCon+  , tyConArity  :: !Int            -- ^ Number of type arguments+  , tyConSubst  :: [([Type],Type)] -- ^ List of: ([LHS match types], RHS type)+  }+  -- | Primitive TyCons+  | PrimTyCon+  { tyConUniq    :: {-# UNPACK #-} !Unique+  , tyConName    :: !TyConName  -- ^ Name of the TyCon+  , tyConKind    :: !Kind       -- ^ Kind of the TyCon+  , tyConArity   :: !Int        -- ^ Number of type arguments+  }+  deriving (Show,Generic,NFData,Binary)++{-+instance Show TyCon where+  show (AlgTyCon       {tyConName = n}) = "AlgTyCon: " ++ show n+  show (FunTyCon       {tyConName = n}) = "FunTyCon: " ++ show n+  show (PrimTyCon      {tyConName = n}) = "PrimTyCon: " ++ show n+-}++instance Eq TyCon where+  (==) = (==) `on` tyConUniq+  (/=) = (/=) `on` tyConUniq++instance Uniquable TyCon where+  getUnique = tyConUniq+  setUnique tyCon u = tyCon {tyConUniq=u}++-- | TyCon reference+type TyConName = Name TyCon+type TyConMap  = UniqMap TyCon++-- | The RHS of an Algebraic Datatype+data AlgTyConRhs+  = DataTyCon+  { dataCons :: [DataCon]        -- ^ The DataCons of a TyCon+  }+  | NewTyCon+  { dataCon   :: !DataCon        -- ^ The newtype DataCon+  , ntEtadRhs :: ([TyVar],Type)  -- ^ The argument type of the newtype+                                 -- DataCon in eta-reduced form, which is+                                 -- just the representation of the TyCon.+                                 -- The TyName's are the type-variables from+                                 -- the corresponding TyCon.+  }+  deriving (Show,Generic,NFData,Binary)++-- | Create a Kind out of a TyConName+mkKindTyCon :: TyConName+            -> Kind+            -> TyCon+mkKindTyCon name kind+  = PrimTyCon (nameUniq name) name kind 0++-- | Does the TyCon look like a tuple TyCon+isTupleTyConLike :: TyConName -> Bool+isTupleTyConLike nm = tupleName (T.takeWhileEnd (/= '.') (nameOcc nm))+  where+    tupleName nm0+      | Just ('(', nm1) <- T.uncons nm0+      , Just (nm2, ')') <- T.unsnoc nm1+      = T.all (== ',') nm2+    tupleName _ =+      any (`T.isPrefixOf` (nameOcc nm)) $ map T.pack+        [ "GHC.Tuple.Prim.Tuple"+        , "GHC.Tuple.Tuple"+        ]++-- | Get the DataCons belonging to a TyCon+tyConDataCons :: TyCon -> [DataCon]+tyConDataCons (AlgTyCon {algTcRhs = DataTyCon { dataCons = cons}}) = cons+tyConDataCons (AlgTyCon {algTcRhs = NewTyCon  { dataCon  = con }}) = [con]+tyConDataCons _                                                    = []++isPrimTc+  :: TyCon+  -> Bool+isPrimTc PrimTyCon{} = True+isPrimTc _ = False++isNewTypeTc+  :: TyCon+  -> Bool+isNewTypeTc (AlgTyCon {algTcRhs = NewTyCon {}}) = True+isNewTypeTc _ = False++isPromotedDc+  :: TyCon+  -> Bool+isPromotedDc PromotedDataCon{} = True+isPromotedDc _ = False
+ src/Clash/Core/TyCon.hs-boot view
@@ -0,0 +1,12 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++module Clash.Core.TyCon where++import Clash.Core.Name (Name)++data TyCon+type TyConName = Name TyCon
+ src/Clash/Core/Type.hs view
@@ -0,0 +1,748 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                     2016     , Myrtle Software Ltd,+                     2017     , Google Inc.+                     2021-2024, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Types in CoreHW+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++module Clash.Core.Type+  ( Type (..)+  , TypeView (..)+  , ConstTy (..)+  , LitTy (..)+  , Kind+  , KindOrType+  , KiName+  , TyName+  , TyVar+  , tyView+  , coreView+  , coreView1+  , mkTyConTy+  , mkFunTy+  , mkPolyFunTy+  , mkTyConApp+  , splitFunTy+  , splitFunTys+  , splitFunForallTy+  , splitCoreFunForallTy+  , splitTyConAppM+  , isPolyFunTy+  , isPolyFunCoreTy+  , isPolyTy+  , isTypeFamilyApplication+  , isFunTy+  , isClassTy+  , applyFunTy+  , findFunSubst+  , reduceTypeFamily+  , isIntegerTy+  , normalizeType+  , varAttrs+  , typeAttrs+  )+where++-- External import+import           Control.DeepSeq        as DS+import           Data.Binary            (Binary)+import           Data.Coerce            (coerce)+import           Data.Hashable          (Hashable (hashWithSalt))+#if !MIN_VERSION_base(4,20,0)+import           Data.List              (foldl')+#endif+import           Data.List.Extra        (splitAtList)+import           Data.Maybe             (isJust, mapMaybe)+import           Data.Text              (Text)+import           GHC.Base               (isTrue#,(==#))+import           GHC.Generics           (Generic(..))+import           GHC.Integer            (smallInteger)+import           GHC.Integer.Logarithms (integerLogBase#)+import           GHC.TypeLits           (type TypeError, ErrorMessage(Text, (:<>:)))+import           GHC.Base               (ord)+import           Data.Char              (chr)+import           Data.Maybe             (fromMaybe)+import           Data.Text.Extra        (showt)++-- GHC API+import           GHC.Builtin.Names+  (typeCharCmpTyFamNameKey, typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey,+   typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey)+import           GHC.Builtin.Names+  (integerTyConKey, typeNatAddTyFamNameKey, typeNatExpTyFamNameKey,+   typeNatMulTyFamNameKey, typeNatSubTyFamNameKey,+   typeNatCmpTyFamNameKey, ordLTDataConKey, ordEQDataConKey, ordGTDataConKey,+   typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey,+   typeNatDivTyFamNameKey, typeNatModTyFamNameKey)+import           GHC.Types.SrcLoc       (wiredInSrcSpan)++-- Local imports+import           Clash.Annotations.SynthesisAttributes+import           Clash.Core.DataCon+import           Clash.Core.Name+import {-# SOURCE #-} Clash.Core.Subst+import           Clash.Core.TyCon+import           Clash.Core.Var+import qualified Clash.Data.UniqMap as UniqMap+import           Clash.Unique (fromGhcUnique)+import           Clash.Util++varAttrs :: Var a -> [Attr Text]+varAttrs t@(TyVar {}) =+  error $ $(curLoc) ++ "Unexpected argument: " ++ show t++varAttrs (Id _ _ ty _) =+  case ty of+    AnnType attrs _typ -> attrs+    _                  -> []+++-- | Types in CoreHW: function and polymorphic types+data Type+  = VarTy    !TyVar             -- ^ Type variable+  | ConstTy  !ConstTy           -- ^ Type constant+  | ForAllTy !TyVar !Type       -- ^ Polymorphic Type+  | AppTy    !Type !Type        -- ^ Type Application+  | LitTy    !LitTy             -- ^ Type literal+  | AnnType  [Attr Text] !Type  -- ^ Annotated type, see Clash.Annotations.SynthesisAttributes+  deriving (Show, Generic, NFData, Binary)++instance TypeError (+        'Text "A broken implementation of Hashable Type has been "+  ':<>: 'Text "removed in Clash 1.4.7. If this is an issue for you, please submit "+  ':<>: 'Text "an issue report at https://github.com/clash-lang/clash-compiler/issues."+  ) => Hashable Type where+    hashWithSalt = error "Type.hashWithSalt: unreachable"++-- | An easier view on types+data TypeView+  = FunTy    !Type  !Type      -- ^ Function type+  | TyConApp !TyConName [Type] -- ^ Applied TyCon+  | OtherType !Type            -- ^ Neither of the above+  deriving Show++-- | Type Constants+data ConstTy+  = TyCon !TyConName -- ^ TyCon type+  | Arrow            -- ^ Function type+  deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary)++-- | Literal Types+data LitTy+  = NumTy !Integer+  | SymTy !String+  | CharTy !Char+  deriving (Eq,Ord,Show,Generic,NFData,Hashable,Binary)++-- | The level above types+type Kind       = Type+-- | Either a Kind or a Type+type KindOrType = Type++-- | Reference to a Type+type TyName     = Name Type+-- | Reference to a Kind+type KiName     = Name Kind++-- TODO+--+-- tyView could be smarter about what it gives back. Since it traverses the+-- arguments to make a `TyConApp`, if the leftmost innermost type isn't a+-- TyCon it could still return a list of applied types to save a later call to+-- something like splitFunForallTy.+--+-- It could / should also look through annotations instead of just returning+-- the original type wrapped in OtherType.++-- | An easier view on types+--+-- Note [Arrow arguments]+--+-- Clash' Arrow type can either have 2 or 4 arguments, depending on who created it.+-- By default it has two arguments: the argument type of a function, and the result+-- type of a function.+--+-- So when do we have 4 arguments? When in Haskell/GHC land the arrow was+-- unsaturated. This can happen in instance heads, or in the eta-reduced+-- representation of newtypes. So what are those additional 2 arguments compared to+-- the "normal" function type? They're the kinds of argument and result type.+tyView :: Type -> TypeView+-- XXX: this is a manually unrolled version of:+--+-- tyView tOrig = go [] tOrig+--  where+--   go args t = case t of+--     ConstTy c -> case c of+--       TyCon tc -> TyConApp tc args+--       Arrow -> case args of+--         (arg:res:rest) -> case rest of+--           [] -> FunTy arg res+--           [arg1,res1] -> FunTy arg1 res1+--           _ -> OtherType tOrig+--     AppTy l r -> go (r:args) l+--     _ -> OtherType tOrig+--+-- To get a FunTy without recursive calls. Because it is called so often this+-- saves us 5-10% runtime.+tyView tOrig = case tOrig of+  ConstTy c -> case c of+    TyCon tc -> TyConApp tc []+    _ -> OtherType tOrig+  AppTy l0 res -> case l0 of+    ConstTy (TyCon tc) -> TyConApp tc [res]+    AppTy l1 arg -> case l1 of+      ConstTy Arrow -> FunTy arg res+      ConstTy (TyCon tc) -> TyConApp tc [arg,res]+      AppTy l2 resK -> case l2 of+        ConstTy (TyCon tc) -> TyConApp tc [resK,arg,res]+        AppTy l3 argK -> case l3 of+          ConstTy (TyCon tc) -> TyConApp tc [argK,resK,arg,res]+          ConstTy Arrow -> FunTy arg res -- See Note [Arrow arguments]+          _ -> case go [argK,resK,arg,res] l3 of+            (ConstTy (TyCon tc),args)+              -> TyConApp tc args+            _ -> OtherType tOrig+        _ -> OtherType tOrig+      _ -> OtherType tOrig+    _ -> OtherType tOrig+  _ -> OtherType tOrig+ where+  go args (AppTy ty1 ty2) = go (ty2:args) ty1+  go args t1              = (t1,args)++-- | A view on types in which newtypes are transparent, the Signal type is+-- transparent, and type functions are evaluated to WHNF (when possible).+--+-- Strips away ALL layers. If no layers are found it returns the given type.+coreView :: TyConMap -> Type -> Type+coreView tcm ty =+  case coreView1 tcm ty of+    Nothing  -> ty+    Just ty' -> coreView tcm ty'++-- | A view on types in which newtypes are transparent, the Signal type is+-- transparent, and type functions are evaluated to WHNF (when possible).+--+-- Only strips away one "layer".+coreView1 :: TyConMap -> Type -> Maybe Type+coreView1 tcMap ty = case tyView ty of+  TyConApp tcNm args+    | nameOcc tcNm == "Clash.Signal.BiSignal.BiSignalIn"+    , [_,_,_,elTy] <- args+    -> Just elTy+    | nameOcc tcNm == "Clash.Signal.BiSignal.BiSignalOut"+    , [_,_,_,elTy] <- args+    -> Just elTy+    | nameOcc tcNm == "Clash.Signal.Internal.Signal"+    , [_,elTy] <- args+    -> Just elTy+    | otherwise+    -> case UniqMap.find tcNm tcMap of+         AlgTyCon {algTcRhs = (NewTyCon _ nt)}+           -> newTyConInstRhs nt args+         _ -> reduceTypeFamily tcMap ty+  OtherType (AnnType _ ty') -> coreView1 tcMap ty'+  _ -> Nothing++-- | Instantiate and Apply the RHS/Original of a NewType with the given+-- list of argument types+--+-- Returns /Nothing/ when under-applied+newTyConInstRhs :: ([TyVar],Type) -> [Type] -> Maybe Type+newTyConInstRhs (tvs,ty) tys+    | length tvs <= length tys+    = Just (foldl' AppTy (substTyWith tvs tys1 ty) tys2)+    | otherwise+    = Nothing+  where+    (tys1, tys2) = splitAtList tvs tys++-- | Make a function type of an argument and result type+mkFunTy :: Type -> Type -> Type+mkFunTy t1 = AppTy (AppTy (ConstTy Arrow) t1)++-- | Make a TyCon Application out of a TyCon and a list of argument types+mkTyConApp :: TyConName -> [Type] -> Type+mkTyConApp tc = foldl AppTy (ConstTy $ TyCon tc)++-- | Make a Type out of a TyCon+mkTyConTy :: TyConName -> Type+mkTyConTy ty = ConstTy $ TyCon ty++-- | Split a TyCon Application in a TyCon and its arguments+splitTyConAppM :: Type+               -> Maybe (TyConName,[Type])+splitTyConAppM (tyView -> TyConApp tc args) = Just (tc,args)+splitTyConAppM _                            = Nothing++-- | Is a type polymorphic?+isPolyTy :: Type -> Bool+isPolyTy (ForAllTy _ _)          = True+isPolyTy (tyView -> FunTy _ res) = isPolyTy res+isPolyTy _                       = False++-- | Split a function type in an argument and result type+splitFunTy :: TyConMap+           -> Type+           -> Maybe (Type, Type)+splitFunTy m (coreView1 m -> Just ty)  = splitFunTy m ty+splitFunTy _ (tyView -> FunTy arg res) = Just (arg,res)+splitFunTy _ _ = Nothing++splitFunTys :: TyConMap+            -> Type+            -> ([Type],Type)+splitFunTys m ty = go [] ty ty+  where+    go args orig_ty (coreView1 m -> Just ty') = go args orig_ty ty'+    go args _       (tyView -> FunTy arg res) = go (arg:args) res res+    go args orig_ty _                         = (reverse args, orig_ty)++-- | Split a poly-function type in a: list of type-binders and argument types,+-- and the result type+splitFunForallTy :: Type+                 -> ([Either TyVar Type],Type)+splitFunForallTy = go []+  where+    go args (ForAllTy tv ty)          = go (Left tv:args) ty+    go args (tyView -> FunTy arg res) = go (Right arg:args) res+    go args ty                        = (reverse args,ty)++-- | Make a polymorphic function type out of a result type and a list of+-- quantifiers and function argument types+mkPolyFunTy+  :: Type+  -- ^ Result type+  -> [Either TyVar Type]+  -- ^ List of quantifiers and function argument types+  -> Type+mkPolyFunTy = foldr (either ForAllTy mkFunTy)++-- | Split a poly-function type in a: list of type-binders and argument types,+-- and the result type. Looks through 'Signal' and type functions.+splitCoreFunForallTy :: TyConMap+                     -> Type+                     -> ([Either TyVar Type], Type)+splitCoreFunForallTy tcm ty = go [] ty ty+  where+    go args orig_ty (coreView1 tcm -> Just ty') = go args orig_ty ty'+    go args _       (ForAllTy tv res)           = go (Left tv:args) res res+    go args _       (tyView -> FunTy arg res)   = go (Right arg:args) res res+    go args orig_ty _                           = (reverse args,orig_ty)++-- | Is a type a polymorphic or function type?+isPolyFunTy :: Type+            -> Bool+isPolyFunTy = not . null . fst . splitFunForallTy++-- | Is a type a polymorphic or function type under 'coreView1'?+isPolyFunCoreTy :: TyConMap+                -> Type+                -> Bool+isPolyFunCoreTy m (coreView1 m -> Just ty) = isPolyFunCoreTy m ty+isPolyFunCoreTy _ ty = case tyView ty of+  FunTy _ _ -> True+  OtherType (ForAllTy _ _) -> True+  _ -> False++-- | Extract attributes from type. Will return an empty list if this is an+-- AnnType with an empty list AND if this is not an AnnType at all.+typeAttrs :: Type -> [Attr Text]+typeAttrs (AnnType attrs _typ) = attrs+typeAttrs _                    = []++-- | Is a type a function type?+isFunTy :: TyConMap+        -> Type+        -> Bool+isFunTy m = isJust . splitFunTy m++-- | Apply a function type to an argument type and get the result type+applyFunTy :: TyConMap+           -> Type+           -> Type+           -> Type+applyFunTy m (coreView1 m -> Just ty)   arg = applyFunTy m ty arg+applyFunTy _ (tyView -> FunTy _ resTy) _    = resTy+applyFunTy _ _ _ = error $ $(curLoc) ++ "Report as bug: not a FunTy"++-- Type function substitutions++-- Given a set of type functions, and list of argument types, get the first+-- type function that matches, and return its substituted RHS type.+findFunSubst :: TyConMap -> [([Type],Type)] -> [Type] -> Maybe Type+findFunSubst _   [] _ = Nothing+findFunSubst tcm (tcSubst:rest) args = case funSubsts tcm tcSubst args of+  Just ty -> Just ty+  Nothing -> findFunSubst tcm rest args++-- Given a ([LHS match type], RHS type) representing a type function, and+-- a set of applied types. Match LHS with args, and when successful, return+-- a substituted RHS+funSubsts :: TyConMap -> ([Type],Type) -> [Type] -> Maybe Type+funSubsts tcm (tcSubstLhs,tcSubstRhs) args = do+  let (funArgs,remainder) = zipAtLeast tcSubstLhs args+  tySubts <- foldl' (funSubst tcm) (Just []) funArgs+  let tyRhs = uncurry substTyWith (unzip tySubts) tcSubstRhs+  -- Type functions can return higher-kinded types+  case remainder of+    []    -> return tyRhs+    -- So don't forget to apply the arguments not consumed by the type+    -- function application!+    --+    -- Forgetting leads to: #232+    args' -> return (foldl' AppTy tyRhs args')+  where+    zipAtLeast [] ys = ([],ys)+    zipAtLeast _  [] = error "Under-applied type family"+    zipAtLeast (x:xs) (y:ys) =+      let (zs,remainder) = zipAtLeast xs ys+       in ((x,y):zs,remainder)++-- Given a LHS matching type, and a RHS to-match type, check if LHS and RHS+-- are a match. If they do match, and the LHS is a variable, return a+-- substitution+funSubst+  :: TyConMap+  -> Maybe [(TyVar,Type)]+  -> (Type,Type)+  -> Maybe [(TyVar,Type)]+funSubst _   Nothing  = const Nothing+funSubst tcm (Just s) = uncurry go+  where+    -- AnnType cannot be matched in type-families within regular GHC (as they+    -- are type synonyms) so it is fine to skip over them here.+    go (AnnType _ t1) t2 = go t1 t2++    go (VarTy nmF) ty = case lookup nmF s of+      Nothing -> Just ((nmF,ty):s)+      -- Given, for example, the type family definition:+      --+      -- > type family Max x y where+      -- >   Max 0 b = b+      -- >   Max a 0 = a+      -- >   Max n n = n+      -- >   Max a b = If (a <=? b) b a+      --+      -- Then `Max 4 8` matches against the 4th clause.+      --+      -- So this is why, whenever we match against a type variable, we first+      -- check if there is already a substitution defined for this type variable,+      -- and if so, the applied type, and the type in the substitution should match.+      Just ty' | ty' `aeqType` ty -> Just s+      _ -> Nothing++    -- Only look through annotations in RHS after the VarTy case, so we can+    -- preserve annotations in the substitution created by the VarTy case above+    go t1 (AnnType _ t2) = go t1 t2++    -- [Note] funSubst FunTy+    --+    -- Whenever type classes have associated types whose instances 'map' to+    -- functions, we try to find substitutions in the LHS and RHS of these+    -- (type-level) functions. Because we use @funSubst@ recursively, we+    -- implicitly check if these functions are of the same arity and match+    -- in the first place. An example of such a construct:+    --+    --   class Example p where+    --     type AB p+    --+    --   instance Example (a -> a) where+    --     type AB (a -> a) = a+    --+    -- In the given example, we would find two substitutions. For example, when+    -- matching against `Char -> Char` we'd find a duplicate `a -> Char`. We+    -- can't think of any (type-checking) cases where these mappings would map+    -- to different types, so this is OK for our purposes.+    go (AppTy a1 r1) (AppTy a2 r2) = do+      s1 <- funSubst tcm (Just s) (a1, a2)+      funSubst tcm (Just s1)+                   ( r1+                   , argView tcm r2 -- See [Note: Eager type families]+                   )++    go (ConstTy c1) (ConstTy c2)+      | c1 == c2 = Just s++    go (LitTy l1) (LitTy l2)+      | l1 == l2 = Just s++    go _ _ = Nothing++{- [Note: Eager type families]++I don't know whether type families are evaluated strictly or lazily, but since+type families do not reduce on stuck argument, we assume strictly.+-}++reduceTypeFamily :: TyConMap -> Type -> Maybe Type+reduceTypeFamily tcm (tyView -> TyConApp tc tys)+  | nameUniq tc == fromGhcUnique typeNatAddTyFamNameKey+  = case mapMaybe (litView tcm) tys of+      [i1,i2] -> Just (LitTy (NumTy (i1 + i2)))+      _ -> Nothing++  | nameUniq tc == fromGhcUnique typeNatMulTyFamNameKey+  = case mapMaybe (litView tcm) tys of+      [i1, i2] -> Just (LitTy (NumTy (i1 * i2)))+      _ -> Nothing++  | nameUniq tc == fromGhcUnique typeNatExpTyFamNameKey+  = case mapMaybe (litView tcm) tys of+      [i1, i2] -> Just (LitTy (NumTy (i1 ^ i2)))+      _ -> Nothing++  | nameUniq tc == fromGhcUnique typeNatSubTyFamNameKey+  = case mapMaybe (litView tcm) tys of+      [i1, i2]+        | let z = i1 - i2+        , z >= 0+        -> Just (LitTy (NumTy z))+      _ -> Nothing++  | nameUniq tc == fromGhcUnique typeNatCmpTyFamNameKey -- "GHC.TypeNats.CmpNat"+  = case mapMaybe (litView tcm) tys of+      [i1, i2] ->+        Just $ ConstTy $ TyCon $+          case compare i1 i2 of+            LT -> Name User "GHC.Types.LT"+                    (fromGhcUnique ordLTDataConKey) wiredInSrcSpan+            EQ -> Name User "GHC.Types.EQ"+                    (fromGhcUnique ordEQDataConKey) wiredInSrcSpan+            GT -> Name User "GHC.Types.GT"+                    (fromGhcUnique ordGTDataConKey) wiredInSrcSpan+      _ -> Nothing++  | nameUniq tc == fromGhcUnique typeSymbolCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol"+  = case mapMaybe (symLitView tcm) tys of+      [s1, s2] ->+        Just $ ConstTy $ TyCon $+          case compare s1 s2 of+            LT -> Name User "GHC.Types.LT"+                    (fromGhcUnique ordLTDataConKey) wiredInSrcSpan+            EQ -> Name User "GHC.Types.EQ"+                    (fromGhcUnique ordEQDataConKey) wiredInSrcSpan+            GT -> Name User "GHC.Types.GT"+                    (fromGhcUnique ordGTDataConKey) wiredInSrcSpan+      _ -> Nothing++  | nameUniq tc == fromGhcUnique typeCharCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol"+  = case mapMaybe (charLitView tcm) tys of+      [s1, s2] ->+        Just $ ConstTy $ TyCon $+          case compare s1 s2 of+            LT -> Name User (showt 'LT)+                    (fromGhcUnique ordLTDataConKey) wiredInSrcSpan+            EQ -> Name User (showt 'EQ)+                    (fromGhcUnique ordEQDataConKey) wiredInSrcSpan+            GT -> Name User (showt 'GT)+                    (fromGhcUnique ordGTDataConKey) wiredInSrcSpan+      _ -> Nothing++  | nameUniq tc == fromGhcUnique typeConsSymbolTyFamNameKey -- ConsSymbol+  , [c0, s0] <- tys+  , Just c1 <- charLitView tcm c0+  , Just s1 <- symLitView tcm s0+  = Just (LitTy (SymTy (c1:s1)))++  | nameUniq tc == fromGhcUnique typeUnconsSymbolTyFamNameKey -- UnconsSymbol+  , [s1] <- mapMaybe (symLitView tcm) tys+  = fromMaybe (error "reduceTypeFamily: cannot construct UnconsSymbol result") $ do+      FunTyCon {tyConKind = tck} <- UniqMap.lookup tc tcm+      TyConApp maybeTcNm [tupTcApp] <- pure (tyView (snd (splitFunTys tcm tck)))+      maybeTc <- UniqMap.lookup maybeTcNm tcm+      [nothingTc,justTc] <- pure (map (coerce . dcName) (tyConDataCons maybeTc))+      TyConApp tupTcNm [charTy,symbolTy] <- pure (tyView tupTcApp)+      tupTc <- UniqMap.lookup tupTcNm tcm+      [tupDc] <- pure (map (coerce . dcName) (tyConDataCons tupTc))+      case s1 of+        [] ->+          pure (Just (mkTyConApp nothingTc [tupTcApp]))+        (c:cs) ->+          let tup = mkTyConApp tupDc+                      [charTy,symbolTy,LitTy (CharTy c),LitTy (SymTy cs)]+           in pure (Just (mkTyConApp justTc [tupTcApp,tup]))++  | nameUniq tc == fromGhcUnique typeCharToNatTyFamNameKey -- CharToNat+  , [c1] <- mapMaybe (charLitView tcm) tys+  = Just (LitTy (NumTy (fromIntegral (ord c1))))++  | nameUniq tc == fromGhcUnique typeNatToCharTyFamNameKey -- NatToChar+  , [n1] <- mapMaybe (litView tcm) tys+  = Just (LitTy (CharTy (chr (fromInteger n1))))++  | nameUniq tc == fromGhcUnique typeSymbolAppendFamNameKey  -- GHC.TypeLits.AppendSymbol"+  = case mapMaybe (symLitView tcm) tys of+      [s1, s2] ->+        Just (LitTy (SymTy (s1 ++ s2)))+      _ -> Nothing++  | nameOcc tc `elem` ["GHC.TypeLits.Extra.FLog", "GHC.TypeNats.FLog"]+  = case mapMaybe (litView tcm) tys of+      [i1, i2]+        | i1 > 1+        , i2 > 0+        -> Just (LitTy (NumTy (smallInteger (integerLogBase# i1 i2))))+      _ -> Nothing+++  | nameOcc tc `elem` ["GHC.TypeLits.Extra.CLog", "GHC.TypeNats.CLog"]+  = case mapMaybe (litView tcm) tys of+      [i1, i2]+        | Just k <- clogBase i1 i2+        -> Just (LitTy (NumTy (toInteger k)))+      _ -> Nothing++  | nameOcc tc `elem` ["GHC.TypeLits.Extra.Log", "GHC.TypeNats.Log"]+  = case mapMaybe (litView tcm) tys of+      [i1, i2]+        | i1 > 1+        , i2 > 0+        -> if i2 == 1+           then Just (LitTy (NumTy 0))+           else let z1 = integerLogBase# i1 i2+                    z2 = integerLogBase# i1 (i2-1)+                in  if isTrue# (z1 ==# z2)+                        then Nothing+                        else Just (LitTy (NumTy (smallInteger z1)))+      _ -> Nothing+++  | nameOcc tc `elem` ["GHC.TypeLits.Extra.GCD", "GHC.TypeNats.GCD"]+  = case mapMaybe (litView tcm) tys of+      [i1, i2] -> Just (LitTy (NumTy (i1 `gcd` i2)))+      _ -> Nothing++  | nameOcc tc `elem` ["GHC.TypeLits.Extra.LCM", "GHC.TypeNats.LCM"]+  = case  mapMaybe (litView tcm) tys of+      [i1, i2] -> Just (LitTy (NumTy (i1 `lcm` i2)))+      _ -> Nothing++  | nameOcc tc `elem` ["GHC.TypeLits.Extra.Div"]+  = case mapMaybe (litView tcm) tys of+      [i1, i2]+        | i2 > 0+        -> Just (LitTy (NumTy (i1 `div` i2)))+      _ -> Nothing++  | nameOcc tc `elem` ["GHC.TypeLits.Extra.Mod"]+  = case mapMaybe (litView tcm) tys of+      [i1, i2]+        | i2 > 0+        -> Just (LitTy (NumTy (i1 `mod` i2)))+      _ -> Nothing++  | nameUniq tc == fromGhcUnique typeNatDivTyFamNameKey+  = case mapMaybe (litView tcm) tys of+      [i1, i2]+        | i2 > 0+        -> Just (LitTy (NumTy (i1 `div` i2)))+      _ -> Nothing++  | nameUniq tc == fromGhcUnique typeNatModTyFamNameKey+  = case mapMaybe (litView tcm) tys of+      [i1, i2]+        | i2 > 0+        -> Just (LitTy (NumTy (i1 `mod` i2)))+      _ -> Nothing++  | Just (FunTyCon {tyConSubst = tcSubst}) <- UniqMap.lookup tc tcm+  = let -- See [Note: Eager type families]+        tysR = map (argView tcm) tys+     in findFunSubst tcm tcSubst tysR++reduceTypeFamily _ _ = Nothing++-- |+isTypeFamilyApplication ::  TyConMap -> Type -> Bool+isTypeFamilyApplication tcm (tyView -> TyConApp tcNm _args)+  | Just (FunTyCon {}) <- UniqMap.lookup tcNm tcm = True+isTypeFamilyApplication _tcm _type = False++argView :: TyConMap -> Type -> Type+argView m t = case reduceTypeFamily m t of+  Nothing -> t+  Just tR -> argView m tR++litView :: TyConMap -> Type -> Maybe Integer+litView _ (LitTy (NumTy i))                = Just i+litView m (reduceTypeFamily m -> Just ty') = litView m ty'+litView _ _ = Nothing++symLitView :: TyConMap -> Type -> Maybe String+symLitView _ (LitTy (SymTy s))                = Just s+symLitView m (reduceTypeFamily m -> Just ty') = symLitView m ty'+symLitView _ _ = Nothing++charLitView :: TyConMap -> Type -> Maybe Char+charLitView _ (LitTy (CharTy c)) = Just c+charLitView m (reduceTypeFamily m -> Just t) = charLitView m t+charLitView _ _ = Nothing++isIntegerTy :: Type -> Bool+isIntegerTy (ConstTy (TyCon nm)) = nameUniq nm == fromGhcUnique integerTyConKey+isIntegerTy _ = False++-- | Normalize a type, looking through Signals and newtypes+--+-- For example: @Signal a (Vec (6-1) (Unsigned (3+1)))@ normalizes to @Vec 5 (Unsigned 4)@+normalizeType :: TyConMap -> Type -> Type+normalizeType tcMap = go+  where+  go ty = case tyView ty of+    TyConApp tcNm args+      -- These Clash types are implemented with newtypes.+      -- We need to keep these newtypes because they define the width of the numbers.+      | nameOcc tcNm == "Clash.Sized.Internal.BitVector.Bit" ||+        nameOcc tcNm == "Clash.Sized.Internal.BitVector.BitVector" ||+        nameOcc tcNm == "Clash.Sized.Internal.Index.Index"         ||+        nameOcc tcNm == "Clash.Sized.Internal.Signed.Signed"       ||+        nameOcc tcNm == "Clash.Sized.Internal.Unsigned.Unsigned"+      -> mkTyConApp tcNm (map go args)+      | otherwise+      -> case UniqMap.find tcNm tcMap of+          AlgTyCon {algTcRhs = (NewTyCon _ nt)}+             -> case newTyConInstRhs nt args of+                  Just ty' -> go ty'+                  Nothing  -> ty+          _ ->+             let args' = map go args+                 ty' = mkTyConApp tcNm args'+             in case reduceTypeFamily tcMap ty' of+               -- TODO Instead of recursing here, reduceTypeFamily should+               -- ensure that if the result is a reducible type family it is+               -- also reduced. This would reduce traversals over a type.+               --+               -- It may be a good idea to keep reduceTypeFamily only reducing+               -- one family, and definiing reduceTypeFamilies to reduce all+               -- it encounters in one traversal.+               Just ty'' -> go ty''+               Nothing  -> ty'+    FunTy ty1 ty2 -> mkFunTy (go ty1) (go ty2)+    OtherType (ForAllTy tyvar ty')+      -> ForAllTy tyvar (go ty')+    _ -> ty++isClassTy+  :: TyConMap+  -> Type+  -> Bool+isClassTy tcm (tyView -> TyConApp tcNm _) =+  case UniqMap.lookup tcNm tcm of+    Just (AlgTyCon {isClassTc}) -> isClassTc+    _ -> False+isClassTy _ _ = False
+ src/Clash/Core/Type.hs-boot view
@@ -0,0 +1,32 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                          2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-missing-methods #-}++module Clash.Core.Type where++import Control.DeepSeq                  (NFData)+import Data.Binary                      (Binary)+import GHC.Generics                     (Generic)++import                Clash.Core.Name+import {-# SOURCE #-} Clash.Core.TyCon++data Type++type Kind   = Type+type TyName = Name Type+type KiName = Name Kind++instance Generic  Type+instance Show     Type+instance NFData   Type+instance Binary   Type++mkTyConTy :: TyConName -> Type
+ src/Clash/Core/TysPrim.hs view
@@ -0,0 +1,306 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                     2016     , Myrtle Software Ltd,+                     2021-2026, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Builtin Type and Kind definitions+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++module Clash.Core.TysPrim+  ( liftedTypeKind+  , typeNatKind+  , typeSymbolKind+  , intPrimTy+  , integerPrimTy+  , charPrimTy+  , stringPrimTy+  , wordPrimTy+  , int64PrimTy+  , word64PrimTy+  , int8PrimTy+  , int16PrimTy+  , int32PrimTy+  , word8PrimTy+  , word16PrimTy+  , word32PrimTy+  , floatPrimTy+  , doublePrimTy+  , naturalPrimTy+  , byteArrayPrimTy+  , eqPrimTy+  , tysPrimMap+  , integerIsDc+  , naturalNsDc+  )+where++import           GHC.Builtin.Names++import           GHC.Base hiding (Type, TyCon)+import           Data.Text.Extra (showt)++import           Clash.Core.DataCon (DataCon(..), DcStrictness(..))+import           GHC.Num.Integer (Integer(..))+import           GHC.Num.Natural (Natural(..))++import           Clash.Core.Name+import           Clash.Core.TyCon+import           Clash.Core.Type+import           Clash.Core.Var (mkTyVar)+import           Clash.Unique (fromGhcUnique)+import qualified Clash.Data.UniqMap as UniqMap++-- | Builtin Name+liftedTypeKindTyConName, typeNatKindTyConName, typeSymbolKindTyConName :: TyConName+liftedTypeKindTyConName   = mkUnsafeSystemName "Type"+                              (fromGhcUnique liftedTypeKindTyConKey)+typeNatKindTyConName      = naturalPrimTyConName+typeSymbolKindTyConName   = mkUnsafeSystemName "Symbol"+                              (fromGhcUnique typeSymbolKindConNameKey)++-- | Builtin Kind+liftedTypeKindTc, typeNatKindTc, typeSymbolKindTc :: TyCon+liftedTypeKindTc = mkKindTyCon liftedTypeKindTyConName liftedTypeKind+typeNatKindTc    = mkKindTyCon typeNatKindTyConName liftedTypeKind+typeSymbolKindTc = mkKindTyCon typeSymbolKindTyConName liftedTypeKind++liftedTypeKind, typeNatKind, typeSymbolKind :: Type+liftedTypeKind = mkTyConTy liftedTypeKindTyConName+typeNatKind    = mkTyConTy typeNatKindTyConName+typeSymbolKind = mkTyConTy typeSymbolKindTyConName++intPrimTyConName, integerPrimTyConName, charPrimTyConName, stringPrimTyConName,+  wordPrimTyConName,  int64PrimTyConName, word64PrimTyConName,+  floatPrimTyConName, doublePrimTyConName,+  naturalPrimTyConName, byteArrayPrimTyConName, eqPrimTyConName :: TyConName+intPrimTyConName     = mkUnsafeSystemName (showt ''Int#)+                                (fromGhcUnique intPrimTyConKey)+integerPrimTyConName = mkUnsafeSystemName (showt ''Integer)+                                (fromGhcUnique integerTyConKey)+stringPrimTyConName  = mkUnsafeSystemName (showt ''Addr#)+                        (fromGhcUnique addrPrimTyConKey)+charPrimTyConName    = mkUnsafeSystemName (showt ''Char#)+                                (fromGhcUnique charPrimTyConKey)+wordPrimTyConName    = mkUnsafeSystemName (showt ''Word#)+                                (fromGhcUnique wordPrimTyConKey)+int64PrimTyConName   = mkUnsafeSystemName (showt ''Int64#)+                                (fromGhcUnique int64PrimTyConKey)+word64PrimTyConName  = mkUnsafeSystemName (showt ''Word64#)+                                (fromGhcUnique word64PrimTyConKey)+floatPrimTyConName   = mkUnsafeSystemName (showt ''Float#)+                                (fromGhcUnique floatPrimTyConKey)+doublePrimTyConName  = mkUnsafeSystemName (showt ''Double#)+                                (fromGhcUnique doublePrimTyConKey)+naturalPrimTyConName = mkUnsafeSystemName (showt ''Natural)+                                (fromGhcUnique naturalTyConKey)+byteArrayPrimTyConName = mkUnsafeSystemName (showt ''ByteArray#)+                          (fromGhcUnique byteArrayPrimTyConKey)++eqPrimTyConName = mkUnsafeSystemName "GHC.Prim.~#" (fromGhcUnique eqPrimTyConKey)+++int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, word8PrimTyConName,+  word16PrimTyConName, word32PrimTyConName :: TyConName+int8PrimTyConName   = mkUnsafeSystemName (showt ''Int8#)+                        (fromGhcUnique int8PrimTyConKey)+int16PrimTyConName  = mkUnsafeSystemName (showt ''Int16#)+                        (fromGhcUnique int16PrimTyConKey)+int32PrimTyConName  = mkUnsafeSystemName (showt ''Int32#)+                        (fromGhcUnique int32PrimTyConKey)+word8PrimTyConName  = mkUnsafeSystemName (showt ''Word8#)+                        (fromGhcUnique word8PrimTyConKey)+word16PrimTyConName = mkUnsafeSystemName (showt ''Word16#)+                        (fromGhcUnique word16PrimTyConKey)+word32PrimTyConName = mkUnsafeSystemName (showt ''Word32#)+                        (fromGhcUnique word32PrimTyConKey)++liftedPrimTC :: TyConName+             -> TyCon+liftedPrimTC name = PrimTyCon (nameUniq name) name liftedTypeKind 0++-- | Builtin Type+intPrimTc, integerPrimTc, charPrimTc, stringPrimTc, wordPrimTc,+  int64PrimTc, word64PrimTc, floatPrimTc, doublePrimTc, naturalPrimTc,+  byteArrayPrimTc :: TyCon+intPrimTc     = liftedPrimTC intPrimTyConName++-- While GHC might have dropped Integer and Natural literals, in Clash it is+-- still nice to have them around. However, Integer and Natural are also no+-- longer primitive types in GHC, but we still want to give the Integer and+-- Natural type to our Integer and Natural literals.+--+-- So instead of recording the primitive types, we record the algebraic types,+-- i.e. the complete data type for Integer and Natural, data constructors and all.++integerIsDc, naturalNsDc :: DataCon+integerIsDc = isDc+  where+    isDcNm = mkUnsafeSystemName (showt 'IS) (fromGhcUnique integerISDataConKey)+    isDc = MkData+      { dcName = isDcNm+      , dcUniq = nameUniq isDcNm+      , dcTag  = 1+      , dcType = mkPolyFunTy integerPrimTy [Right intPrimTy]+      , dcUnivTyVars = []+      , dcExtTyVars = []+      , dcArgTys = [intPrimTy]+      , dcArgStrict = [Strict]+      , dcFieldLabels = []+      }++integerPrimTc =+  let+    name = integerPrimTyConName+    uniq = nameUniq name+    isDc = integerIsDc+    ipDcNm = mkUnsafeSystemName (showt 'IP) (fromGhcUnique integerIPDataConKey)+    ipDc = MkData+      { dcName = ipDcNm+      , dcUniq = nameUniq ipDcNm+      , dcTag  = 2+      , dcType = mkPolyFunTy integerPrimTy [Right byteArrayPrimTy]+      , dcUnivTyVars = []+      , dcExtTyVars = []+      , dcArgTys = [byteArrayPrimTy]+      , dcArgStrict = [Strict]+      , dcFieldLabels = []+      }+    inDcNm = mkUnsafeSystemName (showt 'IN) (fromGhcUnique integerINDataConKey)+    inDc = MkData+      { dcName = inDcNm+      , dcUniq = nameUniq inDcNm+      , dcTag  = 3+      , dcType = mkPolyFunTy integerPrimTy [Right byteArrayPrimTy]+      , dcUnivTyVars = []+      , dcExtTyVars = []+      , dcArgTys = [byteArrayPrimTy]+      , dcArgStrict = [Strict]+      , dcFieldLabels = []+      }+    rhs = DataTyCon [isDc,ipDc,inDc]+  in+    AlgTyCon uniq name liftedTypeKind 0 rhs False++naturalNsDc = nsDc+  where+    nsDcNm = mkUnsafeSystemName (showt 'NS) (fromGhcUnique naturalNSDataConKey)+    nsDc = MkData+      { dcName = nsDcNm+      , dcUniq = nameUniq nsDcNm+      , dcTag  = 1+      , dcType = mkPolyFunTy naturalPrimTy [Right wordPrimTy]+      , dcUnivTyVars = []+      , dcExtTyVars = []+      , dcArgTys = [wordPrimTy]+      , dcArgStrict = [Strict]+      , dcFieldLabels = []+      }++naturalPrimTc =+  let+    name = naturalPrimTyConName+    uniq = nameUniq name+    nsDc = naturalNsDc+    nbDcNm = mkUnsafeSystemName (showt 'NB) (fromGhcUnique naturalNBDataConKey)+    nbDc = MkData+      { dcName = nbDcNm+      , dcUniq = nameUniq nbDcNm+      , dcTag  = 2+      , dcType = mkPolyFunTy naturalPrimTy [Right byteArrayPrimTy]+      , dcUnivTyVars = []+      , dcExtTyVars = []+      , dcArgTys = [byteArrayPrimTy]+      , dcArgStrict = [Strict]+      , dcFieldLabels = []+      }+    rhs = DataTyCon [nsDc,nbDc]+   in+    AlgTyCon uniq name liftedTypeKind 0 rhs False+charPrimTc    = liftedPrimTC charPrimTyConName+stringPrimTc  = liftedPrimTC stringPrimTyConName+wordPrimTc    = liftedPrimTC wordPrimTyConName+int64PrimTc   = liftedPrimTC int64PrimTyConName+word64PrimTc  = liftedPrimTC word64PrimTyConName+floatPrimTc   = liftedPrimTC floatPrimTyConName+doublePrimTc  = liftedPrimTC doublePrimTyConName+byteArrayPrimTc = liftedPrimTC  byteArrayPrimTyConName+++int8PrimTc, int16PrimTc, int32PrimTc, word8PrimTc, word16PrimTc,+  word32PrimTc :: TyCon+int8PrimTc    = liftedPrimTC int8PrimTyConName+int16PrimTc   = liftedPrimTC int16PrimTyConName+int32PrimTc   = liftedPrimTC int32PrimTyConName+word8PrimTc   = liftedPrimTC word8PrimTyConName+word16PrimTc  = liftedPrimTC word16PrimTyConName+word32PrimTc  = liftedPrimTC word32PrimTyConName++eqPrimTc :: TyCon+eqPrimTc = PrimTyCon (nameUniq eqPrimTyConName) eqPrimTyConName ty 4+ where+  -- forall (a :: Type). forall (b :: Type). a -> b -> Type+  --+  -- The "real" type for this in GHC has a codomain of `TYPE ('TupleRep '[])`+  -- instead of the `TYPE 'LiftedRep` used here.+  ty  = mkPolyFunTy liftedTypeKind+    [Left aTv, Left bTv, Right (VarTy aTv), Right (VarTy bTv)]++  aTv = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0)+  bTv = mkTyVar liftedTypeKind (mkUnsafeSystemName "b" 1)++intPrimTy, integerPrimTy, charPrimTy, stringPrimTy, wordPrimTy,+  int64PrimTy, word64PrimTy, floatPrimTy, doublePrimTy, naturalPrimTy,+  byteArrayPrimTy, eqPrimTy :: Type+intPrimTy     = mkTyConTy intPrimTyConName+integerPrimTy = mkTyConTy integerPrimTyConName+charPrimTy    = mkTyConTy charPrimTyConName+stringPrimTy  = mkTyConTy stringPrimTyConName+wordPrimTy    = mkTyConTy wordPrimTyConName+int64PrimTy   = mkTyConTy int64PrimTyConName+word64PrimTy  = mkTyConTy word64PrimTyConName+floatPrimTy   = mkTyConTy floatPrimTyConName+doublePrimTy  = mkTyConTy doublePrimTyConName+naturalPrimTy = mkTyConTy naturalPrimTyConName+byteArrayPrimTy = mkTyConTy byteArrayPrimTyConName+eqPrimTy = mkTyConTy eqPrimTyConName++int8PrimTy, int16PrimTy, int32PrimTy, word8PrimTy, word16PrimTy,+  word32PrimTy :: Type+int8PrimTy    = mkTyConTy int8PrimTyConName+int16PrimTy   = mkTyConTy int16PrimTyConName+int32PrimTy   = mkTyConTy int32PrimTyConName+word8PrimTy   = mkTyConTy word8PrimTyConName+word16PrimTy  = mkTyConTy word16PrimTyConName+word32PrimTy  = mkTyConTy word32PrimTyConName++tysPrimMap :: TyConMap+tysPrimMap = UniqMap.fromList+  [  (liftedTypeKindTyConName , liftedTypeKindTc)+  ,  (typeNatKindTyConName , typeNatKindTc)+  ,  (typeSymbolKindTyConName , typeSymbolKindTc)+  ,  (intPrimTyConName , intPrimTc)+  ,  (integerPrimTyConName , integerPrimTc)+  ,  (charPrimTyConName , charPrimTc)+  ,  (stringPrimTyConName , stringPrimTc)+  ,  (wordPrimTyConName , wordPrimTc)+  ,  (int64PrimTyConName , int64PrimTc)+  ,  (word64PrimTyConName , word64PrimTc)+  ,  (int8PrimTyConName , int8PrimTc)+  ,  (int16PrimTyConName , int16PrimTc)+  ,  (int32PrimTyConName , int32PrimTc)+  ,  (word8PrimTyConName , word8PrimTc)+  ,  (word16PrimTyConName , word16PrimTc)+  ,  (word32PrimTyConName , word32PrimTc)+  ,  (floatPrimTyConName , floatPrimTc)+  ,  (doublePrimTyConName , doublePrimTc)+  ,  (naturalPrimTyConName , naturalPrimTc)+  ,  (byteArrayPrimTyConName , byteArrayPrimTc)+  ,  (eqPrimTyConName , eqPrimTc)+  ]
+ src/Clash/Core/Util.hs view
@@ -0,0 +1,775 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                     2021-2024, QBayLogic B.V.,+                     2022     , Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Smart constructor and destructor functions for CoreHW+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Core.Util where++import Control.Exception.Base (patError)+import GHC.Prim.Panic (absentError)+import Control.Monad.Trans.Except              (Except, throwE, runExcept)+import Data.Bifunctor                          (first, second)+import qualified Data.HashSet                  as HashSet+import qualified Data.Graph                    as Graph+import Data.List                               (mapAccumR, uncons)+import Data.List.Extra                         (zipEqual)+import Data.List.NonEmpty                      (NonEmpty (..), toList)+import Data.Maybe+  (fromMaybe, isJust, mapMaybe, catMaybes)+import qualified Data.Set                      as Set+import qualified Data.Set.Lens                 as Lens+import qualified Data.Text                     as T+import           Data.Text.Extra               (showt)+import           GHC.Real+  (divZeroError, overflowError, ratioZeroDenominatorError, underflowError)+import           GHC.Stack                     (HasCallStack)++import           GHC.Builtin.Names       (ipClassKey)++import Clash.Core.DataCon+import Clash.Core.EqSolver+import Clash.Core.FreeVars               (freeLocalIds)+import Clash.Core.HasFreeVars+import Clash.Core.HasType+import Clash.Core.Name+  (Name (..), OccName, mkUnsafeInternalName, mkUnsafeSystemName)+import Clash.Core.Pretty                 (showPpr)+import Clash.Core.Subst+import Clash.Core.Term+import Clash.Core.TyCon                  (TyConMap, tyConDataCons)+import Clash.Core.Type+import Clash.Core.TysPrim                (liftedTypeKind, typeNatKind)+import Clash.Core.Var                    (Id, Var(..), mkLocalId, mkTyVar)+import Clash.Core.VarEnv+import qualified Clash.Data.UniqMap as UniqMap+import Clash.Debug                       (traceIf)+import Clash.Unique                      (fromGhcUnique)+import Clash.Util+import Clash.Util.Supply                 (Supply, freshId)++import {-# SOURCE #-} qualified Clash.Normalize.Primitives as Primitives+import Clash.XException (errorX)++-- | Rebuild a let expression / let expressions by taking the SCCs of a list+-- of bindings and remaking Let (NonRec ...) ... and Let (Rec ...) ...+--+listToLets :: [LetBinding] -> Term -> Term+listToLets xs body = foldr go body (sccLetBindings xs)+ where+  go (Graph.AcyclicSCC (i, x)) acc = Let (NonRec i x) acc+  go (Graph.CyclicSCC binds) acc = Let (Rec binds) acc++-- | The type @forall a . a@+undefinedTy ::Type+undefinedTy =+  let aNm = mkUnsafeSystemName "a" 0+      aTv = (TyVar aNm 0 liftedTypeKind)+  in  ForAllTy aTv (VarTy aTv)++-- | The type @forall a. forall b. a -> b@+unsafeCoerceTy :: Type+unsafeCoerceTy =+  let aNm = mkUnsafeSystemName "a" 0+      aTv = TyVar aNm 0 liftedTypeKind+      bNm = mkUnsafeSystemName "b" 1+      bTv = TyVar bNm 1 liftedTypeKind+  in ForAllTy aTv (ForAllTy bTv (mkFunTy (VarTy aTv) (VarTy bTv)))++-- | Create a vector of supplied elements+mkVec :: DataCon -- ^ The Nil constructor+      -> DataCon -- ^ The Cons (:>) constructor+      -> Type    -- ^ Element type+      -> Integer -- ^ Length of the vector+      -> [Term]  -- ^ Elements to put in the vector+      -> Term+mkVec nilCon consCon resTy = go+  where+    go _ [] = mkApps (Data nilCon) [Right (LitTy (NumTy 0))+                                   ,Right resTy+                                   ,Left  (primCo nilCoTy)+                                   ]++    go n (x:xs) = mkApps (Data consCon) [Right (LitTy (NumTy n))+                                        ,Right resTy+                                        ,Right (LitTy (NumTy (n-1)))+                                        ,Left (primCo (consCoTy n))+                                        ,Left x+                                        ,Left (go (n-1) xs)]++    nilCoTy    = case dataConInstArgTys nilCon [(LitTy (NumTy 0)) ,resTy] of+                   Just (x:_) -> x+                   _ -> error "impossible"+    consCoTy n = case dataConInstArgTys consCon+                                        [(LitTy (NumTy n))+                                        ,resTy+                                        ,(LitTy (NumTy (n-1)))] of+                   Just (x:_) -> x+                   _ -> error "impossible"++-- | Append elements to the supplied vector+appendToVec :: DataCon -- ^ The Cons (:>) constructor+            -> Type    -- ^ Element type+            -> Term    -- ^ The vector to append the elements to+            -> Integer -- ^ Length of the vector+            -> [Term]  -- ^ Elements to append+            -> Term+appendToVec consCon resTy vec = go+  where+    go _ []     = vec+    go n (x:xs) = mkApps (Data consCon) [Right (LitTy (NumTy n))+                                        ,Right resTy+                                        ,Right (LitTy (NumTy (n-1)))+                                        ,Left (primCo (consCoTy n))+                                        ,Left x+                                        ,Left (go (n-1) xs)]++    consCoTy n = case dataConInstArgTys consCon+                                        [(LitTy (NumTy n))+                                        ,resTy+                                        ,(LitTy (NumTy (n-1)))] of+                   Just (x:_) -> x+                   _ -> error "impossible"++-- | Create let-bindings with case-statements that select elements out of a+-- vector. Returns both the variables to which element-selections are bound+-- and the let-bindings+extractElems+  :: HasCallStack+  => Supply+  -- ^ Unique supply+  -> InScopeSet+  -- ^ (Superset of) in scope variables+  -> DataCon+  -- ^ The Cons (:>) constructor+  -> Type+  -- ^ The element type+  -> Char+  -- ^ Char to append to the bound variable names+  -> Integer+  -- ^ Length of the vector+  -> Term+  -- ^ The vector+  -> (Supply, NonEmpty (Term,NonEmpty (Id, Term)))+extractElems supply inScope consCon resTy s maxN vec =+  if maxN >= 1 then+    first fst (go maxN (supply,inScope) vec)+  else+    error "extractElems must be called with positive number"+ where+  go :: Integer -> (Supply,InScopeSet) -> Term+     -> ((Supply,InScopeSet),NonEmpty (Term, NonEmpty (Id, Term)))+  go n uniqs0 e = fromMaybe (error "extractElems: failed to project elements") $ do+    let tys = [(LitTy (NumTy n)),resTy,(LitTy (NumTy (n-1)))]+    idTys <- dataConInstArgTys consCon tys+    let restTy = last idTys++    let (uniqs1,mTV) = mkUniqSystemTyVar uniqs0 ("m",typeNatKind)+    (uniqs2,[elNId,restNId,co,el,rest]) <- pure $+      mapAccumR mkUniqSystemId uniqs1 $ zipEqual+        ["el" `T.append` (s `T.cons` T.pack (show (maxN-n)))+        ,"rest" `T.append` (s `T.cons` T.pack (show (maxN-n)))+        ,"_co_"+        ,"el"+        ,"rest"+        ]+        (resTy:restTy:idTys)++    let elNVar    = Var elNId+        pat       = DataPat consCon [mTV] [co,el,rest]+        lhs       = Case e resTy  [(pat,Var el)]+        rhs       = Case e restTy [(pat,Var rest)]++    let (uniqs3,restVs) = if n < 2 then (uniqs2,[]) else second toList (go (n-1) uniqs2 (Var restNId))++    return (uniqs3,(elNVar,(elNId, lhs) :| [(restNId, rhs)]) :| restVs)++-- | Create let-bindings with case-statements that select elements out of a+-- tree. Returns both the variables to which element-selections are bound+-- and the let-bindings+extractTElems+  :: Supply+  -- ^ Unique supply+  -> InScopeSet+  -- ^ (Superset of) in scope variables+  -> DataCon+  -- ^ The 'LR' constructor+  -> DataCon+  -- ^ The 'BR' constructor+  -> Type+  -- ^ The element type+  -> Char+  -- ^ Char to append to the bound variable names+  -> Integer+  -- ^ Depth of the tree+  -> Term+  -- ^ The tree+  -> (Supply,([Term],[(Id, Term)]))+extractTElems supply inScope lrCon brCon resTy s maxN tree =+  first fst (go maxN [0..(2^(maxN+1))-2] [0..(2^maxN - 1)] (supply,inScope) tree)+ where+  go :: Integer+     -> [Int]+     -> [Int]+     -> (Supply,InScopeSet)+     -> Term+     -> ((Supply,InScopeSet),([Term],[(Id, Term)]))+  go 0 _ ks uniqs0 e = fromMaybe (error "extractTElems: failed to project elements") $ do+    let tys = [LitTy (NumTy 0),resTy]+    idTys <- dataConInstArgTys lrCon tys+    (k,_) <- uncons ks++    (uniqs1,[elNId,co,el]) <- pure $+      mapAccumR mkUniqSystemId uniqs0 $ zipEqual+        [ "el" `T.append` (s `T.cons` T.pack (show k))+        , "_co_"+        , "el"+        ]+        (resTy:idTys)+    let elNVar = Var elNId+        pat    = DataPat lrCon [] [co,el]+        rhs    = Case e resTy [(pat,Var el)]+    return (uniqs1,([elNVar],[(elNId, rhs)]))++  go n bs ks uniqs0 e = fromMaybe (error "extractTElems: failed to project elements") $ do+    let tys = [LitTy (NumTy n),resTy,LitTy (NumTy (n-1))]+    idTys <- dataConInstArgTys brCon tys++    let (uniqs1,mTV) = mkUniqSystemTyVar uniqs0 ("m",typeNatKind)+    (b0:bL,b1:bR) <- pure (splitAt (length bs `div` 2) bs)+    let brTy = last idTys+    (uniqs2,[ltNId,rtNId,co,lt,rt]) <- pure $+      mapAccumR mkUniqSystemId uniqs1 $ zipEqual+        ["lt" `T.append` (s `T.cons` T.pack (show b0))+        ,"rt" `T.append` (s `T.cons` T.pack (show b1))+        ,"_co_"+        ,"lt"+        ,"rt"+        ]+        (brTy:brTy:idTys)+    let ltVar = Var ltNId+        rtVar = Var rtNId+        pat   = DataPat brCon [mTV] [co,lt,rt]+        ltRhs = Case e brTy [(pat,Var lt)]+        rtRhs = Case e brTy [(pat,Var rt)]++        (kL,kR) = splitAt (length ks `div` 2) ks+        (uniqs3,(lVars,lBinds)) = go (n-1) bL kL uniqs2 ltVar+        (uniqs4,(rVars,rBinds)) = go (n-1) bR kR uniqs3 rtVar++    return ( uniqs4+           , ( lVars ++ rVars+             , (ltNId, ltRhs):(rtNId, rtRhs): (lBinds ++ rBinds)+             )+           )++-- | Create a vector of supplied elements+mkRTree :: DataCon -- ^ The LR constructor+        -> DataCon -- ^ The BR constructor+        -> Type    -- ^ Element type+        -> Integer -- ^ Depth of the tree+        -> [Term]  -- ^ Elements to put in the tree+        -> Term+mkRTree lrCon brCon resTy = go+  where+    go _ [x] = mkApps (Data lrCon) [Right (LitTy (NumTy 0))+                                    ,Right resTy+                                    ,Left  (primCo lrCoTy)+                                    ,Left  x+                                    ]++    go n xs =+      let (xsL,xsR) = splitAt (length xs `div` 2) xs+      in  mkApps (Data brCon) [Right (LitTy (NumTy n))+                              ,Right resTy+                              ,Right (LitTy (NumTy (n-1)))+                              ,Left (primCo (brCoTy n))+                              ,Left (go (n-1) xsL)+                              ,Left (go (n-1) xsR)]++    lrCoTy   = case dataConInstArgTys lrCon [(LitTy (NumTy 0)) ,resTy] of+                 Just (x:_) -> x+                 _ -> error "impossible"+    brCoTy n = case dataConInstArgTys brCon+                                      [(LitTy (NumTy n))+                                      ,resTy+                                      ,(LitTy (NumTy (n-1)))] of+                 Just (x:_) -> x+                 _ -> error "impossible"++-- | Determine whether a type is isomorphic to "Clash.Signal.Internal.Signal"+--+-- It is i.e.:+--+--   * Signal clk a+--   * (Signal clk a, Signal clk b)+--   * Vec n (Signal clk a)+--   * data Wrap = W (Signal clk' Int)+--   * etc.+--+-- This also includes BiSignals, i.e.:+--+--   * BiSignalIn High System Int+--   * etc.+--+isSignalType :: TyConMap -> Type -> Bool+isSignalType tcm ty = go HashSet.empty ty+  where+    go tcSeen (tyView -> TyConApp tcNm args) = case nameOcc tcNm of+      "Clash.Signal.Internal.Signal"      -> True+      "Clash.Signal.BiSignal.BiSignalIn"  -> True+      "Clash.Signal.BiSignal.BiSignalOut" -> True+      _ | tcNm `HashSet.member` tcSeen    -> False -- Do not follow rec types+        | otherwise -> case UniqMap.lookup tcNm tcm of+            Just tc -> let dcs         = tyConDataCons tc+                           dcInsArgTys = concat+                                       $ mapMaybe (`dataConInstArgTys` args) dcs+                           tcSeen'     = HashSet.insert tcNm tcSeen+                       in  any (go tcSeen') dcInsArgTys+            Nothing -> traceIf True ($(curLoc) ++ "isSignalType: " ++ show tcNm+                                     ++ " not found.") False++    go _ _ = False++-- | Determines whether given type is an (alias of en) Enable line.+isEnable+  :: TyConMap+  -> Type+  -> Bool+isEnable m ty0+  | TyConApp (nameOcc -> "Clash.Signal.Internal.Enable") _ <- tyView ty0 = True+  | Just ty1 <- coreView1 m ty0 = isEnable m ty1+isEnable _ _ = False++-- | Determines whether given type is an (alias of en) Clock or Reset line+isClockOrReset+  :: TyConMap+  -> Type+  -> Bool+isClockOrReset m (coreView1 m -> Just ty)    = isClockOrReset m ty+isClockOrReset _ (tyView -> TyConApp tcNm _) = case nameOcc tcNm of+  "Clash.Signal.Internal.Clock" -> True+  "Clash.Signal.Internal.ClockN" -> True+  "Clash.Signal.Internal.Reset" -> True+  _ -> False+isClockOrReset _ _ = False++tyNatSize :: TyConMap+          -> Type+          -> Except String Integer+tyNatSize m (coreView1 m -> Just ty) = tyNatSize m ty+tyNatSize _ (LitTy (NumTy i))        = return i+tyNatSize _ ty = throwE $ $(curLoc) ++ "Cannot reduce to an integer:\n" ++ showPpr ty+++mkUniqSystemTyVar+  :: (Supply, InScopeSet)+  -> (OccName, Kind)+  -> ((Supply, InScopeSet), TyVar)+mkUniqSystemTyVar (supply,inScope) (nm, ki) =+  ((supply',extendInScopeSet inScope v'), v')+ where+  (u,supply') = freshId supply+  v           = mkTyVar ki (mkUnsafeSystemName nm u)+  v'          = uniqAway inScope v++mkUniqSystemId+  :: (Supply, InScopeSet)+  -> (OccName, Type)+  -> ((Supply,InScopeSet), Id)+mkUniqSystemId (supply,inScope) (nm, ty) =+  ((supply',extendInScopeSet inScope v'), v')+ where+  (u,supply') = freshId supply+  v           = mkLocalId ty (mkUnsafeSystemName nm u)+  v'          = uniqAway inScope v++mkUniqInternalId+  :: (Supply, InScopeSet)+  -> (OccName, Type)+  -> ((Supply,InScopeSet), Id)+mkUniqInternalId (supply,inScope) (nm, ty) =+  ((supply',extendInScopeSet inScope v'), v')+ where+  (u,supply') = freshId supply+  v           = mkLocalId ty (mkUnsafeInternalName nm u)+  v'          = uniqAway inScope v+++-- | Same as @dataConInstArgTys@, but it tries to compute existentials too,+-- hence the extra argument @TyConMap@. WARNING: It will return the types+-- of non-existentials only+dataConInstArgTysE+  :: HasCallStack+  => InScopeSet+  -> TyConMap+  -> DataCon+  -> [Type]+  -> Maybe [Type]+dataConInstArgTysE is0 tcm (MkData { dcArgTys, dcExtTyVars, dcUnivTyVars }) inst_tys = do+  -- TODO: Check if all existentials were solved (they should be, or the wouldn't have+  -- TODO: been solved in the caseElemExistentials transformation)+  let is1   = extendInScopeSetList is0 dcExtTyVars+      is2   = unionInScope is1 (mkInScopeSet (freeVarsOf inst_tys))+      subst = extendTvSubstList (mkSubst is2) (zipEqual dcUnivTyVars inst_tys)+  go+    (substGlobalsInExistentials is0 dcExtTyVars (zipEqual dcUnivTyVars inst_tys))+    (map (substTy subst) dcArgTys)++ where+  exts = mkVarSet dcExtTyVars+  go+    :: [TyVar]+    -- ^ Existentials+    -> [Type]+    -- ^ Type arguments+    -> Maybe [Type]+    -- ^ Maybe ([type of non-existential])+  go exts0 args0 =+    let eqs = catMaybes (map (typeEq tcm) args0) in+    case solveNonAbsurds tcm exts eqs of+      [] ->+        Just args0+      sols ->+        go exts1 args1+        where+          exts1 = substInExistentialsList is0 exts0 sols+          is2   = extendInScopeSetList is0 exts1+          subst = extendTvSubstList (mkSubst is2) sols+          args1 = map (substTy subst) args0+++-- | Given a DataCon and a list of types, the type variables of the DataCon+-- type are substituted for the list of types. The argument types are returned.+--+-- The list of types should be equal to the number of type variables, otherwise+-- @Nothing@ is returned.+dataConInstArgTys :: DataCon -> [Type] -> Maybe [Type]+dataConInstArgTys (MkData { dcArgTys, dcUnivTyVars, dcExtTyVars }) inst_tys =+  -- TODO: Check if inst_tys do not contain any free variables on call sites. If+  -- TODO: they do, this function is unsafe to use.+  let tyvars = dcUnivTyVars ++ dcExtTyVars in+  if length tyvars == length inst_tys then+    Just (map (substTyWith tyvars inst_tys) dcArgTys)+  else+    Nothing++-- | Make a coercion+primCo+  :: Type+  -> Term+primCo ty = Prim (PrimInfo "_CO_" ty WorkNever SingleResult NoUnfolding)++-- | Make an unsafe coercion+primUCo :: Term+primUCo =+  Prim PrimInfo { primName        = "GHC.Prim.unsafeCoerce#"+                , primType        = unsafeCoerceTy+                , primWorkInfo    = WorkNever+                , primMultiResult = SingleResult+                , primUnfolding = NoUnfolding+                }++undefinedPrims :: [T.Text]+undefinedPrims = fmap showt+  [ 'Primitives.undefined+  , 'patError+  , 'error+  , 'errorWithoutStackTrace+  , 'undefined+  , 'absentError+  , 'divZeroError+  , 'overflowError+  , 'ratioZeroDenominatorError+  , 'underflowError+  ]++undefinedXPrims :: [T.Text]+undefinedXPrims = fmap showt+  [ 'Primitives.undefinedX+  , 'errorX+  ]++substArgTys+  :: DataCon+  -> [Type]+  -> [Type]+substArgTys dc args =+  let univTVs = dcUnivTyVars dc+      extTVs  = dcExtTyVars dc+      argsFVs = freeVarsOf args+      is      = mkInScopeSet (argsFVs `unionVarSet` mkVarSet extTVs)+      -- See Note [The substitution invariant]+      subst   = extendTvSubstList (mkSubst is) (univTVs `zipEqual` args)+  in  map (substTy subst) (dcArgTys dc)++-- | Try to reduce an arbitrary type to a literal type (Symbol or Nat),+-- and subsequently extract its String representation+tyLitShow+  :: TyConMap+  -> Type+  -> Except String String+tyLitShow m (coreView1 m -> Just ty) = tyLitShow m ty+tyLitShow _ (LitTy (SymTy s))        = return s+tyLitShow _ (LitTy (NumTy s))        = return (show s)+tyLitShow _ ty = throwE $ $(curLoc) ++ "Cannot reduce to a string:\n" ++ showPpr ty++-- | Helper existential for 'shouldSplit', contains a function that:+--+-- 1. given a term of a type that should be split,+-- 2. creates projections of that term for all the constructor arguments+data Projections where+  Projections :: (forall m . MonadUnique m => InScopeSet -> Term -> m [Term])+              -> Projections++-- | Determine whether we should split away types from a product type, i.e.+-- clocks should always be separate arguments, and not part of a product.+shouldSplit+  :: TyConMap+  -> Type+  -- ^ Type to examine+  -> Maybe ([Term] -> Term, Projections, [Type])+  -- ^ If we want to split values of the given type then we have /Just/:+  --+  -- 1. The (type-applied) data-constructor which, when applied to values of+  --    the types in 3., creates a value of the examined type+  --+  -- 2. Function that give a term of the type we need to split, creates projections+  --    of that term for all the types in 3.+  --+  -- 3. The arguments types of the product we are trying to split.+  --+  -- Note that we only split one level at a time (although we check all the way+  -- down), e.g. given /(Int, (Clock, Bool))/ we return:+  --+  -- > Just ( (,) @Int @(Clock, Bool)+  -- >      , \s -> [case s of (a,b) -> a, case s of (a,b) -> b]+  -- >      , [Int, (Clock, Bool)])+  --+  -- An outer loop is required to subsequently split the /(Clock, Bool)/ tuple.+shouldSplit tcm (tyView ->  TyConApp (nameOcc -> "Clash.Explicit.SimIO.SimIO") [tyArg]) =+  -- We also look through `SimIO` to find things like Files+  shouldSplit tcm tyArg+shouldSplit tcm ty = shouldSplit0 tcm (tyView (coreView tcm ty))++-- | Worker of 'shouldSplit', works on 'TypeView' instead of 'Type'+shouldSplit0+  :: TyConMap+  -> TypeView+  -> Maybe ([Term] -> Term, Projections, [Type])+shouldSplit0 tcm (TyConApp tcNm tyArgs)+  | Just tc <- UniqMap.lookup tcNm tcm+  , [dc] <- tyConDataCons tc+  , let dcArgs = substArgTys dc tyArgs+  , let dcArgsLen = length dcArgs+  , dcArgsLen > 1+  , let dcArgVs = map (tyView . coreView tcm) dcArgs+  = if any shouldSplitTy dcArgVs && not (isHidden tcNm tyArgs) then+      Just ( mkApps (Data dc) . (map Right tyArgs ++) . map Left+           , Projections+             (\is0 subj -> mapM (mkSelectorCase ($(curLoc) ++ "splitArg") is0 tcm subj 1)+                                [0..dcArgsLen - 1])+           , dcArgs+           )+    else+      Nothing+  | "Clash.Sized.Vector.Vec" <- nameOcc tcNm+  , [nTy,argTy] <- tyArgs+  , Right n <- runExcept (tyNatSize tcm nTy)+  , n > 1+  , Just tc <- UniqMap.lookup tcNm tcm+  , [nil,cons] <- tyConDataCons tc+  = if shouldSplitTy (tyView (coreView tcm argTy)) then+      Just ( mkVec nil cons argTy n+           , Projections (\is0 subj -> mapM (mkVecSelector is0 subj) [0..n-1])+           , replicate (fromInteger n) argTy)+    else+      Nothing+ where+  -- Project the n'th value out of a vector+  --+  -- >>> mkVecSelector subj 0+  -- case subj of Cons x xs -> x+  --+  -- >>> mkVecSelector subj 2+  -- case (case (case subj of Cons x xs -> xs) of Cons x xs -> xs) of Cons x xs -> x+  mkVecSelector :: forall m . MonadUnique m => InScopeSet -> Term -> Integer -> m Term+  mkVecSelector is0 subj 0 =+    mkSelectorCase ($(curLoc) ++ "mkVecSelector") is0 tcm subj 2 1++  mkVecSelector is0 subj !n = do+    subj1 <- mkSelectorCase ($(curLoc) ++ "mkVecSelector") is0 tcm subj 2 2+    mkVecSelector is0 subj1 (n-1)++  shouldSplitTy :: TypeView -> Bool+  shouldSplitTy ty = isJust (shouldSplit0 tcm ty) || splitTy ty++  -- Hidden constructs (HiddenClock, HiddenReset, ..) don't need to be split+  -- because KnownDomain will be filtered anyway during netlist generation due+  -- to it being a zero-width type+  --+  -- TODO: This currently only handles (IP $x, KnownDomain) given that $x is any+  -- TODO: of the constructs handled in 'splitTy'. In practice this means only+  -- TODO: HiddenClock, HiddenReset, and HiddenEnable are handled. If a user were+  -- TODO: to define their own versions with -for example- the elements of the+  -- TODO: tuple swapped, 'isHidden' wouldn't recognize it. We could generalize+  -- TODO: this in the future.+  --+  isHidden :: Name a -> [Type] -> Bool+  isHidden nm [a1, a2] | TyConApp a2Nm _ <- tyView a2 =+       nameOcc nm `elem` ["GHC.Classes.(%,%)", "GHC.Classes.CTuple2"]+    && splitTy (tyView (stripIP a1))+    && nameOcc a2Nm == "Clash.Signal.Internal.KnownDomain"+  isHidden _ _ = False++  splitTy (TyConApp tcNm0 _)+    = nameOcc tcNm0 `elem` [ "Clash.Signal.Internal.Clock"+                           , "Clash.Signal.Internal.ClockN"+                           , "Clash.Signal.Internal.Reset"+                           , "Clash.Signal.Internal.Enable"+                           -- iverilog doesn't like it when we put file handles+                           -- in a bitvector, so we need to make sure Clash+                           -- splits them off+                           , "Clash.Explicit.SimIO.File"+                           , "GHC.IO.Handle.Types.Handle"+                           ]+  splitTy _ = False++shouldSplit0 _ _ = Nothing++-- | Potentially split apart a list of function argument types. e.g. given:+--+-- > [Int,(Clock,(Reset,Bool)),Char]+--+-- we return+--+-- > [Int,Clock,Reset,Bool,Char]+--+-- But we would leave+--+-- > [Int, (Bool,Int), Char]+--+-- unchanged.+splitShouldSplit+  :: TyConMap+  -> [Type]+  -> [Type]+splitShouldSplit tcm = foldr go []+ where+  go ty rest = case shouldSplit tcm ty of+    Just (_,_,tys) -> splitShouldSplit tcm tys ++ rest+    Nothing        -> ty : rest++-- | Strip implicit parameter wrappers (IP)+stripIP :: Type -> Type+stripIP t@(tyView -> TyConApp tcNm [_a1, a2]) =+  if nameUniq tcNm == fromGhcUnique ipClassKey then a2 else t+stripIP t = t++-- | Do an inverse topological sorting of the let-bindings in a let-expression+inverseTopSortLetBindings+  :: HasCallStack+  => [(Id, Term)]+  -> [(Id, Term)]+inverseTopSortLetBindings bndrs0 =+  let (graph,nodeMap,_) =+        Graph.graphFromEdges+          (map (\(i,e) -> let fvs = fmap varUniq+                                    (Set.elems (Lens.setOf freeLocalIds e) )+                          in  ((i,e),varUniq i,fvs)) bndrs0)+      nodes  = postOrd graph+      bndrs1 = map ((\(x,_,_) -> x) . nodeMap) nodes+   in bndrs1+ where+  postOrd :: Graph.Graph -> [Graph.Vertex]+  postOrd g = postorderF (Graph.dff g) []++  postorderF :: Graph.Forest a -> [a] -> [a]+  postorderF ts = foldr (.) id (map postorder ts)++  postorder :: Graph.Tree a -> [a] -> [a]+  postorder (Graph.Node a ts) = postorderF ts . (a :)+{-# SCC inverseTopSortLetBindings #-}++-- | Group let-bindings into cyclic groups and acyclic individual bindings+sccLetBindings+  :: HasCallStack+  => [(Id, Term)]+  -> [Graph.SCC (Id, Term)]+sccLetBindings =+  Graph.stronglyConnComp .+  (map (\(i,e) -> let fvs = fmap varUniq+                            (Set.elems (Lens.setOf freeLocalIds e) )+                  in  ((i,e),varUniq i,fvs)))+{-# SCC sccLetBindings #-}++-- | Make a case-decomposition that extracts a field out of a (Sum-of-)Product type+mkSelectorCase+  :: HasCallStack+  => MonadUnique m+  => String -- ^ Name of the caller of this function+  -> InScopeSet+  -> TyConMap -- ^ TyCon cache+  -> Term -- ^ Subject of the case-composition+  -> Int -- ^ n'th DataCon+  -> Int -- ^ n'th field+  -> m Term+mkSelectorCase caller inScope tcm scrut dcI fieldI = go (inferCoreTypeOf tcm scrut)+  where+    go (coreView1 tcm -> Just ty') = go ty'+    go scrutTy@(tyView -> TyConApp tc args) =+      case tyConDataCons (UniqMap.find tc tcm) of+        [] -> cantCreate $(curLoc) ("TyCon has no DataCons: " ++ show tc ++ " " ++ showPpr tc) scrutTy+        dcs | dcI > length dcs -> cantCreate $(curLoc) "DC index exceeds max" scrutTy+            | otherwise -> do+          let dc = indexNote ($(curLoc) ++ "No DC with tag: " ++ show (dcI-1)) dcs (dcI-1)+          let fieldTys =+                fromMaybe (cantCreate $(curLoc) "Cannot instantiate dataCon" scrutTy)+                          (dataConInstArgTysE inScope tcm dc args)+          if fieldI >= length fieldTys+            then cantCreate $(curLoc) "Field index exceed max" scrutTy+            else do+              wildBndrs <- mapM (mkWildValBinder inScope) fieldTys+              let ty = indexNote ($(curLoc) ++ "No DC field#: " ++ show fieldI) fieldTys fieldI+              selBndr <- mkInternalVar inScope "sel" ty+              let bndrs  = take fieldI wildBndrs ++ [selBndr] ++ drop (fieldI+1) wildBndrs+                  pat    = DataPat dc (dcExtTyVars dc) bndrs+                  retVal = Case scrut ty [ (pat, Var selBndr) ]+              return retVal+    go scrutTy = cantCreate $(curLoc) ("Type of subject is not a datatype: " ++ showPpr scrutTy) scrutTy++    cantCreate :: String -> String -> Type -> a+    cantCreate loc info scrutTy = error $ loc ++ "Can't create selector " ++ show (caller,dcI,fieldI) ++ " for: (" ++ showPpr scrut ++ " :: " ++ showPpr scrutTy ++ ")\nAdditional info: " ++ info++-- | Make a binder that should not be referenced+mkWildValBinder+  :: (MonadUnique m)+  => InScopeSet+  -> Type+  -> m Id+mkWildValBinder is = mkInternalVar is "wild"++-- | Make a new, unique, identifier+mkInternalVar+  :: (MonadUnique m)+  => InScopeSet+  -> OccName+  -- ^ Name of the identifier+  -> KindOrType+  -> m Id+mkInternalVar inScope name ty = do+  i <- getUniqueM+  let nm = mkUnsafeInternalName name i+  return (uniqAway inScope (mkLocalId ty nm))
+ src/Clash/Core/Var.hs view
@@ -0,0 +1,146 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                     2017-2018, Google Inc.+                          2021, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Variables in CoreHW+-}++{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++module Clash.Core.Var+  ( Var (..)+  , IdScope (..)+  , Id+  , TyVar+  , mkId+  , mkLocalId+  , mkGlobalId+  , mkTyVar+  , setIdScope+  , modifyVarName+  , isGlobalId+  , isLocalId+  )+where+++import Control.DeepSeq                  (NFData (..))+import Data.Binary                      (Binary)+import Data.Function                    (on)+import Data.Hashable                    (Hashable(hashWithSalt))+import GHC.Generics                     (Generic)+import Clash.Core.Name                  (Name (..))+import {-# SOURCE #-} Clash.Core.Term   (Term, TmName)+import {-# SOURCE #-} Clash.Core.Type   (Kind, Type, TyName)+import Clash.Unique++-- | Variables in CoreHW+data Var a+  -- | Constructor for type variables+  = TyVar+  { varName :: !(Name a)+  , varUniq :: {-# UNPACK #-} !Unique+  -- ^ Invariant: forall x . varUniq x ~ nameUniq (varName x)+  , varType :: Kind+  }+  -- | Constructor for term variables+  | Id+  { varName :: !(Name a)+  , varUniq :: {-# UNPACK #-} !Unique+  -- ^ Invariant: forall x . varUniq x ~ nameUniq (varName x)+  , varType :: Type+  , idScope :: IdScope+  }+  deriving (Show,Generic,NFData,Binary)++-- | Gets a _key_ in the DBMS sense: a value that uniquely identifies a+-- Var. In case of a "Var" that is its unique and (if applicable) scope+varKey :: Var a -> (Unique, Maybe IdScope)+varKey TyVar{varUniq} = (varUniq, Nothing)+varKey Id{varUniq,idScope} = (varUniq, Just idScope)++instance Hashable (Var a) where+  hashWithSalt salt a = hashWithSalt salt (varKey a)++instance Eq (Var a) where+  (==) = (==) `on` varKey+  (/=) = (/=) `on` varKey++instance Ord (Var a) where+  compare = compare `on` varKey++instance Uniquable (Var a) where+  getUnique = varUniq+  setUnique var u = var {varUniq=u, varName=(varName var){nameUniq=u}}++data IdScope = GlobalId | LocalId+  deriving (Show,Generic,NFData,Hashable,Binary,Eq,Ord)++-- | Term variable+type Id    = Var Term+-- | Type variable+type TyVar = Var Type++-- | Change the name of a variable+modifyVarName ::+  (Name a -> Name a)+  -> Var a+  -> Var a+modifyVarName f (TyVar n _ k) =+  let n' = f n+  in  TyVar n' (nameUniq n') k+modifyVarName f (Id n _ t s) =+  let n' = f n+  in  Id n' (nameUniq n') t s++-- | Make a type variable+mkTyVar+  :: Kind+  -> TyName+  -> TyVar+mkTyVar tyKind tyName = TyVar tyName (nameUniq tyName) tyKind++-- | Make a term variable+mkId+  :: Type+  -> IdScope+  -> TmName+  -> Id+mkId tmType scope tmName = Id tmName (nameUniq tmName) tmType scope++mkLocalId+  :: Type+  -> TmName+  -> Id+mkLocalId tmType tmName = Id tmName (nameUniq tmName) tmType LocalId++mkGlobalId+  :: Type+  -> TmName+  -> Id+mkGlobalId tmType tmName = Id tmName (nameUniq tmName) tmType GlobalId++isGlobalId+  :: Var a+  -> Bool+isGlobalId (Id {idScope = GlobalId}) = True+isGlobalId _ = False++isLocalId+  :: Var a+  -> Bool+isLocalId (Id {idScope = LocalId}) = True+isLocalId _  = False++setIdScope+  :: IdScope+  -> Var a+  -> Var a+setIdScope s (Id nm u t _) = Id nm u t s+setIdScope _ v = v
+ src/Clash/Core/VarEnv.hs view
@@ -0,0 +1,656 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Core.VarEnv+  ( -- * Environment with variables as keys+    VarEnv+    -- ** Accessors+    -- *** Size information+  , nullVarEnv+    -- ** Indexing+  , lookupVarEnv+  , lookupVarEnv'+  , lookupVarEnvDirectly+    -- ** Construction+  , emptyVarEnv+  , unitVarEnv+  , mkVarEnv+    -- ** Modification+  , extendVarEnv+  , extendVarEnvList+  , extendVarEnvWith+  , delVarEnv+  , delVarEnvList+  , unionVarEnv+  , unionVarEnvWith+  , differenceVarEnv+    -- ** Element-wise operations+    -- *** Mapping+  , mapVarEnv+  , mapMaybeVarEnv+    -- ** Folding+  , foldlWithUniqueVarEnv'+    -- ** Working with predicates+    -- *** Searching+  , elemVarEnv+  , notElemVarEnv+    -- ** Conversions+    -- *** Lists+  , eltsVarEnv+    -- * Sets of variables+  , VarSet+    -- ** Construction+  , emptyVarSet+  , unitVarSet+    -- ** Modification+  , delVarSetByKey+  , unionVarSet+  , differenceVarSet+    -- ** Working with predicates+  , nullVarSet+    -- *** Searching+  , elemVarSet+  , notElemVarSet+  , subsetVarSet+  , disjointVarSet+    -- ** Conversions+    -- *** Lists+  , mkVarSet+  , eltsVarSet+    -- * In-scope sets+  , InScopeSet+    -- ** Accessors+    -- *** Size information+  , emptyInScopeSet+    -- *** Indexing+  , lookupInScope+    -- ** Construction+  , mkInScopeSet+    -- ** Modification+  , extendInScopeSet+  , extendInScopeSetList+  , unionInScope+    -- ** Working with predicates+    -- *** Searching+  , elemInScopeSet+  , elemUniqInScopeSet+  , notElemInScopeSet+  , varSetInScope+    -- ** Unique generation+  , uniqAway+  , uniqAway'+    -- * Dual renaming+  , RnEnv+    -- ** Construction+  , mkRnEnv+    -- ** Renaming+  , rnTmBndr+  , rnTyBndr+  , rnTmBndrs+  , rnTyBndrs+  , rnOccLId+  , rnOccRId+  , rnOccLTy+  , rnOccRTy+  )+where++#if MIN_VERSION_ghc(9,8,4) || (MIN_VERSION_ghc(9,6,7) && !MIN_VERSION_ghc(9,8,0))+#define UNIQUE_IS_WORD64+#endif++import           Control.DeepSeq           (NFData)+import           Data.Binary               (Binary)+import           Data.Coerce               (coerce)+import qualified Data.List                 as List+import qualified Data.List.Extra           as List+import           Data.Maybe                (fromMaybe)+#ifdef UNIQUE_IS_WORD64+import           Data.Word                 (Word64)+#endif++#if MIN_VERSION_prettyprinter(1,7,0)+import           Prettyprinter+#else+import           Data.Text.Prettyprint.Doc+#endif++import           GHC.Exts                  (Any)+import           GHC.Generics              (Generic)+import           GHC.Stack                 (HasCallStack)++import           Clash.Core.Pretty         ()+import           Clash.Core.Var+import           Clash.Data.UniqMap        (UniqMap)+import qualified Clash.Data.UniqMap as UniqMap+import           Clash.Debug               (debugIsOn)+import           Clash.Unique+import           Clash.Util+import           Clash.Pretty++-- * VarEnv++-- | Map indexed by variables+type VarEnv a = UniqMap a++-- | Empty map+emptyVarEnv+  :: VarEnv a+emptyVarEnv = UniqMap.empty++-- | Environment containing a single variable-value pair+unitVarEnv+  :: Var b+  -> a+  -> VarEnv a+unitVarEnv = UniqMap.singleton++-- | Look up a value based on the variable+lookupVarEnv+  :: Var b+  -> VarEnv a+  -> Maybe a+lookupVarEnv = UniqMap.lookup++-- | Lookup a value based on the unique of a variable+lookupVarEnvDirectly+  :: Unique+  -> VarEnv a+  -> Maybe a+lookupVarEnvDirectly = UniqMap.lookup++-- | Lookup a value based on the variable+--+-- Errors out when the variable is not present+lookupVarEnv'+  :: HasCallStack+  => VarEnv a+  -> Var b+  -> a+lookupVarEnv' = flip UniqMap.find++-- | Remove a variable-value pair from the environment+delVarEnv+  :: VarEnv a+  -> Var b+  -> VarEnv a+delVarEnv = flip UniqMap.delete++-- | Remove a list of variable-value pairs from the environment+delVarEnvList+  :: VarEnv a+  -> [Var b]+  -> VarEnv a+delVarEnvList = flip UniqMap.deleteMany++-- | Add a variable-value pair to the environment; overwrites the value if the+-- variable already exists+extendVarEnv+  :: Var b+  -> a+  -> VarEnv a+  -> VarEnv a+extendVarEnv = UniqMap.insert++-- | Add a variable-value pair to the environment; if the variable already+-- exists, the two values are merged with the given function+extendVarEnvWith+  :: Var b+  -> a+  -> (a -> a -> a)+  -> VarEnv a+  -> VarEnv a+extendVarEnvWith k v f =+  UniqMap.insertWith f k v++-- | Add a list of variable-value pairs; the values of existing keys will be+-- overwritten+extendVarEnvList+  :: VarEnv a+  -> [(Var b, a)]+  -> VarEnv a+extendVarEnvList = flip UniqMap.insertMany++-- | Is the environment empty+nullVarEnv+  :: VarEnv a+  -> Bool+nullVarEnv = UniqMap.null++-- | Get the (left-biased) union of two environments+unionVarEnv+  :: VarEnv a+  -> VarEnv a+  -> VarEnv a+unionVarEnv = (<>)++-- | Get the union of two environments, mapped values existing in both+-- environments will be merged with the given function.+unionVarEnvWith+  :: (a -> a -> a)+  -> VarEnv a+  -> VarEnv a+  -> VarEnv a+unionVarEnvWith = UniqMap.unionWith++-- | Filter the first varenv to only contain keys which are not in the second varenv.+differenceVarEnv+  :: VarEnv a+  -> VarEnv a+  -> VarEnv a+differenceVarEnv = UniqMap.difference++-- | Create an environment given a list of var-value pairs+mkVarEnv+  :: [(Var a,b)]+  -> VarEnv b+mkVarEnv = UniqMap.fromList++-- | Apply a function to every element in the environment+mapVarEnv+  :: (a -> b)+  -> VarEnv a+  -> VarEnv b+mapVarEnv = fmap++-- | Apply a function to every element in the environment; values for which the+-- function returns 'Nothing' are removed from the environment+mapMaybeVarEnv+  :: (a -> Maybe b)+  -> VarEnv a+  -> VarEnv b+mapMaybeVarEnv = UniqMap.mapMaybe++-- | Strict left-fold over an environment using both the unique of the+-- the variable and the value+foldlWithUniqueVarEnv'+  :: (a -> Unique -> b -> a)+  -> a+  -> VarEnv b+  -> a+foldlWithUniqueVarEnv' = UniqMap.foldlWithUnique'++-- | Extract the elements+eltsVarEnv+  :: VarEnv a+  -> [a]+eltsVarEnv = UniqMap.elems++-- | Does the variable exist in the environment+elemVarEnv+  :: Var a+  -> VarEnv b+  -> Bool+elemVarEnv = UniqMap.elem++-- | Does the variable not exist in the environment+notElemVarEnv+  :: Var a+  -> VarEnv b+  -> Bool+notElemVarEnv = UniqMap.notElem++-- * VarSet++-- | Set of variables+type VarSet = UniqMap (Var Any)++-- | The empty set+emptyVarSet+  :: VarSet+emptyVarSet = UniqMap.empty++-- | The set of a single variable+unitVarSet+  :: Var a+  -> VarSet+unitVarSet v = UniqMap.singletonUnique (coerce v)++-- | Add a variable to the set+extendVarSet+  :: VarSet+  -> Var a+  -> VarSet+extendVarSet env v = UniqMap.insertUnique (coerce v) env++-- | Union two sets+unionVarSet+  :: VarSet+  -> VarSet+  -> VarSet+unionVarSet = (<>)++-- | Take the difference of two sets+differenceVarSet+  :: VarSet+  -> VarSet+  -> VarSet+differenceVarSet = UniqMap.difference++-- | Is the variable an element in the set+elemVarSet+  :: Var a+  -> VarSet+  -> Bool+elemVarSet v = UniqMap.elem (getUnique v)++-- | Is the variable not an element in the set+notElemVarSet+  :: Var a+  -> VarSet+  -> Bool+notElemVarSet v = UniqMap.notElem (getUnique v)++-- | Is the set of variables A a subset of the variables B+subsetVarSet+  :: VarSet+  -- ^ Set of variables A+  -> VarSet+  -- ^ Set of variables B+  -> Bool+subsetVarSet = UniqMap.submap++-- | Are the sets of variables disjoint+disjointVarSet+  :: VarSet+  -> VarSet+  -> Bool+disjointVarSet = UniqMap.disjoint++-- | Check whether a varset is empty+nullVarSet+  :: VarSet+  -> Bool+nullVarSet = UniqMap.null++-- | Look up a variable in the set, returns it if it exists+lookupVarSet+  :: Var a+  -> VarSet+  -> Maybe (Var Any)+lookupVarSet = UniqMap.lookup++-- | Remove a variable from the set based on its 'Unique'+delVarSetByKey+  :: Unique+  -> VarSet+  -> VarSet+delVarSetByKey = UniqMap.delete++-- | Create a set from a list of variables+mkVarSet+  :: [Var a]+  -> VarSet+mkVarSet xs = UniqMap.fromList $ fmap (\x -> (getUnique x, coerce x)) xs++eltsVarSet+  :: VarSet+  -> [Var Any]+eltsVarSet = UniqMap.elems++-- * InScopeSet++type Seed+#ifdef UNIQUE_IS_WORD64+  = Word64+#else+  = Int+#endif++-- | Set of variables that is in scope at some point+--+-- The 'Seed' is a kind of hash-value used to generate new uniques. It should+-- never be zero+--+-- See "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 for the+-- motivation+data InScopeSet = InScopeSet VarSet {-# UNPACK #-} !Seed+  deriving (Generic, NFData, Binary)++instance ClashPretty InScopeSet where+  clashPretty (InScopeSet s _) = clashPretty s++-- | The empty set+extendInScopeSet+  :: InScopeSet+  -> Var a+  -> InScopeSet+extendInScopeSet (InScopeSet inScope n) v =+  InScopeSet (extendVarSet inScope v) (n + 1)++-- | Add a list of variables in scope+extendInScopeSetList+  :: InScopeSet+  -> [Var a]+  -> InScopeSet+extendInScopeSetList (InScopeSet inScope n) vs =+  InScopeSet (List.foldl' extendVarSet inScope vs) (n + fromIntegral (length vs))++-- | Union two sets of in scope variables+unionInScope+  :: InScopeSet+  -> InScopeSet+  -> InScopeSet+unionInScope (InScopeSet s1 _) (InScopeSet s2 n2)+  = InScopeSet (s1 `unionVarSet` s2) n2++-- | Is the set of variables in scope+varSetInScope+  :: VarSet+  -> InScopeSet+  -> Bool+varSetInScope vars (InScopeSet s1 _)+  = vars `subsetVarSet` s1++-- | Look up a variable in the 'InScopeSet'. This gives you the canonical+-- version of the variable+lookupInScope+  :: InScopeSet+  -> Var a+  -> Maybe (Var Any)+lookupInScope (InScopeSet s _) v = lookupVarSet v s++-- | Is the variable in scope+elemInScopeSet+  :: Var a+  -> InScopeSet+  -> Bool+elemInScopeSet v (InScopeSet s _) = elemVarSet v s++-- | Check whether an element exists in the set based on the `Unique` contained+-- in that element+elemUniqInScopeSet+  :: Unique+  -> InScopeSet+  -> Bool+elemUniqInScopeSet u (InScopeSet s _) = UniqMap.elem u s++-- | Is the variable not in scope+notElemInScopeSet+  :: Var a+  -> InScopeSet+  -> Bool+notElemInScopeSet v (InScopeSet s _) = notElemVarSet v s++-- | Create a set of variables in scope+mkInScopeSet+  :: VarSet+  -> InScopeSet+mkInScopeSet is = InScopeSet is 1++-- | The empty set+emptyInScopeSet+  :: InScopeSet+emptyInScopeSet = mkInScopeSet emptyVarSet++-- | Ensure that the 'Unique' of a variable does not occur in the 'InScopeSet'+uniqAway+  :: (Uniquable a, ClashPretty a)+  => InScopeSet+  -> a+  -> a+uniqAway (InScopeSet set n) a =+  uniqAway' (`UniqMap.elem` set) n a++uniqAway'+  :: (Uniquable a, ClashPretty a)+  => (Unique -> Bool)+  -- ^ Unique in scope test+  -> Seed+  -- ^ Seed+  -> a+  -> a+uniqAway' inScopeTest n u =+  if inScopeTest (getUnique u) then+    try 1+  else+    u+ where+  origUniq = getUnique u+  try k+    | debugIsOn && k > 1000+    = pprPanic "uniqAway loop:" msg+    | inScopeTest uniq+    = try (k + 1)+    | k > 3+    = pprTraceDebug "uniqAway:" msg (setUnique u uniq)+    | otherwise+    = setUnique u uniq+    where+      msg  = fromPretty k <+> "tries" <+> clashPretty u <+> fromPretty n+      uniq = deriveUnique origUniq (n * k)++deriveUnique+  :: Unique+  -> Seed+  -> Unique+deriveUnique i delta = i + delta++-- * RnEnv++-- | Rename environment for e.g. alpha equivalence+--+-- When going under binders for e.g.+--+-- @+-- \x -> e1  `aeq` \y -> e2+-- @+--+-- We want to rename @[x -> y]@  or @[y -> x]@, but we have to pick a binder+-- that is neither free in @e1@ nor @e2@ or we risk accidental capture.+--+-- So we must maintain:+--+--   1. A renaming for the left term+--+--   2. A renaming for the right term+--+--   3. A set of in scope variables+data RnEnv+  = RnEnv+  { rn_envLTy  :: VarEnv TyVar+    -- ^ Type renaming for the left term+  , rn_envLTm  :: VarEnv Id+    -- ^ Term renaming for the left term+  , rn_envRTy  :: VarEnv TyVar+    -- ^ Type renaming for the right term+  , rn_envRTm  :: VarEnv Id+    -- ^ Term renaming for the right term+  , rn_inScope :: InScopeSet+    -- ^ In scope in left or right terms+  }++-- | Create an empty renaming environment+mkRnEnv+  :: InScopeSet -> RnEnv+mkRnEnv vars+  = RnEnv+  { rn_envLTy  = emptyVarEnv+  , rn_envLTm  = emptyVarEnv+  , rn_envRTy  = emptyVarEnv+  , rn_envRTm  = emptyVarEnv+  , rn_inScope = vars+  }++-- | Look up the renaming of an type-variable occurrence in the left term+rnOccLTy+  :: RnEnv -> TyVar -> TyVar+rnOccLTy rn v = fromMaybe v (lookupVarEnv v (rn_envLTy rn))++-- | Look up the renaming of an type-variable occurrence in the right term+rnOccRTy+  :: RnEnv -> TyVar -> TyVar+rnOccRTy rn v = fromMaybe v (lookupVarEnv v (rn_envRTy rn))++-- | Simultaneously go under the type-variable binder /bTvL/ and type-variable+-- binder /bTvR/, finds a new binder /newTvB/, and return an environment mapping+-- @[bTvL -> newB]@ and @[bTvR -> newB]@+rnTyBndr+  :: RnEnv -> TyVar -> TyVar -> RnEnv+rnTyBndr rv@(RnEnv {rn_envLTy = lenv, rn_envRTy = renv, rn_inScope = inScope}) bL bR =+  rv { rn_envLTy = extendVarEnv bL newB lenv -- See Note [Rebinding and shadowing]+     , rn_envRTy = extendVarEnv bR newB renv+     , rn_inScope = extendInScopeSet inScope newB }+ where+  -- Find a new type-binder not in scope in either term+  newB | not (bL `elemInScopeSet` inScope) = bL+       | not (bR `elemInScopeSet` inScope) = bR+       | otherwise                         = uniqAway inScope bL++{- Note [Rebinding and shadowing]+Imagine:++@+\x -> \x -> e1  `aeq` \y -> \x -> e2+@++Then inside++@+\x \y  { [x->p] [y->p]  {p} }+\x \z  { [x->q] [y->p, z->q] {p,q} }+@++i.e. if the new var is the same as the old var, the renaming is deleted by+'extendVarEnv'+-}++-- | Applies 'rnTyBndr' to several variables: the two variable lists must be of+-- equal length.+rnTyBndrs+  :: RnEnv -> [TyVar] -> [TyVar] -> RnEnv+rnTyBndrs env tvs1 tvs2 =+  List.foldl' (\s (l,r) -> rnTyBndr s l r) env (List.zipEqual tvs1 tvs2)++-- | Look up the renaming of an occurrence in the left term+rnOccLId+  :: RnEnv -> Id -> Id+rnOccLId rn v = fromMaybe v (lookupVarEnv v (rn_envLTm rn))++-- | Look up the renaming of an occurrence in the left term+rnOccRId+  :: RnEnv -> Id -> Id+rnOccRId rn v = fromMaybe v (lookupVarEnv v (rn_envRTm rn))++-- | Simultaneously go under the binder /bL/ and binder /bR/, finds a new binder+-- /newTvB/, and return an environment mapping @[bL -> newB]@ and @[bR -> newB]@+rnTmBndr+  :: RnEnv -> Id -> Id -> RnEnv+rnTmBndr rv@(RnEnv {rn_envLTm = lenv, rn_envRTm = renv, rn_inScope = inScope}) bL bR =+  rv { rn_envLTm = extendVarEnv bL newB lenv -- See Note [Rebinding and shadowing]+     , rn_envRTm = extendVarEnv bR newB renv+     , rn_inScope = extendInScopeSet inScope newB }+ where+  -- Find a new type-binder not in scope in either term+  newB | not (bL `elemInScopeSet` inScope) = bL+       | not (bR `elemInScopeSet` inScope) = bR+       | otherwise                         = uniqAway inScope bL++-- | Applies 'rnTmBndr' to several variables: the two variable lists must be of+-- equal length.+rnTmBndrs+  :: RnEnv -> [Id] -> [Id] -> RnEnv+rnTmBndrs env ids1 ids2 =+  List.foldl' (\s (l,r) -> rnTmBndr s l r) env (List.zipEqual ids1 ids2)
+ src/Clash/Data/UniqMap.hs view
@@ -0,0 +1,250 @@+{-+Copyright   : (C) 2016-2021 QBayLogic B.V.+                       2022 Alexander McKenna+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Data.UniqMap+  ( UniqMap(..)+  , empty+  , singleton+  , singletonUnique+  , null+  , insert+  , insertUnique+  , insertWith+  , insertMany+  , lookup+  , find+  , elem+  , notElem+  , filter+  , mapMaybe+  , foldrWithUnique+  , foldlWithUnique'+  , delete+  , deleteMany+  , unionWith+  , difference+  , disjoint+  , submap+  , fromList+  , toList+  , keys+  , elems+  ) where++#if MIN_VERSION_ghc(9,8,4) || (MIN_VERSION_ghc(9,6,7) && !MIN_VERSION_ghc(9,8,0))+#define UNIQUE_IS_WORD64+#endif++import           Prelude hiding (elem, filter, lookup, notElem, null)++import           Control.DeepSeq (NFData)+import           Data.Binary (Binary (..))+import           Data.Bifunctor (first)+import           Data.Function (on)+#ifdef UNIQUE_IS_WORD64+import           GHC.Data.Word64Map.Strict (Word64Map)+import qualified GHC.Data.Word64Map.Strict as IntMap+#else+import           Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+#endif+import qualified Data.List as List (foldl')++#if MIN_VERSION_prettyprinter(1,7,0)+import           Prettyprinter+#else+import           Data.Text.Prettyprint.Doc+#endif++import           Clash.Pretty+import           Clash.Unique (Unique, Uniquable(getUnique))++-- | A map indexed by a 'Unique'. Typically the elements of this map are also+-- uniqueable and provide their own key, however a unique can be associated+-- with any value.+newtype UniqMap a+#ifdef UNIQUE_IS_WORD64+  = UniqMap { uniqMapToIntMap :: Word64Map a }+#else+  = UniqMap { uniqMapToIntMap :: IntMap a }+#endif+  deriving stock Traversable+  deriving newtype+    ( Foldable+    , Functor+    , Monoid+    , NFData+    , Semigroup+    , Show+    )+#ifdef UNIQUE_IS_WORD64+instance Binary a => Binary (UniqMap a) where+  put (UniqMap m) = put (IntMap.size m) <> mapM_ put (IntMap.toAscList m)+  get             = fmap (UniqMap . IntMap.fromDistinctAscList) get+#else+  deriving newtype Binary+#endif++instance ClashPretty a => ClashPretty (UniqMap a) where+  clashPretty xs =+    brackets $ fillSep $ punctuate comma $+      [ fromPretty k <+> ":->" <+> clashPretty v+      | (k, v) <- toList xs+      ]++-- | An empty map.+empty :: UniqMap a+empty =+  UniqMap IntMap.empty++{-# SPECIALIZE singleton :: Unique -> b -> UniqMap b #-}+-- | A map containing a single value indexed by the given key's unique.+singleton :: Uniquable a => a -> b -> UniqMap b+singleton k v =+  UniqMap (IntMap.singleton (getUnique k) v)++{-# SPECIALIZE singletonUnique :: Unique -> UniqMap Unique #-}+-- | A map containing a single value indexed by the value's unique.+singletonUnique :: Uniquable a => a -> UniqMap a+singletonUnique v =+  singleton (getUnique v) v++-- | Check if the map is empty.+null :: UniqMap a -> Bool+null =+  IntMap.null . uniqMapToIntMap++{-# SPECIALIZE insert :: Unique -> b -> UniqMap b -> UniqMap b #-}+-- | Insert a new key-value pair into the map.+insert :: Uniquable a => a -> b -> UniqMap b -> UniqMap b+insert k v =+  UniqMap . IntMap.insert (getUnique k) v . uniqMapToIntMap++{-# SPECIALIZE insertUnique :: Unique -> UniqMap Unique -> UniqMap Unique #-}+-- | Insert a new value into the map, using the unique of the value as the key.+insertUnique :: Uniquable a => a -> UniqMap a -> UniqMap a+insertUnique v =+  insert (getUnique v) v++-- | Insert a new key-value pair into the map, using the given combining+-- function if there is already an entry with the same unique in the map.+insertWith :: Uniquable a => (b -> b -> b) -> a -> b -> UniqMap b -> UniqMap b+insertWith f k v =+  UniqMap . IntMap.insertWith f (getUnique k) v . uniqMapToIntMap++-- | Insert a list of key-value pairs into the map.+insertMany :: Uniquable a => [(a, b)] -> UniqMap b -> UniqMap b+insertMany kvs xs =+  List.foldl' (\acc (k, v) -> insert k v acc) xs kvs++{-# SPECIALIZE lookup :: Unique -> UniqMap b -> Maybe b #-}+-- | Lookup an item in the map, using the unique of the given key.+lookup :: Uniquable a => a -> UniqMap b -> Maybe b+lookup k =+  IntMap.lookup (getUnique k) . uniqMapToIntMap++{-# SPECIALIZE find :: Unique -> UniqMap b -> b #-}+-- | Lookup and item in the map, using the unique of the given key. If the item+-- is not found in the map an error is raised.+find :: Uniquable a => a -> UniqMap b -> b+find k =+  let notFound =+        error ("find: Key " <> show (getUnique k) <> " is not in the UniqMap")+   in IntMap.findWithDefault notFound (getUnique k) . uniqMapToIntMap++{-# SPECIALIZE elem :: Unique -> UniqMap b -> Bool #-}+-- | Check if there is an entry in the map for the unique of the given value.+elem :: Uniquable a => a -> UniqMap b -> Bool+elem k =+  IntMap.member (getUnique k) . uniqMapToIntMap++{-# SPECIALIZE notElem :: Unique -> UniqMap b -> Bool #-}+-- | Check if there is not an entry in the map for the unique of the given+-- value.+notElem :: Uniquable a => a -> UniqMap b -> Bool+notElem k =+  IntMap.notMember (getUnique k) . uniqMapToIntMap++-- | Filter all elements in the map according to some predicate.+filter :: (b -> Bool) -> UniqMap b -> UniqMap b+filter p =+  UniqMap . IntMap.filter p . uniqMapToIntMap++-- | Apply a function to all elements in the map, keeping those where the+-- result is not @Nothing@.+mapMaybe :: (a -> Maybe b) -> UniqMap a -> UniqMap b+mapMaybe f =+  UniqMap . IntMap.mapMaybe f . uniqMapToIntMap++-- | Lazily right-fold over the map using the given function.+foldrWithUnique :: (Unique -> a -> b -> b) -> b -> UniqMap a -> b+foldrWithUnique f x =+  IntMap.foldrWithKey f x . uniqMapToIntMap++-- | Strictly left-fold over the map using the given function.+foldlWithUnique' :: (b -> Unique -> a -> b) -> b -> UniqMap a -> b+foldlWithUnique' f x =+  IntMap.foldlWithKey' f x . uniqMapToIntMap++{-# SPECIALIZE delete :: Unique -> UniqMap b -> UniqMap b #-}+-- | Delete the entry in the map indexed by the unique of the given value.+delete :: Uniquable a => a -> UniqMap b -> UniqMap b+delete k =+  UniqMap . IntMap.delete (getUnique k) . uniqMapToIntMap++-- | Delete all entries in the map indexed by the uniques of the given values.+deleteMany :: Uniquable a => [a] -> UniqMap b -> UniqMap b+deleteMany ks xs =+  List.foldl' (\acc k -> delete k acc) xs ks++-- | Merge two unique maps, using the given combining funcion if a value with+-- the same unique key exists in both maps.+unionWith :: (b -> b -> b) -> UniqMap b -> UniqMap b -> UniqMap b+unionWith f xs ys =+  UniqMap ((IntMap.unionWith f `on` uniqMapToIntMap) xs ys)++-- | Filter the first map to only contain keys which are not in the second map.+difference :: UniqMap b -> UniqMap b -> UniqMap b+difference xs ys =+  UniqMap ((IntMap.difference `on` uniqMapToIntMap) xs ys)++-- | Check if there are no common keys between two maps.+disjoint :: UniqMap b -> UniqMap b -> Bool+disjoint =+  IntMap.disjoint `on` uniqMapToIntMap++-- | Check if one map is a submap of another.+submap :: UniqMap b -> UniqMap b -> Bool+submap =+  -- We only check that the keys of the map make it a submap, the elements do+  -- not need to be equal. Maybe this should be changed?+  IntMap.isSubmapOfBy (\_ _ -> True) `on` uniqMapToIntMap++{-# SPECIALIZE fromList :: [(Unique, b)] -> UniqMap b #-}+-- | Convert a list of key-value pairs to a map.+fromList :: Uniquable a => [(a, b)] -> UniqMap b+fromList =+  UniqMap . IntMap.fromList . fmap (first getUnique)++-- | Convert a map to a list of unique-value pairs.+toList :: UniqMap b -> [(Unique, b)]+toList =+  IntMap.toList . uniqMapToIntMap++-- | Get the unique keys of a map.+keys :: UniqMap b -> [Unique]+keys =+  IntMap.keys . uniqMapToIntMap++-- | Get the values of a map.+elems :: UniqMap b -> [b]+elems =+  IntMap.elems . uniqMapToIntMap
+ src/Clash/DataFiles.hs view
@@ -0,0 +1,63 @@+{-|+Copyright   :  (C) 2022     , Google Inc.+License     :  BSD2 (see the file LICENSE)+Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++This module provides a way to access static files that are useful when working+with Clash designs.+-}++module Clash.DataFiles where++import System.FilePath ((</>))++import Paths_clash_lib (getDataFileName)++{- | The Tcl Connector: a Tcl script that can parse Clash output and emit the+  correct commands for loading the design into Vivado (Quartus support will be+  added later).++  Apart from parsing the @clash-manifest.json@ files produced by Clash, the Tcl+  Connector also supports the so-called /Clash\<->Tcl API/. This functionality+  enables Clash primitives to pass complex instructions to the Tcl Connector.+  Current features are instantiating IP in Vivado and passing metadata along+  with Vivado XDC files.++  An example use of the Tcl Connector, demonstrating its basic features:++  > source -notrace clashConnector.tcl+  > # Pass it the path to "clash-manifest.json" of your top entity+  > clash::readMetadata vhdl/Design.topEntity+  > # Instantiate IP (no-op if no IP defined)+  > file mkdir ip+  > clash::createAndReadIp -dir ip+  > # Read all VHDL/Verilog/SystemVerilog files generated by Clash+  > clash::readHdl+  > # Handle XDC files, in correct order+  > clash::readXdc early+  > # A file containing PACKAGE_PIN and IOSTANDARD definitions (but not+  > # create_clock, clocks are part of the Clash-generated files)+  > read_xdc Arty-A7-35-Master.xdc+  > set_property USED_IN implementation [get_files Arty-A7-35-Master.xdc]+  > clash::readXdc {normal late}+  > synth_design -top $clash::topEntity -part xc7a35ticsg324-1L+  > opt_design+  > place_design+  > route_design+  > write_bitstream ${clash::topEntity}.bit++  "Clash.Xilinx.ClockGen" and @clash-cores:Clash.Cores.Xilinx@+  modules make use of the IP instantiating functionality; XDC metadata+  functionality is not currently used as the IP is already packaged with correct+  constraints by Vivado.++  More documentation about the Tcl Connector and the Clash\<->Tcl API will be+  made available later.++  In addition to this module, you can also write a copy of the Tcl script to a+  file by invoking++  > cabal run clash-lib:static-files -- --tcl-connector clashConnector.tcl+-}+tclConnector :: IO FilePath+tclConnector = getDataFileName $ "data-files" </> "tcl" </> "clashConnector.tcl"
+ src/Clash/Debug.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE CPP #-}++module Clash.Debug+  ( debugIsOn+  , traceIf+  , module Debug.Trace+  ) where++import Debug.Trace++debugIsOn :: Bool+#if defined(DEBUG)+debugIsOn = True+#else+debugIsOn = False+#endif++-- | Performs trace when first argument evaluates to 'True'+traceIf :: Bool -> String -> a -> a+traceIf True  msg = trace msg+traceIf False _   = id+{-# INLINE traceIf #-}
+ src/Clash/Driver.hs view
@@ -0,0 +1,1058 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                     2016-2017, Myrtle Software Ltd,+                     2017     , QBayLogic, Google Inc.+                     2020-2024, QBayLogic,+                     2022     , Google Inc.++  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Module that connects all the parts of the Clash compiler library+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Driver where++import           Control.Concurrent               (MVar, modifyMVar, modifyMVar_, newMVar, withMVar)+import           Control.Concurrent.Async         (mapConcurrently_)+import           Control.DeepSeq+import           Control.Exception                (throw, Exception)+import qualified Control.Monad                    as Monad+import           Control.Monad                    (unless, foldM, forM)+import           Control.Monad.Catch              (MonadMask, MonadThrow (throwM))+import           Control.Monad.Extra              (whenM, ifM, unlessM)+import           Control.Monad.IO.Class           (MonadIO)+import           Control.Monad.State              (evalState, get)+import           Control.Monad.State.Strict       (State)+import qualified Control.Monad.State.Strict       as State+import qualified Crypto.Hash.SHA256               as Sha256+import           Data.Bifunctor                   (first, second)+import           Data.ByteString                  (ByteString)+import qualified Data.ByteString                  as ByteString+import qualified Data.ByteString.Lazy             as ByteStringLazy+import qualified Data.ByteString.Lazy.Char8       as ByteStringLazyChar8+import           Data.Char                        (isAscii, isAlphaNum)+import           Data.Default+import           Data.Hashable                    (hash)+import           Data.HashMap.Strict              (HashMap)+import qualified Data.HashMap.Strict              as HashMap+import qualified Data.HashSet                     as HashSet+import           Data.Proxy                       (Proxy(..))+import           Data.List                        (intercalate)+import qualified Data.List                        as List+import           Data.List.NonEmpty               (NonEmpty((:|)))+import qualified Data.List.NonEmpty               as NonEmpty+import           Data.Maybe                       (fromMaybe, maybeToList, mapMaybe)+import qualified Data.Map.Ordered                 as OMap+import           Data.Map.Ordered.Extra           ()+import           Data.Monoid                      (Ap(..))+import qualified Data.Text+import           Data.Text.Lazy                   (Text)+import qualified Data.Text.Lazy                   as Text+import           Data.Text.Lazy.Encoding          as Text+import qualified Data.Text.Lazy.IO                as Text+import           Data.Text.Prettyprint.Doc.Extra+  (Doc, LayoutOptions (..), PageWidth (..) , layoutPretty, renderLazy)+import qualified Data.Time.Clock                  as Clock+import           GHC.Stack                        (HasCallStack)+import qualified Language.Haskell.Interpreter     as Hint+import qualified Language.Haskell.Interpreter.Extension as Hint+import qualified Language.Haskell.Interpreter.Unsafe as Hint+import qualified System.Directory                 as Directory+import           System.Directory+  (doesPathExist, listDirectory, doesDirectoryExist, createDirectoryIfMissing,+   removeDirectoryRecursive, doesFileExist)+import           System.Environment               (getExecutablePath)+import           System.FilePath                  ((</>), (<.>), takeDirectory, takeFileName, isAbsolute)+import qualified System.FilePath                  as FilePath+import qualified System.IO                        as IO+import           System.IO.Temp+  (getCanonicalTemporaryDirectory, withTempDirectory)+import           Text.Trifecta.Result+  (Result(Success, Failure), _errDoc)++import           GHC.Builtin.Names                 (eqTyConKey, ipClassKey)++import           GHC.Types.SrcLoc                  (SrcSpan)+import           GHC.BasicTypes.Extra             ()++import           Clash.Annotations.Primitive+  (HDL (..))+import           Clash.Annotations.BitRepresentation.Internal+  (CustomReprs)+import           Clash.Annotations.TopEntity+  (TopEntity (..), PortName(PortName, PortProduct))+import           Clash.Annotations.TopEntity.Extra ()+import           Clash.Backend+import           Clash.Core.PartialEval as PE     (Evaluator)+import           Clash.Core.Evaluator.Types as WHNF (Evaluator)+import           Clash.Core.HasType+import           Clash.Core.Name                  (Name (..))+import           Clash.Core.Pretty                (PrettyOptions(..), showPpr')+import           Clash.Core.Type+  (Type(ForAllTy, LitTy, AnnType), TypeView(..), tyView, mkFunTy, LitTy(SymTy))+import           Clash.Core.TyCon                 (TyConMap)+import           Clash.Core.Util                  (shouldSplit)+import           Clash.Core.Var+  (Id, varName, varUniq, varType)+import           Clash.Core.VarEnv+  (elemVarEnv, emptyVarEnv, lookupVarEnv, lookupVarEnv', mkVarEnv, lookupVarEnvDirectly, eltsVarEnv, VarEnv)+import           Clash.Debug                      (debugIsOn)+import qualified Clash.Driver.BrokenGhcs          as BrokenGhcs+import           Clash.Driver.Types+import           Clash.Driver.Manifest+  (Manifest(..), readFreshManifest, UnexpectedModification, pprintUnexpectedModifications,+   mkManifest, writeManifest, manifestFilename)+import           Clash.Edalize.Edam+import           Clash.Netlist                    (genNetlist, genTopNames)+import           Clash.Netlist.BlackBox.Parser    (runParse)+import           Clash.Netlist.BlackBox.Types     (BlackBoxTemplate, BlackBoxFunction)+import qualified Clash.Netlist.Id                 as Id+import           Clash.Netlist.Types+  (IdentifierText, BlackBox (..), Component (..), FilteredHWType, HWMap, SomeBackend (..),+   TopEntityT(..), TemplateFunction, ComponentMap, findClocks, ComponentMeta(..))+import           Clash.Normalize                  (checkNonRecursive, cleanupGraph,+                                                   normalize, runNormalization)+import           Clash.Normalize.Util             (callGraph, tvSubstWithTyEq)+import qualified Clash.Primitives.Sized.Signed    as P+import qualified Clash.Primitives.Sized.ToInteger as P+import qualified Clash.Primitives.Sized.Vector    as P+import qualified Clash.Primitives.GHC.Int         as P+import qualified Clash.Primitives.GHC.Word        as P+import qualified Clash.Primitives.Intel.ClockGen  as P+import qualified Clash.Primitives.Magic           as P+import qualified Clash.Primitives.Verification    as P+import qualified Clash.Primitives.Xilinx.ClockGen as P+import           Clash.Primitives.Types+import           Clash.Signal.Internal+import           Clash.Unique                     (Unique, getUnique, fromGhcUnique)+import           Clash.Util+  (ClashException(..), reportTimeDiff,+   wantedLanguageExtensions, unwantedLanguageExtensions, curLoc)+import           Clash.Util.Graph                 (reverseTopSort)+import qualified Clash.Util.Interpolate           as I+import qualified Clash.Util.Supply                as Supply++-- | Worker function of 'splitTopEntityT'+splitTopAnn+  :: TyConMap+  -> SrcSpan+  -- ^ Source location of top entity (for error reporting)+  -> Type+  -- ^ Top entity body+  -> TopEntity+  -- ^ Port annotations for top entity+  -> TopEntity+  -- ^ New top entity with split ports (or the old one if not applicable)+splitTopAnn tcm sp typ@(tyView -> FunTy {}) t@Synthesize{t_inputs} =+  t{t_inputs=go typ t_inputs}+ where+  go :: Type -> [PortName] -> [PortName]+  go _ [] = []+  go (tyView -> FunTy a res) (p:ps)+   | shouldNotHavePortName a+     -- Insert dummy PortName for args for which the user shouldn't have+     -- to provide a name.+     -- Ideally this would be any (non Hidden{Clock,Reset,Enable}) constraint.+     -- But because we can't properly detect constraints,+     -- we only skip some specific one. see "shouldNotHavePortName"+     = PortName "" : go res (p:ps)+   | otherwise =+    case shouldSplit tcm a of+      Just (_,_,argTys@(_:_:_)) ->+        -- Port must be split up into 'n' pieces.. can it?+        case p of+          PortProduct nm portNames0 ->+            let+              n = length argTys+              newPortNames = map (PortName . show) [(0::Int)..]+              portNames1 = map (prependName nm) (portNames0 ++ newPortNames)+              newLam = foldr1 mkFunTy (argTys ++ [res])+            in+              go newLam (take n portNames1 ++ ps)+          PortName nm ->+            throw (flip (ClashException sp) Nothing $ [I.i|+              Couldn't separate clock, reset, or enable from a product type due+              to a malformed Synthesize annotation. All clocks, resets, and+              enables should be given a unique port name. Type to be split:++                #{showPpr' (PrettyOptions False True False False) a}++              Given port annotation: #{p}. You might want to use the+              following instead: PortProduct #{show nm} []. This allows Clash to+              autogenerate names based on the name #{show nm}.+            |])+      _ ->+        -- No need to split the port, carrying on..+        p : go res ps+  go (ForAllTy _tyVar ty) ps = go ty ps+  go _ty ps = ps++  prependName :: String -> PortName -> PortName+  prependName "" pn = pn+  prependName p (PortProduct nm ps) = PortProduct (p ++ "_" ++ nm) ps+  prependName p (PortName nm) = PortName (p ++ "_" ++ nm)++  -- Returns True for+  --   * type equality constraints (~)+  --   * HasCallStack+  shouldNotHavePortName :: Type -> Bool+  shouldNotHavePortName (tyView -> TyConApp (nameUniq -> tcUniq) tcArgs)+    | tcUniq == fromGhcUnique eqTyConKey = True+    | tcUniq == fromGhcUnique ipClassKey+    , [LitTy (SymTy "callStack"), _] <- tcArgs = True+  shouldNotHavePortName _ = False++splitTopAnn tcm sp (ForAllTy _tyVar typ) t = splitTopAnn tcm sp typ t+splitTopAnn tcm sp (AnnType _anns typ) t = splitTopAnn tcm sp typ t+splitTopAnn _tcm _sp _typ t = t++-- When splitting up a single argument into multiple arguments (see docs of+-- 'separateArguments') we should make sure to update TopEntity annotations+-- accordingly. See: https://github.com/clash-lang/clash-compiler/issues/1033+splitTopEntityT+  :: HasCallStack+  => TyConMap+  -> BindingMap+  -> TopEntityT+  -> TopEntityT+splitTopEntityT tcm bindingsMap tt@(TopEntityT id_ (Just t@(Synthesize {})) _) =+  case lookupVarEnv id_ bindingsMap of+    Just (Binding _id sp _ _ _ _) ->+      tt{topAnnotation=Just (splitTopAnn tcm sp (coreTypeOf id_) t)}+    Nothing ->+      error "Internal error in 'splitTopEntityT'. Please report as a bug."+splitTopEntityT _ _ t = t++-- | Remove constraints such as 'a ~ 3'.+removeForAll :: TopEntityT -> TopEntityT+removeForAll (TopEntityT var annM isTb) =+  TopEntityT var{varType=tvSubstWithTyEq (coreTypeOf var)} annM isTb++-- | Given a list of all found top entities and _maybe_ a top entity (+dependencies)+-- passed in by '-main-is', return the list of top entities Clash needs to+-- compile.+selectTopEntities :: [TopEntityT] -> Maybe (TopEntityT, [TopEntityT]) -> [TopEntityT]+selectTopEntities topEntities mainTopEntity =+  maybe topEntities (uncurry (:)) mainTopEntity++-- | Get modification data of current clash binary.+getClashModificationDate :: IO Clock.UTCTime+getClashModificationDate = Directory.getModificationTime =<< getExecutablePath++hdlFromBackend :: forall backend. Backend backend => Proxy backend -> HDL+hdlFromBackend _ = hdlKind (undefined :: backend)++replaceChar :: Char -> Char -> String -> String+replaceChar a b = map go+ where+  go c+    | c == a = b+    | otherwise = c++removeHistoryFile :: Maybe FilePath -> IO ()+removeHistoryFile =+  maybe (pure ()) removeHistory+ where+  removeHistory path =+    whenM (Directory.doesFileExist path) (Directory.removeFile path)++prefixModuleName+  :: HDL+  -> Maybe Data.Text.Text+  -> Maybe TopEntity+  -> String+  -> (String, Maybe String)+prefixModuleName hdl compPrefix annM modName =+  case compPrefix of+    Just (Data.Text.unpack -> p)+      | not (null p) -> case annM of+          Just ann ->+            let nm = p <> "_" <> t_name ann+             in (nm, Just nm)++          Nothing ->+            (p <> "_" <> modName, Just p)++      | Just ann <- annM -> case hdl of+          VHDL -> (t_name ann, Just modName)+          _ -> (t_name ann, Nothing)++    _ -> case annM of+      Just ann -> case hdl of+        VHDL -> (t_name ann, Just modName)+        _ -> (t_name ann, Just modName)+      _ -> (modName, Nothing)++-- | Create a set of target HDL files for a set of functions+generateHDL+  :: forall backend . Backend backend+  => ClashEnv+  -> ClashDesign+  -> Maybe backend+  -> (CustomReprs -> TyConMap -> Type ->+      State HWMap (Maybe (Either String FilteredHWType)))+  -- ^ Hardcoded 'Type' -> 'HWType' translator+  -> PE.Evaluator+  -- ^ Hardcoded evaluator for partial evaluation+  -> WHNF.Evaluator+  -- ^ Hardcoded evaluator for WHNF (old evaluator)+  -> Maybe (TopEntityT, [TopEntityT])+  -- ^ Main top entity to compile. If Nothing, all top entities in the+  -- 'ClashDesign' argument will be compiled.+  -> Clock.UTCTime+  -> IO ()+generateHDL env design hdlState typeTrans peEval eval mainTopEntity startTime = do+    let bindingsMap = designBindings design+    let tcm = envTyConMap env+    let topEntities0 = designEntities design+    let opts = envOpts env++    -- Detect "broken" GHCs and throw an error (unless silenced)+    unless (opt_ignoreBrokenGhcs opts) BrokenGhcs.assertWorking++    removeHistoryFile (dbg_historyFile (opt_debug opts))++    unless (opt_cachehdl opts) $+      putStrLn "Clash: Ignoring previously made caches"++    let topEntities1 = fmap (removeForAll . splitTopEntityT tcm bindingsMap)+                         (selectTopEntities topEntities0 mainTopEntity)+        hdl = hdlFromBackend (Proxy @backend)+        (compNames, initIs) = genTopNames opts hdl topEntities1+        (tes, deps) = sortTop bindingsMap topEntities1++    -- TODO This is here because of some minimal effort refactoring. At some+    -- point generateHDL should be better laid out so this can be closer to+    -- the few places it is needed.+    let topEntityMap = mkVarEnv (fmap (\x -> (topId x, x)) topEntities1)++    -- Data which is updated and used when updating the different top entities+    -- is kept in an MVar.+    idSet <- newMVar initIs+    edamFiles <- newMVar HashMap.empty+    ioLock <- newMVar ()++    let+      maybeMapConcurrently_+        | opt_concurrentTopEntities opts = mapConcurrently_+        | otherwise = mapM_++    maybeMapConcurrently_ (go compNames idSet edamFiles ioLock deps topEntityMap) tes++    time <- Clock.getCurrentTime+    let diff = reportTimeDiff time startTime+    putStrLn $ "Clash: Total compilation took " ++ diff+ where+  go+    :: VarEnv Id.Identifier+    -> MVar Id.IdentifierSet+    -> MVar (HashMap Unique [EdamFile])+    -> MVar ()+    -> HashMap Unique [Unique]+    -> VarEnv TopEntityT+    -> TopEntityT+    -> IO ()+  go compNames seenV edamFilesV ioLockV deps topEntityMap (TopEntityT topEntity annM isTb) = do+  let domainConfs = envDomains env+  let bindingsMap = designBindings design+  let primMap = envPrimitives env+  let topEntities0 = designEntities design+  let opts = envOpts env+  prevTime <- Clock.getCurrentTime+  let topEntityS = Data.Text.unpack (nameOcc (varName topEntity))++  withMVar ioLockV . const $+    putStrLn ("Clash: Compiling " ++ topEntityS)++  let modName1 = filter (\c -> isAscii c && (isAlphaNum c || c == '_')) (replaceChar '.' '_' topEntityS)++  modifyMVar_ seenV $ \seen ->+    pure $! State.execState (Id.addRaw (Data.Text.pack modName1)) seen++  let topNm = lookupVarEnv' compNames topEntity+      (modNameS, fmap Data.Text.pack -> prefixM) = prefixModuleName (hdlKind (undefined :: backend)) (opt_componentPrefix opts) annM modName1+      modNameT  = Data.Text.pack modNameS+      hdlState' = setDomainConfigurations domainConfs+                $ setModName modNameT+                $ setTopName topNm+                $ fromMaybe (initBackend @backend opts) hdlState+      hdlDir    = fromMaybe (Clash.Backend.name hdlState') (opt_hdlDir opts) </> topEntityS+      manPath   = hdlDir </> manifestFilename+      ite       = ifThenElseExpr hdlState'+      topNmT    = Id.toText topNm++  -- Get manifest file if cache is not stale and caching is enabled. This is used+  -- to prevent unnecessary recompilation.+  clashModDate <- getClashModificationDate+  (userModifications, maybeManifest, topHash) <-+    readFreshManifest topEntities0 (bindingsMap, topEntity) primMap opts clashModDate manPath++  let topEntityNames = map topId (eltsVarEnv topEntityMap)++  case maybeManifest of+    Just manifest0@Manifest{fileNames} | Just [] <- userModifications -> do+      -- Found a 'manifest' files. Use it to extend "seen" set. Generate EDAM+      -- files if necessary.+      withMVar ioLockV . const $+        putStrLn ("Clash: Using cached result for: " ++ topEntityS)++      modifyMVar_ seenV $ \seen ->+        pure $! State.execState (mapM_ Id.addRaw (componentNames manifest0)) seen++      fileNames1 <- modifyMVar edamFilesV $ \edamFiles ->+        if opt_edalize opts+          then writeEdam hdlDir (topNm, varUniq topEntity) deps edamFiles fileNames+          else pure (edamFiles, fileNames)++      writeManifest manPath manifest0{fileNames=fileNames1}++      topTime <- Clock.getCurrentTime+      let topDiff = reportTimeDiff topTime prevTime++      withMVar ioLockV . const $+        putStrLn ("Clash: Compiling " ++ topEntityS ++ " took " ++ topDiff)++      return ()++    _ -> do+      -- 1. Prepare HDL directory+      --+      -- [Note] Create HDL dir before netlist generation+      --+      -- Already create the directory where the HDL ends up being generated, as+      -- we use directories relative to this final directory to find manifest+      -- files belonging to other top entities. Failing to do so leads to #463+      prepareDir hdlDir opts userModifications++      -- 2. Normalize topEntity+      supplyN <- Supply.newSupply+      transformedBindings <- normalizeEntity env bindingsMap typeTrans peEval+                               eval topEntityNames supplyN topEntity++      normTime <- transformedBindings `deepseq` Clock.getCurrentTime+      let prepNormDiff = reportTimeDiff normTime prevTime++      withMVar ioLockV . const $+        putStrLn ("Clash: Normalization took " ++ prepNormDiff)++      -- 3. Generate netlist for topEntity+      (topComponent, netlist) <- modifyMVar seenV $ \seen -> do+        (topComponent, netlist, seen') <-+          -- TODO My word, this has far too many arguments.+          genNetlist env peEval isTb transformedBindings topEntityMap compNames+            typeTrans ite (SomeBackend hdlState') seen hdlDir prefixM topEntity++        pure (seen', (topComponent, netlist))++      netlistTime <- netlist `deepseq` Clock.getCurrentTime+      let normNetDiff = reportTimeDiff netlistTime normTime++      withMVar ioLockV . const $+        putStrLn ("Clash: Netlist generation took " ++ normNetDiff)++      -- 4. Generate topEntity wrapper+      (hdlDocs, dfiles, mfiles) <- withMVar seenV $ \seen ->+        pure $! createHDL hdlState' opts modNameT seen netlist domainConfs topComponent topNmT++      -- TODO: Data files should go into their own directory+      -- FIXME: Files can silently overwrite each other+      hdlDocDigests <- mapM (writeHDL hdlDir) hdlDocs+      dataFilesDigests <- copyDataFiles hdlDir dfiles+      memoryFilesDigests <- writeMemoryDataFiles hdlDir mfiles++      let+        components = map (snd . snd) (OMap.assocs netlist)+        filesAndDigests0 =+          -- FIXME: We should track dependencies of `mfiles` and `dfiles` and+          -- maintain the proper topological sort of all these.+             zip (map fst mfiles) memoryFilesDigests+          <> zip (map fst dfiles) dataFilesDigests+          <> zip (map fst hdlDocs) hdlDocDigests++      filesAndDigests1 <- modifyMVar edamFilesV $ \edamFiles ->+        if opt_edalize opts+          then writeEdam hdlDir (topNm, varUniq topEntity) deps edamFiles filesAndDigests0+          else pure (edamFiles, filesAndDigests0)++      let+        depUniques = fromMaybe [] (HashMap.lookup (getUnique topEntity) deps)+        depBindings = mapMaybe (flip lookupVarEnvDirectly bindingsMap) depUniques+        depIds = map bindingId depBindings++        manifest =+          mkManifest+            hdlState' domainConfs opts topComponent components depIds+            filesAndDigests1 topHash+      writeManifest manPath manifest++      topTime <- hdlDocs `seq` Clock.getCurrentTime+      let topDiff = reportTimeDiff topTime prevTime++      withMVar ioLockV . const $+        putStrLn ("Clash: Compiling " ++ topEntityS ++ " took " ++ topDiff)++-- | Interpret a specific function from a specific module. This action tries+-- two things:+--+--   1. Interpret without explicitly loading the module. This will succeed if+--      the module was already loaded through a package database (set using+--      'interpreterArgs').+--+--   2. If (1) fails, it does try to load it explicitly. If this also fails,+--      an error is returned.+--+loadImportAndInterpret+  :: (MonadIO m, MonadMask m)+  => [String]+  -- ^ Extra search path (usually passed as -i)+  -> [String]+  -- ^ Interpreter args+  -> String+  -- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.)+  -- can be found+  -> Hint.ModuleName+  -- ^ Module function lives in+  -> String+  -- ^ Function name+  -> String+  -- ^ Type name ('BlackBoxFunction' or 'TemplateFunction')+  -> m (Either (NonEmpty Hint.InterpreterError) a)+loadImportAndInterpret iPaths0 interpreterArgs topDir qualMod funcName typ = do+  Hint.liftIO $ Monad.when debugIsOn $+    putStr "Hint: Interpreting " >> putStrLn (qualMod ++ "." ++ funcName)+  -- Try to interpret function *without* loading module explicitly. If this+  -- succeeds, the module was already in the global package database(s).+  bbfE <- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do+    iPaths1 <- (++iPaths0) <$> Hint.get Hint.searchPath+    Hint.set [Hint.searchPath Hint.:= iPaths1]+    Hint.setImports [ "Clash.Netlist.Types", "Clash.Netlist.BlackBox.Types", qualMod]+    Hint.unsafeInterpret funcName typ++  case bbfE of+    Left globalException -> do+      -- Try to interpret module as a local module, not yet present in the+      -- global package database(s).+      localRes <- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do+        Hint.reset+        iPaths1 <- (iPaths0++) <$> Hint.get Hint.searchPath+        Hint.set [ Hint.searchPath Hint.:= iPaths1+                 , Hint.languageExtensions Hint.:= langExts]+        Hint.loadModules [qualMod]+        Hint.setImports [ "Clash.Netlist.BlackBox.Types", "Clash.Netlist.Types", qualMod]+        Hint.unsafeInterpret funcName typ++      case localRes of+        Left localException -> pure (Left (globalException :| [localException]))+        Right res -> pure (Right res)++    Right res -> do+      return (Right res)+ where+   langExts = map Hint.asExtension $+                map show wantedLanguageExtensions +++                map ("No" ++ ) (map show unwantedLanguageExtensions)++-- | List of known BlackBoxFunctions used to prevent Hint from firing. This+--  improves Clash startup times.+knownBlackBoxFunctions :: HashMap String BlackBoxFunction+knownBlackBoxFunctions =+  HashMap.fromList $ map (first show) $+    [ ('P.checkBBF, P.checkBBF)+    , ('P.bvToIntegerVHDL, P.bvToIntegerVHDL)+    , ('P.bvToIntegerVerilog, P.bvToIntegerVerilog)+    , ('P.clashCompileErrorBBF, P.clashCompileErrorBBF)+    , ('P.foldBBF, P.foldBBF)+    , ('P.indexIntVerilog, P.indexIntVerilog)+    , ('P.indexToIntegerVerilog, P.indexToIntegerVerilog)+    , ('P.indexToIntegerVHDL, P.indexToIntegerVHDL)+    , ('P.intTF, P.intTF)+    , ('P.iterateBBF, P.iterateBBF)+    , ('P.signedToIntegerVerilog, P.signedToIntegerVerilog)+    , ('P.signedToIntegerVHDL, P.signedToIntegerVHDL)+    , ('P.unsignedToIntegerVerilog, P.unsignedToIntegerVerilog)+    , ('P.unsignedToIntegerVHDL, P.unsignedToIntegerVHDL)+    , ('P.wordTF, P.wordTF)+    ]++-- | List of known TemplateFunctions used to prevent Hint from firing. This+--  improves Clash startup times.+knownTemplateFunctions :: HashMap String TemplateFunction+knownTemplateFunctions =+  HashMap.fromList $ map (first show) $+    [ ('P.altpllQsysTF, P.altpllQsysTF)+    , ('P.alteraPllQsysTF, P.alteraPllQsysTF)+    , ('P.alteraPllTF, P.alteraPllTF)+    , ('P.altpllTF, P.altpllTF)+    , ('P.fromIntegerTFvhdl, P.fromIntegerTFvhdl)+    , ('P.clockWizardTF, P.clockWizardTF)+    , ('P.clockWizardDifferentialTF, P.clockWizardDifferentialTF)+    , ('P.clockWizardTclTF, P.clockWizardTclTF)+    , ('P.clockWizardDifferentialTclTF, P.clockWizardDifferentialTclTF)+    ]++-- | Compiles blackbox functions and parses blackbox templates.+compilePrimitive+  :: [FilePath]+  -- ^ Import directories (-i flag)+  -> [FilePath]+  -- ^ Package databases+  -> FilePath+  -- ^ The folder in which the GHC bootstrap libraries (base, containers, etc.)+  -- can be found+  -> ResolvedPrimitive+  -- ^ Primitive to compile+  -> IO CompiledPrimitive+compilePrimitive idirs pkgDbs topDir (BlackBoxHaskell bbName wf usedArgs multiRes bbGenName source) = do+  bbFunc <-+    -- TODO: Use cache for hint targets. Right now Hint will fire multiple times+    -- TODO: if multiple functions use the same blackbox haskell function.+    case HashMap.lookup fullName knownBlackBoxFunctions of+      Just f -> pure f+      Nothing -> do+        Monad.when debugIsOn (putStr "Hint: interpreting " >> putStrLn (show fullName))+        let interpreterArgs = concatMap (("-package-db":) . (:[])) pkgDbs+        -- Compile a blackbox template function or fetch it from an already compiled file.+        r <- go interpreterArgs source+        processHintErrors (show bbGenName) bbName r++  pure (BlackBoxHaskell bbName wf usedArgs multiRes bbGenName (hash source, bbFunc))+ where+    fullName = qualMod ++ "." ++ funcName+    qualMod = intercalate "." modNames+    BlackBoxFunctionName modNames funcName = bbGenName++    -- | Create directory based on base name and directory. Return path+    -- of directory just created.+    createDirectory'+      :: FilePath+      -> FilePath+      -> IO FilePath+    createDirectory' base sub =+      let new = base </> sub in+      Directory.createDirectory new >> return new++    go+      :: [String]+      -> Maybe Text+      -> IO (Either (NonEmpty Hint.InterpreterError) BlackBoxFunction)+    go args (Just source') = do+      -- Create a temporary directory with user module in it, add it to the+      -- list of import direcotries, and run as if it were a "normal" compiled+      -- module.+      tmpDir0 <- getCanonicalTemporaryDirectory+      withTempDirectory tmpDir0 "clash-prim-compile" $ \tmpDir1 -> do+        modDir <- foldM createDirectory' tmpDir1 (init modNames)+        Text.writeFile (modDir </> (last modNames ++ ".hs")) source'+        loadImportAndInterpret (tmpDir1:idirs) args topDir qualMod funcName "BlackBoxFunction"++    go args Nothing = do+      loadImportAndInterpret idirs args topDir qualMod funcName "BlackBoxFunction"++compilePrimitive idirs pkgDbs topDir+  (BlackBox pNm wf rVoid multiRes tkind () outputUsage libM imps fPlural incs rM riM templ) = do+  libM'  <- mapM parseTempl libM+  imps'  <- mapM parseTempl imps+  incs'  <- mapM (traverse parseBB) incs+  templ' <- parseBB templ+  rM'    <- traverse parseBB rM+  riM'   <- traverse parseBB riM+  return (BlackBox pNm wf rVoid multiRes tkind () outputUsage libM' imps' fPlural incs' rM' riM' templ')+ where+  iArgs = concatMap (("-package-db":) . (:[])) pkgDbs++  parseTempl+    :: Applicative m+    => Text+    -> m BlackBoxTemplate+  parseTempl t = case runParse t of+    Failure errInfo+      -> error ("Parsing template for blackbox " ++ Data.Text.unpack pNm ++ " failed:\n"+               ++ show (_errDoc errInfo))+    Success t'+      -> pure t'++  parseBB+    :: ((TemplateFormat,BlackBoxFunctionName), Maybe Text)+    -> IO BlackBox+  parseBB ((TTemplate,_),Just t)     = BBTemplate <$> parseTempl t+  parseBB ((TTemplate,_),Nothing)    =+    error ("No template specified for blackbox: " ++ show pNm)+  parseBB ((THaskell,bbGenName),Just source) = do+    let BlackBoxFunctionName modNames funcName = bbGenName+        qualMod = intercalate "." modNames+    tmpDir <- getCanonicalTemporaryDirectory+    r <- withTempDirectory tmpDir "clash-prim-compile" $ \tmpDir' -> do+      let modDir = foldl (</>) tmpDir' (init modNames)+      Directory.createDirectoryIfMissing True modDir+      Text.writeFile (modDir </> last modNames <.>  "hs") source+      loadImportAndInterpret (tmpDir':idirs) iArgs topDir qualMod funcName "TemplateFunction"+    let hsh = hash (qualMod, source)+    BBFunction (Data.Text.unpack pNm) hsh <$>+      processHintErrors (show bbGenName) pNm  r+  parseBB ((THaskell,bbGenName),Nothing) = do+    let BlackBoxFunctionName modNames funcName = bbGenName+        qualMod = intercalate "." modNames+        hsh     = hash qualMod+        fullName = qualMod ++ "." ++ funcName+    tf <-+      case HashMap.lookup fullName knownTemplateFunctions of+        Just f -> pure f+        Nothing -> do+          r <- loadImportAndInterpret idirs iArgs topDir qualMod funcName "TemplateFunction"+          processHintErrors (show bbGenName) pNm r+    pure (BBFunction (Data.Text.unpack pNm) hsh tf)++compilePrimitive _ _ _ (Primitive pNm wf typ) =+  return (Primitive pNm wf typ)+{-# SCC compilePrimitive #-}++newtype HintError = HintError String deriving (Exception)++instance Show HintError where+  showsPrec :: Int -> HintError -> ShowS+  showsPrec _ (HintError e) = showString e++processHintErrors ::+  (MonadThrow m, Monad m) =>+  -- | Function to interpret+  String ->+  -- | BlackBox function name+  Data.Text.Text ->+  -- | Hint result+  Either (NonEmpty Hint.InterpreterError) t ->+  m t+processHintErrors fun bb r = case r of+  Left es -> throwM $ HintError (formatExceptions (NonEmpty.toList es))+  Right f -> pure f+ where+  formatExceptions es = [I.i|+    Encountered one or more exceptions when compiling blackbox template function+    '#{fun}' for function '#{bb}'.+  |] <> "\n\n" <> intercalate "\n\n" (map formatException es)++  formatException e = [I.i|+    Encountered:++      #{e}+  |]++-- | Pretty print Components to HDL Documents+createHDL+  :: Backend backend+  => backend+  -- ^ Backend+  -> ClashOpts+  -- ^ Global Clash options+  -> IdentifierText+  -- ^ Module hierarchy root+  -> Id.IdentifierSet+  -- ^ Component names+  -> ComponentMap+  -- ^ List of components+  -> HashMap Data.Text.Text VDomainConfiguration+  -- ^ Known domains to configurations+  -> Component+  -- ^ Top component+  -> IdentifierText+  -- ^ Name of the manifest file+  -> ([(String,Doc)],[(String,FilePath)],[(String,String)])+  -- ^ The pretty-printed HDL documents+  -- + The data files that need to be copied+createHDL backend opts modName seen components domainConfs top topName = flip evalState backend $ getAp $ do+  let componentsL = map snd (OMap.assocs components)+  (hdlNmDocs0,incs) <-+    fmap unzip $+      forM componentsL $ \(ComponentMeta{cmLoc, cmScope,cmUsage}, comp) ->+         genHDL opts modName cmLoc (Id.union seen cmScope) cmUsage comp++  hwtys <- HashSet.toList <$> extractTypes <$> Ap get+  typesPkg0 <- mkTyPackage modName hwtys+  dataFiles <- Ap getDataFiles+  memFiles  <- Ap getMemoryDataFiles+  let+    typesPkg1 = map (first (<.> Clash.Backend.extension backend)) typesPkg0+    hdlNmDocs1 = map (first (<.> Clash.Backend.extension backend)) hdlNmDocs0+    topFiles = concat incs ++ typesPkg1 ++ hdlNmDocs1++    topClks = findClocks top+    sdcInfo = fmap findDomainConfig <$> topClks+    sdcFile = Data.Text.unpack topName <.> "sdc"+    sdcDoc  = (sdcFile, pprSDC (SdcInfo sdcInfo))+    sdc = if null sdcInfo then Nothing else Just sdcDoc++  return (maybeToList sdc <> topFiles, dataFiles, memFiles)+ where+  findDomainConfig dom =+    HashMap.lookupDefault+      (error $ $(curLoc) ++ "Unknown synthesis domain: " ++ show dom)+      dom+      domainConfs++writeEdam ::+  FilePath ->+  (Id.Identifier, Unique) ->+  HashMap Unique [Unique] ->+  HashMap Unique [EdamFile] ->+  [(FilePath, ByteString)] ->+  IO (HashMap Unique [EdamFile], [(FilePath, ByteString)])+writeEdam hdlDir (topNm, topEntity) deps edamFiles0 filesAndDigests = do+  let+    (edamFiles1, edamInfo) =+      createEDAM (topNm, topEntity) deps edamFiles0 (map fst filesAndDigests)+  edamDigest <- writeHDL hdlDir ("edam.py", pprEdam edamInfo)+  pure (edamFiles1, ("edam.py", edamDigest) : filesAndDigests)++-- | Create an Edalize metadata file for using Edalize to build the project.+--+-- TODO: Handle libraries. Also see: https://github.com/olofk/edalize/issues/220+createEDAM ::+  -- Top entity name and unique+  (Id.Identifier, Unique) ->+  -- | Top entity dependency map+  HashMap Unique [Unique] ->+  -- | Edam files of each top entity+  HashMap Unique [EdamFile] ->+  -- | Files to include in Edam file+  [FilePath] ->+  -- | (updated map, edam)+  (HashMap Unique [EdamFile], Edam)+createEDAM (topName, topUnique) deps edamFileMap files =+  (HashMap.insert topUnique (edamFiles edam) edamFileMap, edam)+ where+  edam = Edam+    { edamProjectName = Id.toText topName+    , edamTopEntity   = Id.toText topName+    , edamFiles       = fmap (asEdamFile topName) files <> fmap asIncFile incFiles+    , edamToolOptions = def+    }++  incFiles =+    concatMap+      (\u -> HashMap.lookupDefault [] u edamFileMap)+      (HashMap.lookupDefault [] topUnique deps)++  asIncFile f =+    f { efName = ".." </> Data.Text.unpack (efLogicalName f) </> efName f }++asEdamFile :: Id.Identifier -> FilePath -> EdamFile+asEdamFile topName path =+  EdamFile path edamFileType (Id.toText topName)+ where+  edamFileType =+    case FilePath.takeExtension path of+      ".vhdl" -> VhdlSource+      ".v" -> VerilogSource+      ".sv" -> SystemVerilogSource+      ".tcl" -> TclSource+      ".qsys" -> QSYS+      ".sdc" -> SDC+      _ -> Clash.Edalize.Edam.Unknown++-- | Prepares directory for writing HDL files.+prepareDir ::+  -- | HDL directory to prepare+  FilePath ->+  -- | Relevant options: @-fclash-no-clean@+  ClashOpts ->+  -- | Did directory contain unexpected modifications? See 'readFreshManifest'+  Maybe [UnexpectedModification] ->+  IO ()+prepareDir hdlDir ClashOpts{opt_clear} mods = do+  ifM+    (doesPathExist hdlDir)+    (ifM+      (doesDirectoryExist hdlDir)+      (detectCaseIssues >> clearOrError >> createDir)+      (error [I.i|Tried to write HDL files to #{hdlDir}, but it wasn't a directory.|]))+    createDir++ where+  createDir = createDirectoryIfMissing True hdlDir++  -- Windows considers 'foo' and 'FOO' the same directory. Error if users tries+  -- to synthesize two top entities with conflicting (in this sense) names.+  detectCaseIssues = do+    allPaths <- listDirectory (takeDirectory hdlDir)+    unless (takeFileName hdlDir `elem` allPaths) (error [I.i|+      OS indicated #{hdlDir} existed, but Clash could not find it among the+      list of existing directories in #{takeDirectory hdlDir}:++        #{allPaths}++      This probably means your OS or filesystem is case-insensitive. Rename your+      top level binders in order to prevent this error message.+    |])++  clearOrError =+    case mods of+      Just [] ->+        -- No unexpected changes, so no user work will get lost+        removeDirectoryRecursive hdlDir+      _ | opt_clear ->+        -- Unexpected changes / non-empty directory, but @-fclash-clear@ was+        -- set, so remove directory anyway.+        removeDirectoryRecursive hdlDir+      Just unexpected ->+        -- Unexpected changes; i.e. modifications were made after last Clash run+        error [I.i|+          Changes were made to #{hdlDir} after last Clash run:++            #{pprintUnexpectedModifications 5 unexpected}++          Use '-fclash-clear' if you want Clash to clear out the directory.+          Warning: this will remove the complete directory, be cautious of data+          loss.+        |]+      Nothing ->+        -- No manifest file was found. Refuse to write if directory isn't empty.+        unlessM+          (null <$> listDirectory hdlDir)+          (error [I.i|+            Tried to write HDL files to #{hdlDir}, but directory wasn't empty. This+            message will be supressed if Clash can detect that no files have+            changed since it was last run. If you're seeing this message even+            though you haven't modified any files, Clash encountered a problem+            reading "#{manifestFilename :: String}". This can happen when upgrading+            Clash.++            Use '-fclash-clear' if you want Clash to clear out the directory.+            Warning: this will remove the complete directory, be cautious of data+            loss.+          |])++-- | Write a file to disk in chunks. Returns SHA256 sum of file contents.+writeAndHash :: FilePath -> ByteStringLazy.ByteString -> IO ByteString+writeAndHash path bs =+  IO.withFile path IO.WriteMode $ \handle ->+      fmap Sha256.finalize+    $ foldM (writeChunk handle) Sha256.init+    $ ByteStringLazy.toChunks bs+ where+  writeChunk :: IO.Handle -> Sha256.Ctx -> ByteString -> IO Sha256.Ctx+  writeChunk h !ctx chunk = do+    ByteString.hPut h chunk+    pure (Sha256.update ctx chunk)++-- | Writes a HDL file to the given directory. Returns SHA256 hash of written+-- file.+writeHDL :: FilePath -> (FilePath, Doc) -> IO ByteString+writeHDL dir (cname, hdl) = do+  let+    layout = LayoutOptions (AvailablePerLine 120 0.4)+    rendered0 = renderLazy (layoutPretty layout hdl)+    rendered1 = Text.unlines (map Text.stripEnd (Text.lines rendered0))+  writeAndHash (dir </> cname) (Text.encodeUtf8 (rendered1 <> "\n"))++-- | Copy given files+writeMemoryDataFiles+    :: FilePath+    -- ^ Directory to copy  files to+    -> [(FilePath, String)]+    -- ^ (filename, content)+    -> IO [ByteString]+writeMemoryDataFiles dir files =+  forM files $ \(fname, content) ->+    writeAndHash (dir </> fname) (ByteStringLazyChar8.pack content)++-- | Copy data files added with ~FILE, assumes the files are canonicalized already.+-- Throws an error on relative paths as sanity check.+copyDataFiles+  :: FilePath+  -- ^ Directory to copy to+  -> [(FilePath,FilePath)]+  -- ^ [(name of newly made file in HDL output dir, file to copy)]+  -> IO [ByteString]+  -- ^ SHA256 hashes of written files+copyDataFiles targetDir = mapM copyDataFile+ where+  copyDataFile :: (FilePath, FilePath) -> IO ByteString+  copyDataFile (newName, toCopy)+    | isAbsolute toCopy = do+      ifM+        (doesFileExist toCopy)+        (copyAndHash toCopy (targetDir </> newName))+        (error [I.i|Could not find data file #{show toCopy}. Does it exist?|])+    | otherwise = error [I.i|copyDataFiles received a relative path #{show toCopy}. This is a bug in Clash, please report it.|]++  copyAndHash src dst = do+    ifM+      (doesPathExist dst)+      (error [I.i|+        Tried to copy data file #{src} to #{dst} but a file or directory with+        that name already existed. This is a bug in Clash, please report it.+      |])+      (ByteStringLazy.readFile src >>= writeAndHash dst)++-- | Normalize a complete hierarchy+normalizeEntity+  :: ClashEnv+  -> BindingMap+  -- ^ All bindings+  -> (CustomReprs -> TyConMap -> Type ->+      State HWMap (Maybe (Either String FilteredHWType)))+  -- ^ Hardcoded 'Type' -> 'HWType' translator+  -> PE.Evaluator+  -- ^ Hardcoded evaluator for partial evaluation+  -> WHNF.Evaluator+  -- ^ Hardcoded evaluator for WHNF (old evaluator)+  -> [Id]+  -- ^ TopEntities+  -> Supply.Supply+  -- ^ Unique supply+  -> Id+  -- ^ root of the hierarchy+  -> IO BindingMap+normalizeEntity env bindingsMap typeTrans peEval eval topEntities supply tm = transformedBindings+  where+    doNorm = do norm <- normalize [tm]+                let normChecked = checkNonRecursive norm+                cleaned <- cleanupGraph tm normChecked+                return cleaned+    transformedBindings = runNormalization env supply bindingsMap+                            typeTrans peEval eval emptyVarEnv+                            topEntities doNorm++-- | Reverse topologically sort given top entities. Also returns a mapping that+-- maps a top entity to its reverse topologically sorted transitive dependencies.+sortTop ::+  BindingMap ->+  [TopEntityT] ->+  ( [TopEntityT]+  , HashMap Unique [Unique]+  )+sortTop bindingsMap topEntities =+  case reverseTopSort nodes edges of+    Left msg   -> error msg+    Right tops -> (tops, mapFrom tops)+ where+  nodes = [(varUniq topE, t) | t@(TopEntityT topE _ _) <- topEntities]+  edges = concatMap getEdges topEntities++  getEdges (TopEntityT topE _ _) =+    map+      (\top -> (varUniq topE, topToUnique top))+      (getTransitiveRefs topE)++  getTransitiveRefs top =+    let allDeps = callGraph bindingsMap top+    in  filter (\t -> topId t /= top && topId t `elemVarEnv` allDeps) topEntities++  topToUnique = varUniq . topId++  mapFrom tops =+    let+      topIndices = HashMap.fromList (zip (map topToUnique tops) [(0 :: Unique)..])+      nonOrdered = HashMap.fromListWith (<>) (map (second pure) edges)+      orderFunc k = HashMap.lookup k topIndices+    in+      HashMap.map (List.sortOn orderFunc) nonOrdered
+ src/Clash/Driver/Bool.hs view
@@ -0,0 +1,28 @@+{-|+  Copyright   :  (C) 2024, Martijn Bastiaan+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}++module Clash.Driver.Bool where++import Control.DeepSeq (NFData)+import Data.Hashable (Hashable)+import GHC.Generics (Generic)++import qualified GHC.Data.Bool as Ghc++data OverridingBool = Auto | Never | Always+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Hashable, Generic, NFData)++toGhcOverridingBool :: OverridingBool -> Ghc.OverridingBool+toGhcOverridingBool Auto = Ghc.Auto+toGhcOverridingBool Never = Ghc.Never+toGhcOverridingBool Always = Ghc.Always++fromGhcOverridingBool :: Ghc.OverridingBool -> OverridingBool+fromGhcOverridingBool Ghc.Auto = Auto+fromGhcOverridingBool Ghc.Never = Never+fromGhcOverridingBool Ghc.Always = Always
+ src/Clash/Driver/BrokenGhcs.hs view
@@ -0,0 +1,157 @@+{-|+Copyright   :  (C) 2024, Martijn Bastiaan+License     :  BSD2 (see the file LICENSE)+Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++Utilities to detect and report GHC / operating system combinations that are+known to be buggy.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE QuasiQuotes #-}++module Clash.Driver.BrokenGhcs where++import Data.Maybe (listToMaybe)+import Data.Version (Version(Version, versionBranch))+import GHC.Platform (OS(..))++import System.Info (fullCompilerVersion)++import qualified Clash.Util.Interpolate as I+import qualified System.Info++-- | Current OS. Currently only recognizes Linux, Windows, and macOS.+os :: OS+os = case System.Info.os of+  "darwin" -> OSDarwin+  "linux" -> OSLinux+  "mingw32" -> OSMinGW32+  _ -> OSUnknown++-- | What OS GHC is broken on (or all)+data BrokenOn = All | SomeOs OS++data GhcVersion = Ghc+  { major0 :: Int+  , major1 :: Int+  , patch :: Int+  }+  deriving (Eq, Ord)++data GhcRange = GhcRange+  { from :: GhcVersion+  -- ^ Start of range, inclusive+  , to :: GhcVersion+  -- ^ End of range, exclusive+  }++-- | Check if a 'GhcVersion' is within a 'GhcRange'+ghcInRange :: GhcVersion -> GhcRange -> Bool+ghcInRange ghc GhcRange{from, to} = from <= ghc && ghc < to++-- | Construct a range of all GHC versions matching a major version+ghcMajor :: Int -> Int -> GhcRange+ghcMajor major0 major1 = GhcRange+  { from=Ghc major0 major1 0+  , to=Ghc major0 (major1 + 1) 0+  }++data Why = Why+  { what :: String+    -- ^ What is broken+  , solution :: String+    -- ^ What can be done to work around or solve the issue+  , issue :: String+    -- ^ Link to issue+  , brokenOn :: [(BrokenOn, GhcRange)]+    -- ^ What operation systems are affected+  }++-- | Get current GHC version expressed as a triple. It probably does something+-- non-sensible on unreleased GHCs.+ghcVersion :: GhcVersion+ghcVersion = Ghc{major0, major1, patch}+ where+  (major0, major1, patch) =+    case fullCompilerVersion of+      Version{versionBranch} ->+        case versionBranch of+          [] -> (0, 0, 1)+          [a] -> (a, 0, 1)+          [a, b] -> (a, b, 1)+          [a, b, c] -> (a, b, c)+          (a:b:c:_) -> (a, b, c)++-- | Pretty print 'Why' into an error message+whyPp :: Why -> String+whyPp Why{what, solution, issue}= [I.i|+  Clash has known issues on #{major0}.#{major1}.#{patch} on your current+  OS. While not completely preventing the compiler from working, we recommend+  switching to another GHC version. Symptoms:++    #{what}++  Consider the following work around or solution:++    #{solution}++  More information can be found at:++    #{issue}++  If you want to ignore this message, pass the following flag to Clash:++    -fclash-ignore-broken-ghcs++  Alternatively, you can set the environment variable CLASH_IGNORE_BROKEN_GHCS+  to 'True'.+  |]+ where+  Ghc{major0, major1, patch} = ghcVersion++-- | Which GHCs are broken and why+brokenGhcs :: [Why]+brokenGhcs = [brokenClashCores, brokenTypeErrors, slowStarts]+ where+  brokenClashCores = Why+    { what = "GHC is known to fail compilation of libraries used by the Clash compiler test suite"+    , solution = "Upgrade to GHC 9.4 or downgrade to GHC 8.10"+    , issue = "<no link>"+    , brokenOn = [(SomeOs OSMinGW32, ghcMajor 9 0)]+    }++  brokenTypeErrors = Why+    { what = "Clash type error messages are indecipherable"+    , solution = "Upgrade to GHC 9.4 or downgrade to GHC 9.0"+    , issue = "<no link>"+    , brokenOn = [(All, ghcMajor 9 2)]+    }++  slowStarts = Why+    { what = "Clash starts really slowly from GHC 9.4.8 up to and including 9.6.2"+    , solution = "Upgrade to GHC 9.6.3 or newer, or downgrade to GHC 9.4.7"+    , issue = "https://github.com/clash-lang/clash-compiler/issues/2710"+    , brokenOn = [(All, GhcRange{from=Ghc 9 4 8, to=Ghc 9 6 3})]+    }++-- | Given a 'BrokenOn', determine whether current OS matches+matchOs :: BrokenOn -> Bool+matchOs All = True+matchOs (SomeOs brokenOs) = os == brokenOs++-- | Given a 'BrokenOn' and 'GhcVersion', determine whether it matches current OS and GHC+matchBroken :: (BrokenOn, GhcRange) -> Bool+matchBroken (brokenOs, brokenRange) = matchOs brokenOs && ghcInRange ghcVersion brokenRange++-- | Get first reason for GHC/OS being broken, if any+broken :: Maybe Why+broken = listToMaybe [why | why <- brokenGhcs, any matchBroken (brokenOn why)]++-- | Throw an error if current OS / GHC version is known to be buggy+assertWorking :: IO ()+assertWorking = case broken of+  Nothing -> pure ()+  Just why -> error (whyPp why)
+ src/Clash/Driver/Manifest.hs view
@@ -0,0 +1,507 @@+{-|+Copyright  : (C) 2021-2023, QBayLogic B.V.+License    : BSD2 (see the file LICENSE)+Maintainer : QBayLogic B.V. <devops@qbaylogic.com>++Functions to read, write, and handle manifest files.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Driver.Manifest where++import           Control.Exception (tryJust)+import           Control.Monad (guard, forM)+import           Control.Monad.State (evalState)+import qualified Crypto.Hash.SHA256 as Sha256+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encode.Pretty as Aeson+import           Data.Aeson+  (ToJSON(toJSON), FromJSON(parseJSON), KeyValue ((.=)), (.:), (.:?))+import           Data.Aeson.Types (Parser)+import qualified Data.Binary as Binary+import qualified Data.ByteString.Base16 as Base16+import qualified Data.ByteString.Lazy as ByteStringLazy+import           Data.ByteString (ByteString)+import           Data.Char (toLower)+#if MIN_VERSION_base16_bytestring(1,0,0)+import           Data.Either (fromRight)+#endif+import           Data.Hashable (hash)+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import           Data.Maybe (catMaybes)+import           Data.Monoid (Ap(getAp))+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.Encoding as LText+import           Data.Text (Text)+import           Data.Text.Prettyprint.Doc.Extra (renderOneLine)+import           Data.Time (UTCTime)+import qualified Data.Set as Set+import           Data.String (IsString)+import           GHC.Generics (Generic)+import           System.IO.Error (isDoesNotExistError)+import           System.FilePath (takeDirectory, (</>))+import           System.Directory (listDirectory, doesFileExist)+import           Text.Read (readMaybe)++import           Clash.Annotations.TopEntity.Extra ()+import           Clash.Backend (Backend (hdlType), Usage (External))+import           Clash.Core.Name (nameOcc)+import           Clash.Driver.Bool (OverridingBool(..))+import           Clash.Driver.Types+import           Clash.Primitives.Types+import           Clash.Core.Var (Id, varName)+import           Clash.Netlist.Types+  (TopEntityT, Component(..), HWType (Clock, ClockN), hwTypeDomain)+import qualified Clash.Netlist.Types as Netlist+import qualified Clash.Netlist.Id as Id+import           Clash.Netlist.Util (typeSize)+import           Clash.Primitives.Util (hashCompiledPrimMap)+import           Clash.Signal (VDomainConfiguration(..))+import           Clash.Util.Graph (callGraphBindings)++data PortDirection+  = In | Out | InOut+  deriving (Generic, Eq, Read, Show)++instance ToJSON PortDirection where+  toJSON = Aeson.genericToJSON Aeson.defaultOptions+    { Aeson.constructorTagModifier = fmap toLower }++instance FromJSON PortDirection where+  parseJSON = Aeson.genericParseJSON Aeson.defaultOptions+    { Aeson.constructorTagModifier = fmap toLower }++data ManifestPort = ManifestPort+  { mpName :: Text+  -- ^ Port name (as rendered in HDL)+  , mpTypeName :: Text+  -- ^ Type name (as rendered in HDL)+  , mpDirection :: PortDirection+  -- ^ Port direction (in / out / inout)+  , mpWidth :: Int+  -- ^ Port width in bits+  , mpIsClock :: Bool+  -- ^ Is this port a clock?+  , mpDomain :: Maybe Text+  -- ^ Domain this port belongs to. This is currently only included for clock,+  -- reset, and enable ports. TODO: add to all ports originally defined as a+  -- @Signal@ too.+  } deriving (Show,Read,Eq)++instance ToJSON ManifestPort where+  toJSON (ManifestPort{..}) =+    Aeson.object $+      [ "name" .= mpName+      , "type_name" .= mpTypeName+      , "direction" .= mpDirection+      , "width" .= mpWidth+      , "is_clock" .= mpIsClock+      ] <>+      (case mpDomain of+        Just dom -> ["domain" .= dom]+        Nothing -> [] )++instance FromJSON ManifestPort where+  parseJSON = Aeson.withObject "ManifestPort" $ \v ->+    ManifestPort+      <$> v .: "name"+      <*> v .: "type_name"+      <*> v .: "direction"+      <*> v .: "width"+      <*> v .: "is_clock"+      <*> v .:? "domain"++-- | Just the 'fileNames' part of 'Manifest'+newtype FilesManifest = FilesManifest [(FilePath, ByteString)]++instance FromJSON FilesManifest where+  parseJSON = Aeson.withObject "FilesManifest" $ fmap FilesManifest . parseFiles++-- | Information about the generated HDL between (sub)runs of the compiler+data Manifest+  = Manifest+  { manifestHash :: ByteString+    -- ^ Hash digest of the TopEntity and all its dependencies.+  , successFlags  :: (Int, Int)+    -- ^ Compiler flags used to achieve successful compilation:+    --+    --   * opt_inlineLimit+    --   * opt_specLimit+  , ports :: [ManifestPort]+    -- ^ Ports in the generated @TopEntity@.+  , componentNames :: [Text]+    -- ^ Names of all the generated components for the @TopEntity@ (does not+    -- include the names of the components of the @TestBench@ accompanying+    -- the @TopEntity@).+    --+    -- This list is reverse topologically sorted. I.e., a component might depend+    -- on any component listed before it, but not after it.+  , topComponent :: Text+    -- ^ Design entry point. This is usually the component annotated with a+    -- @TopEntity@ annotation.+  , fileNames :: [(FilePath, ByteString)]+    -- ^ Names and hashes of all the generated files for the @TopEntity@. Hashes+    -- are SHA256.+    --+    -- This list is reverse topologically sorted. I.e., a component might depend+    -- on any component listed before it, but not after it.+  , domains :: HashMap Text VDomainConfiguration+    -- ^ Domains encountered in design+  , transitiveDependencies :: [Text]+    -- ^ Dependencies of this design (fully qualified binder names). Is a+    -- transitive closure of all dependencies.+    --+    -- This list is reverse topologically sorted. I.e., a component might depend+    -- on any component listed before it, but not after it.+  } deriving (Show,Read,Eq)++instance ToJSON Manifest where+  toJSON (Manifest{..}) =+    Aeson.object+      [ "version" .= ("unstable" :: Text)+      , "hash" .= toHexDigest manifestHash+      , "flags" .= successFlags+        -- TODO: add nested ports (i.e., how Clash split/filtered arguments)+      , "components" .= componentNames+      , "top_component" .= Aeson.object+        [ "name" .= topComponent+        , "ports_flat" .= ports+        ]+      , "files" .=+        [ Aeson.object+          [ "name" .= fName+          , "sha256" .= toHexDigest fHash+            -- TODO: Add Edam like fields+          ]+        | (fName, fHash) <- fileNames]+      , "domains" .= HashMap.fromList+        [ ( domNm+          , Aeson.object+            [ "period" .= vPeriod+            , "active_edge" .= show vActiveEdge+            , "reset_kind" .= show vResetKind+            , "init_behavior" .= show vInitBehavior+            , "reset_polarity" .= show vResetPolarity+            ]+          )+        | (domNm, VDomainConfiguration{..}) <- HashMap.toList domains ]+      , "dependencies" .= Aeson.object+        [ "transitive" .= transitiveDependencies ]+      ]++-- Note [Failed hex digest decodes]+--+-- 'unsafeFromHexDigest' may fail to decode a hex digest if it contains characters+-- outside of [a-fA-F0-9]. In this case, it will return a broken digest. Because+-- this module discards any data covered by the broken digest if it does not match+-- a freshly calculated one, this poses no problem.++-- | Decode a hex digest to a ByteString. Returns a broken digest if the decode+-- fails - hence it being marked as unsafe.+unsafeFromHexDigest :: Text -> ByteString+unsafeFromHexDigest =+#if MIN_VERSION_base16_bytestring(1,0,0)+  fromRight "failed decode" . Base16.decode . Text.encodeUtf8+#else+  fst . Base16.decode . Text.encodeUtf8+#endif++-- | Encode a ByteString to a hex digest.+toHexDigest :: ByteString -> Text+toHexDigest = Text.decodeUtf8 . Base16.encode++-- | Parse @files@ part of a Manifest file+parseFiles :: Aeson.Object -> Parser [(FilePath, ByteString)]+parseFiles v = do+  files <- v .: "files"+  forM files $ \obj -> do+    fName <- obj .: "name"+    sha256 <- obj .: "sha256"+    -- See Note [Failed hex digest decodes]+    pure (fName, unsafeFromHexDigest sha256)++instance FromJSON Manifest where+  parseJSON = Aeson.withObject "Manifest" $ \v ->+    let+      topComponent = v .: "top_component"+    in+      Manifest+            -- See Note [Failed hex digest decodes]+        <$> (unsafeFromHexDigest <$> v .: "hash")+        <*> v .: "flags"+        <*> (topComponent >>= (.: "ports_flat"))+        <*> v .: "components"+        <*> (topComponent >>= (.: "name"))+        <*> parseFiles v+        <*> (v .: "domains" >>= HashMap.traverseWithKey parseDomain)+        <*> (v .: "dependencies" >>= (.: "transitive"))+   where+    parseDomain :: Text -> Aeson.Object -> Parser VDomainConfiguration+    parseDomain nm v =+      VDomainConfiguration+        <$> pure (Text.unpack nm)+        <*> (v .: "period")+        <*> parseWithRead "active_edge" v+        <*> parseWithRead "reset_kind" v+        <*> parseWithRead "init_behavior" v+        <*> parseWithRead "reset_polarity" v++    parseWithRead field obj = do+      v <- obj .:? field+      case readMaybe =<< v of+        Just a -> pure a+        Nothing -> fail $ "Could not read field: " <> show field++data UnexpectedModification+  -- | Clash generated file was modified+  = Modified FilePath+  -- | Non-clash generated file was added+  | Added FilePath+  -- | Clash generated file was removed+  | Removed FilePath+  deriving (Show)++mkManifestPort ::+  Backend backend =>+  -- | Backend used to lookup port type names+  backend ->+  -- | Port name+  Id.Identifier ->+  -- | Port type+  HWType ->+  PortDirection ->+  ManifestPort+mkManifestPort backend portId portType portDir = ManifestPort{..}+ where+  mpName = Id.toText portId+  mpWidth = typeSize portType+  mpDirection = portDir+  mpIsClock = case portType of {Clock _ -> True; ClockN _ -> True; _ -> False}+  mpDomain = hwTypeDomain portType+  mpTypeName = flip evalState backend $ getAp $ do+     LText.toStrict . renderOneLine <$> hdlType (External mpName) portType++-- | Filename manifest file should be written to and read from+manifestFilename :: IsString a => a+manifestFilename = "clash-manifest.json"++mkManifest ::+  Backend backend =>+  -- | Backend used to lookup port type names+  backend ->+  -- | Domains encountered in design+  HashMap Text VDomainConfiguration ->+  -- | Options Clash was run with+  ClashOpts ->+  -- | Component of top entity+  Component ->+  -- | All other entities+  [Component] ->+  -- | Names of dependencies (transitive closure)+  [Id] ->+  -- | Files and  their hashes+  [(FilePath, ByteString)] ->+  -- | Hash returned by 'readFreshManifest'+  ByteString ->+  -- | New manifest+  Manifest+mkManifest backend domains ClashOpts{..} Component{..} components deps files topHash = Manifest+  { manifestHash = topHash+  , ports = inPorts <> inOutPorts <> outPorts+  , componentNames = map Id.toText compNames+  , topComponent = Id.toText componentName+  , fileNames = files+  , successFlags = (opt_inlineLimit, opt_specLimit)+  , domains = domains+  , transitiveDependencies = map (nameOcc . varName) deps+  }+ where+  compNames = map Netlist.componentName components++  inPorts =+    [mkManifestPort backend pName pType In | p@(pName, pType) <- inputs, not (Netlist.isBiDirectional p)]++  inOutPorts =+    [mkManifestPort backend pName pType InOut | p@(pName, pType) <- inputs, Netlist.isBiDirectional p]++  outPorts =+    [mkManifestPort backend pName pType Out | (_, (pName, pType), _) <- outputs]++-- | Pretty print an unexpected modification as a list item.+pprintUnexpectedModification :: UnexpectedModification -> String+pprintUnexpectedModification = \case+  Modified p -> "Unexpected modification in " <> p+  Added p -> "Unexpected extra file " <> p+  Removed p -> "Unexpected removed file " <> p++-- | Pretty print a list of unexpected modifications. Print a maximum of /n/+-- modifications.+pprintUnexpectedModifications :: Int -> [UnexpectedModification] -> String+pprintUnexpectedModifications 0 us = pprintUnexpectedModifications maxBound us+pprintUnexpectedModifications _ [] = []+pprintUnexpectedModifications _ [u] = "* " <> pprintUnexpectedModification u+pprintUnexpectedModifications 1 (u:us) =+  "* and " <> show (length (u:us)) <> " more unexpected changes"+pprintUnexpectedModifications n (u:us) =+  "* " <> pprintUnexpectedModification u+        <> "\n" <> pprintUnexpectedModifications (n-1) us++-- | Reads a manifest file. Does not return manifest file if:+--+--  * Caching is disabled through @-fclash-no-cache@.+--  * Manifest could not be found.+--  * Cache is stale. This could be triggered by any of the given arguments.+--+-- Raises an exception if the manifest file or any of the files it is referring+-- to was inaccessible.+--+readFreshManifest ::+  -- | "This" top entity plus all that depend on it.+  [TopEntityT] ->+  -- | Core expressions and entry point. Any changes in the call graph will+  -- trigger a recompile.+  (BindingMap, Id) ->+  -- | Any changes in any primitive will trigger a recompile.+  CompiledPrimMap ->+  -- | Certain options will trigger recompiles if changed+  ClashOpts ->+  -- | Clash modification date+  UTCTime ->+  -- | Path to manifest file.+  FilePath ->+  -- | ( Nothing if no manifest file was found+  --   , Nothing on stale cache, disabled cache, or not manifest file found )+  IO (Maybe [UnexpectedModification], Maybe Manifest, ByteString)+readFreshManifest tops (bindingsMap, topId) primMap opts@(ClashOpts{..}) clashModDate path = do+  modificationsM <- traverse (isUserModified path) =<< readManifest path++  manifestM <- readManifest path+  pure+    ( modificationsM+    , checkManifest =<< if opt_cachehdl then manifestM else Nothing+    , topHash+    )++ where+  optsHash = hash opts {+      -- Ignore the following settings, they don't affect the generated HDL:++      -- 1. Debug+      opt_debug = opt_debug+        { dbg_invariants = False+        , dbg_transformations = Set.empty+        , dbg_historyFile = Nothing+        }++      -- 2. Caching+    , opt_cachehdl = True++      -- 3. Warnings / errors+    , opt_primWarn = True+    , opt_color = Auto+    , opt_errorExtra = False+    , opt_checkIDir = True+    , opt_ignoreBrokenGhcs = False++      -- 4. Optional output+    , opt_edalize = False++      -- Ignore the following settings, they don't affect the generated HDL. However,+      -- they do influence whether HDL can be generated at all.+      --+      -- We therefore check whether the new flags changed in such a way that+      -- they could affect successful compilation, and use that information+      -- to decide whether to use caching or not (see: XXXX).+      --+      -- 5. termination measures+    , opt_inlineLimit = 20+    , opt_specLimit = 20++      -- Finally, also ignore the HDL dir setting, because when a user moves the+      -- entire dir with generated HDL, they probably still want to use that as+      -- a cache+    , opt_hdlDir = Nothing+    }++  -- TODO: Binary encoding does not account for alpha equivalence (nor should+  --       it?), so the cache behaves more pessimisticly than it could.+  topHash = Sha256.hashlazy $ Binary.encode+    ( tops+    , hashCompiledPrimMap primMap+    , show clashModDate+    , callGraphBindings bindingsMap topId+    , optsHash+    )++  checkManifest manifest@Manifest{manifestHash,successFlags}+    | (cachedInline, cachedSpec) <- successFlags++    -- Higher limits shouldn't affect HDL+    , cachedInline <= opt_inlineLimit+    , cachedSpec <= opt_specLimit++    -- Callgraph hashes should correspond+    , manifestHash == topHash+    = Just manifest++    -- One or more checks failed+    | otherwise = Nothing++-- | Determines whether the HDL directory the given 'LocatedManifest' was found+-- in contains any user made modifications. This is used by Clash to protect the+-- user against lost work.+isUserModified :: FilePath -> FilesManifest -> IO [UnexpectedModification]+isUserModified (takeDirectory -> topDir) (FilesManifest fileNames) = do+  let+    manifestFiles = Set.fromList (map fst fileNames)++  currentFiles <- (Set.delete manifestFilename . Set.fromList) <$> listDirectory topDir++  let+    removedFiles = Set.toList (manifestFiles `Set.difference` currentFiles)+    addedFiles = Set.toList (currentFiles `Set.difference` manifestFiles)++  changedFiles <- catMaybes <$> mapM detectModification fileNames++  pure+    (  map Removed removedFiles+    <> map Added addedFiles+    <> map Modified changedFiles )+ where+  detectModification :: (FilePath, ByteString) -> IO (Maybe FilePath)+  detectModification (filename, manifestDigest) = do+    let fullPath = topDir </> filename+    fileExists <- doesFileExist fullPath+    if fileExists then do+      contents <- ByteStringLazy.readFile fullPath+      if manifestDigest == Sha256.hashlazy contents+      then pure Nothing+      else pure (Just filename)+    else+      -- Will be caught by @removedFiles@+      pure Nothing++-- | Read a manifest file from disk. Returns 'Nothing' if file does not exist.+-- Any other IO exception is re-raised.+readManifest :: FromJSON a => FilePath -> IO (Maybe a)+readManifest path = do+  contentsE <- tryJust (guard . isDoesNotExistError) (Aeson.decodeFileStrict path)+  pure (either (const Nothing) id contentsE)++-- | Write manifest file to disk+writeManifest :: FilePath -> Manifest -> IO ()+writeManifest path = ByteStringLazy.writeFile path . Aeson.encodePretty++-- | Serialize a manifest.+--+-- TODO: This should really yield a 'ByteString'.+serializeManifest :: Manifest -> Text+serializeManifest = LText.toStrict . LText.decodeUtf8 . Aeson.encodePretty
+ src/Clash/Driver/Types.hs view
@@ -0,0 +1,475 @@+{-|+  Copyright  :  (C) 2013-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017     , QBayLogic, Google Inc.,+                    2022     , Google Inc.,+                    2020-2026, QBayLogic,+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Type definitions used by the Driver module+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Clash.Driver.Types where++-- For Int/Word size+#include "MachDeps.h"++import           Control.DeepSeq                (NFData(rnf), deepseq)+import           Data.Binary                    (Binary)+import           Data.Fixed+import           Data.Hashable+import           Data.HashMap.Strict            (HashMap)+import           Data.IntMap.Strict             (IntMap)+import           Data.Maybe                     (isJust)+import           Data.Set                       (Set)+import qualified Data.Set                       as Set+import           Data.Text                      (Text)+import qualified Data.Text as Text              (dropAround)++#if MIN_VERSION_prettyprinter(1,7,0)+import           Prettyprinter+#else+import           Data.Text.Prettyprint.Doc+#endif++import           GHC.Generics                   (Generic)++import           GHC.Types.Basic                (InlineSpec)+import           GHC.Types.SrcLoc               (SrcSpan)++import           Clash.Annotations.BitRepresentation.Internal (CustomReprs)+import           Clash.Signal.Internal++import           Clash.Backend.Verilog.Time     (Period(..), Unit(Fs))+import           Clash.Core.Pretty              (unsafeLookupEnvBool)+import           Clash.Core.Term                (Term)+import           Clash.Core.TyCon               (TyConMap, TyConName)+import           Clash.Core.Var                 (Id)+import           Clash.Core.VarEnv              (VarEnv)+import           Clash.Driver.Bool              (OverridingBool(..))+import           Clash.Netlist.BlackBox.Types   (HdlSyn (..))+import {-# SOURCE #-} Clash.Netlist.Types       (PreserveCase(..), TopEntityT)+import           Clash.Primitives.Types         (CompiledPrimMap)++data ClashEnv = ClashEnv+  { envOpts        :: ClashOpts+  , envTyConMap    :: TyConMap+  , envTupleTyCons :: IntMap TyConName+  , envPrimitives  :: CompiledPrimMap+  , envCustomReprs :: CustomReprs+  , envDomains     :: DomainMap+  } deriving (Generic, NFData)++data ClashDesign = ClashDesign+  { designEntities :: [TopEntityT]+  , designBindings :: BindingMap+  }++instance NFData ClashDesign where+  rnf design =+    designEntities design `seq`+    designBindings design `deepseq`+    ()++data IsPrim+  = IsPrim+    -- ^ The binding is the unfolding for a primitive.+  | IsFun+    -- ^ The binding is an ordinary function.+  deriving (Binary, Eq, Generic, NFData, Show)++-- A function binder in the global environment.+--+data Binding a = Binding+  { bindingId :: Id+    -- ^ The core identifier for this binding.+  , bindingLoc :: SrcSpan+    -- ^ The source location of this binding in the original source code.+  , bindingSpec :: InlineSpec+    -- ^ the inline specification for this binding, in the original source code.+  , bindingIsPrim :: IsPrim+    -- ^ Is the binding a core term corresponding to a primitive with a known+    -- implementation? If so, it can potentially be inlined despite being+    -- marked as NOINLINE in source.+  , bindingTerm :: a+    -- ^ The term representation for this binding. This is polymorphic so+    -- alternate representations can be used if more appropriate (i.e. in the+    -- evaluator this can be Value for evaluated bindings).+  , bindingRecursive :: Bool+    -- ^ Whether the binding is recursive.+    --+    -- TODO Ideally the BindingMap would store recursive and non-recursive+    -- bindings in a way similar to Let / Letrec. GHC also does this.+  } deriving (Binary, Functor, Generic, NFData, Show)++-- | Global function binders+--+-- Global functions cannot be mutually recursive, only self-recursive.+type BindingMap = VarEnv (Binding Term)+type DomainMap = HashMap Text VDomainConfiguration++-- | Information to show about transformations during compilation.+--+-- __NB__: The @Ord@ instance compares by amount of information.+data TransformationInfo+  = None+  -- ^ Show no information about transformations.+  | FinalTerm+  -- ^ Show the final term after all applied transformations.+  | AppliedName+  -- ^ Show the name of every transformation that is applied.+  | AppliedTerm+  -- ^ Show the name and result of every transformation that is applied.+  | TryName+  -- ^ Show the name of every transformation that is attempted, and the result+  -- of every transformation that is applied.+  | TryTerm+  -- ^ Show the name and input to every transformation that is applied, and+  -- the result of every transformation that is applied.+  deriving (Eq, Generic, Hashable, Ord, Read, Show, NFData)++-- | Options related to debugging. See 'ClashOpts'+data DebugOpts = DebugOpts+  { dbg_invariants :: Bool+  -- ^ Check that the results of applied transformations do not violate the+  -- invariants for rewriting (e.g. no accidental shadowing, or type changes).+  --+  -- Command line flag: -fclash-debug-invariants+  , dbg_transformationInfo :: TransformationInfo+  -- ^ The information to show when debugging a transformation. See the+  -- 'TransformationInfo' type for different configurations.+  --+  -- Command line flag: -fclash-debug-info (None|FinalTerm|AppliedName|AppliedTerm|TryName|TryTerm)+  , dbg_transformations :: Set String+  -- ^ List the transformations that are being debugged. When the set is empty,+  -- all transformations are debugged.+  --+  -- Command line flag: -fclash-debug-transformations t1[,t2...]+  , dbg_countTransformations :: Bool+  -- ^ Count how many times transformations are applied and provide a summary+  -- at the end of normalization. This includes all transformations, not just+  -- those in 'dbg_transformations'.+  --+  -- Command line flag: -fclash-debug-count-transformations+  , dbg_transformationsFrom :: Maybe Word+  -- ^ Debug transformations applied after the nth transformation applied. This+  -- includes all transformations, not just those in 'dbg_transformations'.+  --+  -- Command line flag: -fclash-debug-transformations-from=N+  , dbg_transformationsLimit :: Maybe Word+  -- ^ Debug up to the nth applied transformation. If this limit is exceeded+  -- then Clash will error. This includes all transformations, not just those+  -- in 'dbg_transformations'.+  --+  -- Command line flag: -fclash-debug-transformations-limit=N+  , dbg_historyFile :: Maybe FilePath+  -- ^ Save information about all applied transformations to a history file+  -- for use with @clash-term@.+  --+  -- Command line flag: -fclash-debug-history[=FILE]+  } deriving (Generic, NFData, Show, Eq)++instance Hashable DebugOpts where+  hashWithSalt s DebugOpts{..} =+    s `hashWithSalt`+    dbg_invariants `hashWithSalt`+    dbg_transformationInfo `hashSet`+    dbg_transformations `hashWithSalt`+    dbg_countTransformations `hashWithSalt`+    dbg_transformationsFrom `hashWithSalt`+    dbg_transformationsLimit `hashWithSalt`+    dbg_historyFile+   where+    hashSet = Set.foldl' hashWithSalt+    infixl 0 `hashSet`++-- | Check whether the debugging options mean the compiler is debugging. This+-- is true only if at least one debugging feature is enabled, namely one of+--+--   * checking for invariants+--   * showing info for transformations+--   * counting applied transformations+--   * limiting the number of transformations+--+-- Other flags, such as writing to a history file or offsetting which applied+-- transformation to show information from do not affect the result, as it is+-- possible to enable these but still not perform any debugging checks in+-- functions like 'applyDebug'. If this is no longer the case, this function+-- will need to be changed.+isDebugging :: DebugOpts -> Bool+isDebugging opts = or+  [ dbg_invariants opts+  , dbg_transformationInfo opts > None+  , dbg_countTransformations opts+  , isJust (dbg_transformationsLimit opts)+  ]++-- | Check whether the requested information is available to the specified+-- transformation according to the options. e.g.+--+-- @+-- traceIf (hasDebugInfo AppliedName name opts) ("Trace something using: " <> show name)+-- @+--+-- This accounts for the set of transformations which are being debugged. For a+-- check which is agnostic to the a transformation, see 'hasTransformationInfo'.+hasDebugInfo :: TransformationInfo -> String -> DebugOpts -> Bool+hasDebugInfo info name opts =+  isDebugged name && hasTransformationInfo info opts+ where+  isDebugged n =+    let set = dbg_transformations opts+     in Set.null set || Set.member n set++-- | Check that the transformation info shown supports the requested info.+-- If the call-site is in the context of a particular transformation,+-- 'hasDebugInfo' should be used instead.+hasTransformationInfo :: TransformationInfo -> DebugOpts -> Bool+hasTransformationInfo info opts =+  info <= dbg_transformationInfo opts++-- NOTE [debugging options]+--+-- The preset debugging options here provide backwards compatibility with the+-- old style DebugLevel enum. However it is also possible to have finer-grained+-- control over debugging by using individual flags which did not previously+-- exist, e.g. -fclash-debug-invariants.++-- | -fclash-debug DebugNone+debugNone :: DebugOpts+debugNone = DebugOpts+  { dbg_invariants = False+  , dbg_transformationInfo = None+  , dbg_transformations = Set.empty+  , dbg_countTransformations = False+  , dbg_transformationsFrom = Nothing+  , dbg_transformationsLimit = Nothing+  , dbg_historyFile = Nothing+  }++-- | -fclash-debug DebugSilent+debugSilent :: DebugOpts+debugSilent = debugNone { dbg_invariants = True }++-- | -fclash-debug DebugFinal+debugFinal :: DebugOpts+debugFinal = debugSilent { dbg_transformationInfo = FinalTerm }++-- | -fclash-debug DebugCount+debugCount :: DebugOpts+debugCount = debugFinal { dbg_countTransformations = True }++-- | -fclash-debug DebugName+debugName :: DebugOpts+debugName = debugCount { dbg_transformationInfo = AppliedName }++-- | -fclash-debug DebugTry+debugTry :: DebugOpts+debugTry = debugName { dbg_transformationInfo = TryName }++-- | -fclash-debug DebugApplied+debugApplied :: DebugOpts+debugApplied = debugTry { dbg_transformationInfo = AppliedTerm }++-- | -fclash-debug DebugAll+debugAll :: DebugOpts+debugAll = debugApplied { dbg_transformationInfo = TryTerm }++-- | Options passed to Clash compiler+data ClashOpts = ClashOpts+  { opt_werror :: Bool+  -- ^ Are warnings treated as errors.+  --+  -- Command line flag: -Werror+  , opt_inlineLimit :: Int+  -- ^ Change the number of times a function f can undergo inlining inside+  -- some other function g. This prevents the size of g growing dramatically.+  --+  -- Command line flag: -fclash-inline-limit+  , opt_specLimit :: Int+  -- ^ Change the number of times a function can undergo specialization.+  --+  -- Command line flag: -fclash-spec-limit+  , opt_inlineFunctionLimit :: Word+  -- ^ Set the threshold for function size. Below this threshold functions are+  -- always inlined (if it is not recursive).+  --+  -- Command line flag: -fclash-inline-function-limit+  , opt_inlineConstantLimit :: Word+  -- ^ Set the threshold for constant size. Below this threshold constants are+  -- always inlined. A value of 0 inlines all constants.+  --+  -- Command line flag: -fclash-inline-constant-limit+  , opt_evaluatorFuelLimit :: Word+  -- ^ Set the threshold for maximum unfolding depth in the evaluator. A value+  -- of zero means no potentially non-terminating binding is unfolded.+  --+  -- Command line flag: -fclash-evaluator-fuel-limit+  , opt_debug :: DebugOpts+  -- ^ Options which control debugging. See 'DebugOpts'.+  , opt_ghcDebugLevel :: Int+  -- ^ What the GHC debug level is (i.e. @-g<N>@).+  --+  -- Clash uses this to decide whether to emit source-location information in+  -- generated HDL.+  , opt_cachehdl :: Bool+  -- ^ Reuse previously generated output from Clash. Only caches topentities.+  --+  -- Command line flag: -fclash-no-cache+  , opt_clear :: Bool+  -- ^ Remove HDL directories before writing to them. By default, Clash will+  -- only write to non-empty directories if it can prove all files in it are+  -- generated by a previous run. This option applies to directories of the+  -- various top entities, i.e., the subdirectories made in the directory passed+  -- in with @-fclash-hdldir@. Note that Clash will still use a cache if it can.+  --+  -- Command line flag: @-fclash-clear@+  , opt_primWarn :: Bool+  -- ^ Disable warnings for primitives+  --+  -- Command line flag: -fclash-no-prim-warn+  , opt_color :: OverridingBool+  -- ^ Show colors in debug output+  --+  -- Command line flag: -fdiagnostics-color+  , opt_intWidth :: Int+  -- ^ Set the bit width for the Int\/Word\/Integer types. The only allowed values+  -- are 32 or 64.+  , opt_hdlDir :: Maybe String+  -- ^ Directory to save HDL files to+  , opt_hdlSyn :: HdlSyn+  -- ^ Synthesis target. See "HdlSyn" for available options.+  , opt_errorExtra :: Bool+  -- ^ Show additional information in error messages+  , opt_importPaths :: [FilePath]+  -- ^ Paths where Clash should look for modules+  , opt_componentPrefix :: Maybe Text+  -- ^ Prefix components with given string+  , opt_newInlineStrat :: Bool+  -- ^ Use new inline strategy. Functions marked NOINLINE will get their own+  -- HDL module.+  , opt_escapedIds :: Bool+  -- ^ Use escaped identifiers in HDL. See:+  --+  --  * https://peterfab.com/ref/vhdl/vhdl_renerta/source/vhd00037.htm+  --  * https://peterfab.com/ref/verilog/verilog_renerta/source/vrg00018.htm+  , opt_lowerCaseBasicIds :: PreserveCase+  -- ^ Force all generated basic identifiers to lowercase. Among others, this+  -- affects module and file names.+  , opt_ultra :: Bool+  -- ^ Perform a high-effort compile, trading improved performance for+  -- potentially much longer compile times.+  --+  -- Name inspired by Design Compiler's /compile_ultra/ flag.+  , opt_forceUndefined :: Maybe (Maybe Int)+  -- ^+  -- * /Nothing/: generate undefined's in the HDL+  --+  -- * /Just Nothing/: replace undefined's by a constant in the HDL; the+  -- compiler decides what's best+  --+  -- * /Just (Just x)/: replace undefined's by /x/ in the HDL+  , opt_checkIDir :: Bool+  -- ^ Check whether paths specified in 'opt_importPaths' exists on the+  -- filesystem.+  , opt_aggressiveXOpt :: Bool+  -- ^ Enable aggressive X optimization, which may remove undefineds from+  -- generated HDL by replaced with defined alternatives.+  , opt_aggressiveXOptBB :: Bool+  -- ^ Enable aggressive X optimization, which may remove undefineds from+  -- HDL generated by blackboxes. This enables the ~ISUNDEFINED template tag.+  , opt_inlineWFCacheLimit :: Word+  -- ^ At what size do we cache normalized work-free top-level binders.+  , opt_edalize :: Bool+  -- ^ Generate an EDAM file for use with Edalize.+  , opt_renderEnums :: Bool+  -- ^ Render sum types with all zero-width fields as enums where supported, as+  -- opposed to rendering them as bitvectors.+  , opt_timescalePrecision :: Period+  -- ^ Timescale precision set in Verilog files. E.g., setting this would sets+  -- the second part of @`timescale 100fs/100fs@.+  , opt_ignoreBrokenGhcs :: Bool+  -- ^ Don't error if we see a (potentially) broken GHC / platform combination.+  -- See the project's @README.md@ for more information.+  , opt_concurrentTopEntities :: Bool+  -- ^ Compile top entities concurrently. Disabling this is useful when+  -- investigating bugs, because it will make log output deterministic.+  --+  -- Command line flag: -fclash-no-concurrent-topentity-compilation+  }+  deriving (Show, Eq, NFData, Generic, Hashable)++defClashOpts :: ClashOpts+defClashOpts+  = ClashOpts+  { opt_werror              = False+  , opt_inlineLimit         = 20+  , opt_specLimit           = 20+  , opt_inlineFunctionLimit = 15+  , opt_inlineConstantLimit = 0+  , opt_evaluatorFuelLimit  = 20+  , opt_debug               = debugNone+  , opt_ghcDebugLevel       = 0+  , opt_cachehdl            = True+  , opt_clear               = False+  , opt_primWarn            = True+  , opt_color               = Auto+  , opt_intWidth            = WORD_SIZE_IN_BITS+  , opt_hdlDir              = Nothing+  , opt_hdlSyn              = Other+  , opt_errorExtra          = False+  , opt_importPaths         = []+  , opt_componentPrefix     = Nothing+  , opt_newInlineStrat      = True+  , opt_escapedIds          = True+  , opt_lowerCaseBasicIds   = PreserveCase+  , opt_ultra               = False+  , opt_forceUndefined      = Nothing+  , opt_checkIDir           = True+  , opt_aggressiveXOpt      = False+  , opt_aggressiveXOptBB    = False+  , opt_inlineWFCacheLimit  = 10 -- TODO: find "optimal" value+  , opt_edalize             = False+  , opt_renderEnums         = True+  , opt_timescalePrecision  = Period 100 Fs+  -- XXX: We probe environment variables until we've found a proper solution to+  --      https://github.com/clash-lang/clash-compiler/issues/2762.+  , opt_ignoreBrokenGhcs    = unsafeLookupEnvBool "CLASH_IGNORE_BROKEN_GHCS" False+  , opt_concurrentTopEntities = True+  }++-- | Synopsys Design Constraint (SDC) information for a component.+-- Currently this limited to the names and periods of clocks for create_clock.+--+newtype SdcInfo = SdcInfo+  { sdcClock :: [(Text, VDomainConfiguration)]+  }++-- | Render an SDC file from an SdcInfo.+-- The clock periods, waveforms, and targets are all hardcoded.+--+pprSDC :: SdcInfo -> Doc ()+pprSDC = vcat . fmap go . sdcClock+ where+  go (i, dom) =+        -- VDomainConfiguration stores period in ps, SDC expects it in ns.+    let p        = MkFixed (toInteger $ vPeriod dom) :: Fixed E3+        name     = braces (pretty (Text.dropAround (== '\\') i))+        period   = viaShow p+        waveform = braces ("0.000" <+> viaShow (p / 2))+        targets  = brackets ("get_ports" <+> name)+     in hsep+          [ "create_clock"+          , "-name" <+> name+          , "-period" <+> period+          , "-waveform" <+> waveform+          , targets+          ]
+ src/Clash/Edalize/Edam.hs view
@@ -0,0 +1,325 @@+{-|+Copyright       : (C) 2020, QBayLogic+License         : BSD2 (see the file LICENSE)+Maintainer      : QBayLogic B.V. <devops@qbaylogic.com>++Data types and rendering for Edalize Metadata files (EDAM).+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Edalize.Edam+  ( Edam(..)+  , EdamFile(..)+  , EdamFileType(..)+  , EdamTools(..)+  , GhdlOptions(..)+  , IcarusOptions(..)+  , ModelsimOptions(..)+  , QuartusOptions(..)+  , VivadoOptions(..)++  , pprEdam+  ) where++import Data.Default+import Data.Maybe+import Data.Text (Text)++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter+#else+import Data.Text.Prettyprint.Doc+#endif++-- | EDAM data structure to be given to an Edalize backend. This contains all+-- information needed to generate a project scaffolding. Note that hooks and+-- VPI modules are currently not specified by clash.+--+data Edam = Edam+  { edamProjectName :: Text+  , edamTopEntity   :: Text+  , edamFiles       :: [EdamFile]+  , edamToolOptions :: EdamTools+  }++pprEdam :: Edam -> Doc ann+pprEdam (Edam n te fs ts) = vsep+  [ pyPre+  , hsep ["edam", equals, manifest]+  , pyPost+  ]+ where+  manifest = pyRecord+    [ pyField "name" $ squotes (pretty n)+    , pyField "toplevel" $ squotes (pretty te)+    , pyField "files" $ pyList (fmap pprFile fs)+    , pyField "tool_options" $ pprEdamTools ts+    ]++-- | Information about each file in the project. This does not include+-- is_include_file or include_path, as these are not currently used by Clash.+--+data EdamFile = EdamFile+  { efName        :: FilePath+  , efType        :: EdamFileType+  , efLogicalName :: Text+  }++pprFile :: EdamFile -> Doc ann+pprFile (EdamFile n ty ln) =+  pyRecord+    [ pyField "name" $ joinPath n+    , pyField "file_type" $ squotes (pprFileType ty)+    , pyField "logical_name" $ squotes (pretty ln)+    ]++-- | A subset of the file types recognized by Edalize. The supported formats+-- are largely from IP-XACT 2014 (IEEE 1685-2014), although Edalize extends+-- this with other types, e.g. QSYS.+--+-- Only file types which are generated by Clash are listed.+--+data EdamFileType+  = Unknown+    -- ^ Unknown file type.+  | VhdlSource+    -- ^ VHDL source.+  | VerilogSource+    -- ^ Verilog source.+  | SystemVerilogSource+    -- ^ SystemVerilog source.+  | TclSource+    -- ^ Tool Command Language source.+  | QSYS+    -- ^ QSys system source.+  | SDC+    -- ^ Synopsys Design Constraints source.+  deriving (Eq, Show)++pprFileType :: EdamFileType -> Doc ann+pprFileType = \case+  Unknown -> "unknown"+  VhdlSource -> "vhdlSource"+  VerilogSource -> "verilogSource"+  SystemVerilogSource -> "systemVerilogSource"+  TclSource -> "tclSource"+  QSYS -> "QSYS"+  SDC -> "SDC"++-- | Tool-specific configuration used by Edalize.+-- Currently only tools which are supported by Clash are provided.+--+data EdamTools = EdamTools+  { etGhdl      :: Maybe GhdlOptions+  , etIcarus    :: Maybe IcarusOptions+  , etModelsim  :: Maybe ModelsimOptions+  , etQuartus   :: Maybe QuartusOptions+  , etVivado    :: Maybe VivadoOptions+  }++instance Default EdamTools where+  def = EdamTools def def def def def++pprEdamTools :: EdamTools -> Doc ann+pprEdamTools tools =+  pyRecord+    [ pyField "ghdl" $ pprGhdlOptions ghdl+    , pyField "icarus" $ pprIcarusOptions icarus+    , pyField "modelsim" $ pprModelsimOptions modelsim+    , pyDocField+        "quartus"+        "TODO Specify options if using Quartus"+        (pprQuartusOptions quartus)++    , pyDocField+        "vivado"+        "TODO Specify options if using Vivado"+        (pprVivadoOptions vivado)+    ]+ where+  ghdl     = fromMaybe def (etGhdl tools)+  icarus   = fromMaybe def (etIcarus tools)+  modelsim = fromMaybe def (etModelsim tools)+  quartus  = fromMaybe def (etQuartus tools)+  vivado   = fromMaybe def (etVivado tools)++data GhdlOptions = GhdlOptions+  { ghdlAnalyseOpts :: [Text]+  , ghdlRunOpts     :: [Text]+  }++instance Default GhdlOptions where+  def = GhdlOptions [] []++pprGhdlOptions :: GhdlOptions -> Doc ann+pprGhdlOptions (GhdlOptions aOpts rOpts) =+  pyRecord+    [ pyDocField+        "analyze_options"+        "Command line arguments for analysis"+        (flagList (fmap pretty aOpts))++    , pyDocField+        "run_options"+        "Command line arguments for simulation"+        (flagList (fmap pretty rOpts))+    ]++data IcarusOptions = IcarusOptions+  { icarusOpts      :: [Text]+  , icarusTimeScale :: Text+  }++instance Default IcarusOptions where+  def = IcarusOptions [] "100fs/100fs"++pprIcarusOptions :: IcarusOptions -> Doc ann+pprIcarusOptions (IcarusOptions opts ts) =+  pyRecord+    [ pyDocField+        "iverilog_options"+        "Command line options for iverilog"+        (flagList (fmap pretty opts))++    , pyDocField+        "timescale"+        "Default timescale for simulation"+        (squotes (pretty ts))+    ]++data ModelsimOptions = ModelsimOptions+  { msVlogOpts :: [Text]+  , msVsimOpts :: [Text]+  }++instance Default ModelsimOptions where+  def = ModelsimOptions [] []++pprModelsimOptions :: ModelsimOptions -> Doc ann+pprModelsimOptions (ModelsimOptions vlog vsim) =+  pyRecord+    [ pyDocField+        "vlog_options"+        "Command line arguments for vlog"+        (flagList (fmap pretty vlog))++    , pyDocField+        "vsim_options"+        "Command line arguments for vsim"+        (flagList (fmap pretty vsim))+    ]++data QuartusOptions = QuartusOptions+  { quartusBoardDevIndex :: Int+  , quartusFamily        :: Text+  , quartusDevice        :: Text+  , quartusOpts          :: [Text]+  , quartusDseOpts       :: [Text]+  }++instance Default QuartusOptions where+  def = QuartusOptions 1 "" "" [] []++pprQuartusOptions :: QuartusOptions -> Doc ann+pprQuartusOptions (QuartusOptions bdi fam dev opts dse) =+  pyRecord+    [ pyDocField+        "board_device_index"+        "Specify the FPGA's device number in the JTAG chain"+        (squotes (pretty bdi))++    , pyDocField+        "family"+        "FPGA family, e.g. Cyclone IV E"+        (squotes (pretty fam))++    , pyDocField+        "device"+        "Device identifier, e.g. EP4CE55F23C8"+        (squotes (pretty dev))++    , pyDocField+        "quartus_options"+        "Command line arguments for Quartus"+        (flagList (fmap pretty opts))++    , pyDocField+        "dse_options"+        "Command line arguments for Design Space Explorer"+        (flagList (fmap pretty dse))+    ]++data VivadoOptions = VivadoOptions+  { vivadoPart :: Text+  }++instance Default VivadoOptions where+  def = VivadoOptions ""++pprVivadoOptions :: VivadoOptions -> Doc ann+pprVivadoOptions (VivadoOptions part) =+  pyRecord+    [ pyDocField+        "part"+        "Specify target part by ID, e.g. xc7z020-1clg400c"+        (squotes (pretty part))+    ]++-- Helpers; don't export++pyPre :: Doc ann+pyPre = vsep+  [ "import os"+  , ""+  , "edam_root = os.path.dirname(os.path.realpath(__file__))"+  , "work_root = 'build'"+  , ""+  , "# TODO Specify the EDA tool to use"+  , "tool = ''"+  , ""+  ]++pyPost :: Doc ann+pyPost = vsep+  [ ""+  , "if __name__ == '__main__':"+  , indent 4 $ vsep+      [ "from edalize import *"+      , ""+      , "tool = get_edatool(tool)(edam=edam, work_root=work_root)"+      , "os.makedirs(work_root)"+      , "tool.configure()"+      , "tool.build()"+      ]+  ]++pyList :: [Doc ann] -> Doc ann+pyList xs = vsep [lbracket, indent 4 (commaList xs), rbracket]++pyRecord :: [Doc ann] -> Doc ann+pyRecord xs = vsep [lbrace, indent 4 (commaList xs), rbrace]++pyComment :: Text -> Doc ann+pyComment x = hsep ["#", pretty x]++pyField :: Text -> Doc ann -> Doc ann+pyField n x = hcat [squotes (pretty n), colon, space, x]++pyDocField :: Text -> Text -> Doc ann -> Doc ann+pyDocField n d x = vsep [pyComment d, pyField n x]++joinPath :: FilePath -> Doc ann+joinPath x = hcat+  [ "os.path.join"+  , parens (hsep $ punctuate comma ["edam_root", squotes (pretty x)])+  ]++flagList :: [Doc ann] -> Doc ann+flagList = squotes . hsep++commaList :: [Doc ann] -> Doc ann+commaList = vsep . punctuate comma+
+ src/Clash/Netlist.hs view
@@ -0,0 +1,1150 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                     2016-2017, Myrtle Software Ltd,+                     2017-2018, Google Inc.,+                     2022     , Google Inc.,+                     2021-2026, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Create Netlists out of normalized CoreHW Terms+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Netlist where++import           Control.Exception                (throw)+import           Control.Lens                     ((.=), (<~))+import qualified Control.Lens                     as Lens+import           Control.Monad                    (zipWithM)+import           Control.Monad.Extra              (concatMapM, mapMaybeM)+import           Control.Monad.Reader             (runReaderT)+import           Control.Monad.State.Strict       (State, runStateT, runState)+import           Data.Bifunctor                   (first, second)+import           Data.Char                        (ord)+import           Data.Either                      (partitionEithers, rights)+import           Data.Foldable                    (foldlM)+import           Data.List                        (elemIndex, partition)+import           Data.List.Extra                  (zipEqual)+import           Data.List.NonEmpty               (NonEmpty (..))+import qualified Data.List.NonEmpty.Extra         as NE+import           Data.Maybe+  (listToMaybe, fromMaybe)+import qualified Data.Map.Ordered                 as OMap+import qualified Data.Set                         as Set+import qualified Data.Text                        as StrictText+import           GHC.Stack                        (HasCallStack)++import           GHC.Utils.Outputable             (ppr, showSDocUnsafe)+import           GHC.Types.SrcLoc                 (isGoodSrcSpan)++import           Clash.Annotations.Primitive      (HDL)+import           Clash.Annotations.BitRepresentation.ClashLib+  (coreToType')+import           Clash.Annotations.BitRepresentation.Internal+  (CustomReprs, DataRepr'(..), ConstrRepr'(..), getDataRepr, getConstrRepr)+import           Clash.Core.DataCon               (DataCon (..))+import           Clash.Core.HasType+import           Clash.Core.Literal               (Literal (..))+import           Clash.Core.Name                  (Name(..))+import           Clash.Core.Pretty                (showPpr)+import           Clash.Core.Term+  (IsMultiPrim (..), PrimInfo (..), mpi_resultTypes,  Alt, Pat (..), Term (..),+   TickInfo (..), collectArgs, collectArgsTicks,+   collectTicks, mkApps, mkTicks, stripTicks)+import qualified Clash.Core.Term                  as Core+import           Clash.Core.TermInfo              (multiPrimInfo', splitMultiPrimArgs)+import           Clash.Core.Type+  (Type (..), coreView1, splitFunForallTy, splitCoreFunForallTy)+import           Clash.Core.TyCon                 (TyConMap)+import           Clash.Core.TysPrim               (integerPrimTy, naturalPrimTy)+import           Clash.Core.Util                  (splitShouldSplit)+import           Clash.Core.Var                   (Id, Var (..), isGlobalId)+import           Clash.Core.VarEnv+  (VarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, lookupVarEnv,+   lookupVarEnv')+import           Clash.Driver.Types               (BindingMap, Binding(..), ClashEnv(..), ClashOpts (..))+import           Clash.Netlist.BlackBox+import qualified Clash.Netlist.Id                 as Id+import           Clash.Netlist.Types              as HW+import           Clash.Netlist.Util+import           Clash.Primitives.Types           as P+import           Clash.Util+import qualified Clash.Util.Interpolate           as I+import Clash.Core.PartialEval (Evaluator)++-- | Generate a hierarchical netlist out of a set of global binders with+-- @topEntity@ at the top.+genNetlist+  :: ClashEnv+  -> Evaluator+  -> Bool+  -- ^ Whether this we're compiling a testbench (suppresses certain warnings)+  -> BindingMap+  -- ^ Global binders+  -> VarEnv TopEntityT+  -- ^ TopEntity annotations+  -> VarEnv Identifier+  -- ^ Top entity names+  -> (CustomReprs -> TyConMap -> Type ->+      State HWMap (Maybe (Either String FilteredHWType)))+  -- ^ Hardcoded Type -> HWType translator+  -> Bool+  -- ^ Whether the backend supports ifThenElse expressions+  -> SomeBackend+  -- ^ The current HDL backend+  -> IdentifierSet+  -- ^ Seen components+  -> FilePath+  -- ^ HDL dir+  -> Maybe StrictText.Text+  -- ^ Component name prefix+  -> Id+  -- ^ Name of the @topEntity@+  -> IO (Component, ComponentMap, IdentifierSet)+genNetlist env eval isTb globals tops topNames typeTrans ite be seen0 dir prefixM topEntity = do+  ((_meta, topComponent), s) <-+    runNetlistMonad env eval isTb globals tops typeTrans ite be seen1 dir componentNames_+      $ genComponent topEntity+  return (topComponent, _components s, seen1)+ where+  (componentNames_, seen1) =+    genNames (opt_newInlineStrat (envOpts env)) prefixM seen0 topNames globals++-- | Run a NetlistMonad action in a given environment+runNetlistMonad+  :: ClashEnv+  -> Evaluator+  -> Bool+  -- ^ Whether this we're compiling a testbench (suppresses certain warnings)+  -> BindingMap+  -- ^ Global binders+  -> VarEnv TopEntityT+  -- ^ TopEntity annotations+  -> (CustomReprs -> TyConMap -> Type ->+      State HWMap (Maybe (Either String FilteredHWType)))+  -- ^ Hardcode Type -> HWType translator+  -> Bool+  -- ^ Whether the backend supports ifThenElse expressions+  -> SomeBackend+  -- ^ The current HDL backend+  -> IdentifierSet+  -- ^ Seen components+  -> FilePath+  -- ^ HDL dir+  -> VarEnv Identifier+  -- ^ Seen components+  -> NetlistMonad a+  -- ^ Action to run+  -> IO (a, NetlistState)+runNetlistMonad env eval isTb s tops typeTrans ite be seenIds_ dir componentNames_+  = flip runReaderT (NetlistEnv env "" "" Nothing [] eval)+  . flip runStateT s'+  . runNetlist+  where+    s' =+      NetlistState+        { _bindings=s+        , _components=OMap.empty+        , _typeTranslator=typeTrans+        , _curCompNm=(error "genComponent should have set _curCompNm", noSrcSpan)+        , _seenIds=seenIds_+        , _seenComps=seenIds_+        , _seenPrimitives=Set.empty+        , _componentNames=componentNames_+        , _topEntityAnns=tops+        , _hdlDir=dir+        , _curBBlvl=0+        , _isTestBench=isTb+        , _backEndITE=ite+        , _backend=be+        , _htyCache=mempty+        , _usages=mempty+        }++-- | Generate names for all binders in "BindingMap", except for the ones already+-- present in given identifier varenv.+genNames+  :: Bool+  -- ^ New inline strategy enabled?+  -> Maybe StrictText.Text+  -- ^ Prefix+  -> IdentifierSet+  -- ^ Identifier set to extend+  -> VarEnv Identifier+  -- ^ Pre-generated names+  -> BindingMap+  -> (VarEnv Identifier, IdentifierSet)+genNames newInlineStrat prefixM is env bndrs =+  runState (foldlM go env bndrs) is+ where+  go env_ (bindingId -> id_) =+    case lookupVarEnv id_ env_ of+      Just _ -> pure env_+      Nothing -> do+        nm <- Id.makeBasic (genComponentName newInlineStrat prefixM id_)+        pure (extendVarEnv id_ nm env_)++-- | Generate names for top entities. Should be executed at the very start of+-- the synthesis process and shared between all passes.+genTopNames+  :: ClashOpts+  -> HDL+  -- ^ HDL to generate identifiers for+  -> [TopEntityT]+  -> (VarEnv Identifier, IdentifierSet)+genTopNames opts hdl tops =+  -- TODO: Report error if fixed top entities have conflicting names+  flip runState (Id.emptyIdentifierSet esc lw hdl) $ do+    env0 <- foldlM goFixed emptyVarEnv fixedTops+    env1 <- foldlM goNonFixed env0 nonFixedTops+    pure env1+ where+  prefixM = opt_componentPrefix opts+  esc = opt_escapedIds opts+  lw = opt_lowerCaseBasicIds opts++  fixedTops = [(topId, ann) | TopEntityT{topId, topAnnotation=Just ann} <- tops]+  nonFixedTops = [topId | TopEntityT{topId, topAnnotation=Nothing} <- tops]++  goFixed env (topId, ann) = do+    topNm <- genTopName prefixM ann+    pure (extendVarEnv topId topNm env)++  goNonFixed env id_ = do+    topNm <- Id.makeBasic (genComponentName True prefixM id_)+    pure (extendVarEnv id_ topNm env)++-- | Generate a component for a given function (caching)+genComponent+  :: HasCallStack+  => Id+  -- ^ Name of the function+  -> NetlistMonad (ComponentMeta, Component)+genComponent compName = do+  compExprM <- lookupVarEnv compName <$> Lens.use bindings+  case compExprM of+    Nothing -> do+      (_,sp) <- Lens.use curCompNm+      throw (ClashException sp ($(curLoc) ++ "No normalized expression found for: " ++ show compName) Nothing)+    Just b -> do+      makeCachedO compName components $ genComponentT compName (bindingTerm b)++-- | Generate a component for a given function+genComponentT+  :: HasCallStack+  => Id+  -- ^ Name of the function+  -> Term+  -- ^ Corresponding term+  -> NetlistMonad (ComponentMeta, Component)+genComponentT compName0 componentExpr = do+  tcm <- Lens.view tcCache+  compName1 <- (`lookupVarEnv'` compName0) <$> Lens.use componentNames+  sp <- (bindingLoc . (`lookupVarEnv'` compName0)) <$> Lens.use bindings+  curCompNm .= (compName1, sp)+  usages .= mempty++  topEntityTM <- lookupVarEnv compName0 <$> Lens.use topEntityAnns+  let topAnnMM = topAnnotation <$> topEntityTM+      topVarTypeM = snd . splitCoreFunForallTy tcm . coreTypeOf . topId <$> topEntityTM++  seenIds <~ Lens.use seenComps+  (wereVoids,compInps,argWrappers,compOutps,resUnwrappers,binders,resultM) <-+    case splitNormalized tcm componentExpr of+      Right (args, binds, res) -> do+        let varType1 = fromMaybe (coreTypeOf res) topVarTypeM+        mkUniqueNormalized+          emptyInScopeSet+          topAnnMM+          -- HACK: Determine resulttype of this function by looking at its definition+          -- instead of looking at its last binder (which obscures any attributes+          -- [see: Clash.Annotations.SynthesisAttributes]).+          (args, binds, res{varType=varType1})+      Left err ->+        throw (ClashException sp ($curLoc ++ err) Nothing)++  netDecls <- concatMapM mkNetDecl (filter (maybe (const True) (/=) resultM . fst) binders)+  decls    <- concat <$> mapM (uncurry mkDeclarations) binders++  case resultM of+    Just result -> do+      [NetDecl' _ _ _ rIM] <- case filter ((==result) . fst) binders of+        b:_ -> mkNetDecl b+        _ -> error "internal error: couldn't find result binder"++      u <- Lens.use usages+      let useOf i = fromMaybe Cont $ lookupUsage (fst i) u++      let (compOutps',resUnwrappers') = case compOutps of+            [oport] -> ([(useOf oport,oport,rIM)],resUnwrappers)+            _ -> case resUnwrappers of+              NetDecl n res resTy:_ ->+                (map (\op -> (useOf op,op,Nothing)) compOutps+                ,NetDecl' n res resTy Nothing:drop 1 resUnwrappers+                )+              _ -> error "internal error: insufficient resUnwrappers"+          component      = Component compName1 compInps compOutps'+                             (netDecls ++ argWrappers ++ decls ++ resUnwrappers')+      ids <- Lens.use seenIds+      return (ComponentMeta wereVoids sp ids u, component)+    -- No result declaration means that the result is empty, this only happens+    -- when the TopEntity has an empty result. We just create an empty component+    -- in this case.+    Nothing -> do+      let component = Component compName1 compInps [] (netDecls ++ argWrappers ++ decls)+      ids <- Lens.use seenIds+      u <- Lens.use usages+      return (ComponentMeta wereVoids sp ids u, component)++mkNetDecl :: (Id, Term) -> NetlistMonad [Declaration]+mkNetDecl (id_,tm) | (_,_,ticks) <- collectArgsTicks tm = preserveVarEnv $ withTicks ticks $ \_ -> do++  lAttrs <- Lens.view localAttrs+  hwTy0 <- unsafeCoreTypeToHWTypeM' $(curLoc) (coreTypeOf id_)+  let hwTy = case hwTy0 of+        Annotated attrs hty0 -> Annotated (attrs ++ lAttrs) hty0+        hty0 -> annotated lAttrs hty0++  -- GHC starts including sources notes on any debug level greater than 0+  -- we copy this behaviour here.+  emitLocs <- (>0) . opt_ghcDebugLevel <$> Lens.view clashOpts+  let+    srcNote =+      if emitLocs then+        addSrcNote $ case tm of+          Tick (SrcSpan s) _ -> s+          _ -> nameLoc (varName id_)+      else+        Nothing++  if | not (shouldRenderDecl hwTy tm) -> return []+     | (Prim pInfo@PrimInfo{primMultiResult=MultiResult}, args) <- collectArgs tm ->+          multiDecls srcNote pInfo args+     | otherwise -> pure <$> singleDecl srcNote hwTy++  where+    multiDecls srcNote pInfo args0 = do+      tcm <- Lens.view tcCache+      resInits0 <- getResInits (id_, tm)+      let+        resInits1 = map Just resInits0 <> repeat Nothing+        mpInfo = multiPrimInfo' tcm pInfo+        (_, res) = splitMultiPrimArgs mpInfo args0++        netdecl i typ resInit =+          NetDecl' srcNote (Id.unsafeFromCoreId i) typ resInit++      hwTys <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc)) (mpi_resultTypes mpInfo)+      pure (zipWith3 netdecl res hwTys resInits1)++    singleDecl srcNote hwTy = do+      rIM <- listToMaybe <$> getResInits (id_, tm)+      return (NetDecl' srcNote (Id.unsafeFromCoreId id_) hwTy rIM)++    addSrcNote loc+      | isGoodSrcSpan loc = Just (StrictText.pack (showSDocUnsafe (ppr loc)))+      | otherwise = Nothing++    isMultiPrimSelect :: Term -> Bool+    isMultiPrimSelect t = case collectArgs t of+      (Prim (primName -> "c$multiPrimSelect"), _) -> True+      _ -> False++    shouldRenderDecl :: HWType -> Term -> Bool+    shouldRenderDecl ty t+      | isVoid ty = False+      | isMultiPrimSelect t = False+      | otherwise = True++    -- Set the initialization value of a signal when a primitive wants to set it+    getResInits :: (Id, Term) -> NetlistMonad [Expr]+    getResInits (i,collectArgs -> (k,args0)) = case k of+      Prim p -> extractPrimWarnOrFail (primName p) >>= go p+      _ -> return []+     where+      go pInfo (BlackBox {resultInits=nmDs, multiResult=True}) = do+        tcm <- Lens.view tcCache+        let (args1, res) = splitMultiPrimArgs (multiPrimInfo' tcm pInfo) args0+        (bbCtx, _) <- mkBlackBoxContext (primName pInfo) Concurrent res args1+        mapM (go' (primName pInfo) bbCtx) nmDs+      go pInfo (BlackBox {resultInits=nmDs}) = do+        (bbCtx, _) <- mkBlackBoxContext (primName pInfo) Concurrent [i] args0+        mapM (go' (primName pInfo) bbCtx) nmDs+      go _ _ = pure []++      go' pNm bbCtx nmD = do+        (bbTempl, templDecl) <- prepareBlackBox pNm nmD bbCtx+        case templDecl of+          [] ->+            return (BlackBoxE pNm [] [] [] bbTempl bbCtx False)+          _  -> do+            (_,sloc) <- Lens.use curCompNm+            throw (ClashException sloc [I.i|+              Initial values cannot produce declarations, but saw:++                #{templDecl}++              after rendering initial values for blackbox:++                #{pNm}++              Given template:++                #{nmD}+            |] Nothing)++-- | Generate a list of concurrent Declarations for a let-binder, return an+-- empty list if the bound expression is represented by 0 bits+mkDeclarations+  :: HasCallStack+  => Id+  -- ^ LHS of the let-binder+  -> Term+  -- ^ RHS of the let-binder+  -> NetlistMonad [Declaration]+mkDeclarations = mkDeclarations' Concurrent++-- | Generate a list of Declarations for a let-binder, return an empty list if+-- the bound expression is represented by 0 bits+mkDeclarations'+  :: HasCallStack+  => DeclarationType+  -- ^ Concurrent of sequential declaration+  -> Id+  -- ^ LHS of the let-binder+  -> Term+  -- ^ RHS of the let-binder+  -> NetlistMonad [Declaration]+mkDeclarations' declType bndr (collectTicks -> (Var v,ticks)) =+  withTicks ticks (mkFunApp declType (Id.unsafeFromCoreId bndr) v [])++mkDeclarations' _declType _bndr e@(collectTicks -> (Case _ _ [],_)) = do+  (_,sp) <- Lens.use curCompNm+  throw $ ClashException+          sp+          ( unwords [ $(curLoc)+                    , "Not in normal form: Case-decompositions with an"+                    , "empty list of alternatives not supported:\n\n"+                    , showPpr e+                    ])+          Nothing++mkDeclarations' declType bndr (collectTicks -> (Case scrut altTy (alt:alts@(_:_)),ticks)) =+  withTicks ticks (mkSelection declType (CoreId bndr) scrut altTy (alt :| alts))++mkDeclarations' declType bndr app = do+  let (appF,args0,ticks) = collectArgsTicks app+      (args,tyArgs) = partitionEithers args0+  case appF of+    Var f+      | null tyArgs ->+        withTicks ticks (mkFunApp declType (Id.unsafeFromCoreId bndr) f args)+      | otherwise   -> do+        (_,sp) <- Lens.use curCompNm+        throw (ClashException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showPpr app) Nothing)+    _ -> do+      (exprApp,declsApp0) <- mkExpr False declType (CoreId bndr) app+      let dstId = Id.unsafeFromCoreId bndr+      assn  <- case exprApp of+                 Identifier _ Nothing ->+                   -- Supplied 'bndr' was used to assign a result to, so we+                   -- don't have to manually turn it into a declaration+                   pure []++                 Noop ->+                   -- Rendered expression rendered a "noop" - a list of+                   -- declarations without a result. Used for things like+                   -- mealy IO / inline assertions / multi result primitives.+                   pure []++                 _ -> do+                   -- Turn returned expression into declaration by assigning+                   -- it to 'dstId'+                   assn <- case declType of+                     Concurrent -> contAssign dstId exprApp+                     Sequential -> procAssign Blocking dstId exprApp+                   pure [assn]++      declsApp1 <- if null declsApp0+                   then withTicks ticks return+                   else pure declsApp0+      return (declsApp1 ++ assn)++-- | Generate a declaration that selects an alternative based on the value of+-- the scrutinee+mkSelection+  :: DeclarationType+  -> NetlistId+  -> Term+  -> Type+  -> NonEmpty Alt+  -> [Declaration]+  -> NetlistMonad [Declaration]+mkSelection declType bndr scrut altTy alts0 tickDecls = do+  let dstId = netlistId1 id Id.unsafeFromCoreId bndr+  tcm <- Lens.view tcCache+  let scrutTy = inferCoreTypeOf tcm scrut+  scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy+  scrutId  <- Id.suffix dstId "selection"+  (_,sp) <- Lens.use curCompNm+  ite <- Lens.use backEndITE+  altHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) altTy+  let e = Case scrut altTy (NE.toList alts0)+  case iteAlts scrutHTy alts0 of+    Just (altT,altF)+      | ite+      , Concurrent <- declType+      -> do+      (scrutExpr,scrutDecls) <- case scrutHTy of+        SP {} -> first (mkScrutExpr sp scrutHTy (fst (NE.last alts0))) <$>+                   mkExpr True declType (NetlistId scrutId scrutTy) scrut+        _ -> mkExpr False declType (NetlistId scrutId scrutTy) scrut+      altTId <- Id.suffix dstId "sel_alt_t"+      altFId <- Id.suffix dstId "sel_alt_f"+      (altTExpr,altTDecls) <- mkExpr False declType (NetlistId altTId altTy) altT+      (altFExpr,altFDecls) <- mkExpr False declType (NetlistId altFId altTy) altF+      -- This logic (and the same logic a few lines below) is faulty in the+      -- sense that it won't generate "void decls" if the alternatives' type+      -- is void, but the type of the scrut isn't. Ideally, we'd like to pass+      -- a boolean to 'mkExpr' indicating that it should only render "void decls"+      -- but that it should skip any others.+      --+      -- TODO: Fix ^+      if | isVoid altHTy && isVoid scrutHTy+          -> return $! scrutDecls ++ altTDecls ++ altFDecls+         | isVoid altHTy+          -> return $! altTDecls ++ altFDecls+         | otherwise+          -> do dstAssign <- contAssign dstId (IfThenElse scrutExpr altTExpr altFExpr)+                return $! scrutDecls ++ altTDecls ++ altFDecls ++ tickDecls ++ [dstAssign]+    _ | scrutTy == integerPrimTy+      -> throw (ClashException sp ($(curLoc) ++ "Can't create netlist for:  case (_ :: Integer) of ...") (Just $ showPpr e))+    _ | scrutTy == naturalPrimTy+      -> throw (ClashException sp ($(curLoc) ++ "Can't create netlist for:  case (_ :: Natural) of ...") (Just $ showPpr e))+    _ -> do+      reprs <- Lens.view customReprs+      let alts1 = (reorderDefault . reorderCustom tcm reprs scrutTy) alts0+      (scrutExpr,scrutDecls) <- first (mkScrutExpr sp scrutHTy (fst (NE.head alts1))) <$>+                                  mkExpr True declType (NetlistId scrutId scrutTy) scrut+      (exprs,altsDecls)      <- unzip <$> mapM (mkCondExpr scrutHTy) (NE.toList alts1)+      case declType of+        Sequential -> do+          -- Assign to the result in every branch+          (altNets,exprAlts) <- fmap unzip (zipWithM (altAssign dstId) exprs altsDecls)+          return $! scrutDecls ++ tickDecls ++ concat altNets +++                    [Seq [Branch scrutExpr scrutHTy exprAlts]]+        Concurrent ->+          if | isVoid altHTy && isVoid scrutHTy+              -> return $! concat altsDecls ++ scrutDecls+             | isVoid altHTy+              -> return $! concat altsDecls+             | otherwise+              -> do assign <- condAssign dstId altHTy scrutExpr scrutHTy exprs+                    return $! scrutDecls ++ concat altsDecls ++ tickDecls ++ [assign]+ where+  mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe HW.Literal,Expr),[Declaration])+  mkCondExpr scrutHTy (pat,alt) = do+    altId <- Id.suffix (netlistId1 id Id.unsafeFromCoreId bndr) "sel_alt"+    (altExpr,altDecls) <- mkExpr False declType (NetlistId altId altTy) alt+    (,altDecls) <$> case pat of+      DefaultPat           -> return (Nothing,altExpr)+      DataPat dc _ _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr)+      LitPat  (IntegerLiteral i) -> return (Just (NumLit i),altExpr)+      LitPat  (IntLiteral i) -> return (Just (NumLit i), altExpr)+      LitPat  (WordLiteral w) -> return (Just (NumLit w), altExpr)+      LitPat  (CharLiteral c) -> return (Just (NumLit . toInteger $ ord c), altExpr)+      LitPat  (Int64Literal i) -> return (Just (NumLit i), altExpr)+      LitPat  (Word64Literal w) -> return (Just (NumLit w), altExpr)+      LitPat  (Int8Literal i) -> return (Just (NumLit i), altExpr)+      LitPat  (Int16Literal i) -> return (Just (NumLit i), altExpr)+      LitPat  (Int32Literal i) -> return (Just (NumLit i), altExpr)+      LitPat  (Word8Literal w) -> return (Just (NumLit w), altExpr)+      LitPat  (Word16Literal w) -> return (Just (NumLit w), altExpr)+      LitPat  (Word32Literal w) -> return (Just (NumLit w), altExpr)+      LitPat  (NaturalLiteral n) -> return (Just (NumLit n), altExpr)+      _  -> do+        (_,sp) <- Lens.use curCompNm+        throw (ClashException sp ($(curLoc) ++ "Not an integer literal in LitPat:\n\n" ++ showPpr pat) Nothing)++  mkScrutExpr :: SrcSpan -> HWType -> Pat -> Expr -> Expr+  mkScrutExpr sp scrutHTy pat scrutE = case pat of+    DataPat dc _ _ -> let modifier = Just (DC (scrutHTy,dcTag dc - 1))+                      in case scrutE of+                          Identifier scrutId Nothing -> Identifier scrutId modifier+                          _ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement:\n\n" ++ show scrutE) Nothing)+    _ -> scrutE++  altAssign+    :: Identifier+    -> (Maybe HW.Literal,Expr)+    -> [Declaration]+    -> NetlistMonad ([Declaration],(Maybe HW.Literal,[Seq]))+  altAssign i (m,expr) ds = do+    let (nets,rest) = partition isNet ds+    assn <- case expr of+              Noop -> pure []+              _ -> do assn <- procAssign Blocking i expr+                      pure [assn]+    pure (nets,(m,map SeqDecl (rest ++ assn)))+   where+    isNet NetDecl' {} = True+    isNet _ = False++-- GHC puts default patterns in the first position, we want them in the+-- last position.+reorderDefault+  :: NonEmpty (Pat, Term)+  -> NonEmpty (Pat, Term)+reorderDefault ((DefaultPat,e) :| alts') =+  case alts' of+    [] -> (DefaultPat,e) :| []+    x:xs -> x :| (xs <> [(DefaultPat,e)])+reorderDefault alts' = alts'++reorderCustom+  :: TyConMap+  -> CustomReprs+  -> Type+  -> NonEmpty (Pat, Term)+  -> NonEmpty (Pat, Term)+reorderCustom tcm reprs (coreView1 tcm -> Just ty) alts =+  reorderCustom tcm reprs ty alts+reorderCustom _tcm reprs (coreToType' -> Right typeName) alts =+  case getDataRepr typeName reprs of+    Just (DataRepr' _name _size _constrReprs) ->+      NE.sortOn (patPos reprs . fst) alts+    Nothing ->+      alts+reorderCustom _tcm _reprs _type alts =+  alts++patPos+  :: CustomReprs+  -> Pat+  -> Int+patPos _reprs DefaultPat = -1+patPos _reprs (LitPat _) = 0+patPos reprs pat@(DataPat dataCon _ _) =+  -- We sort data patterns by their syntactical order+  let name = nameOcc $ dcName dataCon in+  case getConstrRepr name reprs of+    Nothing ->+      -- TODO: err+      error $ $(curLoc) ++ (show pat)+    Just (ConstrRepr' _name n _mask _value _anns) ->+      n+++-- | Generate a list of Declarations for a let-binder where the RHS is a function application+mkFunApp+  :: HasCallStack+  => DeclarationType+  -> Identifier -- ^ LHS of the let-binder+  -> Id -- ^ Name of the applied function+  -> [Term] -- ^ Function arguments+  -> [Declaration] -- ^ Tick declarations+  -> NetlistMonad [Declaration]+mkFunApp declType dstId fun args tickDecls = do+  topAnns <- Lens.use topEntityAnns+  tcm     <- Lens.view tcCache+  case (isGlobalId fun, lookupVarEnv fun topAnns) of+    (True, Just topEntity)+      | let ty = coreTypeOf (topId topEntity)+      , let (fArgTys0,fResTy) = splitFunForallTy ty+      -- Take into account that clocks and stuff are split off from any product+      -- types containing them+      , let fArgTys1 = splitShouldSplit tcm $ rights fArgTys0+      , length fArgTys1 == length args+      -> do+        argHWTys <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc)) fArgTys1+        (argExprs, concat -> argDecls) <- unzip <$>+          mapM (\(e,t) -> mkExpr False declType (NetlistId dstId t) e)+                                 (zip args fArgTys1)++        -- Filter void arguments, but make sure to render their declarations:+        let+          filteredTypeExprs = filter (not . isVoid . snd) (zip argExprs argHWTys)++        dstHWty  <- unsafeCoreTypeToHWTypeM' $(curLoc) fResTy++        -- TODO: The commented code fetches the function definition from the+        --       set of global bindings and uses it to replicate the port names+        --       of it. However, this does rely on the binding actually being+        --       present in the binding map. This isn't the case, as only+        --       the current top entity (and its dependencies, stopping at other+        --       top entities) are present. We can't add the non-normalized+        --       version, as this logic relies on 'splitArguments' having+        --       fired. Adding normalized versions would create a dependency+        --       between two top entities, defeating the ability to compile in+        --       parallel.+        --+        --       One option is to split the normalization process into two+        --       chunks: preprocessing (e.g., 'splitArguments') and actually+        --       normalizing. This would ensure only minimal work is being done+        --       serially.+        --+        --       The current workaround is to not rely on named arguments, using+        --       positional ones instead when instantiating a top entity.+        --+        -- funTerm <- fmap bindingTerm . lookupVarEnv fun <$> Lens.use bindings+        --+        -- expandedTopEntity <-+        --   case splitNormalized tcm <$> funTerm of+        --     Nothing -> error ("Internal error: could not find " <> show fun)+        --     Just (Left err) -> error ("Internal error: " <> show err)+        --     Just (Right (argIds, _binds, resId)) -> do+        --       argTys <- mapM (unsafeCoreTypeToHWTypeM $(curLoc)) (map coreTypeOf argIds)+        --       resTy <- unsafeCoreTypeToHWTypeM $(curLoc) (coreTypeOf resId)+        --       is <- Lens.use seenIds+        --       let topAnnM = topAnnotation topEntity+        --       pure (expandTopEntityOrErr is (zip argIds argTys) (resId, resTy) topAnnM)++        -- Generate ExpandedTopEntity, see TODO^+        argTys <- mapM (unsafeCoreTypeToHWTypeM $(curLoc) . inferCoreTypeOf tcm) args+        resTy <- unsafeCoreTypeToHWTypeM $(curLoc) fResTy+        let+          ettArgs = (Nothing,) <$> argTys+          ettRes = (Nothing, resTy)+        expandedTopEntity <-+            expandTopEntityOrErrM ettArgs ettRes (topAnnotation topEntity)++        instDecls <-+          mkTopUnWrapper+            fun expandedTopEntity (dstId, dstHWty)+            filteredTypeExprs tickDecls++        return (argDecls ++ instDecls)++      | otherwise -> error $ $(curLoc) ++ "under-applied TopEntity: " ++ showPpr fun+    (True, Nothing) -> do+      normalized <- Lens.use bindings+      case lookupVarEnv fun normalized of+        Nothing -> error [I.i|+          Internal error: unknown normalized binder:++            #{showPpr fun}+        |]+        Just (Binding{bindingTerm}) -> do+          (_, Component compName compInps co _) <- preserveVarEnv $ genComponent fun+          let argTys = map (inferCoreTypeOf tcm) args+          argHWTys <- mapM coreTypeToHWTypeM' argTys++          (argExprs, concat -> argDecls) <- unzip <$>+            mapM (\(e,t) -> mkExpr False declType (NetlistId dstId t) e)+                 (zip args argTys)++          -- Filter void arguments, but make sure to render their declarations:+          let+            argTypeExprs = zip argHWTys (zip argExprs argTys)+            filteredTypeExprs = fmap snd $ filter (not . isVoidMaybe True . fst) argTypeExprs++          let compOutp = (\(_,x,_) -> x) <$> listToMaybe co+          if length filteredTypeExprs == length compInps+            then do+              (argExprs',argDecls') <- (second concat . unzip) <$> mapM (toSimpleVar declType dstId) filteredTypeExprs+              let inpAssigns    = zipWith (\(i,t) e -> (Identifier i Nothing,In,t,e)) compInps argExprs'+                  outpAssign    = case compOutp of+                    Nothing -> []+                    Just (id_,hwtype) -> [(Identifier id_ Nothing,Out,hwtype,Identifier dstId Nothing)]+              let instLabel0 = StrictText.concat [Id.toText compName, "_", Id.toText dstId]+              instLabel1 <- fromMaybe instLabel0 <$> Lens.view setName+              instLabel2 <- affixName instLabel1+              instLabel3 <- Id.makeBasic instLabel2+              let portMap = NamedPortMap (outpAssign ++ inpAssigns)+                  instDecl = InstDecl Entity Nothing [] compName instLabel3 [] portMap+              declareInstUses outpAssign+              return (argDecls ++ argDecls' ++ tickDecls ++ [instDecl])+            else+              let+                argsFiltered :: [Expr]+                argsFiltered = map fst filteredTypeExprs+              in error [I.i|+              Under-applied normalized function at component #{compName}:++              #{showPpr fun}++              Core:++              #{showPpr bindingTerm}++              Applied to arguments:+              #{showPpr args}++              Applied to filtered arguments:+              #{argsFiltered}++              Component inputs:+              #{compInps}+            |]+    _ ->+      case args of+        [] -> do+          -- TODO: Figure out what to do with zero-width constructs+          assn <- contAssign dstId (Identifier (Id.unsafeFromCoreId fun) Nothing)+          pure [assn]+        _ -> error [I.i|+          Netlist generation encountered a local function. This should not+          happen. Function:++            #{showPpr fun}++          Arguments:++            #{showPpr args}++          Posssible user issues:++            * A top entity has an higher-order argument, e.g (Int -> Int) or+            Maybe (Int -> Int)++          Possible internal compiler issues:++            * 'bindOrLiftNonRep' failed to fire++            * 'caseCon' failed to eliminate something of a type such as+            "Maybe (Int -> Int)"+          |]++toSimpleVar :: DeclarationType+            -> Identifier+            -> (Expr,Type)+            -> NetlistMonad (Expr,[Declaration])+toSimpleVar _ _ (e@(Identifier _ Nothing),_) = return (e,[])+toSimpleVar declType dstId (e,ty) = do+  argNm <- Id.suffix dstId "fun_arg"+  hTy <- unsafeCoreTypeToHWTypeM' $(curLoc) ty+  let assignTy = declTypeUsage declType+  argDecl <- mkInit declType assignTy argNm hTy e+  return (Identifier argNm Nothing, argDecl)++-- | Generate an expression for a term occurring on the RHS of a let-binder+mkExpr :: HasCallStack+       => Bool -- ^ Treat BlackBox expression as declaration+       -> DeclarationType+       -- ^ Should the returned declarations be concurrent or sequential?+       -> NetlistId -- ^ Name hint for the id to (potentially) assign the result to+       -> Term -- ^ Term to convert to an expression+       -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations+mkExpr _ _ _ (stripTicks -> Core.Literal l) = do+  iw <- Lens.view intWidth+  return (mkLiteral iw l, [])++mkExpr bbEasD declType bndr app =+ let (appF,args,ticks) = collectArgsTicks app+     (tmArgs,tyArgs) = partitionEithers args+ in  withTicks ticks $ \tickDecls -> do+  hwTys  <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc)) (netlistTypes bndr)+  (_,sp) <- Lens.use curCompNm+  let hwTyA = case hwTys of+        hwTy:_ -> hwTy+        _ -> error ("internal error: unable to extract sufficient hwTys from: " <> show bndr)+  let invalid kind = throw (ClashException sp ($(curLoc) ++ "Not in normal form: " ++ kind ++ "\n\n" ++ showPpr app) Nothing)+  case appF of+    Data dc -> mkDcApplication declType hwTys bndr dc tmArgs+    Prim pInfo -> mkPrimitive False bbEasD declType bndr pInfo args tickDecls+    Var f+      | null tmArgs ->+          if isVoid hwTyA then+            return (Noop, [])+          else do+            return (Identifier (Id.unsafeFromCoreId f) Nothing, [])+      | not (null tyArgs) -> invalid "Var-application with type arguments"+      | otherwise -> do+          argNm <- Id.suffix (netlistId1 id Id.unsafeFromCoreId bndr) "fun_arg"+          decls  <- mkFunApp declType argNm f tmArgs tickDecls+          if isVoid hwTyA then+            return (Noop, decls)+          else+            -- This net was already declared in the call to mkSelection.+            return ( Identifier argNm Nothing+                   , NetDecl Nothing argNm hwTyA : decls)+    Case scrut ty' [alt] -> mkProjection declType bbEasD bndr scrut ty' alt+    Case scrut tyA (alt:alts) -> do+      argNm <- Id.suffix (netlistId1 id Id.unsafeFromCoreId bndr) "sel_arg"+      decls  <- mkSelection declType (NetlistId argNm (netlistTypes1 bndr))+                            scrut tyA (alt :| alts) tickDecls+      if isVoid hwTyA then+        return (Noop, decls)+      else+        -- This net was already declared in the call to mkSelection+        return ( Identifier argNm Nothing+               , NetDecl' Nothing argNm hwTyA Nothing:decls)+    Case _ _ [] -> invalid "No case alternatives\n\n"+    Letrec binders body -> do+      netDecls <- concatMapM mkNetDecl binders+      decls    <- concatMapM (uncurry (mkDeclarations' declType)) binders+      (bodyE,bodyDecls) <- mkExpr bbEasD declType bndr (mkApps (mkTicks body ticks) args)+      return (bodyE,netDecls ++ decls ++ bodyDecls)+    Core.Literal _ -> invalid "application of literal"+    Let _ _ -> invalid "application of let"+    TyApp _ _ -> invalid "application of type application"+    Tick _ _ -> invalid "application of tick"+    Cast _ _ _ -> invalid "application of cast"+    Lam _ _ -> invalid "application of lambda"+    TyLam _ _ -> invalid "application of type lambda"+    App _ _ -> invalid "application of application"++-- | Generate an expression that projects a field out of a data-constructor.+--+-- Works for both product types, as sum-of-product types.+mkProjection+  :: DeclarationType+  -> Bool+  -- ^ Projection must bind to a simple variable+  -> NetlistId+  -- ^ Name hint for the signal to which the projection is (potentially) assigned+  -> Term+  -- ^ The subject/scrutinee of the projection+  -> Type+  -- ^ The type of the result+  -> Alt+  -- ^ The field to be projected+  -> NetlistMonad (Expr, [Declaration])+mkProjection declType mkDec bndr scrut altTy alt@(pat,v) = do+  tcm <- Lens.view tcCache+  let assignTy = declTypeUsage declType+  let scrutTy = inferCoreTypeOf tcm scrut+      e = Case scrut scrutTy [alt]+  (_,sp) <- Lens.use curCompNm+  varTm <- case v of+    (Var n) -> return n+    _ -> throw (ClashException sp ($(curLoc) +++                "Not in normal form: RHS of case-projection is not a variable:\n\n"+                 ++ showPpr e) Nothing)+  sHwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy+  vHwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) altTy+  scrutRendered <- do+    scrutNm <-+      netlistId1+        Id.next+        (\b -> Id.suffix (Id.unsafeFromCoreId b) "projection")+        bndr+    (scrutExpr,newDecls) <- mkExpr False declType (NetlistId scrutNm scrutTy) scrut+    case scrutExpr of+      Identifier newId modM ->+        pure (Right (newId, modM, newDecls))+      Noop ->+        -- Scrutinee was a zero-width / void construct. We need to render its+        -- declarations, but it's no use assigning it to a new variable.+        -- TODO: Figure out whether we need to render alternatives too.+        -- TODO: seems useless?+        pure (Left newDecls)+      _ -> do+        scrutDecl <- mkInit declType assignTy scrutNm sHwTy scrutExpr+        pure (Right (scrutNm, Nothing, newDecls ++ scrutDecl))++  case scrutRendered of+    Left newDecls -> pure (Noop, newDecls)+    Right (selId, modM, decls) -> do+      let altVarId = Id.unsafeFromCoreId varTm+      modifier <- case pat of+        DataPat dc exts tms -> do+          let+            tms' =+              if bindsExistentials exts tms then+                throw (ClashException sp ($(curLoc)+                  ++ "Not in normal form: Pattern binds existential variables:\n\n"+                  ++ showPpr e) Nothing)+              else+                tms+          argHWTys <- mapM coreTypeToHWTypeM' (map coreTypeOf tms)+          let tmsBundled   = zip argHWTys tms'+              tmsFiltered  = filter (maybe False (not . isVoid) . fst) tmsBundled+              tmsFiltered' = map snd tmsFiltered+          case elemIndex varTm {varType = altTy} tmsFiltered' of+            Nothing -> pure Nothing+            Just fI+              | sHwTy /= vHwTy ->+                pure $ nestModifier modM (Just (Indexed (sHwTy,dcTag dc - 1,fI)))+              -- When element and subject have the same HW-type,+              -- then the projections is just the identity+              | otherwise ->+                pure $ nestModifier modM (Just (DC (Void Nothing,0)))+        _ -> throw (ClashException sp ($(curLoc)+               ++ "Not in normal form: Unexpected pattern in case-projection:\n\n"+               ++ showPpr e) Nothing)+      let extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier+      case bndr of+        NetlistId scrutNm _ | mkDec -> do+          scrutNm' <- Id.next scrutNm+          scrutDecl <- mkInit declType assignTy scrutNm' vHwTy extractExpr+          return (Identifier scrutNm' Nothing, scrutDecl ++ decls)+        MultiId {} -> error "mkProjection: MultiId"+        _ -> return (extractExpr,decls)+  where+    nestModifier Nothing  m          = m+    nestModifier m Nothing           = m+    nestModifier (Just m1) (Just m2) = Just (Nested m1 m2)++-- | Generate an expression for a DataCon application occurring on the RHS of a let-binder+mkDcApplication+    :: HasCallStack+    => DeclarationType+    -> [HWType]+    -- ^ HWType of the LHS of the let-binder, can multiple types when we're+    -- creating a "split" product type (e.g. a tuple of a Clock and Reset)+    -> NetlistId+    -- ^ Name hint for result id+    -> DataCon+    -- ^ Applied DataCon+    -> [Term]+    -- ^ DataCon Arguments+    -> NetlistMonad (Expr,[Declaration])+    -- ^ Returned expression and a list of generate BlackBox declarations+mkDcApplication declType [dstHType] bndr dc args = do+  let dcNm = nameOcc (dcName dc)+  tcm <- Lens.view tcCache+  let argTys = map (inferCoreTypeOf tcm) args+  argNm <- netlistId1 return (\b -> Id.suffix (Id.unsafeFromCoreId b) "dc_arg") bndr+  argHWTys <- mapM coreTypeToHWTypeM' argTys++  (argExprs, concat -> argDecls) <- unzip <$>+    mapM (\(e,t) -> mkExpr False declType (NetlistId argNm t) e) (zip args argTys)++  -- Filter void arguments, but make sure to render their declarations:+  let+    filteredTypeExprDecls =+      filter+        (not . isVoidMaybe True . fst)+        (zip argHWTys argExprs)++    (hWTysFiltered, argExprsFiltered) = unzip filteredTypeExprDecls++  fmap (,argDecls) $! case (hWTysFiltered,argExprsFiltered) of+    -- Is the DC just a newtype wrapper?+    ([Just argHwTy],[argExpr]) | argHwTy == dstHType ->+      return (HW.DataCon dstHType (DC (Void Nothing,-1)) [argExpr])+    _ -> case dstHType of+      SP _ dcArgPairs -> do+        let dcI      = dcTag dc - 1+            dcArgs   = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI+        case compare (length dcArgs) (length argExprsFiltered) of+          EQ -> return (HW.DataCon dstHType (DC (dstHType,dcI)) argExprsFiltered)+          LT -> error $ $(curLoc) ++ "Over-applied constructor: " ++ StrictText.unpack dcNm+          GT -> error $ $(curLoc) ++ "Under-applied constructor: " ++ StrictText.unpack dcNm+      Product _ _ dcArgs ->+        case compare (length dcArgs) (length argExprsFiltered) of+          EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprsFiltered)+          LT -> error $ $(curLoc) ++ "Over-applied constructor: " ++ StrictText.unpack dcNm+          GT -> error $ unlines [ $(curLoc) ++ "Under-applied constructor:" ++ StrictText.unpack dcNm+                                , "dcArgs=" ++ unlines [" - " ++ show x | x <- dcArgs]+                                , "argExprs=" ++ unlines [" - " ++ show x | x <- argExprs]+                                , "hWTysFilt=" ++ unlines [" - " ++ show x | x <- hWTysFiltered]+                                , "argExprsFilt=" ++ unlines [" - " ++ show x | x <- argExprsFiltered]+                                ]+      CustomProduct _ _ _ _ dcArgs ->+        case compare (length dcArgs) (length argExprsFiltered) of+          EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprsFiltered)+          LT -> error $ $(curLoc) ++ "Over-applied constructor: " ++ StrictText.unpack dcNm+          GT -> error $ $(curLoc) ++ "Under-applied constructor: " ++ StrictText.unpack dcNm+      Sum _ _ ->+        return (HW.DataCon dstHType (DC (dstHType,dcTag dc - 1)) [])+      CustomSP _ _ _ dcArgsTups -> do+        -- Safely get item from list, or err with note+        let dcI    = dcTag dc - 1+        let note   = $(curLoc) ++ "No DC with tag: " ++ show dcI+        let argTup = indexNote note dcArgsTups dcI+        let (_, _, dcArgs) = argTup++        case compare (length dcArgs) (length argExprsFiltered) of+          EQ -> return (HW.DataCon dstHType (DC (dstHType, dcI)) argExprsFiltered)+          LT -> error $ $(curLoc) ++ "Over-applied constructor: " ++ StrictText.unpack dcNm+          GT -> error $ $(curLoc) ++ "Under-applied constructor: " ++ StrictText.unpack dcNm++      CustomSum _ _ _ _ ->+        return (HW.DataCon dstHType (DC (dstHType, dcTag dc - 1)) [])+      Enable _ ->+        case argExprsFiltered of+          [x] -> return (HW.DataCon dstHType (DC (dstHType,dcTag dc - 1)) [x])+          _   -> error $ $(curLoc) ++ "unexpected arguments to Enable: " ++ show argExprsFiltered+      Bool ->+        let dc' = case dcTag dc of+                   1  -> HW.Literal Nothing (BoolLit False)+                   2  -> HW.Literal Nothing (BoolLit True)+                   tg -> error $ $(curLoc) ++ "unknown bool literal: " ++ showPpr dc ++ "(tag: " ++ show tg ++ ")"+        in  return dc'+      Vector 0 _ -> return (HW.DataCon dstHType VecAppend [])+      Vector 1 _ -> case argExprsFiltered of+                      [e] -> return (HW.DataCon dstHType VecAppend [e])+                      _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showPpr args+      Vector _ _ -> case argExprsFiltered of+                      [e1,e2] -> return (HW.DataCon dstHType VecAppend [e1,e2])+                      _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showPpr args+      MemBlob _ _ ->+        case compare 6 (length argExprsFiltered) of+          EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprsFiltered)+          LT -> error $ $(curLoc) ++ "Over-applied constructor"+          GT -> error $ $(curLoc) ++ "Under-applied constructor"+      RTree 0 _ -> case argExprsFiltered of+                      [e] -> return (HW.DataCon dstHType RTreeAppend [e])+                      _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `LR`: " ++ showPpr args+      RTree _ _ -> case argExprsFiltered of+                      [e1,e2] -> return (HW.DataCon dstHType RTreeAppend [e1,e2])+                      _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `BR`: " ++ showPpr args+      String ->+        let dc' = case dcTag dc of+                    1 -> HW.Literal Nothing (StringLit "")+                    _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,dcTag dc,args,argHWTys)+        in  return dc'+      Void {} -> return Noop+      Signed _+        | dcNm == "GHC.Num.Integer.IS"+        , (a:_) <- argExprsFiltered+        -> pure a+        -- ByteArray# are non-translatable / void, except when they're literals+        | dcNm == "GHC.Num.Integer.IP"+        , (a@(HW.Literal Nothing (NumLit _)):_) <- argExprs+        -> pure a+        | dcNm == "GHC.Num.Integer.IN"+        -- ByteArray# are non-translatable / void, except when they're literals+        , (HW.Literal Nothing (NumLit i):_) <- argExprs+        -> pure (HW.Literal Nothing (NumLit (negate i)))+      Unsigned _+        | dcNm == "GHC.Num.Natural.NS"+        , (a:_) <- argExprsFiltered+        -> pure a+        | dcNm == "GHC.Num.Natural.NB"+        -- ByteArray# are non-translatable / void, except when they're literals+        , (a@(HW.Literal Nothing (NumLit _)):_) <- argExprs+        -> pure a+      _ ->+        error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys)++-- Handle MultiId assignment+mkDcApplication declType dstHTypes (MultiId argNms) _ args = do+  tcm                 <- Lens.view tcCache+  let argTys          = map (inferCoreTypeOf tcm) args+  argHWTys            <- mapM coreTypeToHWTypeM' argTys+  -- Filter out the arguments of hwtype `Void` and only translate+  -- them to the intermediate HDL afterwards+  let argsBundled   = zip argHWTys (zipEqual (map CoreId argNms) args)+      (_hWTysFiltered,argsFiltered) = unzip+        (filter (maybe True (not . isVoid) . fst) argsBundled)+  (argExprs,argDecls) <- fmap (second concat . unzip) $!+                         mapM (uncurry (mkExpr False declType)) argsFiltered+  if length dstHTypes == length argExprs then do+    assns <- mapMaybeM+                  (\case (_,Noop) -> pure Nothing+                         (dstId,e) -> let nm = netlistId1 id Id.unsafeFromCoreId dstId+                                       in case e of+                                            Identifier nm0 Nothing+                                              | nm == nm0 -> pure Nothing+                                            _ -> Just <$> case declType of+                                                            Concurrent -> contAssign nm e+                                                            Sequential -> procAssign Blocking nm e)+                  (zipEqual (map CoreId argNms) argExprs)+    return (Noop,argDecls ++ assns)+  else+    error "internal error"++mkDcApplication _ _ _ _ _ = error "internal error"
+ src/Clash/Netlist.hs-boot view
@@ -0,0 +1,82 @@+{-|+  Copyright   :  (C) 2015-2016, University of Twente+                     2022     , Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>+-}+{-# LANGUAGE CPP #-}++module Clash.Netlist+  (genComponent+  ,mkExpr+  ,mkDcApplication+  ,mkDeclarations+  ,mkDeclarations'+  ,mkNetDecl+  ,mkProjection+  ,mkSelection+  ,mkFunApp+  ) where++import Data.List.NonEmpty (NonEmpty)++import Clash.Core.DataCon   (DataCon)+import Clash.Core.Term      (Alt,LetBinding,Term)+import Clash.Core.Type      (Type)+import Clash.Core.Var       (Id)+import Clash.Netlist.Types+  (Expr, HWType, Identifier, NetlistMonad, Declaration, NetlistId,+   DeclarationType, ComponentMeta, Component)++import GHC.Stack (HasCallStack)++genComponent :: HasCallStack+             => Id+             -> NetlistMonad (ComponentMeta, Component)++mkExpr :: HasCallStack+       => Bool+       -> DeclarationType+       -> NetlistId+       -> Term+       -> NetlistMonad (Expr,[Declaration])++mkDcApplication :: HasCallStack+                => DeclarationType+                -> [HWType]+                -> NetlistId+                -> DataCon+                -> [Term]+                -> NetlistMonad (Expr,[Declaration])++mkProjection+  :: DeclarationType+  -> Bool+  -> NetlistId+  -> Term+  -> Type+  -> Alt+  -> NetlistMonad (Expr, [Declaration])++mkSelection+  :: DeclarationType+  -> NetlistId+  -> Term+  -> Type+  -> NonEmpty Alt+  -> [Declaration]+  -> NetlistMonad [Declaration]++mkNetDecl :: LetBinding -> NetlistMonad [Declaration]++mkDeclarations :: HasCallStack => Id -> Term -> NetlistMonad [Declaration]+mkDeclarations' :: HasCallStack => DeclarationType -> Id -> Term -> NetlistMonad [Declaration]++mkFunApp+  :: HasCallStack+  => DeclarationType+  -> Identifier -- ^ LHS of the let-binder+  -> Id -- ^ Name of the applied function+  -> [Term] -- ^ Function arguments+  -> [Declaration] -- ^ Tick declarations+  -> NetlistMonad [Declaration]
+ src/Clash/Netlist/BlackBox.hs view
@@ -0,0 +1,1365 @@+{-# LANGUAGE NamedFieldPuns #-}+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017     , Google Inc.,+                    2021-2024, QBayLogic B.V.+                    2022     , Google Inc.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Functions to create BlackBox Contexts and fill in BlackBox templates+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Netlist.BlackBox+    ( mkBlackBoxContext+    , extractPrimWarnOrFail+    , mkPrimitive+    , prepareBlackBox+    , isLiteral+    ) where++import           Control.Exception             (throw)+import           Control.Lens                  ((%=))+import qualified Control.Lens                  as Lens+import           Control.Monad                 (when, replicateM, zipWithM)+import           Control.Monad.Extra           (concatMapM)+import           Control.Monad.IO.Class        (liftIO)+import           Data.Bifunctor                (first, second)+import           Data.Either                   (lefts, partitionEithers)+import           Data.Foldable                 (for_)+import qualified Data.HashMap.Lazy             as HashMap+import qualified Data.IntMap                   as IntMap+import           Data.List.NonEmpty            (NonEmpty (..))+import           Data.List                     (elemIndex, partition)+import           Data.List.Extra               (countEq, mapAccumLM)+import           Data.Maybe                    (listToMaybe, fromJust, fromMaybe)+import           Data.Monoid                   (Ap(getAp))+import qualified Data.Set                      as Set+import           Data.Text.Lazy                (fromStrict)+import qualified Data.Text.Lazy                as Text+import           Data.Text                     (unpack)+import qualified Data.Text                     as TextS+import           Data.Text.Extra+import           GHC.Stack+  (HasCallStack, callStack, prettyCallStack)+import qualified System.Console.ANSI           as ANSI+import           System.Console.ANSI+  ( hSetSGR, SGR(SetConsoleIntensity, SetColor), Color(Magenta, Red)+  , ConsoleIntensity(BoldIntensity), ConsoleLayer(Foreground), ColorIntensity(Vivid))+import           System.IO+  (hPutStrLn, stderr, hFlush, hIsTerminalDevice)++import           Clash.Annotations.Primitive+  ( PrimitiveGuard(HasBlackBox, DontTranslate)+  , PrimitiveWarning(WarnNonSynthesizable, WarnAlways)+  , extractPrim, HDL(VHDL))+import           Clash.Core.DataCon            as D (dcTag)+import           Clash.Core.FreeVars           (freeIds)+import           Clash.Core.HasType+import           Clash.Core.Literal            as C (Literal (..))+import           Clash.Core.Name+  (Name (..), mkUnsafeSystemName)+import qualified Clash.Netlist.Id              as Id+import           Clash.Core.Pretty             (showPpr)+import           Clash.Core.Subst              (extendIdSubst, mkSubst, substTm)+import           Clash.Core.Term               as C+  (IsMultiPrim (..), PrimInfo (..), Term (..), WorkInfo (..), collectArgs,+   collectArgsTicks, collectBndrs, mkApps, PrimUnfolding(..))+import           Clash.Core.TermInfo+import           Clash.Core.Type               as C+  (Type (..), ConstTy (..), TypeView (..), mkFunTy, splitFunTys, tyView)+import           Clash.Core.TyCon              as C (TyConMap, tyConDataCons)+import           Clash.Core.Util+  (inverseTopSortLetBindings, splitShouldSplit)+import           Clash.Core.Var                as V+  (Id, mkLocalId, modifyVarName, varType)+import           Clash.Core.VarEnv+  (extendInScopeSet, mkInScopeSet, lookupVarEnv, uniqAway, unitVarSet)+import {-# SOURCE #-} Clash.Netlist+  (genComponent, mkDcApplication, mkDeclarations, mkExpr, mkNetDecl,+   mkProjection, mkSelection, mkFunApp, mkDeclarations')+import qualified Clash.Backend                 as Backend+import qualified Clash.Data.UniqMap as UniqMap+import           Clash.Debug                   (debugIsOn)+import           Clash.Driver.Bool             (OverridingBool(..))+import           Clash.Driver.Types+  (ClashOpts(opt_primWarn, opt_color, opt_werror))+import           Clash.Netlist.BlackBox.Types  as B+import           Clash.Netlist.BlackBox.Util   as B+import           Clash.Netlist.Types           as N+import           Clash.Netlist.Util            as N+import           Clash.Normalize.Primitives    (removedArg)+import           Clash.Primitives.Types        as P+import qualified Clash.Primitives.Util         as P+import           Clash.Signal.Internal         (ActiveEdge (..))+import           Clash.Util+import qualified Clash.Util.Interpolate        as I++-- | Emits (colorized) warning to stderr+warn+  :: ClashOpts+  -> String+  -> IO ()+warn opts msg = do+  -- TODO: Put in appropriate module+  useColor <-+    case opt_color opts of+      Always -> return True+      Never  -> return False+      Auto   -> hIsTerminalDevice stderr++  hSetSGR stderr [SetConsoleIntensity BoldIntensity]++  case opt_werror opts of+    True -> do+      when useColor $ hSetSGR stderr [SetColor Foreground Vivid Red]+      throw (ClashException noSrcSpan msg Nothing)++    False -> do+      when useColor $ hSetSGR stderr [SetColor Foreground Vivid Magenta]+      hPutStrLn stderr $ "[WARNING] " ++ msg+      hSetSGR stderr [ANSI.Reset]+      hFlush stderr++-- | Generate the context for a BlackBox instantiation.+mkBlackBoxContext+  :: HasCallStack+  => TextS.Text+  -- ^ Blackbox function name+  -> DeclarationType+  -- ^ Are we concurrent or sequential?+  -> [Id]+  -- ^ Identifiers binding the primitive/blackbox application+  -> [Either Term Type]+  -- ^ Arguments of the primitive/blackbox application+  -> NetlistMonad (BlackBoxContext,[Declaration])+mkBlackBoxContext bbName declType resIds args@(lefts -> termArgs) = do+    -- Make context inputs+    let+      resNms = fmap Id.unsafeFromCoreId resIds+      resNm = fromMaybe (error "mkBlackBoxContext: head") (listToMaybe resNms)+    resTys <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc) . coreTypeOf) resIds+    (imps,impDecls) <- unzip <$> zipWithM (mkArgument bbName resNm declType) [0..] termArgs+    (funs,funDecls) <-+      mapAccumLM+        (addFunction (map coreTypeOf resIds))+        IntMap.empty+        (zip termArgs [0..])++    -- Make context result+    let ress = map (flip Identifier Nothing) resNms++    lvl <- Lens.use curBBlvl+    (nm,_) <- Lens.use curCompNm++    -- Set "context name" to value set by `Clash.Magic.setName`, default to the+    -- name of the closest binder+    ctxName1 <- fromMaybe (map Id.toText resNms) . fmap pure <$> Lens.view setName+    -- Update "context name" with prefixes and suffixes set by+    -- `Clash.Magic.prefixName` and `Clash.Magic.suffixName`+    ctxName2 <- mapM affixName ctxName1++    return ( Context bbName (zip ress resTys) imps funs [] lvl nm (listToMaybe ctxName2)+           , concat impDecls ++ concat funDecls+           )+  where+    addFunction resTys im (arg,i) = do+      tcm <- Lens.view tcCache+      if isFun tcm arg then do+        -- Only try to calculate function plurality when primitive actually+        -- exists. Here to prevent crashes on __INTERNAL__ primitives.+        prim <- HashMap.lookup bbName <$> Lens.view primitives+        funcPlurality <-+          case extractPrim <$> prim of+            Just (Just p) ->+              P.getFunctionPlurality p args resTys i+            _ ->+              pure 1++        curBBlvl Lens.+= 1+        (fs,ds) <- case resIds of+          (resId:_) -> unzip <$> replicateM funcPlurality (mkFunInput bbName declType resId arg)+          _ -> error "internal error: insufficient resIds"+        curBBlvl Lens.-= 1++        let im' = IntMap.insert i fs im+        return (im', concat ds)+      else+        return (im, [])++prepareBlackBox+  :: TextS.Text+  -> BlackBox+  -> BlackBoxContext+  -> NetlistMonad (BlackBox,[Declaration])+prepareBlackBox _pNm templ bbCtx =+  case verifyBlackBoxContext bbCtx templ of+    Nothing -> do+      (t2,decls) <-+        onBlackBox+          (fmap (first BBTemplate) . setSym bbCtx)+          (\bbName bbHash bbFunc -> pure (BBFunction bbName bbHash bbFunc, []))+          templ+      for_ decls goDecl+      return (t2,decls)+    Just err0 -> do+      (_,sp) <- Lens.use curCompNm+      let err1 = concat [ "Couldn't instantiate blackbox for "+                        , Data.Text.unpack (bbName bbCtx), ". Verification "+                        , "procedure reported:\n\n" ++ err0 ]+      throw (ClashException sp ($(curLoc) ++ err1) Nothing)+ where+  -- Right now we assume that (1) a blackbox doesn't assign to a signal+  -- declared outside the black box template and (2) all uses of a signal+  -- within a blackbox are correct for the targeted HDL (i.e. we don't try+  -- to generate new signals when a signal is used incorrectly).+  goDecl = \case+    Assignment i u _ ->+      declareUse u i++    CondAssignment i _ _ _ _ -> do+      -- Currently, all CondAssignment get rendered as `always @*` blocks in+      -- (System)Verilog. This means when we target these HDL, this is _really_+      -- a blocking procedural assignment.+      SomeBackend b <- Lens.use backend+      let use = case Backend.hdlKind b of { VHDL -> Cont ; _ -> Proc Blocking }+      declareUse use i++    Seq seqs -> for_ seqs goSeq++    _ -> pure ()++  goSeq = \case+    AlwaysClocked _ _ seqs ->+      for_ seqs goSeq++    Initial seqs ->+      for_ seqs goSeq++    AlwaysComb seqs ->+      for_ seqs goSeq++    SeqDecl conc ->+      goDecl conc++    Branch _ _ alts ->+      let seqs = concatMap snd alts+       in for_ seqs goSeq++-- | Determine if a term represents a literal+isLiteral :: Term -> Bool+isLiteral e = case collectArgs e of+  (Data _, args)   -> all (either isLiteral (const True)) args+  (Prim _, args) -> all (either isLiteral (const True)) args+  (C.Literal _,_)  -> True+  _                -> False+++mkArgument+  :: TextS.Text+  -- ^ Blackbox function name+  -> Identifier+  -- ^ LHS of the original let-binder. Is used as a name hint to generate new+  -- names in case the argument is a declaration.+  -> DeclarationType+  -- ^ Are we concurrent or sequential?+  -> Int+  -- ^ Argument n (zero-indexed). Used for error message.+  -> Term+  -> NetlistMonad ( (Expr,HWType,Bool)+                  , [Declaration]+                  )+mkArgument bbName bndr declType nArg e = do+    tcm   <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm e+    iw    <- Lens.view intWidth+    hwTyM <- fmap stripFiltered <$> N.termHWTypeM e+    let eTyMsg = "(" ++ showPpr e ++ " :: " ++ showPpr ty ++ ")"+    ((e',t,l),d) <- case hwTyM of+      Nothing+        | (Prim p,_) <- collectArgs e+        , primName p == showt 'removedArg+        -> return ((Identifier (Id.unsafeMake (showt 'removedArg)) Nothing, Void Nothing, False), [])+        | otherwise+        -> return ((error ($(curLoc) ++ "Forced to evaluate untranslatable type: " ++ eTyMsg), Void Nothing, False), [])+      Just hwTy -> case collectArgsTicks e of+        (C.Var v,[],_) -> do+          return ((Identifier (Id.unsafeFromCoreId v) Nothing,hwTy,False),[])+        (C.Literal l,[],_) ->+          return ((mkLiteral iw l,hwTy,True),[])++        (Prim pinfo,args,ticks) -> withTicks ticks $ \tickDecls -> do+          (e',d) <- mkPrimitive True False declType (NetlistId bndr ty) pinfo args tickDecls+          case e' of+            (Identifier _ _) -> return ((e',hwTy,False), d)+            _                -> return ((e',hwTy,isLiteral e), d)+        (Data dc, args,_) -> do+          (exprN,dcDecls) <- mkDcApplication declType [hwTy] (NetlistId bndr ty) dc (lefts args)+          return ((exprN,hwTy,isLiteral e),dcDecls)+        (Case scrut ty' [alt],[],_) -> do+          (projection,decls) <- mkProjection declType False (NetlistId bndr ty) scrut ty' alt+          return ((projection,hwTy,False),decls)+        (Let _bnds _term, [], _ticks) -> do+          (exprN, letDecls) <- mkExpr False declType (NetlistId bndr ty) e+          return ((exprN,hwTy,False),letDecls)+        _ -> do+          let errMsg = [I.i|+            Forced to evaluate unexpected function argument:++              #{eTyMsg}++            in 'mkArgument' for argument #{nArg} of blackbox #{show bbName}.+          |]++          return ((Identifier (error ($(curLoc) ++ errMsg)) Nothing, hwTy, False), [])++    return ((e',t,l),d)++-- | Extract a compiled primitive from a guarded primitive. Emit a warning if+-- the guard wants to, or fail entirely.+extractPrimWarnOrFail+  :: HasCallStack+  => TextS.Text+  -- ^ Name of primitive+  -> NetlistMonad CompiledPrimitive+extractPrimWarnOrFail nm = do+  prim <- HashMap.lookup nm <$> Lens.view primitives+  case prim of+    Just (HasBlackBox warnings compiledPrim) ->+      -- See if we need to warn the user+      if null warnings then return compiledPrim else go warnings compiledPrim+    Just DontTranslate -> do+      -- We need to error because we encountered a primitive the user+      -- explicitly requested not to translate+      (_,sp) <- Lens.use curCompNm+      let msg = $(curLoc) ++ "Clash was forced to translate '" ++ unpack nm+             ++ "', but this value was marked with DontTranslate. Did you forget"+             ++ " to include a blackbox for one of the constructs using this?"+             ++ (if debugIsOn then "\n\n" ++ prettyCallStack callStack ++ "\n\n" else [])+      throw (ClashException sp msg Nothing)+    Nothing -> do+      -- Blackbox requested, but no blackbox found at all!+      (_,sp) <- Lens.use curCompNm+      let msg = $(curLoc) ++ "No blackbox found for: " ++ unpack nm+             ++ ". Did you forget to include directories containing "+             ++ "primitives? You can use '-i/my/prim/dir' to achieve this."+             ++ (if debugIsOn then "\n\n" ++ prettyCallStack callStack ++ "\n\n" else [])+      throw (ClashException sp msg Nothing)+ where+  go+    :: [PrimitiveWarning]+    -> CompiledPrimitive+    -> NetlistMonad CompiledPrimitive++  go ((WarnAlways warning):ws) cp = do+    opts <- Lens.view clashOpts+    let primWarn = opt_primWarn opts+    seen <- Set.member nm <$> Lens.use seenPrimitives++    when (primWarn && not seen)+      $ liftIO+      $ warn opts+      $ "Dubious primitive instantiation for "+     ++ unpack nm+     ++ ": "+     ++ warning+     ++ " (disable with -fclash-no-prim-warn)"++    go ws cp++  go ((WarnNonSynthesizable warning):ws) cp = do+    isTB <- Lens.use isTestBench+    if isTB then go ws cp else go ((WarnAlways warning):ws) cp++  go [] cp = do+    seenPrimitives %= Set.insert nm+    return cp++mkPrimitive+  :: Bool+  -- ^ Put BlackBox expression in parenthesis+  -> Bool+  -- ^ Treat BlackBox expression as declaration+  -> DeclarationType+  -- ^ Are we concurrent or sequential?+  -> NetlistId+  -- ^ Id to assign the result to+  -> PrimInfo+  -- ^ Primitive info+  -> [Either Term Type]+  -- ^ Arguments+  -> [Declaration]+  -- ^ Tick declarations+  -> NetlistMonad (Expr,[Declaration])+mkPrimitive bbEParen bbEasD declType dst pInfo args tickDecls =+  go =<< extractPrimWarnOrFail (primName pInfo)+  where+    tys = netlistTypes dst+    ty = fromMaybe (error "mkPrimitive") (listToMaybe tys)+    assignTy = declTypeUsage declType++    go+      :: CompiledPrimitive+      -> NetlistMonad (Expr, [Declaration])+    go =+      \case+        P.BlackBoxHaskell bbName wf _usedArgs multiResult funcName (_fHash, func) -> do+          bbFunRes <- func bbEasD (primName pInfo) args tys+          case bbFunRes of+            Left err -> do+              -- Blackbox template function returned an error:+              let err' = unwords [ $(curLoc) ++ "Could not create blackbox"+                                 , "template using", show funcName, "for"+                                 , show bbName ++ ".", "Function reported: \n\n"+                                 , err ]+              (_,sp) <- Lens.use curCompNm+              throw (ClashException sp err' Nothing)+            Right (BlackBoxMeta {..}, bbTemplate) ->+              -- Blackbox template generation successful. Rerun 'go', but this time+              -- around with a 'normal' @BlackBox@+              go (P.BlackBox+                    bbName wf bbRenderVoid multiResult bbKind () bbOutputUsage+                    bbLibrary bbImports bbFunctionPlurality bbIncludes+                    bbResultNames bbResultInits bbTemplate)+        -- See 'setupMultiResultPrim' in "Clash.Normalize.Transformations":+        P.BlackBox {name="c$multiPrimSelect"} ->+          pure (Noop, [])+        p@P.BlackBox {multiResult=True, name, template} -> do+          -- Multi result primitives assign their results to signals+          -- provided as arguments. Hence, we ignore any declarations+          -- from 'resBndr1'.+          tcm <- Lens.view tcCache+          let (args1, resArgs) = splitMultiPrimArgs (multiPrimInfo' tcm pInfo) args+          (bbCtx, ctxDcls) <- mkBlackBoxContext (primName pInfo) declType resArgs args1+          (templ, templDecl) <- prepareBlackBox name template bbCtx+          let bbDecl = N.BlackBoxD name (libraries p) (imports p) (includes p) templ bbCtx+          return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])+        p@(P.BlackBox {template, name=pNm, kind,outputUsage}) ->+          case kind of+            TDecl -> do+              resM <- resBndr1 True dst+              case resM of+                Just (dst',dstNm,dstDecl) -> do+                  (bbCtx,ctxDcls)   <- mkBlackBoxContext (primName pInfo) declType [dst'] args+                  (templ,templDecl) <- prepareBlackBox pNm template bbCtx+                  let bbDecl = N.BlackBoxD pNm (libraries p) (imports p)+                                           (includes p) templ bbCtx+                  declareUse outputUsage dstNm+                  return (Identifier dstNm Nothing,dstDecl ++ ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])++                -- Render declarations as a Noop when requested+                Nothing | RenderVoid <- renderVoid p -> do+                  -- TODO: We should probably 'mkBlackBoxContext' to accept empty lists+                  let dst1 = mkLocalId ty (mkUnsafeSystemName "__VOID_TDECL_NOOP__" 0)+                  (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) declType [dst1] args+                  (templ,templDecl) <- prepareBlackBox pNm template bbCtx+                  let bbDecl = N.BlackBoxD pNm (libraries p) (imports p)+                                           (includes p) templ bbCtx+                  return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])++                -- Otherwise don't render them+                Nothing -> return (Noop,[])+            TExpr -> do+              if bbEasD+                then do+                  resM <- resBndr1 True dst+                  case resM of+                    Just (dst',dstNm,dstDecl) -> do+                      (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) declType [dst'] args+                      (bbTempl,templDecl) <- prepareBlackBox pNm template bbCtx+                      let bbE =  BlackBoxE pNm (libraries p) (imports p) (includes p) bbTempl bbCtx bbEParen+                      tmpAssgn <- case declType of+                        Concurrent -> contAssign dstNm bbE+                        Sequential -> procAssign Blocking dstNm bbE+                      return (Identifier dstNm Nothing, dstDecl ++ ctxDcls ++ templDecl ++ [tmpAssgn])++                    -- Render expression as a Noop when requested+                    Nothing | RenderVoid <- renderVoid p -> do+                      -- TODO: We should probably 'mkBlackBoxContext' to accept empty lists+                      let dst1 = mkLocalId ty (mkUnsafeSystemName "__VOID_TEXPRD_NOOP__" 0)+                      (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) declType [dst1] args+                      (templ,templDecl) <- prepareBlackBox pNm template bbCtx+                      let bbDecl = N.BlackBoxD pNm (libraries p) (imports p)+                                               (includes p) templ bbCtx+                      return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])++                    -- Otherwise don't render them+                    Nothing -> return (Identifier (Id.unsafeMake "__VOID_TEXPRD__") Nothing,[])+                else do+                  resM <- resBndr1 False dst+                  case resM of+                    Just (dst',_,_) -> do+                      (bbCtx,ctxDcls)      <- mkBlackBoxContext (primName pInfo) declType [dst'] args+                      (bbTempl,templDecl0) <- prepareBlackBox pNm template bbCtx+                      let templDecl1 = case primName pInfo of+                            "Clash.Sized.Internal.BitVector.fromInteger#"+                              | [N.Literal _ (NumLit _), N.Literal _ _, N.Literal _ _] <- extractLiterals bbCtx -> []+                            "Clash.Sized.Internal.BitVector.fromInteger##"+                              | [N.Literal _ _, N.Literal _ _] <- extractLiterals bbCtx -> []+                            "Clash.Sized.Internal.Index.fromInteger#"+                              | [N.Literal _ (NumLit _), N.Literal _ _] <- extractLiterals bbCtx -> []+                            "Clash.Sized.Internal.Signed.fromInteger#"+                              | [N.Literal _ (NumLit _), N.Literal _ _] <- extractLiterals bbCtx -> []+                            "Clash.Sized.Internal.Unsigned.fromInteger#"+                              | [N.Literal _ (NumLit _), N.Literal _ _] <- extractLiterals bbCtx -> []+                            _ -> templDecl0+                      return (BlackBoxE pNm (libraries p) (imports p) (includes p) bbTempl bbCtx bbEParen,ctxDcls ++ templDecl1)+                    -- Render expression as a Noop when requested+                    Nothing | RenderVoid <- renderVoid p -> do+                      -- TODO: We should probably 'mkBlackBoxContext' to accept empty lists+                      let dst1 = mkLocalId ty (mkUnsafeSystemName "__VOID_TEXPRE_NOOP__" 0)+                      (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) declType [dst1] args+                      (templ,templDecl) <- prepareBlackBox pNm template bbCtx+                      let bbDecl = N.BlackBoxD pNm (libraries p) (imports p)+                                               (includes p) templ bbCtx+                      return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl])++                    -- Otherwise don't render them+                    Nothing -> return (Identifier (Id.unsafeMake "__VOID__") Nothing,[])+        P.Primitive pNm _ _+          | pNm == "GHC.Prim.tagToEnum#" -> do+              hwTy <- N.unsafeCoreTypeToHWTypeM' $(curLoc) ty+              case args of+                [Right (ConstTy (TyCon tcN)), Left (C.Literal (IntLiteral i))] -> do+                  tcm <- Lens.view tcCache+                  let dcs = tyConDataCons (UniqMap.find tcN tcm)+                      dc  = dcs !! fromInteger i+                  (exprN,dcDecls) <- mkDcApplication declType [hwTy] dst dc []+                  return (exprN,dcDecls)+                [Right _, Left scrut] -> do+                  tcm     <- Lens.view tcCache+                  let scrutTy = inferCoreTypeOf tcm scrut+                  (scrutExpr,scrutDecls) <-+                    mkExpr False declType (NetlistId (Id.unsafeMake "c$tte_rhs") scrutTy) scrut+                  case scrutExpr of+                    Identifier id_ Nothing -> return (DataTag hwTy (Left id_),scrutDecls)+                    _ -> do+                      scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy+                      tmpRhs <- Id.make "c$tte_rhs"+                      netDecl <- N.mkInit declType assignTy tmpRhs scrutHTy scrutExpr+                      return (DataTag hwTy (Left tmpRhs), netDecl ++ scrutDecls)+                _ -> error $ $(curLoc) ++ "tagToEnum: " ++ show (map (either showPpr showPpr) args)+          | pNm == "GHC.Prim.dataToTag#" -> case args of+              [Right _,Left (Data dc)] -> do+                iw <- Lens.view intWidth+                return (N.Literal (Just (Signed iw,iw)) (NumLit $ toInteger $ dcTag dc - 1),[])+              [Right _,Left scrut] -> do+                tcm      <- Lens.view tcCache+                let scrutTy = inferCoreTypeOf tcm scrut+                scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy+                (scrutExpr,scrutDecls) <-+                  mkExpr False declType (NetlistId (Id.unsafeMake "c$dtt_rhs") scrutTy) scrut+                case scrutExpr of+                  Identifier id_ Nothing -> return (DataTag scrutHTy (Right id_),scrutDecls)+                  _ -> do+                    tmpRhs <- Id.make "c$dtt_rhs"+                    netDecl <- N.mkInit declType assignTy tmpRhs scrutHTy scrutExpr+                    return (DataTag scrutHTy (Right tmpRhs),netDecl ++ scrutDecls)+              _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showPpr showPpr) args)++          | pNm `elem`+            ["GHC.Prim.dataToTagSmall#", "GHC.Prim.dataToTagLarge#"] -> case args of+              [Right _, Right _,Left (Data dc)] -> do+                iw <- Lens.view intWidth+                return (N.Literal (Just (Signed iw,iw)) (NumLit $ toInteger $ dcTag dc - 1),[])+              [Right _, Right _,Left scrut] -> do+                tcm      <- Lens.view tcCache+                let scrutTy = inferCoreTypeOf tcm scrut+                scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy+                (scrutExpr,scrutDecls) <-+                  mkExpr False declType (NetlistId (Id.unsafeMake "c$dtt_rhs") scrutTy) scrut+                case scrutExpr of+                  Identifier id_ Nothing -> return (DataTag scrutHTy (Right id_),scrutDecls)+                  _ -> do+                    tmpRhs <- Id.make "c$dtt_rhs"+                    netDecl <- N.mkInit declType assignTy tmpRhs scrutHTy scrutExpr+                    return (DataTag scrutHTy (Right tmpRhs),netDecl ++ scrutDecls)+              _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showPpr showPpr) args)++          | pNm == "Clash.Explicit.SimIO.mealyIO" -> do+              resM <- resBndr1 True dst+              case resM of+                Just (_,dstNm,dstDecl) -> do+                  tcm <- Lens.view tcCache+                  mealyDecls <- collectMealy dstNm dst tcm (lefts args)+                  return (Noop, dstDecl ++ mealyDecls)+                Nothing -> return (Noop,[])++          | pNm == "Clash.Explicit.SimIO.bindSimIO#" -> do+              (expr,decls) <- collectBindIO dst (lefts args)+              resM <- resBndr True dst+              case resM of+                Just (_,dstNms,dstDecl) -> case expr of+                  Noop ->+                    return (Noop,decls)+                  _ -> case dstNms of+                    [dstNm] -> do+                      declareUse (Proc Blocking) dstNm+                      assn <- procAssign Blocking dstNm expr+                      return ( Identifier dstNm Nothing+                             , dstDecl ++ decls ++ [assn])+                    _ -> error $ $(curLoc) ++ "bindSimIO: " ++ show resM+                _ ->+                  return (Noop,decls)++          | pNm == "Clash.Explicit.SimIO.apSimIO#" -> do+              collectAppIO dst (lefts args) []++          | pNm == "Clash.Explicit.SimIO.fmapSimIO#" -> do+              resM <- resBndr1 True dst+              case resM of+                Just (_,dstNm,dstDecl) -> case lefts args of+                  (fun0:arg0:_) -> do+                    tcm <- Lens.view tcCache+                    let arg1 = unSimIO tcm arg0+                        fun1 = case fun0 of+                          Lam b bE ->+                            let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet fun0)+                                subst = extendIdSubst (mkSubst is0) b arg1+                            in  substTm "mkPrimitive.fmapSimIO" subst bE+                          _ -> mkApps fun0 [Left arg1]+                    (expr,bindDecls) <- mkExpr False Sequential dst fun1+                    assn <- case expr of+                              Noop -> pure []+                              _ -> do declareUse (Proc Blocking) dstNm+                                      assn <- procAssign Blocking dstNm expr+                                      pure [assn]+                    return (Identifier dstNm Nothing, dstDecl ++ bindDecls ++ assn)+                  args1 -> error ("internal error: fmapSimIO# has insufficient arguments"+                                  <> showPpr args1)+                Nothing -> case lefts args of+                  (_:arg0:_) -> do+                    (_,bindDecls) <- mkExpr True Sequential dst arg0+                    return (Noop, bindDecls)+                  args1 -> error ("internal error: fmapSimIO# has insufficient arguments"+                                  <> showPpr args1)+++          | pNm == "Clash.Explicit.SimIO.unSimIO#" ->+              case lefts args of+                (arg:_) -> mkExpr False Sequential dst arg+                _ -> error "internal error: insufficient arguments"++          | pNm == "Clash.Explicit.SimIO.pureSimIO#" -> do+              (expr,decls) <- case lefts args of+                (arg:_) -> mkExpr False Sequential dst arg+                _ -> error "internal error: insufficient arguments"+              resM <- resBndr True dst+              case resM of+                Just (_,dstNms,dstDecl) -> case expr of+                  Noop ->+                    return (Noop,decls)+                  _ -> case dstNms of+                    [dstNm] -> do+                      declareUse (Proc Blocking) dstNm+                      assn <- procAssign Blocking dstNm expr+                      return ( Identifier dstNm Nothing+                             , dstDecl ++ decls ++ [assn])+                    _ -> error "internal error"+                _ ->+                  return (Noop,decls)++          | pNm == "GHC.Num.Integer.IS" -> do+              (expr,decls) <- case lefts args of+                (arg:_) -> mkExpr False declType dst arg+                _ -> error "internal error: insufficient arguments"+              iw <- Lens.view intWidth+              return (N.DataCon (Signed iw) (DC (Void Nothing,-1)) [expr],decls)++          | pNm == "GHC.Num.Integer.IP" -> do+              (expr,decls) <- case lefts args of+                (arg:_) -> mkExpr False declType dst arg+                _ -> error "internal error: insufficient arguments"+              case expr of+                N.Literal Nothing (NumLit _) -> return (expr,decls)+                _ -> error "non-constant ByteArray# not supported"++          | pNm == "GHC.Num.Integer.IN" -> do+              (expr,decls) <- case lefts args of+                (arg:_) -> mkExpr False declType dst arg+                _ -> error "internal error: insufficient arguments"+              case expr of+                N.Literal Nothing (NumLit i) ->+                  return (N.Literal Nothing (NumLit (negate i)),decls)+                _ -> error "non-constant ByteArray# not supported"++          | pNm == "GHC.Num.Natural.NS" -> do+              (expr,decls) <- case lefts args of+                (arg:_) -> mkExpr False declType dst arg+                _ -> error "internal error: insufficient arguments"+              iw <- Lens.view intWidth+              return (N.DataCon (Unsigned iw) (DC (Void Nothing,-1)) [expr],decls)++          | pNm == "GHC.Num.Integer.NB" -> do+              (expr,decls) <- case lefts args of+                (arg:_) -> mkExpr False declType dst arg+                _ -> error "internal error: insufficient arguments"+              case expr of+                N.Literal Nothing (NumLit _) -> return (expr,decls)+                _ -> error "non-constant ByteArray# not supported"++          | otherwise ->+              return (BlackBoxE "" [] [] []+                        (BBTemplate [Text $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]])+                        (emptyBBContext pNm) False,[])++    -- Do we need to create a new identifier to assign the result?+    --+    -- CoreId: No, this is an original LHS of a let-binder, and already has a+    --         corresponding NetDecl; unlike NetlistIds, it is not already+    --         assigned, it will be assigned by the BlackBox/Primitive.+    --+    -- NetlistId: This is a derived (either from an CoreId or other NetlistId)+    --            identifier created in the NetlistMonad that's already being+    --            used in an assignment, i.e. we cannot assign it again.+    --+    --            So if it is a declaration BlackBox (indicated by 'mkDec'),+    --            we will have to create a new NetlistId, create a NetDecl for+    --            it, and use this new NetlistId for the assignment inside the+    --            declaration BlackBox+    --+    -- MultiId: This is like a CoreId, but it's split over multiple identifiers+    --          because it was originally of a product type where the element+    --          types should not be part of an aggregate type in the generated+    --          HDL (e.g. Clocks should not be part of an aggregate, because+    --          tools like verilator don't like it)+    resBndr+      :: Bool+      -- Do we need to create and declare a new identifier in case we're given+      -- a NetlistId?+      -> NetlistId+      -- CoreId/NetlistId/MultiId+      -> NetlistMonad (Maybe ([Id],[Identifier],[Declaration]))+      -- Nothing when the binder would have type `Void`+    resBndr mkDec dst' = do+      resHwTy <- case tys of+        (ty1:_) -> unsafeCoreTypeToHWTypeM' $(curLoc) ty1+        _ -> error "internal error: insufficient types"+      if isVoid resHwTy then+        pure Nothing+      else+        case dst' of+          NetlistId dstL ty' -> case mkDec of+            False -> do+              -- TODO: check that it's okay to use `mkUnsafeSystemName`+              let nm' = mkUnsafeSystemName (Id.toText dstL) 0+                  id_ = mkLocalId ty' nm'+              return (Just ([id_],[dstL],[]))+            True -> do+              nm2 <- Id.suffix dstL "res"+              -- TODO: check that it's okay to use `mkUnsafeInternalName`+              let nm3 = mkUnsafeSystemName (Id.toText nm2) 0+                  id_ = mkLocalId ty nm3++              idDeclM <- mkNetDecl (id_, mkApps (Prim pInfo) args)+              case idDeclM of+                [] -> return Nothing+                [idDecl] -> return (Just ([id_],[nm2],[idDecl]))+                ids -> error [I.i|+                  Unexpected nested use of multi result primitive. Ids:++                    #{show ids}++                  Multi primitive should only appear on the RHS of a+                  let-binding. Please report this as a bug.+                |]++          CoreId dstR ->+            return (Just ([dstR], [Id.unsafeFromCoreId dstR], []))+          MultiId ids ->+            return (Just (ids, map Id.unsafeFromCoreId ids, []))++    -- Like resBndr, but fails on MultiId+    resBndr1+      :: HasCallStack+      => Bool+      -> NetlistId+      -> NetlistMonad (Maybe (Id,Identifier,[Declaration]))+    resBndr1 mkDec dst' = resBndr mkDec dst' >>= \case+      Nothing -> pure Nothing+      Just ([id_],[nm_],decls) -> pure (Just (id_,nm_,decls))+      _ -> error "internal error"++-- | Turn a 'mealyIO' expression into a two sequential processes, one "initial"+-- process for the starting state, and one clocked sequential process.+collectMealy+  :: HasCallStack+  => Identifier+  -- ^ Identifier to assign the final result to+  -> NetlistId+  -- ^ Id to assign the final result to+  -> TyConMap+  -> [Term]+  -- ^ The arguments to 'mealyIO'+  -> NetlistMonad [Declaration]+collectMealy dstNm dst tcm (kd:clk:mealyFun:mealyInit:mealyIn:_) = do+  let (lefts -> args0,res0) = collectBndrs mealyFun+      is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet res0 <>+                          Lens.foldMapOf freeIds unitVarSet mealyInit <>+                          Lens.foldMapOf freeIds unitVarSet mealyIn)+      -- Given that we're creating a sequential list of statements from the+      -- let-bindings, make sure that everything is inverse topologically sorted+      (bs,res) = case res0 of+        Letrec bsU e | let bsN = inverseTopSortLetBindings bsU -> case e of+          C.Var resN -> (bsN,resN)+          _ ->+            let u = case dst of+                      CoreId u0 -> u0+                      _ -> uniqAway is0+                            (mkLocalId (inferCoreTypeOf tcm e)+                                        (mkUnsafeSystemName "mealyres" 0))+            in  (bsN ++ [(u,e)], u)+        e ->+          let u = case dst of+                    CoreId u0 -> u0+                    _ -> uniqAway is0+                           (mkLocalId (inferCoreTypeOf tcm e)+                                      (mkUnsafeSystemName "mealyres" 0))+          in  ([(u,e)], u)+      args1 = args0+      -- Take into account that the state argument is split over multiple+      -- binders because it contained types that are not allowed to occur in+      -- a HDL aggregate type+      mealyInitLength = length (splitShouldSplit tcm [inferCoreTypeOf tcm mealyInit])+      (sArgs,iArgs) = splitAt mealyInitLength args1+  -- Give all binders a unique name+  let sBindings = map (,mealyInit) sArgs ++ map (,mealyIn) iArgs ++ bs+  normE <- mkUniqueNormalized is0 Nothing ([], sBindings, res)+  case normE of+    -- We're not expecting any input or output wrappers+    (_,[],[],_,[],binders0,Just result) -> do+      let (sBinders,binders1) = splitAt (length sArgs) binders0+          (iBinders,binders2) = splitAt (length iArgs) binders1+          -- Get all the "original" let-bindings, without the above "mealyres".+          -- We don't want to make a NetDecl for it.+          bindersN = case res0 of+            Letrec _ (C.Var {}) -> binders2+            _                   -> init binders2++      -- Create new net declarations for state-binders, input-binders, and all+      -- the "original" let-bindings in 'mealyFun'+      --+      -- The first set is only assigned in the always block, so they must be+      -- 'reg' in Verilog terminology+      netDeclsSeq <- concatMapM mkNetDecl (sBinders ++ bindersN)+      -- The second set is assigned using concurrent assignment, so don't need+      -- to be 'reg'+      netDeclsInp <- concatMapM mkNetDecl iBinders++      -- If the 'mealyFun' was not a let-expression with a variable reference+      -- as a body then we used the LHS of the entire 'mealyIO' expression as+      -- a new let-binding; otherwise 'mkUniqueNormalized' would not work.+      --+      -- However, 'mkUniqueNormalized' made a new unique name for that LHS,+      -- which is not what we want. We want to assign the last expression to the+      -- LHS of 'mealyIO'.+      let bindersE = case res0 of+                        Letrec _ (C.Var {}) -> binders2+                        _ -> case dst of+                          -- See above why we do this.+                          CoreId u0 -> init binders2 ++ [(u0,snd (last binders2))]+                          _ -> binders2+      seqDecls <- concat <$> mapM (uncurry (mkDeclarations' Sequential)) bindersE++      -- When the body the let-expression of 'mealyFun' was variable reference,+      -- or in case we had to create a new identifier because the original LHS+      -- was not available: then we need to assign+      (resExpr,resDecls) <- case res0 of+        Letrec _ (C.Var {}) -> mkExpr False Concurrent dst (C.Var result)+        _ -> case dst of+          CoreId {} -> pure (Noop,[])+          _ -> mkExpr False Sequential dst (C.Var result)++      resAssn <- case resExpr of+            Noop -> pure []+            _ -> do+              assign <- SeqDecl <$> procAssign Blocking dstNm resExpr+              pure [Seq [AlwaysComb [assign]]]++      -- Create the declarations for the "initial state" block+      let sDst = case sBinders of+                   [] -> error "internal error: insufficient sBinders"+                   [(b,_)] -> CoreId b+                   _       -> MultiId (map fst sBinders)++      (exprInit,initDecls) <- mkExpr False Sequential sDst mealyInit++      initAssign <- case exprInit of+        Identifier _ Nothing -> pure []+        Noop -> pure []+        _ -> case sBinders of+          ((b,_):_) -> do assn <- procAssign Blocking (Id.unsafeFromCoreId b) exprInit+                          pure [assn]+          _ -> error "internal error: insufficient sBinders"++      -- Create the declarations that corresponding to the input+      let iDst = case iBinders of+                   []      -> error "internal error: insufficient iBinders"+                   [(b,_)] -> CoreId b+                   _       -> MultiId (map fst iBinders)++      (exprArg,inpDeclsMisc) <- mkExpr False Concurrent iDst mealyIn++      argAssign <- case iBinders of+        ((i,_):_) -> do assn <- contAssign (Id.unsafeFromCoreId i) exprArg+                        pure [assn]+        _ -> error "internal error: insufficient iBinders"++      -- Split netdecl declarations and other declarations+      let (netDeclsSeqMisc,seqDeclsOther) = partition isNet (seqDecls ++ resDecls)+          (netDeclsInit,initDeclsOther)   = partition isNet initDecls+      -- All assignments happens within a sequential block, so the nets need to+      -- be of type 'reg' in Verilog nomenclature+      let netDeclsSeq1 = netDeclsSeq ++ netDeclsSeqMisc ++ netDeclsInit++      -- We run mealy block in the opposite clock edge of the the ambient system+      -- because we're basically clocked logic; so we need to have our outputs+      -- ready before the ambient system starts sampling them. The clockGen code+      -- ensures that the "opposite" edge always comes first.+      kdTy <- unsafeCoreTypeToHWTypeM $(curLoc) (inferCoreTypeOf tcm kd)+      let edge = case stripVoid (stripFiltered kdTy) of+                   KnownDomain _ _ Rising _ _ _  -> Falling+                   KnownDomain _ _ Falling _ _ _ -> Rising+                   _ -> error "internal error"+      (clkExpr,clkDecls) <-+        mkExpr False Concurrent (NetlistId (Id.unsafeMake "__MEALY_CLK__") (inferCoreTypeOf tcm clk)) clk++      -- collect the declarations related to the input+      let netDeclsInp1 = netDeclsInp ++ inpDeclsMisc++      -- Collate everything+      return (clkDecls ++ netDeclsSeq1 ++ netDeclsInp1 ++ argAssign +++                [ Seq [Initial (map SeqDecl (initDeclsOther ++ initAssign))]+                , Seq [AlwaysClocked edge clkExpr (map SeqDecl seqDeclsOther)]+                ] ++ resAssn)+    _ -> error "internal error"+ where+  isNet NetDecl' {} = True+  isNet _ = False++collectMealy _ _ _ _ = error "internal error"++-- | Collect the sequential declarations for 'bindIO'+collectBindIO :: NetlistId -> [Term] -> NetlistMonad (Expr,[Declaration])+collectBindIO dst (m:Lam x q@e:_) = do+  tcm <- Lens.view tcCache+  (ds0,subst) <- collectAction tcm+  let qS = substTm "collectBindIO1" subst q+  case splitNormalized tcm qS of+    Right (args,bs0,res) -> do+      let bs = inverseTopSortLetBindings bs0+      let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet qS)+      normE <- mkUniqueNormalized is0 Nothing (args,bs,res)+      case normE of+        (_,_,[],_,[],binders,Just result) -> do+          ds1 <- concatMapM (uncurry (mkDeclarations' Sequential)) binders+          netDecls <- concatMapM mkNetDecl binders+          return (Identifier (Id.unsafeFromCoreId result) Nothing, netDecls ++ ds0 ++ ds1)+        _ -> error "internal error"+    _ -> case substTm "collectBindIO2" subst e of+      Letrec {} -> error "internal error"+      (collectArgs -> (Prim p,args))+        | primName p == "Clash.Explicit.SimIO.bindSimIO#" -> do+            (expr,ds1) <- collectBindIO dst (lefts args)+            return (expr, ds0 ++ ds1)+      eS -> do+        (expr,ds1) <- mkExpr False Sequential dst eS+        return (expr, ds0 ++ ds1)+ where+  collectAction tcm = case splitNormalized tcm m of+    Right (args,bs0,res) -> do+      let bs = inverseTopSortLetBindings bs0+      let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet m)+      normE <- mkUniqueNormalized is0 Nothing (args,(x,m):bs,res)+      case normE of+        (_,_,[],_,[],binders@(b:_),Just result) -> do+          let binders1 = drop 1 binders ++ [(fst b, C.Var result)]+          ds1 <- concatMapM (uncurry (mkDeclarations' Sequential)) binders1+          netDecls <- concatMapM mkNetDecl binders+          return (netDecls ++ ds1,extendIdSubst (mkSubst eInScopeSet) x (Var (fst b)))+        _ -> error "internal error"+    _ -> do+      ([x'],s) <- mkUnique (mkSubst eInScopeSet) [x]+      netDecls <- concatMapM mkNetDecl [(x',m)]+      ds1 <- mkDeclarations' Sequential x' m+      return (netDecls ++ ds1,s)++  eInScopeSet = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet e)++collectBindIO _ es = error ("internal error:\n" ++ showPpr es)++-- | Collect the sequential declarations for 'appIO'+collectAppIO :: NetlistId -> [Term] -> [Term] -> NetlistMonad (Expr,[Declaration])+collectAppIO dst (fun1:arg1:_) rest = case collectArgs fun1 of+  (Prim (PrimInfo "Clash.Explicit.SimIO.fmapSimIO#" _ _ _ _),(lefts -> (fun0:arg0:_))) -> do+    tcm <- Lens.view tcCache+    let argN = map (Left . unSimIO tcm) (arg0:arg1:rest)+    mkExpr False Sequential dst (mkApps fun0 argN)+  (Prim (PrimInfo "Clash.Explicit.SimIO.apSimIO#" _ _ _ _),(lefts -> args)) -> do+    collectAppIO dst args (arg1:rest)+  _ -> error ("internal error:\n" ++ showPpr (fun1:arg1:rest))+++collectAppIO _ es _ = error ("internal error:\n" ++ showPpr es)++-- | Unwrap the new-type wrapper for things of type SimIO, this is needed to+-- allow applications of the `State# World` token to the underlying IO type.+--+-- XXX: this is most likely needed because Ghc2Core that threw away the cast+-- that this unwrapping; we should really start to support casts.+unSimIO+  :: TyConMap+  -> Term+  -> Term+unSimIO tcm arg =+  let argTy = inferCoreTypeOf tcm arg+  in  case tyView argTy of+        TyConApp _ [tcArg] ->+          mkApps (Prim (PrimInfo+                          "Clash.Explicit.SimIO.unSimIO#"+                          (mkFunTy argTy tcArg)+                          WorkNever+                          SingleResult+                          NoUnfolding))+                 [Left arg]+        _ -> error ("internal error:\n" ++ showPpr arg)++-- | Create an template instantiation text and a partial blackbox content for an+-- argument term, given that the term is a function. Errors if the term is not+-- a function+mkFunInput+  :: HasCallStack+  => TextS.Text+  -- ^ Name of the primitive of which the function in question is an argument.+  -- Used for error reporting.+  -> DeclarationType+  -- ^ Are we concurrent or sequential?+  -> Id+  -- ^ Identifier binding the encompassing primitive/blackbox application. Used+  -- as a name hint if 'mkFunInput' needs intermediate signals.+  -> Term+  -- ^ The function argument term+  -> NetlistMonad+      ((Either BlackBox (Identifier,[Declaration])+       ,Usage+       ,[BlackBoxTemplate]+       ,[BlackBoxTemplate]+       ,[((TextS.Text,TextS.Text),BlackBox)]+       ,BlackBoxContext)+      ,[Declaration])+mkFunInput parentName declType resId e =+ let (appE,args,ticks) = collectArgsTicks e+ in  withTicks ticks $ \tickDecls -> do+  tcm <- Lens.view tcCache+  -- TODO: Rewrite this function to use blackbox functions. Right now it+  -- TODO: generates strings that are later parsed/interpreted again. Silly!+  templ <- case appE of+            Prim p -> do+              bb  <- extractPrimWarnOrFail (primName p)+              case bb of+                P.BlackBox {..} ->+                  pure (Left (kind,outputUsage,libraries,imports,includes,primName p,template))+                P.Primitive pn _ pt ->+                  error $ $(curLoc) ++ "Unexpected blackbox type: "+                                    ++ "Primitive " ++ show pn+                                    ++ " " ++ show pt+                P.BlackBoxHaskell{name=pName, multiResult=True} ->+                  -- TODO: dev pointers+                  error [I.i|+                    Encountered multiresult primitive as a direct argument to+                    another primitive. This should not happen.++                      Encountered: #{pName}++                    Please report this as an issue.+                  |]+                P.BlackBoxHaskell{name=pName, functionName=fName, function=(_, func)} -> do+                  -- Determine result type of this blackbox. If it's not a+                  -- function, simply use its term type.+                  let (_, resTy) = splitFunTys tcm (inferCoreTypeOf tcm e)+                  bbhRes <- func True pName args [resTy]+                  case bbhRes of+                    Left err ->+                      error $ $(curLoc) ++ show fName ++ " yielded an error: "+                                        ++ err+                    Right (BlackBoxMeta{..}, template) ->+                      pure $+                        Left ( bbKind, bbOutputUsage, bbLibrary, bbImports+                             , bbIncludes, pName, template)+            Data dc -> do+              let eTy = inferCoreTypeOf tcm e+                  (_,resTy) = splitFunTys tcm eTy++              resHTyM0 <- coreTypeToHWTypeM resTy+              let resHTyM1 = (\fHwty -> (stripFiltered fHwty, flattenFiltered fHwty)) <$> resHTyM0++              case resHTyM1 of+                -- Special case where coreTypeToHWTypeM determined a type to+                -- be completely transparent.+                Just (_resHTy, [areVoids@(countEq False -> 1)]) -> do+                  let nonVoidArgI = fromJust (elemIndex False areVoids)+                  let arg = Id.unsafeMake (TextS.concat ["~ARG[", showt nonVoidArgI, "]"])+                  let assign = Assignment (Id.unsafeMake "~RESULT") assignTy (Identifier arg Nothing)+                  return (Right ((Id.unsafeMake "", tickDecls ++ [assign]), assignTy))++                -- Because we filter void constructs, the argument indices and+                -- the field indices don't necessarily correspond anymore. We+                -- use the result of coreTypeToHWTypeM to figure out what the+                -- original indices are. Please see the documentation in+                -- Clash.Netlist.Util.mkADT for more information.+                Just (resHTy@(SP _ _), areVoids0) -> do+                  let+                      dcI       = dcTag dc - 1+                      areVoids1 = indexNote ($(curLoc) ++ "No areVoids with index: " ++ show dcI) areVoids0 dcI+                      mkArg i   = Id.unsafeMake ("~ARG[" <> showt i <> "]")+                      dcInps    = [Identifier (mkArg x) Nothing | x <- originalIndices areVoids1]+                      dcApp     = DataCon resHTy (DC (resHTy,dcI)) dcInps+                      dcAss     = Assignment (Id.unsafeMake "~RESULT") assignTy dcApp+                  return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), assignTy))++                -- CustomSP the same as SP, but with a user-defined bit+                -- level representation+                Just (resHTy@(CustomSP {}), areVoids0) -> do+                  let+                      dcI       = dcTag dc - 1+                      areVoids1 = indexNote ($(curLoc) ++ "No areVoids with index: " ++ show dcI) areVoids0 dcI+                      mkArg i   = Id.unsafeMake ("~ARG[" <> showt i <> "]")+                      dcInps    = [Identifier (mkArg x) Nothing | x <- originalIndices areVoids1]+                      dcApp     = DataCon resHTy (DC (resHTy,dcI)) dcInps+                      dcAss     = Assignment (Id.unsafeMake "~RESULT") assignTy dcApp+                  return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), assignTy))++                -- Like SP, we have to retrieve the index BEFORE filtering voids+                Just (resHTy@(Product _ _ _), areVoids1:_) -> do+                  let mkArg i    = Id.unsafeMake ("~ARG[" <> showt i <> "]")+                      dcInps    = [ Identifier (mkArg x) Nothing | x <- originalIndices areVoids1]+                      dcApp     = DataCon resHTy (DC (resHTy,0)) dcInps+                      dcAss     = Assignment (Id.unsafeMake "~RESULT") assignTy dcApp+                  return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), assignTy))++                -- Vectors never have defined areVoids (or all set to False), as+                -- it would be converted to Void otherwise. We can therefore+                -- safely ignore it:+                Just (resHTy@(Vector _ _), _areVoids) -> do+                  let mkArg i = Id.unsafeMake ("~ARG[" <> showt i <> "]")+                      dcInps = [ Identifier (mkArg x) Nothing | x <- [(1::Int)..2] ]+                      dcApp  = DataCon resHTy (DC (resHTy,1)) dcInps+                      dcAss  = Assignment (Id.unsafeMake "~RESULT") assignTy dcApp+                  return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), assignTy))++                -- Sum types OR a Sum type after filtering empty types:+                Just (resHTy@(Sum _ _), _areVoids) -> do+                  let dcI   = dcTag dc - 1+                      dcApp = DataCon resHTy (DC (resHTy,dcI)) []+                      dcAss = Assignment (Id.unsafeMake "~RESULT") assignTy dcApp+                  return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), assignTy))++                -- Same as Sum, but with user defined bit level representation+                Just (resHTy@(CustomSum {}), _areVoids) -> do+                  let dcI   = dcTag dc - 1+                      dcApp = DataCon resHTy (DC (resHTy,dcI)) []+                      dcAss = Assignment (Id.unsafeMake "~RESULT") assignTy dcApp+                  return (Right ((Id.unsafeMake "",tickDecls ++ [dcAss]), assignTy))++                Just (Void {}, _areVoids) ->+                  return (error $ $(curLoc) ++ "Encountered Void in mkFunInput."+                                            ++ " This is a bug in Clash.")++                _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showPpr e+            C.Var fun -> do+              topAnns <- Lens.use topEntityAnns+              case lookupVarEnv fun topAnns of+                Just _ ->+                  error $ $(curLoc) ++ "Cannot make function input for partially applied Synthesize-annotated: " ++ showPpr e+                _ -> do+                  normalized <- Lens.use bindings+                  case lookupVarEnv fun normalized of+                    Just _ -> do+                      (meta,N.Component compName compInps compOutps _) <-+                        preserveVarEnv $ genComponent fun++                      let+                        ComponentMeta{cmWereVoids} = meta+                        inpAssign (i, t) e' = (Identifier i Nothing, In, t, e')+                        inpVar i = Id.unsafeMake ("~VAR[arg" <> showt i <> "][" <> showt i <> "]")+                        inpVars = [Identifier (inpVar i)  Nothing | i <- originalIndices cmWereVoids]+                        inpAssigns = zipWith inpAssign compInps inpVars+                        outpAssigns = case compOutps of+                          [] -> [] -- See issue #2549+                          [(_,compOutp,_)] ->+                            [ ( Identifier (fst compOutp) Nothing+                              , Out+                              , snd compOutp+                              , Identifier (Id.unsafeMake "~RESULT") Nothing )+                            ]+                          outps ->+                            error [I.i|+                              Cannot handle multi-result function as an argument to+                              a primitive.++                              Primitive: #{parentName}++                              Argument: #{showPpr fun} :: #{showPpr (varType fun)}++                              Outputs: #{show (map (\(_,x,_) -> x) outps)}++                              Please report this as an issue.+                            |]+                      instLabel <- Id.next compName+                      let+                        portMap = NamedPortMap (outpAssigns ++ inpAssigns)+                        instDecl = InstDecl Entity Nothing [] compName instLabel [] portMap+                      return (Right ((Id.unsafeMake "",tickDecls ++ [instDecl]), Cont))+                    Nothing -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showPpr e+            C.Lam {} -> do+              let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet appE)+              either Left (Right . first (second (tickDecls ++))) <$> go is0 0 appE+            _ -> error $ $(curLoc) ++ "Cannot make function input for: " ++ showPpr e+  let pNm = case appE of+              Prim p -> primName p+              _ -> "__INTERNAL__"+  (bbCtx,dcls) <- mkBlackBoxContext pNm declType [resId] args+  case templ of+    Left (TDecl,outputUsage,libs,imps,inc,_,templ') -> do+      (l',templDecl)+        <- onBlackBox+            (fmap (first BBTemplate) . setSym bbCtx)+            (\bbName bbHash bbFunc -> pure $ (BBFunction bbName bbHash bbFunc, []))+            templ'+      return ((Left l',outputUsage,libs,imps,inc,bbCtx),dcls ++ templDecl)+    Left (TExpr,_,libs,imps,inc,nm,templ') -> do+      onBlackBox+        (\t -> do t' <- getAp (prettyBlackBox t)+                  let t'' = Id.unsafeMake (Text.toStrict t')+                      assn = Assignment (Id.unsafeMake "~RESULT") assignTy (Identifier t'' Nothing)+                  return ((Right (Id.unsafeMake "",[assn]),assignTy,libs,imps,inc,bbCtx),dcls))+        (\bbName bbHash (TemplateFunction k g _) -> do+          let f' bbCtx' = do+                let assn = Assignment (Id.unsafeMake "~RESULT") assignTy+                            (BlackBoxE nm libs imps inc templ' bbCtx' False)+                p <- getAp (Backend.blockDecl (Id.unsafeMake "") [assn])+                return p+          return ((Left (BBFunction bbName bbHash (TemplateFunction k g f'))+                  ,assignTy+                  ,[]+                  ,[]+                  ,[]+                  ,bbCtx+                  )+                 ,dcls+                 )+        )+        templ'+    Right (decl,u) ->+      return ((Right decl,u,[],[],[],bbCtx),dcls)+  where+    assignTy = declTypeUsage declType++    goExpr app@(collectArgsTicks -> (C.Var fun,args@(_:_),ticks)) = do+      tcm <- Lens.view tcCache+      resTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (inferCoreTypeOf tcm app)+      let (tmArgs,tyArgs) = partitionEithers args+      if null tyArgs+        then+          withTicks ticks $ \tickDecls -> do+            resNm <- Id.make "result"+            appDecls <- mkFunApp declType resNm fun tmArgs tickDecls+            let assn = [ Assignment (Id.unsafeMake "~RESULT") assignTy (Identifier resNm Nothing)+                       , NetDecl Nothing resNm resTy ]+            nm <- Id.makeBasic "block"+            return (Right ((nm,assn++appDecls), assignTy))+        else do+          (_,sp) <- Lens.use curCompNm+          throw (ClashException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showPpr app) Nothing)+    goExpr e' = do+      tcm <- Lens.view tcCache+      let eType = inferCoreTypeOf tcm e'+      (appExpr,appDecls) <- mkExpr False declType (NetlistId (Id.unsafeMake "c$bb_res") eType) e'+      let assn = Assignment (Id.unsafeMake "~RESULT") assignTy appExpr+      nm <- if null appDecls+               then return (Id.unsafeMake "")+               else Id.makeBasic "block"+      return (Right ((nm,appDecls ++ [assn]), assignTy))++    go is0 n (Lam id_ e') = do+      lvl <- Lens.use curBBlvl+      let nm    = TextS.concat+                    ["~ARGN[",TextS.pack (show lvl),"][",TextS.pack (show n),"]"]+          v'    = uniqAway is0 (modifyVarName (\v -> v {nameOcc = nm}) id_)+          subst = extendIdSubst (mkSubst is0) id_ (C.Var v')+          e''   = substTm "mkFunInput.goLam" subst e'+          is1   = extendInScopeSet is0 v'+      go is1 (n+(1::Int)) e''++    go _ _ (C.Var v) = do+      let assn = Assignment (Id.unsafeMake "~RESULT") assignTy (Identifier (Id.unsafeFromCoreId v) Nothing)+      return (Right ((Id.unsafeMake "",[assn]), assignTy))++    go _ _ (Case scrut ty [alt]) = do+      tcm <- Lens.view tcCache+      let sTy = inferCoreTypeOf tcm scrut+      (projection,decls) <- mkProjection declType False (NetlistId (Id.unsafeMake "c$bb_res") sTy) scrut ty alt+      let assn = Assignment (Id.unsafeMake "~RESULT") assignTy projection+      nm <- if null decls+               then return (Id.unsafeMake "")+               else Id.makeBasic "projection"+      return (Right ((nm,decls ++ [assn]), assignTy))++    go _ _ (Case scrut ty (alt:alts@(_:_))) = do+      resNm <- Id.make "result"+      resTy <- unsafeCoreTypeToHWTypeM' $(curLoc) ty+      -- It's safe to use 'mkUnsafeSystemName' here: only the name, not the+      -- unique, will be used+      let resId'  = NetlistId resNm ty+      selectionDecls <- mkSelection declType resId' scrut ty (alt :| alts) []+      let assn = [ NetDecl' Nothing resNm resTy Nothing+                 , Assignment (Id.unsafeMake "~RESULT") assignTy (Identifier resNm Nothing) ]+      nm <- Id.makeBasic "selection"+      return (Right ((nm,assn++selectionDecls), assignTy))++    go is0 _ e'@(Let{}) = do+      tcm <- Lens.view tcCache+      let normE = splitNormalized tcm e'+      (_,[],[],_,[],binders,resultM) <- case normE of+        Right norm -> mkUniqueNormalized is0 Nothing norm+        Left err -> error err+      case resultM of+        Just result -> do+          -- TODO: figure out what to do with multires blackboxes here+          netDecls <- concatMapM mkNetDecl $ binders+          decls    <- concatMapM (uncurry mkDeclarations) binders+          nm <- Id.makeBasic "fun"+          let resultId = Id.unsafeFromCoreId result+          -- TODO: Due to reasons lost in the mists of time, #1265 creates an+          -- assignement here, whereas it previously wouldn't. With the PR in+          -- tests break when reverting to the old behavior. In some cases this+          -- creates "useless" assignments. We should investigate whether we can+          -- get the old behavior back.+          let resDecl = Assignment (Id.unsafeMake "~RESULT") assignTy (Identifier resultId Nothing)+          return (Right ((nm,resDecl:netDecls ++ decls), assignTy))+        Nothing -> return (Right ((Id.unsafeMake "",[]), Cont))++    go is0 n (Tick _ e') = go is0 n e'++    go _ _ e'@(App {}) = goExpr e'+    go _ _ e'@(C.Data {}) = goExpr e'+    go _ _ e'@(C.Literal {}) = goExpr e'+    go _ _ e'@(Cast {}) = goExpr e'+    go _ _ e'@(Prim {}) = goExpr e'+    go _ _ e'@(TyApp {}) = goExpr e'++    go _ _ e'@(Case _ _ []) =+      error $ $(curLoc) ++ "Cannot make function input for case without alternatives: " ++ show e'++    go _ _ e'@(TyLam {}) =+      error $ $(curLoc) ++ "Cannot make function input for TyLam: " ++ show e'
+ src/Clash/Netlist/BlackBox.hs-boot view
@@ -0,0 +1,32 @@+{-|+  Copyright   :  (C) 2019, Google Inc+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>+-}++module Clash.Netlist.BlackBox where++import Data.Text (Text)+import GHC.Stack (HasCallStack)+import Clash.Core.Term (Term)+import Clash.Core.Type (Type)+import Clash.Core.Var (Id)+import Clash.Netlist.Types (BlackBoxContext, Declaration, DeclarationType, NetlistMonad)+import Clash.Primitives.Types (CompiledPrimitive)++extractPrimWarnOrFail+  :: HasCallStack+  => Text+  -> NetlistMonad CompiledPrimitive++mkBlackBoxContext+  :: HasCallStack+  => Text+  -- ^ Blackbox function name+  -> DeclarationType+  -- ^ Are we concurrent or sequential?+  -> [Id]+  -- ^ Identifiers binding the primitive/blackbox application+  -> [Either Term Type]+  -- ^ Arguments of the primitive/blackbox application+  -> NetlistMonad (BlackBoxContext,[Declaration])
+ src/Clash/Netlist/BlackBox/Parser.hs view
@@ -0,0 +1,159 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2017     , Myrtle Software Ltd,+                    2021-2022, QBayLogic B.V.+                    2022     , Google Inc.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Parser definitions for BlackBox templates+-}++{-# LANGUAGE OverloadedStrings #-}++module Clash.Netlist.BlackBox.Parser+  (runParse)+where++import           Control.Applicative          ((<|>))+import           Data.Text.Lazy               (Text, pack, unpack)+import qualified Data.Text.Lazy               as Text+import           Text.Trifecta                hiding (Err)+import           Text.Trifecta.Delta++import qualified Clash.Signal.Internal        as Signal+import           Clash.Netlist.BlackBox.Types++-- | Parse a text as a BlackBoxTemplate, returns a list of errors in case+-- parsing fails+runParse :: Text -> Result BlackBoxTemplate+runParse = parseString (pBlackBoxD <* eof) (Directed "" 0 0 0 0) . unpack++-- | Parse a BlackBoxTemplate (Declarations and Expressions)+pBlackBoxD :: Parser BlackBoxTemplate+pBlackBoxD = some pElement++-- | Parse a single Template Element+pElement :: Parser Element+pElement  =  pTagD+         <|> Text <$> pText+         <|> Text <$> (pack <$> string "~ ")++-- | Parse the Text part of a Template+pText :: Parser Text+pText = pack <$> some (satisfyRange '\000' '\125')++pEdge :: Parser Signal.ActiveEdge+pEdge =+  (pure Signal.Rising <* symbol "Rising") <|>+  (pure Signal.Falling <* symbol "Falling")+++-- | Parse a Declaration or Expression element+pTagD :: Parser Element+pTagD =  IF <$> (symbol "~IF" *> pTagE)+            <*> (spaces *> (string "~THEN" *> pBlackBoxD))+            <*> (string "~ELSE" *> option ([Text ""]) pBlackBoxD <* string "~FI")+     <|> Component <$> pDecl+     <|> pTagE++-- | Parse a Declaration+pDecl :: Parser Decl+pDecl = Decl <$> (symbol "~INST" *> natural') <*> pure 0 <*>+        ((:) <$> pOutput <*> many pInput) <* string "~INST"++-- | Parse the output tag of Declaration+pOutput :: Parser (BlackBoxTemplate,BlackBoxTemplate)+pOutput = symbol "~OUTPUT" *> symbol "<=" *> ((,) <$> (pBlackBoxE <* symbol "~") <*> pBlackBoxE) <* symbol "~"++-- | Parse the input tag of Declaration+pInput :: Parser (BlackBoxTemplate,BlackBoxTemplate)+pInput = symbol "~INPUT" *> symbol "<=" *> ((,) <$> (pBlackBoxE <* symbol "~") <*> pBlackBoxE) <* symbol "~"++-- | Parse an Expression element+pTagE :: Parser Element+pTagE =  Result            <$  string "~RESULT"+     <|> ArgGen            <$> (string "~ARGN" *> brackets' natural') <*> brackets' natural'+     <|> Arg               <$> (string "~ARG" *> brackets' natural')+     <|> Const             <$> (string "~CONST" *> brackets' natural')+     <|> Lit               <$> (string "~LIT" *> brackets' natural')+     <|> Name              <$> (string "~NAME" *> brackets' natural')+     <|> ToVar             <$> try (string "~VAR" *> brackets' pSigDorEmpty) <*> brackets' natural'+     <|> (Sym Text.empty)  <$> (string "~SYM" *> brackets' natural')+     <|> Typ Nothing       <$  string "~TYPO"+     <|> (Typ . Just)      <$> try (string "~TYP" *> brackets' natural')+     <|> TypM Nothing      <$  string "~TYPMO"+     <|> (TypM . Just)     <$> (string "~TYPM" *> brackets' natural')+     <|> Err Nothing       <$  string "~ERRORO"+     <|> (Err . Just)      <$> (string "~ERROR" *> brackets' natural')+     <|> TypElem           <$> (string "~TYPEL" *> brackets' pTagE)+     <|> IndexType         <$> (string "~INDEXTYPE" *> brackets' pTagE)+     <|> CompName          <$  string "~COMPNAME"+     <|> IncludeName       <$> (string "~INCLUDENAME" *> brackets' natural')+     <|> Size              <$> (string "~SIZE" *> brackets' pTagE)+     <|> Length            <$> (string "~LENGTH" *> brackets' pTagE)+     <|> Depth             <$> (string "~DEPTH" *> brackets' pTagE)+     <|> MaxIndex          <$> (string "~MAXINDEX" *> brackets' pTagE)+     <|> FilePath          <$> (string "~FILE" *> brackets' pTagE)+     <|> Gen               <$> (True <$ string "~GENERATE")+     <|> Gen               <$> (False <$ string "~ENDGENERATE")+     <|> (`SigD` Nothing)  <$> (string "~SIGDO" *> brackets' pSigD)+     <|> SigD              <$> (string "~SIGD" *> brackets' pSigD) <*> (Just <$> (brackets' natural'))+     <|> IW64              <$  string "~IW64"+     <|> CmpLE             <$> try (string "~CMPLE" *> brackets' pTagE) <*> brackets' pTagE+     <|> (HdlSyn Vivado)   <$  string "~VIVADO"+     <|> (HdlSyn Other)    <$  string "~OTHERSYN"+     <|> (BV True)         <$> (string "~TOBV" *> brackets' pSigD) <*> brackets' pTagE+     <|> (BV False)        <$> (string "~FROMBV" *> brackets' pSigD) <*> brackets' pTagE+     <|> Sel               <$> (string "~SEL" *> brackets' pTagE) <*> brackets' natural'+     <|> IsLit             <$> (string "~ISLIT" *> brackets' natural')+     <|> IsVar             <$> (string "~ISVAR" *> brackets' natural')+     <|> IsScalar          <$> (string "~ISSCALAR" *> brackets' natural')+     <|> IsActiveHigh      <$> (string "~ISACTIVEHIGH" *> brackets' natural')+     <|> IsActiveEnable    <$> (string "~ISACTIVEENABLE" *> brackets' natural')+     <|> IsUndefined       <$> (string "~ISUNDEFINED" *> brackets' natural')+     <|> StrCmp            <$> (string "~STRCMP" *> brackets' pSigD) <*> brackets' natural'+     -- Parse ~OUTPUTWIREREG for backwards compatibility+     <|> OutputUsage       <$> (string "~OUTPUTWIREREG" *> brackets' natural')+     <|> OutputUsage       <$> (string "~OUTPUTUSAGE" *> brackets' natural')+     <|> GenSym            <$> (string "~GENSYM" *> brackets' pSigD) <*> brackets' natural'+     <|> Template          <$> (string "~TEMPLATE" *> brackets' pSigD) <*> brackets' pSigD+     <|> Repeat            <$> (string "~REPEAT" *> brackets' pSigD) <*> brackets' pSigD+     <|> DevNull           <$> (string "~DEVNULL" *> brackets' pSigD)+     <|> And               <$> (string "~AND" *> brackets' (commaSep pTagE))+     <|> Vars              <$> (string "~VARS" *> brackets' natural')++     -- Domain attributes:+     <|> Tag               <$> (string "~TAG" *> brackets' natural')+     <|> Period            <$> (string "~PERIOD" *> brackets' natural')+     <|> ActiveEdge        <$> (string "~ACTIVEEDGE" *> brackets pEdge) <*> brackets' natural'+     <|> IsSync            <$> (string "~ISSYNC" *> brackets' natural')+     <|> IsInitDefined     <$> (string "~ISINITDEFINED" *> brackets' natural')+     <|> CtxName           <$  string "~CTXNAME"+     <|> LongestPeriod     <$  string "~LONGESTPERIOD"++natural' :: TokenParsing m => m Int+natural' = fmap fromInteger natural++-- | Parse a bracketed text+brackets' :: Parser a -> Parser a+brackets' p = char '[' *> p <* char ']'++-- | Parse the expression part of Blackbox Templates+pBlackBoxE :: Parser BlackBoxTemplate+pBlackBoxE = some pElemE++-- | Parse an Expression or Text+pElemE :: Parser Element+pElemE = pTagE+      <|> Text <$> pText++-- | Parse SigD+pSigD :: Parser [Element]+pSigD = some (pTagE <|> (EscapedSymbol SquareBracketOpen <$ string "[\\")+                    <|> (EscapedSymbol SquareBracketClose <$ string "\\]")+                    <|> (Text <$> (pack <$> some (satisfyRange '\000' '\90')))+                    <|> (Text <$> (pack <$> some (satisfyRange '\94' '\125'))))++pSigDorEmpty :: Parser [Element]+pSigDorEmpty = pSigD <|> mempty
+ src/Clash/Netlist/BlackBox/Types.hs view
@@ -0,0 +1,248 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2017     , Myrtle Software Ltd,+                    2021-2022, QBayLogic B.V.+                    2022     , LUMI GUIDE FIETSDETECTIE B.V.+                    2022     , Google Inc.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Types used in BlackBox modules+-}++{-# LANGUAGE DeriveAnyClass #-}++module Clash.Netlist.BlackBox.Types+ ( BlackBoxMeta(..)+ , emptyBlackBoxMeta+ , BlackBoxFunction+ , BlackBoxTemplate+ , TemplateKind (..)+ , Element(..)+ , EscapedSymbol(..)+ , Decl(..)+ , HdlSyn(..)+ , RenderVoid(..)+ ) where++import                Control.DeepSeq            (NFData)+import                Data.Aeson                 (FromJSON)+import                Data.Binary                (Binary)+import                Data.Hashable              (Hashable)+import                Data.Text.Lazy             (Text)+import qualified      Data.Text                  as S+import                GHC.Generics               (Generic)++import                Clash.Core.Term            (Term)+import                Clash.Core.Type            (Type)+import {-# SOURCE #-} Clash.Netlist.Types+  (BlackBox, NetlistMonad, Usage(Cont))++import qualified      Clash.Signal.Internal      as Signal++-- | Whether this primitive should be rendered when its result type is void.+-- Defaults to 'NoRenderVoid'.+data RenderVoid+  = RenderVoid+  -- ^ Render blackbox, even if result type is void+  | NoRenderVoid+  -- ^ Don't render blackbox result type is void. Default for all blackboxes.+  deriving (Show, Generic, NFData, Binary, Eq, Hashable, FromJSON)++data TemplateKind+  = TDecl+  | TExpr+  deriving (Show, Eq, Generic, NFData, Binary, Hashable)++-- | See 'Clash.Primitives.Types.BlackBox' for documentation on this record's+-- fields. (They are intentionally renamed to prevent name clashes.)+data BlackBoxMeta =+  BlackBoxMeta { bbOutputUsage :: Usage+               , bbKind :: TemplateKind+               , bbLibrary :: [BlackBoxTemplate]+               , bbImports :: [BlackBoxTemplate]+               , bbFunctionPlurality :: [(Int, Int)]+               , bbIncludes :: [((S.Text, S.Text), BlackBox)]+               , bbRenderVoid :: RenderVoid+               , bbResultNames :: [BlackBox]+               , bbResultInits :: [BlackBox]+               }++-- | Use this value in your blackbox template function if you do want to+-- accept the defaults as documented in 'Clash.Primitives.Types.BlackBox'.+emptyBlackBoxMeta :: BlackBoxMeta+emptyBlackBoxMeta = BlackBoxMeta Cont TExpr [] [] [] [] NoRenderVoid [] []++-- | A BlackBox function generates a blackbox template, given the inputs and+-- result type of the function it should provide a blackbox for. This is useful+-- when having a need for blackbox functions, ... TODO: docs+type BlackBoxFunction+   = Bool+  -- ^ Indicates whether caller needs a declaration. If set, the function is+  -- still free to return an expression, but the caller will convert it to a+  -- declaration.+  -> S.Text+  -- ^ Name of primitive+  -> [Either Term Type]+  -- ^ Arguments+  -> [Type]+  -- ^ Result types+  -> NetlistMonad (Either String (BlackBoxMeta, BlackBox))++-- | A BlackBox Template is a List of Elements+-- TODO: Add name of function for better error messages+type BlackBoxTemplate = [Element]++-- | Elements of a blackbox context. If you extend this list, make sure to+-- update the following functions:+--+--  - Clash.Netlist.BlackBox.Types.prettyElem+--  - Clash.Netlist.BlackBox.Types.renderElem+--  - Clash.Netlist.BlackBox.Types.renderTag+--  - Clash.Netlist.BlackBox.Types.setSym+--  - Clash.Netlist.BlackBox.Util.inputHole+--  - Clash.Netlist.BlackBox.Types.getUsedArguments+--  - Clash.Netlist.BlackBox.Types.usedVariables+--  - Clash.Netlist.BlackBox.Types.verifyBlackBoxContext+--  - Clash.Netlist.BlackBox.Types.walkElement+data Element+  = Text !Text+  -- ^ Dumps given text without processing in HDL+  | Component !Decl+  -- ^ Component instantiation hole+  | Result+  -- ^ Output hole;+  | Arg !Int+  -- ^ Input hole+  | ArgGen !Int !Int+  -- ^ Like Arg, but its first argument is the scoping level. For use in+  -- in generated code only.+  | Const !Int+  -- ^ Like Arg, but input hole must be a constant.+  | Lit !Int+  -- ^ Like Arg, but input hole must be a literal+  | Name !Int+  -- ^ Name hole+  | ToVar [Element] !Int+  -- ^ Like Arg but only insert variable reference (creating an assignment+  -- elsewhere if necessary).+  | Sym !Text !Int+  -- ^ Symbol hole+  | Typ !(Maybe Int)+  -- ^ Type declaration hole+  | TypM !(Maybe Int)+  -- ^ Type root hole+  | Err !(Maybe Int)+  -- ^ Error value hole+  | TypElem !Element+  -- ^ Select element type from a vector-like type+  | CompName+  -- ^ Hole for the name of the component in which the blackbox is instantiated+  | IncludeName !Int+  | IndexType !Element+  -- ^ Index data type hole, the field is the (exclusive) maximum index+  | Size !Element+  -- ^ Size of a type hole+  | Length !Element+  -- ^ Length of a vector-like hole+  | Depth !Element+  -- ^ Depth of a tree hole+  | MaxIndex !Element+  -- ^ Max index into a vector-like type+  | FilePath !Element+  -- ^ Hole containing a filepath for a data file+  | Template [Element] [Element]+  -- ^ Create data file <HOLE0> with contents <HOLE1>+  | Gen !Bool+  -- ^ Hole marking beginning (True) or end (False) of a generative construct+  | IF !Element [Element] [Element]+  | And [Element]+  | IW64+  -- ^ Hole indicating whether Int/Word/Integer are 64-Bit+  | CmpLE !Element !Element+  -- ^ Compare less-or-equal+  | HdlSyn HdlSyn+  -- ^ Hole indicating which synthesis tool we're generating HDL for+  | BV !Bool [Element] !Element+  -- ^ Convert to (True)/from(False) a bit-vector+  | Sel !Element !Int+  -- ^ Record selector of a type+  | IsLit !Int+  | IsVar !Int+  | IsScalar !Int+  -- ^ Whether element is scalar+  | IsActiveHigh !Int+  -- ^ Whether a domain's reset lines are active high. Errors if not applied to+  -- a @KnownDomain@ or @KnownConfiguration@.+  | Tag !Int+  -- ^ Tag of a domain.+  | Period !Int+  -- ^ Period of a domain. Errors if not applied to a @KnownDomain@ or+  -- @KnownConfiguration@.+  | LongestPeriod+  -- ^ Longest period of all known domains. The minimum duration returned is+  -- 100 ns, see https://github.com/clash-lang/clash-compiler/issues/2455.+  | ActiveEdge !Signal.ActiveEdge !Int+  -- ^ Test active edge of memory elements in a certain domain. Errors if not+  -- applied to a @KnownDomain@ or @KnownConfiguration@.+  | IsSync !Int+  -- ^ Whether a domain's reset lines are synchronous. Errors if not applied to+  -- a @KnownDomain@ or @KnownConfiguration@.+  | IsInitDefined !Int+  -- ^ Whether the initial (or "power up") value of memory elements in a domain+  -- are configurable to a specific value rather than unknown\/undefined. Errors+  -- if not applied to a @KnownDomain@ or @KnownConfiguration@.+  | IsActiveEnable !Int+  -- ^ Whether given enable line is active. More specifically, whether the+  -- enable line is NOT set to a constant 'True'.+  | IsUndefined !Int+  -- ^ Whether argument is undefined. E.g., an XException, error call,+  -- removed argument, or primitive that is undefined. This template tag will+  -- always return 0 (False) if `-fclash-aggressive-x-optimization-blackboxes`+  -- is NOT set.+  | StrCmp [Element] !Int+  | OutputUsage !Int+  | Vars !Int+  | GenSym [Element] !Int+  | Repeat [Element] [Element]+  -- ^ Repeat <hole> n times+  | DevNull [Element]+  -- ^ Evaluate <hole> but swallow output+  | SigD [Element] !(Maybe Int)+  | CtxName+  -- ^ The "context name", name set by `Clash.Magic.setName`, defaults to the+  -- name of the closest binder+  | EscapedSymbol EscapedSymbol+  -- ^ Used for "[\" and "\]", they'll be rendered as "[" and "]",+  -- but pretty printed as "[\" and "\]".+  deriving (Show, Generic, NFData, Binary, Eq, Hashable)++data EscapedSymbol = SquareBracketOpen | SquareBracketClose+  deriving (Show, Generic, NFData, Binary, Eq, Hashable)++-- | Component instantiation hole. First argument indicates which function argument+-- to instantiate. Third argument corresponds to output and input assignments,+-- where the first element is the output assignment, and the subsequent elements+-- are the consecutive input assignments.+--+-- The LHS of the tuple is the name of the signal, while the RHS of the tuple+-- is the type of the signal+data Decl+  = Decl+      !Int+      -- ^ Argument position of the function to instantiate+      !Int+      -- ^ Subposition of function: blackboxes can request multiple instances+      -- to be rendered of their given functions. This subposition indicates the+      -- nth function instance to be rendered (zero-indexed).+      --+      -- This is a hack: the proper solution would postpone rendering the+      -- function until the very last moment. The blackbox language has no way+      -- to indicate the subposition, and every ~INST will default its subposition+      -- to zero. Haskell blackboxes can use this data type.+      [(BlackBoxTemplate,BlackBoxTemplate)]+      -- ^ (name of signal, type of signal)+  deriving (Show, Generic, NFData, Binary, Eq, Hashable)++data HdlSyn = Vivado | Quartus | Other+  deriving (Eq, Show, Read, Generic, NFData, Binary, Hashable)
+ src/Clash/Netlist/BlackBox/Util.hs view
@@ -0,0 +1,1412 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2021-2026, QBayLogic B.V.+                    2022     , LUMI GUIDE FIETSDETECTIE B.V.+                    2022     , Google Inc.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Utilties to verify blackbox contexts against templates and rendering filled+  in templates+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Netlist.BlackBox.Util+    ( renderTemplate+    , lookupFunctionInstantiation+    , walkElement+    , verifyBlackBoxContext+    , onBlackBox+    , setSym+    , extractLiterals+    , renderBlackBox+    , getUsedArguments+    , canonicalizeDataFilePath+    , addFilePath+    , exprToString+    , renderElem+    , getDomainConf+    , prettyBlackBox+    ) where++import           Control.Exception               (throw)+import           Control.Lens+  (use, (%=), _1, _2, element, (^?))+import           Control.Monad                   (forM, (<=<), filterM)+import           Control.Monad.Extra             (ifM)+import           Control.Monad.State             (State, StateT (..), lift, gets)+import           Data.Bitraversable              (bitraverse)+import           Data.Bool                       (bool)+import           Data.Coerce                     (coerce)+import           Data.Containers.ListUtils       (nubOrd)+import           Data.Foldable                   (foldrM)+import           Data.Hashable                   (Hashable (..))+import qualified Data.HashMap.Strict             as HashMap+import qualified Data.IntMap                     as IntMap+import           Data.List                       (nub)+import           Data.List.Extra                 (indexMaybe)+import qualified Data.Map                        as Map+import           Data.Map                        (Map)+import           Data.Maybe                      (mapMaybe, maybeToList, fromJust)+import           Data.Monoid                     (Ap(getAp))+import qualified Data.Set                        as Set+import           Data.Set                        (Set)+import qualified Data.Text+import           Data.Text.Lazy                  (Text)+import qualified Data.Text.Lazy                  as Text+import           System.Directory                (doesFileExist, canonicalizePath)+import           System.IO.Unsafe                (unsafePerformIO)++#if MIN_VERSION_prettyprinter(1,7,0)+import qualified Prettyprinter                   as PP+#else+import qualified Data.Text.Prettyprint.Doc       as PP+#endif++import           Data.Text.Prettyprint.Doc.Extra+import           GHC.Stack                       (HasCallStack)+import           System.FilePath                 (replaceBaseName, takeBaseName,+                                                  takeFileName, (<.>), isAbsolute, (</>))+import           Text.Printf+import           Text.Read                       (readEither)+import           Text.Trifecta.Result            hiding (Err)++import           Clash.Backend+  (Backend (..), DomainMap, Usage (..), AggressiveXOptBB(..), RenderEnums(..))+import           Clash.Netlist.BlackBox.Parser+import           Clash.Netlist.BlackBox.Types+import           Clash.Netlist.Types+  (BlackBoxContext (..), Expr (..), HWType (..), Literal (..), Modifier (..),+   Declaration(BlackBoxD))+import qualified Clash.Netlist.Id                as Id+import qualified Clash.Netlist.Types             as N+import           Clash.Netlist.Util              (typeSize, isVoid, stripAttributes, stripVoid)+import           Clash.Signal.Internal+  (ResetKind(..), ResetPolarity(..), InitBehavior(..), VDomainConfiguration (..))+import           Clash.Util+import qualified Clash.Util.Interpolate          as I++import           Clash.Annotations.Primitive     (HDL(VHDL))++inputHole :: Element -> Maybe Int+inputHole = \case+  Text _           -> Nothing+  Component _      -> Nothing+  Result           -> Nothing+  Arg n            -> pure n+  ArgGen _ n       -> pure n+  Const n          -> pure n+  Lit n            -> pure n+  Name n           -> pure n+  ToVar _ n        -> pure n+  Sym _ _          -> Nothing+  Typ nM           -> nM+  TypM nM          -> nM+  Err nM           -> nM+  TypElem _        -> Nothing+  CompName         -> Nothing+  IncludeName _    -> Nothing+  IndexType _      -> Nothing+  Size _           -> Nothing+  Length _         -> Nothing+  Depth _          -> Nothing+  MaxIndex _       -> Nothing+  FilePath _       -> Nothing+  Template _ _     -> Nothing+  Gen _            -> Nothing+  IF _ _ _         -> Nothing+  And _            -> Nothing+  IW64             -> Nothing+  CmpLE _ _        -> Nothing+  HdlSyn _         -> Nothing+  BV _ _ _         -> Nothing+  Sel _ _          -> Nothing+  IsLit n          -> pure n+  IsVar n          -> pure n+  IsScalar n       -> pure n+  IsActiveHigh n   -> pure n+  Tag n            -> pure n+  Period n         -> pure n+  LongestPeriod    -> Nothing+  ActiveEdge _ n   -> pure n+  IsSync n         -> pure n+  IsInitDefined n  -> pure n+  IsActiveEnable n -> pure n+  IsUndefined n    -> pure n+  StrCmp _ n       -> pure n+  OutputUsage n    -> pure n+  Vars n           -> pure n+  GenSym _ _       -> Nothing+  Repeat _ _       -> Nothing+  DevNull _        -> Nothing+  SigD _ nM        -> nM+  CtxName          -> Nothing+  EscapedSymbol _  -> Nothing++lookupFunctionInstantiation+  :: BlackBoxContext+  -> Int+  -> Int+  -> Either+      String+      ( Either N.BlackBox (Id.Identifier, [Declaration])+      , N.Usage+      , [BlackBoxTemplate]+      , [BlackBoxTemplate]+      , [((Data.Text.Text, Data.Text.Text), N.BlackBox)]+      , BlackBoxContext+      )+lookupFunctionInstantiation bbCtx n subn =+  case IntMap.lookup n (bbFunctions bbCtx) of+    Nothing ->+      Left+        ( "Blackbox requested instantiation of function at argument "+            ++ show n+            ++ ", but BlackBoxContext did not contain one."+        )+    Just funcs ->+      case indexMaybe funcs subn of+        Nothing ->+          Left+            ( "Blackbox requested at least "+                ++ show (subn + 1)+                ++ " renders of function at argument "+                ++ show n+                ++ " but found only "+                ++ show (length funcs)+            )+        Just func ->+          Right func++-- | Determine if the number of normal\/literal\/function inputs of a blackbox+-- context at least matches the number of argument that is expected by the+-- template.+verifyBlackBoxContext+  :: BlackBoxContext+  -- ^ Blackbox to verify+  -> N.BlackBox+  -- ^ Template to check against+  -> Maybe String+verifyBlackBoxContext bbCtx (N.BBFunction _ _ (N.TemplateFunction _ f _)) =+  if f bbCtx then+    Nothing+  else+    -- TODO: Make TemplateFunction return a string+    Just ("Template function for returned False")+verifyBlackBoxContext bbCtx (N.BBTemplate t) =+  orElses (concatMap (walkElement verify') t)+  where+    concatTups = concatMap (\(x, y) -> [x, y])++    verify' e =+      Just $+      case e of+        Lit n ->+          case indexMaybe (bbInputs bbCtx) n of+            Just (inp, isVoid -> False, False) ->+              Just ( "Argument " ++ show n ++ " should be literal, as blackbox "+                  ++ "used ~LIT[" ++ show n ++ "], but was:\n\n" ++ show inp)+            _ -> Nothing+        Const n ->+          case indexMaybe (bbInputs bbCtx) n of+            Just (inp, isVoid -> False, False) ->+              Just ( "Argument " ++ show n ++ " should be literal, as blackbox "+                  ++ "used ~CONST[" ++ show n ++ "], but was:\n\n" ++ show inp)+            _ -> Nothing+        Component (Decl n subn l') ->+          case lookupFunctionInstantiation bbCtx n subn of+            Left lookupErr ->+              Just lookupErr+            Right _ ->+              orElses $+                map+                  (verifyBlackBoxContext bbCtx . N.BBTemplate)+                  (concatTups l')+        _ ->+          case inputHole e of+            Nothing ->+              Nothing+            Just n ->+              case indexMaybe (bbInputs bbCtx) n of+                Just _ -> Nothing+                Nothing -> do+                  let str = fromJust (fmap Text.unpack (getAp $ prettyElem e))+                  Just ( "Blackbox used \"" ++ str ++ "\""+                      ++ ", but only " ++ show (length (bbInputs bbCtx))+                      ++ " arguments were passed." )++extractLiterals :: BlackBoxContext+                -> [Expr]+extractLiterals = map (\case (e,_,_) -> e)+                . filter (\case (_,_,b) -> b)+                . bbInputs++-- | Update all the symbol references in a template, and increment the symbol+-- counter for every newly encountered symbol.+setSym+  :: forall m+   . Id.IdentifierSetMonad m+  => BlackBoxContext+  -> BlackBoxTemplate+  -> m (BlackBoxTemplate,[N.Declaration])+setSym bbCtx l = do+    (a,(_,decls)) <- runStateT (mapM setSym' l) (IntMap.empty,IntMap.empty)+    return (a,concatMap snd (IntMap.elems decls))+  where+    bbnm = Data.Text.unpack (bbName bbCtx)++    setSym'+      :: Element+      -> StateT ( IntMap.IntMap N.IdentifierText+                , IntMap.IntMap (N.IdentifierText, [N.Declaration]))+                m+                Element+    setSym' e = case e of+      ToVar nm i | i < length (bbInputs bbCtx) -> case bbInputs bbCtx !! i of+        (Identifier nm0 Nothing,_,_) ->+          return (ToVar [Text (Id.toLazyText nm0)] i)++        (e',hwTy,_) -> do+          varM <- IntMap.lookup i <$> use _2+          case varM of+            Nothing -> do+              nm' <- lift (Id.make (Text.toStrict (concatT (Text "c$":nm))))+              let decls = case typeSize hwTy of+                    0 -> []+                    _ -> [N.NetDecl Nothing nm' hwTy+                         ,N.Assignment nm' N.Cont e' -- TODO De-hardcode Cont+                         ]+              _2 %= (IntMap.insert i (Id.toText nm',decls))+              return (ToVar [Text (Id.toLazyText nm')] i)+            Just (nm',_) ->+              return (ToVar [Text (Text.fromStrict nm')] i)+      Sym _ i -> do+        symM <- IntMap.lookup i <$> use _1+        case symM of+          Nothing -> do+            t <- Id.toText <$> lift (Id.make "c$n")+            _1 %= (IntMap.insert i t)+            return (Sym (Text.fromStrict t) i)+          Just t -> return (Sym (Text.fromStrict t) i)+      GenSym t i -> do+        symM <- IntMap.lookup i <$> use _1+        case symM of+          Nothing -> do+            t' <- Id.toText <$> lift (Id.makeBasic (Text.toStrict (concatT t)))+            _1 %= (IntMap.insert i t')+            return (GenSym [Text (Text.fromStrict t')] i)+          Just _ ->+            error ("Symbol #" ++ show (t,i)+                ++ " is already defined in BlackBox for: "+                ++ bbnm)+      Component (Decl n subN l') ->+        Component <$> (Decl n subN <$> mapM (bitraverse (mapM setSym') (mapM setSym')) l')+      IF c t f      -> IF <$> pure c <*> mapM setSym' t <*> mapM setSym' f+      SigD e' m     -> SigD <$> (mapM setSym' e') <*> pure m+      BV t e' m     -> BV <$> pure t <*> mapM setSym' e' <*> pure m+      _             -> pure e++    concatT :: [Element] -> Text+    concatT = Text.concat . map (+      \case+        Text t -> t+        Name i ->+          case elementToText bbCtx (Name i) of+            Right t -> t+            Left msg ->+              error $ $(curLoc) ++  "Could not convert ~NAME[" ++ show i ++ "]"+                   ++ " to string:" ++ msg ++ "\n\nError occured while "+                   ++ "processing blackbox for " ++ bbnm+        Lit i ->+          case elementToText bbCtx (Lit i) of+            Right t -> t+            Left msg ->+              error $ $(curLoc) ++  "Could not convert ~LIT[" ++ show i ++ "]"+                   ++ " to string:" ++ msg ++ "\n\nError occured while "+                   ++ "processing blackbox for " ++ bbnm+        Result | [(Identifier t _, _)] <- bbResults bbCtx -> Id.toLazyText t+        CompName -> Id.toLazyText (bbCompName bbCtx)+        CtxName ->+          case bbCtxName bbCtx of+            Just nm -> Text.fromStrict nm+            _ | [(Identifier t _, _)] <- bbResults bbCtx -> Id.toLazyText t+            _ -> error $ $(curLoc) ++ "Internal error when processing blackbox "+                      ++ "for " ++ bbnm+        _ -> error $ $(curLoc) ++ "Unexpected element in GENSYM when processing "+                  ++ "blackbox for " ++ bbnm+        )++type FileName = FilePath++-- | Canonicalizes a datafile path, keeping in mind that the path might be+-- relative to one of the import directories passed in with @-i@.+canonicalizeDataFilePath ::+  -- | Import directories passed in with @-i@+  [FilePath] ->+  -- | File to canonicalize+  FilePath ->+  FilePath+canonicalizeDataFilePath idirs toCanonicalize+  | isAbsolute toCanonicalize = unsafePerformIO $+    ifM+      (doesFileExist toCanonicalize)+      (canonicalizePath toCanonicalize)+      (error [I.i|Could not find data file #{show toCanonicalize}. Does it exist?|])+  | otherwise = unsafePerformIO $ do+      let candidates = map (</> toCanonicalize) (nubOrd idirs)+      found <- filterM doesFileExist candidates+      case found of+        [] -> error [I.i|+          Could not find data file #{show toCanonicalize}. The following directories were+          searched:+            #{idirs}+        |]+        (_:_:_) -> error [I.i|+          Multiple data files for #{show toCanonicalize} found. The following candidates+          were found:+            #{found}+          Please disambiguate data files.+        |]+        [c] ->+          canonicalizePath c+{-# NOINLINE canonicalizeDataFilePath #-} -- To contain unsafePerformIO++-- | Select a new file name that doesn't collide with existing names. Might return+-- the same name as given if there are no collisions.+selectNewName ::+  -- | Set of existing names+  Set FileName ->+  -- | Name for file+  FileName ->+  -- | Updated file name+  FileName+selectNewName as a+  | a `Set.member` as = selectNewName as (replaceBaseName a (takeBaseName a ++ "_"))+  | otherwise = a++-- | Add a data file to a collection of existing files. Typically used in the HDL+-- backend's 'addAndSetData'.+addFilePath ::+  -- | Import directories passed in with @-i@+  [FilePath] ->+  -- | Map of existing file paths to file names. The file names are guaranteed+  -- to be unique, as long as this function is used to add new file paths.+  Map FilePath FileName ->+  -- | New file path to add. The canonicalized version of this file path is stored+  -- in the map. See 'canonicalizeFilePath'.+  FilePath ->+  -- | Updated map and filename. Note that the returned filename might be different+  -- from the filename in the given filepath in case of naming collisions.+  (Map FilePath FileName, FileName)+addFilePath iDirs existing path =+  case Map.lookup canonicalizedPath existing of+    Just existingName ->+      -- This path was already added, return existing map and name+      (existing, existingName)+    Nothing ->+      -- Select a new name that doesn't collide with existing names+      ( Map.insert canonicalizedPath newFileName existing+      , newFileName+      )+ where+  canonicalizedPath = canonicalizeDataFilePath iDirs path++  allNames = Set.fromList (Map.elems existing)+  fileName = takeFileName canonicalizedPath+  newFileName = selectNewName allNames fileName++-- | Render a blackbox given a certain context. Returns a filled out template+-- and a list of 'hidden' inputs that must be added to the encompassing component.+renderTemplate+  :: Backend backend+  => BlackBoxContext -- ^ Context used to fill in the hole+  -> BlackBoxTemplate -- ^ Blackbox template+  -> State backend (Int -> Text)+renderTemplate bbCtx l = do+  l' <- mapM (renderElem bbCtx) l+  return (\col -> Text.concat (map ($ col) l'))++renderBlackBox+  :: Backend backend+  => [BlackBoxTemplate]+  -> [BlackBoxTemplate]+  -> [((Data.Text.Text,Data.Text.Text), N.BlackBox)]+  -> N.BlackBox+  -> BlackBoxContext+  -> State backend (Int -> Doc)+renderBlackBox libs imps includes bb bbCtx = do+  let nms' = zipWith (\_ i -> "~INCLUDENAME[" <> Text.pack (show i) <> "]")+                     includes+                     [(0 :: Int)..]+      layout = LayoutOptions (AvailablePerLine 120 0.4)+  nms <-+    forM includes $ \((nm,_),inc) -> do+      case verifyBlackBoxContext bbCtx inc of+        Nothing -> return ()+        Just err0 -> do+          sp <- getSrcSpan+          let err1 = concat [ "Couldn't instantiate blackbox for "+                            , Data.Text.unpack (bbName bbCtx), ". Verification "+                            , "procedure reported:\n\n" ++ err0 ]+          throw (ClashException sp ($(curLoc) ++ err1) Nothing)+      let bbCtx' = bbCtx {bbQsysIncName = map Text.toStrict nms'}+      incForHash <- onBlackBox (renderTemplate bbCtx')+                               (\_name _hash (N.TemplateFunction _ _ f) -> do+                                  t <- f bbCtx'+                                  let t' = renderLazy (layoutPretty layout t)+                                  return (const t'))+                               inc+      iw <- iwWidth+      topNm <- getTopName+      let incHash = hash (incForHash 0)+          nm'     = Text.concat+                      [ Text.fromStrict (Id.toText topNm)+                      , "_"+                      , Text.fromStrict nm+                      , "_"+                      , Text.pack (printf ("%0" ++ show (iw `div` 4) ++ "X") incHash)+                      ]+      pure nm'++  let bbNamedCtx = bbCtx {bbQsysIncName = map Text.toStrict nms}+      incs = snd <$> includes+  bb' <- case bb of+        N.BBTemplate bt   -> do+          t <- renderTemplate bbNamedCtx bt+          return (\col -> let t1 = t (col + 2)+                          in  if Text.null t1+                              then PP.emptyDoc+                              else PP.nest (col-2) (PP.pretty t1))+        N.BBFunction _ _ (N.TemplateFunction _ _ bf)  -> do+          t <- bf bbNamedCtx+          return (\_ -> t)++  incs' <- mapM (onBlackBox (fmap (PP.pretty . ($ 0)) . renderTemplate bbNamedCtx)+                            (\_name _hash (N.TemplateFunction _ _ f) -> f bbNamedCtx))+                incs+  libs' <- mapM (fmap ($ 0) . renderTemplate bbNamedCtx) libs+  imps' <- mapM (fmap ($ 0) . renderTemplate bbNamedCtx) imps+  addIncludes $ zipWith3 (\nm' ((_, ext), _) inc -> (Text.unpack nm' <.> Data.Text.unpack ext, inc)) nms includes incs'+  addLibraries libs'+  addImports imps'+  return bb'++-- | Render a single template element+renderElem+  :: HasCallStack+  => Backend backend+  => BlackBoxContext+  -> Element+  -> State backend (Int -> Text)+renderElem b (Component (Decl n subN (l:ls))) = do+  (o,oTy,_) <- idToExpr <$> bitraverse (lineToIdentifier b) (return . lineToType b) l+  is <- mapM (fmap idToExpr . bitraverse (lineToIdentifier b) (return . lineToType b)) ls+  sp <- getSrcSpan+  case lookupFunctionInstantiation b n subN of+    Right (templ0,_,libs,imps,inc,pCtx) -> do+      let b' = pCtx { bbResults = [(o,oTy)], bbInputs = bbInputs pCtx ++ is }+          layoutOptions = LayoutOptions (AvailablePerLine 120 0.4)+          render = N.BBTemplate . parseFail b' . renderLazy . layoutPretty layoutOptions++      templ1 <-+        case templ0 of+          Left t ->+            return t+          Right (nm0,ds) -> do+            nm1 <- Id.next nm0+            block <- getAp (blockDecl nm1 ds)+            return (render block)++      templ4 <-+        case templ1 of+          N.BBFunction {} ->+            return templ1+          N.BBTemplate templ2 -> do+            (templ3, templDecls) <- setSym b' templ2+            case templDecls of+              [] ->+                return (N.BBTemplate templ3)+              _ -> do+                nm1 <- Id.toText <$> Id.makeBasic "bb"+                nm2 <- Id.makeBasic "bb"+                let bbD = BlackBoxD nm1 libs imps inc (N.BBTemplate templ3) b'+                block <- getAp (blockDecl nm2 (templDecls ++ [bbD]))+                return (render block)++      case verifyBlackBoxContext b' templ4 of+        Nothing -> do+          bb <- renderBlackBox libs imps inc templ4 b'+          return (renderLazy . layoutPretty layoutOptions . bb)+        Just err0 -> do+          let err1 = concat [ "Couldn't instantiate blackbox for "+                            , Data.Text.unpack (bbName b), ". Verification procedure "+                            , "reported:\n\n" ++ err0 ]+          throw (ClashException sp ($(curLoc) ++ err1) Nothing)+    Left err0 ->+      throw (ClashException sp ($(curLoc) ++ "renderElem: " ++ err0) Nothing)++renderElem b (SigD e m) = do+  e' <- Text.concat <$> mapM (fmap ($ 0) . renderElem b) e+  let ty = case m of+             Nothing -> snd $ bbResult "~SIGD" b+             Just n  -> let (_,ty',_) = bbInputs b !! n+                        in  ty'+  t  <- getAp (hdlSig e' ty)+  return (const (renderOneLine t))++renderElem b (Period n) = do+  let (_, ty, _) = bbInputs b !! n+  case stripVoid ty of+    KnownDomain _ period _ _ _ _ ->+      return $ const $ Text.pack $ show period+    _ ->+      error $ $(curLoc) ++ "Period: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty++renderElem _ LongestPeriod = do+  doms <- domainConfigurations+  -- Longest period with a minimum of 100 ns, see:+  -- https://github.com/clash-lang/clash-compiler/issues/2455+  let longestPeriod = maximum (100_000 : [vPeriod v | v <- HashMap.elems doms])+  return (const (Text.pack (show longestPeriod)))++renderElem b (Tag n) = do+  let (_, ty, _) = bbInputs b !! n+  case stripVoid ty of+    KnownDomain dom _ _ _ _ _ ->+      return (const (Text.pack (Data.Text.unpack dom)))+    Clock dom ->+      return (const (Text.pack (Data.Text.unpack dom)))+    ClockN dom ->+      return (const (Text.pack (Data.Text.unpack dom)))+    Reset dom ->+      return (const (Text.pack (Data.Text.unpack dom)))+    Enable dom ->+      return (const (Text.pack (Data.Text.unpack dom)))+    _ ->+      error $ $(curLoc) ++ "Tag: Expected `KnownDomain` or `KnownConfiguration`, not: " ++ show ty+++renderElem b (IF c t f) = do+  iw <- iwWidth+  hdl <- gets hdlKind+  syn <- hdlSyn+  enums <- renderEnums+  xOpt <- aggressiveXOptBB+  c' <- check (coerce xOpt) iw hdl syn enums c+  if c' > 0 then renderTemplate b t else renderTemplate b f+  where+    check :: Backend backend => Bool -> Int -> HDL -> HdlSyn -> RenderEnums -> Element -> State backend Int+    check xOpt iw hdl syn enums c' = case c' of+      (Size e)   -> pure $ typeSize (lineToType b [e])+      (Length e) -> pure $ case lineToType b [e] of+                       (Vector n _)              -> n+                       Void (Just (Vector n _))  -> n+                       (MemBlob n _)             -> n+                       Void (Just (MemBlob n _)) -> n+                       _                         -> 0 -- HACK: So we can test in splitAt if one of the+                              -- vectors in the tuple had a zero length+      (Lit n) -> pure $ case bbInputs b !! n of+        (l,_,_)+          | Literal _ l' <- l ->+            case l' of+              -- Integer, Int#, KnownNat, Natural, Word#+              NumLit i -> fromInteger i+              -- Bit+              BitLit bl -> case bl of+                N.H -> 1+                N.L -> 0+                _   -> error $ $(curLoc) ++ "IF: LIT bit literal must be high or low"+              -- Bool+              BoolLit bl -> bool 0 1 bl+              _ -> error $ $(curLoc) ++ "IF: LIT must be a numeric lit"+          -- Int+          | DataCon (Signed _) _ [Literal _ (NumLit i)] <- l+            -> fromInteger i+          -- Word, SNat+          | DataCon (Unsigned _) _ [Literal _ (NumLit i)] <- l+            -> fromInteger i+          | BlackBoxE pNm _lib _use _incl _templ bbCtx _paren <- l+          , pNm `elem` ["GHC.Int.I8#", "GHC.Int.I16#", "GHC.Int.I32#", "GHC.Int.I64#"+                       ,"GHC.Word.W8#","GHC.Word.W16#","GHC.Word.W32#","GHC.Word.W64#"+                       ,"GHC.Types.I#","GHC.Types.W#"+                       ]+          , [Literal _ (NumLit j)] <- extractLiterals bbCtx+          -> fromInteger j+        k -> error $ $(curLoc) ++ ("IF: LIT must be a numeric lit:" ++ show k)+      (Depth e)  -> pure $ case lineToType b [e] of+                      (RTree n _) -> n+                      _ -> error $ $(curLoc) ++ "IF: treedepth of non-tree type"+      IW64       -> pure $ if iw == 64 then 1 else 0+      (HdlSyn s) -> pure $ if s == syn then 1 else 0+      (IsVar n)  -> pure $ let (e,_,_) = bbInputs b !! n+                    in case e of+                      Identifier _ Nothing -> 1+                      _                    -> 0+      (IsLit n)  -> pure $ let (e,_,_) = bbInputs b !! n+                    in case e of+                      DataCon {}   -> 1+                      Literal {}   -> 1+                      BlackBoxE {} -> 1+                      _            -> 0+      (IsScalar n) -> let (_,ty,_) = bbInputs b !! n+                          isScalar _ Bit          = 1+                          isScalar _ Bool         = 1+                          isScalar VHDL Integer   = 1+                          isScalar VHDL (Sum _ _) = case enums of+                                                       RenderEnums True  -> 1+                                                       RenderEnums False -> 0+                          isScalar _ _            = 0+                        in pure $ isScalar hdl ty++      (IsUndefined n) -> pure $+        let (e, _, _) = bbInputs b !! n+        in if xOpt && checkUndefined e then 1 else 0++      (IsActiveEnable n) -> pure $+        let (e, ty, _) = bbInputs b !! n in+        case ty of+          Enable _ ->+            case e of+              DataCon _ _ [Literal Nothing (BoolLit True)]  -> 0+              -- TODO: Emit warning? If enable signal is inferred as always+              -- TODO: False, the component will never be enabled. This is+              -- TODO: probably not the user's intention.+              DataCon _ _ [Literal Nothing (BoolLit False)] -> 1+              _                                             -> 1+          Bool ->+            case e of+              Literal Nothing (BoolLit True)  -> 0+              -- TODO: Emit warning? If enable signal is inferred as always+              -- TODO: False, the component will never be enabled. This is+              -- TODO: probably not the user's intention.+              Literal Nothing (BoolLit False) -> 1+              _                               -> 1+          _ ->+            error $ $(curLoc) ++ "IsActiveEnable: Expected Bool or Enable, not: " ++ show ty++      (ActiveEdge edgeRequested n) -> do+        let (_, ty, _) = bbInputs b !! n+        domConf <- getDomainConf ty+        case domConf of+          VDomainConfiguration _ _ edgeActual _ _ _ -> pure $+            if edgeRequested == edgeActual then 1 else 0++      (IsSync n) -> do+        let (_, ty, _) = bbInputs b !! n+        domConf <- getDomainConf ty+        case domConf of+          VDomainConfiguration _ _ _ Synchronous _ _ -> pure 1+          VDomainConfiguration _ _ _ Asynchronous _ _ -> pure 0++      (IsInitDefined n) -> do+        let (_, ty, _) = bbInputs b !! n+        domConf <- getDomainConf ty+        case domConf of+          VDomainConfiguration _ _ _ _ Defined _ -> pure 1+          VDomainConfiguration _ _ _ _ Unknown _ -> pure 0++      (IsActiveHigh n) -> do+        let (_, ty, _) = bbInputs b !! n+        domConf <- getDomainConf ty+        case domConf of+          VDomainConfiguration _ _ _ _ _ ActiveHigh -> pure 1+          VDomainConfiguration _ _ _ _ _ ActiveLow  -> pure 0++      (StrCmp [Text t1] n) -> pure $+        let (e,_,_) = bbInputs b !! n+        in  case exprToString e of+              Just t2+                | t1 == Text.pack t2 -> 1+                | otherwise -> 0+              Nothing -> error $ $(curLoc) ++ "Expected a string literal: " ++ show e+      (And es)   -> do+        es' <- mapM (check xOpt iw hdl syn enums) es+        pure $ if all (/=0) es'+                       then 1+                       else 0+      CmpLE e1 e2 -> do+        v1 <- check xOpt iw hdl syn enums e1+        v2 <- check xOpt iw hdl syn enums e2+        if v1 <= v2+          then pure 1+          else pure 0+      _ -> error $ $(curLoc) ++ "IF: condition must be: SIZE, LENGTH, LIT, DEPTH, IW64, VIVADO, OTHERSYN, ISVAR, ISLIT, ISUNDEFINED, ISACTIVEENABLE, ACTIVEEDGE, ISSYNC, ISINITDEFINED, ISACTIVEHIGH, STRCMP, AND, ISSCALAR or CMPLE."+                             ++ "\nGot: " ++ show c'+renderElem b e = fmap const (renderTag b e)++getDomainConf :: (Backend backend, HasCallStack) => HWType -> State backend VDomainConfiguration+getDomainConf = generalGetDomainConf domainConfigurations++generalGetDomainConf+  :: forall m. (Monad m, HasCallStack)+  => (m DomainMap) -- ^ a way to get the `DomainMap`+  -> HWType -> m VDomainConfiguration+generalGetDomainConf getDomainMap ty = case (snd . stripAttributes . stripVoid) ty of+  KnownDomain dom period activeEdge resetKind initBehavior resetPolarity ->+    pure $ VDomainConfiguration (Data.Text.unpack dom) (fromIntegral period) activeEdge resetKind initBehavior resetPolarity++  Clock dom -> go dom+  ClockN dom -> go dom+  Reset dom  -> go dom+  Enable dom -> go dom+  Product _DiffClock _ [Clock dom,_clkN] -> go dom+  t -> error $ "Don't know how to get a Domain out of HWType: " <> show t+ where+  go :: HasCallStack => N.DomainName -> m VDomainConfiguration+  go dom = do+    doms <- getDomainMap+    case HashMap.lookup dom doms of+      Nothing -> error $ "Can't find domain " <> show dom <> ". Please report an issue at https://github.com/clash-lang/clash-compiler/issues."+      Just conf -> pure conf++parseFail :: BlackBoxContext -> Text -> BlackBoxTemplate+parseFail b t = case runParse t of+  Failure errInfo ->+    error $ unlines+        [ "error while parsing blackbox: " <> Data.Text.unpack (bbName b)+        , "in component " <> Data.Text.unpack (Id.toText $ bbCompName b)+        , "error:"+        , show (_errDoc errInfo)+        ]+  Success templ -> templ++idToExpr+  :: (Text, HWType)+  -> (Expr, HWType, Bool)+idToExpr (t, ty) =+  (Identifier (Id.unsafeMake (Text.toStrict t)) Nothing, ty, False)++bbResult :: HasCallStack => String -> BlackBoxContext -> (Expr, HWType)+bbResult _s (bbResults -> [r]) = r+bbResult s ctx = error [I.i|+  Multi result primitives not supported when using template tag #{s}. Tag used+  in blackbox implementation of #{bbName ctx} |]++-- | Fill out the template corresponding to an output/input assignment of a+-- component instantiation, and turn it into a single identifier so it can+-- be used for a new blackbox context.+lineToIdentifier :: Backend backend+                 => BlackBoxContext+                 -> BlackBoxTemplate+                 -> State backend Text+lineToIdentifier b = foldrM (\e a -> do+                              e' <- renderTag b e+                              return (e' `Text.append` a)+                   ) Text.empty++lineToType :: BlackBoxContext+           -> BlackBoxTemplate+           -> HWType+lineToType b [(Typ Nothing)]  = snd $ bbResult "~TYPO" b+lineToType b [(Typ (Just n))] = let (_,ty,_) = bbInputs b !! n+                                in  ty+lineToType b [(TypElem t)]    = case lineToType b [t] of+                                  Vector _ elTy -> elTy+                                  MemBlob _ m -> BitVector m+                                  _ -> error $ $(curLoc) ++ "Element type selection of a non-vector-like type"+lineToType b [(IndexType (Lit n))] =+  case bbInputs b !! n of+    (Literal _ (NumLit n'),_,_) -> Index (fromInteger n')+    x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x++lineToType _ _ = error $ $(curLoc) ++ "Unexpected type manipulation"++-- | Give a context and a tagged hole (of a template), returns part of the+-- context that matches the tag of the hole.+renderTag :: Backend backend+          => BlackBoxContext+          -> Element+          -> State backend Text+renderTag _ (Text t)        = return t+renderTag b (Result)    = do+  fmap renderOneLine . getAp . expr False . fst $ bbResult "~RESULT" b+renderTag b (Arg n)  = do+  let (e,_,_) = bbInputs b !! n+  renderOneLine <$> getAp (expr True e)++renderTag b (Const n)  = do+  let (e,_,_) = bbInputs b !! n+  renderOneLine <$> getAp (expr False e)++renderTag b t@(ArgGen k n)+  | k == bbLevel b+  , let (e,_,_) = bbInputs b !! n+  = renderOneLine <$> getAp (expr False e)+  | otherwise+  = getAp (prettyElem t)++renderTag b (Lit n) =+  renderOneLine <$> getAp (expr False (mkLit e))+ where+  (e,_,_) = bbInputs b !! n++  mkLit (Literal (Just (Signed _,_)) i)                                 = Literal Nothing i  -- Integer, Int#+  mkLit (Literal (Just (Unsigned _,_)) i)                               = Literal Nothing i  -- KnownNat, Natural, Word#++  mkLit (DataCon _ (DC (Void {}, _)) [Literal (Just (Signed _,_)) i])   = Literal Nothing i  -- Int+  mkLit (DataCon _ (DC (Void {}, _)) [Literal (Just (Unsigned _,_)) i]) = Literal Nothing i  -- SNat, Word++  mkLit (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm `elem` ["GHC.Int.I8#", "GHC.Int.I16#", "GHC.Int.I32#", "GHC.Int.I64#"+                                                     ,"GHC.Word.W8#","GHC.Word.W16#","GHC.Word.W32#","GHC.Word.W64#"+                                                     ,"GHC.Types.I#","GHC.Types.W#"+                                                     ]+                                        , [Literal _ i] <- extractLiterals bbCtx+                                        = Literal Nothing i+  mkLit (BlackBoxE pNm _ _ _ _ bbCtx _) | pNm `elem` ["Clash.Sized.Internal.Signed.fromInteger#"+                                                     ,"Clash.Sized.Internal.Unsigned.fromInteger#"+                                                     ,"Clash.Sized.Internal.Index.fromInteger#"]+                                        , [Literal {}, Literal _ i] <- extractLiterals bbCtx+                                         = Literal Nothing i+  mkLit i                                                               = i++renderTag b e@(Name _i) =+  case elementToText b e of+      Right s  -> return s+      Left msg -> error $ $(curLoc) ++ unwords [ "Error when reducing to string"+                                               , "in ~NAME construct:", msg ]++renderTag _ (ToVar [Text t] _) = return t+renderTag _ (Sym t _) = return t++renderTag b (BV True es e) = do+  e' <- Text.concat <$> mapM (fmap ($ 0) . renderElem b) es+  let ty = lineToType b [e]+  renderOneLine <$> getAp (toBV ty e')+renderTag b (BV False es e) = do+  e' <- Text.concat <$> (mapM (fmap ($ 0) . renderElem b) es)+  let ty = lineToType b [e]+  renderOneLine <$> getAp (fromBV ty e')++renderTag b (Sel e n) =+  let ty = lineToType b [e]+  in  renderOneLine <$> getAp (hdlRecSel ty n)++renderTag b (Typ Nothing)   = fmap renderOneLine . getAp . hdlType Internal . snd $ bbResult "~TYPO" b+renderTag b (Typ (Just n))  = let (_,ty,_) = bbInputs b !! n+                              in  renderOneLine <$> getAp (hdlType Internal ty)+renderTag b (TypM Nothing)  = fmap renderOneLine . getAp . hdlTypeMark . snd $ bbResult "~TYPMO" b+renderTag b (TypM (Just n)) = let (_,ty,_) = bbInputs b !! n+                              in  renderOneLine <$> getAp (hdlTypeMark ty)+renderTag b (Err Nothing)   = fmap renderOneLine . getAp . hdlTypeErrValue . snd $ bbResult "~ERRORO" b+renderTag b (Err (Just n))  = let (_,ty,_) = bbInputs b !! n+                              in  renderOneLine <$> getAp (hdlTypeErrValue ty)+renderTag b (Size e)        = return . Text.pack . show . typeSize $ lineToType b [e]++renderTag b (Length e) = return . Text.pack . show . vecLen $ lineToType b [e]+  where+    vecLen (Vector n _)                = n+    vecLen (Void (Just (Vector n _)))  = n+    vecLen (MemBlob n _)               = n+    vecLen (Void (Just (MemBlob n _))) = n+    vecLen thing =+      error $ $(curLoc) ++ "vecLen of a non-vector-like type: " ++ show thing++renderTag b (Depth e) = return . Text.pack . show . treeDepth $ lineToType b [e]+  where+    treeDepth (RTree n _)               = n+    treeDepth (Void (Just (RTree n _))) = n+    treeDepth thing =+      error $ $(curLoc) ++ "treeDepth of a non-tree type: " ++ show thing++renderTag b (MaxIndex e) = return . Text.pack . show . vecLen $ lineToType b [e]+  where+    vecLen (Vector n _)  = n-1+    vecLen (Void (Just (Vector n _)))  = n-1+    vecLen (MemBlob n _) = n-1+    vecLen (Void (Just (MemBlob n _))) = n-1+    vecLen thing =+      error $ $(curLoc) ++ "vecLen of a non-vector-like type: " ++ show thing++renderTag b e@(TypElem _)   = let ty = lineToType b [e]+                              in  renderOneLine <$> getAp (hdlType Internal ty)+renderTag _ (Gen b)         = renderOneLine <$> genStmt b+renderTag _ (GenSym [Text t] _) = return t++-- Determine variables used in argument /n/.+renderTag b (Vars n) = return $ vars'+  where+    (e, _, _) = bbInputs b !! n+    vars      = map Text.fromStrict (usedVariables e)+    vars'     = Text.concat (map (Text.cons ',') vars)++renderTag b (IndexType (Lit n)) =+  case bbInputs b !! n of+    (Literal _ (NumLit n'),_,_) ->+      let hty = Index (fromInteger n')+      in  fmap renderOneLine (getAp (hdlType Internal hty))+    x -> error $ $(curLoc) ++ "Index type not given a literal: " ++ show x+renderTag b (FilePath e)    = case e of+  Lit n -> do+    let (e',_,_) = bbInputs b !! n+    case exprToString e' of+      Just s -> do+        s' <- addAndSetData s+        return (Text.pack (show s'))+      _ -> do+        e2  <- getAp (prettyElem e)+        error $ $(curLoc) ++ "argument of ~FILE:" ++ show e2 ++  "does not reduce to a string"+  _ -> do e' <- getAp (prettyElem e)+          error $ $(curLoc) ++ "~FILE expects a ~LIT[N] argument, but got: " ++ show e'+renderTag b (IncludeName n) = case indexMaybe (bbQsysIncName b) n of+  Just nm -> return (Text.fromStrict nm)+  _ -> error $ $(curLoc) ++ "~INCLUDENAME[" ++ show n ++ "] does not correspond to any index of the 'includes' field that is specified in the primitive definition"+renderTag b (OutputUsage n) = do+  hdl <- gets hdlKind++  let u = case IntMap.lookup n (bbFunctions b) of+            Just ((_,u',_,_,_,_):_) -> u'+            _ -> error $ $(curLoc) ++ "~OUTPUTUSAGE[" ++ show n ++ "] used where argument " ++ show n ++ " is not a function"++  pure $ case (hdl, u) of+    (VHDL, N.Proc N.Blocking) -> "variable"+    (VHDL, _) -> "signal"++    (_, N.Cont) -> "wire"+    (_, _) -> "reg"+renderTag b (Repeat [es] [i]) = do+  i'  <- Text.unpack <$> renderTag b i+  es' <- renderTag b es+  let i'' = case (readEither i' :: Either String Int) of+              Left msg -> error $ $(curLoc) ++ "Could not parse " ++ show i' ++ ". read reported: " ++ msg ++ "."+              Right n  -> n+  return $ Text.concat $ take i'' $ repeat es'++renderTag b (DevNull es) = do+  _ <- mapM (renderElem b) es+  return $ Text.empty++renderTag b (Template filenameL sourceL) = case file of+  Left msg ->+      error $ $(curLoc) ++ unwords [ "Name or source in ~TEMPLATE construct"+                                   , "did not reduce to a string."+                                   , "'elementToText' reported:"+                                   , msg ]+  Right fstup@(filename, _source) -> do+    fs <- getMemoryDataFiles+    if elem filename (map fst fs)+      then if not (elem fstup fs)+        then error $ $(curLoc) ++ unwords [ "Multiple ~TEMPLATE constructs"+                                           , "specifiy the same filename"+                                           , "but different contents. Make"+                                           , "sure these names are unique." ]+      -- We replace the Template element with an empty constant, so nothing+      -- ends up in the generated HDL.+        else return (Text.pack "")+      else do+        addMemoryDataFile fstup+        return (Text.pack "")++  where+      file = do+          filename <- elementsToText b filenameL+          source   <- elementsToText b sourceL+          return (Text.unpack filename, Text.unpack source)++renderTag b CompName = pure (Id.toLazyText (bbCompName b))++renderTag b CtxName = case bbCtxName b of+  Just nm -> return (Text.fromStrict nm)+  _ | Identifier t _ <- fst (bbResult "~CTXNAME" b)+    -> return (Id.toLazyText t)+  _ -> error "internal error"++renderTag _ (EscapedSymbol sym) = case sym of+  SquareBracketOpen  -> return "["+  SquareBracketClose -> return "]"++renderTag _ e = do e' <- getAp (prettyElem e)+                   error $ $(curLoc) ++ "Unable to evaluate: " ++ show e'++-- | Compute string from a list of elements. Can interpret ~NAME string literals+-- on template level (constants).+elementsToText+    :: BlackBoxContext+    -> [Element]+    -> Either String Text+elementsToText bbCtx elements =+    foldl (\txt el -> case txt of+                          -- Append new string (if no error) to string so far+                          Right s -> (Text.append s) <$> elementToText bbCtx el+                          -- If previous iteration resulted in an error: stop.+                          msg -> msg) (Right $ Text.pack "") elements++elementToText+    :: BlackBoxContext+    -> Element+    -> Either String Text+elementToText bbCtx  (Name n) = elementToText bbCtx (Lit n)+elementToText _bbCtx (Text t) = return $ t+elementToText bbCtx  (Lit n) =+    case bbInputs bbCtx ^? element n of+        Just (e,_,_) ->+            case exprToString e of+                Just t ->+                    Right $ Text.pack t+                Nothing ->+                    Left $ $(curLoc) ++ unwords [ "Could not extract string from"+                                                , show e, "referred to by"+                                                , show (Lit n) ]+        Nothing ->+            Left $ $(curLoc) ++ unwords [ "Invalid literal", show (Lit n)+                                        , "used in blackbox with context:"+                                        , show bbCtx, "." ]++elementToText _bbCtx e = error $ "Unexpected string like: " ++ show e++-- | Extracts string from SSymbol or string literals+exprToString+  :: Expr+  -> Maybe String+exprToString (Literal _ (NumLit i)) = Just (show i)+exprToString (Literal _ (StringLit l)) = Just l+exprToString (BlackBoxE "Clash.Promoted.Symbol.SSymbol" _ _ _ _ ctx _) =+  case bbInputs ctx of+    (e0,_,_):_ -> exprToString e0+    _ -> error "internal error: insufficient bbInputs"+exprToString (BlackBoxE "GHC.CString.unpackCString#" _ _ _ _ ctx _) =+  case bbInputs ctx of+    (e0,_,_):_ -> exprToString e0+    _ -> error "internal error: insufficient bbInputs"+exprToString _ = Nothing++prettyBlackBox :: Monad m+               => BlackBoxTemplate+               -> Ap m Text+prettyBlackBox bbT = Text.concat <$> mapM prettyElem bbT++prettyElem+  :: (HasCallStack, Monad m)+  => Element+  -> Ap m Text+prettyElem (Text t) = return t+prettyElem (Component (Decl i 0 args)) = do+  args' <- mapM (\(a,b) -> (,) <$> prettyBlackBox a <*> prettyBlackBox b) args+  case args' of+    (arg:rest) ->+      renderOneLine <$>+        (nest 2 (string "~INST" <+> int i <> line <>+            string "~OUTPUT" <+> string "=>" <+> string (fst arg) <+> string (snd arg) <+> string "~" <> line <>+            vcat (mapM (\(a,b) -> string "~INPUT" <+> string "=>" <+> string a <+> string b <+> string "~") rest))+          <> line <> string "~INST")+    _ -> error "internal error: insufficient args"+prettyElem (Component (Decl {})) =+  error $ $(curLoc) ++ "prettyElem can't (yet) render ~INST when subfuncion /= 0!"+prettyElem Result = return "~RESULT"+prettyElem (Arg i) = renderOneLine <$> ("~ARG" <> brackets (int i))+prettyElem (Lit i) = renderOneLine <$> (string "~LIT" <> brackets (int i))+prettyElem (Const i) = renderOneLine <$> (string "~CONST" <> brackets (int i))+prettyElem (Name i) = renderOneLine <$> (string "~NAME" <> brackets (int i))+prettyElem (ToVar es i) = do+  es' <- prettyBlackBox es+  renderOneLine <$> (string "~VAR" <> brackets (string es') <> brackets (int i))+prettyElem (Sym _ i) = renderOneLine <$> (string "~SYM" <> brackets (int i))+prettyElem (Typ Nothing) = return "~TYPO"+prettyElem (Typ (Just i)) = renderOneLine <$> (string "~TYP" <> brackets (int i))+prettyElem (TypM Nothing) = return "~TYPMO"+prettyElem (TypM (Just i)) = renderOneLine <$> (string "~TYPM" <> brackets (int i))+prettyElem (Err Nothing) = return "~ERRORO"+prettyElem (Err (Just i)) = renderOneLine <$> (string "~ERROR" <> brackets (int i))+prettyElem (TypElem e) = do+  e' <- prettyElem e+  renderOneLine <$> (string "~TYPEL" <> brackets (string e'))+prettyElem CompName = return "~COMPNAME"+prettyElem (IncludeName i) = renderOneLine <$> ("~INCLUDENAME" <> brackets (int i))+prettyElem (IndexType e) = do+  e' <- prettyElem e+  renderOneLine <$> (string "~INDEXTYPE" <> brackets (string e'))+prettyElem (Size e) = do+  e' <- prettyElem e+  renderOneLine <$> (string "~SIZE" <> brackets (string e'))+prettyElem (Length e) = do+  e' <- prettyElem e+  renderOneLine <$> (string "~LENGTH" <> brackets (string e'))+prettyElem (Depth e) = do+  e' <- prettyElem e+  renderOneLine <$> (string "~DEPTH" <> brackets (string e'))+prettyElem (MaxIndex e) = do+  e' <- prettyElem e+  renderOneLine <$> (string "~MAXINDEX" <> brackets (string e'))+prettyElem (FilePath e) = do+  e' <- prettyElem e+  renderOneLine <$> (string "~FILE" <> brackets (string e'))+prettyElem (Gen b) = if b then return "~GENERATE" else return "~ENDGENERATE"+prettyElem (IF b esT esF) = do+  b' <- prettyElem b+  esT' <- prettyBlackBox esT+  esF' <- prettyBlackBox esF+  (renderLazy . layoutCompact) <$>+    (string "~IF" <+> string b' <+> string "~THEN" <>+     string esT' <>+     string "~ELSE" <>+     string esF' <>+     string "~FI")+prettyElem (And es) = renderOneLine <$>+  (string "~AND" <>+  (brackets (hcat (punctuate comma (mapM (string <=< prettyElem) es)))))+prettyElem (CmpLE e1 e2) = do+  e1' <- prettyElem e1+  e2' <- prettyElem e2+  renderOneLine <$> (string "~CMPLE" <> brackets (string e1')+                                     <> brackets (string e2'))+prettyElem IW64 = return "~IW64"+prettyElem (HdlSyn s) = case s of+  Vivado -> return "~VIVADO"+  _      -> return "~OTHERSYN"+prettyElem (BV b es e) = do+  es' <- prettyBlackBox es+  e'  <- prettyBlackBox [e]+  renderOneLine <$>+    if b+       then string "~TOBV" <> brackets (string es') <> brackets (string e')+       else string "~FROMBV" <> brackets (string es') <> brackets (string e')+prettyElem (Sel e i) = do+  e' <- prettyElem e+  renderOneLine <$> (string "~SEL" <> brackets (string e') <> brackets (int i))+prettyElem (IsLit i) = renderOneLine <$> (string "~ISLIT" <> brackets (int i))+prettyElem (IsVar i) = renderOneLine <$> (string "~ISVAR" <> brackets (int i))+prettyElem (IsScalar i) = renderOneLine <$> (string "~ISSCALAR" <> brackets (int i))+prettyElem (IsActiveHigh i) = renderOneLine <$> (string "~ISACTIVEHIGH" <> brackets (int i))+prettyElem (IsActiveEnable i) = renderOneLine <$> (string "~ISACTIVEENABLE" <> brackets (int i))+prettyElem (IsUndefined i) = renderOneLine <$> (string "~ISUNDEFINED" <> brackets (int i))++-- Domain attributes:+prettyElem (Tag i) = renderOneLine <$> (string "~TAG" <> brackets (int i))+prettyElem (Period i) = renderOneLine <$> (string "~PERIOD" <> brackets (int i))+prettyElem LongestPeriod = return "~LONGESTPERIOD"+prettyElem (ActiveEdge e i) = renderOneLine <$> (string "~ACTIVEEDGE" <> brackets (string (Text.pack (show e))) <> brackets (int i))+prettyElem (IsSync i) = renderOneLine <$> (string "~ISSYNC" <> brackets (int i))+prettyElem (IsInitDefined i) = renderOneLine <$> (string "~ISINITDEFINED" <> brackets (int i))++prettyElem (StrCmp es i) = do+  es' <- prettyBlackBox es+  renderOneLine <$> (string "~STRCMP" <> brackets (string es') <> brackets (int i))+prettyElem (GenSym es i) = do+  es' <- prettyBlackBox es+  renderOneLine <$> (string "~GENSYM" <> brackets (string es') <> brackets (int i))+prettyElem (Repeat [es] [i]) = do+  es' <- prettyElem es+  i'  <- prettyElem i+  renderOneLine+    <$> string "~REPEAT"+    <>  brackets (string es')+    <>  brackets (string i')+prettyElem (Repeat es i) = error $ $(curLoc)+                                ++ "Unexpected number of arguments in either "+                                ++ show es+                                ++ " or "+                                ++ show i+                                ++ ". Both lists are expected to have a single element."+prettyElem (DevNull es) = do+  es' <- mapM prettyElem es+  renderOneLine <$> (string "~DEVNULL" <> brackets (string $ Text.concat es'))++prettyElem (SigD es mI) = do+  es' <- prettyBlackBox es+  renderOneLine <$>+    (maybe (string "~SIGDO" <> brackets (string es'))+           (((string "~SIGD" <> brackets (string es')) <>) . int)+           mI)+prettyElem (Vars i) = renderOneLine <$> (string "~VARS" <> brackets (int i))+prettyElem (OutputUsage n) = renderOneLine <$> (string "~OUTPUTUSAGE" <> brackets (int n))+prettyElem (ArgGen n x) =+  renderOneLine <$> (string "~ARGN" <> brackets (int n) <> brackets (int x))+prettyElem (Template bbname source) = do+  bbname' <- mapM prettyElem bbname+  source' <- mapM prettyElem source+  renderOneLine <$> (string "~TEMPLATE"+                                  <> brackets (string $ Text.concat bbname')+                                  <> brackets (string $ Text.concat source'))+prettyElem CtxName = return "~CTXNAME"+prettyElem (EscapedSymbol sym) = case sym of+  SquareBracketOpen  -> return "[\\"+  SquareBracketClose -> return "\\]"++-- | Recursively walk @Element@, applying @f@ to each element in the tree.+walkElement+  :: (Element -> Maybe a)+  -> Element+  -> [a]+walkElement f el = maybeToList (f el) ++ walked+  where+    go     = walkElement f+    walked =+      -- TODO: alternatives are purposely explicitly listed in case @Element@+      -- TODO: gets extended. This way, GHC will complain about missing+      -- TODO: alternatives. It would probably be better to replace it by Lens+      -- TODO: logic?+      case el of+        Component (Decl _ _ args) ->+          concatMap (\(a,b) -> concatMap go a ++ concatMap go b) args+        IndexType e -> go e+        FilePath e -> go e+        Template bbname source ->+          concatMap go bbname ++ concatMap go source+        IF b esT esF ->+          go b ++ concatMap go esT ++ concatMap go esF+        SigD es _ -> concatMap go es+        BV _ es _ -> concatMap go es+        GenSym es _ -> concatMap go es+        DevNull es -> concatMap go es+        Text _ -> []+        Result -> []+        Arg _ -> []+        ArgGen _ _ -> []+        Const _ -> []+        Lit _ -> []+        Name _ -> []+        ToVar es _ -> concatMap go es+        Sym _ _ -> []+        Typ _ -> []+        TypM _ -> []+        Err _ -> []+        TypElem e -> go e+        CompName -> []+        IncludeName _ -> []+        Size e -> go e+        Length e -> go e+        Depth e -> go e+        MaxIndex e -> go e+        Gen _ -> []+        And es -> concatMap go es+        CmpLE e1 e2 -> go e1 ++ go e2+        IW64 -> []+        HdlSyn _ -> []+        Sel e _ -> go e+        IsLit _ -> []+        IsVar _ -> []+        IsScalar _ -> []+        Tag _ -> []+        Period _ -> []+        LongestPeriod -> []+        ActiveEdge _ _ -> []+        IsSync _ -> []+        IsInitDefined _ -> []+        IsActiveHigh _ -> []+        IsActiveEnable _ -> []+        IsUndefined _ -> []+        StrCmp es _ -> concatMap go es+        OutputUsage _ -> []+        Vars _ -> []+        Repeat es1 es2 ->+          concatMap go es1 ++ concatMap go es2+        CtxName -> []+        EscapedSymbol _ -> []++-- | Determine variables used in an expression. Used for VHDL sensitivity list.+-- Also see: https://github.com/clash-lang/clash-compiler/issues/365+usedVariables :: Expr -> [N.IdentifierText]+usedVariables Noop              = []+usedVariables (Identifier i _)  = [Id.toText i]+usedVariables (DataCon _ _ es)  = concatMap usedVariables es+usedVariables (DataTag _ e')    = [Id.toText (either id id e')]+usedVariables (Literal {})      = []+usedVariables (ToBv _ _ e') = usedVariables e'+usedVariables (FromBv _ _ e') = usedVariables e'+usedVariables (IfThenElse e1 e2 e3) = concatMap usedVariables [e1,e2,e3]+usedVariables (BlackBoxE _ _ _ _ t bb _) = nub (sList ++ sList')+  where+    matchArg (Arg i) = Just i+    matchArg _         = Nothing++    matchVar (ToVar [Text v] _) = Just (Text.toStrict v)+    matchVar _                  = Nothing++    t'     = onBlackBox id (\_ _ _ -> []) t+    usedIs = mapMaybe (indexMaybe (bbInputs bb)) (concatMap (walkElement matchArg) t')+    sList  = concatMap (\(e,_,_) -> usedVariables e) usedIs+    sList' = concatMap (walkElement matchVar) t'++-- | Collect arguments (e.g., ~ARG, ~LIT) used in this blackbox+getUsedArguments :: N.BlackBox -> [Int]+getUsedArguments (N.BBFunction _nm _hsh (N.TemplateFunction k _ _)) = k+getUsedArguments (N.BBTemplate t) = nub (concatMap (walkElement matchArg) t)+  where+    matchArg =+      \case+        Arg i -> Just i+        Component (Decl i _ _) -> Just i+        Const i -> Just i+        IsLit i -> Just i+        IsActiveEnable i -> Just i+        IsUndefined i -> Just i+        Lit i -> Just i+        Name i -> Just i+        ToVar _ i -> Just i++        -- Domain properties (only need type):+        IsInitDefined _ -> Nothing+        ActiveEdge _ _ -> Nothing+        IsSync _ -> Nothing+        Period _ -> Nothing+        LongestPeriod -> Nothing+        Tag _ -> Nothing++        -- Others. Template tags only using types of arguments can be considered+        -- "not used".+        And _ -> Nothing+        ArgGen _ _ -> Nothing+        BV _ _ _ -> Nothing+        CmpLE _ _ -> Nothing+        CompName -> Nothing+        Depth _ -> Nothing+        DevNull _ -> Nothing+        Err _ -> Nothing+        FilePath _ -> Nothing+        Gen _ -> Nothing+        GenSym _ _ -> Nothing+        HdlSyn _ -> Nothing+        IF _ _ _ -> Nothing+        IncludeName _ -> Nothing+        IndexType _ -> Nothing+        IsActiveHigh _ -> Nothing+        IsVar _ -> Nothing+        IsScalar _ -> Nothing+        IW64 -> Nothing+        Length _ -> Nothing+        MaxIndex _ -> Nothing+        OutputUsage _ -> Nothing+        Repeat _ _ -> Nothing+        Result -> Nothing+        Sel _ _ -> Nothing+        SigD _ _ -> Nothing+        Size _ -> Nothing+        StrCmp _ _ -> Nothing+        Sym _ _ -> Nothing+        Template _ _ -> Nothing+        Text _ -> Nothing+        Typ _ -> Nothing+        TypElem _ -> Nothing+        TypM _ -> Nothing+        Vars _ -> Nothing+        CtxName -> Nothing+        EscapedSymbol _ -> Nothing++onBlackBox+  :: (BlackBoxTemplate -> r)+  -> (N.BBName -> N.BBHash -> N.TemplateFunction -> r)+  -> N.BlackBox+  -> r+onBlackBox f _ (N.BBTemplate t) = f t+onBlackBox _ g (N.BBFunction n h t) = g n h t++-- | Is the value of the 'Expr' fully undefined?+checkUndefined :: Expr -> Bool+checkUndefined = \case+  BlackBoxE _ _ _ _ (N.BBTemplate [Err _]) _ _ -> True+  BlackBoxE "Clash.Sized.Internal.BitVector.fromInteger#" [] [] [] _ bbCtx _+    | [sz, mask, _val] <- bbInputs bbCtx+    , (Literal _ (NumLit sz0), _, True) <- sz+    , (Literal _ (NumLit mask0), _, True) <- mask+    , mask0 == 2^sz0 - 1+    -> True+  DataCon (Product _ _ _) _ es -> and (map checkUndefined es)+  _ -> False
+ src/Clash/Netlist/BlackBox/Util.hs-boot view
@@ -0,0 +1,19 @@+{-|+  Copyright   :  (C) 2019, Google Inc+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>+-}++module Clash.Netlist.BlackBox.Util where++import Data.Text.Lazy (Text)+import Control.Monad.State (State)+import Clash.Backend (Backend)+import Clash.Netlist.Types (BlackBoxContext)+import Clash.Netlist.BlackBox.Types (BlackBoxTemplate)++renderTemplate+  :: Backend backend+  => BlackBoxContext -- ^ Context used to fill in the hole+  -> BlackBoxTemplate -- ^ Blackbox template+  -> State backend (Int -> Text)
+ src/Clash/Netlist/Expr.hs view
@@ -0,0 +1,172 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2017     , Myrtle Software Ltd,+                    2017-2018, Google Inc.+                    2020-2022, QBayLogic B.V.+                    2022     , Google Inc.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Functions for expression manipulation+-}++{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Netlist.Expr where++import Control.Monad (zipWithM)+import Control.Exception (assert)+import Data.Set (fromList, member)+import Data.Bits (Bits, testBit, setBit, zeroBits)+import Data.Foldable (fold)+import Data.Tree (Tree(..))+import GHC.Stack (HasCallStack)+import Data.Text (unpack)+import Language.Haskell.TH.Quote (dataToPatQ)++import qualified Clash.Sized.Vector as V (replicate)+import qualified Clash.Sized.Internal.Index as I (fromInteger#)+import qualified Clash.Sized.Internal.Signed as S (fromInteger#)+import qualified Clash.Sized.Internal.Unsigned as U (fromInteger#)+import qualified Clash.Sized.Internal.BitVector as BV+  (high, low, fromInteger#, fromInteger##)+import GHC.Int (Int8(I8#), Int16(I16#), Int32(I32#), Int64(I64#))+import GHC.Word (Word8(W8#), Word16(W16#), Word32(W32#), Word64(W64#))++import Clash.Primitives.DSL (tySize)+import Clash.Netlist.Types+  ( Size, Bit(..), Expr(..), HWType(..), Literal(..), Modifier(..)+  , BlackBoxContext(..)+  )++-- | Turns a constant expression of known bitsize into their+-- corresponding bitstream representation, arranged as a tree+-- that corresponds to the structure of the expression.+--+-- NOTE: This conversion serves as a best effort approach and can be+-- considered a hack. Fully featured constant expression evaluation is+-- not available in clash yet and will replace this implementation+-- once it is officially supported.+bits :: HasCallStack => Size -> Expr -> Either Expr (Tree [Bool])+bits size expr = case expr of+  Literal _ lit -> case lit of+    BitLit bLit   -> case bLit of+      H -> leaf [True]+      L -> leaf [False]+      _ -> Left expr+    BoolLit bLit      -> leaf [bLit]+    NumLit nLit       -> leaf $ toBits size nLit+    BitVecLit _ bvLit -> leaf $ toBits size bvLit+    VecLit lits       ->+      mapM (bits (size `div` length lits) . lit2Expr) lits >>= inner+    StringLit{}       -> Left expr+  DataCon ty m subs -> assert (tySize ty == size) $ case ty of+    Vector s t      -> vecBits (tySize t) s subs+    Product _ _ tys -> zipWithM bits (map tySize tys) subs >>= inner+    Sum _ cs        -> spBits expr size m subs $ map (const []) cs+    SP _ xs         -> spBits expr size m subs $ map (map tySize . snd) xs+    _               -> case subs of+      [e] -> bits size e+      []  -> leaf []+      _   -> Left expr+  -- appears in case of complex transformations, e.g.,+  -- >>> (bv2v 0b010) :: Vec 3 Bit+  -- >>> (iterate (SNat @3) not True) :: Vec 3 Bool+  -- >>> (complement <$> (True :> False :> Nil)) :: Vec 2 Bool+  Identifier{} -> Left expr+  DataTag{} -> Left expr+  BlackBoxE bbName _ _ _ _ bbCtx _ -> case unpack bbName of+    $(dataToPatQ (const Nothing) $ show 'BV.low) -> leaf [False]+    $(dataToPatQ (const Nothing) $ show 'BV.high) -> leaf [True]+    $(dataToPatQ (const Nothing) $ show 'V.replicate) -> case bbInputs bbCtx of+      [ (eSize, ty, _), (eValue, _, _) ] -> do+        bs <- bits (tySize ty) eSize+        let s = fromBits $ fold bs+        v <- bits (size `div` s) eValue+        inner $ replicate s v+      _ -> Left expr+    _ ->+      if unpack bbName `member` skippableBBs+      then skippableBBBits expr bbCtx size+      else Left expr+  ToBv _ _ e -> bits size e+  FromBv _ _ e -> bits size e+  IfThenElse cond match alt -> case bits 1 cond of+    Right (Node [True] [])  -> bits size match+    Right (Node [False] []) -> bits size alt+    _ -> Left expr+  Noop -> leaf []++ where+  -- known skippable blackboxes+  skippableBBs = fromList $ map show+    [ 'I.fromInteger#, 'S.fromInteger#, 'U.fromInteger#+    , 'BV.fromInteger#, 'BV.fromInteger##+    , 'I8#, 'I16#, 'I32#, 'I64#+    , 'W8#, 'W16#, 'W32#, 'W64#+    ]++  -- skips the blackbox conversion and obtains the constant result+  -- directly from the last input argument instead+  skippableBBBits e Context{..} n = case reverse bbInputs of+    (x, _, _) : _ -> bits n x+    _             -> Left e++  -- turns sum (& product) expressions into bitstreams (preserving the+  -- expressions' tree layout)+  spBits :: Expr -> Size -> Modifier -> [Expr] -> [[Size]]+         -> Either Expr (Tree [Bool])+  spBits e n m es sizes = case m of+    DC (_, i) -> do+      xs <- zipWithM bits (sizes !! i) es+      bs <- fold <$> inner xs+      l <- leaf $ toBits (n - length bs) i+      r <- leaf bs+      inner [ l, r ]+    _ -> Left e++  -- turns vector expressions into bitstream (preserving the+  -- expressions' tree layout)+  vecBits :: Size -> Int -> [Expr] -> Either Expr (Tree [Bool])+  vecBits elemSize elems = \case+    []   -> assert (elems == 0) $ leaf []+    x:xr -> assert (elems > 0) $ do+      (processedElems, cur) <- case x of+        DataCon t _ xs -> case t of+          Vector subElems (tySize -> subTySize) ->+            assert (subElems <= elems && subTySize == elemSize)+              ((subElems,) <$> vecBits elemSize subElems xs)+          _ -> (1,) <$> bits elemSize x+        _ -> (1,) <$> bits elemSize x+      sub <- vecBits elemSize (elems - processedElems) xr+      inner [cur, sub]++  -- creates a leaf node holding the leaf value+  leaf :: [a] -> Either b (Tree [a])+  leaf x = return $ Node x []++  -- creates an inner node (holding no value) with the given+  -- sub-trees+  inner :: [Tree [a]] -> Either b (Tree [a])+  inner = return . Node []++  -- turns a literal into an expression+  lit2Expr = Literal Nothing++-- | Turns values into bitstreams of known length. If the bit stream+-- requires more bits for representing the given value, then only the+-- suffix of the corresponding bitstream gets returned.+toBits :: Bits a => Int -> a -> [Bool]+toBits n x =+  map (testBit x) [n-1,n-2..0]++-- | Turns bitstreams into values.+fromBits :: Bits a => [Bool] -> a+fromBits xs =+  foldl setBit zeroBits $ map snd $ filter fst $ zip xs [n-1,n-2..0]+ where+  n = length xs
+ src/Clash/Netlist/Id.hs view
@@ -0,0 +1,244 @@+{-|+  Copyright  :  (C) 2020, QBayLogic B.V.+                    2022, Google Inc.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Netlist.Id+  ( -- * Utilities to use IdentifierSet+    IdentifierSet+  , IdentifierSetMonad(..)+  , HasIdentifierSet(..)+  , emptyIdentifierSet+  , makeSet+  , clearSet++    -- * Unsafe creation and extracting identifiers+  , Identifier+  , IdentifierType (..)+  , unsafeMake+  , unsafeFromCoreId+  , toText+  , toLazyText+  , toList+  , union++    -- * Creating and extending identifiers+  , make+  , makeBasic+  , makeBasicOr+  , makeAs+  , add+  , addMultiple+  , addRaw+  , deepen+  , deepenN+  , next+  , nextN+  , prefix+  , suffix+  , fromCoreId++  -- * Misc. and internals+  , VHDL.stripDollarPrefixes+  , toBasicId#+  , isBasic#+  , isExtended#+  )+where++import           Clash.Annotations.Primitive (HDL (..))+import           Clash.Core.Name (nameOcc)+import           Clash.Core.Var (Id, varName)+import           Clash.Debug (debugIsOn)+import           Clash.Netlist.Types+  (PreserveCase(..), HasIdentifierSet(..), IdentifierSet(..), Identifier(..),+   IdentifierType(..), IdentifierSetMonad(identifierSetM))+import qualified Data.HashSet as HashSet+import qualified Data.HashMap.Strict as HashMap+import qualified Data.IntMap.Strict as IntMap+import qualified Data.List as List+import           Data.Text (Text)+import qualified Data.Text.Lazy as LT+import           GHC.Stack++import qualified Clash.Netlist.Id.VHDL as VHDL+import           Clash.Netlist.Id.Internal++-- | Identifier set without identifiers+emptyIdentifierSet+  :: Bool+  -- ^ Allow escaped identifiers?+  -> PreserveCase+  -- ^ Should all basic identifiers be lower case?+  -> HDL+  -- ^ HDL to generate names for+  -> IdentifierSet+emptyIdentifierSet esc lw hdl = makeSet esc lw hdl mempty++-- | Union of two identifier sets. Errors if given sets have been made with+-- different options enabled.+union :: HasCallStack => IdentifierSet -> IdentifierSet -> IdentifierSet+union (IdentifierSet escL lwL hdlL freshL idsL) (IdentifierSet escR lwR hdlR freshR idsR)+  | escL /= escR = error $ "Internal error: escL /= escR, " <> show (escL, escR)+  | hdlL /= hdlR = error $ "Internal error: hdlL /= hdlR, " <> show (hdlL, hdlR)+  | lwL /= lwR = error $ "Internal error: lwL /= lwR , " <> show (lwL, lwR)+  | otherwise = IdentifierSet escR lwR hdlR fresh ids+ where+  fresh = HashMap.unionWith (IntMap.unionWith max) freshL freshR+  ids = HashSet.union idsL idsR++-- | Make a identifier set filled with given identifiers+makeSet+  :: Bool+  -- ^ Allow escaped identifiers?+  -> PreserveCase+  -- ^ Should all basic identifiers be lower case?+  -> HDL+  -- ^ HDL to generate names for+  -> HashSet.HashSet Identifier+  -- ^ Identifiers to add to set+  -> IdentifierSet+makeSet esc lw hdl ids = IdentifierSet esc lw hdl fresh ids+ where+  fresh = List.foldl' updateFreshCache# mempty ids++-- | Remove all identifiers from a set+clearSet :: IdentifierSet -> IdentifierSet+clearSet (IdentifierSet escL lwL hdlL _ _) =+  IdentifierSet escL lwL hdlL mempty mempty++toList :: IdentifierSet -> [Identifier]+toList (IdentifierSet _ _ _ _ idStore) = HashSet.toList idStore++-- | Convert an identifier to string+toText :: Identifier -> Text+toText = toText#++-- | Convert an identifier to string+toLazyText :: Identifier -> LT.Text+toLazyText = LT.fromStrict . toText++-- | Helper function to define pure Id functions in terms of a IdentifierSetMonad+withIdentifierSetM'+  :: IdentifierSetMonad m+  => (IdentifierSet -> a -> IdentifierSet)+  -> a+  -> m ()+withIdentifierSetM' f a = do+  is0 <- identifierSetM id+  identifierSetM (const (f is0 a)) >> pure ()++-- | Helper function to define pure Id functions in terms of a IdentifierSetMonad+withIdentifierSetM+  :: IdentifierSetMonad m+  => (IdentifierSet -> a -> (IdentifierSet, b))+  -> a+  -> m b+withIdentifierSetM f a = do+  is0 <- identifierSetM id+  let (is1, b) = f is0 a+  _ <- identifierSetM (const is1)+  pure b++-- | Like 'addRaw', 'unsafeMake' creates an identifier that will be spliced+-- at verbatim in the HDL. As opposed to 'addRaw', the resulting Identifier+-- might be generated at a later point as it is NOT added to an IdentifierSet.+unsafeMake :: HasCallStack => Text -> Identifier+unsafeMake t =+  RawIdentifier t Nothing (if debugIsOn then callStack else emptyCallStack)++-- | Add an identifier to an IdentifierSet+add :: HasCallStack => IdentifierSetMonad m => Identifier -> m ()+add = withIdentifierSetM' add#++-- | Add identifiers to an IdentifierSet+addMultiple :: (HasCallStack, IdentifierSetMonad m, Foldable t) => t Identifier -> m ()+addMultiple = withIdentifierSetM' addMultiple#++-- | Add a string as is to an IdentifierSet. Should only be used for identifiers+-- that should be spliced at verbatim in HDL, such as port names. It's sanitized+-- version will still be added to the identifier set, to prevent freshly+-- generated variables clashing with the raw one.+addRaw :: (HasCallStack, IdentifierSetMonad m) => Text -> m Identifier+addRaw = withIdentifierSetM addRaw#++-- | Make unique identifier based on given string+make :: (HasCallStack, IdentifierSetMonad m) => Text -> m Identifier+make = withIdentifierSetM make#++-- | Make unique basic identifier based on given string+makeBasic :: (HasCallStack, IdentifierSetMonad m) => Text -> m Identifier+makeBasic = withIdentifierSetM makeBasic#++-- | Make unique basic identifier based on given string. If given string can't+-- be converted to a basic identifier (i.e., it would yield an empty string) the+-- alternative name is used.+makeBasicOr+  :: (HasCallStack, IdentifierSetMonad m)+  => Text+  -- ^ Name hint+  -> Text+  -- ^ If name hint can't be converted to a sensible basic id, use this instead+  -> m Identifier+makeBasicOr hint altHint =+  withIdentifierSetM+    (\is0 -> uncurry (makeBasicOr# is0))+    (hint, altHint)++-- | Make unique identifier. Uses 'makeBasic' if first argument is 'Basic'+makeAs :: (HasCallStack, IdentifierSetMonad m) => IdentifierType -> Text -> m Identifier+makeAs Basic = makeBasic+makeAs Extended = make++-- | Given identifier "foo_1_2" return "foo_1_3". If "foo_1_3" is already a+-- member of the given set, return "foo_1_4" instead, etc. Identifier returned+-- is guaranteed to be unique.+next :: (HasCallStack, IdentifierSetMonad m) => Identifier -> m Identifier+next = withIdentifierSetM next#++-- | Same as 'nextM', but returns N fresh identifiers+nextN :: (HasCallStack, IdentifierSetMonad m) => Int -> Identifier -> m [Identifier]+nextN n = withIdentifierSetM (nextN# n)++-- | Given identifier "foo_1_2" return "foo_1_2_0". If "foo_1_2_0" is already a+-- member of the given set, return "foo_1_2_1" instead, etc. Identifier returned+-- is guaranteed to be unique.+deepen :: (HasCallStack, IdentifierSetMonad m) => Identifier -> m Identifier+deepen = withIdentifierSetM deepen#++-- | Same as 'deepenM', but returns N fresh identifiers. For example, given+-- "foo_23" is would return "foo_23_0", "foo_23_1", ...+deepenN :: (HasCallStack, IdentifierSetMonad m) => Int -> Identifier -> m [Identifier]+deepenN n = withIdentifierSetM (deepenN# n)++-- | Given identifier "foo_1_2" and a suffix "bar", return an identifier called+-- "foo_bar". Identifier returned is guaranteed to be unique according to the+-- rules of 'nextIdentifier'.+suffix :: (HasCallStack, IdentifierSetMonad m) => Identifier -> Text -> m Identifier+suffix id0 suffix_ = withIdentifierSetM (\is id1 -> suffix# is id1 suffix_) id0++-- | Given identifier "foo_1_2" and a prefix "bar", return an identifier called+-- "bar_foo". Identifier returned is guaranteed to be unique according to the+-- rules of 'nextIdentifier'.+prefix :: (HasCallStack, IdentifierSetMonad m) => Identifier -> Text -> m Identifier+prefix id0 prefix_ = withIdentifierSetM (\is id1 -> prefix# is id1 prefix_) id0++-- | Convert a Clash Core Id to an identifier. Makes sure returned identifier+-- is unique.+fromCoreId :: (HasCallStack, IdentifierSetMonad m) => Id -> m Identifier+fromCoreId = withIdentifierSetM fromCoreId#++-- | Like 'fromCoreId, 'unsafeFromCoreId' creates an identifier that will be+-- spliced at verbatim in the HDL. As opposed to 'fromCoreId', the resulting+-- Identifier might be generated at a later point as it is NOT added to an+-- IdentifierSet.+unsafeFromCoreId :: HasCallStack => Id -> Identifier+unsafeFromCoreId = unsafeMake . nameOcc . varName
+ src/Clash/Netlist/Id.hs-boot view
@@ -0,0 +1,6 @@+module Clash.Netlist.Id where++import {-# SOURCE #-} Clash.Netlist.Types (Identifier)+import Data.Text (Text)++toText :: Identifier -> Text
+ src/Clash/Netlist/Id/Common.hs view
@@ -0,0 +1,107 @@+{-|+  Copyright  :  (C) 2020-2021, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com+-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Netlist.Id.Common where++import           Control.Arrow (first)+import           Control.Applicative ((<|>))+import           Data.Maybe (fromMaybe)+import           Data.Text (Text)+import           Data.Text.Extra (showt)+import qualified Data.Text as Text+import qualified Data.Char as Char++parseWhiteSpace :: Text -> Maybe Text+parseWhiteSpace = parseSingle isWhiteSpace++isWhiteSpace :: Char -> Bool+isWhiteSpace c = c `elem` [' ', '\n', '\t']++parsePrintable :: Text -> Maybe Text+parsePrintable = parseSingle (\c -> Char.isPrint c && Char.isAscii c)++parseSingle :: (Char -> Bool) -> Text -> Maybe Text+parseSingle predicate s = do+  (l, ls) <- Text.uncons s+  if predicate l then Just ls else Nothing++parseMaybeSingle :: (Char -> Bool) -> Text -> Maybe Text+parseMaybeSingle predicate s = Just (fromMaybe s (parseSingle predicate s))++parseLetter :: Text -> Maybe Text+parseLetter = parseSingle (\c -> Char.isAscii c && Char.isLetter c)++parseDigit :: Text -> Maybe Text+parseDigit = parseSingle Char.isDigit++parseLetterOrDigit :: Text -> Maybe Text+parseLetterOrDigit s = parseLetter s <|> parseDigit s++parseUnderscore :: Text -> Maybe Text+parseUnderscore = parseSingle (=='_')++parseDollar :: Text -> Maybe Text+parseDollar = parseSingle (=='$')++parseTab :: Text -> Maybe Text+parseTab = parseSingle (=='\t')++parseBackslash :: Text -> Maybe Text+parseBackslash = parseSingle (=='\\')++failNonEmpty :: Text -> Maybe Text+failNonEmpty s | Text.null s = Just Text.empty+               | otherwise = Nothing++repeatParseN :: (Text -> Maybe Text) -> Text -> Maybe (Int, Text)+repeatParseN parser = go 0+ where+  go n s0 =+    case parser s0 of+      Just s1 -> go (n+1) s1+      Nothing -> Just (n, s0)++repeatParse :: (Text -> Maybe Text) -> Text -> Maybe Text+repeatParse parser s0 = snd <$> repeatParseN parser s0++-- | Encodes tuples as "TupN" and removes all characters not matching a+-- predicate.+zEncode+  :: (Char -> Bool)+  -- ^ Characters to keep+  -> Text+  -> Text+zEncode keep s =+  let go = zEncode keep in+  case maybeTuple s of+    Just (tupName, rest) ->+      tupName <> go rest+    Nothing ->+      case Text.uncons s of+        Just (c, rest) ->+          if keep c then+            Text.cons c (go rest)+          else+            go rest+        Nothing -> s++prettyName :: Text -> Text+prettyName t = maybe t (uncurry (<>)) (maybeTuple t)++maybeTuple :: Text -> Maybe (Text, Text)+maybeTuple "(# #)" = Just ("Unit", "")+maybeTuple "()" = Just ("Unit", "")+maybeTuple t = first (\n -> "Tuple" <> showt n) <$> parseTuple t++parseTuple :: Text -> Maybe (Int, Text)+parseTuple t0 = do+  t1 <- parseSingle (=='(') t0+  t2 <- parseMaybeSingle (=='#') t1+  (n, t3) <- repeatParseN (parseSingle (== ',')) t2+  t4 <- parseMaybeSingle (=='#') t3+  t5 <- parseSingle (==')') t4+  pure (n+1, t5)
+ src/Clash/Netlist/Id/Internal.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Clash.Netlist.Id.Internal where++import           Clash.Annotations.Primitive (HDL (..))+import           Clash.Core.Name (Name(nameOcc))+import           Clash.Core.Var (Id, varName)+import           Clash.Debug (debugIsOn)+import           Clash.Netlist.Types+  (PreserveCase(..), IdentifierSet(..), Identifier(..), FreshCache,+   IdentifierType(..))+import           Control.Arrow (second)+import qualified Data.Char as Char+import qualified Data.List as List++#if MIN_VERSION_prettyprinter(1,7,0)+import qualified Prettyprinter as PP+#else+import qualified Data.Text.Prettyprint.Doc as PP+#endif++import qualified Data.Text as Text+import           Data.Text (Text)+import           Data.Text.Extra (showt)+import qualified Data.Maybe as Maybe+import           Text.Read (readMaybe)+import           GHC.Stack++import qualified Data.IntMap as IntMap+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet++import qualified Clash.Netlist.Id.SystemVerilog as SystemVerilog+import qualified Clash.Netlist.Id.Verilog as Verilog+import qualified Clash.Netlist.Id.VHDL as VHDL+import qualified Clash.Netlist.Id.Common as Common++-- | Return identifier with highest extension for given identifier. See+-- 'is_freshCache' for more information.+--+-- For example, if the FreshCache contains "foo_12_25" and the given identifier+-- is "foo_12_13" this function would return "Just 25". In this case, "foo_12_26"+-- is guaranteed to be a fresh identifier.+lookupFreshCache# :: FreshCache -> Identifier -> Maybe Word+lookupFreshCache# fresh0 id0 = do+  fresh1 <- HashMap.lookup (i_baseNameCaseFold id0) fresh0+  IntMap.lookup (length (i_extensionsRev id0)) fresh1++-- | Add new identifier to FreshCache, see 'is_freshCache' for more information.+updateFreshCache# :: HasCallStack => FreshCache -> Identifier -> FreshCache+updateFreshCache# _fresh (RawIdentifier _s Nothing _) =+  error "Internal error: updateFreshCache# called with unsafely made identifier"+updateFreshCache# fresh (RawIdentifier _s (Just id_) _) =+  updateFreshCache# fresh id_+updateFreshCache# fresh id_ =+  go0 (go1 (max (Maybe.fromMaybe 0 (Maybe.listToMaybe exts))))+ where+  go0 f = HashMap.alter (Just . f . Maybe.fromMaybe mempty) base fresh+  go1 f = IntMap.alter (Just . f . Maybe.fromMaybe 0) (length exts)++  exts = i_extensionsRev id_+  base = i_baseNameCaseFold id_++-- | Adds identifier at verbatim if its basename hasn't been used before.+-- Otherwise it will return the first free identifier.+mkUnique#+  :: HasCallStack+  => IdentifierSet+  -> Identifier+  -> (IdentifierSet, Identifier)+mkUnique# _is0 (RawIdentifier {}) =+  error "Internal error: mkUnique# cannot be used on RawIdentifiers"+mkUnique# is0 id_@(i_extensionsRev -> []) = deepen# is0 id_+mkUnique# is id0 = (is{is_freshCache=freshCache, is_store=isStore}, id2)+ where+  freshCache = updateFreshCache# (is_freshCache is) id2+  isStore = HashSet.insert id2 (is_store is)+  id2 = case id1 of+          x@RawIdentifier{} -> x+          y -> y{i_provenance=if debugIsOn then callStack else emptyCallStack}+  id1 = case lookupFreshCache# (is_freshCache is) id0 of+    Just currentMax ->+      id0{i_extensionsRev=currentMax+1 : drop 1 (i_extensionsRev id0)}+    Nothing ->+      -- Identifier doesn't exist in set yet, so just return it.+      id0++-- | Non-monadic, internal version of 'add'+add# :: HasCallStack => IdentifierSet -> Identifier -> IdentifierSet+add# is0@(IdentifierSet{..}) (RawIdentifier t Nothing _) = add# is0 (make## is_hdl t)+add# is0 (RawIdentifier _ (Just id0) _) = add# is0 id0+add# is0@(IdentifierSet{..}) id0 = is0{is_freshCache=fresh1, is_store=ids1}+ where+  ids1 = HashSet.insert id0 is_store+  fresh1 = updateFreshCache# is_freshCache id0++-- | Non-monadic, internal version of 'addMultiple'+addMultiple# :: (HasCallStack, Foldable t) => IdentifierSet -> t Identifier -> IdentifierSet+addMultiple# is ids = List.foldl' add# is ids++-- | Non-monadic, internal version of 'addRaw'+addRaw# :: HasCallStack => IdentifierSet -> Text -> (IdentifierSet, Identifier)+addRaw# is0 id0 =+  second+    (\i -> RawIdentifier id0 (Just i) (if debugIsOn then callStack else emptyCallStack))+    (make# is0 (unextend id0))+ where+  unextend = case is_hdl is0 of+    VHDL -> VHDL.unextend+    Verilog -> Verilog.unextend+    SystemVerilog -> SystemVerilog.unextend++-- | Non-monadic, internal version of 'make'+make# :: HasCallStack => IdentifierSet -> Text -> (IdentifierSet, Identifier)+make# is0@(IdentifierSet esc lw hdl fresh0 ids0) (Common.prettyName -> id0) =+  if id1 `HashSet.member` ids0 then+    -- Ideally we'd like to continue with the id from the HashSet so all the old+    -- strings can be garbage collected, but I haven't found an efficient way of+    -- doing so. I also doubt that this case will get hit often..+    deepen# is0 id1+  else+    (is0{is_freshCache=fresh1, is_store=ids1}, id1)+ where+  ids1 = HashSet.insert id1 ids0+  fresh1 = updateFreshCache# fresh0 id1+  id1 = make## (is_hdl is0) (if esc then id0 else toBasicId# hdl lw id0)++-- | Non-monadic, internal version of 'makeBasic'+makeBasic# :: HasCallStack => IdentifierSet -> Text -> (IdentifierSet, Identifier)+makeBasic# is0 = make# is0 . toBasicId# (is_hdl is0) (is_lowerCaseBasicIds is0)++-- | Non-monadic, internal version of 'makeBasicOr'+makeBasicOr# :: HasCallStack => IdentifierSet -> Text -> Text -> (IdentifierSet, Identifier)+makeBasicOr# is0 hint altHint = make# is0 id1+ where+  id0 = toBasicId# (is_hdl is0) (is_lowerCaseBasicIds is0) hint+  id1 = if Text.null id0+        then toBasicId# (is_hdl is0) (is_lowerCaseBasicIds is0) altHint+        else id0++-- | Non-monadic, internal version of 'next'+next# :: HasCallStack => IdentifierSet -> Identifier ->  (IdentifierSet, Identifier)+next# is0 (RawIdentifier t Nothing _) = uncurry next# (make# is0 t)+next# is0 (RawIdentifier _ (Just id_) _) = next# is0 id_+next# is0 id_@(i_extensionsRev -> []) = deepen# is0 id_+next# is0 id_ = mkUnique# is0 id_++-- | Non-monadic, internal version of 'nextN'+nextN# :: HasCallStack => Int -> IdentifierSet -> Identifier ->  (IdentifierSet, [Identifier])+nextN# n is0 id0 = List.mapAccumL (\is1 _n -> next# is1 id0) is0 [1..n]+-- TODO: ^ More efficient implementation.++-- | Non-monadic, internal version of 'deepenN'+deepenN# :: HasCallStack => Int -> IdentifierSet -> Identifier ->  (IdentifierSet, [Identifier])+deepenN# n is0 id0 = List.mapAccumL (\is1 _n -> deepen# is1 id0) is0 [1..n]+-- TODO: ^ More efficient implementation.++-- | Non-monadic, internal version of 'deepen'+deepen# :: HasCallStack => IdentifierSet -> Identifier ->  (IdentifierSet, Identifier)+deepen# is0 (RawIdentifier t Nothing _) = uncurry deepen# (make# is0 t)+deepen# is0 (RawIdentifier _ (Just id_) _) = deepen# is0 id_+deepen# is0 id_ = mkUnique# is0 (id_{i_extensionsRev=0:i_extensionsRev id_})++-- | Non-monadic, internal version of 'suffix'+suffix# :: HasCallStack => IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)+suffix# is0 (RawIdentifier t Nothing _) suffix_ = (uncurry suffix# (make# is0 t)) suffix_+suffix# is0 (RawIdentifier _ (Just id_) _) suffix_ = suffix# is0 id_ suffix_+suffix# is0 id0 suffix_ = make# is0 (i_baseName id0 <> "_" <> suffix_)++-- | Non-monadic, internal version of 'prefix'+prefix# :: HasCallStack => IdentifierSet -> Identifier -> Text -> (IdentifierSet, Identifier)+prefix# is0 (RawIdentifier t Nothing _) prefix_ = (uncurry prefix# (make# is0 t)) prefix_+prefix# is0 (RawIdentifier _ (Just id_) _) prefix_ = prefix# is0 id_ prefix_+prefix# is0 id0 prefix_ = make# is0 (prefix_ <> "_" <> i_baseName id0)++toText# :: Identifier -> Text+toText# (RawIdentifier t _ _) = t+toText# (UniqueIdentifier{..}) =+  case i_hdl of+    VHDL -> VHDL.toText i_idType basicId+    Verilog -> Verilog.toText i_idType basicId+    SystemVerilog -> SystemVerilog.toText i_idType basicId+ where+  exts = map showt (reverse i_extensionsRev)+  basicId = Text.intercalate "_" (i_baseName : exts)++-- | Is given string a valid basic identifier in given HDL?+isBasic# :: HDL -> Text -> Bool+isBasic# VHDL = VHDL.parseBasic+isBasic# Verilog = Verilog.parseBasic+isBasic# SystemVerilog = SystemVerilog.parseBasic++-- | Is given string a valid extended identifier in given HDL?+isExtended# :: HDL -> Text -> Bool+isExtended# VHDL = VHDL.parseExtended+isExtended# Verilog = Verilog.parseExtended+isExtended# SystemVerilog = SystemVerilog.parseExtended++-- | Convert given string to ASCII. Retains all printable ASCII. All other+-- characters are thrown out.+toPrintableAscii# :: Text -> Text+toPrintableAscii# = Text.filter (\c -> Char.isPrint c && Char.isAscii c)++-- | Split identifiers such as "foo_1_2" into ("foo", [2, 1]).+parseIdentifier# :: Text -> (Text, [Word])+parseIdentifier# t =+  let (tsRev, extsRev) = go (List.reverse (Text.splitOn "_" t)) in+  (Text.intercalate "_" (List.reverse tsRev), extsRev)+ where+  go :: [Text] -> ([Text], [Word])+  go [] = go ["clash", "internal"]+  go (i:is) = case readMaybe @Word (Text.unpack i) of+    Just w -> second (w:) (go is)+    Nothing -> (i:is, [])++make## :: HasCallStack => HDL -> Text -> Identifier+make## hdl =+    go+  . Text.strip+  . Text.replace "\\" ""+  . toPrintableAscii#+ where+  go s | Text.null s = go "clash_internal"+       | otherwise =+          let+            (baseName, extensions) = parseIdentifier# s+            idType = if isBasic# hdl s then Basic else Extended++            -- VHDL is a case insensitive language, so we convert the given+            -- text to lowercase. Note that 'baseNameCaseFold' is used in the+            -- Eq for Identifier.+            baseNameCaseFold = case hdl of+              VHDL -> Text.toCaseFold baseName+              _ -> baseName+          in+            UniqueIdentifier+              baseName baseNameCaseFold extensions idType hdl+              (if debugIsOn then callStack else emptyCallStack)++toBasicId# :: HDL -> PreserveCase -> Text -> Text+toBasicId# hdl lw id0 =+  case hdl of+    VHDL -> VHDL.toBasic id1+    Verilog -> Verilog.toBasic id1+    SystemVerilog -> SystemVerilog.toBasic id1+ where+  id1 = case lw of {PreserveCase -> id0; ToLower -> Text.toLower id0}++-- | Convert a Clash Core Id to an identifier. Makes sure returned identifier+-- is unique.+fromCoreId# :: IdentifierSet -> Id -> (IdentifierSet, Identifier)+fromCoreId# is0 id0 = make# is0 (nameOcc (varName id0))++instance PP.Pretty Identifier where+  pretty = PP.pretty . toText#
+ src/Clash/Netlist/Id/SystemVerilog.hs view
@@ -0,0 +1,71 @@+{-|+  Copyright  :  (C) 2020, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com+-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Netlist.Id.SystemVerilog where++import           Data.Text (Text)+import qualified Data.Text as Text+import           Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet+import qualified Clash.Netlist.Id.Verilog as Verilog++import           Clash.Netlist.Types (IdentifierType)++-- List of reserved SystemVerilog-2012 keywords+keywords :: HashSet Text+keywords = HashSet.fromList+  ["accept_on","alias","always","always_comb","always_ff"+  ,"always_latch","and","assert","assign","assume","automatic","before","begin"+  ,"bind","bins","binsof","bit","break","buf","bufif0","bufif1","byte","case"+  ,"casex","casez","cell","chandle","checker","class","clocking","cmos","config"+  ,"const","constraint","context","continue","cover","covergroup","coverpoint"+  ,"cross","deassign","default","defparam","design","disable","dist","do","edge"+  ,"else","end","endcase","endchecker","endclass","endclocking","endconfig"+  ,"endfunction","endgenerate","endgroup","endinterface","endmodule","endpackage"+  ,"endprimitive","endprogram","endproperty","endspecify","endsequence"+  ,"endtable","endtask","enum","event","eventually","expect","export","extends"+  ,"extern","final","first_match","for","force","foreach","forever","fork"+  ,"forkjoin","function","generate","genvar","global","highz0","highz1","if"+  ,"iff","ifnone","ignore_bins","illegal_bins","implements","implies","import"+  ,"incdir","include","initial","inout","input","inside","instance","int"+  ,"integer","interconnect","interface","intersect","join","join_any"+  ,"join_none","large","let","liblist","library","local","localparam","logic"+  ,"longint","macromodule","matches","medium","modport","module","nand"+  ,"negedge","nettype","new","nexttime","nmos","nor","noshowcancelled","not"+  ,"notif0","notif1","null","or","output","package","packed","parameter","pmos"+  ,"posedge","primitive","priority","program","property","protected","pull0"+  ,"pull1","pulldown","pullup","pulsestyle_ondetect","pulsestyle_onevent"+  ,"pure","rand","randc","randcase","randsequence","rcmos","real","realtime"+  ,"ref","reg","reject_on","release","repeat","restrict","return","rnmos"+  ,"rpmos","rtran","rtranif0","rtranif1","s_always","s_eventually","s_nexttime"+  ,"s_until","s_until_with","scalared","sequence","shortint","shortreal"+  ,"showcancelled","signed","small","soft","solve","specify","specparam"+  ,"static","string","strong","strong0","strong1","struct","super","supply0"+  ,"supply1","sync_accept_on","sync_reject_on","table","tagged","task","this"+  ,"throughout","time","timeprecision","timeunit","tran","tranif0","tranif1"+  ,"tri","tri0","tri1","triand","trior","trireg","type","typedef","union"+  ,"unique","unique0","unsigned","until","until_with","untyped","use","uwire"+  ,"var","vectored","virtual","void","wait","wait_order","wand","weak","weak0"+  ,"weak1","while","wildcard","wire","with","within","wor","xnor","xor"]++isKeyword :: Text -> Bool+isKeyword t = HashSet.member (Text.toLower t) keywords++parseBasic :: Text -> Bool+parseBasic id0 = Verilog.parseBasic' id0 && not (isKeyword id0)++parseExtended :: Text -> Bool+parseExtended = Verilog.parseExtended++toBasic :: Text -> Text+toBasic (Verilog.toBasic' -> t) = if isKeyword t then "r_" <> t else t++unextend :: Text -> Text+unextend = Verilog.unextend++toText :: IdentifierType -> Text -> Text+toText = Verilog.toText
+ src/Clash/Netlist/Id/VHDL.hs view
@@ -0,0 +1,163 @@+{-|+  Copyright  :  (C) 2020, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com+-}+{-# LANGUAGE OverloadedStrings #-}+module Clash.Netlist.Id.VHDL where++import Clash.Netlist.Id.Common++import           Control.Applicative ((<|>))+import qualified Data.Char as Char+import qualified Data.Text as Text+import           Data.Text (Text)+import           Data.Maybe (isJust, fromMaybe)+import           Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet++import           Clash.Netlist.Types (IdentifierType(..))++-- | Identifiers which are imported from the following:+--+-- use IEEE.STD_LOGIC_1164.ALL;+-- use IEEE.NUMERIC_STD.ALL;+-- use IEEE.MATH_REAL.ALL;+-- use std.textio.all;+--+-- Clash should not use these identifiers, as it can lead to errors when+-- interfacing with an EDA tool.+--+-- See https://github.com/clash-lang/clash-compiler/issues/1439.+--+importedNames :: [Text]+importedNames =+  [ -- ieee.std_logic_1164.all+    "std_ulogic", "std_ulogic_vector", "resolved", "std_logic", "std_logic_vector"+  , "x01", "x01z", "ux01", "ux01z", "to_bit", "to_bitvector", "to_stdulogic"+  , "to_stdlogicvector", "to_stdulogicvector", "to_01", "to_x01", "to_x01z"+  , "to_ux01", "rising_edge", "falling_edge", "is_x"+    -- ieee.numeric_std.all+  , "unresolved_unsigned", "unresolved_signed", "u_unsigned", "u_signed"+  , "unsigned", "signed", "find_leftmost", "find_rightmost", "minimum"+  , "maximum", "shift_left", "shift_right", "rotate_left", "rotate_right"+  , "resize", "to_integer", "to_unsigned", "to_signed", "std_match"+    -- ieee.math_real.all+  , "math_e", "math_1_over_e", "math_pi", "math_2_pi", "math_1_over_pi"+  , "math_pi_over_2", "math_pi_over_3", "path_pi_over_4", "path_3_pi_over_2"+  , "math_log_of_2", "math_log_of_10", "math_log10_of_e", "math_sqrt_2"+  , "math_1_over_sqrt_2", "math_sqrt_pi", "math_deg_to_rad", "math_rad_to_deg"+  , "sign", "ceil", "floor", "round", "trunc", "realmax", "realmin", "uniform"+  , "sqrt", "cbrt", "exp", "log", "log2", "log10", "sin", "cos", "tan", "arcsin"+  , "arccos", "arctan", "sinh", "cosh", "tanh", "arcsinh", "arccosh", "arctanh"+    -- std.textio.all+  , "line", "text", "side", "width", "justify", "input", "output", "readline"+  , "read", "sread", "string_read", "bread", "binary_read", "oread", "octal_read"+  , "hread", "hex_read", "writeline", "tee", "write", "swrite", "string_write"+  , "bwrite", "binary_write", "owrite", "octal_write", "hwrite", "hex_write"+  ]++-- | Time units: are added to 'reservedWords' as simulators trip over signals+-- named after them.+timeUnits :: [Text]+timeUnits = ["fs", "ps", "ns", "us", "ms", "sec", "min", "hr"]++-- List of reserved VHDL-2008 keywords+-- + used internal names: toslv, fromslv, tagtoenum, datatotag+-- + used IEEE library names: integer, boolean, std_logic, std_logic_vector,+--   signed, unsigned, to_integer, to_signed, to_unsigned, string+keywords :: HashSet Text+keywords = HashSet.fromList $+  ["abs","access","after","alias","all","and","architecture"+  ,"array","assert","assume","assume_guarantee","attribute","begin","block"+  ,"body","buffer","bus","case","component","configuration","constant","context"+  ,"cover","default","disconnect","downto","else","elsif","end","entity","exit"+  ,"fairness","file","for","force","function","generate","generic","group"+  ,"guarded","if","impure","in","inertial","inout","is","label","library"+  ,"linkage","literal","loop","map","mod","nand","new","next","nor","not","null"+  ,"of","on","open","or","others","out","package","parameter","port","postponed"+  ,"procedure","process","property","protected","pure","range","record"+  ,"register","reject","release","rem","report","restrict","restrict_guarantee"+  ,"return","rol","ror","select","sequence","severity","signal","shared","sla"+  ,"sll","sra","srl","strong","subtype","then","to","transport","type"+  ,"unaffected","units","until","use","variable","vmode","vprop","vunit","wait"+  ,"when","while","with","xnor","xor","toslv","fromslv","tagtoenum","datatotag"+  ,"integer", "boolean", "std_logic", "std_logic_vector", "signed", "unsigned"+  ,"to_integer", "to_signed", "to_unsigned", "string","log"] <> timeUnits <> importedNames++isKeyword :: Text -> Bool+isKeyword t = HashSet.member (Text.toLower t) keywords++parseBasic :: Text -> Bool+parseBasic id0 = parseBasic' id0 && not (isKeyword id0)++parseBasic' :: Text -> Bool+parseBasic' id0 = isJust $ do+  id1 <- parseLetter id0+  id2 <- repeatParse parseGroup id1+  failNonEmpty id2+ where+  parseGroup s0 = do+    s1 <- parseUnderscore s0 <|> Just s0+    s2 <- parseLetterOrDigit s1+    repeatParse parseLetterOrDigit s2++parseExtended :: Text -> Bool+parseExtended id0 = isJust $ do+  id1 <- parseBackslash id0+  id2 <- parse id1+  id3 <- parseBackslash id2+  failNonEmpty id3+ where+  parse s0 =+    case parseBackslash s0 of+      Just s1 -> parseBackslash s1 >>= repeatParse parse+      Nothing -> parsePrintable s0 >>= repeatParse parse++toBasic :: Text -> Text+toBasic =+    replaceKeywords+  . stripMultiscore+  . Text.dropWhileEnd (=='_')+  . Text.dropWhile (\c -> c == '_' || Char.isDigit c)+  . zEncode isBasicChar+  . stripDollarPrefixes+--  . Text.toLower+ where+  replaceKeywords i+    | isKeyword i = "r_" <> i+    | otherwise = i++  stripMultiscore =+      Text.concat+    . Prelude.map (\cs -> case Text.head cs of {'_' -> "_"; _ -> cs})+    . Text.group++isBasicChar :: Char -> Bool+isBasicChar c = or+  [ Char.isAsciiLower c+  , Char.isAsciiUpper c+  , Char.isDigit c+  , c == '_'+  ]++stripDollarPrefixes :: Text -> Text+stripDollarPrefixes = stripWorkerPrefix . stripSpecPrefix . stripConPrefix+                    . stripWorkerPrefix . stripDictFunPrefix+  where+    stripDictFunPrefix t =+      maybe t (Text.takeWhileEnd (/='_')) (Text.stripPrefix "$f" t)+    stripWorkerPrefix t = fromMaybe t (Text.stripPrefix "$w" t)+    stripConPrefix t = fromMaybe t (Text.stripPrefix "$c" t)+    stripSpecPrefix t = fromMaybe t (Text.stripPrefix "$s" t)++unextend :: Text -> Text+unextend =+     Text.strip+   . (\t -> fromMaybe t (Text.stripPrefix "\\" t))+   . (\t -> fromMaybe t (Text.stripSuffix "\\" t))+   . Text.strip++toText :: IdentifierType -> Text -> Text+toText Basic t = t+toText Extended t = "\\" <> t <> "\\"
+ src/Clash/Netlist/Id/Verilog.hs view
@@ -0,0 +1,99 @@+{-|+  Copyright  :  (C) 2020, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com+-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Netlist.Id.Verilog where++import           Control.Applicative ((<|>))+import qualified Data.Char as Char+import           Data.Maybe (isJust, fromMaybe)+import qualified Data.Text as Text+import           Data.Text (Text)+import           Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet++import           Clash.Netlist.Id.Common+import           Clash.Netlist.Types (IdentifierType(..))++-- List of reserved Verilog-2005 keywords+keywords :: HashSet Text+keywords = HashSet.fromList+  ["always","and","assign","automatic","begin","buf","bufif0"+  ,"bufif1","case","casex","casez","cell","cmos","config","deassign","default"+  ,"defparam","design","disable","edge","else","end","endcase","endconfig"+  ,"endfunction","endgenerate","endmodule","endprimitive","endspecify"+  ,"endtable","endtask","event","for","force","forever","fork","function"+  ,"generate","genvar","highz0","highz1","if","ifnone","incdir","include"+  ,"initial","inout","input","instance","integer","join","large","liblist"+  ,"library","localparam","macromodule","medium","module","nand","negedge"+  ,"nmos","nor","noshowcancelled","not","notif0","notif1","or","output"+  ,"parameter","pmos","posedge","primitive","pull0","pull1","pulldown","pullup"+  ,"pulsestyle_onevent","pulsestyle_ondetect","rcmos","real","realtime","reg"+  ,"release","repeat","rnmos","rpmos","rtran","rtranif0","rtranif1","scalared"+  ,"showcancelled","signed","small","specify","specparam","strong0","strong1"+  ,"supply0","supply1","table","task","time","tran","tranif0","tranif1","tri"+  ,"tri0","tri1","triand","trior","trireg","unsigned","use","uwire","vectored"+  ,"wait","wand","weak0","weak1","while","wire","wor","xnor","xor"]++isKeyword :: Text -> Bool+isKeyword t = HashSet.member (Text.toLower t) keywords++parseBasic :: Text -> Bool+parseBasic id0 = parseBasic' id0 && not (isKeyword id0)++parseBasic' :: Text -> Bool+parseBasic' id0 = isJust $ do+  id1 <- parseUnderscore id0 <|> parseLetter id0+  id2 <- repeatParse parseAllowedChars id1+  failNonEmpty id2+ where+  parseAllowedChars s =+        parseLetterOrDigit s+    <|> parseUnderscore s+    <|> parseDollar s++parseExtended :: Text -> Bool+parseExtended id0 =+  isJust ((parse id0 >>= failNonEmpty) >> parseEnd id0)+ where+  -- Extended identifier must start with backslash, followed by printable chars+  parse s = parseBackslash s >>= repeatParse parsePrintable++  -- Extended identifier must end in exactly one whitespace+  parseEnd :: Text -> Maybe Text+  parseEnd s =+    case Text.unpack (Text.takeEnd 2 s) of+      [c0, c1] | not (isWhiteSpace c0) && isWhiteSpace c1 -> Just ""+      _ -> Nothing++toBasic' :: Text -> Text+toBasic' (zEncode isBasicChar -> t) =+  case Text.uncons t of+    Just (c, _) | Char.isDigit c || c == '$' -> Text.cons '_' t+    _ -> t++toBasic :: Text -> Text+toBasic (toBasic' -> t) =+  if HashSet.member (Text.toLower t) keywords then "r_" <> t else t++isBasicChar :: Char -> Bool+isBasicChar c = or+  [ Char.isAsciiLower c+  , Char.isAsciiUpper c+  , Char.isDigit c+  , c == '_'+  , c == '$'+  ]++unextend :: Text -> Text+unextend =+     Text.strip+   . (\t -> fromMaybe t (Text.stripPrefix "\\" t))+   . Text.strip++toText :: IdentifierType -> Text -> Text+toText Basic t = t+toText Extended t = "\\" <> t <> " "
+ src/Clash/Netlist/Types.hs view
@@ -0,0 +1,1046 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2017     , Myrtle Software Ltd,+                    2017-2018, Google Inc.+                    2020-2023, QBayLogic B.V.+                    2022-2023, Google Inc.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Type and instance definitions for Netlist modules+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Netlist.Types+  ( Declaration (..,NetDecl)+  , module Clash.Netlist.Types+  )+where++import Control.DeepSeq+import qualified Control.Lens               as Lens+import Control.Lens                         (Lens', (.=))+import Control.Monad.Reader                 (ReaderT, MonadReader)+import qualified Control.Monad.State        as Lazy (State)+import qualified Control.Monad.State.Strict as Strict+  (State, MonadIO, MonadState, StateT)+import Data.Aeson                           (FromJSON(..))+import qualified Data.Aeson as Aeson+import Data.Bits                            (testBit)+import Data.Binary                          (Binary(..))+import Data.Function                        (on)+import Data.Hashable                        (Hashable(hash,hashWithSalt))+import Data.HashMap.Strict                  (HashMap)+import Data.HashSet                         (HashSet)+import qualified Data.List                  as List+import Data.IntMap                          (IntMap, empty)+import Data.Map.Ordered                     (OMap)+import Data.Map                             (Map)+import qualified Data.Map as Map+import Data.Maybe                           (mapMaybe)+import Data.Monoid                          (Ap(..))+import qualified Data.Set                   as Set+import Data.Text                            (Text)++#if __GLASGOW_HASKELL__ <= 910+import Data.Typeable                        (Typeable)+#endif+import Data.Text.Prettyprint.Doc.Extra      (Doc)+import GHC.Generics                         (Generic)+import GHC.Stack+import Language.Haskell.TH.Syntax           (Lift)++import GHC.Types.SrcLoc                     (SrcSpan)++import Clash.Annotations.SynthesisAttributes(Attr)+import Clash.Annotations.BitRepresentation  (FieldAnn)+import Clash.Annotations.Primitive          (HDL(..))+import Clash.Annotations.TopEntity          (TopEntity)+import Clash.Backend                        (Backend, HasUsageMap (..))+import Clash.Core.HasType+import Clash.Core.PartialEval               (Evaluator)+import Clash.Core.Type                      (Type)+import Clash.Core.Var                       (Id)+import Clash.Core.TyCon                     (TyConMap)+import Clash.Core.VarEnv                    (VarEnv)+import Clash.Driver.Types+  (BindingMap, ClashEnv(..), ClashOpts(..))+import Clash.Netlist.BlackBox.Types         (BlackBoxTemplate)+import Clash.Primitives.Types               (CompiledPrimMap)+import Clash.Signal.Internal+  (ResetPolarity, ActiveEdge, ResetKind, InitBehavior)+import Clash.Unique                         (Unique)++import Clash.Annotations.BitRepresentation.Internal+  (CustomReprs, DataRepr', ConstrRepr')++import {-# SOURCE #-} qualified Clash.Netlist.Id as Id (toText)++-- | Structure describing a top entity: it's id and its port annotations.+data TopEntityT = TopEntityT+  { topId :: Id+  -- ^ Id of top entity+  , topAnnotation :: Maybe TopEntity+  -- ^ (Maybe) a topentity annotation+  , topIsTestBench :: Bool+  -- ^ Whether this entity is a test bench+  } deriving (Generic, Show, Eq)++-- | Same as "TopEntity", but with all port names that end up in HDL specified+data ExpandedTopEntity a = ExpandedTopEntity+  { et_inputs :: [Maybe (ExpandedPortName a)]+  -- ^ Inputs with fully expanded port names. /Nothing/ if port is void.+  , et_output :: Maybe (ExpandedPortName a)+  -- ^ Output with fully expanded port names. /Nothing/ if port is void or+  -- BiDirectionalOut.+  } deriving (Show, Functor, Foldable, Traversable)++-- | See "ExpandedTopEntity"+data ExpandedPortName a+  -- | Same as "PortName", but fully expanded+  = ExpandedPortName HWType a++  -- | Same as "PortProduct", but fully expanded+  | ExpandedPortProduct+      Text+      -- ^ Name hint. Can be used to create intermediate signal names.+      HWType+      -- ^ Type of product+      [ExpandedPortName a]+      -- ^ Product fields+  deriving (Show, Functor, Foldable, Traversable)++-- | Monad that caches generated components (StateT) and remembers hidden inputs+-- of components that are being generated (WriterT)+newtype NetlistMonad a =+  NetlistMonad { runNetlist :: Strict.StateT NetlistState (ReaderT NetlistEnv IO) a }+  deriving newtype (Functor, Monad, Applicative, MonadReader NetlistEnv,+                    Strict.MonadState NetlistState, Strict.MonadIO, MonadFail)++type HWMap = Map Type (Either String FilteredHWType)++-- | See 'is_freshCache'+type FreshCache = HashMap Text (IntMap Word)++type IdentifierText = Text++-- | Whether to preserve casing in ids or converted everything to+--  lowercase. Influenced by '-fclash-lower-case-basic-identifiers'+data PreserveCase+  = PreserveCase+  | ToLower+  deriving (Show, Generic, NFData, Eq, Binary, Hashable)++-- See: http://vhdl.renerta.com/mobile/source/vhd00037.htm+--      http://www.verilog.renerta.com/source/vrg00018.htm+data IdentifierType+  = Basic+  -- ^ A basic identifier: does not have to be escaped in order to be a valid+  -- identifier in HDL.+  | Extended+  -- ^ An extended identifier: has to be escaped, wrapped, or otherwise+  -- postprocessed before writhing it to HDL.+  deriving (Show, Generic, NFData, Eq)++-- | A collection of unique identifiers. Allows for fast fresh identifier+-- generation.+--+-- __NB__: use the functions in Clash.Netlist.Id. Don't use the constructor directly.+data IdentifierSet+  = IdentifierSet {+      is_allowEscaped :: !Bool+      -- ^ Allow escaped ids? If set to False, "make" will always behave like+      -- "makeBasic".+    , is_lowerCaseBasicIds :: !PreserveCase+      -- ^ Force all generated basic identifiers to lowercase.+    , is_hdl :: !HDL+      -- ^ HDL to generate fresh identifiers for+    , is_freshCache :: !FreshCache+      -- ^ Maps an 'i_baseNameCaseFold' to a map mapping the number of+      -- extensions (in 'i_extensionsRev') to the maximum word at that+      -- basename/level. For example, if a set would contain the identifiers:+      --+      --   [foo, foo_1, foo_2, bar_5, bar_7_8]+      --+      -- the map would look like:+      --+      --   [(foo, [(0, 0), (1, 2)]), (bar, [(1, 5), (2, 8)])]+      --+      -- This mapping makes sure we can quickly generate fresh identifiers. For+      -- example, generating a new id for "foo_1" would be a matter of looking+      -- up the base name in this map, concluding that the maximum identifier+      -- with this basename and this number of extensions is "foo_2",+      -- subsequently generating "foo_3".+      --+      -- Note that an identifier with no extensions is also stored in this map+      -- for practical purposes, but the maximum ext is invalid.+    , is_store :: !(HashSet Identifier)+      -- ^ Identifier store+    } deriving (Generic, NFData, Show)++-- | HDL identifier. Consists of a base name and a number of extensions. An+-- identifier with a base name of "foo" and a list of extensions [1, 2] will be+-- rendered as "foo_1_2".+--+-- Note: The Eq instance of "Identifier" is case insensitive! E.g., two+-- identifiers with base names 'fooBar' and 'FoObAR' are considered the same.+-- However, identifiers are stored case preserving. This means Clash won't+-- generate two identifiers with differing case, but it will try to keep+-- capitalization.+--+-- The goal of this data structure is to greatly simplify how Clash deals with+-- identifiers internally. Any Identifier should be trivially printable to any+-- HDL.+--+-- __NB__: use the functions in "Clash.Netlist.Id". Don't use these constructors+-- directly.+data Identifier+  -- | Unparsed identifier. Used for things such as port names, which should+  -- appear in the HDL exactly as the user specified.+  = RawIdentifier+      !Text+      -- ^ An identifier exactly as given by the user+      (Maybe Identifier)+      -- ^ Parsed version of raw identifier. Will not be populated if this+      -- identifier was created with an unsafe function.+      !CallStack+      -- ^ Stores where this identifier was generated. Tracking is only enabled+      -- is 'debugIsOn', otherwise this field will be populated by an empty+      -- callstack.++  -- | Parsed and sanitized identifier. See various fields for more information+  -- on its invariants.+  | UniqueIdentifier {+      i_baseName :: !Text+    -- ^ Base name of identifier. 'make' makes sure this field:+    --+    --    * does not end in '_num' where 'num' is a digit.+    --    * is solely made up of printable ASCII characters+    --    * has no leading or trailing whitespace+    --+    , i_baseNameCaseFold :: !Text+    -- ^ Same as 'i_baseName', but can be used for equality testing that doesn't+    -- depend on capitalization.+    , i_extensionsRev :: [Word]+    -- ^ Extensions applied to base identifier. E.g., an identifier with a base+    -- name of 'foo' and an extension of [6, 5] would render as 'foo_5_6'. Note+    -- that extensions are stored in reverse order for easier manipulation.+    , i_idType :: !IdentifierType+    -- ^ See 'IdentifierType'.+    , i_hdl :: !HDL+    -- ^ HDL this identifier is generated for.+    , i_provenance :: !CallStack+    -- ^ Stores where this identifier was generated. Tracking is only enabled+    -- is 'debugIsOn', otherwise this field will be populated by an empty+    -- callstack.+    } deriving (Show, Generic, NFData)++identifierKey# :: Identifier -> ((Text, Bool), [Word])+identifierKey# (RawIdentifier t _id _) = ((t, True), [])+identifierKey# id_ = ((i_baseNameCaseFold id_, False), i_extensionsRev id_)++instance Hashable Identifier where+  hashWithSalt salt = hashWithSalt salt . hash+  hash = uncurry hash# . identifierKey#+   where+    hash# a extensions =+      -- 'hash' has an identity around zero, e.g. `hash (0, 2) == 2`. Because a+      -- lot of zeros can be expected, extensions are fuzzed in order to keep+      -- efficient `HashMap`s.+      let fuzz fuzzFactor ext = fuzzFactor * fuzzFactor * ext in+      hash (a, List.foldl' fuzz 2 extensions)++instance Eq Identifier where+  i1 == i2 = identifierKey# i1 == identifierKey# i2+  i1 /= i2 = identifierKey# i1 /= identifierKey# i2++instance Ord Identifier where+  compare = compare `on` identifierKey#++-- | Environment of the NetlistMonad+data NetlistEnv+  = NetlistEnv+  { _clashEnv :: ClashEnv+  , _prefixName  :: Text+  -- ^ Prefix for instance/register names+  , _suffixName :: Text+  -- ^ Postfix for instance/register names+  , _setName :: Maybe Text+  -- ^ (Maybe) user given instance/register name+  , _localAttrs :: [Attr Text]+  -- ^ Synthesis attributes brough into scope by+  -- 'Clash.Annotations.SynthesisAttributes.annotateReg'+  , _peEvaluator :: Evaluator+  -- ^ Evaluator to evaluate a term to Normal Form+  }++data ComponentMeta = ComponentMeta+  { cmWereVoids :: [Bool]+  , cmLoc :: SrcSpan+  , cmScope :: IdentifierSet+  , cmUsage :: UsageMap+  } deriving (Generic, Show, NFData)++type ComponentMap = OMap Unique (ComponentMeta, Component)++-- | State of the NetlistMonad+data NetlistState+  = NetlistState+  { _bindings       :: BindingMap+  -- ^ Global binders+  , _components     :: ComponentMap+  -- ^ Cached components. Is an insertion ordered map to preserve a topologically+  -- sorted component list for the manifest file.+  , _typeTranslator :: CustomReprs -> TyConMap -> Type+                    -> Strict.State HWMap (Maybe (Either String FilteredHWType))+  -- ^ Hardcoded Type -> HWType translator+  , _curCompNm      :: !(Identifier,SrcSpan)+  , _seenIds        :: IdentifierSet+  -- ^ All names currently in scope.+  , _seenComps      :: IdentifierSet+  -- ^ Components (to be) generated during this netlist run. This is always a+  -- subset of 'seenIds'. Reason d'etre: we currently generate components in a+  -- top down manner. E.g. given:+  --+  --   - A+  --   -- B+  --   -- C+  --+  -- we would generate component 'A' first. Before trying to generate 'B' and+  -- 'C'. 'A' might introduce a number of signal declarations. The names of these+  -- signals can't clash with the name of component 'B', hence we need to pick a+  -- name for B unique w.r.t. all these signal names. If we would postpone+  -- generating a unqiue name for 'B' til _after_ generating all the signal+  -- names, the signal names would get all the "nice" names. E.g., a signal+  -- would be called "foo", thereby forcing the component 'B' to be called+  -- "foo_1". Ideally, we'd use the "nice" names for components, and the "ugly"+  -- names for signals. To achieve this, we generate all the component names+  -- up front and subsequently store them in '_seenComps'.+  , _seenPrimitives :: Set.Set Text+  -- ^ Keeps track of invocations of ´mkPrimitive´. It is currently used to+  -- filter duplicate warning invocations for dubious blackbox instantiations,+  -- see GitHub pull request #286.+  , _componentNames :: VarEnv Identifier+  -- ^ Names of components (to be) generated during this netlist run. Includes+  -- top entity names.+  , _topEntityAnns  :: VarEnv TopEntityT+  , _hdlDir         :: FilePath+  , _curBBlvl       :: Int+  -- ^ The current scoping level assigned to black box contexts+  , _isTestBench    :: Bool+  -- ^ Whether we're compiling a testbench (suppresses some warnings)+  , _backEndITE :: Bool+  -- ^ Whether the backend supports ifThenElse expressions+  , _backend :: SomeBackend+  -- ^ The current HDL backend+  , _htyCache :: HWMap+  , _usages :: UsageMap+  -- ^ The current way signals are assigned in netlist. This is used to+  -- determine how signals are rendered in HDL (i.e. wire/reg in Verilog, or+  -- signal/variable in VHDL).+  }++data ComponentPrefix+  = ComponentPrefix+  { componentPrefixTop :: Maybe Text+    -- ^ Prefix for top-level components+  , componentPrefixOther :: Maybe Text+    -- ^ Prefix for all other components+  } deriving Show++-- | Existentially quantified backend+data SomeBackend where+  SomeBackend :: Backend backend => backend -> SomeBackend++onSomeBackend :: (forall b. Backend b => b -> a) -> SomeBackend -> a+onSomeBackend f (SomeBackend b) = f b++fromSomeBackend :: (forall b. Backend b => b -> a) -> Lens.Getter SomeBackend a+fromSomeBackend f = Lens.to (onSomeBackend f)++type Comment = Text+type Directive = Text++data CommentOrDirective+  = Comment Comment+  | Directive Directive+  deriving Show++-- | Component: base unit of a Netlist+data Component+  = Component+  { componentName :: !Identifier -- ^ Name of the component+  , inputs        :: [(Identifier,HWType)] -- ^ Input ports+  , outputs       :: [(Usage,(Identifier,HWType),Maybe Expr)] -- ^ Output ports+  , declarations  :: [Declaration] -- ^ Internal declarations+  }+  deriving (Show, Generic, NFData)++-- | Check if an input port is really an inout port.+--+isBiDirectional :: (Identifier, HWType) -> Bool+isBiDirectional = go . snd+  where+    go BiDirectional{} = True+    go (Annotated _ hwty) = go hwty+    go _ = False++-- | Find the name and domain name of each clock argument of a component.+--+-- This will not consider @ClockN@ to be a clock argument, which means only the+-- positive phase of a differential pair will be added to @sdcClock@.+findClocks :: Component -> [(Text, Text)]+findClocks (Component _ is _ _) =+  mapMaybe isClock is+ where+  isClock (i, Clock d) = Just (Id.toText i, d)+  isClock (i, Annotated _ t) = isClock (i,t)+  isClock _ = Nothing++-- | Size indication of a type (e.g. bit-size or number of elements)+type Size = Int++type IsVoid = Bool++-- | Tree structure indicating which constructor fields were filtered from+-- a type due to them being void. We need this information to generate stable+-- and/or user-defined port mappings.+data FilteredHWType =+  FilteredHWType HWType [[(IsVoid, FilteredHWType)]]+    deriving (Eq, Show)++type DomainName = Text++-- | Representable hardware types+data HWType+  = Void (Maybe HWType)+  -- ^ Empty type. @Just Size@ for "empty" Vectors so we can still have+  -- primitives that can traverse e.g. Vectors of unit and know the length of+  -- that vector.+  | String+  -- ^ String type+  | Integer+  -- ^ Integer type (for parameters only)+  | Bool+  -- ^ Boolean type+  | Bit+  -- ^ Bit type+  | BitVector !Size+  -- ^ BitVector of a specified size+  | Index !Integer+  -- ^ Unsigned integer with specified (exclusive) upper bounder+  | Signed !Size+  -- ^ Signed integer of a specified size+  | Unsigned !Size+  -- ^ Unsigned integer of a specified size+  | Vector !Size !HWType+  -- ^ Vector type+  | MemBlob !Size !Size+  -- ^ MemBlob type+  | RTree !Size !HWType+  -- ^ RTree type+  | Sum !Text [Text]+  -- ^ Sum type: Name and Constructor names+  | Product !Text (Maybe [Text]) [HWType]+  -- ^ Product type: Name, field names, and field types. Field names will be+  -- populated when using records.+  | SP !Text [(Text, [HWType])]+  -- ^ Sum-of-Product type: Name and Constructor names + field types+  | Clock !DomainName+  -- ^ Clock type corresponding to domain /DomainName/+  | ClockN !DomainName+  -- ^ ClockN type corresponding to domain /DomainName/+  | Reset !DomainName+  -- ^ Reset type corresponding to domain /DomainName/+  | Enable !DomainName+  -- ^ Enable type corresponding to domain /DomainName/+  | BiDirectional !PortDirection !HWType+  -- ^ Tagging type indicating a bidirectional (inout) port+  | CustomSP !Text !DataRepr' !Size [(ConstrRepr', Text, [HWType])]+  -- ^ Same as Sum-Of-Product, but with a user specified bit representation. For+  -- more info, see: Clash.Annotations.BitRepresentations.+  | CustomSum !Text !DataRepr' !Size [(ConstrRepr', Text)]+  -- ^ Same as Sum, but with a user specified bit representation. For more info,+  -- see: Clash.Annotations.BitRepresentations.+  | CustomProduct !Text !DataRepr' !Size (Maybe [Text]) [(FieldAnn, HWType)]+  -- ^ Same as Product, but with a user specified bit representation. For more+  -- info, see: Clash.Annotations.BitRepresentations.+  | Annotated [Attr Text] !HWType+  -- ^ Annotated with HDL attributes+  | KnownDomain !DomainName !Integer !ActiveEdge !ResetKind !InitBehavior !ResetPolarity+  -- ^ Domain name, period, active edge, reset kind, initial value behavior+  | FileType+  -- ^ File type for simulation-level I/O+  deriving (Eq, Ord, Show, Generic, NFData, Hashable)++-- | Smart constructor for 'Annotated'. Wraps the given type in an 'Annotated'+-- if the attribute list is non-empty. If it is empty, it will return the given+-- 'HWType' unchanged.+annotated :: [Attr Text] -> HWType -> HWType+annotated [] t = t+annotated attrs t = Annotated attrs t++hwTypeDomain :: HWType -> Maybe DomainName+hwTypeDomain = \case+  Clock dom -> Just dom+  ClockN dom -> Just dom+  Reset dom -> Just dom+  Enable dom -> Just dom+  KnownDomain dom _ _ _ _ _ -> Just dom+  _ -> Nothing++-- | Extract hardware attributes from Annotated. Returns an empty list if+-- non-Annotated given or if Annotated has an empty list of attributes.+hwTypeAttrs :: HWType -> [Attr Text]+hwTypeAttrs (Annotated attrs _type) = attrs+hwTypeAttrs _                       = []++-- | Specifies how to wire up a component instance+data PortMap+  = IndexedPortMap [(PortDirection, HWType, Expr)]+  -- ^ Port map based on port positions (port direction, type, assignment)+  --+  -- HDL Example:+  --+  --     bytemaster bytemaster_ds+  --       ( clk_1+  --       , rst_1+  --       , bitCtrl_0 );+  --+  | NamedPortMap [(Expr, PortDirection, HWType, Expr)]+  -- ^ Port map based on port names (port name, port direction, type, assignment)+  --+  -- HDL Example:+  --+  --     bytemaster bytemaster_ds+  --       ( .clk (clk_1)+  --       , .rst (rst_1)+  --       , .bitCtrl (bitCtrl_0) );+  --+  deriving (Show)++-- | Internals of a Component+data Declaration+  -- | Signal assignment+  = Assignment+      !Identifier -- ^ Signal to assign+      !Usage      -- ^ How the signal is assigned+      !Expr       -- ^ Assigned expression++  -- | Conditional signal assignment:+  | CondAssignment+      !Identifier            -- ^ Signal to assign+      !HWType                -- ^ Type of the result/alternatives+      !Expr                  -- ^ Scrutinized expression+      !HWType                -- ^ Type of the scrutinee+      [(Maybe Literal,Expr)] -- ^ List of: (Maybe expression scrutinized expression is compared with,RHS of alternative)++  -- | Instantiation of another component:+  | InstDecl+      EntityOrComponent                  -- ^ Whether it's an entity or a component+      (Maybe Text)                       -- ^ Library instance is defined in+      [Attr Text]                        -- ^ Attributes to add to the generated code+      !Identifier                        -- ^ The component's (or entity's) name+      !Identifier                        -- ^ Instance label+      [(Expr,HWType,Expr)]               -- ^ List of parameters for this component (param name, param type, param value)+      PortMap++  -- | Instantiation of blackbox declaration+  | BlackBoxD+      !Text                    -- ^ Primitive name+      [BlackBoxTemplate]       -- ^ VHDL only: add @library@ declarations+      [BlackBoxTemplate]       -- ^ VHDL only: add @use@ declarations+      [((Text,Text),BlackBox)] -- ^ Intel Quartus only: create a @.qsys@ file from given template+      !BlackBox                -- ^ Template tokens+      BlackBoxContext          -- ^ Context in which tokens should be rendered++  -- | @component@ declaration (VHDL).+  --+  -- See [this tutorial](https://www.ics.uci.edu/~jmoorkan/vhdlref/compdec.html);+  -- refer to §4.5 of IEEE 1076-1993+  | CompDecl+      !Text+      [(Text, PortDirection, HWType)]++  -- | Signal declaration+  | NetDecl'+      (Maybe Comment)                -- ^ Note; will be inserted as a comment in target hdl+      !Identifier                    -- ^ Name of signal+      HWType                         -- ^ Type of signal+      (Maybe Expr)                   -- ^ Initial value+      -- ^ Signal declaration++  -- | HDL tick corresponding to a Core tick+  | TickDecl CommentOrDirective++  -- | Sequential statement+  | Seq [Seq]++  -- | Compilation conditional on some preprocessor symbol, note that+  -- declarations here are ignored for VHDL. See here for a discussion+  -- https://github.com/clash-lang/clash-compiler/pull/1798#discussion_r648571862+  | ConditionalDecl+      !Text -- ^ condition text, for example @FORMAL@+      [Declaration]+  deriving Show++-- | Sequential statements+data Seq+  -- | Clocked sequential statements+  = AlwaysClocked+      ActiveEdge -- ^ Edge of the clock the statement should be executed+      Expr       -- ^ Clock expression+      [Seq]      -- ^ Statements to be executed on the active clock edge+  -- | Statements running at simulator start+  | Initial+      [Seq] -- ^ Statements to run at simulator start+  -- | Statements to run always+  | AlwaysComb+      [Seq] -- ^ Statements to run always+  -- | Declaration in sequential form+  | SeqDecl+      Declaration -- ^ The declaration+  -- | Branching statement+  | Branch+      !Expr                    -- ^ Scrutinized expresson+      !HWType                  -- ^ Type of the scrutinized expression+      [(Maybe Literal,[Seq])]  -- ^ List of: (Maybe match, RHS of Alternative)+  deriving Show++-- | Procedural assignment in HDL can be blocking or non-blocking. This+-- determines when the assignment takes place in simulation. The name refers to+-- whether evaluation of the remaining statements in a process is blocked+-- until the assignment is performed or not.+--+-- See Also:+--+-- IEEE 1364-2001, sections 9.2.1 and 9.2.2+-- IEEE 1076-1993, sections 8.4 and 8.5+--+data Blocking+  = NonBlocking+  -- ^ A non-blocking assignment means the new value is not observed until the+  -- next time step in simulation. Using the signal later in the process will+  -- continue to return the old value.+  | Blocking+  -- ^ A blocking assignment means the new value is observed immediately. Using+  -- the signal later in the process will return the new value.+  deriving (Binary, Eq, Generic, Hashable, NFData, Show)++-- NOTE [`Semigroup` instances for `Blocking` and `Usage`]+instance Semigroup Blocking where+  NonBlocking <> y = y+  Blocking    <> _ = Blocking++-- | The usage of a signal refers to how the signal is written to in netlist.+-- This is used to determine if the signal should be a @wire@ or @reg@ in+-- (System)Verilog, or a @signal@ or @variable@ in VHDL.+--+data Usage+  = Cont+  -- ^ Continuous assignment, which occurs in a concurrent context.+  | Proc Blocking+  -- ^ Procedural assignment, which occurs in a sequential context.+  deriving (Binary, Eq, Generic, Hashable, NFData, Show)++-- NOTE [`Semigroup` instances for `Blocking` and `Usage`]+instance Semigroup Usage where+  Cont    <> y      = y+  Proc x  <> Proc y = Proc (x <> y)+  Proc x  <> _      = Proc x++{-+NOTE [`Semigroup` instances for `Blocking` and `Usage`]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Usages (and Blocking) are combined by taking the most restrictive usage, where+most restrictive means "has the most influence over the choice of declaration".+Clash produces three types of assignment:++  * continuous+  * prodecural non-blocking+  * prodecural blocking++Both VHDl and (System)Verilog have a type of declaration which only admits one+type of assignment. This is the most restrictive for that HDL. However, since+that would involve knowing the HDL type in these Semigroup instances, the+most restrictive here is based on ordering where the most restrictive for each+HDL is an extreme value (max for VHDL, min for Verilog). i.e.++          |-------------------------------------|+          | Continuous | NonBlocking | Blocking |+|---------|-------------------------------------|+|    VHDL |         signal           | variable |+|---------|-------------------------------------|+| Verilog |   wire     |          reg           |+|---------|-------------------------------------|+-}++instance FromJSON Usage where+  parseJSON = Aeson.withText "Usage" $ \case+    "Continuous"  -> pure Cont+    "NonBlocking" -> pure (Proc NonBlocking)+    "Blocking"    -> pure (Proc Blocking)+    str           -> fail $ mconcat+      [ "Could not parse usage: "+      , show str+      , "\nRecognized values are 'Continuous', 'NonBlocking' and 'Blocking'"+      ]++-- See NOTE [`Text` key for `UsageMap`]+type UsageMap = Map Text Usage++lookupUsage :: Identifier -> UsageMap -> Maybe Usage+lookupUsage i = Map.lookup (Id.toText i)++{-+NOTE [`Text` key for `UsageMap`]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We would like to use netlist identifiers as the key for the usage map, since+conceptually it is a map from an identifier to how it is used in assignments.+However, in practice we commonly end up with the same textual identifier+appearing in different ways in the netlist.++The most obvious example of this are identifiers that appear as both+`UniqueIdentifier` and `RawIdentifier`. If we track the usage on the raw+identifier, but the `NetDecl` uses the `UniqueIdentifier` then the wrong+declaration may be used in the rendered HDL.++Attempting to fix this by not generating the same textual identifier in+different ways proved difficult, so for now the key type is `Text` instead.+-}++data EntityOrComponent = Entity | Comp | Empty+  deriving Show++pattern NetDecl+  :: Maybe Comment+  -- ^ Note; will be inserted as a comment in target hdl+  -> Identifier+  -- ^ Name of signal+  -> HWType+  -- ^ Type of signal+  -> Declaration+pattern NetDecl note d ty <- NetDecl' note d ty _+  where+    NetDecl note d ty = NetDecl' note d ty Nothing++data PortDirection = In | Out+  deriving (Eq,Ord,Show,Generic,NFData,Hashable)++instance NFData Declaration where+  rnf a = a `seq` ()++-- | Expression Modifier+data Modifier+  = Indexed (HWType, Int, Int)+  -- ^ Index the expression: (Type of expression, DataCon tag, Field Tag). Note+  -- that the type of the expression is the type we are slicing from, not the type+  -- returned by the index operation.+  | DC (HWType, Int)+  -- ^ See expression in a DataCon context: (Type of the expression, DataCon tag)+  | VecAppend+  -- ^ See the expression in the context of a Vector append operation+  | RTreeAppend+  -- ^ See the expression in the context of a Tree append operation+  | Sliced (HWType, Int, Int)+  -- ^ Slice the identifier of the given type from start to end+  | Nested Modifier Modifier+  deriving Show++-- | Expression used in RHS of a declaration+data Expr+  = Literal    !(Maybe (HWType,Size)) !Literal -- ^ Literal expression+  | DataCon    !HWType       !Modifier  [Expr] -- ^ DataCon application+  | Identifier !Identifier   !(Maybe Modifier) -- ^ Signal reference+  | DataTag    !HWType       !(Either Identifier Identifier) -- ^ @Left e@: tagToEnum\#, @Right e@: dataToTag\#++  -- | Instantiation of a BlackBox expression+  | BlackBoxE+      !Text                    -- ^ Primitive name+      [BlackBoxTemplate]       -- ^ VHDL only: add @library@ declarations+      [BlackBoxTemplate]       -- ^ VHDL only: add @use@ declarations:+      [((Text,Text),BlackBox)] -- ^ Intel/Quartus only: create a @.qsys@ file from given template.+      !BlackBox                -- ^ Template tokens+      !BlackBoxContext         -- ^ Context in which tokens should be rendered+      !Bool                    -- ^ Wrap in parentheses?++  -- | Convert some type to a BitVector.+  | ToBv+      (Maybe Identifier) -- ^ Type prefix+      HWType             -- ^ Type to convert _from_+      Expr               -- ^ Expression to convert to BitVector++  -- | Convert BitVector to some type.+  | FromBv+      (Maybe Identifier) -- ^ Type prefix+      HWType             -- ^ Type to convert _to_+      Expr               -- ^ BitVector to convert++  | IfThenElse Expr Expr Expr+  -- | Do nothing+  | Noop+  deriving Show++instance NFData Expr where+  rnf x = x `seq` ()++isConstExpr :: Expr -> Bool+isConstExpr = \case+  Literal{} -> True+  DataCon _ _ es -> all isConstExpr es+  Identifier{} -> False+  DataTag{} -> False+  BlackBoxE nm _ _ _ _ ctx _+    -- When using SimIO, `reg` creates (in Haskell) the mutable reference to+    -- some value. The blackbox for this however is simply `~ARG[0]`, so if+    -- the argument given is constant, the rendered HDL will also be constant.+    | nm == "Clash.Explicit.SimIO.reg" ->+        all (\(e, _, _) -> isConstExpr e) (bbInputs ctx)+    | otherwise -> False+  ToBv _ _ e -> isConstExpr e+  FromBv _ _ e -> isConstExpr e+  IfThenElse{} -> False+  Noop -> False++-- | Literals used in an expression+data Literal+  = NumLit    !Integer          -- ^ Number literal+  | BitLit    !Bit              -- ^ Bit literal+  | BitVecLit !Integer !Integer -- ^ BitVector literal+  | BoolLit   !Bool             -- ^ Boolean literal+  | VecLit    [Literal]         -- ^ Vector literal+  | StringLit !String           -- ^ String literal+  deriving (Eq,Show)++-- | Bit literal+data Bit+  = H -- ^ High+  | L -- ^ Low+  | U -- ^ Undefined+  | Z -- ^ High-impedance+  deriving (Eq,Show,Lift)+#if __GLASGOW_HASKELL__ <= 910+  deriving Typeable+#endif+++toBit :: Integer -- ^ mask+      -> Integer -- ^ value+      -> Bit+toBit m i = if testBit m 0+            then U+            else if testBit i 0 then H else L++-- | Context used to fill in the holes of a BlackBox template+data BlackBoxContext+  = Context+  { bbName :: Text+  -- ^ Blackbox function name (for error reporting)+  , bbResults :: [(Expr,HWType)]+  -- ^ Result names and types. Will typically be a list with a single item.+  -- Multiple result targets will be used for "multi result primitives". See+  -- 'Clash.Normalize.Transformations.setupMultiResultPrim'.+  , bbInputs :: [(Expr,HWType,Bool)]+  -- ^ Argument names, types, and whether it is a literal+  , bbFunctions :: IntMap [(Either BlackBox (Identifier,[Declaration])+                          ,Usage+                          ,[BlackBoxTemplate]+                          ,[BlackBoxTemplate]+                          ,[((Text,Text),BlackBox)]+                          ,BlackBoxContext)]+  -- ^ Function arguments (subset of inputs):+  --+  -- * ( Blackbox Template+  --   , Whether the result should be /reg/ or a /wire/ (Verilog only)+  --   , Partial Blackbox Context+  --   )+  , bbQsysIncName :: [IdentifierText]+  , bbLevel :: Int+  -- ^ The scoping level this context is associated with, ensures that+  -- @~ARGN[k][n]@ holes are only filled with values from this context if @k@+  -- is equal to the scoping level of this context.+  , bbCompName :: Identifier+  -- ^ The component the BlackBox is instantiated in+  , bbCtxName :: Maybe IdentifierText+  -- ^ The "context name", name set by `Clash.Magic.setName`, defaults to the+  -- name of the closest binder+  }+  deriving Show++type BBName = String+type BBHash = Int++data BlackBox+  = BBTemplate BlackBoxTemplate+  | BBFunction BBName BBHash TemplateFunction+  deriving (Generic, NFData, Binary)++data TemplateFunction where+  TemplateFunction+    :: [Int]+    -- ^ Used arguments+    -> (BlackBoxContext -> Bool)+    -- ^ Validation function. Should return 'False' if function can't render+    -- given a certain context.+    -> (forall s . Backend s => BlackBoxContext -> Lazy.State s Doc)+    -- ^ Render function+    -> TemplateFunction++instance Show BlackBox where+  showsPrec d (BBTemplate t) =+    showParen (d > 10) $ ("BBTemplate " ++) . showsPrec 11 t+  showsPrec _ (BBFunction nm hsh _) =+    ("<TemplateFunction(nm=" ++) . shows nm . (", hash=" ++) . shows hsh .+    (")>" ++)++instance NFData TemplateFunction where+  rnf (TemplateFunction is f _) = rnf is `seq` f `seq` ()++-- | __NB__: serialisation doesn't preserve the embedded function+instance Binary TemplateFunction where+  put (TemplateFunction is _ _ ) = put is+  get = (\is -> TemplateFunction is err err) <$> get+    where err = const $ error "TemplateFunction functions can't be preserved by serialisation"++-- | Netlist-level identifier+data NetlistId+  = NetlistId Identifier Type+  -- ^ Identifier generated in the NetlistMonad, always derived from another+  -- 'NetlistId'+  | CoreId Id+  -- ^ An original Core identifier+  | MultiId [Id]+  -- ^ A split identifier (into several sub-identifiers), needed to assign+  -- expressions of types that have to be split apart (e.g. tuples of Files)+  deriving (Eq, Show)++-- | Eliminator for 'NetlistId', fails on 'MultiId'+netlistId1+  :: HasCallStack+  => (Identifier -> r)+  -- ^ Eliminator for Identifiers generated in the NetlistMonad+  -> (Id -> r)+  -- ^ Eliminator for original Core Identifiers+  -> NetlistId+  -> r+netlistId1 f g = \case+  NetlistId i _ -> f i+  CoreId i -> g i+  m -> error ("netlistId1 MultiId: " ++ show m)++-- | Return the type(s) of a 'NetListId', returns multiple types when given a+-- 'MultiId'+netlistTypes+  :: NetlistId+  -> [Type]+netlistTypes = \case+  NetlistId _ t -> [t]+  CoreId i -> [coreTypeOf i]+  MultiId is -> map coreTypeOf is++-- | Return the type of a 'NetlistId', fails on 'MultiId'+netlistTypes1+  :: HasCallStack+  => NetlistId+  -> Type+netlistTypes1 = \case+  NetlistId _ t -> t+  CoreId i -> coreTypeOf i+  m -> error ("netlistTypes1 MultiId: " ++ show m)++-- | Type of declaration, concurrent or sequential+data DeclarationType+  = Concurrent+  | Sequential++-- | Default usage for a type of declaration (concurrent or sequential)+declTypeUsage :: DeclarationType -> Usage+declTypeUsage Concurrent = Cont+declTypeUsage Sequential = Proc Blocking++emptyBBContext :: Text -> BlackBoxContext+emptyBBContext name+  = Context+  { bbName        = name+  , bbResults     = []+  , bbInputs      = []+  , bbFunctions   = empty+  , bbQsysIncName = []+  , bbLevel       = (-1)+  , bbCompName    = UniqueIdentifier+                      "__NOCOMPNAME__" "__NOCOMPNAME__" []+                      Basic VHDL emptyCallStack+  , bbCtxName     = Nothing+  }++Lens.makeLenses ''NetlistEnv+Lens.makeLenses ''NetlistState++intWidth :: Lens.Getter NetlistEnv Int+intWidth = clashEnv . Lens.to (opt_intWidth . envOpts)++customReprs :: Lens.Getter NetlistEnv CustomReprs+customReprs = clashEnv . Lens.to envCustomReprs++tcCache :: Lens.Getter NetlistEnv TyConMap+tcCache = clashEnv . Lens.to envTyConMap++primitives :: Lens.Getter NetlistEnv CompiledPrimMap+primitives = clashEnv . Lens.to envPrimitives++clashOpts :: Lens.Getter NetlistEnv ClashOpts+clashOpts = clashEnv . Lens.to envOpts++-- | Structures that hold an 'IdentifierSet'+class HasIdentifierSet s where+  identifierSet :: Lens' s IdentifierSet++instance HasIdentifierSet IdentifierSet where+  identifierSet = ($)++instance HasUsageMap NetlistState where+  usageMap = usages++instance HasIdentifierSet s => HasIdentifierSet (s, a) where+  identifierSet = Lens._1 . identifierSet++-- | An "IdentifierSetMonad" supports unique name generation for Clash Netlist+class Monad m => IdentifierSetMonad m where+  identifierSetM :: (IdentifierSet -> IdentifierSet) -> m IdentifierSet++instance IdentifierSetMonad NetlistMonad where+  identifierSetM f = do+    is0 <- Lens.use seenIds+    let is1 = f is0+    seenIds .= is1+    pure is1+  {-# INLINE identifierSetM #-}++instance HasIdentifierSet s => IdentifierSetMonad (Strict.State s) where+  identifierSetM f = do+    is0 <- Lens.use identifierSet+    identifierSet .= f is0+    Lens.use identifierSet+  {-# INLINE identifierSetM #-}++instance HasIdentifierSet s => IdentifierSetMonad (Lazy.State s) where+  identifierSetM f = do+    is0 <- Lens.use identifierSet+    identifierSet .= f is0+    Lens.use identifierSet+  {-# INLINE identifierSetM #-}++instance IdentifierSetMonad m => IdentifierSetMonad (Ap m) where+  identifierSetM = Ap . identifierSetM
+ src/Clash/Netlist/Types.hs-boot view
@@ -0,0 +1,68 @@+{-|+  Copyright   :  (C) 2018, Google Inc,+                     2022, QBayLogic B.V.+                     2022, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE RoleAnnotations #-}++module Clash.Netlist.Types where++import Control.DeepSeq (NFData)+import Control.Lens (Lens')+import Data.Aeson (FromJSON)+import Data.Binary (Binary)+import Data.Hashable (Hashable)+import Data.Map (Map)+import Data.Text (Text)++data IdentifierType+data Identifier+data IdentifierSet+data HWType+data Declaration+data Component+data Expr+data BlackBox+data TopEntityT++instance NFData BlackBox++class Monad m => IdentifierSetMonad m where+  identifierSetM :: (IdentifierSet -> IdentifierSet) -> m IdentifierSet++class HasIdentifierSet s where+  identifierSet :: Lens' s IdentifierSet++type role NetlistMonad nominal+data NetlistMonad a+data PreserveCase = PreserveCase | ToLower+instance Hashable PreserveCase+instance Eq PreserveCase+instance Show PreserveCase+instance NFData PreserveCase++data Blocking+  = NonBlocking+  | Blocking++instance Binary Blocking+instance Eq Blocking+instance Hashable Blocking+instance NFData Blocking+instance Show Blocking++data Usage+  = Cont+  | Proc Blocking++instance Binary Usage+instance Eq Usage+instance FromJSON Usage+instance Hashable Usage+instance NFData Usage+instance Show Usage++type UsageMap = Map Text Usage
+ src/Clash/Netlist/Util.hs view
@@ -0,0 +1,2189 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2017     , Myrtle Software Ltd+                    2017-2018, Google Inc.+                    2021-2026, QBayLogic B.V.+                    2022     , Google Inc.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Utilities for converting Core Type/Term to Netlist datatypes+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Netlist.Util where++import           Data.Coerce             (coerce)+import           Control.Exception       (throw)+import           Control.Lens            ((.=), (%=))+import qualified Control.Lens            as Lens+import           Control.Monad           (when, zipWithM)+import           Control.Monad.Extra     (concatMapM)+import           Control.Monad.Reader    (ask, local)+import qualified Control.Monad.State as State+import           Control.Monad.State.Strict+  (State, evalState, get, modify, runState)+import           Control.Monad.Trans.Except+  (ExceptT (..), runExcept, runExceptT, throwE)+import           Data.Bifunctor          (second)+import           Data.Char               (ord)+import           Data.Either             (partitionEithers)+import           Data.Foldable           (Foldable(toList))+import           Data.Functor            (($>))+import           Data.Hashable           (Hashable)+import           Data.HashMap.Strict     (HashMap)+import qualified Data.HashMap.Strict     as HashMap+import           Data.Primitive.ByteArray (ByteArray (..))+import           Control.Applicative     (Alternative((<|>)))+import           Data.List               (unzip4, partition)+import qualified Data.List               as List+import           Data.List.NonEmpty      (NonEmpty((:|)))+import qualified Data.Map                as Map+import           Data.Map                (Map)+import           Data.Maybe+  (catMaybes, fromMaybe, isNothing, mapMaybe, isJust, listToMaybe, maybeToList)+import           Text.Printf             (printf)+import           Data.Proxy+import           Data.Text               (Text)+import qualified Data.Text               as Text+import           Data.Text.Extra         (showt)+import           Data.Text.Lazy          (toStrict)+import           Data.Text.Prettyprint.Doc.Extra++import           GHC.Num.Integer                  (Integer (..))++import           GHC.Stack               (HasCallStack)+import           GHC.TypeLits (someNatVal)+import           GHC.TypeNats (SomeNat(..))++import           GHC.Utils.Monad         (zipWith3M)+import           GHC.Utils.Outputable    (ppr, showSDocUnsafe)++import           Clash.Annotations.TopEntity+  (TopEntity(..), PortName(..), defSyn)+import           Clash.Annotations.BitRepresentation.ClashLib+  (coreToType')+import           Clash.Annotations.BitRepresentation.Internal+  (CustomReprs, ConstrRepr'(..), DataRepr'(..), getDataRepr,+   uncheckedGetConstrRepr)+import           Clash.Annotations.SynthesisAttributes (Attr)+import           Clash.Annotations.Primitive (HDL(VHDL))+import           Clash.Backend           (HasUsageMap (..), HWKind(..), hdlHWTypeKind, hdlKind)+import           Clash.Core.DataCon      (DataCon (..))+import           Clash.Core.EqSolver     (typeEq)+import           Clash.Core.FreeVars     (typeFreeVars, typeFreeVars')+import           Clash.Core.HasFreeVars  (elemFreeVars, isClosed)+import           Clash.Core.HasType+import qualified Clash.Core.Literal      as C+import           Clash.Core.Name+  (Name (..), appendToName, mkUnsafeSystemName, nameOcc)+import           Clash.Core.PartialEval+import           Clash.Core.Pretty       (showPpr)+import           Clash.Core.Subst+  (Subst (..), extendIdSubst, extendIdSubstList, extendInScopeId,+   extendInScopeIdList, mkSubst, substTm)+import           Clash.Core.Term+  (primMultiResult, MultiPrimInfo(..), Alt, LetBinding, Pat (..), Term (..), TickInfo (..), NameMod (..),+   IsMultiPrim (..), collectArgsTicks, collectTicks, collectBndrs, PrimInfo(primName), mkTicks, stripTicks)+import           Clash.Core.TermInfo+import           Clash.Core.TermLiteral (termToDataError)+import           Clash.Core.TyCon+  (TyCon (FunTyCon), TyConName, TyConMap, tyConDataCons)+import           Clash.Core.Type+  (LitTy (..), Type (..), TyVar, TypeView (..), coreView, coreView1, normalizeType,+   splitTyConAppM, tyView)+import           Clash.Core.Util+  (substArgTys, tyLitShow)+import           Clash.Core.Var+  (Id, Var (..), mkLocalId, modifyVarName)+import           Clash.Core.VarEnv+  (InScopeSet, extendInScopeSetList, uniqAway, lookupVarEnv, emptyInScopeSet)+import qualified Clash.Data.UniqMap as UniqMap+import {-# SOURCE #-} Clash.Netlist.BlackBox+import {-# SOURCE #-} Clash.Netlist.BlackBox.Util+import           Clash.Netlist.BlackBox.Types+  (bbResultNames, BlackBoxMeta(BlackBoxMeta))+import qualified Clash.Netlist.Id as Id+import           Clash.Netlist.Types     as HW+import           Clash.Primitives.Types+import qualified Clash.Sized.Vector as V+import           Clash.Util+import qualified Clash.Util.Interpolate  as I+import Clash.Util.Supply++hmFindWithDefault :: (Eq k, Hashable k) => v -> k -> HashMap k v -> v+hmFindWithDefault = HashMap.findWithDefault++-- | Generate a simple port_name expression. See:+--+--   https://www.hdlworks.com/hdl_corner/vhdl_ref/VHDLContents/PortMap.htm+--+-- This function will simply make the left part of a single port map, e.g. "Rst"+-- in:+--+--  Rst => Reset+--+-- If you need more complex constructions, e.g.+--+--  Q(3 downto 1)+--+-- you can build an Expr manually.+instPort :: Text -> Expr+instPort pn = Identifier (Id.unsafeMake pn) Nothing++-- | Throw away information indicating which constructor fields were filtered+-- due to being void.+stripFiltered :: FilteredHWType -> HWType+stripFiltered (FilteredHWType hwty _filtered) = hwty++-- | Strip as many "Void" layers as possible. Might still return a Void if the+-- void doesn't contain a hwtype.+stripVoid :: HWType -> HWType+stripVoid (Void (Just e)) = stripVoid e+stripVoid e = e++flattenFiltered :: FilteredHWType -> [[Bool]]+flattenFiltered (FilteredHWType _hwty filtered) = map (map fst) filtered++isVoidMaybe :: Bool -> Maybe HWType -> Bool+isVoidMaybe dflt Nothing = dflt+isVoidMaybe _dflt (Just t) = isVoid t++-- | Determines if type is a zero-width construct ("void")+isVoid :: HWType -> Bool+isVoid Void {} = True+isVoid _       = False++-- | Same as @isVoid@, but on @FilteredHWType@ instead of @HWType@+isFilteredVoid :: FilteredHWType -> Bool+isFilteredVoid = isVoid . stripFiltered++squashLets :: Term -> Term+squashLets (Letrec xs (Letrec ys e)) =+  squashLets (Letrec (xs <> ys) e)+squashLets e = e++-- | Split a normalized term into: a list of arguments, a list of let-bindings,+-- and a variable reference that is the body of the let-binding. Returns a+-- String containing the error if the term was not in a normalized form.+splitNormalized+  :: TyConMap+  -> Term+  -> (Either String ([Id],[LetBinding],Id))+splitNormalized tcm expr = case collectBndrs expr of+  (args, collectTicks -> (squashLets -> Letrec xes e, ticks))+    | (tmArgs,[]) <- partitionEithers args -> case stripTicks e of+        Var v -> Right (tmArgs, fmap (second (`mkTicks` ticks)) xes,v)+        t     -> Left ($(curLoc) ++ "Not in normal form: res not simple var: " ++ showPpr t)+    | otherwise -> Left ($(curLoc) ++ "Not in normal form: tyArgs")+  _ ->+    Left ($(curLoc) ++ "Not in normal form: no Letrec:\n\n" ++ showPpr expr +++          "\n\nWhich has type:\n\n" ++ showPpr ty)+ where+  ty = inferCoreTypeOf tcm expr++-- | Converts a Core type to a HWType given a function that translates certain+-- builtin types. Errors if the Core type is not translatable.+unsafeCoreTypeToHWType+  :: SrcSpan+  -- ^ Approximate location in original source file+  -> String+  -> (CustomReprs -> TyConMap -> Type ->+      State HWMap (Maybe (Either String FilteredHWType)))+  -> CustomReprs+  -> TyConMap+  -> Type+  -> State HWMap FilteredHWType+unsafeCoreTypeToHWType sp loc builtInTranslation reprs m ty =+  either (\msg -> throw (ClashException sp (loc ++ msg) Nothing)) id <$>+    coreTypeToHWType builtInTranslation reprs m ty++-- | Same as @unsafeCoreTypeToHWTypeM@, but discards void filter information+unsafeCoreTypeToHWTypeM'+  :: String+  -> Type+  -> NetlistMonad HWType+unsafeCoreTypeToHWTypeM' loc ty = stripFiltered <$> unsafeCoreTypeToHWTypeM loc ty++-- | Converts a Core type to a HWType within the NetlistMonad; errors on failure+unsafeCoreTypeToHWTypeM+  :: String+  -> Type+  -> NetlistMonad FilteredHWType+unsafeCoreTypeToHWTypeM loc ty = do+  (_,cmpNm) <- Lens.use curCompNm+  tt        <- Lens.use typeTranslator+  reprs     <- Lens.view customReprs+  tcm       <- Lens.view tcCache+  htm0      <- Lens.use htyCache+  let (hty,htm1) = runState (unsafeCoreTypeToHWType cmpNm loc tt reprs tcm ty) htm0+  htyCache Lens..= htm1+  return hty++-- | Same as @coreTypeToHWTypeM@, but discards void filter information+coreTypeToHWTypeM'+  :: Type+  -- ^ Type to convert to HWType+  -> NetlistMonad (Maybe HWType)+coreTypeToHWTypeM' ty =+  fmap stripFiltered <$> coreTypeToHWTypeM ty+++-- | Converts a Core type to a HWType within the NetlistMonad; 'Nothing' on failure+coreTypeToHWTypeM+  :: Type+  -- ^ Type to convert to HWType+  -> NetlistMonad (Maybe FilteredHWType)+coreTypeToHWTypeM ty = do+  tt    <- Lens.use typeTranslator+  reprs <- Lens.view customReprs+  tcm   <- Lens.view tcCache+  htm0  <- Lens.use htyCache+  let (hty,htm1) = runState (coreTypeToHWType tt reprs tcm ty) htm0+  htyCache Lens..= htm1+  return (either (const Nothing) Just hty)++-- | Constructs error message for unexpected projections out of a type annotated+-- with a custom bit representation.+unexpectedProjectionErrorMsg+  :: DataRepr'+  -> Int+  -- ^ Constructor index+  -> Int+  -- ^ Field index+  -> String+unexpectedProjectionErrorMsg dataRepr cI fI =+     "Unexpected projection of zero-width type: " ++ show (drType dataRepr)+  ++ ". Tried to make a projection of field " ++ show fI ++ " of "+  ++ constrNm ++ ". Did you try to project a field marked as zero-width"+  ++ " by a custom bit representation annotation?"+ where+   constrNm = show (crName (drConstrs dataRepr !! cI))++-- | Helper function of 'maybeConvertToCustomRepr'+convertToCustomRepr+  :: HasCallStack+  => CustomReprs+  -> DataRepr'+  -> HWType+  -> HWType+convertToCustomRepr reprs dRepr@(DataRepr' name' size constrs) hwTy =+  if length constrs == nConstrs then+    if size <= 0 then+      Void (Just cs)+    else+      cs+  else+    error (unwords+      [ "Type", show name', "has", show nConstrs, "constructor(s), "+      , "but the custom bit representation only specified", show (length constrs)+      , "constructors."+      ])+ where+  cs = insertVoids $ case hwTy of+    Sum name conIds ->+      CustomSum name dRepr size (map packSum conIds)+    SP name conIdsAndFieldTys ->+      CustomSP name dRepr size (map packSP conIdsAndFieldTys)+    Product name maybeFieldNames fieldTys+      | [ConstrRepr' _cName _pos _mask _val fieldAnns] <- constrs ->+      CustomProduct name dRepr size maybeFieldNames (zip fieldAnns fieldTys)+    _ ->+      error+        ( "Found a custom bit representation annotation " ++ show dRepr ++ ", "+       ++ "but it was applied to an unsupported HWType: " ++ show hwTy ++ ".")++  nConstrs :: Int+  nConstrs = case hwTy of+    (Sum _name conIds) -> length conIds+    (SP _name conIdsAndFieldTys) -> length conIdsAndFieldTys+    (Product {}) -> 1+    _ -> error ("Unexpected HWType: " ++ show hwTy)++  packSP (name, tys) = (uncheckedGetConstrRepr name reprs, name, tys)+  packSum name = (uncheckedGetConstrRepr name reprs, name)++  -- Replace some "hwTy" with "Void (Just hwTy)" if the custom bit+  -- representation indicated that field is represented by zero bits. We can't+  -- simply remove them, as we'll later have to deal with an "overapplied"+  -- constructor. If we remove the arguments altogether, we wouldn't know which+  -- - on their own potentially non-void! - arguments to ignore.+  insertVoids :: HWType -> HWType+  insertVoids (CustomSP i d s constrs0) =+    CustomSP i d s (map go0 constrs0)+   where+    go0 (con@(ConstrRepr' _ _ _ _ fieldAnns), i0, hwTys) =+      (con, i0, zipWith go1 fieldAnns hwTys)+    go1 0 hwTy0 = Void (Just hwTy0)+    go1 _ hwTy0 = hwTy0+  insertVoids (CustomProduct i d s f fieldAnns) =+    CustomProduct i d s f (map go fieldAnns)+   where+    go (0, hwTy0) = (0, Void (Just hwTy0))+    go (n, hwTy0) = (n, hwTy0)+  insertVoids hwTy0 = hwTy0++-- | Given a map containing custom bit representation, a type, and the same+-- type represented as HWType, convert the HWType to a CustomSP/CustomSum if+-- it has a custom bit representation.+maybeConvertToCustomRepr+  :: CustomReprs+  -- ^ Map containing all custom representations index on its type+  -> Type+  -- ^ Custom reprs are index on type, so we need the clash core type to look+  -- it up.+  -> FilteredHWType+  -- ^ Type of previous argument represented as a HWType+  -> FilteredHWType+maybeConvertToCustomRepr reprs (coreToType' -> Right tyName) (FilteredHWType hwTy filtered)+  | Just dRepr <- getDataRepr tyName reprs =+    FilteredHWType+      (convertToCustomRepr reprs dRepr hwTy)+      [ [ (fieldAnn == 0, hwty) | ((_, hwty), fieldAnn) <- zip fields (crFieldAnns constr) ]+                                | (fields, constr) <- zip filtered (drConstrs dRepr)]+maybeConvertToCustomRepr _reprs _ty hwTy = hwTy++-- | Same as @coreTypeToHWType@, but discards void filter information+coreTypeToHWType'+  :: (CustomReprs -> TyConMap -> Type ->+      State HWMap (Maybe (Either String FilteredHWType)))+  -> CustomReprs+  -> TyConMap+  -> Type+  -- ^ Type to convert to HWType+  -> State HWMap (Either String HWType)+coreTypeToHWType' builtInTranslation reprs m ty =+  fmap stripFiltered <$> coreTypeToHWType builtInTranslation reprs m ty+++-- | Converts a Core type to a HWType given a function that translates certain+-- builtin types. Returns a string containing the error message when the Core+-- type is not translatable.+coreTypeToHWType+  :: (CustomReprs -> TyConMap -> Type ->+      State HWMap (Maybe (Either String FilteredHWType)))+  -> CustomReprs+  -> TyConMap+  -> Type+  -- ^ Type to convert to HWType+  -> State HWMap (Either String FilteredHWType)+coreTypeToHWType builtInTranslation reprs m ty = do+  htyM <- Map.lookup ty <$> get+  case htyM of+    Just hty -> return hty+    _ -> do+      hty0M <- builtInTranslation reprs m ty+      hty1  <- go hty0M ty+      modify (Map.insert ty hty1)+      return hty1+ where+  -- Try builtin translation; for now this is hardcoded to be the one in ghcTypeToHWType+  go :: Maybe (Either String FilteredHWType)+     -> Type+     -> State (Map Type (Either String FilteredHWType))+              (Either String FilteredHWType)+  go (Just hwtyE) _ = pure $ maybeConvertToCustomRepr reprs ty <$> hwtyE+  -- Strip transparant types:+  go _ (coreView1 m -> Just ty') =+    coreTypeToHWType builtInTranslation reprs m ty'+  -- Try to create hwtype based on AST:+  go _ (tyView -> TyConApp tc args) = runExceptT $ do+    hwty <- mkADT builtInTranslation reprs m (showPpr ty) tc args+    return (maybeConvertToCustomRepr reprs ty hwty)+  -- All methods failed:+  go _ _ = return $ Left $ "Can't translate non-tycon type: " ++ showPpr ty++-- | Generates original indices in list before filtering, given a list of+-- removed indices.+--+-- >>> originalIndices [False, False, True, False]+-- [0,1,3]+originalIndices+  :: [Bool]+  -- ^ Were voids. Length must be less than or equal to n.+  -> [Int]+  -- ^ Original indices+originalIndices wereVoids =+  [i | (i, void) <- zip [0..] wereVoids, not void]++-- | Converts an algebraic Core type (split into a TyCon and its argument) to a HWType.+mkADT+  :: (CustomReprs -> TyConMap -> Type ->+      State HWMap (Maybe (Either String FilteredHWType)))+  -- ^ Hardcoded Type -> HWType translator+  -> CustomReprs+  -> TyConMap+  -- ^ TyCon cache+  -> String+  -- ^ String representation of the Core type for error messages+  -> TyConName+  -- ^ The TyCon+  -> [Type]+  -- ^ Its applied arguments+  -> ExceptT String (State HWMap) FilteredHWType+  -- ^ An error string or a tuple with the type and possibly a list of+  -- removed arguments.+mkADT _ _ m tyString tc _+  | isRecursiveTy m tc+  = throwE $ $(curLoc) ++ "Can't translate recursive type: " ++ tyString++mkADT builtInTranslation reprs m tyString tc args = case tyConDataCons (UniqMap.find tc m) of+  []  -> return (FilteredHWType (Void Nothing) [])+  dcs -> do+    let tcName           = nameOcc tc+        substArgTyss     = map (`substArgTys` args) dcs+    argHTyss0           <- mapM (mapM (ExceptT . coreTypeToHWType builtInTranslation reprs m)) substArgTyss+    let argHTyss1        = map (\tys -> zip (map isFilteredVoid tys) tys) argHTyss0+    let areVoids         = map (map fst) argHTyss1+    let filteredArgHTyss = map (map snd . filter (not . fst)) argHTyss1++    -- Every alternative is annotated with some examples. Be sure to read them.+    case (dcs, filteredArgHTyss) of+      _ | any (hasUnconstrainedExistential m) dcs ->+        throwE $ $(curLoc) +++                 "Can't translate data types with unconstrained existentials: " +++                 tyString+      -- Type has one constructor and that constructor has a single field,+      -- modulo empty fields if keepVoid is False. Examples of such fields+      -- are:+      --+      -- >>> data ABC = ABC Int+      -- >>> data DEF = DEF Int ()+      --+      -- Notice that @DEF@'s constructor has an "empty" second argument. The+      -- second field of FilteredHWType would then look like:+      --+      -- >>> [[False, True]]+      (_:[],[[elemTy]]) ->+        return (FilteredHWType (stripFiltered elemTy) argHTyss1)++      -- Type has one constructor, but multiple fields modulo empty fields+      -- (see previous case for more thorough explanation). Examples:+      --+      -- >>> data GHI = GHI Int Int+      -- >>> data JKL = JKL Int () Int+      --+      -- In the second case the second field of FilteredHWType would be+      -- [[False, True, False]]+      ([dcFieldLabels -> labels0],[elemTys@(_:_)]) -> do+        labelsM <-+          if null labels0 then+            return Nothing+          else+            -- Filter out labels belonging to arguments filtered due to being+            -- void. See argHTyss1.+            let areNotVoids = case areVoids of+                                areVoid:_ -> map not areVoid+                                _ -> error "internal error: insufficient areVoids"+                labels1     = filter fst (zip areNotVoids labels0)+                labels2     = map snd labels1+             in return (Just labels2)+        let hwty = Product tcName labelsM (map stripFiltered elemTys)+        return (FilteredHWType hwty argHTyss1)++      -- Either none of the constructors have fields, or they have been filtered+      -- due to them being empty. Examples:+      --+      -- >>> data MNO = M    | N | O+      -- >>> data PQR = P () | Q | R ()+      -- >>> data STU = STU+      -- >>> data VWX+      (_, concat -> [])+        -- If none of the dataconstructors have fields, and there are 1 or less+        -- of them, this type only has one inhabitant. It can therefore be+        -- represented by zero bits, and is therefore empty:+        | length dcs <= 1 -> case argHTyss0 of+            [argHTys0] ->+              -- We need this to preserve constraint-tuples of `KnownDomains`+              let argHTys1 = map (stripVoid . stripFiltered) argHTys0+              in  return (FilteredHWType+                            (Void (Just (Product tcName Nothing argHTys1)))+                            argHTyss1)+            _ -> return (FilteredHWType (Void Nothing) argHTyss1)+        -- None of the dataconstructors have fields. This type is therefore a+        -- simple Sum type.+        | otherwise ->+          return (FilteredHWType (Sum tcName $ map (nameOcc . dcName) dcs) argHTyss1)++      -- A sum of product, due to multiple constructors, where at least one+      -- of the constructor has one or more fields modulo empty fields. Example:+      --+      -- >>> data YZA = Y Int | Z () | A+      (_,elemHTys) ->+        return $ FilteredHWType (SP tcName $ zipWith+          (\dc tys ->  ( nameOcc (dcName dc), tys))+          dcs (map stripFiltered <$> elemHTys)) argHTyss1++-- | Determine whether a data constructor has unconstrained existential type+-- variables, i.e. those that cannot be inferred by the (potential) constraints+-- between the existential type variables and universal type variables.+--+-- So here we have an example of a constrained existential:+--+-- data Vec :: Nat -> Type -> Type+--  where+--   Nil  :: Vec 0 a+--   Cons :: forall m . (n ~ m + 1) => a -> Vec m a -> Vec n a+--+-- where we can generate a type for `m` when we know `n` (by doing `n-1`).+--+-- And here is an example of an unconstrained existential:+--+-- data SomeSNat where+--  where+--   SomeSNat :: forall m . SNat m -> SomeSNat+--+-- where there is no way to generate a type for `m` from any context.+--+-- So why do we care? Because terms need to be completely monomorphic in order+-- to be translated to circuits. And having a topEntity lambda-bound variable+-- with an unconstrained existential type prevents us from achieving a fully+-- monomorphic term.+hasUnconstrainedExistential+  :: TyConMap+  -> DataCon+  -> Bool+hasUnconstrainedExistential tcm dc =+  let eTVs        = dcExtTyVars dc+      uTVs        = dcUnivTyVars dc+      constraints = mapMaybe (typeEq tcm) (dcArgTys dc)++      -- Is the existential `eTV` constrained by the constraint `(ty1,ty2)`+      isConstrainedBy eTV (ty1,ty2) =+        let -- Free FVs in the LHS and RHS of the constraint that are not the+            -- in the set of universal type variables of the constructor.+            ty1FEVs = Lens.toListOf (typeFreeVars' ((`notElem` uTVs) . coerce)+                                                   mempty)+                                    ty1+            ty2FEVs = Lens.toListOf (typeFreeVars' ((`notElem` uTVs) . coerce)+                                                   mempty)+                                    ty2++            -- Determine whether `eTV` can be generated from one side of a+            -- constraint, under the assumption that the other side of the+            -- constraint mentions no existential type variables.+            isGenerative ::+              -- Side (LHS or RHS) of a constraint+              Type ->+              -- Its free type variables (that are no in the set of universal+              -- type variables)+              [TyVar] ->+              Bool+            isGenerative t efvs = case tyView t of+              TyConApp tcNm _+                | Just (FunTyCon {}) <- UniqMap.lookup tcNm tcm+                -- For type families we can only "calculate" the `eTV` if it is+                -- the only free variable. e.g. we can work out from `n + 1 ~ 4`+                -- that `n ~ 3`, but can't do anything for `n + m ~ 4`.+                -> [eTV] == efvs+                | otherwise+                -- Normal type constructors are fully generative, e.g. given:+                -- DomainConfiguration a b ~ DomainConfiguration "System" 10000+                --+                -- we can infer both `a ~ "System"` and `b ~ 10000`+                -> eTV `elem` efvs+              FunTy {}+                -- Functions are also fully generative+                -> eTV `elem` efvs+              OtherType other -> case other of+                VarTy v -> v == eTV+                LitTy _ -> False+                -- Anything else, like some higher-kinded quantified type we+                -- just give up for now. TODO: implement this+                _ -> False++            onlyTy1 = isGenerative ty1 ty1FEVs && null ty2FEVs+            onlyTy2 = isGenerative ty2 ty2FEVs && null ty1FEVs+        in  onlyTy1 || onlyTy2++      -- The existential type variables that are not constrained by any of the+      -- constraints.+      unconstrainedETVs =+        filter (\v -> not (any (isConstrainedBy v) constraints)) eTVs++  in  not (null unconstrainedETVs)+++-- | Simple check if a TyCon is recursively defined.+--+-- Note [Look through type families in recursivity check]+--+-- Consider:+--+-- @+-- data SList :: [Type] -> Type where+--   SNil  :: SList []+--   CSons :: a -> Sing (as :: [k]) -> SList (a:as)+--+-- type family Sing [a] = SList [a]+-- @+--+-- Without looking through type families, we would think that /SList/ is not+-- recursive. This lead to issue #1921+isRecursiveTy :: TyConMap -> TyConName -> Bool+isRecursiveTy m tc = case tyConDataCons (UniqMap.find tc m) of+    []  -> False+    dcs -> let argTyss   = map dcArgTys dcs+               argTycons = (map fst . catMaybes)+                         $ (concatMap . map)+                               -- Note [Look through type families in recursivity check]+                               (splitTyConAppM . normalizeType m)+                               argTyss+           in tc `elem` argTycons++-- | Determines if a Core type is translatable to a HWType given a function that+-- translates certain builtin types.+representableType+  :: (CustomReprs -> TyConMap -> Type ->+      State HWMap (Maybe (Either String FilteredHWType)))+  -> CustomReprs+  -> Bool+  -- ^ String considered representable+  -> TyConMap+  -> Type+  -> Bool+representableType builtInTranslation reprs stringRepresentable m =+    either (const False) isRepresentable .+    flip evalState mempty .+    coreTypeToHWType' builtInTranslation reprs m+  where+    isRepresentable hty = case hty of+      String            -> stringRepresentable+      Vector _ elTy     -> isRepresentable elTy+      RTree  _ elTy     -> isRepresentable elTy+      Product _ _ elTys -> all isRepresentable elTys+      SP _ elTyss       -> all (all isRepresentable . snd) elTyss+      BiDirectional _ t -> isRepresentable t+      Annotated _ ty    -> isRepresentable ty+      _                 -> True++-- | Determines the bitsize of a type. For types that don't get turned+-- into real values in hardware (string, integer) the size is 0.+typeSize :: HWType+         -> Int+typeSize (Void {}) = 0+typeSize FileType = 32 -- (ref. page 287 of IEEE 1364-2005)+typeSize String = 0+typeSize Integer = 0+typeSize (KnownDomain {}) = 0+typeSize Bool = 1+typeSize Bit = 1+typeSize (Clock _) = 1+typeSize (ClockN _) = 1+typeSize (Reset _) = 1+typeSize (Enable _) = 1+typeSize (BitVector i) = i+typeSize (Index 0) = 0+typeSize (Index 1) = 1+typeSize (Index u) = fromMaybe 0 (clogBase 2 u)+typeSize (Signed i) = i+typeSize (Unsigned i) = i+typeSize (Vector n el) = n * typeSize el+typeSize (MemBlob n m) = n * m+typeSize (RTree d el) = (2^d) * typeSize el+typeSize t@(SP _ cons) = conSize t ++  maximum (map (sum . map typeSize . snd) cons)+typeSize (Sum _ dcs) = fromMaybe 0 . clogBase 2 . toInteger $ length dcs+typeSize (Product _ _ tys) = sum $ map typeSize tys+typeSize (BiDirectional In h) = typeSize h+typeSize (BiDirectional Out _) = 0+typeSize (CustomSP _ _ size _) = fromIntegral size+typeSize (CustomSum _ _ size _) = fromIntegral size+typeSize (CustomProduct _ _ size _ _) = fromIntegral size+typeSize (Annotated _ ty) = typeSize ty++-- | Determines the bitsize of the constructor of a type+conSize :: HWType+        -> Int+conSize (SP _ cons) = fromMaybe 0 . clogBase 2 . toInteger $ length cons+conSize t           = typeSize t++-- | Gives the HWType corresponding to a term. Returns an error if the term has+-- a Core type that is not translatable to a HWType.+termHWType :: String+           -> Term+           -> NetlistMonad HWType+termHWType loc e = do+  m <- Lens.view tcCache+  let ty = inferCoreTypeOf m e+  stripFiltered <$> unsafeCoreTypeToHWTypeM loc ty++-- | Gives the HWType corresponding to a term. Returns 'Nothing' if the term has+-- a Core type that is not translatable to a HWType.+termHWTypeM+  :: Term+  -- ^ Term to convert to HWType+  -> NetlistMonad (Maybe FilteredHWType)+termHWTypeM e = do+  m  <- Lens.view tcCache+  let ty = inferCoreTypeOf m e+  coreTypeToHWTypeM ty++isBiSignalIn :: HWType -> Bool+isBiSignalIn (BiDirectional In _) = True+isBiSignalIn (Annotated _ ty)     = isBiSignalIn ty+isBiSignalIn _                    = False++isBiSignalOut :: HWType -> Bool+isBiSignalOut (BiDirectional Out _) = True+isBiSignalOut (Annotated _ ty)      = isBiSignalOut ty+isBiSignalOut _                     = False++containsBiSignalIn+  :: HWType+  -> Bool+containsBiSignalIn (BiDirectional In _) = True+containsBiSignalIn (Product _ _ tys) = any containsBiSignalIn tys+containsBiSignalIn (SP _ tyss)       = any (any containsBiSignalIn . snd) tyss+containsBiSignalIn (Vector _ ty)     = containsBiSignalIn ty+containsBiSignalIn (RTree _ ty)      = containsBiSignalIn ty+containsBiSignalIn (Annotated _ ty)  = containsBiSignalIn ty+containsBiSignalIn _                 = False++-- | Uniquely rename all the variables and their references in a normalized+-- term+mkUniqueNormalized+  :: HasCallStack+  => InScopeSet+  -> Maybe (Maybe TopEntity)+  -- ^ Top entity annotation where:+  --+  --     * Nothing: term is not a top entity+  --     * Just Nothing: term is a top entity, but has no explicit annotation+  --     * Just (Just ..): term is a top entity, and has an explicit annotation+  -> ( [Id]+     , [LetBinding]+     , Id+     )+  -> NetlistMonad+      ([Bool]+      ,[(Identifier,HWType)]+      ,[Declaration]+      ,[(Identifier,HWType)]+      ,[Declaration]+      ,[LetBinding]+      ,Maybe Id)+mkUniqueNormalized is0 topMM (args, binds, res) = do+  -- Generate port names and add them to set of seen identifiers+  argHwtys <- mapM (unsafeCoreTypeToHWTypeM $(curLoc) . coreTypeOf) args+  resHwty <- unsafeCoreTypeToHWTypeM $(curLoc) (coreTypeOf res)+  etopM <-+    mapM+      (expandTopEntityOrErrM (zip (map Just args) argHwtys) (Just res, resHwty))+      topMM++  -- Make arguments unique+  let (bndrs, exprs) = unzip binds+  let is1 = is0 `extendInScopeSetList` (args ++ bndrs)+  (wereVoids, iports, iwrappers, substArgs) <-+    mkUniqueArguments (mkSubst is1) etopM args++  -- Make result unique. This might yield 'Nothing' in which case the result+  -- was a single BiSignalOut. This is superfluous in the HDL, as the argument+  -- will already contain a bidirectional signal complementing the BiSignalOut.+  resM <- mkUniqueResult substArgs etopM res+  case resM of+    Just (oports, owrappers, res1, subst0) -> do+      -- Collect new names, see 'renameBinder' for more information+      (listToMaybe -> resRenameM0, HashMap.fromList -> renames0) <-+        partition ((== res) . fst) <$> concatMapM renameBinder binds++      let+        -- Is the result variable read by any of the other binders? In that case+        -- we need to add a redirection as most synthesis tools don't allow reads+        -- from output ports. Note that if the result is renamed anyway, we don't+        -- have to do anything here.+        resultRead = any (elemFreeVars res) exprs+        recResult = modifyVarName (`appendToName` "_rec") res+        resRenameM1 = resRenameM0 <|> orNothing resultRead (res, recResult)++      (resN, extraBind, subst1) <-+        case resRenameM1 of+          Nothing ->+            -- Result binder was not renamed, so we can assign result expression+            -- directly to new name given by 'res1'+            pure (res1, Nothing, subst0)+          Just (_, newName0) -> do+            -- Result binder was renamed. We cannot rename 'res1', so we need+            -- to create an indirection.+            ([newName1], s) <- mkUnique subst0 [newName0]+            pure (newName1, Just (res1, Var newName1), s)++      let+        -- Result binder is already unique, so don't rename that+        renames1 = [(b, hmFindWithDefault b b renames0) | b <- bndrs]+        (renamesL0, renamesR0) = case break ((==res) . fst) renames1 of+          (ls,_:rs) -> (ls,rs)+          _ -> error (concat [ "internal error: unable to find: "+                             , show res , " in: "+                             , show renames1 ])++      (renamesL1, subst2) <- mkUnique subst1 (map snd renamesL0)+      (renamesR1, subst3) <- mkUnique subst2 (map snd renamesR0)++      let+        exprs1 = map (substTm "mkUniqueNormalized1" subst3) exprs+        binds0 = zip (renamesL1 <> [resN] <> renamesR1) exprs1+        binds1 = binds0 <> maybeToList extraBind++      -- Return the uniquely named arguments, let-binders, and result+      return (wereVoids, iports, iwrappers, oports, owrappers, binds1, Just res1)++    Nothing -> do+      (bndrs1, substArgs1) <- mkUnique substArgs bndrs+      let binds1 = zip bndrs1 (map (substTm "mkUniqueNormalized2" substArgs1) exprs)+      return (wereVoids, iports, iwrappers, [], [], binds1, Nothing)++-- | Produce a 'Just' when predicate is True, else Nothing+orNothing :: Bool -> a -> Maybe a+orNothing True a = Just a+orNothing False _ = Nothing++-- | Set the name of the binder if the given term is a blackbox requesting+-- a specific name for the result binder. It might return multiple names in+-- case of a multi result primitive.+--+renameBinder :: (Id, Term) -> NetlistMonad [(Id, Id)]+renameBinder (i, collectArgsTicks -> (k, args, ticks)) = withTicks ticks $ \_ -> do+  case k of+    Prim p ->+      case primMultiResult p of+        SingleResult -> extractPrimWarnOrFail (primName p) >>= goSingle p+        MultiResult -> extractPrimWarnOrFail (primName p) >>= goMulti p+    _ -> pure []+ where+  -- Routine for multi result primitives. For more info:+  -- 'Clash.Normalize.Transformations.setupMultiResultPrim'.+  goMulti :: PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]+  goMulti pInfo (BlackBoxHaskell{function=(_, function)}) = do+    tcm <- Lens.view tcCache+    let mpInfo@MultiPrimInfo{mpi_resultTypes} = multiPrimInfo' tcm pInfo+    let (args1, resIds) = splitMultiPrimArgs mpInfo args+    funRes <- preserveVarEnv (function False (primName pInfo) args1 mpi_resultTypes)+    let BlackBoxMeta{bbResultNames} = either error fst funRes+    go (primName pInfo) resIds args1 bbResultNames+  goMulti _ _ = pure []++  -- Routine for single result primitives (the default kind of primitive)+  goSingle :: PrimInfo -> CompiledPrimitive -> NetlistMonad [(Id, Id)]+  goSingle pInfo (BlackBoxHaskell{function=(_, function)}) = do+    funRes <- preserveVarEnv (function False (primName pInfo) args [coreTypeOf i])+    case either error fst funRes of+      BlackBoxMeta{bbResultNames=[bbResultName]} ->+        go (primName pInfo) [i] args [bbResultName]+      _ -> pure []+  goSingle pInfo (BlackBox{resultNames=[resultName]}) = do+    go (primName pInfo) [i] args [resultName]+  goSingle _ _ = pure []++  go :: Text -> [Id] -> [Either Term Type] -> [BlackBox] -> NetlistMonad [(Id, Id)]+  go nm is0 bbArgs bbResultTemplates = do+    (bbCtx, _) <- preserveVarEnv (mkBlackBoxContext nm Concurrent is0 bbArgs)+    be <- Lens.use backend+    let+      _sameName i0 i1 = nameOcc (varName i0) == nameOcc (varName i1)+      newNames = map (evalBlackBox be bbCtx) bbResultTemplates+      modName newRetName = modifyVarName (\n -> n {nameOcc = newRetName})+      is1 = zipWith modName newNames is0++    -- TODO: _sameName check disabled due to+    --       https://github.com/clash-lang/clash-compiler/issues/1566+    -- Don't rename if we didn't change any names, it will cause superfluous+    -- redirections in 'mkUniqueNormalized'.+    -- pure (if and (zipWith sameName is0 is1) then [] else zip is0 is1)+    pure (zip is0 is1)++-- | Render a blackbox given its context. Renders _just_ the blackbox, not any+-- corresponding includes, libraries, and so forth.+evalBlackBox :: HasCallStack => SomeBackend -> BlackBoxContext -> BlackBox -> Text+evalBlackBox (SomeBackend s) bbCtx bb+  | BBFunction _bbName _bbHash (TemplateFunction _usedArgs _verifFunc func) <- bb =+    let layout = LayoutOptions (AvailablePerLine 120 0.4) in+    toStrict (renderLazy (layoutPretty layout (State.evalState (func bbCtx) s)))+  | BBTemplate bbt <- bb =+    toStrict ((State.evalState (renderTemplate bbCtx bbt) s) 0)++mkUniqueArguments+  :: Subst+  -> Maybe (ExpandedTopEntity Identifier)+  -- ^ Top entity annotation where:+  --+  --     * Nothing: term is not a top entity+  --     * Just ..: term is a top entity+  -> [Id]+  -> NetlistMonad+       ( [Bool]                 -- Were voids+       , [(Identifier,HWType)]  -- Arguments and their types+       , [Declaration]          -- Extra declarations+       , Subst                  -- Substitution with new vars in scope+       )+mkUniqueArguments subst0 Nothing args = do+  (args', subst1) <- mkUnique subst0 args+  ports <- mapM idToInPort args'+  return (map isNothing ports, catMaybes ports, [], subst1)++mkUniqueArguments subst0 (Just (ExpandedTopEntity{..})) args = do+  (ports, decls, subst1) <- (unzip3 . catMaybes) <$> zipWithM go et_inputs args+  return ( map isNothing et_inputs+         , concat ports+         , concat decls+         , extendInScopeIdList (extendIdSubstList subst0 (map snd subst1))+                               (map fst subst1))+  where+    go Nothing _var =+      pure Nothing+    go (Just port) var = do+      (ports, decls, _, portI) <- mkTopInput port+      let portName = Id.toText portI+          pId  = mkLocalId (coreTypeOf var) (setRepName portName (varName var))+      return (Just (ports, decls, (pId, (var, Var pId))))+++mkUniqueResult+  :: Subst+  -> Maybe (ExpandedTopEntity Identifier)+  -- ^ Top entity annotation where:+  --+  --     * Nothing: term is not a top entity+  --     * Just ..: term is a top entity+  -> Id+  -> NetlistMonad (Maybe ([(Identifier,HWType)],[Declaration],Id,Subst))+mkUniqueResult subst0 Nothing res = do+  ([res'],subst1) <- mkUnique subst0 [res]+  portM <- idToOutPort res'+  case portM of+    Just port -> return (Just ([port],[],res',subst1))+    _         -> return Nothing++mkUniqueResult _subst0 (Just (ExpandedTopEntity{et_output=Nothing})) _res =+  pure Nothing+mkUniqueResult subst0 (Just (ExpandedTopEntity{et_output=Just iPort})) res = do+  (_, sp) <- Lens.use curCompNm+  (FilteredHWType hwty _) <- unsafeCoreTypeToHWTypeM $(curLoc) (coreTypeOf res)+  when (containsBiSignalIn hwty)+    (throw (ClashException sp ($(curLoc) ++ "BiSignalIn cannot be part of a function's result. Use 'readFromBiSignal'.") Nothing))+  (ports, decls, portI) <- mkTopOutput iPort+  let pO = setRepName (Id.toText portI) (varName res)+      pOId = mkLocalId (coreTypeOf res) pO+      subst1 = extendInScopeId (extendIdSubst subst0 res (Var pOId)) pOId+  return (Just (ports, decls, pOId, subst1))++-- | Same as idToPort, but+--    * Throws an error if the port is a composite type with a BiSignalIn+idToInPort :: Id -> NetlistMonad (Maybe (Identifier, HWType))+idToInPort var = do+  (_, sp) <- Lens.use curCompNm+  portM <- idToPort var+  case portM of+    Just (_,hty) -> do+      when (containsBiSignalIn hty && not (isBiSignalIn hty))+        (throw (ClashException sp ($(curLoc) ++ "BiSignalIn currently cannot be part of a composite type when it's a function's argument") Nothing))+      return portM+    _ -> return Nothing++-- | Same as idToPort, but:+--    * Throws an error if port is of type BiSignalIn+idToOutPort :: Id -> NetlistMonad (Maybe (Identifier,HWType))+idToOutPort var = do+  (_, srcspan) <- Lens.use curCompNm+  portM <- idToPort var+  case portM of+    Just (_,hty) -> do+      when (containsBiSignalIn hty)+        (throw (ClashException srcspan ($(curLoc) ++ "BiSignalIn cannot be part of a function's result. Use 'readFromBiSignal'.") Nothing))+      return portM+    _ -> return Nothing++idToPort :: Id -> NetlistMonad (Maybe (Identifier, HWType))+idToPort var = do+  hwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (coreTypeOf var)+  if isVoid hwTy+    then return Nothing+    else return (Just (Id.unsafeFromCoreId var, hwTy))++setRepName :: Text -> Name a -> Name a+setRepName s (Name sort' _ i loc) = Name sort' s i loc++-- | Make a set of IDs unique; also returns a substitution from old ID to new+-- updated unique ID.+mkUnique+  :: Subst+  -- ^ Existing substitution+  -> [Id]+  -- ^ IDs to make unique+  -> NetlistMonad ([Id],Subst)+  -- ^ (Unique IDs, update substitution)+mkUnique = go []+  where+    go :: [Id] -> Subst -> [Id] -> NetlistMonad ([Id],Subst)+    go processed subst []     = return (reverse processed,subst)+    go processed subst@(Subst isN _ _ _) (i:is) = do+      iN <- Id.toText <$> Id.fromCoreId i+      let i' = uniqAway isN (modifyVarName (setRepName iN) i)+          subst' = extendInScopeId (extendIdSubst subst i (Var i')) i'+      go (i':processed)+         subst'+         is++-- | Preserve the complete state before running an action, and restore it+-- afterwards.+preserveState+  :: NetlistMonad a+  -> NetlistMonad a+preserveState action = do+  state <- State.get+  val <- action+  State.put state+  pure val++-- | Preserve the Netlist '_curCompNm','_seenIds','_usageMap' when executing+-- a monadic action+preserveVarEnv+  :: NetlistMonad a+  -> NetlistMonad a+preserveVarEnv action = do+  -- store state+  vComp <- Lens.use curCompNm+  vSeen <- Lens.use seenIds+  vUses <- Lens.use usageMap+  -- perform action+  val <- action+  -- restore state+  curCompNm .= vComp+  seenIds   .= vSeen+  usageMap  .= vUses+  return val++dcToLiteral :: HWType -> Int -> Literal+dcToLiteral Bool 1 = BoolLit False+dcToLiteral Bool 2 = BoolLit True+dcToLiteral _ i    = NumLit (toInteger i-1)++-- * TopEntity Annotations++extendPorts :: [PortName] -> [Maybe PortName]+extendPorts ps = map Just ps ++ repeat Nothing++-- | Prefix given string before portnames /except/ when this string is empty.+prefixParent :: String -> PortName -> PortName+prefixParent ""     p                   = p+prefixParent parent (PortName p)        = PortName (parent <> "_" <> p)+prefixParent parent (PortProduct "" ps) = PortProduct parent ps+prefixParent parent (PortProduct p ps)  = PortProduct (parent <> "_" <> p) ps++-- | Make a new signal which is assigned with an initial value. This should be+-- used in place of NetDecl directly, as it also updates the usage map to+-- include the new identifier and usage.+--+mkInit+  :: HasCallStack+  => DeclarationType+  -- ^ Are we in a concurrent or sequential context?+  -> Usage+  -- ^ How is the initial value assigned if the assignment is separate+  -> Identifier+  -- ^ The identifier of the declared net+  -> HWType+  -- ^ The typr of the declared net+  -> Expr+  -- ^ The value assigned to the net+  -> NetlistMonad [Declaration]+  -- ^ The declarations needed to declare and assign the net+mkInit _ _ i ty e+  -- When the initial value is a constant, we can set the value at the same+  -- point the declaration happens. Initial assignments of this form do not+  -- count as a usage as they are always allowed.+  | isConstExpr e+  = pure [NetDecl' Nothing i ty (Just e)]++mkInit Concurrent Cont i ty e = do+  usageMap %= Map.insert (Id.toText i) Cont+  pure [NetDecl' Nothing i ty Nothing, Assignment i Cont e]++mkInit Concurrent proc i ty e = do+  usageMap %= Map.insert (Id.toText i) proc+  pure+    [ NetDecl' Nothing i ty Nothing+    , Seq [Initial [SeqDecl (Assignment i proc e)]]+    ]++mkInit Sequential Cont _ _ _ =+  error "mkInit: Cannot continuously assign in a sequential block"++mkInit Sequential proc i ty e = do+  usageMap %= Map.insert (Id.toText i) proc+  pure+    [ NetDecl' Nothing i ty Nothing+    , Seq [SeqDecl (Assignment i proc e)]+    ]++-- | Determine if for the specified HDL, the type of assignment wanted can be+-- performed on a signal which has been assigned another way. This identifies+-- when a new intermediary signal needs to be created, e.g.+--+--   * when attempting to use blocking and non-blocking procedural assignment+--     on the same signal in VHDL+--+--   * when attempting to use continuous and procedural assignment on the same+--     signal in (System)Verilog+--+canUse :: HDL -> Usage -> Usage -> Bool+canUse VHDL (Proc Blocking) = \case+  Proc Blocking -> True+  _ -> False++canUse VHDL _ = \case+  Proc Blocking -> False+  _ -> True++canUse _ Cont = \case+  Cont -> True+  _ -> False++canUse _ _ = \case+  Cont -> False+  _ -> True++declareUse :: Usage -> Identifier -> NetlistMonad ()+declareUse u i = usageMap %= Map.insertWith (<>) (Id.toText i) u++-- | Like 'declareUse', but will throw an exception if we run into a name+-- collision.+declareUseOnce :: HasUsageMap s => Usage -> Identifier -> State.State s ()+declareUseOnce u i = usageMap %= Map.alter go (Id.toText i)+ where+  go Nothing = Just u+  go Just{}  = error ("Internal error: unexpected re-declaration of usage for" ++ show i)++-- | Declare uses which occur as a result of a component being instantiated,+-- for example the following design (verilog)+--+-- > module f ( input p; output reg r ) ... endmodule+-- >+-- > module top ( ... )+-- >   ...+-- >   f f_inst ( .p(p), .r(foo));+-- >   ...+-- > endmodule+--+-- would declare a usage of foo, since it is assigned by @f_inst@.+--+declareInstUses+  :: [(Expr, PortDirection, HWType, Expr)]+  -- ^ The port mappings (named)+  -> NetlistMonad ()+declareInstUses =+  mapM_ declare+ where+  -- Modifiers don't matter for these identifiers+  declare (Identifier _ _, Out, _, Identifier n _) =+    -- See NOTE [output ports are continuously assigned]+    declareUse Cont n++  declare (_, In, _, _) =+    pure ()++  declare portMapping =+    error ("declareInstUses: Unexpected port mapping: " <> show portMapping)++{-+NOTE [output ports are continuously assigned]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When a module is instantiated in Verilog, the output of the module is always+continuously assigned. This means if I have the module++  module f ( ..., output reg result)++and an instantiation++  f f_inst ( ..., .result(foo) );++then the assignment of result to foo is a continuous assignment. This may seem+strange, but consider++  * instantiations can only occur in a concurrent context, and concurrent+    contexts only admit continuous assignment++  * the usage being tracked is not for the result port, but for foo. Whenever+    the value of the port changes, the value of foo will change (i.e. there is+    a wire between them, it cannot "hold" state).++This means when we declare uses that occur as a result of an instantiation in+netlist, the uses are always continuous assignment, and not the usage of the+output port as given in the `outputs` field of the `Component` type.+-}++assignmentWith+  :: HasCallStack+  => (Identifier -> Declaration)+  -> Usage+  -> Identifier+  -> NetlistMonad Declaration+assignmentWith assign new i = do+  u <- Lens.use usageMap+  SomeBackend b <- Lens.use backend++  case lookupUsage i u of+    Just old | not $ canUse (hdlKind b) new old ->+      error $ mconcat+        [ "assignmentWith: Cannot assign as "+        , show new+        , " after "+        , show old+        , " for "+        , show i+        ]++    _ ->+      declareUse new i $> assign i++-- | Attempt to continuously assign an expression to the given identifier. If+-- the assignment is not allowed for the backend being used, a new signal is+-- created which allows the assignment. The identifier which holds the result+-- of the assignment is returned alongside the new declarations.+--+-- This function assumes the identifier being assigned is already declared. If+-- the identifier is not in the usage map then an error is thrown.+--+contAssign+  :: HasCallStack+  => Identifier+  -> Expr+  -> NetlistMonad Declaration+contAssign dst expr =+  assignmentWith (\i -> Assignment i Cont expr) Cont dst++procAssign+  :: HasCallStack+  => Blocking+  -> Identifier+  -> Expr+  -> NetlistMonad Declaration+procAssign block dst expr =+  assignmentWith (\i -> Assignment i (Proc block) expr) (Proc block) dst++condAssign+  :: Identifier+  -> HWType+  -> Expr+  -> HWType+  -> [(Maybe Literal, Expr)]+  -> NetlistMonad Declaration+condAssign dst dstTy scrut scrutTy alts = do+  -- Currently, all CondAssignment get rendered as `always @*` blocks in+  -- (System)Verilog. This means when we target these HDL, this is _really_ a+  -- blocking procedural assignment.+  SomeBackend b <- Lens.use backend+  let use = case hdlKind b of { VHDL -> Cont ; _ -> Proc Blocking }+  assignmentWith (\i -> CondAssignment i dstTy scrut scrutTy alts) use dst++-- | See 'toPrimitiveType' / 'fromPrimitiveType'+convPrimitiveType :: HWType -> a -> NetlistMonad a -> NetlistMonad a+convPrimitiveType hwty a action = do+  b <- Lens.use backend+  let kind = case b of {SomeBackend s -> State.evalState (hdlHWTypeKind hwty) s}+  case kind of+    UserType -> action+    SynonymType -> pure a+    PrimitiveType -> pure a++-- | Top entities only expose primitive types or types that don't need explicit+-- conversion to a primitive type (i.e., no types from the '_types' module). This+-- function converts from a custom type to a primitive type if needed.+--+-- See 'HWKind' for more info on primitive type kinds.+toPrimitiveType+  :: Identifier+  -> HWType+  -> NetlistMonad ([Declaration], Identifier, Expr, HWType)+toPrimitiveType id0 hwty0 = convPrimitiveType hwty0 dflt $ do+  id1 <- Id.next id0+  ds  <- mkInit Concurrent Cont id1 hwty1 expr+  pure (ds, id1, expr, hwty1)+ where+  dflt = ([], id0, Identifier id0 Nothing, hwty0)+  hwty1 = BitVector (typeSize hwty0)+  expr = ToBv Nothing hwty0 (Identifier id0 Nothing)++-- | Top entities only expose primitive types or types that don't need explicit+-- conversion to a primitive type (i.e., no types from the '_types' module). This+-- function converts from a primitive type to a custom type if needed.+--+-- See 'HWKind' for more info on primitive type kinds.+fromPrimitiveType+  :: Identifier+  -> HWType+  -> NetlistMonad ([Declaration], Identifier, Expr, HWType)+fromPrimitiveType id0 hwty0 = convPrimitiveType hwty0 dflt $ do+  id1 <- Id.next id0+  ds <- mkInit Concurrent Cont id1 hwty0 expr+  pure (ds, id1, expr, hwty1)+ where+  dflt = ([], id0, Identifier id0 Nothing, hwty0)+  hwty1 = BitVector (typeSize hwty0)+  expr = FromBv Nothing hwty0 (Identifier id0 Nothing)++-- | Create port names for the declaration of a top entity. For /instantiation/+-- see 'mkTopInstInput'.+mkTopInput+  :: ExpandedPortName Identifier+  -- ^ Port name description+  -> NetlistMonad ([(Identifier, HWType)], [Declaration], Expr, Identifier)+  -- ^ (port names, signal decls for intermediate signals, argument expr, argument id)+mkTopInput (ExpandedPortName hwty0 i0) = do+  (decls, i1, expr, hwty1) <- fromPrimitiveType i0 hwty0+  return ([(i0, hwty1)], decls, expr, i1)++mkTopInput epp@(ExpandedPortProduct p hwty ps) = do+  pN <- Id.makeBasic p+  case hwty of+    Vector sz eHwty -> do+      (ports, _, exprs, _) <- unzip4 <$> mapM mkTopInput ps+      let vecExpr  = mkVectorChain sz eHwty exprs+      decls <- mkInit Concurrent Cont pN hwty vecExpr+      return (concat ports, decls, vecExpr, pN)++    RTree d eHwty -> do+      (ports, _, exprs, _) <- unzip4 <$> mapM mkTopInput ps+      let trExpr   = mkRTreeChain d eHwty exprs+      decls <- mkInit Concurrent Cont pN hwty trExpr+      return (concat ports, decls, trExpr, pN)++    Product _ _ _ -> do+      (ports, _, exprs, _) <- unzip4 <$> mapM mkTopInput ps+      case exprs of+        [expr] -> do+          decls <- mkInit Concurrent Cont pN hwty expr+          return (concat ports, decls, expr, pN)+        _ -> do+          let dcExpr = DataCon hwty (DC (hwty, 0)) exprs+          decls <- mkInit Concurrent Cont pN hwty dcExpr+          return (concat ports, decls, dcExpr, pN)++    SP _ ((concat . map snd) -> [elTy]) -> do+      (ports, _, exprs, _) <- unzip4 <$> mapM mkTopInput ps+      case exprs of+        [conExpr, elExpr] -> do+          let dcExpr   = DataCon hwty (DC (BitVector (typeSize hwty), 0))+                          [conExpr, ToBv Nothing elTy elExpr]+          decls <- mkInit Concurrent Cont pN hwty dcExpr+          return (concat ports, decls, dcExpr, pN)+        _ -> error $ $(curLoc) ++ "Internal error"++    _ ->+      -- 'expandTopEntity' should have made sure this isn't possible+      error $ $(curLoc) ++ "Internal error: " ++ show epp++portProductError :: String -> HWType -> ExpandedPortName Identifier -> a+portProductError loc hwty portProduct = error $ loc ++ [I.i|+  #{loc}PortProduct used, but did not see Vector, RTree, or Product. Saw the+  following instead:++    #{hwty}++  PortProduct used:++    #{portProduct}++  Note that the PortProduct as shown above might is only indicative, and might+  not correspond exactly to the one given in the Clash design. |]++-- | Create a Vector chain for a list of 'Identifier's+mkVectorChain :: Int+              -> HWType+              -> [Expr]+              -> Expr+mkVectorChain _ elTy []      = DataCon (Vector 0 elTy) VecAppend []+mkVectorChain _ elTy [e]     = DataCon (Vector 1 elTy) VecAppend+                                [e]+mkVectorChain sz elTy (e:es) = DataCon (Vector sz elTy) VecAppend+                                [ e+                                , mkVectorChain (sz-1) elTy es+                                ]++-- | Create a RTree chain for a list of 'Identifier's+mkRTreeChain :: Int+             -> HWType+             -> [Expr]+             -> Expr+mkRTreeChain _ elTy [e] = DataCon (RTree 0 elTy) RTreeAppend+                                  [e]+mkRTreeChain d elTy es =+  let (esL,esR) = splitAt (length es `div` 2) es+  in  DataCon (RTree d elTy) RTreeAppend+        [ mkRTreeChain (d-1) elTy esL+        , mkRTreeChain (d-1) elTy esR+        ]++genComponentName+  :: Bool+  -- ^ New inline strategy enabled+  -> Maybe Text+  -- ^ Component name prefix+  -> Id+  -- ^ Create component name based on this Core Id+  -> Text+genComponentName newInlineStrat prefixM nm =+  Text.intercalate "_" (prefix ++ [fn1])+ where+  nm0 = Text.splitOn "." (nameOcc (varName nm))+  fn0 = Id.stripDollarPrefixes (last nm0)+  fn1 = if Text.null fn0 then "Component" else fn0+  prefix = fromMaybe (if newInlineStrat then [] else init nm0) (pure <$> prefixM)++genTopName+  :: IdentifierSetMonad m+  => Maybe Text+  -- ^ Top entity name prefix+  -> TopEntity+  -- ^ Top entity annotation+  -> m Identifier+  -- ^ New identifier+genTopName prefixM ann =+  case prefixM of+    Just prefix | not (Text.null prefix) ->+      Id.addRaw (Text.concat [prefix, "_", Text.pack (t_name ann)])+    _ ->+      Id.addRaw (Text.pack (t_name ann))++-- | Strips one or more layers of attributes from a HWType; stops at first+-- non-Annotated. Accumulates all attributes of nested annotations.+stripAttributes+  :: HWType+  -> ([Attr Text], HWType)+-- Recursively strip type, accumulate attrs:+stripAttributes (Annotated attrs typ) =+  let (attrs', typ') = stripAttributes typ+  in (attrs ++ attrs', typ')+-- Not an annotated type, so just return it:+stripAttributes typ = ([], typ)++-- | Create output port names for the declaration of a top entity. For+-- /instantiation/ see 'mkTopInstOutput'.+mkTopOutput+  :: ExpandedPortName Identifier+  -> NetlistMonad ([(Identifier, HWType)], [Declaration], Identifier)+mkTopOutput (ExpandedPortName hwty0 i0) = do+  i1 <- Id.next i0+  (_, _, bvExpr, hwty1) <- toPrimitiveType i1 hwty0+  if hwty0 == hwty1 then+    -- No type conversion happened, so we can just request caller to assign to+    -- port name directly.+    return ([(i0, hwty0)], [], i0)+  else do+    -- Type conversion happened, so we must use intermediate variable.+    assn <- contAssign i0 bvExpr+    pure ( [(i0, hwty1)], [NetDecl' Nothing i1 hwty0 Nothing, assn], i1)++mkTopOutput epp@(ExpandedPortProduct p hwty ps) = do+  pN <- Id.makeBasic p+  let netdecl = NetDecl' Nothing pN hwty Nothing+  case hwty of+    Vector {} -> do+      (ports, decls, ids) <- unzip3 <$> mapM mkTopOutput ps+      assigns <- zipWithM (\i n -> assignId pN hwty 10 i n) ids [0..]+      return (concat ports, netdecl : assigns ++ concat decls, pN)++    RTree {} -> do+      (ports, decls, ids) <- unzip3 <$> mapM mkTopOutput ps+      assigns <- zipWithM (\i n -> assignId pN hwty 10 i n) ids [0..]+      return (concat ports, netdecl : assigns ++ concat decls, pN)++    Product {} -> do+      (ports, decls, ids) <- unzip3 <$> mapM mkTopOutput ps+      case ids of+        [i] -> do+          assn <- contAssign i (Identifier pN Nothing)+          pure (concat ports, netdecl : assn : concat decls, pN)++        _   -> do+          assigns <- zipWithM (\i n -> assignId pN hwty 0 i n) ids [0..]+          pure (concat ports, netdecl : assigns ++ concat decls, pN)++    SP _ ((concat . map snd) -> [elTy]) -> do+      (ports, decls, ids) <- unzip3 <$> mapM mkTopOutput ps+      case ids of+        [conId, elId] -> do+          let conIx   = Sliced ( BitVector (typeSize hwty)+                               , typeSize hwty - 1+                               , typeSize elTy )+              elIx    = Sliced ( BitVector (typeSize hwty)+                               , typeSize elTy - 1+                               , 0 )++          conAssgn <- contAssign conId (Identifier pN (Just conIx))+          elAssgn <- contAssign elId (FromBv Nothing elTy (Identifier pN (Just elIx)))++          pure (concat ports, netdecl:conAssgn:elAssgn:concat decls, pN)+        _ -> error $ $(curLoc) ++ "Internal error"+    -- 'expandTopEntity' should have made sure this isn't possible+    _ -> error $ $(curLoc) ++ "Internal error: " ++ show epp++ where+  assignId p_ hwty_ con i n =+    contAssign i (Identifier p_ (Just (Indexed (hwty_, con, n))))++mkTopCompDecl+  :: Maybe Text+  -- ^ Library entity is defined in+  -> [Attr Text]+  -- ^ Attributes to add to generate code+  -> Identifier+  -- ^ The component's (or entity's) name+  -> Identifier+  -- ^ Instance label+  -> [(Expr, HWType, Expr)]+  -- ^ List of parameters for this component (param name, param type, param value)+  -> [InstancePort]+  -- ^ Input port assignments+  -> [InstancePort]+  -- ^ Output port assignments+  -> Declaration+mkTopCompDecl lib attrs name instName params inputs outputs =+  InstDecl Entity lib attrs name instName params (IndexedPortMap ports)+ where+  ports = map (toPort In) inputs ++ map (toPort Out) outputs+  toExpr id_ = Identifier id_ Nothing+  toPort dir ip = (dir, (ip_type ip), toExpr (ip_id ip))++-- | Instantiate a TopEntity, and add the proper type-conversions where needed+mkTopUnWrapper+  :: Id+  -- ^ Name of the TopEntity component+  -> ExpandedTopEntity Identifier+  -- ^ A corresponding @TopEntity@ annotation+  -> (Identifier, HWType)+  -- ^ The name and type of the signal to which to assign the result+  -> [(Expr,HWType)]+  -- ^ The arguments with voids filtered.+  -> [Declaration]+  -- ^ Tick declarations+  -> NetlistMonad [Declaration]+mkTopUnWrapper topEntity annM dstId args tickDecls = do+  -- component name+  compNameM <- lookupVarEnv topEntity <$> Lens.use componentNames+  let+    topName = Id.toText topIdentifier+    topIdentifier = flip fromMaybe compNameM (error [I.i|+     Internal error in 'mkTopUnWrapper': tried to lookup (netlist) name+     of #{showPpr (varName topEntity)}, but couldn't find it in NetlistState's+     'componentNames'. This should have been put there by 'runNetlistMonad' /+     'genNames'. |])++  -- inputs+  (iports, wrappers, idsI) <- unzip3 <$> mapM mkTopInstInput (catMaybes (et_inputs annM))+  inpAssigns <- zipWithM (\i e -> contAssign i e) idsI (fst <$> args)++  -- output+  let+    iResult = inpAssigns : wrappers+    instLabel0 = Text.concat [topName, "_", Id.toText (fst dstId)]++  instLabel1 <- fromMaybe instLabel0 <$> Lens.view setName+  instLabel2 <- affixName instLabel1+  instLabel3 <- Id.makeBasic instLabel2+  topOutputM <- traverse mkTopInstOutput (et_output annM)++  let topDecl = mkTopCompDecl (Just topName) [] topIdentifier instLabel3 [] (concat iports)++  case topOutputM of+    Nothing ->+      pure (topDecl [] : concat iResult)+    Just (oports, unwrappers, id0) -> do+      outpAssign <- contAssign (fst dstId) (Identifier id0 Nothing)+      pure (concat iResult ++ tickDecls ++ (topDecl oports:unwrappers) ++ [outpAssign])++data InstancePort = InstancePort+  { ip_id :: Identifier+  -- ^ Identifier to assign. Top entities are instantiated using positional+  -- arguments, so this doesn't hold a port name.+  , ip_type :: HWType+  -- ^ Type assigned to port+  } deriving Show++-- | Generate input port(s) associated with a single argument for an+-- instantiation of a top entity. This function composes the input ports into+-- a single signal and returns its name.+mkTopInstInput+  :: ExpandedPortName Identifier+  -- ^ The @PortName@ of a _TopEntity_ annotation for this input.+  -> NetlistMonad ([InstancePort], [Declaration], Identifier)+  -- ^ (ports to assign, declarations for intermediate signals, argument signal)+mkTopInstInput (ExpandedPortName hwty0 pN) = do+  pN' <- Id.next pN+  (decls, pN'', _bvExpr, hwty1) <- toPrimitiveType pN' hwty0+  return ( [InstancePort pN'' hwty1]+          , NetDecl' Nothing pN' hwty0 Nothing : decls+          , pN' )++mkTopInstInput epp@(ExpandedPortProduct pNameHint hwty0 ps) = do+  pName <- Id.makeBasic pNameHint+  let pDecl = NetDecl' Nothing pName hwty0 Nothing++  let+    (attrs, hwty1) = stripAttributes hwty0+    indexPN constr n = Identifier pName (Just (Indexed (hwty0, constr, n)))++  case hwty1 of+    Vector {} -> do+      (ports, decls, ids) <- unzip3 <$> mapM mkTopInstInput ps+      assigns <- zipWithM contAssign ids (map (indexPN 10) [0..])+      if null attrs then+        return (concat ports, pDecl:assigns ++ concat decls, pName)+      else+        throwAnnotatedSplitError $(curLoc) "Vector"++    RTree {} -> do+      (ports, decls, ids) <- unzip3 <$> mapM mkTopInstInput ps+      assigns <- zipWithM contAssign ids (map (indexPN 10) [0..])+      if null attrs then+        return (concat ports, pDecl:assigns ++ concat decls, pName)+      else+        throwAnnotatedSplitError $(curLoc) "RTree"++    Product {} -> do+      (ports, decls, ids) <- unzip3 <$> mapM mkTopInstInput ps+      assigns <- zipWithM contAssign ids (map (indexPN 0) [0..])+      if null attrs then+        return (concat ports, pDecl:assigns ++ concat decls, pName)+      else+        throwAnnotatedSplitError $(curLoc) "Product"++    SP _ ((concat . map snd) -> [elTy]) -> do+      (ports, decls, ids) <- unzip3 <$> mapM mkTopInstInput ps+      case ids of+        [conId,elId] -> do+          let+            conIx = Sliced+              ( BitVector (typeSize hwty1)+              , typeSize hwty1 - 1+              , typeSize elTy )++            elIx = Sliced+              ( BitVector (typeSize hwty1)+              , typeSize elTy - 1+              , 0 )++          assigns <- sequence+              [ contAssign conId (Identifier pName (Just conIx))+              , contAssign elId  (FromBv Nothing elTy (Identifier pName (Just elIx))) ]++          return (concat ports, pDecl:assigns ++ concat decls, pName)+        _ -> error "Internal error: Unexpected error for PortProduct"+    _ ->+      portProductError $(curLoc) hwty0 epp+++-- | Consider the following type signature:+--+-- @+--   f :: Signal dom (Vec 6 A) \`Annotate\` Attr "keep"+--     -> Signal dom (Vec 6 B)+-- @+--+-- What does the annotation mean, considering that Clash will split these+-- vectors into multiple in- and output ports? Should we apply the annotation+-- to all individual ports? How would we handle pin mappings? For now, we simply+-- throw an error. This is a helper function to do so.+throwAnnotatedSplitError+  :: String+  -> String+  -> NetlistMonad a+throwAnnotatedSplitError loc typ = do+  (_,sp) <- Lens.use curCompNm+  throw $ ClashException sp (loc ++ printf msg typ typ) Nothing+ where+  msg = unwords $ [ "Attempted to split %s into a number of HDL ports. This"+                  , "is not allowed in combination with attribute annotations."+                  , "You can annotate %s's components by splitting it up"+                  , "manually." ]++-- | Generate output port(s) for an instantiation of a top entity. This function+-- combines all output ports into a signal identifier and returns its name.+mkTopInstOutput+  :: HasCallStack+  => ExpandedPortName Identifier+  -- ^ The @PortName@ of a _TopEntity_ annotation for this output+  -> NetlistMonad ([InstancePort], [Declaration], Identifier)+  -- ^ (ports to assign, declarations for intermediate signals, result signal)+mkTopInstOutput (ExpandedPortName hwty0 portName) = do+  assignName0 <- Id.next portName+  (decls, assignName1, _expr, hwty1) <- fromPrimitiveType assignName0 hwty0+  let net = NetDecl' Nothing assignName0 hwty1 Nothing+  return ([InstancePort assignName0 hwty1], net : decls, assignName1)++mkTopInstOutput epp@(ExpandedPortProduct productNameHint hwty ps) = do+  pName <- Id.makeBasic productNameHint+  let pDecl = NetDecl' Nothing pName hwty Nothing+  let (attrs, hwty') = stripAttributes hwty+  case hwty' of+    Vector sz hwty'' -> do+      (ports, decls, ids0) <- unzip3 <$> mapM mkTopInstOutput ps+      let ids1 = map (flip Identifier Nothing) ids0+      netassgn <- contAssign pName (mkVectorChain sz hwty'' ids1)+      if null attrs then+        return (concat ports, pDecl:netassgn:concat decls, pName)+      else+        throwAnnotatedSplitError $(curLoc) "Vector"++    RTree d hwty'' -> do+      (ports, decls, ids0) <- unzip3 <$> mapM mkTopInstOutput ps+      let ids1 = map (flip Identifier Nothing) ids0+      netassgn <- contAssign pName (mkRTreeChain d hwty'' ids1)+      if null attrs then+        return (concat ports, pDecl:netassgn:concat decls, pName)+      else+        throwAnnotatedSplitError $(curLoc) "RTree"++    Product {} -> do+      (ports, decls, ids0) <- unzip3 <$> mapM mkTopInstOutput ps+      let ids1 = map (flip Identifier Nothing) ids0+      netassgn <- contAssign pName (DataCon hwty (DC (hwty,0)) ids1)+      if null attrs then+        return (concat ports, pDecl:netassgn:concat decls, pName)+      else+        throwAnnotatedSplitError $(curLoc) "Product"++    SP _ ((concat . map snd) -> [elTy]) -> do+      (ports, decls, ids0) <- unzip3 <$> mapM mkTopInstOutput ps+      let ids1 = map (flip Identifier Nothing) ids0+          ids2 = case ids1 of+                  [conId, elId] -> [conId, ToBv Nothing elTy elId]+                  _ -> error "Unexpected error for PortProduct"+      netassgn <- contAssign pName (DataCon hwty (DC (BitVector (typeSize hwty),0)) ids2)+      return (concat ports, pDecl:netassgn:concat decls, pName)++    _ ->+      portProductError $(curLoc) hwty' epp++-- | Try to merge nested modifiers into a single modifier, needed by the VHDL+-- and SystemVerilog backend.+nestM :: Modifier -> Modifier -> Maybe Modifier+nestM (Nested a b) m2+  | Just m1  <- nestM a b  = maybe (Just (Nested m1 m2)) Just (nestM m1 m2)+  | Just m2' <- nestM b m2 = maybe (Just (Nested a m2')) Just (nestM a m2')++nestM (Indexed (Vector n t1,1,1)) (Indexed (Vector _ t2,1,0))+  | t1 == t2 = Just (Indexed (Vector n t1,10,1))++nestM (Indexed (Vector n t1,1,1)) (Indexed (Vector _ t2,10,k))+  | t1 == t2 = Just (Indexed (Vector n t1,10,k+1))++nestM (Indexed (RTree d1 t1,1,n)) (Indexed (RTree d2 t2,0,0))+  | t1 == t2+  , d1 >= 0+  , d2 >= 0+  = Just (Indexed (RTree d1 t1,10,n))++nestM (Indexed (RTree d1 t1,1,n)) (Indexed (RTree d2 t2,1,m))+  | t1 == t2+  , d1 >= 0+  , d2 >= 0+  = if | n == 1 && m == 1 -> let r = 2 ^ d1+                                 l = r - (2 ^ (d1-1) `div` 2)+                             in  Just (Indexed (RTree (-1) t1, l, r))+       | n == 1 && m == 0 -> let l = 2 ^ (d1-1)+                                 r = l + (l `div` 2)+                             in  Just (Indexed (RTree (-1) t1, l, r))+       | n == 0 && m == 1 -> let l = (2 ^ (d1-1)) `div` 2+                                 r = 2 ^ (d1-1)+                             in  Just (Indexed (RTree (-1) t1, l, r))+       | n == 0 && m == 0 -> let l = 0+                                 r = (2 ^ (d1-1)) `div` 2+                             in  Just (Indexed (RTree (-1) t1, l, r))+       | n > 1 || n < 0   -> error $ "nestM: n should be 0 or 1, not:" ++ show n+       | m > 1 || m < 0   -> error $ "nestM: m should be 0 or 1, not:" ++ show m+       | otherwise        -> error $ "nestM: unexpected (n, m): " ++ show (n, m)+nestM (Indexed (RTree (-1) t1,l,_)) (Indexed (RTree d t2,10,k))+  | t1 == t2+  , d  >= 0+  = Just (Indexed (RTree d t1,10,l+k))++nestM _ _ = Nothing+++-- | Determines if any type variables (exts) are bound in any of the given+-- type or term variables (tms). It's currently only used to detect bound+-- existentials, hence the name.+bindsExistentials+  :: [TyVar]+  -> [Var a]+  -> Bool+bindsExistentials exts tms = any (`elem` freeVars) exts+ where+  freeVars = concatMap (Lens.toListOf typeFreeVars) (map coreTypeOf tms)++-- | Attempt to make an if-then-else construction out of this Case+iteAlts :: HWType -> NonEmpty Alt -> Maybe (Term,Term)+iteAlts sHTy ((pat0,alt0) :| [(pat1,alt1)]) | validIteSTy sHTy = case pat0 of+  DataPat dc _ _ -> case dcTag dc of+    2 -> Just (alt0,alt1)+    _ -> Just (alt1,alt0)+  LitPat (C.IntegerLiteral l) -> case l of+    1 -> Just (alt0,alt1)+    _ -> Just (alt1,alt0)+  DefaultPat -> case pat1 of+    DataPat dc _ _ -> case dcTag dc of+      2 -> Just (alt1,alt0)+      _ -> Just (alt0,alt1)+    LitPat (C.IntegerLiteral l) -> case l of+      1 -> Just (alt1,alt0)+      _ -> Just (alt0,alt1)+    _ -> Nothing+  _ -> Nothing+ where+  validIteSTy Bool          = True+  validIteSTy Bit           = True+  validIteSTy (Sum _ [_,_]) = True+  validIteSTy (SP _ [_,_])  = True+  validIteSTy (Unsigned 1)  = True+  validIteSTy (Index 2)     = True+  validIteSTy _             = False++iteAlts _ _ = Nothing++-- | Run a NetlistMonad computation in the context of the given source ticks and+-- name modifier ticks+withTicks+  :: [TickInfo]+  -> ([Declaration] -> NetlistMonad a)+  -- ^ The source ticks are turned into 'TickDecl's and are passed as an argument+  -- to the NetlistMonad computation. Name modifier ticks will change the local+  -- environment for the NetlistMonad computation.+  -> NetlistMonad a+withTicks ticks0 k = do+  let ticks1 = List.nub ticks0+  go [] (reverse ticks1)+ where+  go decls [] = k (reverse decls)++  go decls (DeDup:ticks) = go decls ticks++  go decls (NoDeDup:ticks) = go decls ticks++  go decls (SrcSpan sp:ticks) =+    go (TickDecl (Comment (Text.pack (showSDocUnsafe (ppr sp)))):decls) ticks++  go decls (Attributes ty attrs0:ticks) = do+    -- We have 'Term', `attrs0`, that represents a value of type `Vec n (Attr String)`.+    -- We want to convert this to an actual value of type `Vec n (Attr String)`, for+    -- which we will use `termToDataError`.+    --+    -- The `termToDataError` only works well for completely evaluated literals.+    -- Sometimes we end up with a term which hasn't been complete beta-reduced, e.g.+    -- `(/\b.Nil 0 b (0~0)) Bool` which represents a value of type `Vec 0 Bool`, for+    -- which `termToDataError` would create an error-value.+    --+    -- To ensure that we only pass literals to `termToDataError` we first evaluate+    -- `attrs0` to Normal Form (NF) using the partial evaluators.+    tcm <- Lens.view tcCache+    case coreView tcm ty of+      LitTy (NumTy n)+        | Just (SomeNat (Proxy :: Proxy n)) <- someNatVal n+        -> if isClosed attrs0 then do+            -- Step 1. Evaluate to normal form+            nm <- Lens.use bindings+            ids <- State.liftIO newSupply+            eval <- Lens.view peEvaluator+            let attrsTy = inferCoreTypeOf tcm attrs0+                -- Safe to use `mkUnsafeSystemName` here, because attrs0 has no+                -- free variables (it's closed), meaning there can be no shadowing+                attrsName = mkUnsafeSystemName "attrs" 0+                attrsId = mkLocalId attrsTy attrsName++                genv = mkGlobalEnv nm tcm emptyInScopeSet ids 20 mempty 0+            -- Force attributes term to Normal Form so that it is a simple literal+            -- that is understood by `termToDataError`.+            (attrs1,_) <- State.liftIO (nf eval genv True attrsId attrs0)++            -- Step 2. Create data from the term+            case termToDataError attrs1 of+              Left msg -> error msg+              Right attrs2 ->+                -- Step 3. Finally add the attributes to the environment.+                let attrs3 = fmap (fmap Text.pack) attrs2+                in local (\env -> env {_localAttrs = V.toList @n attrs3}) (go decls ticks)+           else+            error errFV+      _ -> error errNoNum+   where+    errHeader = "ERROR: cannot add attribues: " <> showPpr attrs0+    errNoNum  = unlines [errHeader+                         ,"REASON: Internal length is not a literal" <> showPpr ty]+    errFV     = unlines [errHeader+                         ,"REASON: attributes mentions variables" <> showPpr attrs0+                         ]++  go decls (NameMod m nm0:ticks) = do+    tcm <- Lens.view tcCache+    case runExcept (tyLitShow tcm nm0) of+      Right nm1 -> local (modName m nm1) (go decls ticks)+      _ -> go decls ticks++  modName PrefixName (Text.pack -> s2) env@(NetlistEnv {_prefixName = s1})+    | Text.null s1 = env {_prefixName = s2}+    | otherwise    = env {_prefixName = s1 <> "_" <> s2}+  modName SuffixName (Text.pack -> s2) env@(NetlistEnv {_suffixName = s1})+    | Text.null s1 = env {_suffixName = s2}+    | otherwise    = env {_suffixName = s2 <> "_" <> s1}+  modName SuffixNameP (Text.pack -> s2) env@(NetlistEnv {_suffixName = s1})+    | Text.null s1 = env {_suffixName = s2}+    | otherwise    = env {_suffixName = s1 <> "_" <> s2}+  modName SetName (Text.pack -> s) env = env {_setName = Just s}++-- | Add the pre- and suffix names in the current environment to the given+-- identifier+affixName+  :: Text+  -> NetlistMonad Text+affixName nm0 = do+  NetlistEnv _ pre suf _ _ _ <- ask+  let nm1 = if Text.null pre then nm0 else pre <> "_" <> nm0+      nm2 = if Text.null suf then nm1 else nm1 <> "_" <> suf+  return nm2++-- | Errors 'expandTopEntity' might yield+data ExpandError+  -- | Synthesis attributes are not supported on PortProducts+  = AttrError [Attr Text]+  -- | Something was annotated as being a PortProduct, but wasn't one+  | PortProductError PortName HWType++-- | Same as 'expandTopEntity', but also adds identifiers to the identifier+-- set of the monad.+expandTopEntityOrErrM+  :: HasCallStack+  => [(Maybe Id, FilteredHWType)]+  -- ^ Arguments. Ids are used as name hints.+  -> (Maybe Id, FilteredHWType)+  -- ^ Result. Id is used as name hint.+  -> Maybe TopEntity+  -- ^ If /Nothing/, an expanded top entity will be generated as if /defSyn/+  -- was passed.+  -> NetlistMonad (ExpandedTopEntity Identifier)+  -- ^ Either some error (see "ExpandError") or and expanded top entity. All+  -- identifiers in the expanded top entity will be added to NetlistState's+  -- IdentifierSet.+expandTopEntityOrErrM ihwtys ohwty topM = do+  is <- identifierSetM id++  case expandTopEntity ihwtys ohwty topM of+    Left (AttrError attrs) ->+      (error [I.i|+        Cannot use attribute annotations on product types of top entities. Saw+        annotation:++          #{attrs}+      |])+    Left (PortProductError pn hwty) ->+      (error [I.i|+        Saw a PortProduct in a Synthesize annotation:++          #{pn}++        but the port type:++          #{hwty}++        is not a product!+      |])+    Right eTop -> do+      let ete = evalState (traverse (either Id.addRaw Id.makeBasic) eTop) (Id.clearSet is)+      Id.addMultiple (toList ete)+      pure ete++-- | Take a top entity and /expand/ its port names. I.e., make sure that every+-- port that should be generated in the HDL is part of the data structure. It+-- works on "FilteredHWType" in order to generate stable port names.+expandTopEntity+  :: HasCallStack+  => [(Maybe Id, FilteredHWType)]+  -- ^ Arguments. Ids are used as name hints.+  -> (Maybe Id, FilteredHWType)+  -- ^ Result. Id is used as name hint.+  -> Maybe TopEntity+  -- ^ Top entity to expand+  -> Either ExpandError (ExpandedTopEntity (Either Text Text))+  -- ^ Either some error (see "ExpandError") or and expanded top entity. The+  -- expanded top entity in turn contains an Either too. /Left/ means that+  -- the name was supplied by the user and should be inserted at verbatim,+  -- /Right/ is a name generated by Clash.+expandTopEntity ihwtys (oId, ohwty) topEntityM+  | Synthesize {..} <- fromMaybe (defSyn (error $(curLoc))) topEntityM = do+  -- TODO 1: Check sizes against number of PortProduct fields+  -- TODO 2: Warn about duplicate fields+  let+    argHints = map (maybe "arg" (Id.toText . Id.unsafeFromCoreId) . fst) ihwtys+    resHint = maybe "result" (Id.toText . Id.unsafeFromCoreId) oId++  inputs <- zipWith3M goInput argHints (map snd ihwtys) (extendPorts t_inputs)++  output <-+    -- BiSignalOut signals are filtered as their counterpart - BiSignalIn - will+    -- be printed as an inout port in HDL.+    if isVoid (stripFiltered ohwty) || isBiSignalOut (stripFiltered ohwty) then+      pure Nothing+    else+      Just <$> goPort resHint ohwty t_output++  pure (ExpandedTopEntity {+      et_inputs = inputs+    , et_output = output+    })+ where+  goInput+    :: Text+    -> FilteredHWType+    -> Maybe PortName+    -> Either ExpandError (Maybe (ExpandedPortName (Either Text Text)))+  goInput hint fHwty@(FilteredHWType hwty _) pM+    | isVoid hwty = Right Nothing+    | otherwise = Just <$> go hint fHwty pM++  -- Vector and RTree are hardcoded as product types, even when instantiated as+  -- /Vec 1 a/ or /RTree 0 a/ respectively.+  isProduct :: FilteredHWType -> Bool+  isProduct (FilteredHWType (CustomProduct {}) _) =+    -- CustomProducts are not yet support in mkTopInput/mkTopOutput so we can't treat+    -- them as product types.+    -- FIXME: Support CustomProduct in top entity annotations+    False+  isProduct (FilteredHWType (Vector {}) _) = True+  isProduct (FilteredHWType (RTree {}) _) = True+  isProduct (FilteredHWType _ [(_:_:_)]) = True+  isProduct _ = False++  go+    :: Text+    -> FilteredHWType+    -> Maybe PortName+    -> Either ExpandError (ExpandedPortName (Either Text Text))+  go hint hwty Nothing = goNoPort hint hwty+  go hint hwty (Just p) = goPort hint hwty p++  goPort+    :: Text+    -> FilteredHWType+    -> PortName+    -> Either ExpandError (ExpandedPortName (Either Text Text))+  goPort hint fHwty@(FilteredHWType hwty _) (PortName "") =+    -- TODO: The following logic makes using /no/ top entity annotation and+    -- TODO: using 'defSyn' behave differently. This is probably not what we+    -- TODO: want.+    if isJust topEntityM then+      -- If top entity annotation was explicitly given, render a single port+      pure (ExpandedPortName hwty (Right hint))+    else+      -- Treat empty 'PortName's as an non-annotated port if no explicit+      -- synthesize annotation was given.+      goNoPort hint fHwty+  goPort _hint (FilteredHWType hwty _) (PortName pn) =+    pure (ExpandedPortName hwty (Left (Text.pack pn)))+  goPort hint0 fHwty@(FilteredHWType hwty0 fields0) pp@(PortProduct p ps0)+    -- Attrs not allowed on product types+    | isProduct fHwty+    , (_:_) <- attrs+    = Left (AttrError attrs)++    -- Product types (products, vec, rtree) of which all but one field are+    -- zero-width.+    | isProduct fHwty+    , [fields1] <- fields0+    , ((_:_), [_]) <- partition fst fields1+    = case [go h t p_ | (h, (False, t), p_) <- zip3 hints fields1 ps1] of+        port:_ -> port+        _ -> error "internal error: insuffient ports"++    -- Product types (products, vec, rtree)+    | isProduct fHwty+    , [fields1] <- fields0+    = ExpandedPortProduct hint1 hwty1 <$>+        sequence [go h t p_ | (h, (False, t), p_) <- zip3 hints fields1 ps1]++    -- Things like "Maybe a" are allowed to be split up using a port+    -- annotation (but won't be split up if it's missing, should it?)+    -- FIXME: We probably shouldn't filter void constructs here, it's+    -- FIXME: inconsistent with how we deal with port annotations elsewhere+    | [(False, eHwty)] <- filter (not . fst) (concat fields0)+    , length fields0 > 1+    , length ps0 == 2+    , conHwty <- FilteredHWType (BitVector (conSize hwty0)) []+    = ExpandedPortProduct hint1 hwty1 <$>+        sequence [go h t p_ | (h, t, p_) <- zip3 hints [conHwty, eHwty] ps1]++    -- Port annotated as PortProduct, but wasn't one+    | otherwise+    = Left (PortProductError pp hwty1)++   where+    hint1 = if null p then hint0 else Text.pack p+    ps1 = extendPorts (map (prefixParent p) ps0)+    hints = map (\i -> hint1 <> "_" <> showt i) [(0::Int)..]+    (attrs, hwty1) = stripAttributes hwty0++  goNoPort+    :: Text+    -> FilteredHWType+    -> Either ExpandError (ExpandedPortName (Either Text Text))+  goNoPort hint fHwty@(FilteredHWType hwty0 fields0)+    -- Attrs not allowed on product types+    | isProduct fHwty+    , (_:_) <- attrs+    = Left (AttrError attrs)++    -- Product types (products, vec, rtree) of which all but one field are+    -- zero-width.+    | isProduct fHwty+    , [fields1] <- fields0+    , ((_:_), [_]) <- partition fst fields1+    = case [goNoPort h t | (h, (False, t)) <- zip hints fields1] of+        port:_ -> port+        _ -> error "internal error: insuffient ports"++    -- Product types (products, vec, rtree)+    | isProduct fHwty+    , [fields1] <- fields0+    = ExpandedPortProduct hint hwty1 <$>+        sequence [goNoPort h t | (h, (False, t)) <- zip hints fields1]++    -- All other types (sum of product, sum, "native")+    | otherwise+    = pure (ExpandedPortName hwty0 (Right hint))+   where+    (attrs, hwty1) = stripAttributes hwty0+    hints = map (\i -> hint <> "_" <> showt i) [(0::Int)..]++expandTopEntity _ _ topEntityM =+  error ("expandTopEntity expects a Synthesize annotation, but got: " <> show topEntityM)++-- | Convert a Core 'C.Literal' to a Netlist v'HW.Literal'+mkLiteral :: Int -- ^ int width+          -> C.Literal -> HW.Expr+mkLiteral iw lit = case lit of+  C.IntegerLiteral i -> HW.Literal (Just (Signed iw,iw)) $ NumLit i+  C.IntLiteral i     -> HW.Literal (Just (Signed iw,iw)) $ NumLit i+  C.WordLiteral w    -> HW.Literal (Just (Unsigned iw,iw)) $ NumLit w+  C.Int64Literal i   -> HW.Literal (Just (Signed 64,64)) $ NumLit i+  C.Word64Literal w  -> HW.Literal (Just (Unsigned 64,64)) $ NumLit w+  C.Int8Literal i    -> HW.Literal (Just (Signed 8,8)) $ NumLit i+  C.Int16Literal i   -> HW.Literal (Just (Signed 16,16)) $ NumLit i+  C.Int32Literal i   -> HW.Literal (Just (Signed 32,32)) $ NumLit i+  C.Word8Literal w   -> HW.Literal (Just (Unsigned 8,8)) $ NumLit w+  C.Word16Literal w  -> HW.Literal (Just (Unsigned 16,16)) $ NumLit w+  C.Word32Literal w  -> HW.Literal (Just (Unsigned 32,32)) $ NumLit w+  C.CharLiteral c    -> HW.Literal (Just (Unsigned 21,21)) . NumLit . toInteger $ ord c+  C.FloatLiteral w   -> HW.Literal (Just (BitVector 32,32)) (NumLit $ toInteger w)+  C.DoubleLiteral w  -> HW.Literal (Just (BitVector 64,64)) (NumLit $ toInteger w)+  C.NaturalLiteral n -> HW.Literal (Just (Unsigned iw,iw)) $ NumLit n+  C.ByteArrayLiteral (ByteArray ba) -> HW.Literal Nothing (NumLit (IP ba))+  C.StringLiteral s  -> HW.Literal Nothing $ StringLit s
+ src/Clash/Normalize.hs view
@@ -0,0 +1,422 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente,+                     2016     , Myrtle Software Ltd,+                     2017     , Google Inc.,+                     2021-2026, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Turn CoreHW terms into normalized CoreHW Terms+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Normalize where++import           Control.Exception                (throw)+import qualified Control.Lens                     as Lens+import           Control.Monad                    ((>=>), when)+import           Control.Monad.State.Strict       (State)+import           Data.Default                     (def)+import           Data.Either                      (lefts,partitionEithers)+import qualified Data.IntMap                      as IntMap+import           Data.List+  (intersect, mapAccumL)+import qualified Data.Map                         as Map+import qualified Data.Maybe                       as Maybe+import qualified Data.Set                         as Set+import qualified Data.Set.Lens                    as Lens++#if MIN_VERSION_prettyprinter(1,7,0)+import           Prettyprinter                    (vcat)+#else+import           Data.Text.Prettyprint.Doc        (vcat)+#endif++import           GHC.BasicTypes.Extra             (isNoInline)++import           Clash.Annotations.BitRepresentation.Internal+  (CustomReprs)+import           Clash.Core.Evaluator.Types as WHNF (Evaluator)+import           Clash.Core.FreeVars+  (freeLocalIds, globalIds)+import           Clash.Core.HasFreeVars           (notElemFreeVars)+import           Clash.Core.HasType+import           Clash.Core.PartialEval as PE     (Evaluator)+import           Clash.Core.Pretty                (PrettyOptions(..), showPpr, showPpr', ppr)+import           Clash.Core.Subst+  (extendGblSubstList, mkSubst, substTm)+import           Clash.Core.Term                  (Term (..), collectArgsTicks+                                                  ,mkApps, mkTicks)+import           Clash.Core.Type                  (Type, splitCoreFunForallTy)+import           Clash.Core.TyCon (TyConMap)+import           Clash.Core.Type                  (isPolyTy)+import           Clash.Core.Var                   (Id, varName, varType)+import           Clash.Core.VarEnv+  (VarEnv, elemVarSet, eltsVarEnv, emptyInScopeSet, emptyVarEnv,+   extendVarEnv, lookupVarEnv, mapVarEnv, mapMaybeVarEnv,+   mkVarEnv, mkVarSet, notElemVarEnv, notElemVarSet, nullVarEnv, unionVarEnv)+import           Clash.Debug                      (traceIf)+import           Clash.Driver.Types+  (BindingMap, Binding(..), DebugOpts(..), ClashEnv(..))+import           Clash.Netlist.Types+  (HWMap, FilteredHWType(..))+import           Clash.Netlist.Util+  (splitNormalized)+import           Clash.Normalize.Strategy+import           Clash.Normalize.Transformations+import           Clash.Normalize.Types+import           Clash.Normalize.Util+import           Clash.Rewrite.Combinators+  ((>->), (!->), bottomupR, repeatR, topdownR)+import           Clash.Rewrite.Types+  (RewriteEnv (..), RewriteState (..), bindings, debugOpts, extra,+   tcCache, topEntities, newInlineStrategy)+import           Clash.Rewrite.Util+  (apply, isUntranslatableType, runRewriteSession)+import           Clash.Util+import           Clash.Util.Interpolate           (i)+import           Clash.Util.Supply                (Supply)++import           Data.Binary                      (encode)+import qualified Data.ByteString                  as BS+import qualified Data.ByteString.Lazy             as BL++import           System.IO.Unsafe                 (unsafePerformIO)+import           Clash.Rewrite.Types (RewriteStep(..))+++-- | Run a NormalizeSession in a given environment+runNormalization+  :: ClashEnv+  -> Supply+  -- ^ UniqueSupply+  -> BindingMap+  -- ^ Global Binders+  -> (CustomReprs -> TyConMap -> Type ->+      State HWMap (Maybe (Either String FilteredHWType)))+  -- ^ Hardcoded Type -> HWType translator+  -> PE.Evaluator+  -- ^ Hardcoded evaluator for partial evaluation+  -> WHNF.Evaluator+  -- ^ Hardcoded evaluator for WHNF (old evaluator)+  -> VarEnv Bool+  -- ^ Map telling whether a components is part of a recursive group+  -> [Id]+  -- ^ topEntities+  -> NormalizeSession a+  -- ^ NormalizeSession to run+  -> IO a+runNormalization env supply globals typeTrans peEval eval rcsMap topEnts =+  runRewriteSession rwEnv rwState+  where+    -- TODO The RewriteEnv should just take ClashOpts.+    rwEnv     = RewriteEnv+                  env+                  typeTrans+                  peEval+                  eval+                  (mkVarSet topEnts)++    rwState   = RewriteState+                  0+                  mempty       -- transformCounters Map+                  globals+                  supply+                  (error $ $(curLoc) ++ "Report as bug: no curFun",noSrcSpan)+                  0+                  (IntMap.empty, 0)+                  emptyVarEnv+                  normState++    normState = NormalizeState+                  emptyVarEnv+                  Map.empty+                  emptyVarEnv+                  emptyVarEnv+                  Map.empty+                  rcsMap++normalize+  :: [Id]+  -> NormalizeSession BindingMap+normalize = go >=> unionWithCache+ where+  go []  = return emptyVarEnv+  go top = do+    (new,topNormalized) <- unzip <$> mapM normalize' top+    newNormalized <- normalize (concat new)+    return (unionVarEnv (mkVarEnv topNormalized) newNormalized)++  unionWithCache :: BindingMap -> NormalizeSession BindingMap+  unionWithCache env = do+    cache <- Lens.use (extra.normalized)+    -- We need to include the cache in our final result, forgetting to do so+    -- leads to https://github.com/clash-lang/clash-compiler/issues/3109+    --+    -- On the other hand, just returning the cache as our final result could+    -- not be enough, because normalize' might return a non-normalized binder+    -- that is later picked up and cleaned up by flattenCallTree.+    return (unionVarEnv cache env)++normalize' :: Id -> NormalizeSession ([Id], (Id, Binding Term))+normalize' nm = do+  exprM <- lookupVarEnv nm <$> Lens.use bindings+  let nmS = showPpr (varName nm)+  case exprM of+    Just (Binding nm' sp inl pr tm r) -> do+      tcm <- Lens.view tcCache+      topEnts <- Lens.view topEntities+      let isTop = nm `elemVarSet` topEnts+          ty0 = coreTypeOf nm'+          ty1 = if isTop then tvSubstWithTyEq ty0 else ty0++      -- check for polymorphic types+      when (isPolyTy ty1) $+        let msg = $curLoc ++ [i|+              Clash can only normalize monomorphic functions, but this is polymorphic:+              #{showPpr' def{displayUniques=False\} nm'}+              |]+            msgExtra | ty0 == ty1 = Nothing+                     | otherwise = Just $ [i|+              Even after applying type equality constraints it remained polymorphic:+              #{showPpr' def{displayUniques=False\} nm'{varType=ty1\}}+                         |]+        in throw (ClashException sp msg msgExtra)++      -- check for unrepresentable result type+      let (args,resTy) = splitCoreFunForallTy tcm ty1+          isTopEnt = nm `elemVarSet` topEnts+          isFunction = not $ null $ lefts args+      resTyRep <- not <$> isUntranslatableType False resTy+      if resTyRep+         then do+            tmNorm <- normalizeTopLvlBndr isTopEnt nm (Binding nm' sp inl pr tm r)+            let usedBndrs = Lens.toListOf globalIds (bindingTerm tmNorm)+            traceIf (bindingRecursive tmNorm)+                    (concat [ $(curLoc),"Expr belonging to bndr: ",nmS ," (:: "+                            , showPpr (coreTypeOf (bindingId tmNorm))+                            , ") remains recursive after normalization:\n"+                            , showPpr (bindingTerm tmNorm) ])+                    (return ())+            prevNorm <- mapVarEnv bindingId <$> Lens.use (extra.normalized)+            let toNormalize = filter (`notElemVarSet` topEnts)+                            $ filter (`notElemVarEnv` (extendVarEnv nm nm prevNorm)) usedBndrs+            return (toNormalize,(nm,tmNorm))+         else+           do+            -- Throw an error for unrepresentable topEntities and functions+            when (isTopEnt || isFunction) $+              let msg = $(curLoc) ++ [i|+                    This bndr has a non-representable return type and can't be normalized:+                    #{showPpr' def{displayUniques=False\} nm'}+                    |]+              in throw (ClashException sp msg Nothing)++            -- But allow the compilation to proceed for nonrepresentable values.+            -- This can happen for example when GHC decides to create a toplevel binder+            -- for the ByteArray# inside of a Natural constant.+            -- (GHC-8.4 does this with tests/shouldwork/Numbers/Exp.hs)+            -- It will later be inlined by flattenCallTree.+            opts <- Lens.view debugOpts+            traceIf (dbg_invariants opts)+                    (concat [$(curLoc), "Expr belonging to bndr: ", nmS, " (:: "+                            , showPpr (coreTypeOf nm')+                            , ") has a non-representable return type."+                            , " Not normalising:\n", showPpr tm] )+                    (return ([],(nm,(Binding nm' sp inl pr tm r))))+++    Nothing -> error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " not found"++-- | Check whether the normalized bindings are non-recursive. Errors when one+-- of the components is recursive.+checkNonRecursive+  :: BindingMap+  -- ^ List of normalized binders+  -> BindingMap+checkNonRecursive norm = case mapMaybeVarEnv go norm of+  rcs | nullVarEnv rcs  -> norm+  rcs -> error $ $(curLoc) ++ "Callgraph after normalization contains following recursive components: "+                   ++ show (vcat [ ppr a <> ppr b+                                 | (a,b) <- eltsVarEnv rcs+                                 ])+ where+  go (Binding nm _ _ _ tm r) =+    if r then Just (nm,tm) else Nothing++-- | Perform general \"clean up\" of the normalized (non-recursive) function+-- hierarchy. This includes:+--+--   * Inlining functions that simply \"wrap\" another function+cleanupGraph+  :: Id+  -> BindingMap+  -> NormalizeSession BindingMap+cleanupGraph topEntity norm+  | Just ct <- mkCallTree [] norm topEntity+  = do ctFlat <- flattenCallTree ct+       return (mkVarEnv $ snd $ callTreeToList [] ctFlat)+cleanupGraph _ norm = return norm++-- | A tree of identifiers and their bindings, with branches containing+-- additional bindings which are used. See "Clash.Driver.Types.Binding".+--+data CallTree+  = CLeaf   (Id, Binding Term)+  | CBranch (Id, Binding Term) [CallTree]++mkCallTree+  :: [Id]+  -- ^ Visited+  -> BindingMap+  -- ^ Global binders+  -> Id+  -- ^ Root of the call graph+  -> Maybe CallTree+mkCallTree visited bindingMap root+  | Just rootTm <- lookupVarEnv root bindingMap+  = let used   = Set.toList $ Lens.setOf globalIds $ (bindingTerm rootTm)+        other  = Maybe.mapMaybe (mkCallTree (root:visited) bindingMap) (filter (`notElem` visited) used)+    in  case used of+          [] -> Just (CLeaf   (root,rootTm))+          _  -> Just (CBranch (root,rootTm) other)+mkCallTree _ _ _ = Nothing++stripArgs+  :: [Id]+  -> [Id]+  -> [Either Term Type]+  -> Maybe [Either Term Type]+stripArgs _      (_:_) []   = Nothing+stripArgs allIds []    args = if any mentionsId args+                                then Nothing+                                else Just args+  where+    mentionsId t = not $ null (either (Lens.toListOf freeLocalIds) (const []) t+                              `intersect`+                              allIds)++stripArgs allIds (id_:ids) (Left (Var nm):args)+      | id_ == nm = stripArgs allIds ids args+      | otherwise = Nothing+stripArgs _ _ _ = Nothing++flattenNode+  :: CallTree+  -> NormalizeSession (Either CallTree ((Id,Term),[CallTree]))+flattenNode c@(CLeaf (_,(Binding _ _ spec _ _ _))) | isNoInline spec = return (Left c)+flattenNode c@(CLeaf (nm,(Binding _ _ _ _ e _))) = do+  isTopEntity <- elemVarSet nm <$> Lens.view topEntities+  if isTopEntity then return (Left c) else do+    tcm  <- Lens.view tcCache+    let norm = splitNormalized tcm e+    case norm of+      Right (ids,[(bId,bExpr)],_) -> do+        let (fun,args,ticks) = collectArgsTicks bExpr+        case stripArgs ids (reverse ids) (reverse args) of+          Just remainder | bId `notElemFreeVars` bExpr ->+               return (Right ((nm,mkApps (mkTicks fun ticks) (reverse remainder)),[]))+          _ -> return (Right ((nm,e),[]))+      _ -> return (Right ((nm,e),[]))+flattenNode b@(CBranch (_,(Binding _ _ spec _ _ _)) _) | isNoInline spec =+  return (Left b)+flattenNode b@(CBranch (nm,(Binding _ _ _ _ e _)) us) = do+  isTopEntity <- elemVarSet nm <$> Lens.view topEntities+  if isTopEntity then return (Left b) else do+    tcm  <- Lens.view tcCache+    let norm = splitNormalized tcm e+    case norm of+      Right (ids,[(bId,bExpr)],_) -> do+        let (fun,args,ticks) = collectArgsTicks bExpr+        case stripArgs ids (reverse ids) (reverse args) of+          Just remainder | bId `notElemFreeVars` bExpr ->+               return (Right ((nm,mkApps (mkTicks fun ticks) (reverse remainder)),us))+          _ -> return (Right ((nm,e),us))+      _ -> do+        newInlineStrat <- Lens.view newInlineStrategy+        if newInlineStrat || isCheapFunction e+           then return (Right ((nm,e),us))+           else return (Left b)++flattenCallTree+  :: CallTree+  -> NormalizeSession CallTree+flattenCallTree c@(CLeaf _) = return c+flattenCallTree (CBranch (nm,(Binding nm' sp inl pr tm r)) used) = do+  flattenedUsed   <- mapM flattenCallTree used+  (newUsed,il_ct) <- partitionEithers <$> mapM flattenNode flattenedUsed+  let (toInline,il_used) = unzip il_ct+      subst = extendGblSubstList (mkSubst emptyInScopeSet) toInline+  newExpr <- case toInline of+    [] -> return tm+    _  -> do+      let tm1 = substTm "flattenCallTree.flattenExpr" subst tm++      -- NB: When -fclash-debug-history is on, emit binary data holding the recorded rewrite steps+      opts <- Lens.view debugOpts+      let rewriteHistFile = dbg_historyFile opts+      when (Maybe.isJust rewriteHistFile) $+        let !_ = unsafePerformIO+             $ BS.appendFile (Maybe.fromJust rewriteHistFile)+             $ BL.toStrict+             $ encode RewriteStep+                 { t_ctx    = []+                 , t_name   = "INLINE"+                 , t_bndrS  = showPpr (varName nm')+                 , t_before = tm+                 , t_after  = tm1+                 }+        in pure ()+      rewriteExpr ("flattenExpr",flatten) (showPpr nm, tm1) (nm', sp)+  let allUsed = newUsed ++ concat il_used+  -- inline all components when the resulting expression after flattening+  -- is still considered "cheap". This happens often at the topEntity which+  -- wraps another functions and has some selectors and data-constructors.+  if not (isNoInline inl) && isCheapFunction newExpr+     then do+        let (toInline',allUsed') = unzip (map goCheap allUsed)+            subst' = extendGblSubstList (mkSubst emptyInScopeSet)+                                        (Maybe.catMaybes toInline')+        let tm1 = substTm "flattenCallTree.flattenCheap" subst' newExpr+        newExpr' <- rewriteExpr ("flattenCheap",flatten) (showPpr nm, tm1) (nm', sp)+        return (CBranch (nm,(Binding nm' sp inl pr newExpr' r)) (concat allUsed'))+     else return (CBranch (nm,(Binding nm' sp inl pr newExpr r)) allUsed)+  where+    flatten =+      repeatR (topdownR (apply "appProp" appProp >->+                 apply "bindConstantVar" bindConstantVar >->+                 apply "caseCon" caseCon >->+                 (apply "reduceConst" reduceConst !-> apply "deadcode" deadCode) >->+                 apply "reduceNonRepPrim" reduceNonRepPrim >->+                 apply "removeUnusedExpr" removeUnusedExpr) >->+               bottomupR (apply "flattenLet" flattenLet)) !->+      topdownSucR (apply "topLet" topLet) >->+      -- See [Note] relation `collapseRHSNoops` and `inlineCleanup`+      -- Note that we do this as the very last step, after all constant propagation+      -- has been done to avoid #3036.+      topdownSucR (apply "collapseRHSNoops" collapseRHSNoops) >->+      topdownSucR (apply "inlineCleanup" inlineCleanup) >->+      bottomupR (apply "caseCon" caseCon) >-> -- https://github.com/clash-lang/clash-compiler/issues/3159 / #3204+      bottomupR (apply "flattenLet" flattenLet) >-> -- https://github.com/clash-lang/clash-compiler/issues/3185+      topdownSucR (apply "topLet" topLet)++    goCheap c@(CLeaf   (nm2,(Binding _ _ inl2 _ e _)))+      | isNoInline inl2  = (Nothing     ,[c])+      | otherwise        = (Just (nm2,e),[])+    goCheap c@(CBranch (nm2,(Binding _ _ inl2 _ e _)) us)+      | isNoInline inl2  = (Nothing, [c])+      | otherwise        = (Just (nm2,e),us)++callTreeToList :: [Id] -> CallTree -> ([Id], [(Id, Binding Term)])+callTreeToList visited (CLeaf (nm,bndr))+  | nm `elem` visited = (visited,[])+  | otherwise         = (nm:visited,[(nm,bndr)])+callTreeToList visited (CBranch (nm,bndr) used)+  | nm `elem` visited = (visited,[])+  | otherwise         = (visited',(nm,bndr):(concat others))+  where+    (visited',others) = mapAccumL callTreeToList (nm:visited) used
+ src/Clash/Normalize/PrimitiveReductions.hs view
@@ -0,0 +1,1381 @@+{-|+  Copyright  :  (C) 2015-2016, University of Twente,+                    2016     , Myrtle Software Ltd,+                    2021-2024, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Reductions of primitives++  Currently, it contains reductions for:++    * Clash.Sized.Vector.map+    * Clash.Sized.Vector.zipWith+    * Clash.Sized.Vector.traverse#+    * Clash.Sized.Vector.foldr+    * Clash.Sized.Vector.fold+    * Clash.Sized.Vector.dfold+    * Clash.Sized.Vector.(++)+    * Clash.Sized.Vector.head+    * Clash.Sized.Vector.tail+    * Clash.Sized.Vector.unconcatBitVector#+    * Clash.Sized.Vector.replicate+    * Clash.Sized.Vector.imap+    * Clash.Sized.Vector.dtfold+    * Clash.Sized.RTree.tfold+    * Clash.Sized.Vector.reverse+    * Clash.Sized.Vector.unconcat++  Partially handles:++    * Clash.Sized.Vector.transpose+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++module Clash.Normalize.PrimitiveReductions where++import qualified Control.Lens                     as Lens+import           Control.Lens                     ((.=))+import           Control.Monad.Trans.Class        (lift)+import           Control.Monad.Trans.Maybe        (MaybeT (..))+import           Data.Bifunctor                   (second)+import           Data.List                        (mapAccumR, uncons)+import           Data.List.Extra                  (zipEqual)+#if MIN_VERSION_base(4,20,0)+import qualified Data.List.NonEmpty               as NE hiding (unzip)+import qualified Data.Functor                     as NE+#else+import qualified Data.List.NonEmpty               as NE+#endif+import qualified Data.Maybe                       as Maybe+import           Data.Semigroup                   (sconcat)+import           Data.Text.Extra                  (showt)+import           GHC.Stack                        (HasCallStack)++import           GHC.Builtin.Names+  (boolTyConKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey,+   typeNatSubTyFamNameKey)+import           GHC.Types.SrcLoc                 (wiredInSrcSpan)++import           Clash.Core.DataCon               (DataCon)+import           Clash.Core.FreeVars              (typeFreeVars)+import           Clash.Core.HasType++import           Clash.Core.Literal               (Literal (..))+import           Clash.Core.Name+  (nameOcc, Name(..), NameSort(User), mkUnsafeSystemName)+import           Clash.Core.Pretty                (showPpr)+import           Clash.Core.Subst                 (extendTvSubst, mkSubst, substTy)+import           Clash.Core.Term+  (IsMultiPrim (..), CoreContext (..), PrimInfo (..), Term (..), WorkInfo (..), Pat (..),+   collectTermIds, mkApps, PrimUnfolding(..))+import           Clash.Core.Type                  (LitTy (..), Type (..),+                                                   TypeView (..), coreView1,+                                                   mkFunTy, mkTyConApp,+                                                   normalizeType,+                                                   splitFunForallTy, tyView)+import           Clash.Core.TyCon+  (TyConMap, TyConName, tyConDataCons, tyConName)+import           Clash.Core.TysPrim+  (integerPrimTy, typeNatKind, liftedTypeKind)+import           Clash.Core.Util+  (appendToVec, extractElems, extractTElems, mkRTree,+   mkUniqInternalId, mkUniqSystemTyVar, mkVec, dataConInstArgTys, primCo)+import           Clash.Core.Var                   (mkTyVar, mkLocalId)+import           Clash.Core.VarEnv                (extendInScopeSetList)+import qualified Clash.Data.UniqMap as UniqMap+import qualified Clash.Normalize.Primitives as NP (undefined)+import {-# SOURCE #-} Clash.Normalize.Strategy+import           Clash.Normalize.Types+import           Clash.Rewrite.Types+import           Clash.Rewrite.Util+import           Clash.Unique (fromGhcUnique)+import           Clash.Util+import qualified Clash.Util.Interpolate           as I++typeNatAdd :: TyConName+typeNatAdd =+  Name User "GHC.TypeNats.+" (fromGhcUnique typeNatAddTyFamNameKey) wiredInSrcSpan++typeNatMul :: TyConName+typeNatMul =+  Name User "GHC.TypeNats.*" (fromGhcUnique typeNatMulTyFamNameKey) wiredInSrcSpan++typeNatSub :: TyConName+typeNatSub =+  Name User "GHC.TypeNats.-" (fromGhcUnique typeNatSubTyFamNameKey) wiredInSrcSpan++vecHeadPrim+  :: TyConName+  -- ^ Vec TyCon name+  -> Term+vecHeadPrim vecTcNm =+ -- head :: Vec (n+1) a -> a+  Prim (PrimInfo "Clash.Sized.Vector.head" (vecHeadTy vecTcNm) WorkNever SingleResult NoUnfolding)++vecLastPrim+  :: TyConName+  -- ^ Vec TyCon name+  -> Term+vecLastPrim vecTcNm =+  -- last :: Vec (n+1) a -> a+  -- has the same type signature as head, hence we're reusing its type+  -- definition here.+  Prim (PrimInfo "Clash.Sized.Vector.last" (vecHeadTy vecTcNm) WorkNever SingleResult NoUnfolding)++vecHeadTy+  :: TyConName+  -- ^ Vec TyCon name+  -> Type+vecHeadTy vecNm =+  ForAllTy nTV $+  ForAllTy aTV $+  mkFunTy+    (mkTyConApp vecNm [mkTyConApp typeNatAdd [VarTy nTV, LitTy (NumTy 1)], VarTy aTV])+    (VarTy aTV)+ where+  aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 0)+  nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 1)++vecTailPrim+  :: TyConName+  -- ^ Vec TyCon name+  -> Term+vecTailPrim vecTcNm =+  -- tail :: Vec (n + 1) a -> Vec n a+  Prim (PrimInfo "Clash.Sized.Vector.tail" (vecTailTy vecTcNm) WorkNever SingleResult NoUnfolding)++vecInitPrim+  :: TyConName+  -- ^ Vec TyCon name+  -> Term+vecInitPrim vecTcNm =+  -- init :: Vec (n + 1) a -> Vec n a+  -- has the same type signature as tail, hence we're reusing its type+  -- definition here.+  Prim (PrimInfo "Clash.Sized.Vector.init" (vecTailTy vecTcNm) WorkNever SingleResult NoUnfolding)++vecTailTy+  :: TyConName+  -- ^ Vec TyCon name+  -> Type+vecTailTy vecNm =+  ForAllTy nTV $+  ForAllTy aTV $+  mkFunTy+    (mkTyConApp vecNm [mkTyConApp typeNatAdd [VarTy nTV, LitTy (NumTy 1)], VarTy aTV])+    (mkTyConApp vecNm [VarTy nTV, VarTy aTV])+ where+  nTV = mkTyVar typeNatKind (mkUnsafeSystemName "n" 0)+  aTV = mkTyVar liftedTypeKind (mkUnsafeSystemName "a" 1)++-- | Makes two case statements: the first one extract the _head_ from the given+-- vector, the latter the tail.+extractHeadTail+  :: DataCon+  -- ^ The Cons (:>) constructor+  -> Type+  -- ^ Element type+  -> Integer+  -- ^ Length of the vector, must be positive+  -> Term+  -- ^ Vector to extract head from+  -> (Term, Term)+  -- ^ (head of vector, tail of vector)+extractHeadTail consCon elTy n vec =+  case dataConInstArgTys consCon tys of+    Just [coTy, _elTy, restTy] ->+      let+        mTV = mkTyVar typeNatKind (mkUnsafeSystemName "m" 0)+        co = mkLocalId coTy (mkUnsafeSystemName "_co_" 1)+        el = mkLocalId elTy (mkUnsafeSystemName "el" 2)+        rest = mkLocalId restTy (mkUnsafeSystemName "res" 3)++        pat = DataPat consCon [mTV] [co, el, rest]+      in+        ( Case vec elTy [(pat, Var el)]+        , Case vec restTy [(pat, Var rest)] )+    _ -> error "extractHeadTail: failed to instantiate Cons DC"+ where+  tys = [(LitTy (NumTy n)), elTy, (LitTy (NumTy (n-1)))]++-- | Create a vector of supplied elements+mkVecCons+  :: HasCallStack+  => DataCon+  -- ^ The Cons (:>) constructor+  -> Type+  -- ^ Element type+  -> Integer+  -- ^ Length of the vector+  -> Term+  -- ^ head of the vector+  -> Term+  -- ^ tail of the vector+  -> Term+mkVecCons consCon resTy n h t+  | n <= 0 = error "mkVecCons: n <= 0"+  | otherwise+  = case dataConInstArgTys consCon [LitTy (NumTy n), resTy, LitTy (NumTy (n-1))] of+    Just (consCoTy : _) ->+      mkApps (Data consCon) [ Right (LitTy (NumTy n))+                            , Right resTy+                            , Right (LitTy (NumTy (n-1)))+                            , Left (primCo consCoTy)+                            , Left h+                            , Left t ]+    _ -> error "mkVecCons: failed to instantiate Cons DC"++-- | Create an empty vector+mkVecNil+  :: DataCon+  -- ^ The Nil constructor+  -> Type+  -- ^ The element type+  -> Term+mkVecNil nilCon resTy = case dataConInstArgTys nilCon [LitTy (NumTy 0), resTy] of+  Just (nilCoTy : _) ->+    mkApps (Data nilCon) [ Right (LitTy (NumTy 0))+                        , Right resTy+                        , Left  (primCo nilCoTy) ]+  _ -> error "mkVecNil: failed to instantiate Nil DC"++-- | Replace an application of the @Clash.Sized.Vector.reverse@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.Vector.reverse@+reduceReverse+  :: Integer+  -- ^ Length of the vector, must be positive+  -> Type+  -- ^ Element of type of the vector+  -> Term+  -- ^ The vector to reverse+  -> TransformContext+  -> NormalizeSession Term+reduceReverse n elTy vArg (TransformContext inScope0 _ctx) = do+  tcm <- Lens.view tcCache+  let ty = inferCoreTypeOf tcm vArg+  go tcm ty+ where+  go tcm (coreView1 tcm -> Just ty') = go tcm ty'+  go tcm (tyView -> TyConApp vecTcNm _)+    | Just vecTc <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+    , [nilCon, consCon] <- tyConDataCons vecTc+    = do+      uniqs0 <- Lens.use uniqSupply+      let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip)+                                $ extractElems uniqs0 inScope0 consCon elTy 'V' n vArg+          lbody = mkVec nilCon consCon elTy n (reverse (NE.toList vars))+          lb    = Letrec (NE.init elems) lbody+      uniqSupply Lens..= uniqs1+      changed lb+  go _ ty = error $ $(curLoc) ++ "reduceReverse: argument does not have a vector type: " ++ showPpr ty++-- | Replace an application of the @Clash.Sized.Vector.zipWith@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.Vector.zipWith@+reduceZipWith+  :: PrimInfo -- ^ zipWith primitive info+  -> Integer  -- ^ Length of the vector(s)+  -> Type -- ^ Element type of the lhs of the function+  -> Type -- ^ Element type of the rhs of the function+  -> Type -- ^ Element type of the result of the function+  -> Term -- ^ The zipWith'd functions+  -> Term -- ^ The 1st vector argument+  -> Term -- ^ The 2nd vector argument+  -> TransformContext+  -> NormalizeSession Term+reduceZipWith zipWithPrimInfo n lhsElTy rhsElTy resElTy fun lhsArg rhsArg _ctx = do+  tcm <- Lens.view tcCache+  changed (go tcm (inferCoreTypeOf tcm lhsArg))+ where+  go tcm (coreView1 tcm -> Just ty) = go tcm ty+  go tcm (tyView -> TyConApp vecTcNm _)+    | (Just vecTc) <- UniqMap.lookup vecTcNm tcm+    , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+    , [nilCon, consCon] <- tyConDataCons vecTc+    = if n == 0 then+        mkVecNil nilCon resElTy+      else+        let+          (a, as) = extractHeadTail consCon lhsElTy n lhsArg+          (b, bs) = extractHeadTail consCon rhsElTy n rhsArg+          c = mkApps fun [Left a, Left b]+          cs = mkApps (Prim zipWithPrimInfo) [ Right lhsElTy+                                             , Right rhsElTy+                                             , Right resElTy+                                             , Right (LitTy (NumTy (n - 1)))+                                             , Left fun+                                             , Left as+                                             , Left bs ]+        in+          mkVecCons consCon resElTy n c cs+  go _ ty =+    error $ $(curLoc) ++ [I.i|+      reduceZipWith: argument does not have a vector type:++        #{showPpr ty}+    |]++-- | Replace an application of the @Clash.Sized.Vector.map@ primitive on vectors+-- of a known length @n@, by the fully unrolled recursive "definition" of+-- @Clash.Sized.Vector.map@+reduceMap+  :: PrimInfo -- ^ map primitive info+  -> Integer  -- ^ Length of the vector+  -> Type -- ^ Argument type of the function+  -> Type -- ^ Result type of the function+  -> Term -- ^ The map'd function+  -> Term -- ^ The map'd over vector+  -> TransformContext+  -> NormalizeSession Term+reduceMap mapPrimInfo n argElTy resElTy fun arg _ctx = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm arg+    changed (go tcm ty)+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [nilCon,consCon] <- tyConDataCons vecTc+      = if n == 0 then+          mkVecNil nilCon argElTy+        else+          let+            nPredTy = Right (LitTy (NumTy (n - 1)))+            (a, as) = extractHeadTail consCon argElTy n arg+            b = mkApps fun [Left a]+            bs = mkApps (Prim mapPrimInfo) [ Right argElTy+                                           , Right resElTy+                                           , nPredTy+                                           , Left fun+                                           , Left as ]+          in+            mkVecCons consCon resElTy n b bs+    go _ ty =+      error $ $(curLoc) ++ [I.i|+        reduceMap: argument does not have a vector type:++          #{showPpr ty}+      |]++-- | Replace an application of the @Clash.Sized.Vector.imap@ primitive on vectors+-- of a known length @n@, by the fully unrolled recursive "definition" of+-- @Clash.Sized.Vector.imap@+reduceImap+  :: Integer  -- ^ Length of the vector, must be positive+  -> Type -- ^ Argument type of the function+  -> Type -- ^ Result type of the function+  -> Term -- ^ Lenght of the vector (as a KnownNat)+  -> Term -- ^ The imap'd function+  -> Term -- ^ The imap'd over vector+  -> TransformContext+  -> NormalizeSession Term+reduceImap n argElTy resElTy _kn fun arg (TransformContext is0 ctx) = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm arg+    go tcm ty+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [nilCon,consCon] <- tyConDataCons vecTc+      = do+        uniqs0 <- Lens.use uniqSupply+        fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun+        let is1 = extendInScopeSetList is0 (collectTermIds fun1)+            (uniqs1,nTv) = mkUniqSystemTyVar (uniqs0,is1) ("n",typeNatKind)+            (uniqs2,(vars,elems)) = second (second sconcat . NE.unzip)+                                  $ uncurry extractElems uniqs1 consCon argElTy 'I' n arg+            idxTcNm = Maybe.fromMaybe (error "reduceImap: failed to create Index TC") $ do+              (Right idxTy:_,_) <- pure (splitFunForallTy (inferCoreTypeOf tcm fun))+              TyConApp nm _ <- pure (tyView idxTy)+              return nm+            -- fromInteger# :: KnownNat n => Integer -> Index n+            idxFromIntegerTy = ForAllTy nTv+                                        (foldr mkFunTy+                                               (mkTyConApp idxTcNm+                                                           [VarTy nTv])+                                               [integerPrimTy,integerPrimTy])+            idxFromInteger   = Prim (PrimInfo "Clash.Sized.Internal.Index.fromInteger#" idxFromIntegerTy WorkNever SingleResult NoUnfolding)+            idxs             = map (App (App (TyApp idxFromInteger (LitTy (NumTy n)))+                                             (Literal (IntegerLiteral (toInteger n))))+                                   . Literal . IntegerLiteral . toInteger) [0..(n-1)]+            funApps          = zipWith (\i v -> App (App fun1 i) v) idxs (NE.toList vars)+            lbody            = mkVec nilCon consCon resElTy n funApps+            lb               = Letrec (NE.init elems) lbody+        uniqSupply Lens..= uniqs2+        changed lb+    go _ ty = error $ $(curLoc) ++ "reduceImap: argument does not have a vector type: " ++ showPpr ty++-- | Replace an application of the @Clash.Sized.Vector.iterateI@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.Vector.iterateI@+reduceIterateI+  :: Integer+  -- ^ Length of vector+  -> Type+  -- ^ Vector's element type+  -> Type+  -- ^ Vector's type+  -> Term+  -- ^ Length of the vector (as a KnownNat)+  -> Term+  -- ^ iterateI's HO-function argument+  -> Term+  -- ^ iterateI's start value+  -> TransformContext+  -> RewriteMonad NormalizeState Term+  -- ^ Fully unrolled definition+reduceIterateI n aTy vTy _kn f0 a (TransformContext is0 ctx) = do+  tcm <- Lens.view tcCache+  f1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) f0++  -- Generate uniq ids for element assignments.+  uniqs0 <- Lens.use uniqSupply+  let+    is1 = extendInScopeSetList is0 (collectTermIds f1)+    ((uniqs1, _is2), elementIds) =+      mapAccumR+        mkUniqInternalId+        (uniqs0, is1)+        (zip (map (("el" <>) . showt) [1..n-1]) (repeat aTy))+  uniqSupply .= uniqs1++  let+    elems = map (App f1) (a:map Var elementIds)+    vec = Maybe.fromMaybe (error "reduceIterateI: failed to create Vec DCs") $ do+      TyConApp vecTcNm _ <- pure (tyView vTy)+      vecTc <- UniqMap.lookup vecTcNm tcm+      [nilCon, consCon] <- pure (tyConDataCons vecTc)+      return (mkVec nilCon consCon aTy n (take (fromInteger n) (a:map Var elementIds)))++  -- Result:+  --   let+  --     el1 = f a+  --     el2 = f el1+  --     el3 = f el2+  --     ..+  --   in+  --     (a :> el1 :> el2 :> el3 :> ..)+  --+  changed (Letrec (zip elementIds elems) vec)++-- | Replace an application of the @Clash.Sized.Vector.traverse#@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.Vector.traverse#@+reduceTraverse+  :: Integer  -- ^ Length of the vector, must be positive+  -> Type -- ^ Element type of the argument vector+  -> Type -- ^ The type of the applicative+  -> Type -- ^ Element type of the result vector+  -> Term -- ^ The @Applicative@ dictionary+  -> Term -- ^ The function to traverse with+  -> Term -- ^ The argument vector+  -> TransformContext+  -> NormalizeSession Term+reduceTraverse n aTy fTy bTy dict fun arg (TransformContext is0 ctx) = do+    tcm <- Lens.view tcCache+    case tyView (inferCoreTypeOf tcm dict) of+      TyConApp apDictTcNm _ ->+        let ty = inferCoreTypeOf tcm arg+         in go tcm apDictTcNm ty+      t -> error ("reduceTraverse: expected a TC, but got: " <> show t)+  where+    go tcm apDictTcNm (coreView1 tcm -> Just ty') = go tcm apDictTcNm ty'+    go tcm apDictTcNm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [nilCon,consCon] <- tyConDataCons vecTc+      = fmap (Maybe.fromMaybe (error "reduceTraverse: failed to build")) $ runMaybeT $ do+          uniqs0 <- Lens.use uniqSupply+          fun1 <- lift (constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun)+          let is1 = extendInScopeSetList is0 (collectTermIds fun1)+          apDictTc <- hoistMaybe (UniqMap.lookup apDictTcNm tcm)+          apDictCon <- hoistMaybe (Maybe.listToMaybe (tyConDataCons apDictTc))+          apDictIdTys <- hoistMaybe (dataConInstArgTys apDictCon [fTy])+          (uniqs1,apDictIds@[functorDictId,pureId,apId,_,_,_]) <- pure $+                mapAccumR mkUniqInternalId (uniqs0,is1)+                  (zipEqual ["functorDict","pure","ap","liftA2","apConstL","apConstR"]+                      apDictIdTys)++          TyConApp funcDictTcNm _ <- hoistMaybe (tyView <$> Maybe.listToMaybe apDictIdTys)+          funcDictTc <- hoistMaybe (UniqMap.lookup funcDictTcNm tcm)+          funcDictCon <- hoistMaybe (Maybe.listToMaybe (tyConDataCons funcDictTc))+          funcDictIdTys <- hoistMaybe (dataConInstArgTys funcDictCon [fTy])+          (uniqs2,funcDicIds@[fmapId,_]) <- pure $+                mapAccumR mkUniqInternalId uniqs1+                  (zipEqual ["fmap","fmapConst"] funcDictIdTys)++          let apPat    = DataPat apDictCon   [] apDictIds+              fnPat    = DataPat funcDictCon [] funcDicIds++              -- Extract the 'pure' function from the Applicative dictionary+              pureTy = coreTypeOf pureId+              pureTm = Case dict pureTy [(apPat,Var pureId)]++              -- Extract the '<*>' function from the Applicative dictionary+              apTy   = coreTypeOf apId+              apTm   = Case dict apTy [(apPat, Var apId)]++              -- Extract the Functor dictionary from the Applicative dictionary+              funcTy = coreTypeOf functorDictId+              funcTm = Case dict funcTy+                                [(apPat,Var functorDictId)]++              -- Extract the 'fmap' function from the Functor dictionary+              fmapTy = coreTypeOf fmapId+              fmapTm = Case (Var functorDictId) fmapTy+                            [(fnPat, Var fmapId)]++              (uniqs3,(vars,elems)) = second (second sconcat . NE.unzip)+                                    $ uncurry extractElems uniqs2 consCon aTy 'T' n arg++              funApps = map (fun1 `App`) (NE.toList vars)++              lbody   = mkTravVec vecTcNm nilCon consCon (Var (apDictIds!!1))+                                                        (Var (apDictIds!!2))+                                                        (Var (funcDicIds!!0))+                                                        bTy n funApps++              lb      = Letrec ([((apDictIds!!0), funcTm)+                                ,((apDictIds!!1), pureTm)+                                ,((apDictIds!!2), apTm)+                                ,((funcDicIds!!0), fmapTm)+                                ] ++ NE.init elems) lbody+          uniqSupply Lens..= uniqs3+          lift (changed lb)+    go _ _ ty = error $ $(curLoc) ++ "reduceTraverse: argument does not have a vector type: " ++ showPpr ty++-- | Create the traversable vector+--+-- e.g. for a length '2' input vector, we get+--+-- > (:>) <$> x0 <*> ((:>) <$> x1 <*> pure Nil)+mkTravVec :: TyConName -- ^ Vec tcon+          -> DataCon   -- ^ Nil con+          -> DataCon   -- ^ Cons con+          -> Term      -- ^ 'pure' term+          -> Term      -- ^ '<*>' term+          -> Term      -- ^ 'fmap' term+          -> Type      -- ^ 'b' ty+          -> Integer       -- ^ Length of the vector+          -> [Term]    -- ^ Elements of the vector+          -> Term+mkTravVec vecTc nilCon consCon pureTm apTm fmapTm bTy = go+  where+    go :: Integer -> [Term] -> Term+    go _ [] = mkApps pureTm [Right (mkTyConApp vecTc [LitTy (NumTy 0),bTy])+                            ,Left  (mkApps (Data nilCon)+                                           [Right (LitTy (NumTy 0))+                                           ,Right bTy+                                           ,Left  (primCo nilCoTy)])]++    go n (x:xs) = mkApps apTm+      [Right (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy])+      ,Right (mkTyConApp vecTc [LitTy (NumTy n),bTy])+      ,Left (mkApps fmapTm [Right bTy+                           ,Right (mkFunTy (mkTyConApp vecTc [LitTy (NumTy (n-1)),bTy])+                                           (mkTyConApp vecTc [LitTy (NumTy n),bTy]))+                           ,Left  (mkApps (Data consCon)+                                          [Right (LitTy (NumTy n))+                                          ,Right bTy+                                          ,Right (LitTy (NumTy (n-1)))+                                          ,Left  (primCo (consCoTy n))+                                          ])+                           ,Left  x])+      ,Left (go (n-1) xs)]++    nilCoTy = case dataConInstArgTys nilCon [(LitTy (NumTy 0)), bTy] of+                Just (x:_) -> x+                _ -> error "impossible"++    consCoTy n = case dataConInstArgTys consCon+                                        [(LitTy (NumTy n))+                                        ,bTy+                                        ,(LitTy (NumTy (n-1)))] of+                   Just (x:_) -> x+                   _ -> error "impossible"++-- | Replace an application of the @Clash.Sized.Vector.foldr@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.Vector.foldr@+reduceFoldr+  :: PrimInfo+  -- ^ Primitive info for foldr blackbox+  -> Integer+  -- ^ Length of the vector+  -> Type+  -- ^ Element type of the argument vector+  -> Term+  -- ^ The function to fold with+  -> Term+  -- ^ The starting value+  -> Term+  -- ^ The argument vector+  -> TransformContext+  -> NormalizeSession Term+reduceFoldr _ 0 _ _ start _ _ = changed start+reduceFoldr foldrPrimInfo n aTy fun start arg _ctx = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm arg+    changed (go tcm ty)+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , Just vecTc <- UniqMap.lookup vecTcNm tcm+      , [_nilCon, consCon] <- tyConDataCons vecTc+      = let+          (a, as) = extractHeadTail consCon aTy n arg+          b = mkApps (Prim foldrPrimInfo) [ Right aTy+                                          , Right (inferCoreTypeOf tcm start)+                                          , Right (LitTy (NumTy (n - 1)))+                                          , Left fun+                                          , Left start+                                          , Left as ]+        in+          mkApps fun [Left a, Left b]++    go _ ty =+      error $ $(curLoc) ++ [I.i|+        reduceFoldr: argument does not have a vector type:++          #{showPpr ty}+      |]++-- | Replace an application of the @Clash.Sized.Vector.fold@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.Vector.fold@+reduceFold+  :: Integer+  -- ^ Length of the vector, must be positive+  -> Type+  -- ^ Element type of the argument vector+  -> Term+  -- ^ The function to fold with+  -> Term+  -- ^ The argument vector+  -> TransformContext+  -> NormalizeSession Term+reduceFold n aTy fun arg (TransformContext is0 ctx) = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm arg+    go tcm ty+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [_,consCon]  <- tyConDataCons vecTc+      = do+        uniqs0 <- Lens.use uniqSupply+        fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun+        let is1 = extendInScopeSetList is0 (collectTermIds fun1)+            (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip)+                                  $ extractElems uniqs0 is1 consCon aTy 'F' n arg+            lbody            = foldV fun1 (NE.toList vars)+            lb               = Letrec (NE.init elems) lbody+        uniqSupply Lens..= uniqs1+        changed lb+    go _ ty = error $ $(curLoc) ++ "reduceFold: argument does not have a vector type: " ++ showPpr ty++    foldV _ [a] = a+    foldV f as  = let (l,r) = splitAt (length as `div` 2) as+                      lF    = foldV f l+                      rF    = foldV f r+                  in  mkApps f [Left lF, Left rF]++-- | Replace an application of the @Clash.Sized.Vector.dfold@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.Vector.dfold@+reduceDFold+  :: Integer+  -- ^ Length of the vector+  -> Type+  -- ^ Element type of the argument vector+  -> Term+  -- ^ Length of the vector (as a KnownNat)+  -> Term+  -- ^ The motive+  -> Term+  -- ^ Function to fold with+  -> Term+  -- ^ Starting value+  -> Term+  -- ^ The vector to fold+  -> TransformContext+  -> NormalizeSession Term+reduceDFold 0 _   _   _       _   start _   _ = changed start+reduceDFold n aTy _kn _motive fun start arg (TransformContext is0 _ctx) = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm arg+    go tcm ty+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [_,consCon]  <- tyConDataCons vecTc+      = do+        uniqs0 <- Lens.use uniqSupply+        let is1 = extendInScopeSetList is0 (collectTermIds fun)+            -- TODO: Should 'constantPropagation' be used on 'fun'? It seems to+            -- TOOD: be used for every other function in this module.+            (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip)+                                  $ extractElems uniqs0 is1 consCon aTy 'D' n arg+            snatDc = Maybe.fromMaybe (error "reduceDFold: faild to build SNat") $ do+              (_ltv:_rubp:Right snTy:_,_) <- pure (splitFunForallTy (inferCoreTypeOf tcm fun))+              (TyConApp snatTcNm _) <- pure (tyView snTy)+              snatTc <- UniqMap.lookup snatTcNm tcm+              Maybe.listToMaybe (tyConDataCons snatTc)+            ubp k = Maybe.fromMaybe+              (error "reduceDFold: failed to extract upper bound proof") $ do+                (_ltv:Right ubpT:_,_) <- pure (splitFunForallTy (inferCoreTypeOf tcm fun))+                -- toListOf does not de-duplicate, but we know that there is only+                -- one free variable in here, thus, taking the first element is fine+                (tvN, _) <- uncons $ Lens.toListOf typeFreeVars ubpT+                let subst = extendTvSubst (mkSubst is0) tvN (LitTy (NumTy k))+                let witness = normalizeType tcm (substTy subst ubpT)+                (TyConApp tupTcNm _) <- pure (tyView witness)+                witnessTc <- UniqMap.lookup tupTcNm tcm+                Maybe.listToMaybe (tyConDataCons witnessTc)+            lbody = doFold ubp (buildSNat snatDc) (n-1) (NE.toList vars)+            lb    = Letrec (NE.init elems) lbody+        uniqSupply Lens..= uniqs1+        changed lb+    go _ ty = error $ $(curLoc) ++ "reduceDFold: argument does not have a vector type: " ++ showPpr ty++    doFold _   _    _ []     = start+    doFold ubp snDc k (x:xs) = mkApps fun+                                 [Right (LitTy (NumTy k))+                                 ,Left (Data (ubp k))+                                 ,Left (snDc k)+                                 ,Left x+                                 ,Left (doFold ubp snDc (k-1) xs)+                                 ]++-- | Replace an application of the @Clash.Sized.Vector.head@ primitive on+-- vectors of a known length @n@, by a projection of the first element of a+-- vector.+reduceHead+  :: Integer  -- ^ Length of the vector, must be positive+  -> Type -- ^ Element type of the vector+  -> Term -- ^ The argument vector+  -> TransformContext+  -> NormalizeSession Term+reduceHead n aTy vArg (TransformContext inScope _ctx) = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm vArg+    go tcm ty+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [_,consCon]  <- tyConDataCons vecTc+      = do+        uniqs0 <- Lens.use uniqSupply+        let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip)+                                  $ extractElems uniqs0 inScope consCon aTy 'H' n vArg+            lb = Letrec [NE.head elems] (NE.head vars)+        uniqSupply Lens..= uniqs1+        changed lb+    go _ ty = error $ $(curLoc) ++ "reduceHead: argument does not have a vector type: " ++ showPpr ty++-- | Replace an application of the @Clash.Sized.Vector.tail@ primitive on+-- vectors of a known length @n@, by a projection of the tail of a+-- vector.+reduceTail+  :: Integer  -- ^ Length of the vector, must be positive+  -> Type -- ^ Element type of the vector+  -> Term -- ^ The argument vector+  -> TransformContext+  -> NormalizeSession Term+reduceTail n aTy vArg (TransformContext inScope _ctx) = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm vArg+    go tcm ty+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [_,consCon]  <- tyConDataCons vecTc+      = do+        uniqs0 <- Lens.use uniqSupply+        let (uniqs1,(_,elems)) = second (second sconcat . NE.unzip)+                               $ extractElems uniqs0 inScope consCon aTy 'L' n vArg+            b@(tB,_)     = elems NE.!! 1+            lb           = Letrec [b] (Var tB)+        uniqSupply Lens..= uniqs1+        changed lb+    go _ ty = error $ $(curLoc) ++ "reduceTail: argument does not have a vector type: " ++ showPpr ty++-- | Replace an application of the @Clash.Sized.Vector.last@ primitive on+-- vectors of a known length @n@, by a projection of the last element of a+-- vector.+reduceLast+  :: Integer  -- ^ Length of the vector, must be positive+  -> Type -- ^ Element type of the vector+  -> Term -- ^ The argument vector+  -> TransformContext+  -> NormalizeSession Term+reduceLast n aTy vArg (TransformContext inScope _ctx) = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm vArg+    go tcm ty+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [_,consCon]  <- tyConDataCons vecTc+      = do+        uniqs0 <- Lens.use uniqSupply+        let (uniqs1,(_,elems)) = second NE.unzip+                               $ extractElems uniqs0 inScope consCon aTy 'L' n vArg+            (tB,_)       = NE.head (NE.last elems)+        uniqSupply Lens..= uniqs1+        case n of+         0 -> changed (TyApp (Prim NP.undefined) aTy)+         _ -> changed (Letrec (NE.init (sconcat elems)) (Var tB))+    go _ ty = error $ $(curLoc) ++ "reduceLast: argument does not have a vector type: " ++ showPpr ty++-- | Replace an application of the @Clash.Sized.Vector.init@ primitive on+-- vectors of a known length @n@, by a projection of the init of a+-- vector.+reduceInit+  :: PrimInfo -- ^ Primitive info for 'init'+  -> Integer  -- ^ Length of the vector+  -> Type -- ^ Element type of the vector+  -> Term -- ^ The argument vector+  -> TransformContext+  -> NormalizeSession Term+reduceInit initPrimInfo n aTy vArg _ctx = do+  tcm <- Lens.view tcCache+  let ty = inferCoreTypeOf tcm vArg+  changed (go tcm ty)+ where+  go tcm (coreView1 tcm -> Just ty') = go tcm ty'+  go tcm (tyView -> TyConApp vecTcNm _)+    | (Just vecTc) <- UniqMap.lookup vecTcNm tcm+    , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+    , [nilCon, consCon]  <- tyConDataCons vecTc+    = if n == 0 then+        mkVecNil nilCon aTy+      else+        let+          nPredTy = Right (LitTy (NumTy (n - 1)))+          (a, as0) = extractHeadTail consCon aTy (n+1) vArg+          as1 = mkApps (Prim initPrimInfo) [nPredTy, Right aTy, Left as0]+        in+          mkVecCons consCon aTy n a as1++  go _ ty =+    error $ $(curLoc) ++ [I.i|+      reduceInit: argument does not have a vector type:++        #{showPpr ty}+    |]++-- | Replace an application of the @Clash.Sized.Vector.(++)@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.Vector.(++)@+reduceAppend+  :: Integer  -- ^ Length of the LHS arg+  -> Integer  -- ^ Lenght of the RHS arg+  -> Type -- ^ Element type of the vectors+  -> Term -- ^ The LHS argument+  -> Term -- ^ The RHS argument+  -> TransformContext+  -> NormalizeSession Term+reduceAppend 0 _ _   _    rArg _ = changed rArg+reduceAppend _ 0 _   lArg _    _ = changed lArg+reduceAppend n m aTy lArg rArg (TransformContext inScope _ctx) = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm lArg+    go tcm ty+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [_,consCon]  <- tyConDataCons vecTc+      = do uniqs0 <- Lens.use uniqSupply+           let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip)+                                     $ extractElems uniqs0 inScope consCon aTy+                                         'C' n lArg+               lbody        = appendToVec consCon aTy rArg (n+m) (NE.toList vars)+               lb           = Letrec (NE.init elems) lbody+           uniqSupply Lens..= uniqs1+           changed lb+    go _ ty = error $ $(curLoc) ++ "reduceAppend: argument does not have a vector type: " ++ showPpr ty++-- | Replace an application of the @Clash.Sized.Vector.unconcat@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.Vector.unconcat@+reduceUnconcat :: PrimInfo -- ^ Unconcat primitive info+               -> Integer  -- ^ Length of the result vector+               -> Integer  -- ^ Length of the elements of the result vector+               -> Type -- ^ Element type+               -> Term -- ^ Length of the result vector (as a KnownNat)+               -> Term -- ^ SNat "Length of the elements of the result vector"+               -> Term -- ^ Argument vector+               -> TransformContext+               -> NormalizeSession Term+reduceUnconcat unconcatPrimInfo n m aTy _kn sm arg (TransformContext inScope _ctx) = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm arg+    go tcm ty+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [nilCon,consCon] <- tyConDataCons vecTc+      , let innerVecTy = mkTyConApp vecTcNm [LitTy (NumTy m), aTy]+      = if n == 0 then+          changed (mkVecNil nilCon innerVecTy)+        else if m == 0 then do+          let+            nilVec = mkVecNil nilCon aTy+            retVec = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec)+          changed retVec+        else do+          uniqs0 <- Lens.use uniqSupply+          let+            (uniqs1,(vars,headsAndTails)) =+              second (second sconcat . NE.unzip)+                     (extractElems uniqs0 inScope consCon aTy 'U' (n*m) arg)+            -- Build a vector out of the first m elements+            mvec = mkVec nilCon consCon aTy m (NE.take (fromInteger m) vars)+            -- Get the vector representing the next ((n-1)*m) elements+            -- N.B. `extractElems (xs :: Vec 2 a)` creates:+            -- x0  = head xs+            -- xs0 = tail xs+            -- x1  = head xs0+            -- xs1 = tail xs0+            (lbs,nextVec) = case NE.splitAt ((2*fromInteger m)-1) headsAndTails of+                              (xs,y:_) -> (xs,y)+                              _ -> error "impossible"+            -- recursively call unconcat+            nextUnconcat = mkApps (Prim unconcatPrimInfo)+                                  [ Right (LitTy (NumTy (n-1)))+                                  , Right (LitTy (NumTy m))+                                  , Right aTy+                                  , Left (Literal (NaturalLiteral (n-1)))+                                  , Left sm+                                  , Left (snd nextVec)+                                  ]+            -- let (mvec,nextVec) = splitAt sm arg+            -- in Cons mvec (unconcat sm nextVec)+            lBody = mkVecCons consCon innerVecTy n mvec nextUnconcat+            lb = Letrec lbs lBody++          uniqSupply Lens..= uniqs1+          changed lb+    go _ ty = error $ $(curLoc) ++ "reduceUnconcat: argument does not have a vector type: " ++ showPpr ty++-- | Replace an application of the @Clash.Sized.Vector.transpose@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.Vector.transpose@+reduceTranspose :: Integer  -- ^ Length of the result vector+                -> Integer  -- ^ Length of the elements of the result vector+                -> Type -- ^ Element type+                -> Term -- ^ Lenght of the result vector (as a KnownNat)+                -> Term -- ^ Argument vector+                -> TransformContext+                -> NormalizeSession Term+reduceTranspose n 0 aTy _kn arg _ctx = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm arg+    go tcm ty+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [nilCon,consCon] <- tyConDataCons vecTc+      = let nilVec           = mkVec nilCon consCon aTy 0 []+            innerVecTy       = mkTyConApp vecTcNm [LitTy (NumTy 0), aTy]+            retVec           = mkVec nilCon consCon innerVecTy n (replicate (fromInteger n) nilVec)+        in  changed retVec+    go _ ty = error $ $(curLoc) ++ "reduceTranspose: argument does not have a vector type: " ++ showPpr ty++reduceTranspose _ _ _ _ _ _ = error $ $(curLoc) ++ "reduceTranspose: unimplemented"++reduceReplicate :: Integer+                -> Type+                -> Type+                -> Term+                -> Term+                -> TransformContext+                -> NormalizeSession Term+reduceReplicate n aTy eTy _sn arg _ctx = do+    tcm <- Lens.view tcCache+    go tcm eTy+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [nilCon,consCon] <- tyConDataCons vecTc+      = let retVec = mkVec nilCon consCon aTy n (replicate (fromInteger n) arg)+        in  changed retVec+    go _ ty = error $ $(curLoc) ++ "reduceReplicate: argument does not have a vector type: " ++ showPpr ty++-- TODO: Take a shortcut when given index is a literal. Right now, this function+-- TODO: simply creates a case statement for every element in the vector, which+-- TODO: Clash will eliminate one-by-one if the index turned out to be literal.+-- TODO: It would of course be best to not create the cases in the first place!+reduceReplace_int+  :: Integer+  -- ^ Size of vector, must be positive+  -> Type+  -- ^ Type of vector element+  -> Type+  -- ^ Type of vector+  -> Term+  -- ^ Size of vector (as a KnownNat)+  -> Term+  -- ^ Vector+  -> Term+  -- ^ Index+  -> Term+  -- ^ Element+  -> TransformContext+  -> NormalizeSession Term+reduceReplace_int n aTy vTy _kn v i newA (TransformContext is0 _ctx) = do+  tcm <- Lens.view tcCache+  go tcm vTy+ where+  -- Basically creates:+  --+  -- case eqInt i0 curI  of+  --   True -> newA+  --   _    -> oldA+  --+  -- where:+  --+  --   - curI is the index of the current element, which we statically know+  --   - i0 is the index given to replace_int+  --   - newA is the element given to replace_int as a replacement for..+  --   - oldA; an element at index curI+  --+  replace_intElement+    :: TyConMap+    -- ^ TyCon map+    -> DataCon+    -- Int datacon+    -> Type+    -- Int type+    -> Term+    -- ^ Element in vector+    -> Integer+    -- ^+    -> Term+  replace_intElement tcm iDc iTy oldA elIndex = case0+   where+    case0 = Maybe.fromMaybe (error "replace_intElement: faild to build Truce DC") $ do+      boolTc <- UniqMap.lookup (fromGhcUnique boolTyConKey) tcm+      [_,trueDc] <- pure (tyConDataCons boolTc)+      let eqInt = eqIntPrim iTy (mkTyConApp (tyConName boolTc) [])+      return (Case (mkApps eqInt [ Left i+                                 , Left (mkApps (Data iDc)+                                                [Left (Literal (IntLiteral elIndex))])+                                 ])+                   aTy+                   [ (DefaultPat, oldA)+                   , (DataPat trueDc [] [], newA)+                   ])++  -- Equality on lifted Int that returns a Bool+  eqIntPrim+    :: Type+    -> Type+    -> Term+  eqIntPrim intTy boolTy =+    Prim (PrimInfo+           "GHC.Classes.eqInt"+           (mkFunTy intTy (mkFunTy intTy boolTy))+           WorkVariable+           SingleResult+           NoUnfolding)++  go tcm (coreView1 tcm -> Just ty') = go tcm ty'+  go tcm (tyView -> TyConApp vecTcNm _)+    | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+    , [nilCon,consCon] <- tyConDataCons vecTc+    = do+      -- Get data constructors of 'Int'+      uniqs0                   <- Lens.use uniqSupply+      let iTy                   = inferCoreTypeOf tcm i+          iDc = Maybe.fromMaybe (error "replace_intElement: faild to build Int DC") $ do+            (TyConApp iTcNm _) <- pure (tyView iTy)+            iTc <- UniqMap.lookup iTcNm tcm+            Maybe.listToMaybe (tyConDataCons iTc)++      -- Get elements from vector+          (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip)+                                $ extractElems+                                    uniqs0+                                    is0+                                    consCon+                                    aTy+                                    'I'+                                    n+                                    v++      -- Replace every element with (if i == elIndex then newA else oldA)+      let replacedEls = zipWith (replace_intElement tcm iDc iTy) (NE.toList vars) [0..]+          lbody       = mkVec nilCon consCon aTy n replacedEls+          lb          = Letrec (NE.init elems) lbody+      uniqSupply Lens..= uniqs1+      changed lb+  go _ ty = error $ $(curLoc) ++ "reduceReplace_int: argument does not have "+                                ++ "a vector type: " ++ showPpr ty++-- TODO: Take a shortcut when given index is a literal. Right now, this function+-- TODO: simply creates a case statement for every element in the vector, which+-- TODO: Clash will eliminate one-by-one if the index turned out to be literal.+-- TODO: It would of course be best to not create the cases in the first place!+reduceIndex_int+  :: Integer+  -- ^ Size of vector, must be positive+  -> Type+  -- ^ Type of vector element+  -> Term+  -- ^ Size of vector (as a KnownNat)+  -> Term+  -- ^ Vector+  -> Term+  -- ^ Index+  -> TransformContext+  -> NormalizeSession Term+reduceIndex_int n aTy _kn v i (TransformContext is0 _ctx) = do+  tcm <- Lens.view tcCache+  let vTy = inferCoreTypeOf tcm v+  go tcm vTy+ where+  -- Basically creates:+  --+  -- case eqInt i0 curI of+  --   True -> curA+  --   _    -> next+  --+  -- where:+  --+  --   - curI is the index of the current element, which we statically know+  --   - i0 is the index given to index_int+  --   - curA is the element at index curI+  --   - next; the value if the current index is not equal to index argument+  --+  index_intElement+    :: TyConMap+    -- ^ TyCon map+    -> DataCon+    -- Int datacon+    -> Type+    -- Int type+    -> (Term, Integer)+    -- ^ Element in the vector, and its corresponding index+    -> Term+    -- ^ The rest+    -> Term+  index_intElement tcm iDc iTy (cur,elIndex) next = case0+   where+    case0 = Maybe.fromMaybe (error "reduceIndex_int: faild to build True DC") $ do+      boolTc <- UniqMap.lookup (fromGhcUnique boolTyConKey) tcm+      [_,trueDc] <- pure (tyConDataCons boolTc)+      let eqInt = eqIntPrim iTy (mkTyConApp (tyConName boolTc) [])+      return (Case (mkApps eqInt [ Left i+                                 , Left (mkApps (Data iDc)+                                        [Left (Literal (IntLiteral elIndex))])+                                 ])+                   aTy+                   [ (DefaultPat, next)+                   , (DataPat trueDc [] [], cur)+                   ])++  -- Equality on lifted Int that returns a Bool+  eqIntPrim+    :: Type+    -> Type+    -> Term+  eqIntPrim intTy boolTy =+    Prim ( PrimInfo+            "GHC.Classes.eqInt"+            (mkFunTy intTy (mkFunTy intTy boolTy))+            WorkVariable+            SingleResult+            NoUnfolding)++  go tcm (coreView1 tcm -> Just ty') = go tcm ty'+  go tcm (tyView -> TyConApp vecTcNm _)+    | (Just vecTc)     <- UniqMap.lookup vecTcNm tcm+    , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+    , [_nilCon,consCon] <- tyConDataCons vecTc+    = do+      -- Get data constructors of 'Int'+      uniqs0                   <- Lens.use uniqSupply+      let iTy                   = inferCoreTypeOf tcm i+          iDc = Maybe.fromMaybe (error "reduceIndex_int: faild to build Int DC") $ do+              (TyConApp iTcNm _) <- pure (tyView iTy)+              iTc <- UniqMap.lookup iTcNm tcm+              Maybe.listToMaybe (tyConDataCons iTc)++      -- Get elements from vector+          (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip)+                                $ extractElems+                                    uniqs0+                                    is0+                                    consCon+                                    aTy+                                    'I'+                                    n+                                    v++      -- Build a right-biased tree of case-expressions+      let indexed = foldr (index_intElement tcm iDc iTy)+                              (TyApp (Prim NP.undefined) aTy)+                              (zip (NE.toList vars) [0..])+          lb      = Letrec (NE.init elems) indexed+      uniqSupply Lens..= uniqs1+      changed lb+  go _ ty = error $ $(curLoc) ++ "indexReplace_int: argument does not have "+                              ++ "a vector type: " ++ showPpr ty++-- | Replace an application of the @Clash.Sized.Vector.dtfold@ primitive on+-- vectors of a known length @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.Vector.dtfold@+reduceDTFold+  :: Integer  -- ^ Length of the vector+  -> Type     -- ^ Element type of the argument vector+  -> Term     -- ^ Length of the vector (as a KnownNat)+  -> Term     -- ^ The motive+  -> Term     -- ^ Function to convert elements with+  -> Term     -- ^ Function to combine branches with+  -> Term     -- ^ The vector to fold+  -> TransformContext+  -> NormalizeSession Term+reduceDTFold n aTy _kn _motive lrFun brFun arg (TransformContext inScope _ctx) = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm arg+    go tcm ty+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp vecTcNm _)+      | (Just vecTc) <- UniqMap.lookup vecTcNm tcm+      , nameOcc vecTcNm == "Clash.Sized.Vector.Vec"+      , [_,consCon]  <- tyConDataCons vecTc+      = do uniqs0 <- Lens.use uniqSupply+           let (uniqs1,(vars,elems)) = second (second sconcat . NE.unzip)+                                     $ extractElems uniqs0 inScope consCon aTy+                                         'T' (2^n) arg+               snatDc = Maybe.fromMaybe (error "reduceDTFold: faild to build SNat") $ do+                  (_ltv:Right snTy:_,_) <- pure (splitFunForallTy (inferCoreTypeOf tcm brFun))+                  (TyConApp snatTcNm _) <- pure (tyView snTy)+                  snatTc <- UniqMap.lookup snatTcNm tcm+                  Maybe.listToMaybe (tyConDataCons snatTc)+               lbody = doFold (buildSNat snatDc) (n-1) (NE.toList vars)+               lb = Letrec (NE.init elems) lbody+           uniqSupply Lens..= uniqs1+           changed lb+    go _ ty = error $ $(curLoc) ++ "reduceDTFold: argument does not have a vector type: " ++ showPpr ty++    doFold :: (Integer -> Term) -> Integer -> [Term] -> Term+    doFold _    _ [x] = mkApps lrFun [Left x]+    doFold snDc k xs  =+      let (xsL,xsR) = splitAt (2^k) xs+          k'        = k-1+          eL        = doFold snDc k' xsL+          eR        = doFold snDc k' xsR+      in  mkApps brFun [Right (LitTy (NumTy k))+                       ,Left  (snDc k)+                       ,Left  eL+                       ,Left  eR+                       ]++-- | Replace an application of the @Clash.Sized.RTree.tdfold@ primitive on+-- trees of a known depth @n@, by the fully unrolled recursive "definition"+-- of @Clash.Sized.RTree.tdfold@+reduceTFold+  :: Integer -- ^ Depth of the tree+  -> Type    -- ^ Element type of the argument tree+  -> Term    -- ^ Depth of the tree (as a KnownNat)+  -> Term    -- ^ The motive+  -> Term    -- ^ Function to convert elements with+  -> Term    -- ^ Function to combine branches with+  -> Term    -- ^ The tree to fold+  -> TransformContext+  -> NormalizeSession Term+reduceTFold n aTy _kn _motive lrFun brFun arg (TransformContext inScope _ctx) = do+    tcm <- Lens.view tcCache+    let ty = inferCoreTypeOf tcm arg+    go tcm ty+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp treeTcNm _)+      | (Just treeTc) <- UniqMap.lookup treeTcNm tcm+      , nameOcc treeTcNm == "Clash.Sized.RTree.RTree"+      , [lrCon,brCon] <- tyConDataCons treeTc+      = do uniqs0 <- Lens.use uniqSupply+           let (uniqs1,(vars,elems)) = extractTElems uniqs0 inScope lrCon brCon aTy 'T' n arg+               snatDc = Maybe.fromMaybe (error "reduceTFold: faild to build SNat") $ do+                  (_ltv:Right snTy:_,_) <- pure (splitFunForallTy (inferCoreTypeOf tcm brFun))+                  (TyConApp snatTcNm _) <- pure (tyView snTy)+                  snatTc <- UniqMap.lookup snatTcNm tcm+                  Maybe.listToMaybe (tyConDataCons snatTc)+               lbody = doFold (buildSNat snatDc) (n-1) vars+               lb = (Letrec elems lbody)+           uniqSupply Lens..= uniqs1+           changed lb+    go _ ty = error $ $(curLoc) ++ "reduceTFold: argument does not have a tree type: " ++ showPpr ty++    doFold _    _ [x] = mkApps lrFun [Left x]+    doFold snDc k xs  =+      let (xsL,xsR) = splitAt (length xs `div` 2) xs+          k'        = k-1+          eL        = doFold snDc k' xsL+          eR        = doFold snDc k' xsR+      in  mkApps brFun [Right (LitTy (NumTy k))+                       ,Left (snDc k)+                       ,Left eL+                       ,Left eR+                       ]++reduceTReplicate :: Integer -- ^ Depth of the tree+                 -> Type    -- ^ Element type+                 -> Type    -- ^ Result type+                 -> Term    -- ^ Depth of the tree (as an SNat)+                 -> Term    -- ^ Element+                 -> TransformContext+                 -> NormalizeSession Term+reduceTReplicate n aTy eTy _sn arg _ctx = do+    tcm <- Lens.view tcCache+    go tcm eTy+  where+    go tcm (coreView1 tcm -> Just ty') = go tcm ty'+    go tcm (tyView -> TyConApp treeTcNm _)+      | (Just treeTc) <- UniqMap.lookup treeTcNm tcm+      , nameOcc treeTcNm == "Clash.Sized.RTree.RTree"+      , [lrCon,brCon] <- tyConDataCons treeTc+      = let retVec = mkRTree lrCon brCon aTy n (replicate (2^n) arg)+        in  changed retVec+    go _ ty = error $ $(curLoc) ++ "reduceTReplicate: argument does not have a RTree type: " ++ showPpr ty++buildSNat :: DataCon -> Integer -> Term+buildSNat snatDc i =+  mkApps (Data snatDc)+         [Right (LitTy (NumTy i))+         ,Left (Literal (NaturalLiteral (toInteger i)))+         ]
+ src/Clash/Normalize/Primitives.hs view
@@ -0,0 +1,62 @@+{-|+Copyright   : (C) 2021, QBayLogic B.V.,+                  2022, Google Inc.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>++Special primitives created during the normalization process.+-}++{-# LANGUAGE TemplateHaskellQuotes #-}++module Clash.Normalize.Primitives+  ( removedArg+  , undefined+  , undefinedX+  ) where++import Prelude hiding (undefined)++import qualified Data.Text.Extra as Text++import Clash.Core.Term (IsMultiPrim(..), PrimInfo(..), PrimUnfolding(..), WorkInfo(..))+import Clash.Core.Util (undefinedTy)++-- | The removedArg primitive represents an argument which is computationally+-- irrelevant, and has been removed from the circuit (as removing it does not+-- change the behaviour of the circuit). Examples of such arguments are unused+-- arguments to blackboxes, as removing them does not affect the rendered HDL.+--+removedArg :: PrimInfo+removedArg = PrimInfo+  { primName = Text.showt 'removedArg+  , primType = undefinedTy+  , primWorkInfo = WorkNever+  , primMultiResult = SingleResult+  , primUnfolding = NoUnfolding+  }++-- | The undefined primitive represents an undefined value that was identified+-- during normalization. This includes undefined results to compile-time+-- evaluation, such as division by zero.+--+undefined :: PrimInfo+undefined = PrimInfo+  { primName = Text.showt 'undefined+  , primType = undefinedTy+  , primWorkInfo = WorkNever+  , primMultiResult = SingleResult+  , primUnfolding = NoUnfolding+  }++-- | The undefinedX primitive represents an X-exception throwing value that was+-- identified during normalization.+--+undefinedX :: PrimInfo+undefinedX = PrimInfo+  { primName = Text.showt 'undefinedX+  , primType = undefinedTy+  , primWorkInfo = WorkNever+  , primMultiResult = SingleResult+  , primUnfolding = NoUnfolding+  }
+ src/Clash/Normalize/Primitives.hs-boot view
@@ -0,0 +1,6 @@+module Clash.Normalize.Primitives where++import Clash.Core.Term (PrimInfo)++undefined :: PrimInfo+undefinedX :: PrimInfo
+ src/Clash/Normalize/Strategy.hs view
@@ -0,0 +1,337 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                (C) 2021-2026, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Transformation process for normalization+-}++{-# LANGUAGE CPP #-}++module Clash.Normalize.Strategy where++import Clash.Normalize.Transformations+import Clash.Normalize.Types+import Clash.Rewrite.Combinators+import Clash.Rewrite.Types+import Clash.Rewrite.Util++-- [Note: bottomup traversal reduceConst]+--+-- 2-May-2019: There is a bug in the evaluator where all data constructors are+-- considered lazy, even though their declaration says they have strict fields.+-- This causes some reductions to fail because the term under the constructor is+-- not in WHNF, which is what some of the evaluation rules for certain primitive+-- operations expect. Using a bottom-up traversal works around this bug by+-- ensuring that the values under the constructor are in WHNF.+--+-- Using a bottomup traversal ensures that constants are reduced to NF, even if+-- constructors are lazy, thus ensuring more sensible/smaller generated HDL.++-- | Normalisation transformation+normalization :: NormRewrite+normalization =+  rmDeadcode >-> multPrim >-> constantPropagation >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >->+  bindConst >-> letTL+  >-> evalConst+  >-!-> cse >-!-> cleanup >->+  elimCaseBigNum >->  -- see [Note] late elimCaseBigNum+  xOptim >-> rmDeadcode >->+  cleanup >-> bindSimIO >-> recLetRec >-> splitArgs+  where+    multPrim   = topdownR (apply "setupMultiResultPrim" setupMultiResultPrim)+    anf        = topdownR (apply "nonRepANF" nonRepANF) >-> apply "ANF" makeANF >-> topdownR (apply "caseCon" caseCon)+    letTL      = topdownSucR (apply "topLet" topLet)+    recLetRec  = apply "recToLetRec" recToLetRec+    rmUnusedExpr = bottomupR (apply "removeUnusedExpr" removeUnusedExpr)+    rmDeadcode = bottomupR (apply "deadcode" deadCode)+    bindConst  = topdownR (apply "bindConstantVar" bindConstantVar)+    -- See [Note] bottomup traversal reduceConst:+    evalConst  = bottomupR (apply "reduceConst" reduceConst)+    cse        = topdownR (apply "CSE" simpleCSE)+    elimCaseBigNum = topdownR (apply "elimCaseBigNum" elimCaseBigNumInternals)+    xOptim     = bottomupR (apply "xOptimize" xOptimize)+    cleanup    = topdownR (apply "etaExpandSyn" etaExpandSyn) >->+                 topdownSucR (apply "inlineCleanup" inlineCleanup) !->+                 innerMost (applyMany [("caseCon"        , caseCon)+                                      ,("bindConstantVar", bindConstantVar)+                                      ,("letFlat"        , flattenLet)])+                 >-> rmDeadcode >-> letTL+    splitArgs  = topdownR (apply "separateArguments" separateArguments) !->+                 bottomupR (apply "caseCon" caseCon)+    bindSimIO  = topdownR (apply "bindSimIO" inlineSimIO)+++constantPropagation :: NormRewrite+constantPropagation =+  inlineAndPropagate >->+  caseFlattening >->+  etaTL >->+  dec >->+  spec >->+  dec >->+  conSpec+  where+    etaTL              = apply "etaTL" etaExpansionTL !-> topdownR (apply "applicationPropagation" appProp)+    inlineAndPropagate = repeatR (topdownR (applyMany transPropagateAndInline) >-> inlineNR)+    spec               = bottomupR (applyMany specTransformations)+    caseFlattening     = repeatR (topdownR (apply "caseFlat" caseFlat))+    dec                = repeatR (topdownR (apply "DEC" disjointExpressionConsolidation))+    conSpec            = bottomupR  ((apply "appPropCS" appProp !->+                                     bottomupR (apply "constantSpec" constantSpec)) >-!+                                     apply "constantSpec" constantSpec)++    transPropagateAndInline :: [(String,NormRewrite)]+    transPropagateAndInline =+      [ ("applicationPropagation", appProp              )+      , ("bindConstantVar"       , bindConstantVar      )+      , ("caseLet"               , caseLet              )+      , ("caseCase"              , caseCase             )+      , ("caseCon"               , caseCon              )+      , ("elimExistentials"      , elimExistentials     )+      , ("caseElemNonReachable"  , caseElemNonReachable )+      , ("removeUnusedExpr"      , removeUnusedExpr     )+      -- These transformations can safely be applied in a top-down traversal as+      -- they themselves check whether the to-be-inlined binder is recursive or not.+      , ("inlineWorkFree"  , inlineWorkFree)+      , ("inlineSmall"     , inlineSmall)+      , ("bindOrLiftNonRep", inlineOrLiftNonRep) -- See: [Note] bindNonRep before liftNonRep+                                                 -- See: [Note] bottom-up traversal for liftNonRep+      , ("reduceNonRepPrim", reduceNonRepPrim)+++      , ("caseCast"        , caseCast)+      , ("letCast"         , letCast)+      , ("splitCastWork"   , splitCastWork)+      , ("argCastSpec"     , argCastSpec)+      , ("inlineCast"      , inlineCast)+      , ("elimCastCast"    , elimCastCast)+      ]++    -- InlineNonRep cannot be applied in a top-down traversal, as the non-representable+    -- binder might be recursive. The idea is, is that if the recursive+    -- non-representable binder is inlined once, we can get rid of the recursive+    -- aspect using the case-of-known-constructor+    --+    -- Note that we first do a dead code removal pass, which makes sure that+    -- unused let-bindings get cleaned up. Only if no dead code is removed+    -- 'inlineNonRep' is executed. We do this for two reasons:+    --+    --   1. 'deadCode' is an expensive operation and is therefore left out of+    --      the hot loop 'transPropagateAndInline'.+    --+    --   2. In various situations 'transPropagateAndInline' can do more work+    --      after 'deadCode' was successful. This work in turn might remove a+    --      a construct 'inlineNonRep' would fire on - saving the compiler work.+    --+    inlineNR :: NormRewrite+    inlineNR =+          bottomupR (apply "deadCode" deadCode)+      >-! apply "inlineNonRep" inlineNonRep++    specTransformations :: [(String,NormRewrite)]+    specTransformations =+      [ ("typeSpec"    , typeSpec)+      , ("nonRepSpec"  , nonRepSpec)+      , ("zeroWidthSpec", zeroWidthSpec)+        -- See Note [zeroWidthSpec enabling transformations]+      ]++{-+[Note] late elimCaseBigNum++elimCaseBigNum is placed fairly late in the pipeline, after any constant folding and after caseCon.+Because Naturals also hide inside SNat/Nat/KnownNats, and those can be bigger then 64bits.+But they're ultimately monomorphic and thus static and will be evaluated.+We just have to make sure that evaluation happens before we do elimCaseBigNum.++For an example of where this can happen see foldableSNat in tests/shouldwork/Issues/T3157_IntegerNaturalInternals.hs+-}++{-+Note [zeroWidthSpec enabling transformations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When zeroWidthSpec fires, it can lead to better results in normalization, but+this is somewhat incidental. The extra transformations which fire are typically+from++  * calls to transformations like caseCon which occur after constantPropagation+    (e.g. caseCon run after ANF conversion).++  * flattening / inlining which happens late in normalization (after regular+    normalization has occurred)++  * normalizing another function due to being marked NOINLINE++If we consider the following:++    data AB = A | B++    ab :: KnownNat n => Index n -> AB -> AB+    ab n A = if n >  0 then A else B+    ab n B = if n == 0 then B else A+    {-# NOINLINE ab #-}++    topEntity = ab @1+    {-# NOINLINE topEntity #-}++The zeroWidthSpec transformation fires on the topEntity, giving a+post-normalization topEntity of++    \(x :: Index 1) ->+      \(y :: AB) ->+        letrec result :: AB = ab' y in result++where++    ab' = ab (fromInteger# 0)++The extra transformations which fire happen later when ab' is normalized.+Removing the NOINLINE from ab gives the same result, but the extra+transformations fire in flattening instead.+-}++{- [Note] bottom-up traversal for liftNonRep+We used to say:++"The liftNonRep transformation must be applied in a topDown traversal because+of what Clash considers tail calls in its join-point analysis."++Consider:++> let fail = \x -> ...+> in  case ... of+>       A -> let fail1 = \y -> case ... of+>                                 X -> fail ...+>                                 Y -> ...+>            in case ... of+>                 P -> fail1 ...+>                 Q -> ...+>       B -> fail ...++under "normal" tail call rules, the local 'fail' functions is not a join-point+because it is used in a let-binding. However, we apply "special" tail call rules+in Clash. Because 'fail' is used in a TC position within 'fail1', and 'fail1' is+only used in a TC position, in Clash, we consider 'tail' also only to be used+in a TC position.++Now image we apply 'liftNonRep' in a bottom up traversal, we will end up with:++> fail1 = \fail y -> case ... of+>   X -> fail ...+>   Y -> ...++> let fail = \x -> ...+> in  case ... of+>       A -> case ... of+>                 P -> fail1 fail ...+>                 Q -> ...+>       B -> fail ...++Suddenly, 'fail' ends up in an argument position, because it occurred as a+_locally_ bound variable within 'fail1'. And because of that 'fail' stops being+a join-point.++However, when we apply 'liftNonRep' in a top down traversal we end up with:++> fail = \x -> ...+>+> fail1 = \y -> case ... of+>   X -> fail ...+>   Y -> ...+>+> let ...+> in  case ... of+>       A -> let+>            in case ... of+>                 P -> fail1 ...+>                 Q -> ...+>       B -> fail ...++and all is well with the world.++UPDATE:+We can now just perform liftNonRep in a bottom-up traversal again, because+liftNonRep no longer checks that if the binding that is lifted is a join-point.+However, for this to work, bindNonRep must always have been exhaustively applied+before liftNonRep. See also: [Note] bindNonRep before liftNonRep.+-}++{- [Note] bindNonRep before liftNonRep+The combination of liftNonRep and nonRepSpec can lead to non-termination in an+unchecked rewrite system (without termination measures in place) on the+following:++> main = f not+> f    = \a x -> (a x) && (f a x)++nonRepSpec will lead to:++> main = f'+> f    = \a x -> (a x) && (f a x)+> f'   = (\a x -> (a x) && (f a x)) not++then lamApp leads to:++> main = f'+> f    = \a x -> (a x) && (f a x)+> f'   = let a = not in (\x -> (a x) && (f a x))++then liftNonRep leads to:++> main = f'+> f    = \a x -> (a x) && (f a x)+> f'   = \x -> (g x) && (f g x)+> g    = not++and nonRepSepc leads to:++> main = f'+> f    = \a x -> (a x) && (f a x)+> f'   = \x -> (g x) && (f'' g x)+> g    = not+> f''  = (\a x -> (a x) && (f a x)) g++This cycle continues indefinitely, as liftNonRep creates a new global variable,+which is never alpha-equivalent to the previous global variable introduced by+liftNonRep.++That is why bindNonRep must always be applied before liftNonRep. When we end up+in the situation after lamApp:++> main = f'+> f    = \a x -> (a x) && (f a x)+> f'   = let a = not in (\x -> (a x) && (f a x))++bindNonRep will now lead to:++> main = f'+> f    = \a x -> (a x) && (f a x)+> f'   = \x -> (not x) && (f not x)++Because `f` has already been specialized on the alpha-equivalent-to-itself `not`+function, liftNonRep leads to:++> main = f'+> f    = \a x -> (a x) && (f a x)+> f'   = \x -> (not x) && (f' x)++And there is no non-terminating rewriting cycle.++That is why bindNonRep must always be exhaustively applied before we apply+liftNonRep.+-}++-- | Topdown traversal, stops upon first success+topdownSucR :: Rewrite extra -> Rewrite extra+topdownSucR r = r >-! (allR (topdownSucR r))+{-# INLINE topdownSucR #-}++innerMost :: Rewrite extra -> Rewrite extra+innerMost = let go r = bottomupR (r !-> innerMost r) in go+{-# INLINE innerMost #-}++applyMany :: [(String,Rewrite extra)] -> Rewrite extra+applyMany = foldr1 (>->) . map (uncurry apply)+{-# INLINE applyMany #-}
+ src/Clash/Normalize/Strategy.hs-boot view
@@ -0,0 +1,6 @@+module Clash.Normalize.Strategy (constantPropagation, normalization) where++import Clash.Normalize.Types (NormRewrite)++normalization :: NormRewrite+constantPropagation :: NormRewrite
+ src/Clash/Normalize/Transformations.hs view
@@ -0,0 +1,27 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017-2018, Google Inc.,+                    2021     , QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Transformations of the Normalization process+-}++module Clash.Normalize.Transformations+  ( module X+  ) where++import Clash.Normalize.Transformations.ANF as X+import Clash.Normalize.Transformations.Case as X+import Clash.Normalize.Transformations.Cast as X+import Clash.Normalize.Transformations.DEC as X+import Clash.Normalize.Transformations.EtaExpand as X+import Clash.Normalize.Transformations.Inline as X+import Clash.Normalize.Transformations.Letrec as X+import Clash.Normalize.Transformations.MultiPrim as X+import Clash.Normalize.Transformations.Reduce as X+import Clash.Normalize.Transformations.SeparateArgs as X+import Clash.Normalize.Transformations.Specialize as X+import Clash.Normalize.Transformations.XOptimize as X
+ src/Clash/Normalize/Transformations/ANF.hs view
@@ -0,0 +1,413 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017-2018, Google Inc.,+                    2021,      QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Transformations for converting to A-Normal Form.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Normalize.Transformations.ANF+  ( makeANF+  , nonRepANF+  ) where++import Control.Arrow ((***))+import Control.Lens (_2)+import qualified Control.Lens as Lens+import qualified Control.Monad as Monad+import Control.Monad.State (StateT, lift, modify, runStateT)+import Control.Monad.Writer (listen)+import Data.Bifunctor (second)+import qualified Data.Monoid as Monoid (Any(..))+import qualified Data.Text.Extra as Text (showt)+import GHC.Stack (HasCallStack)++import Clash.Signal.Internal (Signal(..))++import Clash.Core.DataCon (DataCon(..))+import Clash.Core.HasFreeVars (disjointFreeVars)+import Clash.Core.HasType+import Clash.Core.Name (mkUnsafeSystemName, nameOcc)+import Clash.Core.Subst (deshadowLetExpr, freshenTm)+import Clash.Core.Term+  ( Alt, CoreContext(..), LetBinding, Pat(..), PrimInfo(..), Term(..)+  , collectArgs, collectTicks, mkTicks, partitionTicks, stripTicks)+import Clash.Core.TermInfo (isCon, isLocalVar, isPrim, isVar)+import Clash.Core.TyCon (TyConMap)+import Clash.Core.Type (Type, TypeView(..), coreView, tyView)+import Clash.Core.Util (mkSelectorCase)+import Clash.Core.Var (Id)+import Clash.Core.VarEnv (InScopeSet, extendInScopeSet, extendInScopeSetList, mkVarSet)+import Clash.Netlist.Util (bindsExistentials)+import Clash.Normalize.Transformations.Specialize (specialize)+import Clash.Normalize.Types (NormRewrite, NormalizeSession)+import Clash.Rewrite.Combinators (bottomupR)+import Clash.Rewrite.Types+  (Transform, TransformContext(..), tcCache)+import Clash.Rewrite.Util+  (changed, isUntranslatable, mkDerivedName, mkTmBinderFor)+import Clash.Rewrite.WorkFree (isConstant, isConstantNotClockReset)+import Clash.Util (curLoc)++{- [Note: ANF in Clash]+ANF suitable for use in Clash can be described with the given types:++  data ATerm+    = ALam !Id ATerm+    | ATyLam !TyVar ATerm+    | ALetrec [(Id, CTerm)] !ITerm++  data CTerm+    = CApp !Id [Either ITerm Type]+    | CCase !ITerm !Type [(Pat, ITerm)]+    | CCast !ITerm !Type !Type+    | CPrim !PrimInfo [Either ITerm Type]+    | CTick !TickInfo CTerm++  data ITerm+    = IVar !Id+    | ILiteral !Literal+    | IData !DataCon [Either ITerm Type]+    | IPrim !PrimInfo [Either ITerm Type]+    | ITick !TickInfo ITerm++where ATerm is a term in A-normal form, CTerm is a compound term (i.e. one+which can only appear let-bound in ANF) and ITerm is an immediate term (i.e.+one which represents some simple term).++There are two constructors for primtiives, CPrim and IPrim. The difference+between these are whether the primitive performs work or not. Primitives which+perform work should be shared, but work-free primitives can be used directly.++These types help codify some invariants that must hold for the result of ANF:++  * terms start with (ty)lambdas, lambdas do not occur in let bindings or the+    the body of a letrec expression++  * there are no nested letrec expressions, only a single letrec which may+    occur after all lambdas++  * an ANF term may not have a letrec expression if the definition is already+    an immediate term, e.g. where there is no benefit in sharing the result++  * only compound terms are let-bound, as there is no benefit from let binding+    an immediate term (there is no benefit to sharing immediate terms)++  * arguments to functions / data constructors / primitives are not let bound+    if they correspond are immediate, but are if they are compound (to produce+    a variable which is an immediate term)++  * the leftmost innermost term in a function application is always an+    identifier, lambdas should have been removed by application propagation++  * the right-hand side of a case alternative is an immediate term++  * the body of the letrec expression is an immediate term++Some invariants are not captured by these types:++  * non-representable terms and terms in IO are not let-bound, instead they are+    pushed down as far as possible++  * if a let binding is created for the result, the name of the Id is "result"++TODO: The best way to enforce that Clash implements ANF compatible with these+types is to implement ANF using these types. However, as currently implemented+ANF is mostly defined using the bottom-up transformation 'collectANF'. This+would be some amount of effort to replace currently, perhaps it would be better+to convert the result of partial evaluation to these data types when it is+implemented more, then use these Anf types directly in the conversion to+netlist, i.e. Term -> Value -> Normal -> Anf -> Netlist.+-}++{- [Note: Name re-creation]+The names of heap bound variables are safely generate with mkUniqSystemId in+Clash.Core.Evaluator.newLetBinding. But only their uniqs end up in the heap,+not the complete names. So we use mkUnsafeSystemName to recreate the same Name.+-}++-- | Turn an expression into a modified ANF-form. As opposed to standard ANF,+-- constants do not become let-bound.+makeANF :: HasCallStack => NormRewrite+makeANF (TransformContext is0 ctx) (Lam bndr e) = do+  let ctx' = TransformContext (extendInScopeSet is0 bndr) (LamBody bndr : ctx)+  e' <- makeANF ctx' e+  return (Lam bndr e')++makeANF _ e@(TyLam {}) = return e++makeANF ctx@(TransformContext is0 _) e0 = do+    -- We need to freshen all binders in `e` because we're shuffling them around+    -- into a single let-binder, because even when binders don't shadow, they+    -- don't have to be unique within an expression. And so lifting them all+    -- to a single let-binder will cause issues when they're not unique.+    --+    -- We cannot make freshening part of collectANF, because when we generate+    -- new binders, we need to make sure those names do not conflict with _any_+    -- of the existing binders in the expression.+    --+    -- See also Note [ANF InScopeSet]+    let (is2,e1) = freshenTm is0 e0+    ((e2,(bndrs,_)),Monoid.getAny -> hasChanged) <-+      listen (runStateT (bottomupR collectANF ctx e1) ([],is2))+    case bndrs of+      [] -> if hasChanged then return e2 else return e0+      _  -> do+        let (e3,ticks) = collectTicks e2+            (srcTicks,nmTicks) = partitionTicks ticks+        -- Ensure that `AppendName` ticks still scope over the entire expression+        changed (mkTicks (Letrec bndrs (mkTicks e3 srcTicks)) nmTicks)+{-# SCC makeANF #-}++type NormRewriteW = Transform (StateT ([LetBinding],InScopeSet) NormalizeSession)++-- | See Note [ANF InScopeSet]+tellBinders :: [LetBinding] -> StateT ([LetBinding],InScopeSet) NormalizeSession ()+tellBinders bs = modify ((bs ++) *** (`extendInScopeSetList` (map fst bs)))++-- | See Note [ANF InScopeSet]; only extends the inscopeset+notifyBinders :: Monad m => [LetBinding] -> StateT ([LetBinding],InScopeSet) m ()+notifyBinders bs = modify (second (`extendInScopeSetList` (map fst bs)))++-- | Is the given type IO-like+isSimIOTy+  :: TyConMap+  -> Type+  -- ^ Type to check for IO-likeness+  -> Bool+isSimIOTy tcm ty = case tyView (coreView tcm ty) of+  TyConApp tcNm args+    | nameOcc tcNm == "Clash.Explicit.SimIO.SimIO"+    -> True+    | nameOcc tcNm == "GHC.Prim.(#,#)"+    , [_,_,st,_] <- args+    -> isStateTokenTy tcm st+  FunTy _ res -> isSimIOTy tcm res+  _ -> False++-- | Is the given type the state token+isStateTokenTy+  :: TyConMap+  -> Type+  -- ^ Type to check for state tokenness+  -> Bool+isStateTokenTy tcm ty = case tyView (coreView tcm ty) of+  TyConApp tcNm _ -> nameOcc tcNm == "GHC.Prim.State#"+  _ -> False++-- | Note [ANF InScopeSet]+--+-- The InScopeSet contains:+--+--    1. All the free variables of the expression we are traversing+--+--    2. All the bound variables of the expression we are traversing+--+--    3. The newly created let-bindings as we recurse back up the traversal+--+-- All of these are needed to created let-bindings that+--+--    * Do not shadow+--    * Are not shadowed+--    * Nor conflict with each other (i.e. have the same unique)+--+-- Initially we start with the local InScopeSet and add the global variables:+--+-- @+-- is1 <- unionInScope is0 <$> Lens.use globalInScope+-- @+--+-- Which will gives us the (superset of) free variables of the expression. Then+-- we call  'freshenTm'+--+-- @+-- let (is2,e1) = freshenTm is1 e0+-- @+--+-- Which extends the InScopeSet with all the bound variables in 'e1', the+-- version of 'e0' where all binders are unique (not just deshadowed).+--+-- So we start out with an InScopeSet that satisfies points 1 and 2, now every+-- time we create a new binder we must add it to the InScopeSet to satisfy+-- point 3.+--+-- Note [ANF no let-bind]+--+-- | Do not let-bind:+--+-- 1. Arguments with an untranslatable type: untranslatable expressions+--    should be propagated down as far as possible+--+-- 2. Local variables or constants: they don't add any work, so no reason+--    to let-bind to enable sharing+--+-- 3. IO actions, the translation of IO actions to sequential HDL constructs+--    depends on IO actions to be propagated down as far as possible.+collectANF :: HasCallStack => NormRewriteW+collectANF ctx e@(App appf arg)+  | (conVarPrim, _) <- collectArgs e+  , isCon conVarPrim || isPrim conVarPrim || isVar conVarPrim+  = do+    tcm <- Lens.view tcCache+    untranslatable <- lift (isUntranslatable False arg)+    let localVar   = isLocalVar arg+        constantNoCR = isConstantNotClockReset tcm arg+    -- See Note [ANF no let-bind]+    case (untranslatable,localVar || constantNoCR, isSimBind conVarPrim,arg) of+      (False,False,False,_) -> do+        -- See Note [ANF InScopeSet]+        is1   <- Lens.use _2+        argId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "app_arg") arg)+        -- See Note [ANF InScopeSet]+        tellBinders [(argId,arg)]+        return (App appf (Var argId))+      (True,False,_,Letrec binds body) -> do+        tellBinders binds+        return (App appf body)+      _ -> return e+ where+  isSimBind (Prim p) = primName p == "Clash.Explicit.SimIO.bindSimIO#"+  isSimBind _ = False++collectANF _ (Letrec binds body) = do+  tcm <- Lens.view tcCache+  let isSimIO = isSimIOTy tcm (inferCoreTypeOf tcm body)+  untranslatable <- lift (isUntranslatable False body)+  let localVar = isLocalVar body+  -- See Note [ANF no let-bind]+  if localVar || untranslatable || isSimIO+    then do+      tellBinders binds+      return body+    else do+      -- See Note [ANF InScopeSet]+      is1 <- Lens.use _2+      argId <- lift (mkTmBinderFor is1 tcm (mkUnsafeSystemName "result" 0) body)+      -- See Note [ANF InScopeSet]+      tellBinders [(argId,body)]+      tellBinders binds+      return (Var argId)++-- TODO: The code below special-cases ANF for the ':-' constructor for the+-- 'Signal' type. The 'Signal' type is essentially treated as a "transparent"+-- type by the Clash compiler, so observing its constructor leads to all kinds+-- of problems. In this case that "Clash.Rewrite.Util.mkSelectorCase" will+-- try to project the LHS and RHS of the ':-' constructor, however,+-- 'mkSelectorCase' uses 'coreView1' to find the "real" data-constructor.+-- 'coreView1' however looks through the 'Signal' type, and hence 'mkSelector'+-- finds the data constructors for the element type of Signal. This resulted in+-- error #24 (https://github.com/christiaanb/clash2/issues/24), where we+-- try to get the first field out of the 'Vec's 'Nil' constructor.+--+-- Ultimately we should stop treating Signal as a "transparent" type and deal+-- handling of the Signal type, and the involved co-recursive functions,+-- properly. At the moment, Clash cannot deal with this recursive type and the+-- recursive functions involved, hence the need for special-casing code. After+-- everything is done properly, we should remove the two lines below.+collectANF _ e@(Case _ _ [(DataPat dc _ _,_)])+  | nameOcc (dcName dc) == Text.showt '(:-) = return e++collectANF ctx (Case subj ty alts) = do+    let localVar = isLocalVar subj+    let isConstantSubj = isConstant subj++    (subj',subjBinders) <- if localVar || isConstantSubj+      then return (subj,[])+      else do+        tcm <- Lens.view tcCache+        -- See Note [ANF InScopeSet]+        is1 <- Lens.use _2+        argId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "case_scrut") subj)+        -- See Note [ANF InScopeSet]+        notifyBinders [(argId,subj)]+        return (Var argId,[(argId,subj)])++    tcm <- Lens.view tcCache+    let isSimIOAlt = isSimIOTy tcm ty++    alts' <- mapM (doAlt isSimIOAlt subj') alts+    tellBinders subjBinders++    case alts' of+      [(DataPat _ [] xs,altExpr)]+        | mkVarSet xs `disjointFreeVars` altExpr || isSimIOAlt+        -> return altExpr+      _ -> return (Case subj' ty alts')+  where+    doAlt :: Bool -> Term -> Alt -> StateT ([LetBinding],InScopeSet) NormalizeSession Alt+    doAlt isSimIOAlt subj' alt@(DataPat dc exts xs,altExpr) | not (bindsExistentials exts xs) = do+      let lv = isLocalVar altExpr+      patSels <- Monad.zipWithM (doPatBndr subj' dc) xs [0..]+      let altExprIsConstant = isConstant altExpr+      let usesXs (Var n) = any (== n) xs+          usesXs _       = False+      -- See [ANF no let-bind]+      if or [isSimIOAlt, lv && (not (usesXs altExpr) || length alts == 1), altExprIsConstant]+        then do+          -- See Note [ANF InScopeSet]+          tellBinders patSels+          return alt+        else do+          tcm <- Lens.view tcCache+          -- See Note [ANF InScopeSet]+          is1 <- Lens.use _2+          altId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "case_alt") altExpr)+          -- See Note [ANF InScopeSet]+          tellBinders (patSels ++ [(altId,altExpr)])+          return (DataPat dc exts xs,Var altId)+    doAlt _ _ alt@(DataPat {}, _) = return alt+    doAlt isSimIOAlt _ alt@(pat,altExpr) = do+      let lv = isLocalVar altExpr+      let altExprIsConstant = isConstant altExpr+      -- See [ANF no let-bind]+      if isSimIOAlt || lv || altExprIsConstant+        then return alt+        else do+          tcm <- Lens.view tcCache+          -- See Note [ANF InScopeSet]+          is1 <- Lens.use _2+          altId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "case_alt") altExpr)+          tellBinders [(altId,altExpr)]+          return (pat,Var altId)++    doPatBndr :: Term -> DataCon -> Id -> Int -> StateT ([LetBinding],InScopeSet) NormalizeSession LetBinding+    doPatBndr subj' dc pId i = do+      tcm <- Lens.view tcCache+      -- See Note [ANF InScopeSet]+      is1 <- Lens.use _2+      patExpr <- lift (mkSelectorCase ($(curLoc) ++ "doPatBndr") is1 tcm subj' (dcTag dc) i)+      -- No need to 'tellBinders' here because 'pId' is already in the ANF+      -- InScopeSet.+      --+      -- See also Note [ANF InScopeSet]+      return (pId,patExpr)++collectANF _ e = return e+{-# SCC collectANF #-}++-- | Bring an application of a DataCon or Primitive in ANF, when the argument is+-- is considered non-representable+nonRepANF :: HasCallStack => NormRewrite+nonRepANF ctx@(TransformContext is0 _) e@(App appConPrim arg)+  | (conPrim, _) <- collectArgs e+  , isCon conPrim || isPrim conPrim+  = do+    untranslatable <- isUntranslatable False arg+    case (untranslatable,stripTicks arg) of+      (True,Let binds body) ->+        -- This is a situation similar to Note [CaseLet deshadow]+        let (binds1,body1) = deshadowLetExpr is0 binds body+        in  changed (Let binds1 (App appConPrim body1))+      (True,Case {})  -> specialize ctx e+      (True,Lam {})   -> specialize ctx e+      (True,TyLam {}) -> specialize ctx e+      _               -> return e++nonRepANF _ e = return e+{-# SCC nonRepANF #-}
+ src/Clash/Normalize/Transformations/Case.hs view
@@ -0,0 +1,744 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017-2022, Google Inc.,+                    2021-2024, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+  Transformations on case-expressions+-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Normalize.Transformations.Case+  ( caseCase+  , caseCon+  , caseElemNonReachable+  , caseFlat+  , caseLet+  , caseOneAlt+  , elimExistentials+  , elimCaseBigNumInternals+  ) where++import Control.Exception.Base (patError)+import GHC.Prim.Panic (absentError)+import qualified Control.Lens as Lens+import Control.Monad.State.Strict (evalState)+import Data.Bifunctor (second)+import Data.Coerce (coerce)+import qualified Data.Either as Either+import qualified Data.List as List+import qualified Data.List.Extra as List+import qualified Data.Maybe as Maybe+import qualified Data.Primitive.ByteArray as BA+import qualified Data.Text.Extra as Text (showt)+import GHC.Stack (HasCallStack)++import GHC.Num.Integer (Integer(..))++import Clash.Sized.Internal.BitVector as BV (BitVector, eq#)+import Clash.Sized.Internal.Index as I (Index, eq#)+import Clash.Sized.Internal.Signed as S (Signed, eq#)+import Clash.Sized.Internal.Unsigned as U (Unsigned, eq#)++import Clash.Core.DataCon (DataCon(..))+import Clash.Core.EqSolver+import Clash.Core.FreeVars (freeLocalIds, localVarsDoNotOccurIn)+import Clash.Core.HasType+import Clash.Core.Literal (Literal(..))+import Clash.Core.Name (nameOcc)+import Clash.Core.Pretty (showPpr)+import Clash.Core.Subst+import Clash.Core.Term+  ( Alt, Pat(..), PrimInfo(..), Term(..), collectArgs, collectArgsTicks+  , collectTicks, mkApps, mkTicks, patIds, stripTicks, Bind(..))+import Clash.Core.TyCon (TyConMap)+import Clash.Core.Type (LitTy(..), Type(..), TypeView(..), coreView1, tyView)+import Clash.Core.TysPrim (integerIsDc, naturalNsDc)+import Clash.Core.Util (listToLets, mkInternalVar)+import Clash.Core.VarEnv+  ( InScopeSet, elemVarSet, extendInScopeSet, extendInScopeSetList, mkVarSet+  , unitVarSet, uniqAway)+import Clash.Debug (traceIf)+import Clash.Driver.Types (DebugOpts(dbg_invariants))+import Clash.Netlist.Types (FilteredHWType(..), HWType(..))+import Clash.Netlist.Util (coreTypeToHWType, representableType)+import qualified Clash.Normalize.Primitives as NP (undefined, undefinedX)+import Clash.Normalize.Types (NormRewrite, NormalizeSession)+import Clash.Rewrite.Combinators ((>-!))+import Clash.Rewrite.Types+  ( TransformContext(..), bindings, customReprs, debugOpts, tcCache+  , typeTranslator, workFreeBinders)+import Clash.Rewrite.Util (changed, isFromInt, whnfRW)+import Clash.Rewrite.WorkFree+import Clash.Util (curLoc)++import Clash.XException (errorX)++-- | Move a Case-decomposition from the subject of a Case-decomposition to the+-- alternatives+caseCase :: HasCallStack => NormRewrite+caseCase (TransformContext is0 _) e@(Case (stripTicks -> Case scrut alts1Ty alts1) alts2Ty alts2) = do+  ty1Rep <- representableType+    <$> Lens.view typeTranslator+    <*> Lens.view customReprs+    <*> pure False+    <*> Lens.view tcCache+    <*> pure alts1Ty++  -- This is only worth doing if the inner case-expression has a+  -- non-representable alternative type.+  if ty1Rep then return e else+    -- Deshadow to prevent accidental capture of free variables of inner+    -- case. Imagine:+    --+    --   case (case a of {x -> x}) of {_ -> x}+    --+    -- 'x' is introduced the inner 'case' and used (as a free variable) in+    -- the outer one. The goal of 'caseCase' is to rewrite cases such that+    -- their subjects aren't cases. This is achieved by 'pushing' the outer+    -- case to all the alternatives of the inner one. Naively doing so in+    -- this example would cause an accidental capture:+    --+    --   case a of {x -> case x of {_ -> x}}+    --+    -- Suddenly, the 'x' in the alternative of the inner case statement+    -- refers to the one introduced by the outer one, instead of being a+    -- free variable. To prevent this, we deshadow the alternatives of the+    -- original inner case. We now end up with:+    --+    --   case a of {x1 -> case x1 of {_ -> x}}+    --+    let newAlts = fmap (second (\altE -> Case altE alts2Ty alts2))+                      (fmap (deShadowAlt is0) alts1)+     in changed $ Case scrut alts2Ty newAlts++caseCase _ e = return e+{-# SCC caseCase #-}++{-+NOTE: caseOneAlt before caseCon'++When you put a bang on a signal argument:+    f :: Signal d a -> _+    f !x = ...+GHC generates a case like:+    case x of+      _ :- _ -> ...++When this f is inlined in an:+    g = f (pure False)+And clash does its Signal d a ~ a thing we get:+    g = case False of+      _ :- _ -> ...+Because no pattern matches caseCon transforms this into+    g = undefined++By trying caseOneAlt first clash can instead drop the case+and use the body of the single alternative.+-}+caseCon :: HasCallStack => NormRewrite+caseCon = const caseOneAlt >-! caseCon'++-- | Specialize a Case-decomposition (replace by the RHS of an alternative) if+-- the subject is (an application of) a DataCon; or if there is only a single+-- alternative that doesn't reference variables bound by the pattern.+--+-- Note [CaseCon deshadow]+--+-- Imagine:+--+-- @+-- case D (f a b) (g x y) of+--   D a b -> h a+-- @+--+-- rewriting this to:+--+-- @+-- let a = f a b+-- in  h a+-- @+--+-- is very bad because the newly introduced let-binding now captures the free+-- variable 'a' in 'f a b'.+--+-- instead me must rewrite to:+--+-- @+-- let a1 = f a b+-- in  h a1+-- @+caseCon' :: HasCallStack => NormRewrite+caseCon' ctx@(TransformContext is0 _) e@(Case subj ty alts) = do+ tcm <- Lens.view tcCache+ case collectArgsTicks subj of+  -- The subject is an applied data constructor+  (Data dc, args, ticks) -> case List.find (equalCon . fst) alts of+    Just (DataPat _ tvs xs, altE) -> do+     let+      -- Create the substitution environment for all the existential+      -- type variables.+      exTysList = List.zipEqual tvs (drop (length (dcUnivTyVars dc)) (Either.rights args))+      exTySubst = extendTvSubstList (mkSubst is0) exTysList+      -- Apply the type-substitution in all the pattern variables, we need+      -- to do this because we might use them as let-bindings later on,+      -- and they should have the correct type.+      xs1 = fmap (substTyInVar exTySubst) xs+      -- Create an initial set of let-binders for all variables used in the+      -- RHS of the alternative. We might later decide to substitute instead+      -- of let-bind in case the RHS of the let-binder is work-free.+      fvs = Lens.foldMapOf freeLocalIds unitVarSet altE+      (binds,_) = List.partition ((`elemVarSet` fvs) . fst)+                $ List.zipEqual xs1 (Either.lefts args)+      binds1 = fmap (second (`mkTicks` ticks)) binds+     altE1 <-+       case binds1 of+        [] ->+          -- Apply the type-substitution for the existential type variables+          pure (substTm "caseCon'" exTySubst altE)+        _  -> do+          -- See Note [CaseCon deshadow]+          let+            -- Only let-bind expression that perform work.+            is1 = extendInScopeSetList (extendInScopeSetList is0 tvs) xs1+          ((is3,substIds),binds2) <- List.mapAccumLM newBinder (is1,[]) binds1+          let+            -- Create a substitution for all the existential type variables+            -- and the work-free expressions+            subst = mkSubst is3+                      `extendTvSubstList` exTysList+                      `extendIdSubstList` substIds+            body  = substTm "caseCon'" subst altE+          case Maybe.catMaybes binds2 of+            []     -> pure body+            -- Use listToLets to create a series of non-recursive lets instead+            -- of a recursive group. We know these binders will not form a group.+            binds3 -> pure (listToLets binds3 body)+     changed altE1+    _ -> case alts of+           -- In Core, default patterns always come first, so we match against+           -- that if there is one, and we couldn't match with any of the data+           -- patterns.+           ((DefaultPat,altE):_) -> changed altE+           _ -> changed (TyApp (Prim NP.undefined) ty)+    where+      -- Check whether the pattern matches the data constructor+      equalCon (DataPat dcPat _ _) = dcTag dc == dcTag dcPat+      equalCon _ = False++      -- Decide whether the applied arguments of the data constructor should+      -- be let-bound, or substituted into the alternative. We decide this+      -- based on the fact on whether the argument has the potential to make+      -- the circuit larger than needed if we were to duplicate that argument.+      newBinder (isN0, substN) (x, arg) = do+        bndrs <- Lens.use bindings+        isWorkFree workFreeBinders bndrs arg >>= \case+          True -> pure ((isN0, (x, arg):substN), Nothing)+          False ->+            let+              x' = uniqAway isN0 x+              isN1 = extendInScopeSet isN0 x'+            in+              pure ((isN1, (x, Var x'):substN), Just (x', arg))++  -- The subject is a literal+  (Literal l,_,_) -> case List.find (equalLit . fst) alts of+    Just (LitPat _,altE) -> changed altE+    _ -> matchLiteralContructor e l alts+    where+      equalLit (LitPat l') = l == l'+      equalLit _ = False++  -- The subject is an applied primitive+  (Prim _,_,_) ->+    -- We try to reduce the applied primitive to WHNF+    whnfRW True ctx subj $ \ctx1 subj1 -> case collectArgsTicks subj1 of+      -- WHNF of subject is a literal, try `caseCon` with that+      (Literal l,_,_) -> caseCon ctx1 (Case (Literal l) ty alts)+      -- WHNF of subject is a data-constructor, try `caseCon` with that+      (Data _,_,_) -> caseCon ctx1 (Case subj1 ty alts)+      -- WHNF of subject is _|_, in the form of `error`: that means that the+      -- entire case-expression is evaluates to _|_+      (Prim pInfo,repTy:_:callStack:msg:_,ticks)+        | primName pInfo == Text.showt 'error ->+        let e1 = mkApps (mkTicks (Prim pInfo) ticks)+                        [repTy,Right ty,callStack,msg]+         in changed e1+      -- WHNF of subject is _|_, in the form of `absentError`: that means that+      -- the entire case-expression is evaluates to _|_+      (Prim pInfo,_:msgOrCallStack:_,ticks)+        | primName pInfo == Text.showt 'absentError ->+        let e1 = mkApps (mkTicks (Prim pInfo) ticks)+                        [Right ty,msgOrCallStack]+        in  changed e1+      -- WHNF of subject is _|_, in the form of  `patError`, `undefined`, or+      -- `errorWithoutStackTrace`: that means the entire case-expression is _|_+      (Prim pInfo,repTy:_:msgOrCallStack:_,ticks)+        | primName pInfo `elem` [ Text.showt 'patError+                                , Text.showt 'undefined+                                , Text.showt 'errorWithoutStackTrace] ->+        let e1 = mkApps (mkTicks (Prim pInfo) ticks)+                        [repTy,Right ty,msgOrCallStack]+        in  changed e1+      -- WHNF of subject is _|_, in the form of our internal _|_-values: that+      -- means the entire case-expression is _|_+      (Prim pInfo,[_],ticks)+        | primName pInfo `elem` [ Text.showt 'NP.undefined+                                , Text.showt 'NP.undefinedX ] ->+        let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty]+        in changed e1+      -- WHNF of subject is _|_, in the form of `errorX`: that means that+      -- the entire case-expression is evaluates to _|_+      (Prim pInfo,_:callStack:msg:_,ticks)+        | primName pInfo == Text.showt 'errorX+        -> let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty,callStack,msg]+            in changed e1+      -- WHNF of subject is non of the above, so either a variable reference,+      -- or a primitive for which the evaluator doesn't have any evaluation+      -- rules.+      _ -> do+        let subjTy = inferCoreTypeOf tcm subj+        tran <- Lens.view typeTranslator+        reprs <- Lens.view customReprs+        case (`evalState` mempty) (coreTypeToHWType tran reprs tcm subjTy) of+          Right (FilteredHWType (Void (Just hty)) _areVoids)+            | hty `elem` [BitVector 0, Unsigned 0, Signed 0, Index 1]+            -- If we know that the type of the subject is zero-bits wide and+            -- one of the Clash number types. Then the only valid alternative is+            -- the one that can match on the literal "0", so try 'caseCon' with+            -- that.+            -> caseCon ctx1 (Case (Literal (IntegerLiteral 0)) ty alts)+          _ -> do+            opts <- Lens.view debugOpts+            -- When invariants are being checked, report missing evaluation+            -- rules for the primitive evaluator.+            traceIf (dbg_invariants opts && isConstant subj)+              ("Unmatchable constant as case subject: " ++ showPpr subj +++                 "\nWHNF is: " ++ showPpr subj1)+              -- Otherwise check whether the entire case-expression has a+              -- single alternative, and pick that one.+              (caseOneAlt e)++  -- The subject is a variable+  (Var v, [], _) | isNum0 (coreTypeOf v) ->+    -- If we know that the type of the subject is zero-bits wide and+    -- one of the Clash number types. Then the only valid alternative is+    -- the one that can match on the literal "0", so try 'caseCon' with+    -- that.+    caseCon ctx (Case (Literal (IntegerLiteral 0)) ty alts)+   where+    isNum0 (tyView -> TyConApp (nameOcc -> tcNm) [arg])+      | tcNm `elem`+        [ Text.showt ''BitVector+        , Text.showt ''Signed+        , Text.showt ''Unsigned+        ]+      = isLitX 0 arg+      | tcNm == Text.showt ''Index+      = isLitX 1 arg+    isNum0 (coreView1 tcm -> Just t) = isNum0 t+    isNum0 _ = False++    isLitX n (LitTy (NumTy m)) = n == m+    isLitX n (coreView1 tcm -> Just t) = isLitX n t+    isLitX _ _ = False++  -- Otherwise check whether the entire case-expression has a single+  -- alternative, and pick that one.+  _ -> caseOneAlt e++caseCon' _ e = return e+{-# SCC caseCon' #-}++{- [Note: Name re-creation]+The names of heap bound variables are safely generate with mkUniqSystemId in Clash.Core.Evaluator.newLetBinding.+But only their uniqs end up in the heap, not the complete names.+So we use mkUnsafeSystemName to recreate the same Name.+-}++matchLiteralContructor+  :: Term+  -> Literal+  -> [Alt]+  -> NormalizeSession Term+matchLiteralContructor c (IntegerLiteral l) alts = go (reverse alts)+ where+  go [(DefaultPat,e)] = changed e+  go ((DataPat dc [] [x],e):alts')+    | dcTag dc == 1+    , l >= ((-2)^(63::Int)) &&  l < 2^(63::Int)+    = let fvs = Lens.foldMapOf freeLocalIds unitVarSet e+          bind = NonRec x (Literal (IntLiteral l))+       in if x `elemVarSet` fvs+            then changed (Let bind e)+            else changed e+    | dcTag dc == 2+    , l >= 2^(63::Int)+    = let !(IP ba) = l+          ba'       = BA.ByteArray ba+          fvs       = Lens.foldMapOf freeLocalIds unitVarSet e+          bind      = NonRec x (Literal (ByteArrayLiteral ba'))+       in if x `elemVarSet` fvs+            then changed (Let bind e)+            else changed e+    | dcTag dc == 3+    , l < ((-2)^(63::Int))+    = let !(IN ba) = l+          ba'       = BA.ByteArray ba+          fvs       = Lens.foldMapOf freeLocalIds unitVarSet e+          bind      = NonRec x (Literal (ByteArrayLiteral ba'))+       in if x `elemVarSet` fvs+            then changed (Let bind e)+            else changed e+    | otherwise+    = go alts'+  go ((LitPat l', e):alts')+    | IntegerLiteral l == l'+    = changed e+    | otherwise+    = go alts'+  go _ = error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showPpr c++matchLiteralContructor c (NaturalLiteral l) alts = go (reverse alts)+ where+  go [(DefaultPat,e)] = changed e+  go ((DataPat dc [] [x],e):alts')+    | dcTag dc == 1+    , l >= 0 && l < 2^(64::Int)+    = let fvs       = Lens.foldMapOf freeLocalIds unitVarSet e+          bind      = NonRec x (Literal (WordLiteral l))+       in if x `elemVarSet` fvs+            then changed (Let bind e)+            else changed e+    | dcTag dc == 2+    , l >= 2^(64::Int)+    = let !(IP ba) = l+          ba'       = BA.ByteArray ba+          fvs       = Lens.foldMapOf freeLocalIds unitVarSet e+          bind      = NonRec x (Literal (ByteArrayLiteral ba'))+       in if x `elemVarSet` fvs+            then changed (Let bind e)+            else changed e+    | otherwise+    = go alts'+  go ((LitPat l', e):alts')+    | NaturalLiteral l == l'+    = changed e+    | otherwise+    = go alts'+  go _ = error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showPpr c++matchLiteralContructor _ _ ((DefaultPat,e):_) = changed e+matchLiteralContructor c _ _ =+  error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showPpr c+{-# SCC matchLiteralContructor #-}++-- | Remove non-reachable alternatives. For example, consider:+--+-- @+-- data STy ty where+--   SInt :: Int -> STy Int+--   SBool :: Bool -> STy Bool+--+-- f :: STy ty -> ty+-- f (SInt b) = b + 1+-- f (SBool True) = False+-- f (SBool False) = True+-- {\-\# NOINLINE f \#-\}+--+-- g :: STy Int -> Int+-- g = f+-- @+--+-- @f@ is always specialized on @STy Int@. The SBool alternatives are therefore+-- unreachable. Additional information can be found at:+-- https://github.com/clash-lang/clash-compiler/pull/465+caseElemNonReachable :: HasCallStack => NormRewrite+caseElemNonReachable _ case0@(Case scrut altsTy alts0) = do+  tcm <- Lens.view tcCache++  let (altsAbsurd, altsOther) = List.partition (isAbsurdPat tcm . fst) alts0+  case altsAbsurd of+    [] -> return case0+    _  -> changed =<< caseOneAlt (Case scrut altsTy altsOther)++caseElemNonReachable _ e = return e+{-# SCC caseElemNonReachable #-}++-- | Flatten ridiculous case-statements generated by GHC+--+-- For case-statements in haskell of the form:+--+-- @+-- f :: Unsigned 4 -> Unsigned 4+-- f x = case x of+--   0 -> 3+--   1 -> 2+--   2 -> 1+--   3 -> 0+-- @+--+-- GHC generates Core that looks like:+--+-- @+-- f = \\(x :: Unsigned 4) -> case x == fromInteger 3 of+--                             False -> case x == fromInteger 2 of+--                               False -> case x == fromInteger 1 of+--                                 False -> case x == fromInteger 0 of+--                                   False -> error "incomplete case"+--                                   True  -> fromInteger 3+--                                 True -> fromInteger 2+--                               True -> fromInteger 1+--                             True -> fromInteger 0+-- @+--+-- Which would result in a priority decoder circuit where a normal decoder+-- circuit was desired.+--+-- This transformation transforms the above Core to the saner:+--+-- @+-- f = \\(x :: Unsigned 4) -> case x of+--        _ -> error "incomplete case"+--        0 -> fromInteger 3+--        1 -> fromInteger 2+--        2 -> fromInteger 1+--        3 -> fromInteger 0+-- @+caseFlat :: HasCallStack => NormRewrite+caseFlat (TransformContext is0 _) e@(Case (collectEqArgs -> Just (scrut',val)) ty _) =+  case collectFlat scrut' e of+    Just alts' -> case collectArgs val of+      -- When we're pattern matching on `Int`, extract the `Int#` first before+      -- we do the Literal matching branches.+      (Data dc,_)+        | nameOcc (dcName dc) == "GHC.Types.I#"+        , [argTy] <- dcArgTys dc+        -> do+          wild <- mkInternalVar is0 "wild" argTy+          changed (Case scrut' ty+                    [(DataPat dc [] [wild]+                     ,Case (Var wild) ty (last alts' : init alts'))])+      _ -> changed (Case scrut' ty (last alts' : init alts'))+    Nothing -> return e++caseFlat _ e = return e+{-# SCC caseFlat #-}++collectFlat :: Term -> Term -> Maybe [Alt]+collectFlat scrut (Case (collectEqArgs -> Just (scrut', val)) _ty [lAlt,rAlt])+  | scrut' == scrut+  = case collectArgs val of+      (Prim p,args') | isFromInt (primName p) ->+        go (last args')+      (Data dc,args') | nameOcc (dcName dc) == "GHC.Types.I#" ->+        go (last args')+      _ -> Nothing+  where+    go (Left (Literal i)) = case (lAlt,rAlt) of+              ((pl,el),(pr,er))+                | isFalseDcPat pl || isTrueDcPat pr ->+                   case collectFlat scrut el of+                     Just alts' -> Just ((LitPat i, er) : alts')+                     Nothing    -> Just [(LitPat i, er)+                                        ,(DefaultPat, el)+                                        ]+                | otherwise ->+                   case collectFlat scrut er of+                     Just alts' -> Just ((LitPat i, el) : alts')+                     Nothing    -> Just [(LitPat i, el)+                                        ,(DefaultPat, er)+                                        ]+    go _ = Nothing++    isFalseDcPat (DataPat p _ _)+      = ((== "GHC.Types.False") . nameOcc . dcName) p+    isFalseDcPat _ = False++    isTrueDcPat (DataPat p _ _)+      = ((== "GHC.Types.True") . nameOcc . dcName) p+    isTrueDcPat _ = False++collectFlat _ _ = Nothing+{-# SCC collectFlat #-}++collectEqArgs :: Term -> Maybe (Term,Term)+collectEqArgs f@(collectArgsTicks -> (Prim p, args, ticks))+  | nm == Text.showt 'BV.eq#+    = case args of+        [_,_,Left scrut,Left val] -> Just (mkTicks scrut ticks,val)+        _ -> error ("collectEqArgs: BV.eq expects 4 arguments, but got: " <> showPpr f)+  | nm == Text.showt 'I.eq#  ||+    nm == Text.showt 'S.eq# ||+    nm == Text.showt 'U.eq#+    = case args of+        [_,Left scrut,Left val] -> Just (mkTicks scrut ticks,val)+        _ -> error (show nm <> " expects 3 arguments, but got: " <> showPpr f)+  | nm == "GHC.Classes.eqInt"+    = case args of+        [Left scrut,Left val] -> Just (mkTicks scrut ticks,val)+        _ -> error ("eqInt expects 2 arguments, but got: " <> showPpr f)+ where+  nm = primName p++collectEqArgs _ = Nothing++-- | Lift the let-bindings out of the subject of a Case-decomposition+caseLet :: HasCallStack => NormRewrite+caseLet (TransformContext is0 _) (Case (collectTicks -> (Let xes e,ticks)) ty alts) = do+  -- Note [CaseLet deshadow]+  -- Imagine+  --+  -- @+  -- case (let x = u in e) of {p -> a}+  -- @+  --+  -- where `a` has a free variable named `x`.+  --+  -- Simply transforming the above to:+  --+  -- @+  -- let x = u in case e of {p -> a}+  -- @+  --+  -- would be very bad, because now the let-binding captures the free x variable+  -- in a.+  --+  -- We must therefor rename `x` so that it doesn't capture the free variables+  -- in the alternative:+  --+  -- @+  -- let x1 = u[x:=x1] in case e[x:=x1] of {p -> a}+  -- @+  --+  -- It is safe to over-approximate the free variables in `a` by simply taking+  -- the current InScopeSet.+  let (xes1,e1) = deshadowLetExpr is0 xes e+  changed (Let (fmap (`mkTicks` ticks) xes1)+                  (Case (mkTicks e1 ticks) ty alts))++caseLet _ e = return e+{-# SCC caseLet #-}++caseOneAlt :: Term -> NormalizeSession Term+caseOneAlt e@(Case _ _ [(pat,altE)]) =+  case pat of+    DefaultPat -> changed altE+    LitPat _ -> changed altE+    DataPat _ tvs xs+      | (coerce tvs ++ coerce xs) `localVarsDoNotOccurIn` altE+      -> changed altE+      | otherwise+      -> return e++caseOneAlt (Case _ _ ((pat,alt):alts@(_:_)))+  | all ((== alt) . snd) alts+  , (tvs,xs) <- patIds pat+  , (coerce tvs ++ coerce xs) `localVarsDoNotOccurIn` alt+  = changed alt++caseOneAlt e = return e+{-# SCC caseOneAlt #-}++-- | Tries to eliminate existentials by using heuristics to determine what the+-- existential should be. For example, consider Vec:+--+--    data Vec :: Nat -> Type -> Type where+--      Nil       :: Vec 0 a+--      Cons x xs :: a -> Vec n a -> Vec (n + 1) a+--+-- Thus, 'null' (annotated with existentials) could look like:+--+--    null :: forall n . Vec n Bool -> Bool+--    null v =+--      case v of+--        Nil  {n ~ 0}                                     -> True+--        Cons {n1:Nat} {n~n1+1} (x :: a) (xs :: Vec n1 a) -> False+--+-- When it's applied to a vector of length 5, this becomes:+--+--    null :: Vec 5 Bool -> Bool+--    null v =+--      case v of+--        Nil  {5 ~ 0}                                     -> True+--        Cons {n1:Nat} {5~n1+1} (x :: a) (xs :: Vec n1 a) -> False+--+-- This function solves 'n1' and replaces every occurrence with its solution. A+-- very limited number of solutions are currently recognized: only adds (such+-- as in the example) will be solved.+elimExistentials :: HasCallStack => NormRewrite+elimExistentials (TransformContext is0 _) (Case scrut altsTy alts0) = do+  tcm <- Lens.view tcCache+  alts1 <- traverse (go is0 tcm) alts0+  caseOneAlt (Case scrut altsTy alts1)+ where+    -- Eliminate free type variables if possible+    go :: InScopeSet -> TyConMap -> Alt -> NormalizeSession Alt+    go is2 tcm alt@(pat@(DataPat dc exts0 xs0), term0) =+      case solveNonAbsurds tcm (mkVarSet exts0) (patEqs tcm pat) of+        -- No equations solved:+        [] -> return alt+        -- One or more equations solved:+        sols ->+          changed =<< go is2 tcm (DataPat dc exts1 xs1, term1)+          where+            -- Substitute solution in existentials and applied types+            is3 = extendInScopeSetList is2 exts0+            xs1 = fmap (substTyInVar (extendTvSubstList (mkSubst is3) sols)) xs0+            exts1 = substInExistentialsList is2 exts0 sols++            -- Substitute solution in term.+            is4 = extendInScopeSetList is3 xs1+            subst = extendTvSubstList (mkSubst is4) sols+            term1 = substTm "Replacing tyVar due to solved eq" subst term0++    go _ _ alt = return alt++elimExistentials _ e = return e+{-# SCC elimExistentials #-}++-- | This finds cases on Integers and Naturals and rewrites them+-- to remove the alternatives with bignums/bytearrays in them.+--+-- Natural and Integer are defined as:+-- @+-- data Natural = NS Word# | NB ByteArray#+-- data Integer = IS Int#  | IP ByteArray#  | IN ByteArray#+-- @+-- Both 'Natural' and 'Integer' have invariants stating that they will only use NB/IP/IN+-- when their values doesn't fit in NS/IS. And the code in base also makes use of that.+-- So we can be sure that small values, that are representable in HDL, are always encoded with NS/IS.+--+-- Because the NB/IP/IN don't/can't exist in HDL, this transformation looks for case with+-- patterns for NS/IS and just always picks those alternatives, and removes the other+-- alternatives.+--+-- This is as "safe" as the rest of the Natural/Integer handling that clash does in HDL,+-- because numbers bigger then Word/Int can't exist there anyway.+elimCaseBigNumInternals :: HasCallStack => NormRewrite+elimCaseBigNumInternals _ e@(Case scrut altsTy alts0@(_:_:_)) =+  go alts0+ where+  go [] = return e+  go ((pat,altE):alts) = case pat of+    DataPat dc [] [x] | (dc == integerIsDc || dc == naturalNsDc) ->+      if elemVarSet x fvs then+        -- field used, turn the case into a projection+        -- It seems this pattern never happens after ANF.+        changed (Case scrut altsTy [(DataPat dc [] [x],altE)])+      else+        -- field not used, eliminate the case completely+        changed altE+    _ -> go alts+   where+    fvs = Lens.foldMapOf freeLocalIds unitVarSet altE++elimCaseBigNumInternals _ e = return e
+ src/Clash/Normalize/Transformations/Cast.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Normalize.Transformations.Cast+  ( argCastSpec+  , caseCast+  , elimCastCast+  , letCast+  , splitCastWork+  ) where++import Control.Exception (throw)+import qualified Control.Lens as Lens+import Control.Monad.Writer (listen)+import qualified Data.Monoid as Monoid (Any(..))+import GHC.Stack (HasCallStack)++import Clash.Core.Name (nameOcc)+import Clash.Core.Pretty (showPpr)+import Clash.Core.Term (LetBinding, Term(..), collectArgs, stripTicks)+import Clash.Core.TermInfo (isCast)+import Clash.Core.Type (normalizeType)+import Clash.Core.Var (isGlobalId, varName)+import Clash.Core.VarEnv (InScopeSet)+import Clash.Debug (trace)+import Clash.Normalize.Transformations.Specialize (specialize)+import Clash.Normalize.Types (NormRewrite, NormalizeSession)+import Clash.Rewrite.Types+  (TransformContext(..), bindings, curFun, tcCache, workFreeBinders)+import Clash.Rewrite.Util (changed, mkDerivedName, mkTmBinderFor)+import Clash.Rewrite.WorkFree (isWorkFree)+import Clash.Util (ClashException(..), curLoc)++-- | Push cast over an argument to a function into that function+--+-- This is done by specializing on the casted argument.+-- Example:+-- @+--   y = f (cast a)+--     where f x = g x+-- @+-- transforms to:+-- @+--   y = f' a+--     where f' x' = (\\x -> g x) (cast x')+-- @+--+-- The reason d'etre for this transformation is that we hope to end up with+-- and expression where two casts are "back-to-back" after which we can+-- eliminate them in 'elimCastCast'.+argCastSpec :: HasCallStack => NormRewrite+argCastSpec ctx e@(App f (stripTicks -> Cast e' _ _))+ -- Don't specialise when the arguments are casts-of-casts, these casts-of-casts+ -- will be eliminated by 'elimCastCast' during the normalization of the+ -- "current" function. We thus prevent the unnecessary introduction of a+ -- specialized version of 'f'.+ | not (isCast e')+ -- We can only push casts into global binders+ , (Var g, _) <- collectArgs f+ , isGlobalId g = do+  bndrs <- Lens.use bindings+  isWorkFree workFreeBinders bndrs e' >>= \case+    True -> go+    False -> warn go+ where+  go = specialize ctx e+  warn = trace (unwords+    [ "WARNING:", $(curLoc), "specializing a function on a non work-free"+    , "cast. Generated HDL implementation might contain duplicate work."+    , "Please report this as a bug.", "\n\nExpression where this occured:"+    , "\n\n" ++ showPpr e+    ])+argCastSpec _ e = return e+{-# SCC argCastSpec #-}++-- | Push a cast over a case into it's alternatives.+caseCast :: HasCallStack => NormRewrite+caseCast _ (Cast (stripTicks -> Case subj ty alts) ty1 ty2) = do+  let alts' = map (\(p,e) -> (p, Cast e ty1 ty2)) alts+  changed (Case subj ty alts')+caseCast _ e = return e+{-# SCC caseCast #-}++-- | Eliminate two back to back casts where the type going in and coming out are the same+--+-- @+--   (cast :: b -> a) $ (cast :: a -> b) x   ==> x+-- @+elimCastCast :: HasCallStack => NormRewrite+elimCastCast _ c@(Cast (stripTicks -> Cast e tyA tyB) tyB' tyC) = do+  tcm <- Lens.view tcCache+  let ntyA  = normalizeType tcm tyA+      ntyB  = normalizeType tcm tyB+      ntyB' = normalizeType tcm tyB'+      ntyC  = normalizeType tcm tyC+  if ntyB == ntyB' && ntyA == ntyC then changed e+                                   else throwError+  where throwError = do+          (nm,sp) <- Lens.use curFun+          throw (ClashException sp ($(curLoc) ++ showPpr nm+                  ++ ": Found 2 nested casts whose types don't line up:\n"+                  ++ showPpr c)+                Nothing)++elimCastCast _ e = return e+{-# SCC elimCastCast #-}++-- | Push a cast over a Let into it's body+letCast :: HasCallStack => NormRewrite+letCast _ (Cast (stripTicks -> Let binds body) ty1 ty2) =+  changed $ Let binds (Cast body ty1 ty2)+letCast _ e = return e+{-# SCC letCast #-}++-- | Make a cast work-free by splitting the work of to a separate binding+--+-- @+-- let x = cast (f a b)+-- ==>+-- let x  = cast x'+--     x' = f a b+-- @+splitCastWork :: HasCallStack => NormRewrite+splitCastWork ctx@(TransformContext is0 _) unchanged@(Letrec vs e') = do+  (vss', Monoid.getAny -> hasChanged) <- listen (mapM (splitCastLetBinding is0) vs)+  let vs' = concat vss'+  if hasChanged then changed (Letrec vs' e')+                else return unchanged+  where+    splitCastLetBinding+      :: InScopeSet+      -> LetBinding+      -> NormalizeSession [LetBinding]+    splitCastLetBinding isN x@(nm, e) = case stripTicks e of+      Cast (Var {}) _ _  -> return [x]  -- already work-free+      Cast (Cast {}) _ _ -> return [x]  -- casts will be eliminated+      Cast e0 ty1 ty2 -> do+        tcm <- Lens.view tcCache+        nm' <- mkTmBinderFor isN tcm (mkDerivedName ctx (nameOcc $ varName nm)) e0+        changed [(nm',e0)+                ,(nm, Cast (Var nm') ty1 ty2)+                ]+      _ -> return [x]++splitCastWork _ e = return e+{-# SCC splitCastWork #-}
+ src/Clash/Normalize/Transformations/DEC.hs view
@@ -0,0 +1,789 @@+{-|+  Copyright  :  (C) 2015-2016, University of Twente,+                    2021-2024, QBayLogic B.V.+                    2022,      LumiGuide Fietsdetectie B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  The 'disjointExpressionConsolidation' transformation lifts applications of+  global binders out of alternatives of case-statements.++  e.g. It converts:++  > case x of+  >   A -> f 3 y+  >   B -> f x x+  >   C -> h x++  into:++  > let f_arg0 = case x of {A -> 3; B -> x}+  >     f_arg1 = case x of {A -> y; B -> x}+  >     f_out  = f f_arg0 f_arg1+  > in  case x of+  >       A -> f_out+  >       B -> f_out+  >       C -> h x+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MagicHash #-}++module Clash.Normalize.Transformations.DEC+  ( disjointExpressionConsolidation+  ) where++import Control.Lens ((^.), _1)+import qualified Control.Lens as Lens+import qualified Control.Monad as Monad+import Data.Bifunctor (first, second)+import Data.Bits ((.&.), complement)+import Data.Coerce (coerce)+import qualified Data.Either as Either+import qualified Data.Foldable as Foldable+import qualified Data.Graph as Graph+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import qualified Data.List as List+import qualified Data.List.Extra as List+import qualified Data.Map.Strict as Map+import qualified Data.Maybe as Maybe+import Data.Monoid (All(..))+import qualified Data.Text as Text+import Data.Text.Extra (showt)+import GHC.Stack (HasCallStack)+import qualified Language.Haskell.TH as TH++import GHC.Core.Make (chunkify, mkChunkified)++import GHC.Settings.Constants (mAX_TUPLE_SIZE)++-- internal+import Clash.Core.DataCon (DataCon)+import Clash.Core.Evaluator.Types  (whnf')+import Clash.Core.FreeVars+  (termFreeVars', typeFreeVars', localVarsDoNotOccurIn)+import Clash.Core.HasType+import Clash.Core.Literal (Literal(..))+import Clash.Core.Name (OccName, nameOcc)+import Clash.Core.Pretty (showPpr)+import Clash.Core.Term+  ( Alt, LetBinding, Pat(..), PrimInfo(..), Term(..), TickInfo(..)+  , collectArgs, collectArgsTicks, mkApps, mkTicks, patIds, stripTicks)+import Clash.Core.TyCon (TyConMap, TyConName, tyConDataCons)+import Clash.Core.Type+  (Type, TypeView (..), isPolyFunTy, mkTyConApp, splitFunForallTy, tyView)+import Clash.Core.Util (mkInternalVar, mkSelectorCase, sccLetBindings)+import Clash.Core.Var (Id, isGlobalId, isLocalId, varName)+import Clash.Core.VarEnv+  ( InScopeSet, elemInScopeSet, extendInScopeSet, extendInScopeSetList+  , notElemInScopeSet, unionInScope)+import qualified Clash.Data.UniqMap as UniqMap+import Clash.Normalize.Transformations.Letrec (deadCode)+import Clash.Normalize.Types (NormRewrite, NormalizeSession)+import Clash.Rewrite.Combinators (bottomupR)+import Clash.Rewrite.Types+import Clash.Rewrite.Util (changed, isFromInt, isUntranslatableType)+import Clash.Rewrite.WorkFree (isConstant)+import Clash.Util (MonadUnique, curLoc)+import Clash.Util.Supply (splitSupply)++-- primitives+import qualified Clash.Sized.Internal.BitVector+import qualified Clash.Sized.Internal.Index+import qualified Clash.Sized.Internal.Signed+import qualified Clash.Sized.Internal.Unsigned+import qualified GHC.Base+import qualified GHC.Classes+import qualified GHC.Num.Integer+import qualified GHC.Prim++-- | This transformation lifts applications of global binders out of+-- alternatives of case-statements.+--+-- e.g. It converts:+--+-- @+-- case x of+--   A -> f 3 y+--   B -> f x x+--   C -> h x+-- @+--+-- into:+--+-- @+-- let f_arg0 = case x of {A -> 3; B -> x}+--     f_arg1 = case x of {A -> y; B -> x}+--     f_out  = f f_arg0 f_arg1+-- in  case x of+--       A -> f_out+--       B -> f_out+--       C -> h x+-- @+--+-- Though that's a lie. It actually converts it into:+--+-- @+-- let f_tupIn = case x of {A -> (3,y); B -> (x,x)}+--     f_arg0  = case f_tupIn of (l,_) -> l+--     f_arg1  = case f_tupIn of (_,r) -> r+--     f_out   = f f_arg0 f_arg1+-- in  case x of+--       A -> f_out+--       B -> f_out+--       C -> h x+-- @+--+-- In order to share the expression that's in the subject of the case expression,+-- and to share the /decoder/ circuit that logic synthesis will create to map the+-- bits of the subject expression to the bits needed to make the selection in the+-- multiplexer.+disjointExpressionConsolidation :: HasCallStack => NormRewrite+disjointExpressionConsolidation ctx@(TransformContext isCtx _) e@(Case _scrut _ty _alts@(_:_:_)) = do+    -- Collect all (the applications of) global binders (and certain primitives)+    -- that would be interesting to share out of the case-alternatives.+    (_,isCollected,collected) <- collectGlobals isCtx [] [] e+    -- Filter those that are used at most once in every (nested) branch.+    let disJoint = filter (isDisjoint . snd . snd) collected+    if null disJoint+       then return e+       else do+         -- For every to-lift expression create (the generalization of):+         --+         -- let f_tupIn = case x of {A -> (3,y); B -> (x,x)}+         --     f_arg0  = case f_tupIn of (l,_) -> l+         --     f_arg1  = case f_tupIn of (_,r) -> r+         -- in  f f_arg0 f_arg0+         --+         -- if an argument is non-representable, the case-expression is inlined,+         -- and no let-binding will be created for it.+         --+         -- NB: mkDisJointGroup needs the context InScopeSet, isCtx, to determine+         -- whether expressions reference variables from the context, or+         -- variables inside a let-expression inside one of the alternatives.+         lifted <- mapM (mkDisjointGroup isCtx) disJoint+         tcm    <- Lens.view tcCache+         -- Create let-binders for all of the lifted expressions+         --+         -- NB: Because we will be substituting under binders we use the collected+         -- inScopeSet, isCollected, which also contains all the binders+         -- created inside all of the alternatives. With this inScopeSet, we+         -- ensure that the let-bindings we create here won't be accidentally+         -- captured by binders inside the case-alternatives.+         (_,funOutIds) <- List.mapAccumLM (mkFunOut tcm)+                                          isCollected+                                          (zip disJoint lifted)+         -- Create "substitutions" of the form [f X Y := f_out]+         let substitution = zip (map fst disJoint) (map Var funOutIds)+         -- For all of the lifted expression: substitute occurrences of the+         -- disjoint expressions (f X Y) by a variable reference to the lifted+         -- expression (f_out)+         let isCtx1 = extendInScopeSetList isCtx funOutIds+         lifted1 <- substLifted isCtx1 substitution lifted+         -- Do the same for the actual case expression+         (e1,_,_) <- collectGlobals isCtx1 substitution [] e+         -- Let-bind all the lifted function+         let lb = Letrec (zip funOutIds lifted1) e1+         -- Do an initial dead-code elimination pass, as `mkDisJoint` doesn't+         -- clean-up unused let-binders.+         lb1 <- bottomupR deadCode ctx lb+         changed lb1+  where+    -- Make the let-binder for the lifted expressions+    mkFunOut tcm isN ((fun,_),(eLifted,_)) = do+      let ty  = inferCoreTypeOf tcm eLifted+          nm  = decFunName fun+          nm1 = nm `Text.append` "_out"+      nm2 <- mkInternalVar isN nm1 ty+      return (extendInScopeSet isN nm2,nm2)++    -- Substitute inside the lifted expressions+    --+    -- In case you are wondering why this function isn't simply+    --+    -- > mapM (\s (eL,seen) -> collectGlobal isN s seen eL) substitution lifted+    --+    -- then that's because we have e.g. the list of "substitutions":+    --+    -- [foo _ _ := foo_out; bar _ _ := bar_out]+    --+    -- and if we were to apply that to a lifted expression, which is going+    -- to be of the form `foo (case ...) (case ...)` then we would end up+    -- with let-bindings that are simply:+    --+    -- > let foo_out = foo_out ; bar_out = bar_out+    --+    -- instead of the desired+    --+    -- > let foo_out = foo ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out])+    -- >                   ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out])+    -- >     bar_out = bar ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out])+    -- >                   ((case ...)[foo _ _ := foo_out; bar _ _ := bar_out])+    --+    -- So what we do is that for every lifted-expression we make sure that the+    -- 'substitution' never contains the self-substitution, so we end up with:+    --+    -- > let foo_out = (foo (case ...) (case ...))[bar _ _ := bar_out]+    --       bar_out = (bar (case ...) (case ...))[foo _ _ := foo_out]+    --+    -- We used to have a different approach, see commit+    -- 73d237017c4a5fff0c49bb72c9c4d5f6c68faf69+    --+    -- But that lead to the generation of combinational loops. Now that we no+    -- longer traverse into recursive groups of let-bindings, the issue #1316+    -- that the above commit tried to solve, no longer shows up.+    substLifted isN substitution lifted = do+      -- remove the self-substitutions for the respective lifted expressions+      let subsMatrix = l2m substitution+      lifted1 <- Monad.zipWithM (\s (eL,seen) -> collectGlobals isN s seen eL)+                                 subsMatrix+                                 lifted+      return (map (^. _1) lifted1)++    l2m = go []+     where+      go _  []     = []+      go xs (y:ys) = (xs ++ ys) : go (xs ++ [y]) ys++disjointExpressionConsolidation _ e = return e+{-# SCC disjointExpressionConsolidation #-}++decFunName :: Term -> OccName+decFunName fun = last . Text.splitOn "." $ case collectArgs fun of+  (Var v, _) -> nameOcc (varName v)+  (Prim p, _) -> primName p+  _ -> "complex_expression"++data CaseTree a+  = Leaf a+  | LB [LetBinding] (CaseTree a)+  | Branch Term [(Pat,CaseTree a)]+  deriving (Eq,Show,Functor,Foldable)++instance Applicative CaseTree where+  pure = Leaf+  liftA2 f (Leaf a) (Leaf b) = Leaf (f a b)+  liftA2 f (LB lb c1) (LB _ c2) = LB lb (liftA2 f c1 c2)+  liftA2 f (Branch scrut alts1) (Branch _ alts2) =+    Branch scrut (zipWith (\(p1,a1) (_,a2) -> (p1,liftA2 f a1 a2)) alts1 alts2)+  liftA2 _ _ _ = error "CaseTree.liftA2: internal error, this should not happen."++-- | Test if a 'CaseTree' collected from an expression indicates that+-- application of a global binder is disjoint: occur in separate branches of a+-- case-expression.+isDisjoint :: CaseTree ([Either Term Type])+           -> Bool+isDisjoint (Branch _ [_]) = False+isDisjoint ct = go ct+  where+    go (Leaf _)             = False+    go (LB _ ct')           = go ct'+    go (Branch _ [])        = False+    go (Branch _ [(_,x)])   = go x+    go b@(Branch _ (_:_:_)) = allEqual (map Either.rights (Foldable.toList b))++-- | Test if all elements in a list are equal to each other.+allEqual :: Eq a => [a] -> Bool+allEqual []     = True+allEqual (x:xs) = all (== x) xs++-- | Collect 'CaseTree's for (potentially) disjoint applications of globals out+-- of an expression. Also substitute truly disjoint applications of globals by a+-- reference to a lifted out application.+collectGlobals+  :: InScopeSet+  -> [(Term,Term)]+  -- ^ Substitution of (applications of) a global binder by a reference to a+  -- lifted term.+  -> [Term]+  -- ^ List of already seen global binders+  -> Term+  -- ^ The expression+  -> NormalizeSession (Term, InScopeSet, [(Term, ([Term], CaseTree [Either Term Type]))])+collectGlobals is0 substitution seen (Case scrut ty alts) = do+  rec (alts1, isAlts, collectedAlts) <-+        collectGlobalsAlts is0 substitution seen scrut1 alts+      (scrut1, isScrut, collectedScrut) <-+        collectGlobals is0 substitution (map fst collectedAlts ++ seen) scrut+  return ( Case scrut1 ty alts1+         , unionInScope isAlts isScrut+         , collectedAlts ++ collectedScrut )++collectGlobals is0 substitution seen e@(collectArgsTicks -> (fun, args@(_:_), ticks))+  | not (isConstant e) = do+    tcm <- Lens.view tcCache+    bndrs <- Lens.use bindings+    evaluate <- Lens.view evaluator+    ids <- Lens.use uniqSupply+    let (ids1,ids2) = splitSupply ids+    uniqSupply Lens..= ids2+    gh <- Lens.use globalHeap+    let eval = (Lens.view Lens._3) . whnf' evaluate bndrs mempty tcm gh ids1 is0 False+    let eTy  = inferCoreTypeOf tcm e+    untran <- isUntranslatableType False eTy+    case untran of+      -- Don't lift out non-representable values, because they cannot be let-bound+      -- in our desired normal form.+      False -> do+        -- Look for, and substitute by, disjoint applications of globals in+        -- the arguments first before considering the current term in function+        -- position. Doing it in the other order (this term in function position+        -- first, followed by arguments) resulted in issue #1322+        (args1,isArgs,collectedArgs) <-+          collectGlobalsArgs is0 substitution seen args+        let seenInArgs = map fst collectedArgs ++ seen+            isInteresting = interestingToLift is0 eval fun args ticks+        case isInteresting of+          Just fun1 | fun1 `notElem` seenInArgs -> do+            let e1 = Maybe.fromMaybe (mkApps (mkTicks fun1 ticks) args1) (List.lookup fun1 substitution)+            -- This function is lifted out an environment with the currently 'seen'+            -- binders. When we later apply substitution, we need to start with this+            -- environment, otherwise we perform incorrect substitutions in the+            -- arguments.+            return (e1,isArgs,(fun1,(seen,Leaf args1)):collectedArgs)+          _ -> return (mkApps (mkTicks fun ticks) args1, isArgs, collectedArgs)+      _ -> return (e,is0,[])++-- FIXME: This duplicates A LOT of let-bindings, where I just pray that after+-- the ANF, CSE, and DeadCodeRemoval pass all duplicates are removed.+--+-- I think we should be able to do better, but perhaps we cannot fix it here.+collectGlobals is0 substitution seen (Letrec lbs body) = do+  let is1 = extendInScopeSetList is0 (map fst lbs)+  (body1,isBody,collectedBody) <-+    collectGlobals is1 substitution seen body+  (lbs1,isBndrs,collectedBndrs) <-+    collectGlobalsLbs is1 substitution (map fst collectedBody ++ seen) lbs+  return ( Letrec lbs1 body1+         , unionInScope isBody isBndrs+         , map (second (second (LB lbs1))) (collectedBody ++ collectedBndrs)+         )++collectGlobals is0 substitution seen (Tick t e) = do+  (e1,is1,collected) <- collectGlobals is0 substitution seen e+  return (Tick t e1, is1, collected)++collectGlobals is0 _ _ e = return (e,is0,[])++-- | Collect 'CaseTree's for (potentially) disjoint applications of globals out+-- of a list of application arguments. Also substitute truly disjoint+-- applications of globals by a reference to a lifted out application.+collectGlobalsArgs+  :: InScopeSet+  -> [(Term,Term)] -- ^ Substitution of (applications of) a global+                   -- binder by a reference to a lifted term.+  -> [Term] -- ^ List of already seen global binders+  -> [Either Term Type] -- ^ The list of arguments+  -> NormalizeSession+       ( [Either Term Type]+       , InScopeSet+       , [(Term, ([Term], CaseTree [(Either Term Type)]))]+       )+collectGlobalsArgs is0 substitution seen args = do+    ((is1,_),(args',collected)) <- second unzip <$> List.mapAccumLM go (is0,seen) args+    return (args',is1,concat collected)+  where+    go (isN0,s) (Left tm) = do+      (tm',isN1,collected) <- collectGlobals isN0 substitution s tm+      return ((isN1,map fst collected ++ s),(Left tm',collected))+    go (isN,s) (Right ty) = return ((isN,s),(Right ty,[]))++-- | Collect 'CaseTree's for (potentially) disjoint applications of globals out+-- of a list of alternatives. Also substitute truly disjoint applications of+-- globals by a reference to a lifted out application.+collectGlobalsAlts ::+     InScopeSet+  -> [(Term,Term)] -- ^ Substitution of (applications of) a global+                   -- binder by a reference to a lifted term.+  -> [Term] -- ^ List of already seen global binders+  -> Term -- ^ The subject term+  -> [Alt] -- ^ The list of alternatives+  -> NormalizeSession+       ( [Alt]+       , InScopeSet+       , [(Term, ([Term], CaseTree [(Either Term Type)]))]+       )+collectGlobalsAlts is0 substitution seen scrut alts = do+    (is1,(alts',collected)) <- second unzip <$> List.mapAccumLM go is0 alts+    let collectedM  = map (Map.fromList . map (second (second (:[])))) collected+        collectedUN = Map.unionsWith (\(l1,r1) (l2,r2) -> (List.nub (l1 ++ l2),r1 ++ r2)) collectedM+        collected'  = map (second (second (Branch scrut))) (Map.toList collectedUN)+    return (alts',is1,collected')+  where+    go isN0 (p,e) = do+      let isN1 = extendInScopeSetList isN0 (snd (patIds p))+      (e',isN2,collected) <- collectGlobals isN1 substitution seen e+      return (isN2,((p,e'),map (second (second (p,))) collected))++-- | Collect 'CaseTree's for (potentially) disjoint applications of globals out+-- of a list of let-bindings. Also substitute truly disjoint applications of+-- globals by a reference to a lifted out application.+collectGlobalsLbs ::+     InScopeSet+  -> [(Term,Term)] -- ^ Substitution of (applications of) a global+                   -- binder by a reference to a lifted term.+  -> [Term] -- ^ List of already seen global binders+  -> [LetBinding] -- ^ The list let-bindings+  -> NormalizeSession+       ( [LetBinding]+       , InScopeSet+       , [(Term, ([Term], CaseTree [(Either Term Type)]))]+       )+collectGlobalsLbs is0 substitution seen lbs = do+    let lbsSCCs = sccLetBindings lbs+    ((is1,_),(lbsSCCs1,collected)) <-+      second unzip <$> List.mapAccumLM go (is0,seen) lbsSCCs+    return (Graph.flattenSCCs lbsSCCs1,is1,concat collected)+  where+    go :: (InScopeSet,[Term]) -> Graph.SCC LetBinding+       -> NormalizeSession+            ( (InScopeSet, [Term])+            , ( Graph.SCC LetBinding+              , [(Term, ([Term], CaseTree [(Either Term Type)]))]+              )+            )+    go (isN0,s) (Graph.AcyclicSCC (id_, e)) = do+      (e',isN1,collected) <- collectGlobals isN0 substitution s e+      return ((isN1,map fst collected ++ s),(Graph.AcyclicSCC (id_,e'),collected))+    -- TODO: This completely skips recursive let-bindings in the collection of+    -- potentially disjoint applications of globals; and skips substituting truly+    -- disjoint applications of globals by a reference to a lifted out application.+    --+    -- This is to prevent the creation of combinational loops that have occurred+    -- "in the wild", but for which we have not been able to a create small+    -- unit test that triggers this creation-of-combinational-loops bug.+    -- Completely skipping recursive let-bindings is taking the hammer to+    -- solving this bug, without knowing whether a scalpel even existed and what+    -- it might look like. We should at some point think hard how traversing+    -- recursive let-bindings can introduce combinational loops, and whether+    -- there exists a solution that can traverse recursive let-bindings,+    -- finding more opportunities for DEC, while not introducing combinational+    -- loops.+    go acc scc@(Graph.CyclicSCC {}) = return (acc,(scc,[]))++-- | Given a case-tree corresponding to a disjoint interesting \"term-in-a-+-- function-position\", return a let-expression: where the let-binding holds+-- a case-expression selecting between the distinct arguments of the case-tree,+-- and the body is an application of the term applied to the shared arguments of+-- the case tree, and variable references to the created let-bindings.+--+-- case-expressions whose type would be non-representable are not let-bound,+-- but occur directly in the argument position of the application in the body+-- of the let-expression.+mkDisjointGroup+  :: InScopeSet+  -- ^ Variables in scope at the very top of the case-tree, i.e., the original+  -- expression+  -> (Term,([Term],CaseTree [Either Term Type]))+  -- ^ Case-tree of arguments belonging to the applied term.+  -> NormalizeSession (Term,[Term])+mkDisjointGroup inScope (fun,(seen,cs)) = do+    tcm <- Lens.view tcCache+    let funName = decFunName fun+        argLen = case Foldable.toList cs of+                   [] -> error "mkDisjointGroup: no disjoint groups"+                   l:_ -> length l+        csT :: [CaseTree (Either Term Type)] -- "Transposed" 'CaseTree [Either Term Type]'+        csT = map (\i -> fmap (!!i) cs) [0..(argLen-1)] -- sequenceA does the wrong thing+    (lbs,newArgs) <- List.mapAccumRM (\lbs (c,pos) -> do+      let cL = Foldable.toList c+      case (cL, areShared tcm inScope (fmap (first stripTicks) cL)) of+        (Right ty:_, True) ->+          return (lbs,Right ty)+        (Right _:_, False) ->+          error ("mkDisjointGroup: non-equal type arguments: " <>+                 showPpr (Either.rights cL))+        (Left tm:_, True) ->+          return (lbs,Left tm)+        (Left tm:_, False) -> do+          let ty = inferCoreTypeOf tcm tm+          let err = error ("mkDisjointGroup: mixed type and term arguments: " <> show cL)+          (lbM,arg) <- disJointSelProj inScope ty (Either.fromLeft err <$> c) funName pos+          case lbM of+            Just lb -> return (lb:lbs, Left arg)+            _ -> return (lbs, Left arg)+        ([], _) ->+          error "mkDisjointGroup: no arguments"+      ) [] (zip csT [0..])+    let funApp = mkApps fun newArgs+    tupTcm <- Lens.view tupleTcCache+    case lbs of+      [] ->+        return (funApp, seen)+      [(v,(ty,ct))] -> do+        let e = genCase tcm tupTcm ty [ty] (fmap (:[]) ct)+        return (Letrec [(v,e)] funApp, seen)+      _ -> do+        let (vs,zs) = unzip lbs+            csL :: [CaseTree Term]+            (tys,csL) = unzip zs+            csLT :: CaseTree [Term]+            csLT = fmap ($ []) (foldr1 (liftA2 (.)) (fmap (fmap (:)) csL))+            bigTupTy = mkBigTupTy tcm tupTcm tys+            ct = genCase tcm tupTcm bigTupTy tys csLT+        tupIn <- mkInternalVar inScope (funName <> "_tupIn") bigTupTy+        projections <-+          Monad.zipWithM (\v n ->+            (v,) <$> mkBigTupSelector inScope tcm tupTcm (Var tupIn) tys n)+            vs [0..]+        return (Letrec ((tupIn,ct):projections) funApp, seen)++-- | Create a selector for the case-tree of the argument. If the argument is+-- representable create a let-binding for the created selector, and return+-- a variable reference to this let-binding. If the argument is not representable+-- return the selector directly.+disJointSelProj+  :: InScopeSet+  -> Type+  -- ^ Types of the argument+  -> CaseTree Term+  -- ^ The case-tree of argument+  -> OccName+  -- ^ Name of the lifted function+  -> Word+  -- ^ Position of the argument+  -> NormalizeSession (Maybe (Id, (Type, CaseTree Term)),Term)+disJointSelProj inScope argTy cs funName argN = do+    tcm <- Lens.view tcCache+    tupTcm <- Lens.view tupleTcCache+    let sel = genCase tcm tupTcm argTy [argTy] (fmap (:[]) cs)+    untran <- isUntranslatableType False argTy+    case untran of+      True -> return (Nothing, sel)+      False -> do+        argId <- mkInternalVar inScope (funName <> "_arg" <> showt argN) argTy+        return (Just (argId,(argTy,cs)), Var argId)++-- | Arguments are shared between invocations if:+--+-- * They contain _no_ references to locally-bound variables+-- * Are either:+--     1. All equal+--     2. A proof of an equality: we don't care about the shape of a proof.+--+--        Whether we have `Refl : True ~ True` or `SomeAxiom : (1 <=? 2) ~ True`+--        it doesn't matter, since when we normalize both sides we always end+--        up with a proof of `True ~ True`.+--        Since DEC only fires for applications where all the type arguments+--        are equal, we can deduce that all equality arguments witness the same+--        equality, hence we don't have to care about the shape of the proof.+areShared :: TyConMap -> InScopeSet -> [Either Term Type] -> Bool+areShared _   _       []       = True+areShared tcm inScope xs@(x:_) = noFV1 && (isProof x || allEqual xs)+ where+  noFV1 = case x of+    Right ty -> getAll (Lens.foldMapOf (typeFreeVars' isLocallyBound mempty)+                                       (const (All False)) ty)+    Left tm  -> getAll (Lens.foldMapOf (termFreeVars' isLocallyBound)+                                       (const (All False)) tm)++  isLocallyBound v = isLocalId v && v `notElemInScopeSet` inScope++  isProof (Left co) = case tyView (inferCoreTypeOf tcm co) of+    TyConApp (nameOcc -> nm) _ ->  nm == fromTHName ''(~)+    _ -> False+  isProof _ = False++-- | Create a case-expression that selects between the distinct arguments given+-- a case-tree+genCase :: TyConMap+        -> IntMap TyConName+        -> Type -- ^ Type of the alternatives+        -> [Type] -- ^ Types of the arguments+        -> CaseTree [Term] -- ^ CaseTree of arguments+        -> Term+genCase tcm tupTcm ty argTys = go+  where+    go (Leaf tms) =+      mkBigTupTm tcm tupTcm (List.zipEqual argTys tms)++    go (LB lb ct) =+      Letrec lb (go ct)++    go (Branch scrut [(p,ct)]) =+      let ct' = go ct+          (ptvs,pids) = patIds p+      in  if (coerce ptvs ++ coerce pids) `localVarsDoNotOccurIn` ct'+             then ct'+             else Case scrut ty [(p,ct')]++    go (Branch scrut pats) =+      Case scrut ty (map (second go) pats)++-- | Lookup the TyConName and DataCon for a tuple of size n+findTup :: TyConMap -> IntMap TyConName -> Int -> (TyConName,DataCon)+findTup tcm tupTcm n =+  Maybe.fromMaybe (error ("Cannot build " <> show n <> "-tuble")) $ do+    tupTcNm <- IntMap.lookup n tupTcm+    tupTc <- UniqMap.lookup tupTcNm tcm+    tupDc <- Maybe.listToMaybe (tyConDataCons tupTc)+    return (tupTcNm,tupDc)++mkBigTupTm :: TyConMap -> IntMap TyConName -> [(Type,Term)] -> Term+mkBigTupTm tcm tupTcm args = snd $ mkBigTup tcm tupTcm args++mkSmallTup,mkBigTup :: TyConMap -> IntMap TyConName -> [(Type,Term)] -> (Type,Term)+mkSmallTup _ _ [] = error $ $curLoc ++ "mkSmallTup: Can't create 0-tuple"+mkSmallTup _ _ [(ty,tm)] = (ty,tm)+mkSmallTup tcm tupTcm args = (ty,tm)+  where+    (argTys,tms) = unzip args+    (tupTcNm,tupDc) = findTup tcm tupTcm (length args)+    tm = mkApps (Data tupDc) (map Right argTys ++ map Left tms)+    ty = mkTyConApp tupTcNm argTys++mkBigTup tcm tupTcm = mkChunkified (mkSmallTup tcm tupTcm)++mkSmallTupTy,mkBigTupTy+  :: TyConMap+  -> IntMap TyConName+  -> [Type]+  -> Type+mkSmallTupTy _ _ [] = error $ $curLoc ++ "mkSmallTupTy: Can't create 0-tuple"+mkSmallTupTy _ _ [ty] = ty+mkSmallTupTy tcm tupTcm tys = mkTyConApp tupTcNm tys+  where+    m = length tys+    (tupTcNm,_) = findTup tcm tupTcm m++mkBigTupTy tcm tupTcm = mkChunkified (mkSmallTupTy tcm tupTcm)++mkSmallTupSelector,mkBigTupSelector+  :: MonadUnique m+  => InScopeSet+  -> TyConMap+  -> IntMap TyConName+  -> Term+  -> [Type]+  -> Int+  -> m Term+mkSmallTupSelector _ _ _ scrut [_] 0 = return scrut+mkSmallTupSelector _ _ _ _     [_] n = error $ $curLoc ++ "mkSmallTupSelector called with one type, but to select " ++ show n+mkSmallTupSelector inScope tcm _ scrut _ n = mkSelectorCase ($curLoc ++ "mkSmallTupSelector") inScope tcm scrut 1 n++mkBigTupSelector inScope tcm tupTcm scrut tys n = go (chunkify tys)+  where+    go [_] = mkSmallTupSelector inScope tcm tupTcm scrut tys n+    go tyss = do+      let (nOuter,nInner) = divMod n mAX_TUPLE_SIZE+          tyss' = map (mkSmallTupTy tcm tupTcm) tyss+      outer <- mkSmallTupSelector inScope tcm tupTcm scrut tyss' nOuter+      inner <- mkSmallTupSelector inScope tcm tupTcm outer (tyss List.!! nOuter) nInner+      return inner+++-- | Determine if a term in a function position is interesting to lift out of+-- of a case-expression.+--+-- This holds for all global functions, and certain primitives. Currently those+-- primitives are:+--+-- * All non-cheap multiplications+-- * All division-like operations with a non-cheap divisor+--+-- Multiplying/dividing by zero or powers of two are considered cheap and+-- isn't lifted out.+interestingToLift+  :: InScopeSet+  -- ^ in scope+  -> (Term -> Term)+  -- ^ Evaluator+  -> Term+  -- ^ Term in function position+  -> [Either Term Type]+  -- ^ Arguments+  -> [TickInfo]+  -- ^ Tick annoations+  -> Maybe Term+interestingToLift inScope _ e@(Var v) _ ticks =+  if NoDeDup `notElem` ticks && (isGlobalId v ||  v `elemInScopeSet` inScope)+     then (Just e)+     else Nothing+interestingToLift inScope eval e@(Prim pInfo) args ticks+  | NoDeDup `notElem` ticks = do+  let anyArgNotConstant = any (not . isConstant) lArgs+  case List.lookup (primName pInfo) interestingPrims of+    Just t | t || anyArgNotConstant -> (Just e)+    _ | DeDup `elem` ticks -> (Just e)+    _ ->+      if isHOTy (coreTypeOf pInfo) then do+        let anyInteresting = List.any (Maybe.isJust . isInteresting) lArgs+        if anyInteresting then Just e else Nothing+      else+        Nothing++  where+    isInteresting = (\(x, y, z) -> interestingToLift inScope eval x y z) . collectArgsTicks+    interestingPrims = map (first fromTHName)+      [('(Clash.Sized.Internal.BitVector.*#),bothNotPow2)+      ,('Clash.Sized.Internal.BitVector.times#,bothNotPow2)+      ,('Clash.Sized.Internal.BitVector.quot#,lastNotPow2)+      ,('Clash.Sized.Internal.BitVector.rem#,lastNotPow2)+      ,('(Clash.Sized.Internal.Index.*#),bothNotPow2)+      ,('Clash.Sized.Internal.Index.times#,bothNotPow2)+      ,('Clash.Sized.Internal.Index.quot#,lastNotPow2)+      ,('Clash.Sized.Internal.Index.rem#,lastNotPow2)+      ,('(Clash.Sized.Internal.Signed.*#),bothNotPow2)+      ,('Clash.Sized.Internal.Signed.times#,bothNotPow2)+      ,('Clash.Sized.Internal.Signed.rem#,lastNotPow2)+      ,('Clash.Sized.Internal.Signed.quot#,lastNotPow2)+      ,('Clash.Sized.Internal.Signed.div#,lastNotPow2)+      ,('Clash.Sized.Internal.Signed.mod#,lastNotPow2)+      ,('(Clash.Sized.Internal.Unsigned.*#),bothNotPow2)+      ,('Clash.Sized.Internal.Unsigned.times#,bothNotPow2)+      ,('Clash.Sized.Internal.Unsigned.quot#,lastNotPow2)+      ,('Clash.Sized.Internal.Unsigned.rem#,lastNotPow2)+      ,('GHC.Base.quotInt,lastNotPow2)+      ,('GHC.Base.remInt,lastNotPow2)+      ,('GHC.Base.divInt,lastNotPow2)+      ,('GHC.Base.modInt,lastNotPow2)+      ,('GHC.Classes.divInt#,lastNotPow2)+      ,('GHC.Classes.modInt#,lastNotPow2)+      ,('GHC.Num.Integer.integerMul,bothNotPow2)+      ,('GHC.Num.Integer.integerDiv,lastNotPow2)+      ,('GHC.Num.Integer.integerMod,lastNotPow2)+      ,('GHC.Num.Integer.integerQuot,lastNotPow2)+      ,('GHC.Num.Integer.integerRem,lastNotPow2)+      ,('(GHC.Prim.*#),bothNotPow2)+      ,('GHC.Prim.quotInt#,lastNotPow2)+      ,('GHC.Prim.remInt#,lastNotPow2)+      ]++    lArgs       = Either.lefts args++    lastNotPow2 = case lArgs of+                    [] -> True+                    _  -> not (termIsPow2 (last lArgs))+    -- | This only looks at the last two arguments, skipping over any constraints if they exist+    bothNotPow2 = go lArgs+     where+      go xs = case xs of+                [] -> True+                [a] -> not (termIsPow2 a)+                [a,b] -> not (termIsPow2 a) && not (termIsPow2 b)+                (_:rest) -> go rest++    termIsPow2 e' = case eval e' of+      Literal (IntegerLiteral n) -> isPow2 n+      a -> case collectArgs a of+        (Prim p,[Right _,Left _,       Left (Literal (IntegerLiteral n))])+          | isFromInt (primName p) -> isPow2 n+        (Prim p,[Right _,Left _,Left _,Left (Literal (IntegerLiteral n))])+          | primName p == fromTHName 'Clash.Sized.Internal.BitVector.fromInteger#  -> isPow2 n+        _ -> False++    -- This used to contain (x /= 0), but multiplying by zero is free+    isPow2 x = (x .&. (complement x + 1)) == x++    isHOTy t = case splitFunForallTy t of+      (args',_) -> any isPolyFunTy (Either.rights args')++interestingToLift _ _ _ _ _ = Nothing++fromTHName :: TH.Name -> Text.Text+fromTHName = Text.pack . show
+ src/Clash/Normalize/Transformations/EtaExpand.hs view
@@ -0,0 +1,107 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017-2018, Google Inc.,+                    2021     , QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  The eta-expansion transformation.+-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Normalize.Transformations.EtaExpand+  ( etaExpandSyn+  , etaExpansionTL+  ) where++import qualified Control.Lens as Lens+import qualified Data.Maybe as Maybe+import GHC.Stack (HasCallStack)++import Clash.Core.HasType+import Clash.Core.Term (Bind(..), CoreContext(..), Term(..), collectArgs, mkLams)+import Clash.Core.TermInfo (isFun)+import Clash.Core.Type (splitFunTy)+import Clash.Core.Util (mkInternalVar)+import Clash.Core.Var (Id)+import Clash.Core.VarEnv (elemVarSet, extendInScopeSet, extendInScopeSetList)+import Clash.Normalize.Types (NormRewrite)+import Clash.Rewrite.Types (TransformContext(..), tcCache, topEntities)+import Clash.Rewrite.Util (changed)+import Clash.Util (curLoc)++-- | Eta-expand functions with a Synthesize annotation, needed to allow such+-- functions to appear as arguments to higher-order primitives.+etaExpandSyn :: HasCallStack => NormRewrite+etaExpandSyn (TransformContext is0 ctx) e@(collectArgs -> (Var f, _)) = do+  topEnts <- Lens.view topEntities+  tcm <- Lens.view tcCache+  let isTopEnt = f `elemVarSet` topEnts+      isAppFunCtx =+        \case+          AppFun:_ -> True+          TickC _:c -> isAppFunCtx c+          _ -> False+      argTyM = fmap fst (splitFunTy tcm (inferCoreTypeOf tcm e))+  case argTyM of+    Just argTy | isTopEnt && not (isAppFunCtx ctx) -> do+      newId <- mkInternalVar is0 "arg" argTy+      changed (Lam newId (App e (Var newId)))+    _ -> return e++etaExpandSyn _ e = return e+{-# SCC etaExpandSyn #-}++stripLambda :: Term -> ([Id], Term)+stripLambda (Lam bndr e) =+  let (bndrs, e') = stripLambda e+   in (bndr : bndrs, e')++stripLambda e = ([], e)++-- | Eta-expand top-level lambda's (DON'T use in a traversal!)+etaExpansionTL :: HasCallStack => NormRewrite+etaExpansionTL (TransformContext is0 ctx) (Lam bndr e) = do+  let ctx' = TransformContext (extendInScopeSet is0 bndr) (LamBody bndr : ctx)+  e' <- etaExpansionTL ctx' e+  return $ Lam bndr e'++etaExpansionTL (TransformContext is0 ctx) (Let (NonRec i x) e) = do+  let ctx' = TransformContext (extendInScopeSet is0 i) (LetBody [(i,x)] : ctx)+  e' <- etaExpansionTL ctx' e+  case stripLambda e' of+    (bs@(_:_),e2) -> do+      let e3 = Let (NonRec i x) e2+      changed (mkLams e3 bs)+    _ -> return (Let (NonRec i x) e')++etaExpansionTL (TransformContext is0 ctx) (Let (Rec xes) e) = do+  let bndrs = map fst xes+      ctx' = TransformContext (extendInScopeSetList is0 bndrs) (LetBody xes : ctx)+  e' <- etaExpansionTL ctx' e+  case stripLambda e' of+    (bs@(_:_),e2) -> do+      let e3 = Let (Rec xes) e2+      changed (mkLams e3 bs)+    _ -> return (Let (Rec xes) e')++etaExpansionTL (TransformContext is0 ctx) e+  = do+    tcm <- Lens.view tcCache+    if isFun tcm e+      then do+        let argTy = ( fst+                    . Maybe.fromMaybe (error $ $(curLoc) ++ "etaExpansion splitFunTy")+                    . splitFunTy tcm+                    . inferCoreTypeOf tcm+                    ) e+        newId <- mkInternalVar is0 "arg" argTy+        let ctx' = TransformContext (extendInScopeSet is0 newId) (LamBody newId : ctx)+        e' <- etaExpansionTL ctx' (App e (Var newId))+        changed (Lam newId e')+      else return e+{-# SCC etaExpansionTL #-}
+ src/Clash/Normalize/Transformations/Inline.hs view
@@ -0,0 +1,712 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017-2022, Google Inc.,+                    2021-2024, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Transformations for inlining+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Normalize.Transformations.Inline+  ( bindConstantVar+  , inlineBndrsCleanup+  , inlineCast+  , inlineCleanup+  , collapseRHSNoops+  , inlineNonRep+  , inlineOrLiftNonRep+  , inlineSimIO+  , inlineSmall+  , inlineWorkFree+  ) where++import qualified Control.Lens as Lens+import qualified Control.Monad as Monad+import Control.Monad ((>=>))+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Writer (lift,listen)+import Data.Default (Default(..))+import Data.Either  (lefts)+import qualified Data.HashMap.Lazy as HashMap+import qualified Data.List as List+import qualified Data.Maybe as Maybe+import qualified Data.Monoid as Monoid (Any(..))+import qualified Data.Text as Text+import qualified Data.Text.Extra as Text+import GHC.Stack (HasCallStack)+import GHC.BasicTypes.Extra (isNoInline)++import qualified Clash.Explicit.SimIO as SimIO+import qualified Clash.Sized.Internal.BitVector as BV (Bit(Bit), BitVector(BV), xToBV)++import Clash.Annotations.Primitive (extractPrim)+import Clash.Core.DataCon (DataCon(..))+import Clash.Core.FreeVars+  (countFreeOccurances, freeLocalIds)+import Clash.Core.HasFreeVars+import Clash.Core.HasType+import Clash.Core.Name (Name(..), NameSort(..))+import Clash.Core.Pretty (PrettyOptions(..), showPpr, showPpr')+import Clash.Core.Subst+import qualified Clash.Core.Term as Term+import Clash.Core.Term+  ( CoreContext(..), Pat(..), PrimInfo(..), Term(..), WorkInfo(..), collectArgs+  , collectArgsTicks, mkApps , mkTicks, stripTicks)+import Clash.Core.TermInfo (isLocalVar, termSize)+import Clash.Core.Type+  (TypeView(..), isClassTy, isPolyFunCoreTy, tyView)+import Clash.Core.Util (isSignalType, primUCo)+import Clash.Core.Var (Id, Var(..), isGlobalId, isLocalId)+import Clash.Core.VarEnv+  ( InScopeSet, VarEnv, VarSet, elemUniqInScopeSet, elemVarEnv, elemVarSet+  , eltsVarEnv, emptyVarEnv, extendInScopeSetList, extendVarEnv+  , foldlWithUniqueVarEnv', lookupVarEnv, lookupVarEnvDirectly, mkVarEnv+  , notElemVarSet, unionVarEnv, unionVarEnvWith, unitVarSet)+import Clash.Debug (trace)+import Clash.Driver.Types (Binding(..))+import Clash.Netlist.Util (representableType)+import Clash.Primitives.Types+  (CompiledPrimMap, Primitive(..), TemplateKind(..))+import Clash.Rewrite.Combinators (allR)+import Clash.Rewrite.Types+  ( TransformContext(..), bindings, curFun, customReprs, tcCache, topEntities+  , typeTranslator, inlineConstantLimit, inlineFunctionLimit, inlineLimit+  , inlineWFCacheLimit, primitives)+import Clash.Rewrite.Util+  ( changed, inlineBinders, inlineOrLiftBinders, isJoinPointIn+  , isUntranslatable, isUntranslatableType, isVoidWrapper, zoomExtra)+import Clash.Rewrite.WorkFree (isWorkFreeIsh)+import Clash.Normalize.Types ( NormRewrite, NormalizeSession)+import Clash.Normalize.Util+  ( addNewInline, alreadyInlined, isRecursiveBndr, mkInlineTick+  , normalizeTopLvlBndr)+import Clash.Unique (Unique)+import Clash.Util (curLoc)+import qualified Clash.Util.Interpolate as I++{- [Note] join points and void wrappers+Join points are functions that only occur in tail-call positions within an+expression, and only when they occur in a tail-call position more than once.+Normally bindNonRep binds/inlines all non-recursive local functions. However,+doing so for join points would significantly increase compilation time, so we+avoid it. The only exception to this rule are so-called void wrappers. Void+wrappers are functions of the form:+> \(w :: Void) -> f a b c+i.e. a wrapper around the function 'f' where the argument 'w' is not used. We+do bind/line these join-points because these void-wrappers interfere with the+'disjoint expression consolidation' (DEC) and 'common sub-expression elimination'+(CSE) transformation, sometimes resulting in circuits that are twice as big+as they'd need to be.+-}++-- | Inline let-bindings when the RHS is either a local variable reference or+-- is constant (except clock or reset generators)+bindConstantVar :: HasCallStack => NormRewrite+bindConstantVar = inlineBinders test+  where+    test _ (i,stripTicks -> e) = case isLocalVar e of+      -- Don't inline `let x = x in x`, it throws  us in an infinite loop+      True -> return (i `notElemFreeVars` e)+      _    -> do+        tcm <- Lens.view tcCache+        (fn,_) <- Lens.use curFun+        -- Don't inline things that perform work, it increases the circuit size.+        --+        -- Also don't inline globally recursive calls, it prevents the+        -- recToLetRec transformation from transforming global recursion to+        -- local recursion.+        -- See https://github.com/clash-lang/clash-compiler/issues/2839+        case isWorkFreeIsh tcm e && not (e == Var fn) of+          True -> Lens.view inlineConstantLimit >>= \case+            0 -> return True+            n -> return (termSize e <= n)+          _ -> return False+{-# SCC bindConstantVar #-}++-- | Mark to track progress of 'reduceBindersCleanup'+data Mark = Temp | Done | Rec++-- | Used (transitively) by 'inlineCleanup' inline to-inline let-binders into+-- the other to-inline let-binders.+reduceBindersCleanup+  :: HasCallStack+  => InScopeSet+  -- ^ Current InScopeSet+  -> VarEnv ((Id,Term),VarEnv Int)+  -- ^ Original let-binders with their free variables (+ #occurrences)+  -> (Maybe Subst,VarEnv Int,VarEnv ((Id,Term),VarEnv Int,Mark))+  -- ^ Accumulated:+  --+  -- 1. (Maybe) the build up substitution so far+  -- 2. The free variables of the range of the substitution+  -- 3. Processed let-binders with their free variables and a tag to mark+  --    the progress:+  --    * Temp: Will eventually form a recursive cycle+  --    * Done: Processed, non-recursive+  --    * Rec:  Processed, recursive+  -> Unique+  -- ^ The unique of the let-binding that we want to simplify+  -> Int+  -- ^ Ignore, artifact of 'foldlWithUniqueVarEnv'+  -> (Maybe Subst,VarEnv Int,VarEnv ((Id,Term),VarEnv Int,Mark))+  -- ^ Same as the third argument+reduceBindersCleanup isN origInl (!substM,!substFVs,!doneInl) u _ =+  case lookupVarEnvDirectly u doneInl of+    Nothing -> case lookupVarEnvDirectly u origInl of+      Nothing ->+        -- let-binding not found, cannot extend the substitution+        if elemUniqInScopeSet u isN then+          (substM,substFVs,doneInl)+        else+          error [I.i|+            Internal error: 'reduceBindersCleanup' encountered a variable+            reference that was neither in 'doneInl', 'origInl', or in the+            transformation's in scope set. Unique was: '#{u}'.+          |]+      Just ((v,e),eFVs) ->+        -- Simplify the transitive dependencies+        let (sM,substFVsE,doneInl1) =+              foldlWithUniqueVarEnv'+                (reduceBindersCleanup isN origInl)+                ( Nothing+                -- It's okay/needed to over-approximate the free variables of+                -- the range of the new substitution by including the free+                -- variables of the original let-binder, because this set of+                -- free variables is only used to check whether let-binding will+                -- become self-recursive after applying the substitution.+                --+                -- That is, it was already self-recursive, or becomes+                -- self-recursive after applying the substitution because it was+                -- part of a recursive group. And we do not want to inline+                -- recursive binders.+                , eFVs+                -- Temporarily extend the processing environment with the+                -- let-binding so we don't end up in a loop in case there is a+                -- recursive group.+                , extendVarEnv v ((v,e),eFVs,Temp) doneInl)+                eFVs++            e1 = maybeSubstTm "reduceBindersCleanup" sM e+        in  if v `elemVarEnv` substFVsE then+              -- We cannot inline recursive let-bindings, so we do not extend+              -- the substitution environment.+              ( substM+              , substFVs+              -- And we explicitly mark the let-binding as recursive in the+              -- processing environment. So that it will be kept around at the+              -- end of 'inlineCleanup'+              , extendVarEnv v ((v,e1),substFVsE,Rec) doneInl1+              )+            else+              -- Extend the substitution+              ( Just (extendIdSubst (Maybe.fromMaybe (mkSubst isN) substM) v e1)+              , unionVarEnv substFVsE substFVs+              -- Mark the let-binding a fully "reduced", so we don't repeat+              -- this process when we encounter it again.+              , extendVarEnv v ((v,e1),substFVsE,Done) doneInl1+              )+    -- It's already been processed, just extend the substitution environment+    Just ((v,e),eFVs,Done) ->+      ( Just (extendIdSubst (Maybe.fromMaybe (mkSubst isN) substM) v e)+      , unionVarEnv eFVs substFVs+      , doneInl+      )++    -- It's either recursive (Rec), or part of a recursive group (Temp) where we+    -- originally entered a different part of the cycle. Regardless, we do not+    -- extend the substitution environment.+    Just _ ->+      ( substM+      , substFVs+      , doneInl+      )+{-# SCC reduceBindersCleanup #-}++-- | Used by 'inlineCleanup' to inline binders that we want to inline into the+-- binders that we want to keep.+inlineBndrsCleanup+  :: HasCallStack+  => InScopeSet+  -- ^ Current InScopeSet+  -> VarEnv ((Id,Term),VarEnv Int)+  -- ^ Original let-binders with their free variables (+ #occurrences), that we+  -- want to inline+  -> VarEnv ((Id,Term),VarEnv Int,Mark)+  -- ^ Processed let-binders with their free variables and a tag to mark the+  -- progress:+  --   * Temp: Will eventually form a recursive cycle+  --   * Done: Processed, non-recursive+  --   * Rec:  Processed, recursive+  -> [((Id,Term),VarEnv Int)]+  -- ^ The let-binders with their free variables (+ #occurrences), that we want+  -- to keep+  -> [(Id,Term)]+inlineBndrsCleanup isN origInl = go+ where+  go doneInl [] =+    -- If some of the let-binders that we wanted to inline turn out to be+    -- recursive, then we have to keep those around as well, as we weren't able+    -- to inline them. Furthermore, for every recursive binder there might still+    -- be non-inlined variables left, see #1337.+    flip map [ (ve, eFvs) | (ve,eFvs,Rec) <- eltsVarEnv doneInl ] $ \((v, e), eFvs) ->+      let+        (substM, _, _) = foldlWithUniqueVarEnv'+                           (reduceBindersCleanup isN emptyVarEnv)+                           (Nothing, emptyVarEnv, doneInl)+                           eFvs+      in (v, maybeSubstTm "inlineBndrsCleanup_0" substM e)+  go !doneInl_0 (((v,e),eFVs):il) =+    let (sM,_,doneInl_1) = foldlWithUniqueVarEnv'+                            (reduceBindersCleanup isN origInl)+                            (Nothing, emptyVarEnv, doneInl_0)+                            eFVs+        e1 = maybeSubstTm "inlineBndrsCleanup_1" sM e+    in  (v,e1):go doneInl_1 il+{-# SCC inlineBndrsCleanup #-}++-- | Only inline casts that just contain a 'Var', because these are guaranteed work-free.+-- These are the result of the 'splitCastWork' transformation.+inlineCast :: HasCallStack => NormRewrite+inlineCast = inlineBinders test+  where+    test _ (_, (Cast (stripTicks -> Var {}) _ _)) = return True+    test _ _ = return False+{-# SCC inlineCast #-}++-- | Given a function in the desired normal form, inline all the following+-- let-bindings:+--+-- Let-bindings with an internal name that is only used once, where it binds:+--   * a primitive that will be translated to an HDL expression (as opposed to+--     a HDL declaration)+--   * a projection case-expression (1 alternative)+--   * a data constructor+--   * I/O actions+inlineCleanup :: HasCallStack => NormRewrite+inlineCleanup (TransformContext is0 _) (Letrec binds body) = do+  prims <- Lens.view primitives+  -- For all let-bindings, count the number of times they are referenced.+  -- We only inline let-bindings which are referenced only once, otherwise+  -- we would lose sharing.+  let is1       = extendInScopeSetList is0 (map fst binds)+      bindsFvs  = map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds+      allOccs   = List.foldl' (unionVarEnvWith (+)) emptyVarEnv+                $ map (snd.snd) bindsFvs+      bodyFVs   = Lens.foldMapOf freeLocalIds unitVarSet body+      (il,keep) = List.partition (isInteresting allOccs prims bodyFVs)+                                 bindsFvs+      keep'     = inlineBndrsCleanup is1 (mkVarEnv il) emptyVarEnv+                $ map snd keep++  if | null il -> return  (Letrec binds body)+     | null keep' -> changed body+     | otherwise -> changed (Letrec keep' body)+  where+    -- Determine whether a let-binding is interesting to inline+    isInteresting+      :: VarEnv Int+      -> CompiledPrimMap+      -> VarSet+      -> (Id,((Id, Term), VarEnv Int))+      -> Bool+    isInteresting allOccs prims bodyFVs (id_,((_,(fst.collectArgs) -> tm),_))+      -- Try to keep user defined names, but inline names generated by GHC or+      -- Clash. For example, if a user were to write:+      --+      --    x = 2 * y+      --+      -- Even if 'x' is only used once, we'd like to keep it around to produce+      -- more readable HDL. In contrast, if a user were to write:+      --+      --    let x = f (2 * y)+      --+      -- ANF would transform that to:+      --+      --    let x = f f_arg; f_arg = 2 * y+      --+      -- In that case, there's no harm in inlining f_arg.+      | nameSort (varName id_) /= User+      , id_ `notElemVarSet` bodyFVs+      = case tm of+          Prim pInfo+            | let nm = primName pInfo+            , Just (extractPrim -> Just p@(BlackBox {})) <- HashMap.lookup nm prims+            , TExpr <- kind p+            , Just occ <- lookupVarEnv id_ allOccs+            , occ < 2+            -> True+            | otherwise+            -> primName pInfo `elem` ["Clash.Explicit.SimIO.bindSimIO#"]+          Case _ _ [_] -> True+          Data _ -> True+          Case _ aTy (_:_:_)+            | TyConApp nm _ <- tyView aTy+            , nameOcc nm == Text.showt ''SimIO.SimIO+            -> True+          _ -> False+      | id_ `notElemVarSet` bodyFVs+      = case tm of+          Prim pInfo+            | primName pInfo `elem`+                        [ Text.showt 'SimIO.openFile+                        , Text.showt 'SimIO.getChar+                        , Text.showt 'SimIO.isEOF+                        ]+            , Just occ <- lookupVarEnv id_ allOccs+            , occ < 2+            -> True+            | otherwise+            -> primName pInfo `elem` ["Clash.Explicit.SimIO.bindSimIO#"]+          Case _ _ [(DataPat dcE _ _,_)]+            -> let nm = (nameOcc (dcName dcE))+               in -- Inlines WW projection that exposes internals of the BitVector types+                  nm == Text.showt 'BV.BV  ||+                  nm == Text.showt 'BV.Bit ||+                  -- Inlines projections out of constraint-tuples (e.g. HiddenClockReset)+                  "GHC.Classes" `Text.isPrefixOf` nm+          Case _ aTy (_:_:_)+            | TyConApp nm _ <- tyView aTy+            , nameOcc nm == Text.showt ''SimIO.SimIO+            -> True+          _ -> False++    isInteresting _ _ _ _ = False++inlineCleanup _ e = return e+{-# SCC inlineCleanup #-}++{- [Note] relation `collapseRHSNoops` and `inlineCleanup`+The `collapseRHSNoops` transformation replaces functions/primitives that are the identity+in HDL, but not in Haskell, by `unsafeCoerce`.+`inlineCleanup` subsequently inlines these `unsafeCoerce` calls.+The end result of all of this is that we get no/fewer assignments in HDL where the RHS is+simply a variable reference. See issue #779 -}++-- | Takes a binding and collapses its term if it is a noop. Only runs at+-- synthesis boundaries (NOINLINE/OPAQUE functions) to avoid running too early+-- on functions that might be inlined later. See #3036.+collapseRHSNoops :: HasCallStack => NormRewrite+collapseRHSNoops _ letrec@(Let letBind body) = do+  (curFunId, _) <- Lens.use curFun+  curBinding <- lookupVarEnv curFunId <$> Lens.use bindings+  case curBinding of+    Just binding | isNoInline (bindingSpec binding) -> do+      -- Explicitly match on Let instead of using LetRec, because we need to+      -- preserve the structure. See https://github.com/clash-lang/clash-compiler/issues/3044.+      case letBind of+        Term.Rec binds -> do+          binds1 <- mapM runCollapseNoop binds+          pure (Let (Term.Rec binds1) body)+        Term.NonRec b0 e0 -> do+          (b1, e1) <- runCollapseNoop (b0, e0)+          pure (Let (Term.NonRec b1 e1) body)+    _ -> pure letrec+  where+    runCollapseNoop orig =+      runMaybeT (collapseNoop orig) >>= Maybe.maybe (return orig) changed++    collapseNoop (iD,term) = do+      (Prim info,args) <- return $ collectArgs term+      identity         <- getIdentity info $ lefts args+      collapsed        <- collapseToIdentity iD identity+      return (iD,collapsed)++    collapseToIdentity iD identity = do+      tcm <- Lens.view tcCache+      let aTy = inferCoreTypeOf tcm identity+          bTy = coreTypeOf iD+      return $ primUCo `TyApp` aTy `TyApp` bTy `App` identity++    getIdentity primInfo termArgs = do+      WorkIdentity idIdx noopIdxs <- return $ primWorkInfo primInfo+      mapM_ (getTermArg termArgs >=> isNoop >=> Monad.guard) noopIdxs+      getTermArg termArgs idIdx++    getTermArg args i = do+      Monad.guard $ i <= length args - 1+      return $ args !! i++    isNoop (Var i) = do+      binding     <- MaybeT $ lookupVarEnv i <$> Lens.use bindings+      isRecursive <- lift $ isRecursiveBndr $ bindingId binding+      Monad.guard $ not isRecursive+      isNoop $ bindingTerm binding+    isNoop (Prim PrimInfo{primWorkInfo=WorkIdentity _ []}) = return True+    isNoop (Lam x e) = isNoopApp x (collectArgs e)+    isNoop _ = return False++    -- Check whether we have a term of the form:+    --+    -- primX a (primY b (primZ c (... x ...))))+    --+    -- Where primX, primY and primZ are either:+    --+    --  1. xToBV, or+    --  2. Primitives that are the identity on their argument+    --+    -- And that the variable 'x' is used by the last primitive in the chain.+    isNoopApp x (Var y,[]) = return (x == y)+    isNoopApp x (Prim PrimInfo{primWorkInfo=WorkIdentity i []},args) = do+      arg <- getTermArg (lefts args) i+      isNoopApp x (collectArgs arg)+    isNoopApp x (Prim PrimInfo{primName},args)+      | primName == Text.showt 'BV.xToBV = do+      -- We don't make 'xToBV' something of 'WorkIdentity 1 []' because we don't+      -- want 'getIdentity' to replace "naked" occurances of 'xToBV' by+      -- 'unsafeCoerce#'. We don't want that since 'xToBV' has a special evaluator+      -- rule that can translate XExceptions to 'undefined# :: BitVector n'.+      arg@(App {}) <- getTermArg (lefts args) 1+      isNoopApp x (collectArgs arg)+    isNoopApp _ _ = return False++collapseRHSNoops _ e = return e+{-# SCC collapseRHSNoops #-}++-- | Inline function with a non-representable result if it's the subject+-- of a Case-decomposition. It's a custom topdown traversal that -for efficiency+-- reasons- does not explore alternative of cases whose subject triggered an+-- 'inlineNonRepWorker'.+inlineNonRep :: HasCallStack => NormRewrite+inlineNonRep ctx0 e0@(Case {}) = do+  r <- listen (inlineNonRepWorker e0)+  case r of+    (e1, Monoid.getAny -> True) ->+      return e1+    (e1, _) -> do+      -- If a term _in_ the subject triggers 'inlineNonRepWorker', inline and+      -- propagate might eliminate this case. We therefore don't explore the+      -- alternatives. Note that this makes it substantially different from a+      -- 'topdownSucR' transformation.+      let+        (subj0,typ,alts) = case e1 of+          Case s t a -> (s,t,a)+          _ -> error ("internal error, inlineNonRep triggered on a non-Case:" <>+                      showPpr e1)+        TransformContext inScope ctx1 = ctx0+        ctx2 = TransformContext inScope (CaseScrut:ctx1)++      listen (inlineNonRep ctx2 subj0) >>= \case+        (subj1, Monoid.getAny -> True) ->+          return (Case subj1 typ alts)+        (subj1, _) -> do+          let (pats, rhss0) = unzip alts+          rhss1 <- mapM (inlineNonRep ctx2) rhss0+          pure (Case subj1 typ (zip pats rhss1))++inlineNonRep ctx e =+  -- All non-case statements are simply traversed. TODO: are there other special+  -- cases like 'Case' that would warrant an optimization like ^ ?+  allR inlineNonRep ctx e+{-# SCC inlineNonRep #-}++-- | Inline function with a non-representable result if it's the subject+-- of a Case-decomposition. This worker function only tries the given term+-- (i.e., it does not traverse it).+--+-- It sets the changed flag in the NormalizeSession if it successfully inlines+-- a binder.+inlineNonRepWorker :: HasCallStack => Term -> NormalizeSession Term+inlineNonRepWorker e@(Case scrut altsTy alts)+  | (Var f, args,ticks) <- collectArgsTicks scrut+  , isGlobalId f+  = do+    (cf,_)    <- Lens.use curFun+    isInlined <- zoomExtra (alreadyInlined f cf)+    limit     <- Lens.view inlineLimit+    tcm       <- Lens.view tcCache+    let+      scrutTy = inferCoreTypeOf tcm scrut++      -- Constraint dictionary inlining always terminates, so we ignore the+      -- usual inline safeguards.+      notClassTy = not (isClassTy tcm scrutTy)+      overLimit = notClassTy && (Maybe.fromMaybe 0 isInlined) > limit+++    bodyMaybe   <- lookupVarEnv f <$> Lens.use bindings+    nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator+                                              <*> Lens.view customReprs+                                              <*> pure False+                                              <*> Lens.view tcCache+                                              <*> pure scrutTy)+    case (nonRepScrut, bodyMaybe) of+      (True, Just b) -> do+        if overLimit then+          trace ($(curLoc) ++ [I.i|+            InlineNonRep: #{showPpr (varName f)} already inlined+            #{limit} times in: #{showPpr (varName cf)}. The type of the subject+            is:++              #{showPpr' def{displayTypes=True\} scrutTy}++            Function #{showPpr (varName cf)} will not reach a normal form and+            compilation might fail.++            Run with '-fclash-inline-limit=N' to increase the inline limit to N.+          |]) (return e)+        else do+          Monad.when notClassTy (zoomExtra (addNewInline f cf))++          let scrutBody0 = mkTicks (bindingTerm b) (mkInlineTick f : ticks)+          let scrutBody1 = mkApps scrutBody0 args++          changed $ Case scrutBody1 altsTy alts+      _ ->+        return e++inlineNonRepWorker e = pure e+{-# SCC inlineNonRepWorker #-}++inlineOrLiftNonRep :: HasCallStack => NormRewrite+inlineOrLiftNonRep ctx eLet@(Letrec _ body) =+    inlineOrLiftBinders nonRepTest inlineTest ctx eLet+  where+    bodyFreeOccs = countFreeOccurances body++    nonRepTest :: (Id, Term) -> NormalizeSession Bool+    nonRepTest (Id {varType = ty}, _)+      = not <$> (representableType <$> Lens.view typeTranslator+                                   <*> Lens.view customReprs+                                   <*> pure False+                                   <*> Lens.view tcCache+                                   <*> pure ty)+    nonRepTest _ = return False++    inlineTest :: Term -> (Id, Term) -> Bool+    inlineTest e (id_, e') =+      -- We do __NOT__ inline:+      not $ or+        [ -- 1. recursive let-binders+          -- id_ `elemFreeVars` e' -- <= already checked in inlineOrLiftBinders+          -- 2. join points (which are not void-wrappers)+          isJoinPointIn id_ e && not (isVoidWrapper e')+          -- 3. binders that are used more than once in the body, because+          --    it makes CSE a whole lot more difficult.+          --+          -- XXX: Check whether we can extend this to the binders as well+        , maybe False (>1) (lookupVarEnv id_ bodyFreeOccs)+        ]++inlineOrLiftNonRep _ e = return e+{-# SCC inlineOrLiftNonRep #-}++-- | Inline anything of type `SimIO`: IO actions cannot be shared+inlineSimIO :: HasCallStack => NormRewrite+inlineSimIO = inlineBinders test+  where+    test _ (i,_) = case tyView (coreTypeOf i) of+      TyConApp tc _ -> return $! nameOcc tc == Text.showt ''SimIO.SimIO+      _ -> return False+{-# SCC inlineSimIO #-}++-- | Inline small functions+inlineSmall :: HasCallStack => NormRewrite+inlineSmall _ e@(collectArgsTicks -> (Var f,args,ticks)) = do+  untranslatable <- isUntranslatable True e+  topEnts <- Lens.view topEntities+  let lv = isLocalId f+  if untranslatable || f `elemVarSet` topEnts || lv+    then return e+    else do+      bndrs <- Lens.use bindings+      sizeLimit <- Lens.view inlineFunctionLimit+      case lookupVarEnv f bndrs of+        -- Don't inline recursive expressions+        Just b -> do+          isRecBndr <- isRecursiveBndr f+          if not isRecBndr && not (isNoInline (bindingSpec b)) && termSize (bindingTerm b) < sizeLimit+             then do+               let tm = mkTicks (bindingTerm b) (mkInlineTick f : ticks)+               changed $ mkApps tm args+             else return e++        _ -> return e++inlineSmall _ e = return e+{-# SCC inlineSmall #-}++-- | Inline work-free functions, i.e. fully applied functions that evaluate to+-- a constant+inlineWorkFree :: HasCallStack => NormRewrite+inlineWorkFree _ e@(collectArgsTicks -> (Var f,args@(_:_),ticks))+  = do+    tcm <- Lens.view tcCache+    let eTy = inferCoreTypeOf tcm e+    argsHaveWork <- or <$> mapM (either expressionHasWork+                                        (const (pure False)))+                                args+    untranslatable <- isUntranslatableType True eTy+    topEnts <- Lens.view topEntities+    let isSignal = isSignalType tcm eTy+    let lv = isLocalId f+    let isTopEnt = elemVarSet f topEnts+    if untranslatable || isSignal || argsHaveWork || lv || isTopEnt+      then return e+      else do+        bndrs <- Lens.use bindings+        case lookupVarEnv f bndrs of+          -- Don't inline recursive expressions+          Just b -> do+            isRecBndr <- isRecursiveBndr f+            if isRecBndr+               then return e+               else do+                 let tm = mkTicks (bindingTerm b) (mkInlineTick f : ticks)+                 changed $ mkApps tm args++          _ -> return e+  where+    -- an expression is has work when it contains free local variables,+    -- or has a Signal type, i.e. it does not evaluate to a work-free+    -- constant.+    expressionHasWork e' = do+      let fvIds = Lens.toListOf freeLocalIds e'+      tcm   <- Lens.view tcCache+      let e'Ty     = inferCoreTypeOf tcm e'+          isSignal = isSignalType tcm e'Ty+      return (not (null fvIds) || isSignal)++inlineWorkFree _ e@(Var f) = do+  tcm <- Lens.view tcCache+  let fTy      = coreTypeOf f+      closed   = not (isPolyFunCoreTy tcm fTy)+      isSignal = isSignalType tcm fTy+  untranslatable <- isUntranslatableType True fTy+  topEnts <- Lens.view topEntities+  let gv = isGlobalId f+  if closed && f `notElemVarSet` topEnts && not untranslatable && not isSignal && gv+    then do+      bndrs <- Lens.use bindings+      case lookupVarEnv f bndrs of+        -- Don't inline recursive expressions+        Just top -> do+          isRecBndr <- isRecursiveBndr f+          if isRecBndr+             then return e+             else do+              let topB = bindingTerm top+              sizeLimit <- Lens.view inlineWFCacheLimit+              -- caching only worth it from a certain size onwards, otherwise+              -- the caching mechanism itself brings more of an overhead.+              if termSize topB < sizeLimit then+                changed topB+              else do+                b <- normalizeTopLvlBndr False f top+                changed (bindingTerm b)+        _ -> return e+    else return e++inlineWorkFree _ e = return e+{-# SCC inlineWorkFree #-}
+ src/Clash/Normalize/Transformations/Letrec.hs view
@@ -0,0 +1,463 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017-2018, Google Inc.,+                    2021-2022, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Transformations on letrec expressions.+-}++{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++module Clash.Normalize.Transformations.Letrec+  ( deadCode+  , flattenLet+  , recToLetRec+  , removeUnusedExpr+  , simpleCSE+  , topLet+  ) where++import qualified Control.Lens as Lens+import qualified Control.Monad as Monad+import Control.Monad.Trans.Except (runExcept)+import Control.Monad.Writer (listen)+import Data.Bifunctor (second)+import qualified Data.Either as Either+import qualified Data.HashMap.Lazy as HashMap+import Data.List ((\\))+import qualified Data.List as List+import qualified Data.List.Extra as List+import Data.Maybe (fromMaybe)+import qualified Data.Monoid as Monoid (Any(..))+import qualified Data.Text as Text+import qualified Data.Text.Extra as Text+import GHC.Stack (HasCallStack)++import Clash.Annotations.BitRepresentation.Deriving (dontApplyInHDL)+import Clash.Sized.Vector as Vec (Vec(Cons), splitAt)++import Clash.Annotations.Primitive (extractPrim)+import Clash.Core.DataCon (DataCon(..))+import Clash.Core.FreeVars (freeLocalIds)+import Clash.Core.HasFreeVars+import Clash.Core.HasType+import Clash.Core.Name (mkUnsafeSystemName, nameOcc)+import Clash.Core.Subst+import Clash.Core.Term+  ( LetBinding, Pat(..), PrimInfo(..), Term(..), collectArgs, collectArgsTicks+  , collectTicks, isLambdaBodyCtx, isTickCtx, mkApps, mkLams, mkTicks, Bind(..)+  , partitionTicks, stripAllTicks)+import Clash.Core.TermInfo (isCon, isLet, isLocalVar, isTick)+import Clash.Core.TyCon (tyConDataCons)+import Clash.Core.Type+  (Type(..), TypeView(..), normalizeType+  , splitFunForallTy, tyView)+import Clash.Core.Util (inverseTopSortLetBindings, mkVec, tyNatSize)+import Clash.Core.Var (isGlobalId)+import Clash.Core.VarEnv+  ( InScopeSet, elemInScopeSet, emptyVarEnv, extendInScopeSetList, lookupVarEnv+  , unionVarEnvWith, unitVarEnv, mkVarSet)+import qualified Clash.Data.UniqMap as UniqMap+import Clash.Netlist.BlackBox.Types ()+import Clash.Netlist.BlackBox.Util (getUsedArguments)+import Clash.Netlist.Util (splitNormalized)+import Clash.Normalize.Primitives (removedArg)+import Clash.Normalize.Transformations.Reduce (reduceBinders)+import Clash.Normalize.Types (NormRewrite, NormalizeSession)+import Clash.Primitives.Types (Primitive(..), UsedArguments(..))+import Clash.Rewrite.Types+  (TransformContext(..), bindings, curFun, tcCache, workFreeBinders, primitives)+import Clash.Rewrite.Util+  (changed, isFromInt, isUntranslatable, mkTmBinderFor, removeUnusedBinders, setChanged)+import Clash.Rewrite.WorkFree++{- [Note: Name re-creation]+The names of heap bound variables are safely generate with mkUniqSystemId in+Clash.Core.Evaluator.newLetBinding. But only their uniqs end up in the heap,+not the complete names. So we use mkUnsafeSystemName to recreate the same Name.+-}++-- | Remove unused let-bindings+deadCode :: HasCallStack => NormRewrite+deadCode _ e@(Let binds body) =+  case removeUnusedBinders binds body of+    Just t -> changed t+    Nothing -> return e+deadCode _ e = return e+{-# SCC deadCode #-}++removeUnusedExpr :: HasCallStack => NormRewrite+removeUnusedExpr _ e@(collectArgsTicks -> (p@(Prim pInfo),args,ticks)) = do+  bbM <- HashMap.lookup (primName pInfo) <$> Lens.view primitives+  let+    usedArgs0 =+      case Monad.join (extractPrim <$> bbM) of+        Just (BlackBoxHaskell{usedArguments}) ->+          case usedArguments of+            UsedArguments used -> Just used+            IgnoredArguments ignored -> Just ([0..length args - 1] \\ ignored)+        Just (BlackBox pNm _ _ _ _ _ _ _ _ _ inc r ri templ) -> Just $+          if | isFromInt pNm -> [0,1,2]+             | primName pInfo `elem` [ Text.showt 'dontApplyInHDL+                                     , Text.showt 'Vec.splitAt+                                     ] -> [0,1]+             | otherwise -> concat [ concatMap getUsedArguments r+                                   , concatMap getUsedArguments ri+                                   , getUsedArguments templ+                                   , concatMap (getUsedArguments . snd) inc ]+        _ ->+          Nothing++  case usedArgs0 of+    Nothing ->+      return e+    Just usedArgs1 -> do+      tcm <- Lens.view tcCache+      (args1, Monoid.getAny -> hasChanged) <- listen (go tcm 0 usedArgs1 args)+      if hasChanged then+        return (mkApps (mkTicks p ticks) args1)+      else+        return e++  where+    arity = length . Either.rights . fst $ splitFunForallTy (coreTypeOf pInfo)++    go _ _ _ [] = return []+    go tcm !n used (Right ty:args') = do+      args'' <- go tcm n used args'+      return (Right ty : args'')+    go tcm !n used (Left tm : args') = do+      args'' <- go tcm (n+1) used args'+      case tm of+        TyApp (Prim p0) _+          | primName p0 == Text.showt 'removedArg+          -> return (Left tm : args'')+        _ -> do+          let ty = inferCoreTypeOf tcm tm+              p' = TyApp (Prim removedArg) ty+          if n < arity && n `notElem` used+             then changed (Left p' : args'')+             else return  (Left tm : args'')++removeUnusedExpr _ e@(Case _ _ [(DataPat _ [] xs,altExpr)]) =+  if mkVarSet xs `disjointFreeVars` altExpr+     then changed altExpr+     else return e++-- Replace any expression that creates a Vector of size 0 within the application+-- of the Cons constructor, by the Nil constructor.+removeUnusedExpr _ e@(collectArgsTicks -> (Data dc, [_,Right aTy,Right nTy,_,Left a,Left nil],ticks))+  | nameOcc (dcName dc) == Text.showt 'Vec.Cons+  = do+    tcm <- Lens.view tcCache+    case runExcept (tyNatSize tcm nTy) of+      Right 0+        | (con, _) <- collectArgs nil+        , not (isCon con)+        -> let eTy = inferCoreTypeOf tcm e+               v = fromMaybe (error "removeUnusedExpr: failed to create Vec DCs") $ do+                  (TyConApp vecTcNm _) <- pure (tyView eTy)+                  vecTc <- UniqMap.lookup vecTcNm tcm+                  [nilCon,consCon] <- pure (tyConDataCons vecTc)+                  return (mkTicks (mkVec nilCon consCon aTy 1 [a]) ticks)+           in  changed v+      _ -> return e++removeUnusedExpr _ e = return e+{-# SCC removeUnusedExpr #-}++-- | Flatten's letrecs after `inlineCleanup`+--+-- `inlineCleanup` sometimes exposes additional possibilities for `caseCon`,+-- which then introduces let-bindings in what should be ANF. This transformation+-- flattens those nested let-bindings again.+--+-- NB: must only be called in the cleaning up phase.+flattenLet :: HasCallStack => NormRewrite+flattenLet ctx@(TransformContext is0 _) (Letrec binds0 body0@Letrec{}) = do+  -- deshadow binds1, so binds0 and binds1 don't conflict when merged+  let is1 = extendInScopeSetList is0 (fmap fst binds0)+  case deShadowTerm is1 body0 of+    Letrec binds1 body1 -> do+      setChanged+      flattenLet ctx{tfInScope=is1} (Letrec (binds0 <> binds1) body1)+    _ -> error "internal error"++flattenLet (TransformContext is0 _) (Letrec binds body) = do+  let is1 = extendInScopeSetList is0 (map fst binds)+      bodyOccs = Lens.foldMapByOf+                   freeLocalIds (unionVarEnvWith (+))+                   emptyVarEnv (`unitVarEnv` (1 :: Int))+                   body+  (is2,binds1) <- second concat <$> List.mapAccumLM go is1 binds+  bndrs <- Lens.use bindings+  e1WorkFree <-+    case binds1 of+      [(_,e1)] -> isWorkFree workFreeBinders bndrs e1+      _ -> pure (error "flattenLet: unreachable")+  case binds1 of+    -- inline binders into the body when there's only a single binder, and only+    -- if that binder doesn't perform any work or is only used once in the body+    [(id1,e1)] | Just occ <- lookupVarEnv id1 bodyOccs, e1WorkFree || occ < 2 ->+      if id1 `elemFreeVars` e1+         -- Except when the binder is recursive!+         then return (Letrec binds1 body)+         else let subst = extendIdSubst (mkSubst is2) id1 e1+              in changed (substTm "flattenLet" subst body)+    _ -> return (Letrec binds1 body)+  where+    go :: InScopeSet -> LetBinding -> NormalizeSession (InScopeSet,[LetBinding])+    go isN (id1,collectTicks -> (Letrec binds1 body1,ticks)) = do+      let bs1 = map fst binds1+      let (binds2,body2,isN1) =+            -- We need to deshadow because we're merging nested let-expressions+            -- into a single let-expression: and within a let-expression, the+            -- bindings are not allowed to shadow each-other. Of course, we+            -- only need to deshadow if any shadowing is happening in the+            -- first place.+            --+            -- This is much better than blindly calling freshenTm, and saves+            -- almost 30% run-time of the normalization phase on some examples.+            if any (`elemInScopeSet` isN) bs1 then+              case deShadowTerm isN (Letrec binds1 body1) of+                Letrec bindsN bodyN ->+                  (bindsN,bodyN,extendInScopeSetList isN (map fst bindsN))+                _ -> error "internal error"+            else+              (binds1,body1,extendInScopeSetList isN bs1)+      let bodyOccs = Lens.foldMapByOf+                       freeLocalIds (unionVarEnvWith (+))+                       emptyVarEnv (`unitVarEnv` (1 :: Int))+                       body2+          (srcTicks,nmTicks) = partitionTicks ticks+      bndrs <- Lens.use bindings+      e2WorkFree <-+        case binds2 of+          [(_,e2)] -> isWorkFree workFreeBinders bndrs e2+          _ -> pure (error "flattenLet: unreachable")+      -- Distribute the name ticks of the let-expression over all the bindings+      (isN1,) . map (second (`mkTicks` nmTicks)) <$> case binds2 of+        -- inline binders into the body when there's only a single binder, and+        -- only if that binder doesn't perform any work or is only used once in+        -- the body+        [(id2,e2)] | Just occ <- lookupVarEnv id2 bodyOccs, e2WorkFree || occ < 2 ->+          if id2 `elemFreeVars` e2+             -- Except when the binder is recursive!+             then changed ([(id2,e2),(id1, body2)])+             else let subst = extendIdSubst (mkSubst isN1) id2 e2+                  in  changed [(id1+                               -- Only apply srcTicks to the body+                               ,mkTicks (substTm "flattenLetGo" subst body2)+                                        srcTicks)]+        bs -> changed (bs ++ [(id1+                               -- Only apply srcTicks to the body+                              ,mkTicks body2 srcTicks)])+    go isN b = return (isN,[b])++flattenLet _ e = return e+{-# SCC flattenLet #-}++-- | Turn a  normalized recursive function, where the recursive calls only pass+-- along the unchanged original arguments, into let-recursive function. This+-- means that all recursive calls are replaced by the same variable reference as+-- found in the body of the top-level let-expression.+recToLetRec :: HasCallStack => NormRewrite+recToLetRec (TransformContext is0 []) e = do+  (fn,_) <- Lens.use curFun+  tcm    <- Lens.view tcCache+  case splitNormalized tcm e of+    Right (args,bndrs,res) -> do+      let args'             = map Var args+          (toInline,others) = List.partition (eqApp tcm fn args' . snd) bndrs+          resV              = Var res+      case (toInline,others) of+        (_:_,_:_) -> do+          let is1          = extendInScopeSetList is0 (args ++ map fst bndrs)+          let substsInline = extendIdSubstList (mkSubst is1)+                           $ map (second (const resV)) toInline+              others'      = map (second (substTm "recToLetRec" substsInline))+                                 others+          changed $ mkLams (Letrec others' resV) args+        _ -> return e+    _ -> return e+  where+    -- This checks whether things are semantically equal. For example, say we+    -- have:+    --+    --   x :: (a, (b, c))+    --+    -- and+    --+    --   y :: (a, (b, c))+    --+    -- If we can determine that 'y' is constructed solely using the+    -- corresponding fields in 'x', then we can say they are semantically+    -- equal. The algorithm below keeps track of what (sub)field it is+    -- constructing, and checks if the field-expression projects the+    -- corresponding (sub)field from the target variable.+    --+    -- TODO: See [Note: Breaks on constants and predetermined equality]+    --+    -- Since 'aeqTerm' now looks at ticks when determining equality, it is+    -- required that all ticks are removed with 'stripAllTicks' to keep the+    -- previous behaviour of this function. If we remove this, most terms will+    -- not be identified as equal.+    eqApp tcm v args (collectArgs . stripAllTicks -> (Var v',args'))+      | isGlobalId v'+      , v == v'+      , let args2 = Either.lefts args'+      , length args == length args2+      = and (zipWith (eqArg tcm) args args2)+    eqApp _ _ _ _ = False++    eqArg _ v1 v2@Var{}+      = v1 == v2+    eqArg tcm v1 v2@(collectArgs -> (Data _, args'))+      | let t1 = normalizeType tcm (inferCoreTypeOf tcm v1)+      , let t2 = normalizeType tcm (inferCoreTypeOf tcm v2)+      , t1 == t2+      = if isClassConstraint t1 then+          -- Class constraints are equal if their types are equal, so we can+          -- take a shortcut here.+          True+        else+          -- Check whether all arguments to the data constructor are projections+          --+          and (zipWith (eqDat v1) (map pure [0..]) (Either.lefts args'))+    eqArg _ _ _+      = False++    -- Recursively check whether a term /e/ is semantically equal to some variable /v/.+    -- Currently it can only assert equality when /e/ is  syntactically equal+    -- to /v/, or is constructed out of projections of /v/, importantly:+    --+    -- [Note: Breaks on constants and predetermined equality]+    -- This function currently breaks if:+    --+    --   * One or more subfields are constants. Constants might have been+    --     inlined for the construction, instead of being a projection of the+    --     target variable.+    --+    --   * One or more subfields are determined to be equal and one is simply+    --     swapped / replaced by the other. For example, say we have+    --     `x :: (a, a)`. If GHC determines that both elements of the tuple will+    --     always be the same, it might replace the (semantically equal to 'x')+    --     construction of `y` with `(fst x, fst x)`.+    --+    eqDat :: Term -> [Int] -> Term -> Bool+    eqDat v fTrace (collectArgs -> (Data _, args)) =+      and (zipWith (eqDat v) (map (:fTrace) [0..]) (Either.lefts args))+    eqDat v1 fTrace v2 =+      case stripProjection (reverse fTrace) v1 v2 of+        Just [] -> True+        _ -> False++    stripProjection :: [Int] -> Term -> Term -> Maybe [Int]+    stripProjection fTrace0 vTarget0 (Case v _ [(DataPat _ _ xs, r)]) = do+      -- Get projection made in subject of case:+      fTrace1 <- stripProjection fTrace0 vTarget0 v++      -- Extract projection of this case statement. Subsequent calls to+      -- 'stripProjection' will check if new target is actually used.+      (n, fTrace2) <- List.uncons fTrace1+      vTarget1 <- List.indexMaybe xs n++      stripProjection fTrace2 (Var vTarget1) r++    stripProjection fTrace (Var sTarget) (Var s) =+      if sTarget == s then Just fTrace else Nothing++    stripProjection _fTrace _vTarget _v =+      Nothing++recToLetRec _ e = return e+{-# SCC recToLetRec #-}++isClassConstraint :: Type -> Bool+isClassConstraint (tyView -> TyConApp nm0 _) =+  if -- Constraint tuple:+     | "GHC.Classes.(%" `Text.isInfixOf` nm1 -> True+     -- Constraint class:+     | "C:" `Text.isInfixOf` nm2 -> True+     | otherwise -> False+ where+  nm1 = nameOcc nm0+  nm2 = snd (Text.breakOnEnd "." nm1)++isClassConstraint _ = False++-- | Simplified CSE, only works on let-bindings, does an inverse topological+-- sort of the let-bindings and then works from top to bottom+--+-- XXX: Check whether inverse top-sort followed by single traversal removes as+-- many binders as the previous "apply-until-fixpoint" approach in the presence+-- of recursive groups in the let-bindings. If not but just for checking whether+-- changes to transformation affect the eventual size of the circuit, it would+-- be really helpful if we tracked circuit size in the regression/test suite.+-- On the two examples that were tested, Reducer and PipelinesViaFolds, this new+-- version of CSE removed the same amount of let-binders.+simpleCSE :: HasCallStack => NormRewrite+simpleCSE (TransformContext is0 _) term@(Letrec bndrsX body) = do+  let bndrs = inverseTopSortLetBindings bndrsX+  let is1 = extendInScopeSetList is0 (map fst bndrs)+  ((subst,bndrs1), change) <- listen $ reduceBinders (mkSubst is1) [] bndrs+  -- TODO: check whether a substitution over the body is enough, the reason I'm+  -- doing a substitution over the the binders as well is that I don't know in+  -- what order a recursive group shows up in a inverse topological sort.+  -- Depending on the order and forgetting to apply the substitution over the+  -- let-bindings might lead to the introduction of free variables.+  --+  -- NB: don't apply the substitution to the entire let-expression, and that+  -- would rename the let-bindings because they've been added to the InScopeSet+  -- of the substitution.+  if Monoid.getAny change+     then+       let bndrs2 = map (second (substTm "simpleCSE.bndrs" subst)) bndrs1+           body1 = substTm "simpleCSE.body" subst body+        in changed (Letrec bndrs2 body1)+     else+       return term++simpleCSE _ e = return e+{-# SCC simpleCSE #-}++-- | Ensure that top-level lambda's eventually bind a let-expression of which+-- the body is a variable-reference.+topLet :: HasCallStack => NormRewrite+topLet (TransformContext is0 ctx) e+  | all (\c -> isLambdaBodyCtx c || isTickCtx c) ctx && not (isLet e) && not (isTick e)+  = do+  untranslatable <- isUntranslatable False e+  if untranslatable+    then return e+    else do tcm <- Lens.view tcCache+            argId <- mkTmBinderFor is0 tcm (mkUnsafeSystemName "result" 0) e+            changed (Let (NonRec argId e) (Var argId))++topLet (TransformContext is0 ctx) e@(Letrec binds body)+  | all (\c -> isLambdaBodyCtx c || isTickCtx c) ctx+  = do+    let localVar = isLocalVar body+    untranslatable <- isUntranslatable False body+    if localVar || untranslatable+      then return e+      else do+        tcm <- Lens.view tcCache+        let is2 = extendInScopeSetList is0 (fmap fst binds)+        argId <- mkTmBinderFor is2 tcm (mkUnsafeSystemName "result" 0) body++        -- TODO We would like this to be+        --+        -- Let binds (Let (NonRec argId body) (Var argId))+        --+        -- but this makes tests/shouldwork/SimIO/Test00.hs fail.+        changed (Letrec (binds ++ [(argId, body)]) (Var argId))++topLet _ e = return e+{-# SCC topLet #-}
+ src/Clash/Normalize/Transformations/MultiPrim.hs view
@@ -0,0 +1,131 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017-2018, Google Inc.+                    2022     , QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Transformations on primitives with multiple results.+-}++{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Normalize.Transformations.MultiPrim+  ( setupMultiResultPrim+  ) where++import qualified Control.Lens as Lens+import qualified Data.Either as Either+import Data.Text.Extra (showt)+import GHC.Stack (HasCallStack)++import Clash.Annotations.Primitive (extractPrim)+import Clash.Core.Name (mkUnsafeInternalName)+import Clash.Core.Term+  ( IsMultiPrim(..), MultiPrimInfo(..), PrimInfo(..), Term(..), WorkInfo(..)+  , mkAbstraction, mkApps, mkTmApps, mkTyApps, PrimUnfolding(..))+import Clash.Core.TermInfo (multiPrimInfo')+import Clash.Core.TyCon (TyConMap)+import Clash.Core.Type (Type(..), mkPolyFunTy, splitFunForallTy)+import Clash.Core.Util (listToLets)+import Clash.Core.Var (mkLocalId)+import Clash.Normalize.Types (NormRewrite)+import Clash.Primitives.Types (Primitive(..))+import Clash.Rewrite.Types (tcCache, primitives)+import Clash.Rewrite.Util (changed)++-- Note [MultiResult type]+--+-- A multi result primitive assigns its results to multiple result variables+-- instead of one. Besides producing nicer HDL it works around issues with+-- synthesis tooling described in:+--+--   https://github.com/clash-lang/clash-compiler/issues/1555+--+-- This transformation rewrites primitives indicating they can assign their+-- results to multiple signals, such that netlist can easily render it. This+-- involves inserting additional arguments for each of the result values, and+-- then using the c$multiPrimSelect primitive to select individual results.+--+-- Example:+--+-- @+-- prim :: forall a b c. a -> (b, c)+-- @+--+-- will be rewritten to:+--+-- @+--   \\(x :: a) ->+--         let+--            r  = prim @a @b @c x r0 r1 -- With 'Clash.Core.Term.MultiPrim'+--            r0 = c$multiPrimSelect r0 r+--            r1 = c$multiPrimSelect r1 r+--          in+--            (r0, r1)+-- @+--+-- Netlist will not render any @multiPrimSelect@ primitives. Similar to+-- primitives having a /void/ return type, /r/ is not rendered either.+--+-- This transformation is currently hardcoded to recognize tuples as return+-- types, not any product type. It will error if it sees a multi result primitive+-- with a non-tuple return type.+--+setupMultiResultPrim :: HasCallStack => NormRewrite+setupMultiResultPrim _ctx e@(Prim pInfo@PrimInfo{primMultiResult=SingleResult}) = do+  tcm <- Lens.view tcCache+  prim <- Lens.view (primitives . Lens.at (primName pInfo))++  case prim >>= extractPrim of+    Just (BlackBoxHaskell{multiResult=True}) ->+      changed (setupMultiResultPrim' tcm pInfo)+    Just (BlackBox{multiResult=True}) ->+      changed (setupMultiResultPrim' tcm pInfo)+    _ ->+      return e++setupMultiResultPrim _ e = return e++setupMultiResultPrim' :: HasCallStack => TyConMap -> PrimInfo -> Term+setupMultiResultPrim' tcm primInfo@PrimInfo{primType} =+  mkAbstraction letTerm (map Right typeVars <> map Left argIds)+ where+  typeVars = Either.lefts pArgs++  internalNm prefix n = mkUnsafeInternalName (prefix <> showt n) n+  internalId prefix typ n = mkLocalId typ (internalNm prefix n)++  nTermArgs = fromIntegral (length (Either.rights pArgs))+  nResTypes = fromIntegral (length resTypes)+  argIds = zipWith (internalId "a") (Either.rights pArgs) [1..nTermArgs]+  resIds = zipWith (internalId "r") resTypes [nTermArgs+1..nTermArgs+nResTypes]+  resId = mkLocalId pResTy (mkUnsafeInternalName "r" (nTermArgs+nResTypes+1))++  (pArgs, pResTy) = splitFunForallTy primType+  MultiPrimInfo{mpi_resultDc=tupTc, mpi_resultTypes=resTypes} =+    multiPrimInfo' tcm primInfo++  multiPrimSelect r t = (r, mkTmApps (Prim (multiPrimSelectInfo t)) [Var r, Var resId])+  multiPrimSelectBinds = zipWith multiPrimSelect  resIds resTypes+  multiPrimTermArgs = map (Left . Var) (argIds <> resIds)+  multiPrimTypeArgs = map (Right . VarTy) typeVars+  multiPrimBind =+    mkApps+      (Prim primInfo{primMultiResult=MultiResult})+      (multiPrimTypeArgs <> multiPrimTermArgs)++  multiPrimSelectInfo t = PrimInfo+    { primName = "c$multiPrimSelect"+    , primType = mkPolyFunTy pResTy [Right pResTy, Right t]+    , primWorkInfo = WorkAlways+    , primMultiResult = SingleResult+    , primUnfolding = NoUnfolding+    }++  letTerm =+    listToLets+      ((resId,multiPrimBind):multiPrimSelectBinds)+      (mkTmApps (mkTyApps (Data tupTc) resTypes) (map Var resIds))
+ src/Clash/Normalize/Transformations/Reduce.hs view
@@ -0,0 +1,565 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017-2018, Google Inc.,+                    2021-2022, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Transformations for compile-time reduction of expressions / primitives.+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Normalize.Transformations.Reduce+  ( reduceBinders+  , reduceConst+  , reduceNonRepPrim+  ) where++import qualified Control.Lens as Lens+import Control.Monad.Trans.Except (runExcept)+import qualified Data.Either as Either+import qualified Data.List as List+import qualified Data.List.Extra as List+import qualified Data.Maybe as Maybe+import Data.Maybe (fromMaybe, listToMaybe)+import GHC.Stack (HasCallStack)++import Clash.Core.FreeVars (typeFreeVars)+import Clash.Core.HasType+import Clash.Core.Name (nameOcc)+import Clash.Core.Pretty (showPpr)+import Clash.Core.Subst (Subst, extendIdSubst, substTm)+import Clash.Core.Term+  ( CoreContext(..), LetBinding, PrimInfo(..), Term(..), TickInfo(..), collectArgs+  , collectArgsTicks, mkApps, mkTicks, mkTmApps)+import Clash.Core.TyCon (tyConDataCons)+import Clash.Core.Type (Type, TypeView(..), mkTyConApp, splitFunForallTy, tyView)+import Clash.Core.Util (mkVec, shouldSplit, tyNatSize, mkInternalVar)+import Clash.Core.VarEnv (extendInScopeSet)+import qualified Clash.Data.UniqMap as UniqMap+import Clash.Normalize.PrimitiveReductions+import Clash.Normalize.Primitives (removedArg)+import Clash.Normalize.Types (NormRewrite, NormalizeSession)+import Clash.Normalize.Util (shouldReduce)+import Clash.Rewrite.Types (TransformContext(..), tcCache, normalizeUltra)+import Clash.Rewrite.Util (changed, isUntranslatableType, setChanged, whnfRW)++-- | XXX: is given inverse topologically sorted binders, but returns+-- topologically sorted binders+--+-- TODO: check further speed improvements:+--+-- 1. Store the processed binders in a `Map Expr LetBinding`:+--    * Trades O(1) `cons` and O(n)*aeqTerm `find` for:+--    * O(log n)*aeqTerm `insert` and O(log n)*aeqTerm `lookup`+-- 2. Store the processed binders in a `AEQTrie Expr LetBinding`+--    * Trades O(1) `cons` and O(n)*aeqTerm `find` for:+--    * O(e) `insert` and O(e) `lookup`+reduceBinders+  :: Subst+  -> [LetBinding]+  -> [LetBinding]+  -> NormalizeSession (Subst, [LetBinding])+reduceBinders !subst processed [] = return (subst,processed)+reduceBinders !subst processed ((i,substTm "reduceBinders" subst -> e):rest)+  | (_,_,ticks) <- collectArgsTicks e+  , NoDeDup `notElem` ticks+  , Just (i1,_) <- List.find ((== e) . snd) processed+  = do+    let subst1 = extendIdSubst subst i (Var i1)+    setChanged+    reduceBinders subst1 processed rest+  | otherwise+  = reduceBinders subst ((i,e):processed) rest+{-# SCC reduceBinders #-}++reduceConst :: HasCallStack => NormRewrite+reduceConst ctx e@(App _ _)+  | (Prim p0, _) <- collectArgs e+  = whnfRW False ctx e $ \_ctx1 e1 -> case e1 of+      (collectArgs -> (Prim p1, _)) | primName p0 == primName p1 -> return e+      _ -> changed e1++reduceConst _ e = return e+{-# SCC reduceConst #-}++-- | Replace primitives by their "definition" if they would lead to let-bindings+-- with a non-representable type when a function is in ANF. This happens for+-- example when Clash.Size.Vector.map consumes or produces a vector of+-- non-representable elements.+--+-- Basically what this transformation does is replace a primitive the completely+-- unrolled recursive definition that it represents. e.g.+--+-- > zipWith ($) (xs :: Vec 2 (Int -> Int)) (ys :: Vec 2 Int)+--+-- is replaced by:+--+-- > let (x0  :: (Int -> Int))       = case xs  of (:>) _ x xr -> x+-- >     (xr0 :: Vec 1 (Int -> Int)) = case xs  of (:>) _ x xr -> xr+-- >     (x1  :: (Int -> Int)(       = case xr0 of (:>) _ x xr -> x+-- >     (y0  :: Int)                = case ys  of (:>) _ y yr -> y+-- >     (yr0 :: Vec 1 Int)          = case ys  of (:>) _ y yr -> xr+-- >     (y1  :: Int                 = case yr0 of (:>) _ y yr -> y+-- > in  (($) x0 y0 :> ($) x1 y1 :> Nil)+--+-- Currently, it only handles the following functions:+--+-- * Clash.Sized.Vector.zipWith+-- * Clash.Sized.Vector.map+-- * Clash.Sized.Vector.traverse#+-- * Clash.Sized.Vector.fold+-- * Clash.Sized.Vector.foldr+-- * Clash.Sized.Vector.dfold+-- * Clash.Sized.Vector.(++)+-- * Clash.Sized.Vector.head+-- * Clash.Sized.Vector.tail+-- * Clash.Sized.Vector.last+-- * Clash.Sized.Vector.init+-- * Clash.Sized.Vector.unconcat+-- * Clash.Sized.Vector.transpose+-- * Clash.Sized.Vector.replicate+-- * Clash.Sized.Vector.replace_int+-- * Clash.Sized.Vector.imap+-- * Clash.Sized.Vector.dtfold+-- * Clash.Sized.RTree.tdfold+-- * Clash.Sized.RTree.treplicate+-- * Clash.Sized.Internal.BitVector.split#+-- * Clash.Sized.Internal.BitVector.eq#+--+-- Note [Unroll shouldSplit types]+-- 1. Certain higher-order functions over Vec, such as map, have specialized+-- code-paths to turn them into generate-for loops in HDL, instead of having to+-- having to unroll/inline their recursive definitions, e.g. Clash.Sized.Vector.map+--+-- 2. Clash, in general, translates Haskell product types to VHDL records. This+-- mostly works out fine, there is however one exception: certain synthesis+-- tools, and some HDL simulation tools (like verilator), do not like it when+-- the clock (and certain other global control signals) is contained in a+-- record type; they want them to be separate inputs to the entity/module.+-- And Clash actually does some transformations to try to ensure that values of+-- type Clock do not end up in a VHDL record type.+--+-- The problem is that the transformations in 2. never took into account the+-- specialized code-paths in 1. Making the code-paths in 1. aware of the+-- transformations in 2. is really not worth the effort for such a niche case.+-- It's easier to just unroll the recursive definitions.+--+-- See https://github.com/clash-lang/clash-compiler/issues/1606+reduceNonRepPrim :: HasCallStack => NormRewrite+reduceNonRepPrim c@(TransformContext _ ctx) e@(App _ _) | (Prim p, args, ticks) <- collectArgsTicks e = do+  tcm <- Lens.view tcCache+  ultra <- Lens.view normalizeUltra+  let eTy = inferCoreTypeOf tcm e+  let resTy = snd (splitFunForallTy eTy)+  case tyView resTy of+    (TyConApp vecTcNm@(nameOcc -> "Clash.Sized.Vector.Vec")+              [runExcept . tyNatSize tcm -> Right 0, aTy]) -> do+      let nilE = fromMaybe (error "reduceNonRepPrim: unable to create Vec DCs") $ do+            vecTc <- UniqMap.lookup vecTcNm tcm+            [nilCon,consCon] <- pure (tyConDataCons vecTc)+            return (mkVec nilCon consCon aTy 0 [])+      changed (mkTicks nilE ticks)+    tv -> let argLen = length args in case primName p of+      "Clash.Sized.Vector.zipWith"+        | (tmArgs,[lhsElTy,rhsElty,resElTy,nTy]) <- Either.partitionEithers args+        , TyConApp vecTcNm _ <- tv+        , let lhsTy = mkTyConApp vecTcNm [nTy,lhsElTy]+        , let rhsTy = mkTyConApp vecTcNm [nTy,rhsElty]+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ pure (ultra || n < 2)+                                 , shouldReduce ctx+                                 , List.anyM isUntranslatableType_not_poly+                                        [lhsElTy,rhsElty,resElTy]+                                 -- Note [Unroll shouldSplit types]+                                 , pure (any (Maybe.isJust . shouldSplit tcm)+                                             [lhsTy,rhsTy,resTy]) ]+            if shouldReduce1+               then abstractOverMissingArgs ticks tmArgs eTy c+                      (reduceZipWith p n lhsElTy rhsElty resElTy)+               else return e+          _ -> return e+        | argLen >= 4+        -> error ("reduceNonRepPrim: zipWith bad args" <> showPpr e)++      "Clash.Sized.Vector.map"+        | (tmArgs,[argElTy,resElTy,nTy]) <- Either.partitionEithers args+        , TyConApp vecTcNm _ <- tv+        , let argTy = mkTyConApp vecTcNm [nTy,argElTy]+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ pure (ultra || n < 2 )+                                 , shouldReduce ctx+                                 , List.anyM isUntranslatableType_not_poly+                                        [argElTy,resElTy]+                                 -- Note [Unroll shouldSplit types]+                                 , pure (any (Maybe.isJust . shouldSplit tcm)+                                             [argTy,resTy]) ]+            if shouldReduce1+               then abstractOverMissingArgs ticks tmArgs eTy c+                      (reduceMap p n argElTy resElTy)+               else return e+          _ -> return e+        | argLen >= 3+        -> error ("reduceNonRepPrim: map bad args" <> showPpr e)++      "Clash.Sized.Vector.traverse#"+        | (tmArgs,[aTy,fTy,bTy,nTy]) <- Either.partitionEithers args+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> abstractOverMissingArgs ticks tmArgs eTy c (reduceTraverse n aTy fTy bTy)+          _ -> return e+        | argLen >= 4+        -> error ("reduceNonRepPrim: traverse# bad args" <> showPpr e)++      "Clash.Sized.Vector.fold"+        | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args+        , (_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy]))+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ pure (ultra || n == 0)+                                 , shouldReduce ctx+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy))]+            if shouldReduce1 then+              abstractOverMissingArgs ticks tmArgs eTy c (reduceFold (n + 1) aTy)+            else return e+          _ -> return e+        | argLen >= 2+        -> error ("reduceNonRepPrim: fold bad args" <> showPpr e)++      "Clash.Sized.Vector.foldr"+        | (tmArgs,[aTy,bTy,nTy]) <- Either.partitionEithers args+        , (_:_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [aTy,bTy,nTy]))+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ pure ultra+                                 , shouldReduce ctx+                                 , List.anyM isUntranslatableType_not_poly [aTy,bTy]+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy)) ]+            if shouldReduce1+              then abstractOverMissingArgs ticks tmArgs eTy c (reduceFoldr p n aTy)+              else return e+          _ -> return e+        | argLen >= 3+        -> error ("reduceNonRepPrim: foldr bad args" <> showPpr e)++      "Clash.Sized.Vector.dfold"+        | (tmArgs,[_mTy,nTy,aTy]) <- Either.partitionEithers args+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> abstractOverMissingArgs ticks tmArgs eTy c (reduceDFold n aTy)+          _ -> return e+        | argLen >= 3+        -> error ("reduceNonRepPrim: dfold bad args" <> showPpr e)++      "Clash.Sized.Vector.++"+        | (tmArgs,[nTy,aTy,mTy]) <- Either.partitionEithers args+        -> case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of+              (Right n, Right m) -> do+                    shouldReduce1 <- List.orM [ pure (n==0)+                                         , pure (m==0)+                                         , shouldReduce ctx+                                         , isUntranslatableType_not_poly aTy+                                         -- Note [Unroll shouldSplit types]+                                         , pure (Maybe.isJust (shouldSplit tcm resTy)) ]+                    if shouldReduce1+                       then abstractOverMissingArgs ticks tmArgs eTy c (reduceAppend n m aTy)+                       else return e+              _ -> return e+        | argLen >= 3+        -> error ("reduceNonRepPrim: ++ bad args" <> showPpr e)++      "Clash.Sized.Vector.head"+        | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args+        , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy]))+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ shouldReduce ctx+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy)) ]+            if shouldReduce1+               then abstractOverMissingArgs ticks tmArgs eTy c (reduceHead (n+1) aTy)+               else return e+          _ -> return e+        | argLen >= 2+        -> error ("reduceNonRepPrim: head bad args" <> showPpr e)++      "Clash.Sized.Vector.tail"+        | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args+        , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy]))+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ shouldReduce ctx+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy)) ]+            if shouldReduce1+               then abstractOverMissingArgs ticks tmArgs eTy c (reduceTail (n+1) aTy)+               else return e+          _ -> return e+        | argLen >= 2+        -> error ("reduceNonRepPrim: tail bad args" <> showPpr e)++      "Clash.Sized.Vector.last"+        | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args+        , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy]))+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ shouldReduce ctx+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy))+                                 ]+            if shouldReduce1+               then abstractOverMissingArgs ticks tmArgs eTy c (reduceLast (n+1) aTy)+               else return e+          _ -> return e+        | argLen >= 2+        -> error ("reduceNonRepPrim: last bad args" <> showPpr e)++      "Clash.Sized.Vector.init"+        | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args+        , (Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy]))+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ shouldReduce ctx+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy)) ]+            if shouldReduce1+               then abstractOverMissingArgs ticks tmArgs eTy c (reduceInit p n aTy)+               else return e+          _ -> return e+        | argLen >= 2+        -> error ("reduceNonRepPrim: init bad args" <> showPpr e)++      "Clash.Sized.Vector.unconcat"+        | (tmArgs,[nTy,mTy,aTy]) <- Either.partitionEithers args+        , (_:_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,mTy,aTy]))+        -> case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of+          (Right n, Right m) -> do+            shouldReduce1 <- List.orM [ pure (m==0)+                                      , shouldReduce ctx+                                      , isUntranslatableType_not_poly aTy+                                      --  Note [Unroll shouldSplit types]+                                      , pure (Maybe.isJust (shouldSplit tcm argTy))+                                      ]+            if shouldReduce1 then+              abstractOverMissingArgs ticks tmArgs eTy c (reduceUnconcat p n m aTy)+            else+              return e+          _ -> return e+        | argLen >= 3+        -> error ("reduceNonRepPrim: unconcat bad args" <> showPpr e)++      "Clash.Sized.Vector.transpose"+        | (tmArgs,[mTy,nTy,aTy]) <- Either.partitionEithers args+        -> case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of+          (Right n, Right 0) -> abstractOverMissingArgs ticks tmArgs eTy c (reduceTranspose n 0 aTy)+          _ -> return e+        | argLen >= 3+        -> error ("reduceNonRepPrim: transpose bad args" <> showPpr e)++      "Clash.Sized.Vector.replicate"+        | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ shouldReduce ctx+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm resTy))+                                 ]+            if shouldReduce1+               then abstractOverMissingArgs ticks tmArgs eTy c (reduceReplicate n aTy resTy)+               else return e+          _ -> return e+        | argLen >= 2+        -> error ("reduceNonRepPrim: replicate bad args" <> showPpr e)++       -- replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a+      "Clash.Sized.Vector.replace_int"+        | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ pure ultra+                                 , shouldReduce ctx+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm resTy))+                                 ]+            if shouldReduce1+               then abstractOverMissingArgs ticks tmArgs eTy c (reduceReplace_int n aTy resTy)+               else return e+          _ -> return e+        | argLen >= 2+        -> error ("reduceNonRepPrim: replace_int bad args" <> showPpr e)++      "Clash.Sized.Vector.index_int"+        | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args+        , (_:Right argTy:_) <- fst (splitFunForallTy (piResultTys tcm (primType p) [nTy,aTy]))+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ pure ultra+                                 , shouldReduce ctx+                                 , isUntranslatableType_not_poly aTy+                                 -- Note [Unroll shouldSplit types]+                                 , pure (Maybe.isJust (shouldSplit tcm argTy)) ]+            if shouldReduce1+               then abstractOverMissingArgs ticks tmArgs eTy c (reduceIndex_int n aTy)+               else return e+          _ -> return e+        | argLen >= 2+        -> error ("reduceNonRepPrim: index_int bad args" <> showPpr e)++      "Clash.Sized.Vector.imap"+        | (tmArgs,[nTy,argElTy,resElTy]) <- Either.partitionEithers args+        , TyConApp vecTcNm _ <- tv+        , let argTy = mkTyConApp vecTcNm [nTy,argElTy]+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ pure (ultra || n < 2)+                                 , shouldReduce ctx+                                 , List.anyM isUntranslatableType_not_poly [argElTy,resElTy]+                                 -- Note [Unroll shouldSplit types]+                                 , pure (any (Maybe.isJust . shouldSplit tcm)+                                             [argTy,resTy]) ]+            if shouldReduce1+               then abstractOverMissingArgs ticks tmArgs eTy c (reduceImap n argElTy resElTy)+               else return e+          _ -> return e+        | argLen >= 3+        -> error ("reduceNonRepPrim: imap bad args" <> showPpr e)++      "Clash.Sized.Vector.iterateI"+        | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM+              [ pure (ultra || n < 2)+              , shouldReduce ctx+              , isUntranslatableType_not_poly aTy+              -- Note [Unroll shouldSplit types]+              , pure (Maybe.isJust (shouldSplit tcm resTy)) ]++            if shouldReduce1 then+              abstractOverMissingArgs ticks tmArgs eTy c (reduceIterateI n aTy resTy)+            else+              return e+          _ -> return e+        | argLen >= 2+        -> error ("reduceNonRepPrim: iterateI bad args" <> showPpr e)++      "Clash.Sized.Vector.dtfold"+        | (tmArgs,[_mTy,nTy,aTy]) <- Either.partitionEithers args+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> abstractOverMissingArgs ticks tmArgs eTy c (reduceDTFold n aTy)+          _ -> return e+        | argLen >= 3+        -> error ("reduceNonRepPrim: dtfold bad args" <> showPpr e)++      "Clash.Sized.Vector.reverse"+        | ultra+        , (tmArgs,[nTy,aTy]) <- Either.partitionEithers args+        , Right n <- runExcept (tyNatSize tcm nTy)+        -> abstractOverMissingArgs ticks tmArgs eTy c (reduceReverse n aTy)++      "Clash.Sized.RTree.tdfold"+        | (tmArgs,[_mTy,nTy,aTy]) <- Either.partitionEithers args+        -> case runExcept (tyNatSize tcm nTy) of+          Right n -> abstractOverMissingArgs ticks tmArgs eTy c (reduceTFold n aTy)+          _ -> return e+        | argLen >= 3+        -> error ("reduceNonRepPrim: tdfold bad args" <> showPpr e)+      "Clash.Sized.RTree.treplicate"+        | (tmArgs,[nTy,aTy]) <- Either.partitionEithers args ->+        case runExcept (tyNatSize tcm nTy) of+          Right n -> do+            shouldReduce1 <- List.orM [ shouldReduce ctx+                                 , isUntranslatableType False aTy ]+            if shouldReduce1+               then abstractOverMissingArgs ticks tmArgs eTy c (reduceTReplicate n aTy resTy)+               else return e+          _ -> return e+        | argLen >= 2+        -> error ("reduceNonRepPrim: treplicate bad args" <> showPpr e)+      "Clash.Sized.Internal.BitVector.split#"+        | (tmArgs,[nTy,mTy]) <- Either.partitionEithers args ->+        case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy), tv) of+          (Right n, Right m, TyConApp tupTcNm [lTy,rTy])+            | n == 0 -> abstractOverMissingArgs ticks tmArgs eTy c $ \(_kn :: Term) bvArg (_ctx :: TransformContext) -> do+              let tup = mkApps (Data tupDc)+                           [Right lTy+                           ,Right rTy+                           ,Left  bvArg+                           ,Left  (TyApp (Prim removedArg) rTy)+                           ]++              (changed (mkTicks tup ticks) :: NormalizeSession Term)+            | m == 0 -> abstractOverMissingArgs ticks tmArgs eTy c $ \(_kn :: Term) bvArg (_ctx :: TransformContext) -> do+              let tup = mkApps (Data tupDc)+                           [Right lTy+                           ,Right rTy+                           ,Left  (TyApp (Prim removedArg) lTy)+                           ,Left  bvArg+                           ]++              (changed (mkTicks tup ticks) :: NormalizeSession Term)+           where+            tupDc = fromMaybe (error "reduceNonRepPrim: faield to create tup DC") $ do+                    tupTc <- UniqMap.lookup tupTcNm tcm+                    listToMaybe (tyConDataCons tupTc)+          _ -> return e+        | argLen >= 3+        -> error ("reduceNonRepPrim: split# bad args" <> showPpr e)+      "Clash.Sized.Internal.BitVector.eq#"+        | (tmArgs,[nTy]) <- Either.partitionEithers args+        , Right 0 <- runExcept (tyNatSize tcm nTy)+        , TyConApp boolTcNm [] <- tv+        -> abstractOverMissingArgs ticks tmArgs eTy c $ \(_kn :: Term) (_l :: Term) (_r :: Term) (_ctx :: TransformContext) -> do+           let trueDc = fromMaybe (error "reduceNonRepPrim: failed to create True DC") $ do+                  boolTc <- UniqMap.lookup boolTcNm tcm+                  [_falseDc,dc] <- pure (tyConDataCons boolTc)+                  return dc+            in (changed (Data trueDc) :: NormalizeSession Term)+      _ -> return e+  where+    isUntranslatableType_not_poly t = do+      u <- isUntranslatableType False t+      if u+         then return (null $ Lens.toListOf typeFreeVars t)+         else return False++reduceNonRepPrim _ e = return e+{-# SCC reduceNonRepPrim #-}++class AbstractOverMissingArgs a where+  -- | Abstract over a primitive until it is saturated+  abstractOverMissingArgs ::+    HasCallStack =>+    -- | Ticks originally tagged to the applied primitive+    [TickInfo] ->+    -- | Available arguments+    [Term] ->+    -- | The type of the expression containing the applied primitive+    Type ->+    -- | The context in which reduceNonRepPrim was called+    TransformContext ->+    a ->+    NormalizeSession Term++instance AbstractOverMissingArgs (TransformContext -> NormalizeSession Term) where+  abstractOverMissingArgs ticks args _ is f = (`mkTmApps` args) <$> (`mkTicks` ticks) <$> f is++instance AbstractOverMissingArgs a => AbstractOverMissingArgs (Term -> a) where+  abstractOverMissingArgs ticks (t:ts) ty ctx f = abstractOverMissingArgs ticks ts ty ctx (f t)+  abstractOverMissingArgs ticks []     (tyView -> FunTy argTy resTy) (TransformContext is0 ctx) f = do+     newId <- mkInternalVar is0 "arg" argTy+     let ctx1 = TransformContext (extendInScopeSet is0 newId) (LamBody newId : ctx)+     Lam newId <$> abstractOverMissingArgs ticks [] resTy ctx1 (f (Var newId))+  abstractOverMissingArgs _ _ ty _ _ = error ("not a funty: " <> showPpr ty)
+ src/Clash/Normalize/Transformations/SeparateArgs.hs view
@@ -0,0 +1,120 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017-2018, Google Inc.,+                    2021     , QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+  The separating arguments transformation+-}++{-# LANGUAGE OverloadedStrings #-}++module Clash.Normalize.Transformations.SeparateArgs+  ( separateArguments+  ) where++import qualified Control.Lens as Lens+import Control.Monad.Writer (listen)+import qualified Data.List as List+import qualified Data.Monoid as Monoid+import GHC.Stack (HasCallStack)++import Clash.Core.HasType+import Clash.Core.Name (Name(..))+import Clash.Core.Subst (extendIdSubst, mkSubst, substTm)+import Clash.Core.Term (Term(..), collectArgsTicks, mkApps, mkLams, mkTicks)+import Clash.Core.Type (Type, mkPolyFunTy, splitFunForallTy)+import Clash.Core.TyCon (TyConMap)+import Clash.Core.Util (Projections (..), shouldSplit)+import Clash.Core.Var (Id, TyVar, Var (..), isGlobalId, mkLocalId)+import Clash.Core.VarEnv (extendInScopeSet, uniqAway)+import Clash.Normalize.Types (NormRewrite, NormalizeSession)+import Clash.Rewrite.Types (TransformContext(..), tcCache)+import Clash.Rewrite.Util (changed, mkDerivedName)++-- | Split apart (global) function arguments that contain types that we+-- want to separate off, e.g. Clocks. Works on both the definition side (i.e. the+-- lambda), and the call site (i.e. the application of the global variable). e.g.+-- turns+--+-- > f :: (Clock System, Reset System) -> Signal System Int+--+-- into+--+-- > f :: Clock System -> Reset System -> Signal System Int+separateArguments :: HasCallStack => NormRewrite+separateArguments ctx e0@(Lam b eb) = do+  tcm <- Lens.view tcCache+  case separateLambda tcm ctx b eb of+    Just e1 -> changed e1+    Nothing -> return e0++separateArguments (TransformContext is0 _) e@(collectArgsTicks -> (Var g, args, ticks))+  | isGlobalId g = do+  -- We ensure that both the type of the global variable reference is updated+  -- to take into account the changed arguments, and that we apply the global+  -- function with the split apart arguments.+  let (argTys0,resTy) = splitFunForallTy (coreTypeOf g)+  (concat -> args1, Monoid.getAny -> hasChanged)+    <- listen (mapM (uncurry splitArg) (zip argTys0 args))+  if hasChanged then+    let (argTys1,args2) = unzip args1+        gTy = mkPolyFunTy resTy argTys1+    in  return (mkApps (mkTicks (Var g {varType = gTy}) ticks) args2)+  else+    return e++ where+  -- Split a single argument+  splitArg+    :: Either TyVar Type+    -- The quantifier/function argument type of the global variable+    -> Either Term Type+    -- The applied type argument or term argument+    -> NormalizeSession [(Either TyVar Type,Either Term Type)]+  splitArg tv arg@(Right _)    = return [(tv,arg)]+  splitArg ty arg@(Left tmArg) = do+    tcm <- Lens.view tcCache+    let argTy = inferCoreTypeOf tcm tmArg+    case shouldSplit tcm argTy of+      Just (_,Projections projections,_) -> do+        tmArgs <- projections is0 tmArg+        changed (map ((ty,) . Left) tmArgs)+      _ ->+        return [(ty,arg)]++separateArguments _ e = return e+{-# SCC separateArguments #-}++-- | Worker function of 'separateArguments'.+separateLambda+  :: TyConMap+  -> TransformContext+  -> Id+  -- ^ Lambda binder+  -> Term+  -- ^ Lambda body+  -> Maybe Term+  -- ^ If lambda is split up, this function returns a Just containing the new term+separateLambda tcm ctx@(TransformContext is0 _) b eb0 =+  case shouldSplit tcm (coreTypeOf b) of+    Just (dc, _, argTys) ->+      let+        nm = mkDerivedName ctx (nameOcc (varName b))+        bs0 = map (`mkLocalId` nm) argTys+        (is1, bs1) = List.mapAccumL newBinder is0 bs0+        subst = extendIdSubst (mkSubst is1) b (dc (map Var bs1))+        eb1 = substTm "separateArguments" subst eb0+      in+        Just (mkLams eb1 bs1)+    _ ->+      Nothing+ where+  newBinder isN0 x =+    let+      x' = uniqAway isN0 x+      isN1 = extendInScopeSet isN0 x'+    in+      (isN1, x')+{-# SCC separateLambda #-}
+ src/Clash/Normalize/Transformations/Specialize.hs view
@@ -0,0 +1,760 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017-2018, Google Inc.,+                    2021-2026, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Transformations for specialization+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++module Clash.Normalize.Transformations.Specialize+  ( appProp+  , constantSpec+  , specialize+  , nonRepSpec+  , typeSpec+  , zeroWidthSpec+  ) where++import Control.Arrow ((***), (&&&))+import Control.DeepSeq (deepseq)+import Control.Exception (throw)+import Control.Lens ((%=))+import qualified Control.Lens as Lens+import qualified Control.Monad as Monad+import Control.Monad.Extra (orM)+import qualified Control.Monad.Writer as Writer (listen)+import Data.Bifunctor (bimap)+import Data.Coerce (coerce)+import qualified Data.Either as Either+import Data.Functor.Const (Const(..))+import qualified Data.Map.Strict as Map+import qualified Data.Monoid as Monoid (getAny)+import qualified Data.Set.Ordered as OSet+import qualified Data.Set.Ordered.Extra as OSet+import qualified Data.Text as Text+import qualified Data.Text.Extra as Text+import GHC.BasicTypes.Extra (isNoInline)+import GHC.Stack (HasCallStack)++import GHC.Types.Basic (InlineSpec (..))++import qualified Clash.Sized.Internal.BitVector as BV (BitVector, fromInteger#)+import qualified Clash.Sized.Internal.Index as I (Index, fromInteger#)+import qualified Clash.Sized.Internal.Signed as S (Signed, fromInteger#)+import qualified Clash.Sized.Internal.Unsigned as U (Unsigned, fromInteger#)++import Clash.Core.DataCon (DataCon(dcArgTys))+import Clash.Core.FreeVars (freeLocalVars, termFreeTyVars, typeFreeVars)+import Clash.Core.HasType+import Clash.Core.Literal (Literal(..))+import Clash.Core.Name+  (NameSort(..), Name(..), appendToName, mkUnsafeInternalName, mkUnsafeSystemName)+import Clash.Core.Pretty (showPpr)+import Clash.Core.Subst+import Clash.Core.Term+  ( Term(..), TickInfo, collectArgs, collectArgsTicks, mkApps, mkTmApps, mkTicks, patIds, Bind(..)+  , patVars, mkAbstraction, PrimInfo(..), WorkInfo(..), IsMultiPrim(..), PrimUnfolding(..), stripAllTicks)+import Clash.Core.TermInfo (isLocalVar, isVar, isPolyFun)+import Clash.Core.TyCon (TyConMap, tyConDataCons)+import Clash.Core.Type+  (LitTy(NumTy), Type(LitTy,VarTy), applyFunTy, splitTyConAppM, normalizeType+  , mkPolyFunTy, mkTyConApp)+import Clash.Core.TysPrim+import Clash.Core.Util (listToLets)+import Clash.Core.Var (Var(..), Id, TyVar, mkTyVar)+import Clash.Core.VarEnv+  ( InScopeSet, extendInScopeSet, extendInScopeSetList, lookupVarEnv+  , mkInScopeSet, mkVarSet, unionInScope, elemVarSet)+import qualified Clash.Data.UniqMap as UniqMap+import Clash.Debug (traceIf, traceM)+import Clash.Driver.Types (Binding(..), TransformationInfo(..), hasTransformationInfo)+import Clash.Netlist.Util (representableType)+import Clash.Rewrite.Combinators (topdownR)+import Clash.Rewrite.Types+  ( TransformContext(..), bindings, censor, curFun, customReprs, extra, tcCache+  , typeTranslator, workFreeBinders, debugOpts, topEntities, specializationLimit)+import Clash.Rewrite.Util+  ( mkBinderFor, mkDerivedName, mkFunction, mkTmBinderFor, setChanged, changed+  , normalizeTermTypes, normalizeId, whnfRW)+import Clash.Rewrite.WorkFree (isWorkFree)+import Clash.Normalize.Types+  ( NormRewrite, NormalizeSession, specialisationCache, specialisationHistory)+import Clash.Normalize.Util+  (constantSpecInfo, csrFoundConstant, csrNewBindings, csrNewTerm)+import Clash.Unique (Unique)+import Clash.Util (ClashException(..))++-- | Propagate arguments of application inwards; except for 'Lam' where the+-- argument becomes let-bound. 'appProp' tries to propagate as many arguments+-- as possible, down as many levels as possible; and should be called in a+-- top-down traversal.+--+-- The idea is that this reduces the number of traversals, which hopefully leads+-- to shorter compile times.+--+-- Note [AppProp no shadowing]+--+-- Case 1.+--+-- Imagine:+--+-- @+-- (case x of+--    D a b -> h a) (f x y)+-- @+--+-- rewriting this to:+--+-- @+-- let b = f x y+-- in  case x of+--       D a b -> h a b+-- @+--+-- is very bad because @b@ in @h a b@ is now bound by the pattern instead of the+-- newly introduced let-binding+--+-- instead we must deshadow w.r.t. the new variable and rewrite to:+--+-- @+-- let b = f x y+-- in  case x of+--       D a b1 -> h a b+-- @+--+-- Case 2.+--+-- Imagine+--+-- @+-- (\\x -> e) u+-- @+--+-- where @u@ has a free variable named @x@, rewriting this to:+--+-- @+-- let x = u+-- in  e+-- @+--+-- would be very bad, because the let-binding suddenly captures the free+-- variable in @u@. To prevent this from happening we over-approximate and check+-- whether @x@ is in the current InScopeSet, and deshadow if that's the case,+-- i.e. we then rewrite to:+--+-- @+-- let x1 = u+-- in  e [x:=x1]+-- @+--+-- Case 3.+--+-- The same for:+--+-- @+-- (let x = w in e) u+-- @+--+-- where @u@ again has a free variable @x@, rewriting this to:+--+-- @+-- let x = w in (e u)+-- @+--+-- would be bad because the let-binding now captures the free variable in @u@.+--+-- To prevent this from happening, we unconditionally deshadow the function part+-- of the application w.r.t. the free variables in the argument part of the+-- application. It is okay to over-approximate in this case and deshadow w.r.t+-- the current InScopeSet.+appProp :: HasCallStack => NormRewrite+appProp ctx@(TransformContext is _) = \case+  e@App {}+    | let (fun,args,ticks) = collectArgsTicks e+    -> do (eN,hasChanged) <- Writer.listen (go is (deShadowTerm is fun) args ticks)+          if Monoid.getAny hasChanged+            then return eN+            else return e+  e@TyApp {}+    | let (fun,args,ticks) = collectArgsTicks e+    -> do (eN,hasChanged) <- Writer.listen (go is (deShadowTerm is fun) args ticks)+          if Monoid.getAny hasChanged+            then return eN+            else return e+  e          -> return e+ where+  go :: InScopeSet -> Term -> [Either Term Type] -> [TickInfo] -> NormalizeSession Term+  go is0 (collectArgsTicks -> (fun,args0@(_:_),ticks0)) args1 ticks1 =+    go is0 fun (args0 ++ args1) (ticks0 ++ ticks1)++  go is0 (Lam v e) (Left arg:args) ticks = do+    setChanged+    bndrs <- Lens.use bindings+    orM [pure (isVar arg), isWorkFree workFreeBinders bndrs arg] >>= \case+      True ->+        let subst = extendIdSubst (mkSubst is0) v arg in+        (`mkTicks` ticks) <$> go is0 (substTm "appProp.AppLam" subst e) args []+      False ->+        let is1 = extendInScopeSet is0 v in+        Let (NonRec v arg) <$> go is1 (deShadowTerm is1 e) args ticks++  go is0 (Let (NonRec i x) e) args@(_:_) ticks = do+    setChanged+    let is1 = extendInScopeSet is0 i+    -- XXX: binding should already be deshadowed w.r.t. 'is0'+    Let (NonRec i x) <$> go is1 e args ticks++  go is0 (Let (Rec vs) e) args@(_:_) ticks = do+    setChanged+    let vbs  = map fst vs+        is1  = extendInScopeSetList is0 vbs+    -- XXX: 'vs' should already be deshadowed w.r.t. 'is0'+    Let (Rec vs) <$> go is1 e args ticks++  go is0 (TyLam tv e) (Right t:args) ticks = do+    setChanged+    let subst = extendTvSubst (mkSubst is0) tv t+    (`mkTicks` ticks) <$> go is0 (substTm "appProp.TyAppTyLam" subst e) args []++  go is0 (Case scrut ty0 alts) args0@(_:_) ticks = do+    setChanged+    let isA1 = unionInScope+                 is0+                 ((mkInScopeSet . mkVarSet . concatMap (patVars . fst)) alts)+    (ty1,vs,args1) <- goCaseArg isA1 ty0 [] args0+    case vs of+      [] -> (`mkTicks` ticks) . Case scrut ty1 <$> mapM (goAlt is0 args1) alts+      _  -> do+        let vbs   = map fst vs+            is1   = extendInScopeSetList is0 vbs+            alts1 = map (deShadowAlt is1) alts+        -- TODO I should have a mkNonRecLets :: [LetBinding] -> Term -> Term+        -- function which makes a chain of non-recursive let expressions without+        -- needing to first take the SCCs of all the binders.+        listToLets vs . (`mkTicks` ticks) . Case scrut ty1 <$> mapM (goAlt is1 args1) alts1++  go is0 (Tick sp e) args ticks = do+    setChanged+    go is0 e args (sp:ticks)++  go _ fun args ticks = return (mkApps (mkTicks fun ticks) args)++  goAlt is0 args0 (p,e) = do+    let (tvs,ids) = patIds p+        is1       = extendInScopeSetList (extendInScopeSetList is0 tvs) ids+    (p,) <$> go is1 e args0 []++  goCaseArg isA ty0 ls0 (Right t:args0) = do+    tcm <- Lens.view tcCache+    let ty1 = piResultTy tcm ty0 t+    (ty2,ls1,args1) <- goCaseArg isA ty1 ls0 args0+    return (ty2,ls1,Right t:args1)++  goCaseArg isA0 ty0 ls0 (Left arg:args0) = do+    tcm <- Lens.view tcCache+    bndrs <- Lens.use bindings+    let argTy = inferCoreTypeOf tcm arg+        ty1   = applyFunTy tcm ty0 argTy+    orM [pure (isVar arg), isWorkFree workFreeBinders bndrs arg] >>= \case+      True -> do+        (ty2,ls1,args1) <- goCaseArg isA0 ty1 ls0 args0+        return (ty2,ls1,Left arg:args1)+      False -> do+        boundArg <- mkTmBinderFor isA0 tcm (mkDerivedName ctx "app_arg") arg+        let isA1 = extendInScopeSet isA0 boundArg+        (ty2,ls1,args1) <- goCaseArg isA1 ty1 ls0 args0+        return (ty2,(boundArg,arg):ls1,Left (Var boundArg):args1)++  goCaseArg _ ty ls [] = return (ty,ls,[])+{-# SCC appProp #-}++-- | Specialize functions on arguments which are constant, except when they+-- are clock, reset generators.+constantSpec :: HasCallStack => NormRewrite+constantSpec ctx@(TransformContext is0 tfCtx) e@(App e1 e2)+  | (Var {}, args) <- collectArgs e1+  , (_, []) <- Either.partitionEithers args+  , null $ Lens.toListOf termFreeTyVars e2+  = do specInfo<- constantSpecInfo ctx e2+       if csrFoundConstant specInfo then+         let newBindings = csrNewBindings specInfo in+         if null newBindings then do+           -- Whole of e2 is constant, we reduce it here eagerly before specialization+           -- because we have observed long running compile times when having+           -- recursively defined constants, see:+           -- https://github.com/clash-lang/clash-compiler/issues/3129+            e2Red <- case collectArgs e2 of+                           (Prim p0, _) -> whnfRW False ctx e2 $ \_ctx1 e2Red -> case e2Red of+                             (collectArgs -> (Prim p1, _)) | primName p0 == primName p1 -> return e2+                             _ -> changed e2Red+                           _ -> return e2+            specialize ctx (App e1 e2Red)+         else do+           -- Parts of e2 are constant+           let is1 = extendInScopeSetList is0 (fst <$> csrNewBindings specInfo)+           (body, isSpec) <- Writer.listen $ specialize+             (TransformContext is1 tfCtx)+             (App e1 (csrNewTerm specInfo))++           if Monoid.getAny isSpec+             then changed (listToLets newBindings body)+             else return e+       else+        -- e2 has no constant parts+        return e+constantSpec _ e = return e+{-# SCC constantSpec #-}++-- | Specialize an application on its argument+specialize :: NormRewrite+specialize ctx e = case e of+  (TyApp e1 ty) -> specialize' ctx e (collectArgsTicks e1) (Right ty)+  (App e1 e2)   -> specialize' ctx e (collectArgsTicks e1) (Left  e2)+  _             -> return e++{-+Note [ticks and specialization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As Clash now distinguishes between ticks in expressions when comparing for+alpha equality, this has a knock-on effect when accessing the specialization+cache. Consider these applications which differ only by ticks:++    f[GlobalId] (\x -> ... x[LocalId])+    f[GlobalId] <tick>(\x -> ... x[LocalId])+    f[GlobalId] (\x -> ... <tick>x[LocalId])++If one of these had been specialized, the other two would hit that term in the+specialization cache, saving Clash from having to re-do work which is in effect+the same. To preserve this behavior, we use 'stripAllTicks' on the keys for+the specialization cache.++TODO While this preserves the old behavior, the old behavior is likely not+quite what we want. Using a value from the specialization cache may change the+ticks present, which can affect naming / debugging information in generated HDL.+We may also not want to look at ticks, as then the specialization cache will+miss on virtually every lookup which could add to normalization time.+-}++-- | Given two 'InlineSpec's, return the \"strongest\" one. I.e., the one that's+-- closest to @NoInline@ (or @Opaque@ for newer GHCs).+preferNoInline :: InlineSpec -> InlineSpec -> InlineSpec+preferNoInline is0 is1+  | enumInlineSpec is0 >= enumInlineSpec is1 = is0+  | otherwise                                = is1+ where+  enumInlineSpec :: InlineSpec -> Int+  enumInlineSpec = \case+    NoUserInlinePrag {} -> -1+    Inline {} -> 0+    Inlinable {} -> 1+    NoInline {} -> 2+    Opaque {} -> 3++-- | Specialize an application on its argument+specialize'+  :: TransformContext+  -- ^ Transformation context+  -> Term+  -- ^ Original term+  -> (Term, [Either Term Type], [TickInfo])+  -- ^ Function part of the term, split into root and applied arguments+  -> Either Term Type+  -- ^ Argument to specialize on+  -> NormalizeSession Term+specialize' (TransformContext is0 _) e (Var f, args, ticks) specArgIn = do+  opts <- Lens.view debugOpts+  tcm <- Lens.view tcCache++  -- Don't specialize TopEntities+  topEnts <- Lens.view topEntities+  if f `elemVarSet` topEnts+  then do+    case specArgIn of+      Left _ -> do+        traceM ("Not specializing TopEntity: " ++ showPpr (varName f))+        return e+      Right tyArg ->+        traceIf (hasTransformationInfo AppliedTerm opts) ("Dropping type application on TopEntity: " ++ showPpr (varName f) ++ "\ntype:\n" ++ showPpr tyArg) $+        -- TopEntities aren't allowed to be semantically polymorphic.+        -- But using type equality constraints they may be syntactically polymorphic.+        -- > topEntity :: forall dom . (dom ~ "System") => Signal dom Bool -> Signal dom Bool+        -- The TyLam's in the body will have been removed by 'Clash.Normalize.Util.substWithTyEq'.+        -- So we drop the TyApp ("specializing" on it) and change the varType to match.+        let newVarTy = piResultTy tcm (coreTypeOf f) tyArg+        in  changed (mkApps (mkTicks (Var f{varType = newVarTy}) ticks) args)+  else do -- NondecreasingIndentation++  let specArg = bimap (normalizeTermTypes tcm) (normalizeType tcm) specArgIn+      -- Create binders and variable references for free variables in 'specArg'+      -- (specBndrsIn,specVars) :: ([Either Id TyVar], [Either Term Type])+      (specBndrsIn,specVars) = specArgBndrsAndVars specArg+      argLen  = length args+      specBndrs :: [Either Id TyVar]+      specBndrs = map (Lens.over Lens._Left (normalizeId tcm)) specBndrsIn++      -- See Note [ticks and specialization]+      specAbs :: Either Term Type+      specAbs = either (Left . stripAllTicks . (`mkAbstraction` specBndrs)) (Right . id) specArg+  -- Determine if 'f' has already been specialized on (a type-normalized) 'specArg'+  specM <- Map.lookup (f,argLen,specAbs) <$> Lens.use (extra.specialisationCache)+  case specM of+    -- Use previously specialized function+    Just f' ->+      traceIf (hasTransformationInfo AppliedTerm opts)+        ("Using previous specialization of " ++ showPpr (varName f) ++ " on " +++          (either showPpr showPpr) specAbs ++ ": " ++ showPpr (varName f')) $+        changed $ mkApps (mkTicks (Var f') ticks) (args ++ specVars)+    -- Create new specialized function+    Nothing -> do+      -- Determine if we can specialize f+      bodyMaybe <- fmap (UniqMap.lookup f) $ Lens.use bindings+      case bodyMaybe of+        Just (Binding _ sp inl _ bodyTm _) -> do+          -- Determine if we see a sequence of specializations on a growing argument+          specHistM <- UniqMap.lookup f <$> Lens.use (extra.specialisationHistory)+          specLim   <- Lens.view specializationLimit+          if maybe False (> specLim) specHistM+            then throw (ClashException+                        sp+                        (unlines [ "Hit specialization limit " ++ show specLim ++ " on function `" ++ showPpr (varName f) ++ "'.\n"+                                 , "The function `" ++ showPpr f ++ "' is most likely recursive, and looks like it is being indefinitely specialized on a growing argument.\n"+                                 , "Body of `" ++ showPpr f ++ "':\n" ++ showPpr bodyTm ++ "\n"+                                 , "Argument (in position: " ++ show argLen ++ ") that triggered termination:\n" ++ (either showPpr showPpr) specArg+                                 , "Run with '-fclash-spec-limit=N' to increase the specialization limit to N."+                                 ])+                        Nothing)+            else do+              let existingNames = collectBndrsMinusApps bodyTm+                  newNames      = [ mkUnsafeInternalName ("pTS" `Text.append` Text.pack (show n)) n+                                  | n <- [(0::Unique)..]+                                  ]+              -- Make new binders for existing arguments+              (boundArgs,argVars) <- fmap (unzip . map (either (Left &&& Left . Var) (Right &&& Right . VarTy))) $+                                     Monad.zipWithM+                                       (mkBinderFor is0 tcm)+                                       (existingNames ++ newNames)+                                       args+              -- Determine name the resulting specialized function, and the+              -- form of the specialized-on argument+              (newName, inl', specArg') <- case specArg of+                Left a@(collectArgsTicks -> (Var g,gArgs,_gTicks)) -> if isPolyFun tcm a+                    then do+                      -- In case we are specializing on an argument that is a+                      -- global function then we use that function's name as part+                      -- of the name of the specialized higher-order function.+                      -- Additionally, we will return the body of the global+                      -- function, instead of a variable reference to the+                      -- global function.+                      --+                      -- This will turn things like @mealy g@ into a new+                      -- binding where both the body of @mealy@ and @g@+                      -- are inlined, meaning the state-transition-function+                      -- and the memory element will be in a single function.+                      --+                      -- The name of the new function depends on NOINLINE / OPAQUE+                      -- annotations.+                      --+                      --    OPAQUE    | Name for @f g@+                      --   -----------|---------------+                      --    f and g   | f_g+                      --    f         | f+                      --    g         | g+                      --    !f and !g | f_g+                      --+                      -- Finally, we must make sure we do not inline the bodies+                      -- of functions with a Synthesize annotation, as that would+                      -- duplicate Clash compiler work. See also issue #3024+                      gTmM <- fmap (UniqMap.lookup g) $ Lens.use bindings+                      let gBody = if g `elemVarSet` topEnts then+                                    Nothing+                                  else+                                    fmap bindingTerm gTmM+                      return+                        ( specializeName (inl, varName f) (bindingSpec <$> gTmM, varName g)+                        , preferNoInline inl (maybe noUserInline bindingSpec gTmM)+                        , maybe specArg (Left . (`mkApps` gArgs)) gBody+                        )+                    else return (varName f, inl, specArg)+                _ -> return (varName f, inl, specArg)+              -- Create specialized functions+              let newBody = mkAbstraction (mkApps bodyTm (argVars ++ [specArg'])) (boundArgs ++ specBndrs)+              newf <- mkFunction newName sp inl' newBody+              -- Remember specialization+              (extra.specialisationHistory) %= UniqMap.insertWith (+) f 1+              (extra.specialisationCache)  %= Map.insert (f,argLen,specAbs) newf+              -- use specialized function+              let newExpr = mkApps (mkTicks (Var newf) ticks) (args ++ specVars)+              newf `deepseq` changed newExpr+        Nothing -> return e+  where+    noUserInline :: InlineSpec+    noUserInline = NoUserInlinePrag++    specializeName :: (InlineSpec, Name Term) -> (Maybe InlineSpec, Name Term) -> Name Term+    specializeName (spec0, n0) (spec1, n1)+      | (ann0 && ann1) || (not ann0 && not ann1)+      = n0{nameOcc=nameOcc n0 <> "_" <> stripMods (nameOcc n1)}+      | ann0 = n0+      | otherwise = n1+     where+      ann0 = isNoInline spec0+      ann1 = fmap isNoInline spec1 == Just True++    stripMods :: Text.Text -> Text.Text+    stripMods = Text.takeWhileEnd (/= '.')++    collectBndrsMinusApps :: Term -> [Name a]+    collectBndrsMinusApps = reverse . go []+      where+        go bs (Lam v e')    = go (coerce (varName v):bs)  e'+        go bs (TyLam tv e') = go (coerce (varName tv):bs) e'+        go bs (App e' _) = case go [] e' of+          []  -> bs+          bs' -> init bs' ++ bs+        go bs (TyApp e' _) = case go [] e' of+          []  -> bs+          bs' -> init bs' ++ bs+        go bs _ = bs++-- Specializing non Var's is used by nonRepANF+specialize' _ctx _ (appE,args,ticks) (Left specArg) = do+  -- Create binders and variable references for free variables in 'specArg'+  let (specBndrs,specVars) = specArgBndrsAndVars (Left specArg)+  -- Create specialized function+      newBody = mkAbstraction specArg specBndrs+  -- See if there's an existing binder that's alpha-equivalent to the+  -- specialized function+  existing <- UniqMap.filter ((`aeqTerm` newBody) . bindingTerm) <$> Lens.use bindings+  -- Create a new function if an alpha-equivalent binder doesn't exist+  newf <- case UniqMap.elems existing of+    [] -> do (cf,sp) <- Lens.use curFun+             mkFunction (appendToName (varName cf) "_specF") sp NoUserInlinePrag newBody+    (b:_) -> return (bindingId b)+  -- Create specialized argument+  let newArg  = Left $ mkApps (Var newf) specVars+  -- Use specialized argument+  let newExpr = mkApps (mkTicks appE ticks) (args ++ [newArg])+  changed newExpr++specialize' _ e _ _ = return e++-- Note [Collect free-variables in an insertion-ordered set]+--+-- In order for the specialization cache to work, 'specArgBndrsAndVars' should+-- yield (alpha equivalent) results for the same specialization. While collecting+-- free variables in a given term or type it should therefore keep a stable+-- ordering based on the order in which it finds free vars. To see why,+-- consider the following two pseudo-code calls to 'specialize':+--+--     specialize {f ('a', x[123], y[456])}+--     specialize {f ('b', x[456], y[123])}+--+-- Collecting the binders in a VarSet would yield the following (unique ordered)+-- sets:+--+--     {x[123], y[456]}+--     {y[123], x[456]}+--+-- ..and therefore breaking specializing caching. We now track them in insert-+-- ordered sets, yielding:+--+--     {x[123], y[456]}+--     {x[456], y[123]}+--++-- | Create binders and variable references for free variables in 'specArg'+specArgBndrsAndVars+  :: Either Term Type+  -> ([Either Id TyVar], [Either Term Type])+specArgBndrsAndVars specArg =+  -- See Note [Collect free-variables in an insertion-ordered set]+  let unitFV :: Var a -> Const (OSet.OLSet TyVar, OSet.OLSet Id) (Var a)+      unitFV v@(Id {}) = Const (mempty, coerce (OSet.singleton (coerce v)))+      unitFV v@(TyVar {}) = Const (coerce (OSet.singleton (coerce v)), mempty)++      (specFTVs,specFVs) = case specArg of+        Left tm  -> (OSet.toListL *** OSet.toListL) . getConst $+                    Lens.foldMapOf freeLocalVars unitFV tm+        Right ty -> ( UniqMap.elems+                        (Lens.foldMapOf typeFreeVars (\x -> UniqMap.singletonUnique (coerce x)) ty)+                    , [] :: [Id])++      specTyBndrs = map Right specFTVs+      specTmBndrs = map Left  specFVs++      specTyVars  = map (Right . VarTy) specFTVs+      specTmVars  = map (Left . Var) specFVs++  in  (specTyBndrs ++ specTmBndrs,specTyVars ++ specTmVars)++-- | Specialize functions on their non-representable argument+nonRepSpec :: HasCallStack => NormRewrite+nonRepSpec ctx e@(App e1 e2)+  | (Var {}, args) <- collectArgs e1+  , (_, [])     <- Either.partitionEithers args+  , null $ Lens.toListOf termFreeTyVars e2+  = do tcm <- Lens.view tcCache+       let e2Ty = inferCoreTypeOf tcm e2+       let localVar = isLocalVar e2+       nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator+                                              <*> Lens.view customReprs+                                              <*> pure False+                                              <*> Lens.view tcCache+                                              <*> pure e2Ty)+       if nonRepE2 && not localVar+         then do+           e2' <- inlineInternalSpecialisationArgument e2+           specialize ctx (App e1 e2')+         else return e+  where+    -- | If the argument on which we're specializing is an internal function,+    -- one created by the compiler, then inline that function before we+    -- specialize.+    --+    -- We need to do this because otherwise the specialization history won't+    -- recognize the new specialization argument as something the function has+    -- already been specialized on+    inlineInternalSpecialisationArgument+      :: Term+      -> NormalizeSession Term+    inlineInternalSpecialisationArgument app+      | (Var f,fArgs,ticks) <- collectArgsTicks app+      = do+        fTmM <- lookupVarEnv f <$> Lens.use bindings+        case fTmM of+          Just b+            | nameSort (varName (bindingId b)) == Internal+            -> censor (const mempty)+                      (topdownR appProp ctx+                        (mkApps (mkTicks (bindingTerm b) ticks) fArgs))+          _ -> return app+      | otherwise = return app++nonRepSpec _ e = return e+{-# SCC nonRepSpec #-}++-- | Specialize functions on their type+typeSpec :: HasCallStack => NormRewrite+typeSpec ctx e@(TyApp e1 ty)+  | (Var {},  args) <- collectArgs e1+  , null $ Lens.toListOf typeFreeVars ty+  , (_, []) <- Either.partitionEithers args+  = specialize ctx e++typeSpec _ e = return e+{-# SCC typeSpec #-}++-- | Specialize functions on arguments which are zero-width. These arguments+-- can have only one possible value, and specializing on this value may create+-- additional opportunities for transformations to fire.+--+-- As we can't remove zero-width arguements (as transformations cannot change+-- the type of a term), we instead substitute all occurances of a lambda-bound+-- variable with a zero-width type with the only value of that type.+--+zeroWidthSpec :: HasCallStack => NormRewrite+zeroWidthSpec (TransformContext is _) e@(Lam i x0) = do+  tcm <- Lens.view tcCache+  let bndrTy = normalizeType tcm (coreTypeOf i)++  case zeroWidthTypeElem tcm bndrTy of+    Just tm ->+      let subst = extendIdSubst (mkSubst is) i tm+          x1 = substTm "zeroWidthSpec" subst x0+       in changed (Lam i x1)++    Nothing ->+      return e++zeroWidthSpec _ e = return e+{-# SCC zeroWidthSpec #-}++-- Get the only element of a type, if it is zero-width.+--+zeroWidthTypeElem :: TyConMap -> Type -> Maybe Term+zeroWidthTypeElem tcm ty = do+  (tcNm, args) <- splitTyConAppM ty++  if | nameOcc tcNm == Text.showt ''BV.BitVector+     , [LitTy (NumTy 0)] <- args+     -> return (bitVectorZW tcNm args)++     | nameOcc tcNm == Text.showt ''I.Index+     , [LitTy (NumTy 1)] <- args+     -> return (indexZW tcNm args)++     | nameOcc tcNm == Text.showt ''S.Signed+     , [LitTy (NumTy 0)] <- args+     -> return (signedZW tcNm args)++     | nameOcc tcNm == Text.showt ''U.Unsigned+     , [LitTy (NumTy 0)] <- args+     -> return (unsignedZW tcNm args)++     -- Any other zero-width type should only have a single data constructor+     -- where all fields are also zero-width.+     | otherwise+     -> do+       tc <- UniqMap.lookup tcNm tcm++       case tyConDataCons tc of+         [dc] -> do+           zwArgs <- traverse (zeroWidthTypeElem tcm) (dcArgTys dc)+           return (mkTmApps (Data dc) zwArgs)++         _ ->+           Nothing+ where+  nNm = mkUnsafeSystemName "n" 0+  nTv = mkTyVar typeNatKind nNm++  mkBitVector tcNm =+    let prTy = mkPolyFunTy (mkTyConApp tcNm [VarTy nTv])+                 [Left nTv, Right naturalPrimTy, Right naturalPrimTy, Right integerPrimTy]+     in PrimInfo (Text.showt 'BV.fromInteger#) prTy WorkNever SingleResult NoUnfolding++  bitVectorZW tcNm tyArgs =+    let pr = mkBitVector tcNm+     in mkApps (Prim pr) $ fmap Right tyArgs <>+          [ Left (Literal (NaturalLiteral 0))+          , Left (Literal (NaturalLiteral 0))+          , Left (Literal (IntegerLiteral 0))+          ]++  mkSizedNum tcNm n =+    let prTy = mkPolyFunTy (mkTyConApp tcNm [VarTy nTv])+                 [Left nTv, Right naturalPrimTy, Right integerPrimTy]+     in PrimInfo n prTy WorkNever SingleResult NoUnfolding++  indexZW tcNm tyArgs =+    let pr = mkSizedNum tcNm (Text.showt 'I.fromInteger#)+     in mkApps (Prim pr) $ fmap Right tyArgs <>+          [ Left (Literal (NaturalLiteral 1))+          , Left (Literal (IntegerLiteral 0))+          ]++  signedZW tcNm tyArgs =+    let pr = mkSizedNum tcNm (Text.showt 'S.fromInteger#)+     in mkApps (Prim pr) $ fmap Right tyArgs <>+          [ Left (Literal (NaturalLiteral 0))+          , Left (Literal (IntegerLiteral 0))+          ]++  unsignedZW tcNm tyArgs =+    let pr = mkSizedNum tcNm (Text.showt 'U.fromInteger#)+     in mkApps (Prim pr) $ fmap Right tyArgs <>+          [ Left (Literal (NaturalLiteral 0))+          , Left (Literal (IntegerLiteral 0))+          ]
+ src/Clash/Normalize/Transformations/XOptimize.hs view
@@ -0,0 +1,156 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd,+                    2017-2018, Google Inc.,+                    2021-2022, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  The X-optimization transformation.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Normalize.Transformations.XOptimize+  ( xOptimize+  ) where++import qualified Control.Lens as Lens+import qualified Control.Monad as Monad+import qualified Data.List.Extra as List+import qualified Data.Text.Extra as Text (showt)+import GHC.Stack (HasCallStack)++import Clash.XException (errorX)++import Clash.Annotations.Primitive (extractPrim)+import Clash.Core.DataCon (DataCon)+import Clash.Core.HasType+import Clash.Core.Term+  ( Alt, IsMultiPrim(..), LetBinding, Pat(..), PrimInfo(..), Term(..)+  , WorkInfo(..), collectArgs, PrimUnfolding(..))+import Clash.Core.Type (TyVar, Type)+import Clash.Core.Util (mkInternalVar)+import Clash.Core.Var (Id)+import Clash.Core.VarEnv (InScopeSet)+import Clash.Netlist.BlackBox.Types (Element(Err))+import Clash.Netlist.Types (BlackBox(..))+import Clash.Normalize.Types (NormRewrite, NormalizeSession)+import Clash.Primitives.Types (Primitive(..))+import Clash.Rewrite.Types+  (TransformContext(..), aggressiveXOpt, tcCache, primitives)+import Clash.Rewrite.Util (changed)+import Clash.Util (MonadUnique, curLoc)++-- | Remove all undefined alternatives from case expressions, replacing them+-- with the value of another defined alternative. If there is one defined+-- alternative, the entire expression is replaced with that alternative. If+-- there are no defined alternatives, the entire expression is replaced with+-- a call to 'errorX'.+--+-- e.g. It converts+--+--     case x of+--       D1 a -> f a+--       D2   -> undefined+--       D3   -> undefined+--+-- to+--+--     let subj = x+--         a    = case subj of+--                  D1 a -> field0+--      in f a+--+-- where fieldN is an internal variable referring to the nth argument of a+-- data constructor.+--+xOptimize :: HasCallStack => NormRewrite+xOptimize (TransformContext is0 _) e@(Case subj ty alts) = do+  runXOpt <- Lens.view aggressiveXOpt++  if runXOpt then do+    defPart <- List.partitionM (isPrimError . snd) alts++    case defPart of+      ([], _)    -> return e+      (_, [])    -> changed (Prim (PrimInfo (Text.showt 'errorX) ty WorkConstant SingleResult NoUnfolding))+      (_, [alt]) -> xOptimizeSingle is0 subj alt+      (_, defs)  -> xOptimizeMany is0 subj ty defs+  else+    return e++xOptimize _ e = return e+{-# SCC xOptimize #-}++-- Return an expression equivalent to the alternative given. When only one+-- alternative is defined the result of this function is used to replace the+-- case expression.+--+xOptimizeSingle :: InScopeSet -> Term -> Alt -> NormalizeSession Term+xOptimizeSingle is subj (DataPat dc tvs vars, expr) = do+  tcm    <- Lens.view tcCache+  subjId <- mkInternalVar is "subj" (inferCoreTypeOf tcm subj)++  let fieldTys = fmap coreTypeOf vars+  lets <- Monad.zipWithM (mkFieldSelector is subjId dc tvs fieldTys) vars [0..]++  changed (Letrec ((subjId, subj) : lets) expr)++xOptimizeSingle _ _ (_, expr) = changed expr++-- Given a list of alternatives which are defined, create a new case+-- expression which only ever returns a defined value.+--+xOptimizeMany+  :: HasCallStack+  => InScopeSet+  -> Term+  -> Type+  -> [Alt]+  -> NormalizeSession Term+xOptimizeMany is subj ty defs@(d:ds)+  | isAnyDefault defs = changed (Case subj ty defs)+  | otherwise = do+      newAlt <- xOptimizeSingle is subj d+      changed (Case subj ty $ ds <> [(DefaultPat, newAlt)])+ where+  isAnyDefault :: [Alt] -> Bool+  isAnyDefault = any ((== DefaultPat) . fst)++xOptimizeMany _ _ _ [] =+  error $ $(curLoc) ++ "Report as bug: xOptimizeMany error: No defined alternatives"++mkFieldSelector+  :: MonadUnique m+  => InScopeSet+  -> Id+  -- ^ subject id+  -> DataCon+  -> [TyVar]+  -> [Type]+  -- ^ concrete types of fields+  -> Id+  -> Int+  -> m LetBinding+mkFieldSelector is0 subj dc tvs fieldTys nm index = do+  fields <- mapM (\ty -> mkInternalVar is0 "field" ty) fieldTys+  let alt = (DataPat dc tvs fields, Var $ fields !! index)+  return (nm, Case (Var subj) (fieldTys !! index) [alt])++-- Check whether a term is really a black box primitive representing an error.+-- Such values are undefined and are removed in X Optimization.+--+isPrimError :: Term -> NormalizeSession Bool+isPrimError (collectArgs -> (Prim pInfo, _)) = do+  prim <- Lens.view (primitives . Lens.at (primName pInfo))++  case prim >>= extractPrim of+    Just p  -> return (isErr p)+    Nothing -> return False+ where+  isErr BlackBox{template=(BBTemplate [Err _])} = True+  isErr _ = False++isPrimError _ = return False
+ src/Clash/Normalize/Types.hs view
@@ -0,0 +1,78 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                         2017, Google Inc.+                         2022, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Types used in Normalize modules+-}++{-# LANGUAGE TemplateHaskell #-}++module Clash.Normalize.Types where++import qualified Control.Lens as Lens+import Control.Monad.State.Strict (State)+import Data.Map                   (Map)+import Data.Set                   (Set)+import Data.Text                  (Text)++import Clash.Core.Term        (Term)+import Clash.Core.Type        (Type)+import Clash.Core.Var         (Id)+import Clash.Core.VarEnv      (VarEnv)+import Clash.Driver.Types     (BindingMap)+import Clash.Rewrite.Types    (Rewrite, RewriteMonad)++-- | State of the 'NormalizeMonad'+data NormalizeState+  = NormalizeState+  { _normalized          :: BindingMap+  -- ^ Global binders+  , _specialisationCache :: Map (Id,Int,Either Term Type) Id+  -- ^ Cache of previously specialized functions:+  --+  -- * Key: (name of the original function, argument position, specialized term/type)+  --+  -- * Elem: (name of specialized function,type of specialized function)+  , _specialisationHistory :: VarEnv Int+  -- ^ Cache of how many times a function was specialized+  , _inlineHistory   :: VarEnv (VarEnv Int)+  -- ^ Cache of function where inlining took place:+  --+  -- * Key: function where inlining took place+  --+  -- * Elem: (functions which were inlined, number of times inlined)+  , _primitiveArgs :: Map Text (Set Int)+  -- ^ Cache for looking up constantness of blackbox arguments+  , _recursiveComponents :: VarEnv Bool+  -- ^ Map telling whether a components is recursively defined.+  --+  -- NB: there are only no mutually-recursive component, only self-recursive+  -- ones.+  }++Lens.makeLenses ''NormalizeState++-- | State monad that stores specialisation and inlining information+type NormalizeMonad = State NormalizeState++-- | RewriteSession with extra Normalisation information+type NormalizeSession = RewriteMonad NormalizeState++-- | A 'Transform' action in the context of the 'RewriteMonad' and 'NormalizeMonad'+type NormRewrite = Rewrite NormalizeState++-- | Description of a @Term@ in terms of the type "components" the @Term@ has.+--+-- Is used as a performance/size metric.+data TermClassification+  = TermClassification+  { _function   :: !Int -- ^ Number of functions+  , _primitive  :: !Int -- ^ Number of primitives+  , _selection  :: !Int -- ^ Number of selections/multiplexers+  }+  deriving Show++Lens.makeLenses ''TermClassification
+ src/Clash/Normalize/Util.hs view
@@ -0,0 +1,518 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2021-2024, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Utility functions used by the normalisation transformations+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++module Clash.Normalize.Util+ ( ConstantSpecInfo(..)+ , isConstantArg+ , shouldReduce+ , alreadyInlined+ , addNewInline+ , isRecursiveBndr+ , callGraph+ , collectCallGraphUniques+ , classifyFunction+ , isCheapFunction+ , isNonRecursiveGlobalVar+ , constantSpecInfo+ , normalizeTopLvlBndr+ , rewriteExpr+ , mkInlineTick+ , substWithTyEq+ , tvSubstWithTyEq+ )+ where++import           Control.Lens            ((&),(+~),(%=),(.=))+import qualified Control.Lens            as Lens+import           Data.Bifunctor          (bimap)+import           Data.Either             (lefts,rights)+import qualified Data.List               as List+import qualified Data.List.Extra         as List+import qualified Data.Map                as Map+import qualified Data.HashMap.Strict     as HashMapS+import qualified Data.HashSet            as HashSet+import           Data.Text               (Text)+import qualified Data.Text as Text+import qualified Data.Text.Extra as Text++import           GHC.Builtin.Names       (eqTyConKey)++import           Clash.Annotations.Primitive (extractPrim)+import           Clash.Core.FreeVars+  (globalIds, globalIdOccursIn)+import           Clash.Core.HasFreeVars  (isClosed)+import           Clash.Core.HasType+import           Clash.Core.Name         (Name(nameOcc,nameUniq))+import           Clash.Core.Pretty       (showPpr)+import           Clash.Core.Subst+  (deShadowTerm, extendTvSubst, mkSubst, substTm, substTy,+   substId, extendIdSubst)+import           Clash.Core.Term+import           Clash.Core.Type+  (Type(ForAllTy,LitTy, VarTy), LitTy(SymTy), TypeView (..), tyView,+   splitTyConAppM, mkPolyFunTy)+import           Clash.Core.Util+  (isClockOrReset)+import           Clash.Core.Var          (Id, TyVar, Var (..), isGlobalId)+import           Clash.Core.VarEnv+  (VarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, extendVarEnvWith,+   lookupVarEnv, unionVarEnvWith, unitVarEnv, extendInScopeSetList, mkInScopeSet, mkVarSet)+import qualified Clash.Data.UniqMap as UniqMap+import           Clash.Debug             (traceIf)+import           Clash.Driver.Types+  (BindingMap, Binding(..), TransformationInfo(FinalTerm), hasTransformationInfo)+import           Clash.Normalize.Primitives (removedArg)+import {-# SOURCE #-} Clash.Normalize.Strategy (normalization)+import           Clash.Normalize.Types+import           Clash.Primitives.Util   (constantArgs)+import           Clash.Rewrite.Types+  (RewriteMonad, TransformContext(..), bindings, curFun, debugOpts, extra,+   tcCache, primitives)+import           Clash.Rewrite.Util+  (runRewrite, mkTmBinderFor, mkDerivedName)+import           Clash.Unique+import           Clash.Util              (SrcSpan, makeCachedU)++-- | Determine if argument should reduce to a constant given a primitive and+-- an argument number. Caches results.+isConstantArg+  :: Text+  -- ^ Primitive name+  -> Int+  -- ^ Argument number+  -> RewriteMonad NormalizeState Bool+  -- ^ Yields @DontCare@ for if given primitive name is not found, if the+  -- argument does not exist, or if the argument was not mentioned by the+  -- blackbox.+isConstantArg "Clash.Explicit.SimIO.mealyIO" i = pure (i == 2 || i == 3)+isConstantArg nm i = do+  argMap <- Lens.use (extra.primitiveArgs)+  case Map.lookup nm argMap of+    Nothing -> do+      -- Constant args not yet calculated, or primitive does not exist+      prims <- Lens.view primitives+      case extractPrim =<< HashMapS.lookup nm prims of+        Nothing ->+          -- Primitive does not exist:+          pure False+        Just p -> do+          -- Calculate constant arguments:+          let m = constantArgs nm p+          (extra.primitiveArgs) Lens.%= Map.insert nm m+          pure (i `elem` m)+    Just m ->+      -- Cached version found+      pure (i `elem` m)++-- | Given a list of transformation contexts, determine if any of the contexts+-- indicates that the current arg is to be reduced to a constant / literal.+shouldReduce+  :: Context+  -- ^ ..in the current transformcontext+  -> RewriteMonad NormalizeState Bool+shouldReduce = List.anyM isConstantArg'+  where+    isConstantArg' (AppArg (Just (nm, _, i))) = isConstantArg nm i+    isConstantArg' _ = pure False++-- | Determine if a function is already inlined in the context of the 'NetlistMonad'+alreadyInlined+  :: Id+  -- ^ Function we want to inline+  -> Id+  -- ^ Function in which we want to perform the inlining+  -> NormalizeMonad (Maybe Int)+alreadyInlined f cf = do+  inlinedHM <- Lens.use inlineHistory+  case lookupVarEnv cf inlinedHM of+    Nothing       -> return Nothing+    Just inlined' -> return (lookupVarEnv f inlined')++-- | Record a new inlining in the `inlineHistory`+addNewInline+  :: Id+  -- ^ Function we're inlining+  -> Id+  -- ^ Function in which we're inlining it+  -> NormalizeMonad ()+addNewInline f cf =+  inlineHistory %= extendVarEnvWith+                     cf+                     (unitVarEnv f 1)+                     (\_ hm -> extendVarEnvWith f 1 (+) hm)++-- | Test whether a given term represents a non-recursive global variable+isNonRecursiveGlobalVar+  :: Term+  -> NormalizeSession Bool+isNonRecursiveGlobalVar (collectArgs -> (Var i, _args)) = do+  let eIsGlobal = isGlobalId i+  eIsRec    <- isRecursiveBndr i+  return (eIsGlobal && not eIsRec)+isNonRecursiveGlobalVar _ = return False++-- | Assert whether a name is a reference to a recursive binder.+isRecursiveBndr+  :: Id+  -> NormalizeSession Bool+isRecursiveBndr f = do+  cg <- Lens.use (extra.recursiveComponents)+  case lookupVarEnv f cg of+    Just isR -> return isR+    Nothing -> do+      fBodyM <- lookupVarEnv f <$> Lens.use bindings+      case fBodyM of+        Nothing -> return False+        Just b -> do+          -- There are no global mutually-recursive functions, only self-recursive+          -- ones, so checking whether 'f' is part of the free variables of the+          -- body of 'f' is sufficient.+          let isR = f `globalIdOccursIn` bindingTerm b+          (extra.recursiveComponents) %= extendVarEnv f isR+          return isR++data ConstantSpecInfo =+  ConstantSpecInfo+    { csrNewBindings :: [(Id, Term)]+    -- ^ New let-bindings to be created for all the non-constants found+    , csrNewTerm :: !Term+    -- ^ A term where all the non-constant constructs are replaced by variable+    -- references (found in 'csrNewBindings')+    , csrFoundConstant :: !Bool+    -- ^ Whether the algorithm found a constant at all. (If it didn't, it's no+    -- use creating any new let-bindings!)+    } deriving (Show)++-- | Indicate term is fully constant (don't bind anything)+constantCsr :: Term -> ConstantSpecInfo+constantCsr t = ConstantSpecInfo [] t True++-- | Bind given term to a new variable and indicate that it's fully non-constant+bindCsr+  :: TransformContext+  -> Term+  -> RewriteMonad NormalizeState ConstantSpecInfo+bindCsr ctx@(TransformContext is0 _) oldTerm = do+  -- TODO: Seems like the need to put global ids in scope has been made obsolete+  -- TODO: by a recent change in Clash. Investigate whether this is true.+  tcm <- Lens.view tcCache+  newId <- mkTmBinderFor is0 tcm (mkDerivedName ctx "bindCsr") oldTerm+  pure (ConstantSpecInfo+    { csrNewBindings = [(newId, oldTerm)]+    , csrNewTerm = Var newId+    , csrFoundConstant = False+    })++mergeCsrs+  :: TransformContext+  -> [TickInfo]+  -- ^ Ticks to wrap around proposed new term+  -> Term+  -- ^ \"Old\" term+  -> ([Either Term Type] -> Term)+  -- ^ Proposed new term in case any constants were found+  -> [Either Term Type]+  -- ^ Subterms+  -> RewriteMonad NormalizeState ConstantSpecInfo+mergeCsrs ctx ticks oldTerm proposedTerm subTerms = do+  subCsrs <- snd <$> List.mapAccumLM constantSpecInfoFolder ctx subTerms++  -- If any arguments are constant (and hence can be constant specced), a new+  -- term is created with these constants left in, but variable parts let-bound.+  -- There's one edge case: whenever a term has _no_ arguments. This happens for+  -- constructors without fields, or -depending on their WorkInfo- primitives+  -- without args. We still set 'csrFoundConstant', because we know the newly+  -- proposed term will be fully constant.+  let+    anyArgsOrResultConstant =+      null (lefts subCsrs) || any csrFoundConstant (lefts subCsrs)++  if anyArgsOrResultConstant then+    let newTerm = proposedTerm (bimap csrNewTerm id <$> subCsrs)  in+    pure (ConstantSpecInfo+      { csrNewBindings = concatMap csrNewBindings (lefts subCsrs)+      , csrNewTerm = mkTicks newTerm ticks+      , csrFoundConstant = True+      })+  else do+    -- No constructs were found to be constant, so we might as well refer to the+    -- whole thing with a new let-binding (instead of creating a number of+    -- "smaller" let-bindings)+    bindCsr ctx oldTerm++ where+  constantSpecInfoFolder+    :: TransformContext+    -> Either Term Type+    -> RewriteMonad NormalizeState (TransformContext, Either ConstantSpecInfo Type)+  constantSpecInfoFolder localCtx (Right typ) =+    pure (localCtx, Right typ)+  constantSpecInfoFolder localCtx@(TransformContext is0 tfCtx) (Left term) = do+    specInfo <- constantSpecInfo localCtx term+    let newIds = map fst (csrNewBindings specInfo)+    let is1 = extendInScopeSetList is0 newIds+    pure (TransformContext is1 tfCtx, Left specInfo)+++-- | Calculate constant spec info. The goal of this function is to analyze a+-- given term and yield a new term that:+--+--  * Leaves all the constant parts as they were.+--  * Has all _variable_ parts replaced by a newly generated identifier.+--+-- The result structure will additionally contain:+--+--  * Whether the function found any constant parts at all+--  * A list of let-bindings binding the aforementioned identifiers with+--    the term they replaced.+--+-- This can be used in functions wanting to constant specialize over+-- partially constant data structures.+constantSpecInfo+  :: TransformContext+  -> Term+  -> RewriteMonad NormalizeState ConstantSpecInfo+constantSpecInfo ctx e = do+  tcm <- Lens.view tcCache+  -- Don't constant spec clocks or resets, they're either:+  --+  --  * A simple wire (Var), therefore not interesting to spec+  --  * A clock/reset generator, and speccing a generator weirds out HDL simulators.+  --+  -- I believe we can remove this special case in the future by looking at the+  -- primitive's workinfo.+  if isClockOrReset tcm (inferCoreTypeOf tcm e) then+    case collectArgs e of+      (Prim p, _)+        | primName p == Text.showt 'removedArg ->+          pure (constantCsr e)+      _ -> bindCsr ctx e+  else+    case collectArgsTicks e of+      (dc@(Data _), args, ticks) ->+        mergeCsrs ctx ticks e (mkApps dc) args++      -- TODO: Work with prim's WorkInfo?+      (prim@(Prim _), args, ticks) -> do+        csr <- mergeCsrs ctx ticks e (mkApps prim) args+        if null (csrNewBindings csr) then+          pure csr+        else+          bindCsr ctx e++      (Lam _ _, _, _ticks) ->+        if not (isClosed e) then+          bindCsr ctx e+        else+          pure (constantCsr e)++      (var@(Var f), args, ticks) -> do+        (curF, _) <- Lens.use curFun+        isNonRecGlobVar <- isNonRecursiveGlobalVar e+        if isNonRecGlobVar && f /= curF then do+          csr <- mergeCsrs ctx ticks e (mkApps var) args+          if null (csrNewBindings csr) then+            pure csr+          else+            bindCsr ctx e+        else+          bindCsr ctx e++      (Literal _,_, _ticks) ->+        pure (constantCsr e)++      _ ->+        bindCsr ctx e++-- | A call graph counts the number of occurrences that a functions 'g' is used+-- in 'f'.+type CallGraph = VarEnv (VarEnv Word)++-- | Collect all binders mentioned in CallGraph into a HashSet+collectCallGraphUniques :: CallGraph -> HashSet.HashSet Unique+collectCallGraphUniques cg = HashSet.fromList (us0 ++ us1)+ where+  us0 = UniqMap.keys cg+  us1 = concatMap UniqMap.keys (UniqMap.elems cg)++-- | Create a call graph for a set of global binders, given a root+callGraph+  :: BindingMap+  -> Id+  -> CallGraph+callGraph bndrs rt = go emptyVarEnv (varUniq rt)+  where+    go cg root+      | Nothing     <- UniqMap.lookup root cg+      , Just rootTm <- UniqMap.lookup root bndrs =+      let used = Lens.foldMapByOf globalIds (unionVarEnvWith (+))+                  emptyVarEnv (`UniqMap.singleton` 1) (bindingTerm rootTm)+          cg'  = UniqMap.insert root used cg+      in  List.foldl' go cg' (UniqMap.keys used)+    go cg _ = cg++-- | Give a "performance/size" classification of a function in normal form.+classifyFunction+  :: Term+  -> TermClassification+classifyFunction = go (TermClassification 0 0 0)+  where+    go !c (Lam _ e)     = go c e+    go !c (TyLam _ e)   = go c e+    go !c (Letrec bs _) = List.foldl' go c (map snd bs)+    go !c e@(App {}) = case fst (collectArgs e) of+      Prim {} -> c & primitive +~ 1+      Var {}  -> c & function +~ 1+      _ -> c+    go !c (Case _ _ alts) = case alts of+      (_:_:_) -> c & selection  +~ 1+      _ -> c+    go !c (Tick _ e) = go c e+    go c _ = c++-- | Determine whether a function adds a lot of hardware or not.+--+-- It is considered expensive when it has 2 or more of the following components:+--+-- * functions+-- * primitives+-- * selections (multiplexers)+isCheapFunction+  :: Term+  -> Bool+isCheapFunction tm = case classifyFunction tm of+  TermClassification {..}+    | _function  <= 1 -> _primitive <= 0 && _selection <= 0+    | _primitive <= 1 -> _function  <= 0 && _selection <= 0+    | _selection <= 1 -> _function  <= 0 && _primitive <= 0+    | otherwise       -> False++normalizeTopLvlBndr+  :: Bool+  -> Id+  -> Binding Term+  -> NormalizeSession (Binding Term)+normalizeTopLvlBndr isTop nm (Binding nm' sp inl pr tm _) = makeCachedU nm (extra.normalized) $ do+  tcm <- Lens.view tcCache+  let nmS = showPpr (varName nm)+  -- We deshadow the term because sometimes GHC gives us+  -- code where a local binder has the same unique as a+  -- global binder, sometimes causing the inliner to go+  -- into a loop. Deshadowing freshens all the bindings+  -- to avoid this.+  let tm1 = deShadowTerm emptyInScopeSet tm+      tm2 = if isTop then substWithTyEq tm1 else tm1+  old <- Lens.use curFun+  tm3 <- rewriteExpr ("normalization",normalization) (nmS,tm2) (nm',sp)+  curFun .= old+  let ty' = inferCoreTypeOf tcm tm3+  let r' = nm' `globalIdOccursIn` tm3+  return (Binding nm'{varType = ty'} sp inl pr tm3 r')++-- | Turn type equality constraints into substitutions and apply them.+--+-- So given:+--+-- > /\dom . \(eq : dom ~ "System") . \(eta : Signal dom Bool) . eta+--+-- we create the substitution [dom := "System"] and apply it to create:+--+-- > \(eq : "System" ~ "System") . \(eta : Signal "System" Bool) . eta+--+-- __NB:__ Users of this function should ensure it's only applied to TopEntities+substWithTyEq+  :: Term+  -> Term+substWithTyEq e0 = go [] False e0+ where+  go+    :: [Either Id TyVar]+    -> Bool+    -> Term+    -> Term+  go args changed (TyLam tv e) = go (Right tv : args) changed e+  go args changed (Lam v e)+    | TyConApp (nameUniq -> tcUniq) (tvFirst -> Just (tv, ty)) <- tyView (coreTypeOf v)+    , tcUniq == fromGhcUnique eqTyConKey+    , Right tv `elem` args+    = let+        tvs = rights args+        subst0 = extendTvSubst (mkSubst $ mkInScopeSet $ mkVarSet tvs) tv ty+        removedTy = substTy subst0 $ coreTypeOf v+        subst1 = extendIdSubst subst0 v (TyApp (Prim removedArg) removedTy)+      in go (Left (substId subst0 v) : (args List.\\ [Right tv])) True (substTm "substWithTyEq e" subst1 e)+    | otherwise = go (Left v : args) changed e+  go args True e = mkAbstraction e (reverse args)+  go _ False _ = e0++-- Type equality (~) is symmetrical, so users could write: (dom ~ System) or (System ~ dom)+tvFirst :: [Type] -> Maybe (TyVar, Type)+tvFirst [_, VarTy tv, ty] = Just (tv, ty)+tvFirst [_, ty, VarTy tv] = Just (tv, ty)+tvFirst _ = Nothing++-- | The type equivalent of 'substWithTyEq'+tvSubstWithTyEq+  :: Type+  -> Type+tvSubstWithTyEq ty0 = go [] False ty0+ where+  go :: [Either TyVar Type] -> Bool -> Type -> Type+  go argsOut changed (ForAllTy tv ty)+    = go (Left tv:argsOut) changed ty+  go argsOut changed (tyView -> FunTy arg tyRes)+    | Just (tc,tcArgs) <- splitTyConAppM arg+    , nameUniq tc == fromGhcUnique eqTyConKey+    , Just (tv,ty) <- tvFirst tcArgs+    = let+        argsOut2 = Right arg : (argsOut List.\\ [Left tv])+        subst = extendTvSubst (mkSubst $ mkInScopeSet $ mkVarSet $ lefts argsOut2) tv ty+      in go argsOut2 True  (substTy subst tyRes)+    | otherwise = go (Right arg : argsOut) changed tyRes+  go _ False _ = ty0 -- no eq constraints, returning original type+  go argsOut True tyRes = mkPolyFunTy tyRes (reverse argsOut)++-- | Rewrite a term according to the provided transformation+rewriteExpr :: (String,NormRewrite) -- ^ Transformation to apply+            -> (String,Term)        -- ^ Term to transform+            -> (Id, SrcSpan)        -- ^ Renew current function being rewritten+            -> NormalizeSession Term+rewriteExpr (nrwS,nrw) (bndrS,expr) (nm, sp) = do+  curFun .= (nm, sp)+  opts <- Lens.view debugOpts+  let before = showPpr expr+  let expr' = traceIf (hasTransformationInfo FinalTerm opts)+                (bndrS ++ " before " ++ nrwS ++ ":\n\n" ++ before ++ "\n")+                expr+  rewritten <- runRewrite nrwS emptyInScopeSet nrw expr'+  let after = showPpr rewritten+  traceIf (hasTransformationInfo FinalTerm opts)+    (bndrS ++ " after " ++ nrwS ++ ":\n\n" ++ after ++ "\n") $+    return rewritten++-- | A tick to prefix an inlined expression with it's original name.+-- For example, given+--+--     foo = bar  -- ...+--     bar = baz  -- ...+--     baz = quuz -- ...+--+-- if bar is inlined into foo, then the name of the component should contain+-- the name of the inlined component. This tick ensures that the component in+-- foo is called bar_baz instead of just baz.+--+mkInlineTick :: Id -> TickInfo+mkInlineTick n = NameMod PrefixName (LitTy . SymTy $ toStr n)+ where+  toStr = Text.unpack . snd . Text.breakOnEnd "." . nameOcc . varName
+ src/Clash/Pretty.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}++module Clash.Pretty where++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter+import Prettyprinter.Render.String+#else+import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Render.String+#endif++import Data.Maybe (fromMaybe)+import qualified System.Console.Terminal.Size as Terminal+import System.Environment (lookupEnv)+import System.IO.Unsafe (unsafePerformIO)+import Text.Read (readMaybe)+import qualified Clash.Util.Interpolate as I+import GHC.Stack (HasCallStack)++unsafeLookupEnvWord :: HasCallStack => String -> Word -> Word+unsafeLookupEnvWord key dflt =+  case unsafePerformIO (lookupEnv key) of+    Nothing -> dflt+    Just w -> flip fromMaybe (readMaybe w) $ error [I.i|+      'unsafeLookupEnvWord' tried to lookup #{key} in the environment. It found+      it, but couldn't interpret it to as a Word (positive Int). Found:++        #{w}+    |]++defaultPprWidth :: Int+defaultPprWidth =+  let dflt = max 80 (maybe 80 Terminal.width (unsafePerformIO Terminal.size)) in+  fromIntegral (unsafeLookupEnvWord "CLASH_PPR_WIDTH" dflt)++showDoc :: Doc ann -> String+showDoc =+  let layoutOpts = LayoutOptions (AvailablePerLine defaultPprWidth 0.6) in+  renderString . layoutPretty layoutOpts++removeAnnotations :: Doc ann -> Doc ()+removeAnnotations = reAnnotate $ const ()++-- | A variant of @Pretty@ that is not polymorphic on the type of annotations.+-- This is needed to derive instances from Clash's pretty printer (PrettyPrec),+-- which annotates documents with Clash-specific information and, therefore,+-- fixes the type of annotations.+class ClashPretty a where+  clashPretty :: a -> Doc ()++fromPretty :: Pretty a => a -> Doc ()+fromPretty = removeAnnotations . pretty
+ src/Clash/Primitives/Annotations/SynthesisAttributes.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Primitives.Annotations.SynthesisAttributes where++import Prelude++import Control.Monad.State (State)+import Data.Either (lefts, rights)+import Data.List.Infinite((...), Infinite((:<)))+import Data.Proxy (Proxy(..))+import Data.Text (Text)+import Data.Text.Prettyprint.Doc.Extra (Doc)+import GHC.Stack (HasCallStack)+import GHC.TypeLits (someNatVal)+import GHC.TypeNats (KnownNat, SomeNat(..))+import Text.Show.Pretty (ppShow)++import qualified Control.Lens as Lens+import qualified Data.Text as T++import Clash.Annotations.SynthesisAttributes+import Clash.Backend (Backend)+import Clash.Core.TermLiteral (termToDataError)+import Clash.Core.Type (Type(LitTy), LitTy(NumTy), coreView)+import Clash.Netlist.BlackBox.Types+import Clash.Netlist.Types+import Clash.Sized.Vector (Vec, toList)++import qualified Clash.Primitives.DSL as DSL++usedArguments :: [Int]+usedArguments = [attrs, signal]+ where+  attrs :< signal :< _ = (0...)++annotateBBF :: HasCallStack => BlackBoxFunction+annotateBBF _isD _primName args _resTys = Lens.view tcCache >>= go+ where+  go tcm+    | ((coreView tcm -> LitTy (NumTy n)) : _) <- rights args+    , Just (SomeNat (Proxy :: Proxy n)) <- someNatVal n+    , (attrs0 : _) <- lefts args+    = case termToDataError attrs0 of+        Left msg -> error msg+        Right attrs1 -> pure $ Right (bbMeta, bb @n (fmap T.pack <$> attrs1))+  go _ = error $ "Unexpected args:\n " <> ppShow args++  bbMeta :: BlackBoxMeta+  bbMeta = emptyBlackBoxMeta{bbKind = TDecl}++  bb :: KnownNat n => Vec n (Attr Text) -> BlackBox+  bb attrs = BBFunction (show 'annotateTF) 0 (annotateTF attrs)++annotateTF :: HasCallStack => KnownNat n => Vec n (Attr Text) -> TemplateFunction+annotateTF attrs = TemplateFunction usedArguments (const True) (annotateBBTF attrs)++annotateBBTF ::+  (Backend s, KnownNat n, HasCallStack) =>+  Vec n (Attr Text) ->+  BlackBoxContext ->+  State s Doc+annotateBBTF attrs0 bbCtx+  | (_attrs : signal0 : _) <- map fst $ DSL.tInputs bbCtx+  = DSL.declarationReturn bbCtx "annotate_block" $ do+      let+        attrs1 = toList attrs0+        signal1ty = Annotated attrs1 (DSL.ety signal0)+        signal1 = DSL.TExpr{DSL.eex=DSL.eex signal0, DSL.ety=signal1ty}+      resultExpr <- DSL.assign (getSignalName (bbCtxName bbCtx)) signal1+      pure [resultExpr]+ where+  -- Return user-friendly name given a context name hint.+  getSignalName :: Maybe T.Text -> T.Text+  getSignalName Nothing = "result"+  getSignalName (Just "__VOID_TDECL_NOOP__") = getSignalName Nothing+  getSignalName (Just s) = s++annotateBBTF _attrs bbCtx = error $ "Unexpected context:\n " <> ppShow bbCtx
+ src/Clash/Primitives/DSL.hs view
@@ -0,0 +1,1138 @@+{-|+  Copyright   :  (C) 2019,      Myrtle Software Ltd.+                     2020-2026, QBayLogic B.V.+                     2021,      Myrtle.ai+                     2022-2023, Google Inc+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++This module contains a mini dsl for creating haskell blackbox+instantiations.+-}++{-# LANGUAGE CPP               #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms   #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE ViewPatterns      #-}++module Clash.Primitives.DSL+  (+  -- * Annotations+    BlackBoxHaskellOpts(..)+  , blackBoxHaskell++  -- * Declarations+  , BlockState (..)+  , TExpr(..)+  , addDeclaration+  , assign+  , compInBlock+  , declaration+  , declarationReturn+  , declare+  , declareN+  , instDecl+  , instHO+  , viaAnnotatedSignal++  -- ** Literals+  , bvLit+  , LitHDL (..)+  , pattern High+  , pattern Low+  , constructProduct+  , tuple+  , vec++  -- ** Extraction+  , tInputs+  , tResults+  , getStr+  , getBool+  , getVec+  , exprToInteger+  , tExprToInteger+  , deconstructProduct+  , untuple+  , unvec+  , deconstructMaybe++  -- ** Conversion+  , bitCoerce+  , toBV+  , toBvWithAttrs+  , fromBV+  , enableToBit+  , boolToBit+  , boolFromBit+  , boolFromBitVector+  , unsignedFromBitVector+  , boolFromBits++  , unsafeToActiveHigh+  , unsafeToActiveLow++  -- ** Operations+  , andExpr+  , notExpr+  , pureToBV+  , pureToBVResized+  , open++  -- ** Utilities+  , clog2+  , litTExpr+  , toIdentifier+  , tySize+  ) where++import           Control.Lens                    hiding (Indexed, assign)+import           Control.Exception               (throw)+import           Control.Monad                   (forM, forM_, zipWithM)+import           Control.Monad.State+import           Data.Default                    (Default(def))+import           Data.IntMap                     (IntMap)+import qualified Data.IntMap                     as IntMap+import           Data.List                       (intersperse)+import           Data.List.Extra                 (zipEqual)+import           Data.Maybe                      (fromMaybe)+import           Data.Monoid                     (Ap(getAp))+import           Data.Semigroup                  hiding (Product)+import           Data.String+import           Data.Text                       (Text)+import qualified Data.Text                       as Text+import           Data.Text.Extra                 (showt)+import           Data.Text.Prettyprint.Doc.Extra+import           GHC.Stack                       (HasCallStack)++import           Clash.Annotations.Primitive     (HDL (..), Primitive (..))+import           Clash.Annotations.SynthesisAttributes (Attr)+import           Clash.Backend                   hiding (Usage, fromBV, toBV)+import           Clash.Backend.VHDL              (VHDLState)+import           Clash.Explicit.Signal           (ResetPolarity(..), vResetPolarity)+import           Clash.Netlist.BlackBox.Util+  (exprToString, getDomainConf, lookupFunctionInstantiation, renderElem)+import           Clash.Netlist.BlackBox.Types+  (BlackBoxTemplate, Element(Component, Text), Decl(..))+import qualified Clash.Netlist.Id                as Id+import           Clash.Netlist.Types             hiding (Component, toBit)+import           Clash.Netlist.Util+import           Clash.Util                      (ClashException(..), clogBase, curLoc)+import qualified Data.String.Interpolate         as I+import qualified Language.Haskell.TH             as TH+import qualified Language.Haskell.TH.Syntax      as TH+import           Prelude++-- | Options for 'blackBoxHaskell' function. Use 'def' from package+-- 'data-default' for a set of default options.+data BlackBoxHaskellOpts = BlackBoxHaskellOpts+  { -- | Arguments to ignore (i.e., remove during normalization)+    --+    -- Default: []+    bo_ignoredArguments :: [Int]++    -- | HDLs to use the blackbox for+    --+    -- Default: all+  , bo_supportedHdls :: [HDL]++    -- | Does this blackbox assign its results to multiple binders?+    --+    -- Default: False.+  , bo_multiResult :: Bool+  }++instance Default BlackBoxHaskellOpts where+  def = BlackBoxHaskellOpts+    { bo_ignoredArguments = []+    , bo_supportedHdls = [minBound..maxBound]+    , bo_multiResult = False+    }++-- | Create a blackBoxHaskell primitive. To be used as part of an annotation:+--+-- @+-- {-\# ANN myFunction (blackBoxHaskell 'myFunction 'myBBF def{bo_ignoredArguments=[1,2]}) \#-}+-- @+--+-- @[1,2]@ would mean this blackbox __ignores__ its second and third argument.+blackBoxHaskell+  :: TH.Name+  -- ^ blackbox name+  -> TH.Name+  -- ^ template function name+  -> BlackBoxHaskellOpts+  -- ^ Options, see data structure for more information+  -> Primitive+blackBoxHaskell bb tf BlackBoxHaskellOpts{..} =+  InlineYamlPrimitive bo_supportedHdls [I.__i|+    BlackBoxHaskell:+      name: #{bb}+      templateFunction: #{tf}+      ignoredArguments : #{bo_ignoredArguments}+      multiResult : #{toYamlBool bo_multiResult}+    |]+ where+  toYamlBool :: Bool -> String+  toYamlBool True = "true"+  toYamlBool False = "false"++-- | The state of a block. Contains a list of declarations and a the+--   backend state.+data BlockState backend = BlockState+  { _bsDeclarations :: [Declaration]+    -- ^ Declarations store+  , _bsHigherOrderCalls :: IntMap Int+    -- ^ Tracks how many times a higher order function has been instantiated.+    -- Needed to fill in the second field of 'Clash.Netlist.BlackBox.Types.Decl'+  , _bsBackend :: backend+    -- ^ Backend state+  }+makeLenses ''BlockState++instance Backend backend => HasIdentifierSet (BlockState backend) where+  identifierSet :: Lens' (BlockState backend) IdentifierSet+  identifierSet = bsBackend . identifierSet++instance HasUsageMap backend => HasUsageMap (BlockState backend) where+  usageMap = bsBackend.usageMap++liftToBlockState+  :: forall backend a. Backend backend+   => State backend a -> State (BlockState backend) a+liftToBlockState (StateT f) = StateT g+ where+  g :: BlockState backend -> Identity (a, BlockState backend)+  g sbsIn = do+    let sIn = _bsBackend sbsIn+    (res,sOut) <- f sIn+    pure (res, sbsIn{_bsBackend = sOut})++-- | A typed expression.+data TExpr = TExpr+  { ety :: HWType+  , eex :: Expr+  } deriving Show+makeLenses ''TExpr++-- | Run a block declaration. Assign the result of the block builder to the+-- result variable in the given blackbox context.+declarationReturn+  :: Backend backend+  => BlackBoxContext+  -> Text.Text+  -- ^ block name+  -> State (BlockState backend) [TExpr]+  -- ^ block builder yielding an expression that should be assigned to the+  -- result variable in the blackbox context+  -> State backend Doc+  -- ^ pretty printed block+declarationReturn bbCtx blockName blockBuilder =+  declaration blockName $ do+    res <- blockBuilder+    forM_ (zip (bbResults bbCtx) res) $ \(rNm, r) -> case rNm of+      (Identifier resultNm Nothing, _) ->+        addDeclaration (Assignment resultNm Cont (eex r))+      (t,_) -> error ("declarationReturn expected an Identifier, but got: " <> show t)+++emptyBlockState :: backend -> BlockState backend+emptyBlockState bck = BlockState+  { _bsDeclarations = []+  , _bsHigherOrderCalls = IntMap.empty+  , _bsBackend = bck+  }++-- | Run a block declaration.+declaration+  :: Backend backend+  => Text.Text+  -- ^ block name+  -> State (BlockState backend) ()+  -- ^ block builder+  -> State backend Doc+  -- ^ pretty printed block+declaration blockName c = do+  backend0 <- get+  let initState = emptyBlockState backend0+      (BlockState {..}) = execState c initState+  put _bsBackend+  blockNameUnique <- Id.makeBasic blockName+  getAp $ blockDecl blockNameUnique (reverse _bsDeclarations)++-- | Add a declaration to the state.+addDeclaration :: Declaration -> State (BlockState backend) ()+addDeclaration dec = bsDeclarations %= cons dec++-- | Declare a new signal with the given name and type.+declare'+  :: Backend backend+  => Text+  -- ^ Name hint+  -> HWType+  -- ^ Type of new signal+  -> State (BlockState backend) Identifier+  -- ^ Expression pointing the the new signal+declare' decName ty = do+  uniqueName <- Id.makeBasic decName+  addDeclaration (NetDecl' Nothing uniqueName ty Nothing)+  pure uniqueName++-- | Declare a new signal with the given name and type.+declare+  :: Backend backend+  => Text+  -- ^ Name hint+  -> HWType+  -- ^ Type of new signal+  -> State (BlockState backend) TExpr+  -- ^ Expression pointing the the new signal+declare decName ty = do+  uniqueName <- declare' decName ty+  pure (TExpr ty (Identifier uniqueName Nothing))++-- | Declare /n/ new signals with the given type and based on the given name+declareN+  :: Backend backend+  => Text+  -- ^ Name hint+  -> [HWType]+  -- ^ Types of the signals+  -> State (BlockState backend) [TExpr]+  -- ^ Expressions pointing the the new signals+declareN decName tys = do+  firstName <- Id.makeBasic decName+  nextNames <- Id.nextN (length tys - 1) firstName+  let uniqueNames = firstName : nextNames+  zipWithM+    (\uniqueName ty -> do+      addDeclaration $ NetDecl' Nothing uniqueName ty Nothing+      pure $ TExpr ty (Identifier uniqueName Nothing)+    ) uniqueNames tys++-- | Assign an expression to an identifier, returns the new typed+--   identifier expression.+assign+  :: Backend backend+  => Text+  -- ^ Name hint for assignment+  -> TExpr+  -- ^ expression to be assigned to freshly generated identifier+  -> State (BlockState backend) TExpr+  -- ^ the identifier of the expression that actually got assigned+assign aName (TExpr ty aExpr) = do+  texp <- declare aName ty+  let uniqueName = case texp of+        TExpr _ (Identifier x Nothing) -> x+        t' -> error ("assign expected an Identifier, but got: " <> show t')++  addDeclaration (Assignment uniqueName Cont aExpr)+  pure texp++-- | Extract the elements of a vector expression and return expressions+-- to them. If given expression is not an identifier, an intermediate variable+-- will be used to assign the given expression to which is subsequently indexed.+unvec+  :: (HasCallStack, Backend backend)+  => Text+  -- ^ Name hint for intermediate signal+  -> TExpr+  -- ^ Vector expression+  -> State (BlockState backend) [TExpr]+  -- ^ Vector elements+unvec vName v@(ety -> Vector vSize eType) = do+  texp <- toIdentifier vName v+  let vUniqueName = case texp of+        TExpr _ (Identifier x Nothing) -> x+        t' -> error ("unvec expected an Identifier, but got: " <> show t')++  let vIndex i = Identifier vUniqueName (Just (Indexed (ety v, 10, i)))+  pure (map (TExpr eType . vIndex) [0..vSize-1])+unvec _ e = error $ "unvec: cannot be called on non-vector: " <> show (ety e)++-- | Deconstruct a 'Maybe' into its constructor 'Bit' and contents of its 'Just'+-- field. Note that the contents might be undefined, if the constructor bit is+-- set to 'Nothing'.+deconstructMaybe ::+  (HasCallStack, Backend backend) =>+  -- | Maybe expression+  TExpr ->+  -- | Name hint for constructor bit, data+  (Text, Text) ->+  -- | Constructor represented as a Bit, contents of Just+  State (BlockState backend) (TExpr, TExpr)+deconstructMaybe e@TExpr{ety} (bitName, contentName)+  | SP tyName [(_nothing, []),(_just, [aTy])] <- ety+  , tyName == fromString (show ''Maybe)+  = do+    eBv <- toBV (bitName <> "_and_" <> contentName <> "_bv") e+    eId <- toIdentifier' (bitName <> "_and_" <> contentName) eBv+    let eSize = typeSize ety++    bitExpr <- fromBV bitName Bit TExpr+      { eex = Identifier eId (Just (Sliced (BitVector eSize, eSize - 1, eSize - 1)))+      , ety = BitVector 1+      }++    contentExpr <- fromBV contentName aTy TExpr+      { eex = Identifier eId (Just (Sliced (BitVector eSize, eSize - 1 - 1, 0)))+      , ety = BitVector (eSize - 1)+      }++    pure (bitExpr, contentExpr)++deconstructMaybe e _ =+  error $ "deconstructMaybe: cannot be called on non-Maybe: " <> show (ety e)++-- | Extract the fields of a product type and return expressions+--   to them. These new expressions are given unique names and get+--   declared in the block scope.+deconstructProduct+  :: (HasCallStack, Backend backend)+  => TExpr+  -- ^ Product expression+  -> [Text]+  -- ^ Name hints for element assignments+  -> State (BlockState backend) [TExpr]+deconstructProduct (TExpr ty@(Product _ _ fieldTys) (Identifier resName Nothing)) nameHints =+  forM (zip3 [0..] nameHints fieldTys) $ \(fieldIndex, nameHint, fieldTy) ->+    assign nameHint $+      TExpr fieldTy (Identifier resName (Just (Indexed (ty, 0, fieldIndex))))++deconstructProduct t0@(TExpr (Product {}) _) nameHints = do+  t1 <- toIdentifier "product" t0+  deconstructProduct t1 nameHints++deconstructProduct e i =+  error $ "deconstructProduct: " <> show e <> " " <> show i++-- | Extract the elements of a tuple expression and return expressions+--   to them. These new expressions are given unique names and get+--   declared in the block scope.+untuple+  :: (HasCallStack, Backend backend)+  => TExpr+  -- ^ Tuple expression+  -> [Text]+  -- ^ Name hints for element assignments+  -> State (BlockState backend) [TExpr]+untuple = deconstructProduct++-- | The high literal bit.+pattern High :: TExpr+pattern High <- TExpr Bit (Literal _ (BitLit H))+  where High = TExpr Bit (Literal (Just (Bit,1)) (BitLit H))++-- | The low literal bit.+pattern Low :: TExpr+pattern Low <- TExpr Bit (Literal _ (BitLit L))+  where Low = TExpr Bit (Literal (Just (Bit,1)) (BitLit L))++-- | The true literal bool.+pattern T :: TExpr+pattern T <- TExpr Bool (Literal _ (BoolLit True))+  where T = TExpr Bool (Literal (Just (Bool,1)) (BoolLit True))++-- | The false literal bool.+pattern F :: TExpr+pattern F <- TExpr Bool (Literal _ (BoolLit False))+  where F = TExpr Bool (Literal (Just (Bool,1)) (BoolLit False))++-- | Construct a fully defined BitVector literal+bvLit+  :: Int+  -- ^ BitVector size+  -> Integer+  -- ^ Literal+  -> TExpr+bvLit sz n =+  TExpr+    (BitVector sz)+    (Literal (Just (BitVector sz, sz)) (BitVecLit 0 n))++-- | Convert a bool to a bit.+boolToBit+  :: (HasCallStack, Backend backend)+  => Text+  -- ^ Name hint for intermediate signal+  -> TExpr+  -> State (BlockState backend) TExpr+boolToBit bitName = \case+  T -> pure High+  F -> pure Low+  TExpr Bool boolExpr -> do+    texp <- declare bitName Bit+    let uniqueBitName = case texp of+          TExpr _ (Identifier x Nothing) -> x+          t' -> error ("boolFromBit expected an Identifier, but got: " <> show t')+    addDeclaration $+      CondAssignment uniqueBitName Bit boolExpr Bool+        [ (Just (BoolLit True), Literal Nothing (BitLit H))+        , (Nothing            , Literal Nothing (BitLit L))+        ]+    declareUseOnce (Proc NonBlocking) uniqueBitName+    pure texp+  tExpr -> error $ "boolToBit: Got \"" <> show tExpr <> "\" expected Bool"++-- | Convert an enable to a bit.+enableToBit+  :: (HasCallStack, Backend backend)+  => Text+  -- ^ Name hint for intermediate signal+  -> TExpr+  -> State (BlockState backend) TExpr+enableToBit bitName = \case+  TExpr ena@(Enable _) enableExpr -> do+    texp <- declare bitName Bit+    let uniqueBitName = case texp of+          TExpr _ (Identifier x Nothing) -> x+          t' -> error ("boolFromBit expected an Identifier, but got: " <> show t')+    addDeclaration $+      CondAssignment uniqueBitName Bit enableExpr ena+        -- Enable normalizes to Bool for all current backends+        [ (Just (BoolLit True), Literal Nothing (BitLit H))+        , (Nothing            , Literal Nothing (BitLit L))+        ]+    declareUseOnce (Proc NonBlocking) uniqueBitName+    pure texp+  tExpr -> error $ "enableToBit: Got \"" <> show tExpr <> "\" expected Enable"++-- | Use to create an output `Bool` from a `Bit`. The expression given+--   must be the identifier of the bool you wish to get assigned.+--   Returns a reference to a declared `Bit` that should get assigned+--   by something (usually the output port of an entity).+boolFromBit+  :: (HasCallStack, Backend backend)+  => Text+  -- ^ Name hint for intermediate signal+  -> TExpr+  -> State (BlockState backend) TExpr+boolFromBit boolName = \case+  High -> pure T+  Low -> pure F+  TExpr Bit bitExpr -> do+    texp <- declare boolName Bool+    let uniqueBoolName = case texp of+          TExpr _ (Identifier x Nothing) -> x+          t' -> error ("boolFromBit expected an Identifier, but got: " <> show t')+    addDeclaration $+      CondAssignment uniqueBoolName Bool bitExpr Bit+        [ (Just (BitLit H), Literal Nothing (BoolLit True))+        , (Nothing        , Literal Nothing (BoolLit False))+        ]+    declareUseOnce (Proc NonBlocking) uniqueBoolName+    pure texp+  tExpr -> error $ "boolFromBit: Got \"" <> show tExpr <> "\" expected Bit"++-- | Used to create an output `Bool` from a `BitVector` of given size.+-- Works in a similar way to `boolFromBit` above.+--+-- TODO: Implement for (System)Verilog+boolFromBitVector+  :: Size+  -> Text+  -- ^ Name hint for intermediate signal+  -> TExpr+  -> State (BlockState VHDLState) TExpr+boolFromBitVector n =+  outputCoerce (BitVector n) Bool (\i -> "unsigned(" <> i <> ") > 0")++-- | Used to create an output `Unsigned` from a `BitVector` of given+-- size. Works in a similar way to `boolFromBit` above.+unsignedFromBitVector ::+  (HasCallStack, Backend backend) =>+  -- | Name hint for intermediate signal+  Text ->+  -- | BitVector expression+  TExpr ->+  -- | Unsigned expression+  State (BlockState backend) TExpr+unsignedFromBitVector nameHint e@TExpr{ety=BitVector n} =+  fromBV nameHint (Unsigned n) e+unsignedFromBitVector _nameHint TExpr{ety} =+  error $ "unsignedFromBitVector: Expected BitVector, got: " <> show ety++-- | Used to create an output `Bool` from a number of `Bit`s, using+-- conjunction. Similarly to `untuple`, it returns a list of+-- references to declared values (the inputs to the function) which+-- should get assigned by something---usually output ports of an+-- entity.+--+-- TODO: Implement for (System)Verilog+boolFromBits+  :: [Text]+  -> TExpr+  -> State (BlockState VHDLState) [TExpr]+boolFromBits inNames = outputFn (map (const Bit) inNames) Bool+  (foldl (<>) "" . intersperse " and " . map (\i -> "(" <> i <> " = '1')")) inNames++-- | Used to create an output value with an arbitrary VHDL coercion.+-- The expression given should be the identifier of the output value+-- you wish to get assigned. Returns a reference to a declared value+-- of the input type that should get assigned by something (usually+-- the output port of an entity).+outputCoerce+  :: (HasCallStack, Backend backend)+  => HWType+  -> HWType+  -> (Text -> Text)+  -> Text+  -> TExpr+  -> State (BlockState backend) TExpr+outputCoerce fromType toType exprStringFn inName0 expr_+  | TExpr outType (Identifier outName Nothing) <- expr_+  , outType == toType = do+      inName1 <- Id.makeBasic inName0+      let inName2 = Id.unsafeMake (exprStringFn (Id.toText inName1))+          exprIdent = Identifier inName2 Nothing+      addDeclaration (NetDecl Nothing inName1 fromType)+      addDeclaration (Assignment outName Cont exprIdent)+      pure (TExpr fromType (Identifier inName1 Nothing))+outputCoerce _ toType _ _ texpr = error $ "outputCoerce: the expression " <> show texpr+                                  <> " must be an Identifier with type " <> show toType++-- | Used to create an output value that is an arbitrary function (as+-- VHDL) of existing values. The expression given should be the+-- identifier of the output value you wish to get assigned. Similarly+-- to `untuple`, it returns a list of references to declared values+-- (the inputs to the function) which should get assigned by+-- something---usually output ports of an entity.+outputFn+  :: (HasCallStack, Backend backend)+  => [HWType]+  -> HWType+  -> ([Text] -> Text)+  -> [Text]+  -> TExpr+  -> State (BlockState backend) [TExpr]+outputFn fromTypes toType exprFn inNames0 (TExpr outType (Identifier outName Nothing))+  | outType == toType = do+      inNames1 <- mapM Id.makeBasic inNames0+      let idExpr = Id.unsafeMake (exprFn (map Id.toText inNames1))+          exprIdent = Identifier idExpr Nothing+      sequenceOf_ each [ addDeclaration (NetDecl Nothing nm t)+                       | (nm, t) <- zip inNames1 fromTypes ]+      addDeclaration (Assignment outName Cont exprIdent)+      pure [ TExpr t (Identifier nm Nothing)+           | (nm,t) <- zipEqual inNames1 fromTypes ]+outputFn _ outType _ _ texpr =+  error $ "outputFn: the expression " <> show texpr+  <> " must be an Identifier with type " <> show outType++-- | Create a vector of 'TExpr's+vec+  :: (HasCallStack, Backend backend)+  => [TExpr]+  -- ^ Elements of vector+  -> State (BlockState backend) TExpr+  -- ^ Vector elements+vec els@(el:_)+  | all (\e -> ety e == ety el) els+  = pure (TExpr (Vector (length els) (ety el)) theVec)+  | otherwise+  = error $ "vec: elements not of same type: " ++ show els+ where+  theVec = mkVectorChain (length els) (ety el) (map eex els)+vec [] = error "vec: can't be used on empty lists"++-- | Construct a product type given its type and fields+constructProduct :: HWType -> [TExpr] -> TExpr+constructProduct ty els =+  TExpr ty (DataCon ty (DC (ty,0)) (map eex els))++-- | Create an n-tuple of 'TExpr'+tuple :: HasCallStack => [TExpr] -> TExpr+tuple [] = error $ "tuple: Cannot create empty tuple"+tuple [_] =+  -- If we don't put this in: tuple . untuple /= id+  error $ "tuple: Cannot create 1-tuple"+tuple els = constructProduct tupTy els+ where+#if MIN_VERSION_base(4,19,0)+  tupTy = Product (tupModule <> ".Tuple" <> showt (length els)) Nothing (map ety els)+  tupModule =+    $(+    let tupNm = ''(,)+    in case (TH.nameModule tupNm, TH.nameBase tupNm) of+        (Just modNm, "Tuple2") -> TH.lift modNm :: TH.ExpQ+        _ -> error $ "tuple: (,) has an unexpected name: " <> show tupNm+    )+#else+  commas = Text.replicate (length els - 1) ","+  tupTy = Product (tupModule <> ".(" <> commas <> ")") Nothing (map ety els)+  tupModule =+    $(+    let tupNm = ''(,)+    in case (TH.nameModule tupNm, TH.nameBase tupNm) of+        (Just modNm, "(,)") -> TH.lift modNm :: TH.ExpQ+        _ -> error $ "tuple: (,) has an unexpected name: " <> show tupNm+    )+#endif++-- | Try to get the literal string value of an expression.+getStr :: TExpr -> Maybe String+getStr (TExpr _ e) = exprToString e++-- | Try to get the literal bool value of an expression.+getBool :: TExpr -> Maybe Bool+getBool (TExpr _ (Literal _ (BoolLit b))) = Just b+getBool _ = Nothing++-- | Try to get a Vector of expressions.+getVec :: TExpr -> Maybe [TExpr]+getVec (TExpr (Void (Just (Vector 0 _) )) _) =+  pure []+getVec (TExpr (Vector 1 elementTy) (DataCon _ VecAppend [e])) =+  pure [TExpr elementTy e]+getVec (TExpr (Vector n elementTy) (DataCon _ VecAppend [e, es0])) = do+  es1 <- getVec (TExpr (Vector (n-1) elementTy) es0)+  pure (TExpr elementTy e:es1)+getVec _ = Nothing++-- | Try to get the literal nat value of an expression.+tExprToInteger :: TExpr -> Maybe Integer+tExprToInteger (TExpr _ e) = exprToInteger e++exprToInteger :: Expr -> Maybe Integer+exprToInteger (DataCon _ _ [n]) = exprToInteger n+exprToInteger (Literal _ (NumLit n)) = Just n+exprToInteger _ = Nothing++-- | Convert an expression from one type to another. Errors if result type and+-- given expression are sized differently.+bitCoerce ::+  (HasCallStack, Backend backend) =>+  -- | Name hints for intermediate variables+  Text ->+  -- | Type to convert to+  HWType ->+  -- | Expression to convert+  TExpr ->+  -- | Converted expression+  State (BlockState backend) TExpr+bitCoerce nameHint destType e@(TExpr ety _)+  | tySize ety /= tySize @Int destType = error "Size mismatch"+  | ety == destType = pure e+  | BitVector _ <- ety = fromBV nameHint destType e+  | otherwise = bitCoerce nameHint destType =<< toBV nameHint e++-- | Convert an expression to a BitVector+toBV ::+  Backend backend =>+  -- | BitVector name hint+  Text ->+  -- | Expression to convert to BitVector+  TExpr ->+  -- | BitVector expression+  State (BlockState backend) TExpr+toBV = toBvWithAttrs []++-- | Convert an expression to a BitVector and add the given HDL attributes+toBvWithAttrs ::+  Backend backend =>+  [Attr Text] ->+  -- | BitVector name hint+  Text ->+  -- | Expression to convert to BitVector+  TExpr ->+  -- | BitVector expression+  State (BlockState backend) TExpr+toBvWithAttrs attrs bvName (TExpr aTy aExpr) =+  assign bvName $+    TExpr+      (annotated attrs (BitVector (tySize aTy)))+      (ToBv Nothing aTy aExpr)++-- | Convert an expression from a 'BitVector' into some type. If the expression+-- is 'Annotated', only convert the expression within.+fromBV+  :: (HasCallStack, Backend backend) =>+  -- | Result name hint+  Text ->+  -- | Type to convert to+  HWType ->+  -- | 'BitVector' expression+  TExpr ->+  -- | Converted 'BitVector' expression+  State (BlockState backend) TExpr+fromBV resultName resultType e@TExpr{eex, ety = BitVector _} =+  case resultType of+    BitVector{} -> pure e+    _ -> assign resultName (TExpr resultType (FromBv Nothing resultType eex))+fromBV resultName resultType e@TExpr{ety = Annotated _ bv@(BitVector _)} =+  case resultType of+    BitVector{} -> pure (TExpr bv (eex e))+    _ -> assign resultName (TExpr resultType (FromBv Nothing resultType (eex e)))+fromBV _ _ TExpr{ety} = error $ "fromBV: expected BitVector, got: " <> show ety++clog2 :: Num i => Integer -> i+clog2 = fromIntegral . fromMaybe 0 . clogBase 2++tySize :: Num i => HWType -> i+tySize = fromIntegral . typeSize++-- | A literal that can be used for hdl attributes. It has a `Num` and+--   `IsString` instances for convenience.+data LitHDL+  = B Bool+  | S String+  | I Integer+  deriving Show++instance Num LitHDL where+  (+) = undefined+  (*) = undefined+  abs = undefined+  signum = undefined+  negate = undefined+  fromInteger = I++instance IsString LitHDL where+  fromString = S++-- | Instantiate/call a higher-order function.+instHO+  :: Backend backend+  => BlackBoxContext+  -- ^ BlackBoxContext, used for rendering higher-order function and error+  -- reporting+  -> Int+  -- ^ Position of HO-argument. For example:+  --+  -- > fold :: forall n a . (a -> a -> a) -> Vec (n + 1) a -> a+  --+  -- would have its HO-argument at position 0, while+  --+  -- > iterateI :: forall n a. KnownNat n => (a -> a) -> a -> Vec n a+  --+  -- would have it at position 1.+  -> (HWType, BlackBoxTemplate)+  -- ^ Result type of HO function+  -> [(TExpr, BlackBoxTemplate)]+  -- ^ Arguments and their types+  -> State (BlockState backend) TExpr+  -- ^ Result of the function+instHO bbCtx fPos (resTy, bbResTy) argsWithTypes = do+  let (args0, argTypes) = unzip argsWithTypes+  fSubPos <- fromMaybe 0 . IntMap.lookup fPos <$> use bsHigherOrderCalls+  bsHigherOrderCalls %= IntMap.insert fPos (succ fSubPos)++  -- Create argument identifiers, example: fold_ho3_0_arg0+  let+    ctxName = last (Text.split (=='.') (bbName bbCtx))+    baseArgName = ctxName <> "_" <> "ho" <> showt fPos <> "_" <> showt fSubPos+    argName n = baseArgName <> "_arg" <> showt n+  args1 <- zipWithM (\argN -> toIdentifier' (argName argN)) [(0::Int)..] args0++  let+    args2 = map (pure . Text . Id.toLazyText) args1++  resName <- declare' (ctxName <> "_" <> "ho" <> showt fPos <> "_"+                               <> showt fSubPos <> "_res") resTy+  -- Pick the fSubPos-th HO instantiation (if present) and reuse its usage.+  sp <- zoom bsBackend getSrcSpan+  case lookupFunctionInstantiation bbCtx fPos fSubPos of+    Left err0 ->+      throw (ClashException sp ($(curLoc) ++ "instHO: " ++ err0) Nothing)+    Right (_, usage, _, _, _, _) ->+      declareUseOnce usage resName+  let res = ([Text (Id.toLazyText resName)], bbResTy)++  -- Render HO argument to plain text+  let component = Component (Decl fPos fSubPos (res:zip args2 argTypes))+  rendered0 <-+    zoom bsBackend (string =<< (renderElem bbCtx component <*> pure 0))++  let+    layout = LayoutOptions (AvailablePerLine 120 0.4)+    rendered1 = renderLazy (layoutPretty layout rendered0)++  addDeclaration $+    BlackBoxD+      ("__INST_" <> bbName bbCtx <> "_BB_INTERNAL__") [] [] []+      (BBTemplate [Text rendered1])+      (emptyBBContext ("__INST_" <> bbName bbCtx <> "_BB_INTERNAL__"))++  pure (TExpr resTy (Identifier resName Nothing))++-- | This creates a component declaration (for VHDL) given in and out port+-- names, updating the 'BlockState backend' stored in the 'State' monad.+--+-- A typical result is that a+--+-- > component fifo port+-- >    ( rst : in std_logic+-- >    ...+-- >    ; full : out std_logic+-- >    ; empty : out std_logic );+-- >  end component;+--+-- declaration would be added in the appropriate place.+compInBlock+  :: forall backend+   . Backend backend+  => Text+  -- ^ Component name+  -> [(Text, HWType)]+  -- ^ in ports+  -> [(Text, HWType)]+  -- ^ out ports+  -> State (BlockState backend) ()+compInBlock compName inPorts0 outPorts0 =+  addDeclaration (CompDecl compName (inPorts1 ++ outPorts1))+ where+  mkPort inOut (nm, ty) = (nm, inOut, ty)+  inPorts1 = mkPort In <$> inPorts0+  outPorts1 = mkPort Out <$> outPorts0++-- | Convert a 'LitHDL' to a 'TExpr'+--+-- __N.B.__: Clash 1.8 changed 'instDecl'\'s type signature. Where it would+--           previously accept 'LitHDL' in its generics/parameters argument, it+--           now accepts a 'TExpr'. This function is mostly there to ease this+--           transition.+litTExpr :: LitHDL -> TExpr+litTExpr (B b) = TExpr Bool    (Literal Nothing (BoolLit b))+litTExpr (S s) = TExpr String  (Literal Nothing (StringLit s))+litTExpr (I i) = TExpr Integer (Literal Nothing (NumLit i))++-- | Instantiate a component/entity in a block state+instDecl+  :: forall backend+   . Backend backend+  => EntityOrComponent+  -- ^ Type of instantiation+  -> Identifier+  -- ^ Component/entity name+  -> Identifier+  -- ^ Instantiation label+  -> [(Text, TExpr)]+  -- ^ Generics / parameters+  -> [(Text, TExpr)]+  -- ^ In ports+  -> [(Text, TExpr)]+  -- ^ Out ports+  -> State (BlockState backend) ()+instDecl entOrComp compName instLbl params inPorts outPorts = do++  inPorts' <- mapM (mkPort In) inPorts+  outPorts' <- mapM (mkPort Out) outPorts++  addDeclaration $+    InstDecl+      entOrComp Nothing [] compName instLbl (mkParams params)+      (NamedPortMap (inPorts' ++ outPorts'))+   where+    mkPort+      :: PortDirection+      -> (Text, TExpr)+      -> StateT (BlockState backend) Identity (Expr, PortDirection, HWType, Expr)+    mkPort inOrOut (nmText, pExpr) = do+      TExpr ty pExpr' <- toIdentifier (nmText <> "_port")  pExpr+      pure (Identifier (Id.unsafeMake nmText) Nothing, inOrOut, ty, pExpr')++    -- Convert a list of name generics / parameters to the form clash wants+    mkParams :: [(Text.Text, TExpr)] -> [(Expr, HWType, Expr)]+    mkParams = map $ \(paramName, texpr) ->+      ( Identifier (Id.unsafeMake paramName) Nothing+      , ety texpr+      , eex texpr )++-- | Wires the two given `TExpr`s together using a newly declared+-- signal with (exactly) the given name `sigNm`. The new signal has an+-- annotated type, using the given attributes.+viaAnnotatedSignal+  :: (HasCallStack, Backend backend)+  => Identifier+  -- ^ Name given to signal+  -> TExpr+  -- ^ expression the signal is assigned to+  -> TExpr+  -- ^ expression (must be identifier) to which the signal is assigned+  -> [Attr Text]+  -- ^ the attributes to annotate the signal with+  -> State (BlockState backend) ()+viaAnnotatedSignal sigNm (TExpr fromTy fromExpr) (TExpr toTy (Identifier outNm Nothing)) attrs+  | fromTy == toTy = do+      addDeclaration (NetDecl Nothing sigNm (Annotated attrs fromTy))+      addDeclaration (Assignment sigNm Cont fromExpr)+      addDeclaration (Assignment outNm Cont (Identifier sigNm Nothing))+viaAnnotatedSignal _ inTExpr outTExpr@(TExpr _ (Identifier _ _)) _ =+  error $ "viaAnnotatedSignal: The in and out expressions \"" <> show inTExpr <>+  "\" and \"" <> show outTExpr <> "\" have non-matching types."+viaAnnotatedSignal _ _ outTExpr _ =+  error $ "viaAnnotatedSignal: The out expression \"" <> show outTExpr <>+  "\" must be an Identifier."++-- | The TExp inputs from a blackbox context.+tInputs :: BlackBoxContext -> [(TExpr, HWType)]+tInputs = map (\(x, t, _) -> (TExpr t x, t)) . bbInputs++-- | The TExp result of a blackbox context.+tResults :: BlackBoxContext -> [TExpr]+tResults = map (\(x,t) -> TExpr t x) . bbResults++-- | Get an identifier to an expression, creating a new assignment if+--   necessary.+toIdentifier'+  :: Backend backend+  => Text+  -- ^ desired new identifier name, will be made unique+  -> TExpr+  -- ^ expression to get identifier of+  -> State (BlockState backend) Identifier+  -- ^ identifier to expression+toIdentifier' _ (TExpr _ (Identifier aExpr Nothing)) = pure aExpr+toIdentifier' nm texp = do+  t <- assign nm texp+  let nm' = case t of+              TExpr _ (Identifier x Nothing) -> x+              t' -> error ("toIdentifier' expected an Identifier, but got: " <> show t')+  pure nm'++-- | Get an identifier to an expression, creating a new assignment if+--   necessary.+toIdentifier+  :: Backend backend+  => Text+  -- ^ desired new identifier name, will be made unique+  -> TExpr+  -- ^ expression to get identifier of+  -> State (BlockState backend) TExpr+  -- ^ identifier to expression+toIdentifier nm texp = do+  id' <- toIdentifier' nm texp+  pure (TExpr (ety texp) (Identifier id' Nothing))++-- | And together @(&&)@ two expressions, assigning it to a new identifier.+andExpr+  :: Backend backend+  => Text+  -- ^ name hint+  -> TExpr+  -- ^ a+  -> TExpr+  -- ^ a+  -> State (BlockState backend) TExpr+  -- ^ a && b+andExpr _ T bExpr = pure bExpr+andExpr _ F _     = pure F+andExpr _ aExpr T = pure aExpr+andExpr _ _ F     = pure F+andExpr nm a b = do+  aIdent <- Id.toText <$> toIdentifier' (nm <> "_a") a+  bIdent <- Id.toText <$> toIdentifier' (nm <> "_b") b+  -- This is somewhat hacky and relies on the fact that clash doesn't+  -- postprocess the text in Identifier. The alternative is to run+  -- this as a fully fledged @BlackBoxE@ but that involves a lot of+  -- faffing. It should be reasonably safe because we assign each side+  -- to an identifier if it isn't already.+  andTxt <-+    uses bsBackend hdlKind <&> \case+      VHDL          -> aIdent <> " and " <> bIdent+      Verilog       -> aIdent <> " && " <> bIdent+      SystemVerilog -> aIdent <> " && " <> bIdent+  assign nm $ TExpr Bool (Identifier (Id.unsafeMake andTxt) Nothing)++-- | Massage a reset to work as active-high reset.+unsafeToActiveHigh+  :: Backend backend+  => Text+  -- ^ Name hint+  -> TExpr+  -- ^ Reset signal+  -> State (BlockState backend) TExpr+unsafeToActiveHigh nm rExpr = do+  resetLevel <- vResetPolarity <$> liftToBlockState (getDomainConf (ety rExpr))+  case resetLevel of+    ActiveHigh -> pure rExpr+    ActiveLow -> notExpr nm rExpr++-- | Massage a reset to work as active-low reset.+unsafeToActiveLow+  :: Backend backend+  => Text+  -- ^ Name hint+  -> TExpr+  -- ^ Reset signal+  -> State (BlockState backend) TExpr+unsafeToActiveLow nm rExpr = do+  resetLevel <- vResetPolarity <$> liftToBlockState (getDomainConf (ety rExpr))+  case resetLevel of+    ActiveLow -> pure rExpr+    ActiveHigh -> notExpr nm rExpr++-- | Negate @(not)@ an expression, assigning it to a new identifier.+notExpr+  :: Backend backend+  => Text+  -- ^ name hint+  -> TExpr+  -- ^ @a@+  -> State (BlockState backend) TExpr+  -- ^ @not a@+notExpr _ T = pure F+notExpr _ F = pure T+notExpr nm aExpr = do+  aIdent <- Id.toText <$> toIdentifier' (nm <> "_a") aExpr+  -- See disclaimer in `andExpr` above.+  notTxt <- uses bsBackend hdlKind <&> \case+    VHDL          -> "not " <> aIdent+    Verilog       -> "! " <> aIdent+    SystemVerilog -> "! " <> aIdent+  assign nm $ TExpr Bit (Identifier (Id.unsafeMake notTxt) Nothing)++-- | Creates a BV that produces the following vhdl:+--+-- > (0 to n => ARG)+--+-- TODO: Implement for (System)Verilog+pureToBV+  :: Text+  -- ^ name hint+  -> Int+  -- ^ Size (n)+  -> TExpr+  -- ^ @ARG@+  -> State (BlockState VHDLState) TExpr+  -- ^ @(0 to n => ARG)@+pureToBV nm n arg = do+  arg' <- Id.toText <$> toIdentifier' nm arg+  -- This is very hard coded and hacky+  let text = "(0 to " <> showt n <> " => " <> arg' <> ")"+  assign nm $ TExpr (BitVector (n+1)) (Identifier (Id.unsafeMake text) Nothing)++-- | Creates a BV that produces the following vhdl:+--+-- > std_logic_vector(resize(ARG, n))+--+-- TODO: Implement for (System)Verilog+pureToBVResized+  :: Text+  -- ^ name hint+  -> Int+  -- ^ Size (n)+  -> TExpr+  -- ^ ARG+  -> State (BlockState VHDLState) TExpr+  -- ^ @std_logic_vector(resize(ARG, n))@+pureToBVResized nm n arg = do+  arg' <- Id.toText <$> toIdentifier' nm arg+  -- This is very hard coded and hacky+  let text = "std_logic_vector(resize(" <> arg' <> ", " <> showt n <> "))"+  assign nm $ TExpr (BitVector n) (Identifier (Id.unsafeMake text) Nothing)++-- | Allows assignment of a port to be "open"+open+  :: Backend backend+  => HWType+  -> State (BlockState backend) TExpr+open hwType = pure $ TExpr hwType (Identifier (Id.unsafeMake "open") Nothing)
+ src/Clash/Primitives/GHC/Int.hs view
@@ -0,0 +1,64 @@+{-|+  Copyright  :  (C) 2019, Myrtle Software Ltd+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  Blackbox generation for GHC.Int.IntX# data constructors. (System)Verilog only!+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Primitives.GHC.Int (intTF) where++import           Clash.Core.Literal           (Literal(..))+import           Clash.Core.Term              (Term(Literal))+import           Clash.Core.Type              (Type)+import           Clash.Primitives.GHC.Literal+  (literalTF, signed, signedLiteral, assign)+import           Clash.Netlist.Types          (BlackBox(BBTemplate))+import           Clash.Netlist.BlackBox.Types+  (BlackBoxFunction, Element(Arg, Result), emptyBlackBoxMeta+  ,BlackBoxMeta, bbKind, TemplateKind(TDecl))++getIntLit+  :: Literal+  -> Maybe Integer+getIntLit =+  \case+    IntegerLiteral i -> Just i+    IntLiteral i     -> Just i+    Int8Literal i    -> Just i+    Int16Literal i   -> Just i+    Int32Literal i   -> Just i+    Int64Literal i   -> Just i+    _                -> Nothing++-- | Template function for Int8,Int16,.. Constructs "clean" literals.+intTF :: BlackBoxFunction+intTF = literalTF "GHC.Int.I" intTF'++intTF'+  :: Bool+  -- ^ Is declaration+  -> [Either Term Type]+  -- ^ Arguments+  -> Int+  -- ^ Word size+  -> (BlackBoxMeta, BlackBox)+intTF' False [Left (Literal (getIntLit -> Just n))] intSize =+  -- Literal as expression:+  ( emptyBlackBoxMeta+  , BBTemplate [signedLiteral intSize n])++intTF' True [Left (Literal (getIntLit -> Just n))] intSize =+  -- Literal as declaration:+  ( emptyBlackBoxMeta+  , BBTemplate (assign Result [signedLiteral intSize n]))++intTF' _isDecl _args _intSize =+  -- Not a literal. We need an assignment as Verilog does not support truncating+  -- arbitrary expression.+  ( emptyBlackBoxMeta {bbKind = TDecl }+  , BBTemplate (assign Result (signed (Arg 0))))
+ src/Clash/Primitives/GHC/Literal.hs view
@@ -0,0 +1,77 @@+{-|+  Copyright  :  (C) 2019, Myrtle Software Ltd+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  Blackbox generation for literal data constructors. (System)Verilog only!+-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Primitives.GHC.Literal+ ( assign+ , signed+ , signedLiteral+ , unsigned+ , unsignedLiteral+ , literalTF+ )+ where++import qualified Data.Text.Lazy               as LT+import           Data.Text+  (Text, stripPrefix, stripSuffix, unpack)+import           Data.Text.Extra              (showtl)+import           Text.Read                    (readMaybe)++import           Clash.Core.Term              (Term)+import           Clash.Core.Type              (Type)+import           Clash.Netlist.Types          (BlackBox)+import           Clash.Netlist.BlackBox.Types+  (BlackBoxFunction, Element(Text), BlackBoxMeta)++unsigned :: Element -> [Element]+unsigned el = [Text "$unsigned(", el, Text ")"]++signed :: Element -> [Element]+signed el = [Text "$signed(", el, Text ")"]++assign :: Element -> [Element] -> [Element]+assign lhs rhs = Text "assign " : lhs : Text " = " : rhs ++ [Text ";"]++signedLiteral :: Int -> Integer -> Element+signedLiteral wordSize wordVal =+  Text (LT.concat [ if wordVal < 0 then "-" else ""+                  , showtl wordSize+                  , "'sd"+                  , showtl (abs wordVal)+                  ])++unsignedLiteral :: Int -> Integer -> Element+unsignedLiteral wordSize wordVal =+  Text (LT.concat [ if wordVal < 0 then "-" else ""+                  , showtl wordSize+                  , "'d"+                  , showtl (abs wordVal)+                  ])++-- | Parse integer in strings of the form "GHC.Word.WordX#" where+-- "GHC.Word.Word" is the prefix given.+readSize :: Text -> Text -> Maybe Int+readSize prefix nm0 = do+  nm1 <- stripPrefix prefix nm0+  nm2 <- stripSuffix "#" nm1+  readMaybe (unpack nm2)++-- | Constructs "clean" literals.+literalTF+  :: Text+  -- ^ Base name of constructors (for example: "GHC.Word.W")+  -> (Bool -> [Either Term Type] -> Int -> (BlackBoxMeta, BlackBox))+  -- ^ Functions processing+  -> BlackBoxFunction+literalTF baseName tf isDecl primName args _resTy = return $+  case readSize baseName primName of+    Nothing ->+      Left (concat ["Can only make blackboxes for '", unpack baseName, "X#'"])+    Just n ->+      Right (tf isDecl args n)
+ src/Clash/Primitives/GHC/Word.hs view
@@ -0,0 +1,63 @@+{-|+  Copyright  :  (C) 2019, Myrtle Software Ltd+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>++  Blackbox generation for GHC.Word.WordX# data constructors. (System)Verilog only!+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Primitives.GHC.Word (wordTF) where++import           Clash.Core.Literal           (Literal(..))+import           Clash.Core.Term              (Term(Literal))+import           Clash.Core.Type              (Type)+import           Clash.Primitives.GHC.Literal+  (literalTF, unsigned, unsignedLiteral, assign)+import           Clash.Netlist.Types          (BlackBox(BBTemplate))+import           Clash.Netlist.BlackBox.Types+  (BlackBoxFunction, Element(Arg, Result), emptyBlackBoxMeta+  ,BlackBoxMeta, bbKind, TemplateKind(TDecl))++-- | Template function for Word8,Word16,.. Constructs "clean" literals. This+-- function generates valid (System)Verilog only!+wordTF :: BlackBoxFunction+wordTF = literalTF "GHC.Word.W" wordTF'++getWordLit+  :: Literal+  -> Maybe Integer+getWordLit =+  \case+    WordLiteral i   -> Just i+    Word8Literal i  -> Just i+    Word16Literal i -> Just i+    Word32Literal i -> Just i+    Word64Literal i -> Just i+    _               -> Nothing++wordTF'+  :: Bool+  -- ^ Is declaration+  -> [Either Term Type]+  -- ^ Arguments+  -> Int+  -- ^ Word size+  -> (BlackBoxMeta, BlackBox)+wordTF' False [Left (Literal (getWordLit -> Just n))] wordSize =+  -- Literal as expression:+  ( emptyBlackBoxMeta+  , BBTemplate [unsignedLiteral wordSize n])++wordTF' True [Left (Literal (getWordLit -> Just n))] wordSize =+  -- Literal as declaration:+  ( emptyBlackBoxMeta+  , BBTemplate (assign Result [unsignedLiteral wordSize n]))++wordTF' _isDecl _args _wordSize =+  -- Not a literal. We need an assignment as Verilog does not support truncating+  -- arbitrary expression.+  ( emptyBlackBoxMeta {bbKind = TDecl }+  , BBTemplate (assign Result (unsigned (Arg 0))))
+ src/Clash/Primitives/Intel/ClockGen.hs view
@@ -0,0 +1,315 @@+{-|+  Copyright   :  (C) 2018     , Google Inc.,+                     2021-2023, QBayLogic B.V.,+                     2022     , Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Blackbox template functions for Clash.Intel.ClockGen+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE ViewPatterns      #-}++module Clash.Primitives.Intel.ClockGen where++import Control.Monad.State+import Data.List (zip4)+import Data.List.Infinite (Infinite(..), (...))+import Data.Maybe (fromMaybe)+import Data.Text.Prettyprint.Doc.Extra+import Text.Show.Pretty (ppShow)++import Clash.Backend+import qualified Clash.Netlist.Id as Id+import Clash.Netlist.Types+import Clash.Netlist.Util+import qualified Clash.Primitives.DSL as DSL+import Clash.Signal (periodToHz)+import Data.Text.Extra (showt)++import qualified Data.String.Interpolate as I+import qualified Data.Text as TextS+import qualified Prettyprinter.Interpolate as I++data Variant = Altpll | AlteraPll++hdlUsed :: [Int]+hdlUsed = [ clk, rst ]+ where+  _knownDomIn+    :< _clocksClass+    :< _clocksCxt+    :< _numOutClocks+    :< clk+    :< rst+    :< _ = (0...)++hdlValid :: BlackBoxContext -> Bool+hdlValid bbCtx | [(_,Product {})] <- bbResults bbCtx = True+hdlValid _ = False++qsysUsed :: [Int]+qsysUsed = [ knownDomIn, clocksCxt ]+ where+  knownDomIn+    :< _clocksClass+    :< clocksCxt+    :< _ = (0...)++altpllTF :: TemplateFunction+altpllTF = TemplateFunction hdlUsed hdlValid (hdlTemplate Altpll)++altpllQsysTF :: TemplateFunction+altpllQsysTF = TemplateFunction qsysUsed valid altpllQsysTemplate+ where+  valid = const True++alteraPllTF :: TemplateFunction+alteraPllTF = TemplateFunction hdlUsed hdlValid (hdlTemplate AlteraPll)++alteraPllQsysTF :: TemplateFunction+alteraPllQsysTF = TemplateFunction qsysUsed valid alteraPllQsysTemplate+ where+  valid = const True++hdlTemplate ::+  forall s .+  Backend s =>+  Variant ->+  BlackBoxContext ->+  State s Doc+hdlTemplate variant bbCtx+  | [ _knownDomIn+    , _clocksClass+    , _clocksCxt+    , _numOutClocks+    , clk+    , rst+    ] <- map fst (DSL.tInputs bbCtx)+  , [DSL.ety -> resultTy] <- DSL.tResults bbCtx+  , Product _ _ (init -> pllOutTys) <- resultTy+  , [compName] <- bbQsysIncName bbCtx+  = do+    let+      stdName Altpll = "altpll"+      stdName AlteraPll = "altera_pll"+      pllOutName Altpll = "c"+      pllOutName AlteraPll = "outclk_"+      clkInName Altpll = "clk"+      clkInName AlteraPll = "refclk"+      rstName Altpll = "areset"+      rstName AlteraPll = "rst"++    instName <- Id.makeBasic $ fromMaybe (stdName variant) $ bbCtxName bbCtx++    -- TODO: unsafeMake is dubious here: I don't think we take names in+    -- TODO: bbQsysIncName into account when generating fresh ids+    let compNameId = Id.unsafeMake compName++    DSL.declarationReturn bbCtx (stdName variant <> "_block") $ do++      rstHigh <- DSL.unsafeToActiveHigh "reset" rst+      pllOuts <- DSL.declareN "pllOut" pllOutTys+      locked <- DSL.declare "locked" Bit+      pllLock <- DSL.boolFromBit "pllLock" locked++      let+        pllOutNames =+          map (\n -> pllOutName variant <> showt n)+            [0 .. length pllOutTys - 1]+        compInps =+          [ (clkInName variant, DSL.ety clk)+          , (rstName variant, DSL.ety rstHigh)+          ]+        compOuts = zip pllOutNames pllOutTys  <> [("locked", Bit)]+        inps =+          [ (clkInName variant, clk)+          , (rstName variant, rstHigh)+          ]+        outs = zip pllOutNames pllOuts <> [("locked", locked)]++      DSL.compInBlock compName compInps compOuts+      DSL.instDecl Empty compNameId instName [] inps outs++      pure [DSL.constructProduct resultTy (pllOuts <> [pllLock])]+  | otherwise+  = error $ ppShow bbCtx++altpllQsysTemplate+  :: Backend s+  => BlackBoxContext+  -> State s Doc+altpllQsysTemplate bbCtx+  |   (_,stripVoid -> (KnownDomain _ clkInPeriod _ _ _ _),_)+    : _clocksClass+    : (_,stripVoid -> Product _ _ (init -> kdOuts),_)+    : _ <- bbInputs bbCtx+  = let+    clkPeriod (KnownDomain _ p _ _ _ _) = p+    clkPeriod _ =+      error $ "Internal error: not a KnownDomain\n" <> ppShow bbCtx++    clkFreq p = periodToHz (fromInteger p) / 1e6 :: Double++    clkOutPeriods = map clkPeriod kdOuts+    clkLcms = map (lcm clkInPeriod) clkOutPeriods+    clkMults = zipWith quot clkLcms clkOutPeriods+    clkDivs = map (`quot` clkInPeriod) clkLcms+    clkOutFreqs = map clkFreq clkOutPeriods++    qsysParams = TextS.intercalate "\n  "+      [[I.__i|+        <parameter name="PORT_clk#{n}" value="PORT_USED" />+          <parameter name="CLK#{n}_MULTIPLY_BY" value="#{clkMult}" />+          <parameter name="CLK#{n}_DIVIDE_BY" value="#{clkDiv}" />+          <parameter name="CLK#{n}_DUTY_CYCLE" value="50" />+          <parameter name="CLK#{n}_PHASE_SHIFT" value="0" />+        |]+      | (clkMult, clkDiv, n) <- zip3 clkMults clkDivs [(0 :: Word)..]+      ]++    qsysConsts = TextS.intercalate "\n    "+      [[I.__i|+        CT\#PORT_clk#{n} PORT_USED+            CT\#CLK#{n}_MULTIPLY_BY #{clkMult}+            CT\#CLK#{n}_DIVIDE_BY #{clkDiv}+            CT\#CLK#{n}_DUTY_CYCLE 50+            CT\#CLK#{n}_PHASE_SHIFT 0+        |]+      | (clkMult, clkDiv, n) <- zip3 clkMults clkDivs [(0 :: Word)..]+      ]++    qsysPorts =+      TextS.intercalate "\n    "+        [[I.i|IF\#c#{n} {output 0}|] | n <- [0 .. length kdOuts - 1]]++    qsysPrivs = TextS.intercalate "\n    "+      [[I.__i|+        PT\#MULT_FACTOR#{n} #{clkMult}+            PT\#DIV_FACTOR#{n} #{clkDiv}+            PT\#EFF_OUTPUT_FREQ_VALUE#{n} #{clkOutFreq}+            PT\#DUTY_CYCLE#{n} 50.00000000+            PT\#PHASE_SHIFT0 0.00000000+        |]+      | (clkMult, clkDiv, clkOutFreq, n) <-+          zip4 clkMults clkDivs clkOutFreqs [(0 :: Word)..]+      ]++    -- Note [QSys file templates]+    -- This QSys file template was derived from a "full" QSys system with a single+    -- "altpll" IP. Module parameters were then stripped on a trial-and-error+    -- basis to get a template that has the minimal number of parameters, but+    -- still has the desired, working, configuration.+    bbText = [I.__di|+      <?xml version="1.0" encoding="UTF-8"?>+      <system name="$${FILENAME}">+        <module+          name="altpll0"+          kind="altpll"+          enabled="1"+          autoexport="1">+        <parameter name="AVALON_USE_SEPARATE_SYSCLK" value="NO" />+        <parameter name="BANDWIDTH" value="" />+        <parameter name="BANDWIDTH_TYPE" value="AUTO" />+        #{qsysParams}+        <parameter name="COMPENSATE_CLOCK" value="CLK0" />+        <parameter name="INCLK0_INPUT_FREQUENCY" value="#{clkInPeriod}" />+        <parameter name="OPERATION_MODE" value="NORMAL" />+        <parameter name="PLL_TYPE" value="AUTO" />+        <parameter name="PORT_ARESET" value="PORT_USED" />+        <parameter name="PORT_INCLK0" value="PORT_USED" />+        <parameter name="PORT_LOCKED" value="PORT_USED" />+        <parameter name="HIDDEN_IS_FIRST_EDIT" value="0" />+        <parameter name="HIDDEN_CONSTANTS">+          #{qsysConsts}+          CT\#WIDTH_CLOCK 5+          CT\#LPM_TYPE altpll+          CT\#PLL_TYPE AUTO+          CT\#OPERATION_MODE NORMAL+          CT\#COMPENSATE_CLOCK CLK0+          CT\#INCLK0_INPUT_FREQUENCY #{clkInPeriod}+          CT\#PORT_INCLK0 PORT_USED+          CT\#PORT_ARESET PORT_USED+          CT\#BANDWIDTH_TYPE AUTO+          CT\#PORT_LOCKED PORT_USED</parameter>+        <parameter name="HIDDEN_IF_PORTS">+          IF\#phasecounterselect {input 4}+          IF\#locked {output 0}+          IF\#reset {input 0}+          IF\#clk {input 0}+          IF\#phaseupdown {input 0}+          IF\#scandone {output 0}+          IF\#readdata {output 32}+          IF\#write {input 0}+          IF\#scanclk {input 0}+          IF\#phasedone {output 0}+          IF\#address {input 2}+          #{qsysPorts}+          IF\#writedata {input 32}+          IF\#read {input 0}+          IF\#areset {input 0}+          IF\#scanclkena {input 0}+          IF\#scandataout {output 0}+          IF\#configupdate {input 0}+          IF\#phasestep {input 0}+          IF\#scandata {input 0}</parameter>+        <parameter name="HIDDEN_MF_PORTS">+          MF\#areset 1+          MF\#clk 1+          MF\#locked 1+          MF\#inclk 1</parameter>+        <parameter name="HIDDEN_PRIVATES">+          #{qsysPrivs}</parameter>+        </module>+      </system>+      |]+    in+      pure bbText+  | otherwise+  = error $ ppShow bbCtx++alteraPllQsysTemplate+  :: Backend s+  => BlackBoxContext+  -> State s Doc+alteraPllQsysTemplate bbCtx+  |   (_,stripVoid -> kdIn,_)+    : _clocksClass+    : (_,stripVoid -> Product _ _ (init -> kdOuts),_)+    : _ <- bbInputs bbCtx+  = let+    clkFreq (KnownDomain _ p _ _ _ _)+      = periodToHz (fromIntegral p) / 1e6 :: Double+    clkFreq _ =+      error $ "Internal error: not a KnownDomain\n" <> ppShow bbCtx++    clkOuts = TextS.intercalate "\n"+      [[I.i|  <parameter name="gui_output_clock_frequency#{n}" value="#{f}"/>|]+      | (n,f) <- zip [(0 :: Word)..] (map clkFreq kdOuts)+      ]++    -- See Note [QSys file templates] on how this qsys template was derived.+    bbText = [I.__di|+      <?xml version="1.0" encoding="UTF-8"?>+      <system name="$${FILENAME}">+      <module+          name="pll_0"+          kind="altera_pll"+          enabled="1"+          autoexport="1">+        <parameter name="gui_feedback_clock" value="Global Clock" />+        <parameter name="gui_number_of_clocks" value="#{length kdOuts}" />+        <parameter name="gui_operation_mode" value="direct" />+      #{clkOuts}+        <parameter name="gui_pll_mode" value="Integer-N PLL" />+        <parameter name="gui_reference_clock_frequency" value="#{clkFreq kdIn}" />+        <parameter name="gui_use_locked" value="true" />+      </module>+      </system>+      |]+    in+      pure bbText+  | otherwise+  = error $ ppShow bbCtx
+ src/Clash/Primitives/Magic.hs view
@@ -0,0 +1,31 @@+{-|+  Copyright   :  (C) 2022     , Myrtle.ai,+                     2023     , QBayLogic B.V.,+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Blackbox functions for primitives in the @Clash.Magic@ module.+-}++{-# LANGUAGE TemplateHaskellQuotes #-}++module Clash.Primitives.Magic+  ( clashCompileErrorBBF+  ) where++import Data.Either (lefts)+import GHC.Stack (HasCallStack)+import Text.Show.Pretty++import Clash.Core.TermLiteral (termToDataError)+import Clash.Netlist.BlackBox.Types (BlackBoxFunction)+import Clash.Netlist.Types ()++clashCompileErrorBBF :: HasCallStack => BlackBoxFunction+clashCompileErrorBBF _isD _primName args _ty+  |   _hasCallstack+    : (either error id . termToDataError -> msg)+    : _ <- lefts args+  = pure $ Left $ "clashCompileError: " <> msg+  | otherwise+  = pure $ Left $ show 'clashCompileErrorBBF <> ": bad args:\n" <> ppShow args
+ src/Clash/Primitives/Sized/Signed.hs view
@@ -0,0 +1,48 @@+{-|+  Copyright   :  (C) 2021-2022, QBayLogic+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  VHDL Blackbox implementations for 'Clash.Sized.Internal.Signed.fromInteger#'.+-}++{-# LANGUAGE OverloadedStrings #-}+module Clash.Primitives.Sized.Signed (fromIntegerTFvhdl) where++import Control.Monad.State (State)+import Data.Monoid (Ap(getAp))+import Data.Text.Prettyprint.Doc.Extra (Doc, tupled)++import Clash.Backend (Backend, expr)+import Clash.Netlist.Types+  (BlackBoxContext (..), Expr (..), HWType (..), Literal (..), Modifier (..),+   TemplateFunction (..))++fromIntegerTFvhdl :: TemplateFunction+fromIntegerTFvhdl = TemplateFunction used valid fromIntegerTFTemplateVhdl+ where+  used = [0,1]+  valid bbCtx = case bbInputs bbCtx of+    [kn,_] -> case kn of+      (Literal _ (NumLit _),_,True) -> True+      _ -> False+    _ -> False++fromIntegerTFTemplateVhdl+  :: Backend s+  => BlackBoxContext+  -> State s Doc+fromIntegerTFTemplateVhdl bbCtx+  | [(Literal _ (NumLit sz),_,_), (i, Signed szI, _)] <- bbInputs bbCtx+  = getAp $ case compare sz (toInteger szI) of+    LT -> case i of+           Identifier iV m ->+            let sl = Sliced (Signed szI,fromInteger sz-1,0)+                m1 = Just (maybe sl (`Nested` sl) m)+            in expr False (Identifier iV m1)+           _ -> "signed(std_logic_vector(resize(unsigned(std_logic_vector(" <> expr False i <> "))," <> expr False (Literal Nothing (NumLit sz)) <> ")))"+    EQ -> expr False i+    GT -> "resize" <> tupled (sequenceA [expr False i+                                        ,expr False (Literal Nothing (NumLit sz))])+  | otherwise+  = error ("fromIntegerTFTemplateVhdl: bad bInputs: " <> show (bbInputs bbCtx))
+ src/Clash/Primitives/Sized/ToInteger.hs view
@@ -0,0 +1,141 @@+{-|+  Copyright   :  (C) 2020,2022 QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Blackbox implementations for "Clash.Sized.Internal.*.toInteger#".+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-}+module Clash.Primitives.Sized.ToInteger+  ( bvToIntegerVerilog+  , bvToIntegerVHDL+  , indexToIntegerVerilog+  , indexToIntegerVHDL+  , signedToIntegerVerilog+  , signedToIntegerVHDL+  , unsignedToIntegerVerilog+  , unsignedToIntegerVHDL+  )+where++import qualified Control.Lens as Lens+import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import Data.Text.Lazy (pack)+import System.IO (hPutStrLn, stderr)+import Text.Trifecta.Result (Result(Success))++#if MIN_VERSION_ghc(9,8,0)+import GHC.Unit.Module.Warnings (emptyWarningCategorySet)+import GHC.Utils.Error+  (DiagOpts(..), mkPlainDiagnostic, mkPlainMsgEnvelope, pprLocMsgEnvelopeDefault)+import GHC.Utils.Outputable+  (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>),+   defaultSDocContext )+import qualified GHC.Utils.Outputable as Outputable+import GHC.Types.Error (DiagnosticReason (WarningWithoutFlag))+import GHC.Types.SrcLoc (isGoodSrcSpan)+#else+import GHC.Utils.Error+  (DiagOpts(..), mkPlainDiagnostic, mkPlainMsgEnvelope, pprLocMsgEnvelopeDefault)+import GHC.Utils.Outputable+  (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>),+   defaultSDocContext )+import qualified GHC.Utils.Outputable as Outputable+import GHC.Types.Error (DiagnosticReason (WarningWithoutFlag))+import GHC.Types.SrcLoc (isGoodSrcSpan)+#endif++import Clash.Annotations.Primitive (HDL (Verilog,VHDL))+import Clash.Core.Type (Type (LitTy), LitTy (NumTy))+import Clash.Netlist.BlackBox.Parser (runParse)+import Clash.Netlist.BlackBox.Types+  (BlackBoxFunction, BlackBoxMeta (bbKind), TemplateKind (TExpr),+   emptyBlackBoxMeta)+import Clash.Netlist.Types+  (BlackBox (BBTemplate), HWType (..), curCompNm, intWidth)+import Clash.Util (clogBase)++bvToIntegerVerilog, bvToIntegerVHDL, indexToIntegerVerilog,+  indexToIntegerVHDL,  signedToIntegerVerilog, signedToIntegerVHDL,+  unsignedToIntegerVerilog, unsignedToIntegerVHDL :: BlackBoxFunction++bvToIntegerVerilog = toIntegerBB Verilog (BitVector 0)+bvToIntegerVHDL = toIntegerBB VHDL (BitVector 0)+indexToIntegerVerilog = toIntegerBB Verilog (Index 0)+indexToIntegerVHDL = toIntegerBB VHDL (Index 0)+signedToIntegerVerilog = toIntegerBB Verilog (Signed 0)+signedToIntegerVHDL = toIntegerBB VHDL (Signed 0)+unsignedToIntegerVerilog = toIntegerBB Verilog (Unsigned 0)+unsignedToIntegerVHDL = toIntegerBB VHDL (Unsigned 0)++toIntegerBB :: HDL -> HWType -> BlackBoxFunction+toIntegerBB hdl hty _isD _primName args _ty = do+  case args of+    (Right (LitTy (NumTy i)):_) -> do+      iw <- Lens.view intWidth+      let i1 = width i+      when (fromInteger i1 > iw) $ do+        (_,sp) <- Lens.use curCompNm+        let srcInfo1 | isGoodSrcSpan sp = srcInfo+                     | otherwise        = empty+#if MIN_VERSION_ghc(9,8,0)+            opts     = DiagOpts mempty mempty emptyWarningCategorySet emptyWarningCategorySet False False Nothing defaultSDocContext+            diag     = mkPlainDiagnostic WarningWithoutFlag [] (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)+            warnMsg1 = mkPlainMsgEnvelope opts sp diag+            warnMsg2 = pprLocMsgEnvelopeDefault warnMsg1+#else+            opts     = DiagOpts mempty mempty False False Nothing defaultSDocContext+            diag     = mkPlainDiagnostic WarningWithoutFlag [] (warnMsg i1 iw $+$ blankLine $+$ srcInfo1)+            warnMsg1 = mkPlainMsgEnvelope opts sp diag+            warnMsg2 = pprLocMsgEnvelopeDefault warnMsg1+#endif++        liftIO (hPutStrLn stderr (showSDocUnsafe warnMsg2))+    _ -> return ()+  return ((meta,) <$> bb)+ where+  meta = emptyBlackBoxMeta{bbKind=TExpr}++  bb = BBTemplate <$> case runParse (pack bbText) of+         Success t -> Right t+         _         -> Left "internal error: parse fail"++  bbText = case hdl of+    VHDL -> case hty of+      BitVector {} -> "~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(unsigned(~ARG[1]),~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"+      Index {}     -> "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"+      Signed {}    -> "~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEto_signed(0,64)~FI"+      Unsigned {}  -> "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"+      _            -> error "internal error"+    _ -> case hty of+      BitVector {} -> "~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[bv][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[bv][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"+      Index {}     -> "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$unsigned(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"+      Signed {}    -> "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$signed(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {~VAR[i][0][~SIZE[~TYP[0]]-1]}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"+      Unsigned {}  -> "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$unsigned(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"+      _            -> error "internal error"++  tyName = case hty of+    BitVector {} -> text "BitVector"+    Index {} -> text "Index"+    Signed {} -> text "Signed"+    Unsigned {} -> text "Unsigned"+    _ -> error "internal error"++  width i = case hty of+    Index {} -> maybe 0 toInteger (clogBase 2 i)+    _ -> i++  warnMsg i iw =+   tyName Outputable.<> text ".toInteger: Integer width," <+> int iw Outputable.<>+   text ", is smaller than" <+> tyName <+> text "width," <+> integer i Outputable.<>+   text ". Dropping MSBs." $+$+   text "Are you using 'fromIntegral' to convert between types?" <+>+   text "Use 'bitCoerce' instead."++  srcInfo =+   text "NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." $$+   text "The actual location of the error can be in a function that is inlined." $$+   text "To prevent inlining of those functions, annotate them with a NOINLINE pragma."
+ src/Clash/Primitives/Sized/Vector.hs view
@@ -0,0 +1,312 @@+{-|+  Copyright   :  (C) 2020-2022 QBayLogic B.V.+                     2022     , Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Blackbox implementations for functions in "Clash.Sized.Vector".+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Primitives.Sized.Vector where++import           Control.Monad                      (replicateM, zipWithM)+import           Control.Monad.State                (State)+import qualified Control.Lens                       as Lens+import           Data.Either                        (rights)+import           Data.List.Extra                    (iterateNM)+import           Data.Maybe                         (fromMaybe, listToMaybe)+import           Data.Monoid                        (Ap(getAp))+import           Data.Text.Extra                    (showt)+import           Data.Text.Prettyprint.Doc.Extra+  (Doc, string, renderLazy, layoutPretty, LayoutOptions(..),+   PageWidth(AvailablePerLine))+import           Text.Trifecta.Result               (Result(Success))+import qualified Data.String.Interpolate            as I+import           GHC.Stack                          (HasCallStack)++import           Clash.Backend+  (Backend, hdlTypeErrValue, expr, blockDecl)+import           Clash.Core.TermInfo                (isVar)+import           Clash.Core.Type+  (Type(LitTy), LitTy(NumTy), coreView)+import           Clash.Netlist.BlackBox             (isLiteral)+import           Clash.Netlist.BlackBox.Util        (renderElem)+import           Clash.Netlist.BlackBox.Parser      (runParse)+import           Clash.Netlist.BlackBox.Types+  (BlackBoxFunction, BlackBoxMeta(..), TemplateKind(TExpr, TDecl),+   Element(Component, Typ, TypElem, Text), Decl(Decl), emptyBlackBoxMeta)+import           Clash.Netlist.Types+  (Identifier, TemplateFunction, BlackBoxContext, HWType(Vector), Usage(Cont),+   Declaration(..), Expr(Literal,Identifier,DataCon,BlackBoxE), Literal(NumLit),+   BlackBox(BBTemplate, BBFunction), TemplateFunction(..),+   Modifier(Indexed, Nested, DC), HWType(..), BlackBoxContext(..),+   emptyBBContext, tcCache)+import qualified Clash.Netlist.Id                   as Id+import           Clash.Netlist.Util                 (typeSize)+import qualified Clash.Primitives.DSL               as Prim+import           Clash.Primitives.DSL+  (declarationReturn, instHO, tInputs, tExprToInteger)++import           Clash.Util                         (curLoc)++-- | Blackbox function for 'Clash.Sized.Vector.iterateI'+iterateBBF :: HasCallStack => BlackBoxFunction+iterateBBF _isD _primName args _resTy = do+  tcm <- Lens.view tcCache+  pure (Right (meta tcm, bb))+ where+  bb = BBFunction "Clash.Primitives.Sized.Vector.iterateBBF" 0 iterateTF+  vecLength tcm =+    case coreView tcm <$> rights args of+      (LitTy (NumTy 0)):_ -> error "Unexpected empty vector in 'iterateBBF'"+      (LitTy (NumTy n)):_ -> fromInteger (n - 1)+      vl -> error $ "Unexpected vector length: " ++ show (listToMaybe vl)+  meta tcm = emptyBlackBoxMeta {+      bbKind=TDecl+    , bbFunctionPlurality=[(1, vecLength tcm)]+    }++-- | Type signature of function we're generating netlist for:+--+--   iterateI :: KnownNat n => (a -> a) -> a -> Vec n a+--+iterateTF :: TemplateFunction+iterateTF = TemplateFunction [] (const True) iterateTF'++iterateTF'+  :: forall s+   . (HasCallStack, Backend s)+  => BlackBoxContext+  -> State s Doc+iterateTF' bbCtx+  | [ (fromMaybe (error "n") . tExprToInteger -> n, _)+    , _hoFunction+    , (a, aType)+    ] <- tInputs bbCtx+  , let aTemplateType = [TypElem (Typ (Just 2))]+  , let inst arg = instHO bbCtx 1 (aType, aTemplateType) [(arg, aTemplateType)]+  = declarationReturn bbCtx "iterateI" (fmap pure . Prim.vec =<< iterateNM (fromInteger n) inst a)+  | otherwise+  =  error $ "Unexpected number of arguments: " ++ show (length (bbInputs bbCtx))++data FCall =+  FCall+    Identifier -- left+    Identifier -- right+    Identifier -- result++-- | Calculates the number of function calls needed for an evaluation of+-- 'Clash.Sized.Vector.fold', given the length of the vector given to fold.+foldFunctionPlurality :: HasCallStack => Int -> Int+foldFunctionPlurality 1 = 0+foldFunctionPlurality 2 = 1+foldFunctionPlurality n+  | n <= 0 = error $ "functionPlurality: unexpected n: " ++ show n+  | otherwise =+      let (d, r) = n `divMod` 2 in+      1 + foldFunctionPlurality d + foldFunctionPlurality (d+r)++-- | Blackbox function for 'Clash.Sized.Vector.fold'+foldBBF :: HasCallStack => BlackBoxFunction+foldBBF _isD _primName args _resTy = do+  tcm <- Lens.view tcCache+  let+    bb = BBFunction "Clash.Primitives.Sized.Vector.foldTF" 0 foldTF+    vecLengthMinusOne = case rights args of+      (l:_) -> l+      _ -> error ("foldBBF: bad Vec: " <> show args)+    vecLength =+      case coreView tcm vecLengthMinusOne of+        (LitTy (NumTy n)) -> n + 1+        vl -> error $ "Unexpected vector length: " ++ show vl+    funcPlural = foldFunctionPlurality (fromInteger vecLength)+    meta = emptyBlackBoxMeta {bbKind=TDecl, bbFunctionPlurality=[(0, funcPlural)]}+  pure (Right (meta, bb))++-- | Type signature of function we're generating netlist for:+--+--   fold :: (a -> a -> a) -> Vec (n + 1) a -> a+--+-- The implementation promises to create a (balanced) tree structure.+foldTF :: TemplateFunction+foldTF = TemplateFunction [] (const True) foldTF'++foldTF' :: forall s . (HasCallStack, Backend s) => BlackBoxContext -> State s Doc+foldTF' bbCtx@(bbInputs -> [_f, (vec, vecType@(Vector n aTy), _isLiteral)]) = do+  -- Create an id for every element in the vector+  baseId <- Id.make "acc_0"+  vecIds <- replicateM n (Id.next baseId)++  vecId <- Id.make "vec"+  let vecDecl = sigDecl vecType vecId+      vecAssign = Assignment vecId Cont vec+      elemAssigns = zipWith3 Assignment vecIds (repeat Cont) (map (iIndex vecId) [0..])+      resultId =+        case bbResults bbCtx of+          [(Identifier t _, _)] -> t+          _ -> error "Unexpected result identifier"++  -- Create a list of function calls to be made (creates identifiers for+  -- intermediate result signals)+  (concat -> fCalls, result) <- mkTree 1 vecIds++  let intermediateResultIds = concatMap (\(FCall l r _) -> [l, r]) fCalls+      sigDecls = fmap (sigDecl aTy) (result : intermediateResultIds)+      resultAssign = Assignment resultId Cont (Identifier result Nothing)++  callDecls <- zipWithM callDecl [0..] fCalls+  foldNm <- Id.make "fold"++  getAp $ blockDecl foldNm $+    resultAssign :+    vecAssign :+    vecDecl :+    elemAssigns +++    sigDecls +++    callDecls++ where+  callDecl :: Int -> FCall -> State s Declaration+  callDecl fSubPos (FCall a b r) = do+    rendered0 <- string =<< (renderElem bbCtx call <*> pure 0)+    let layout = LayoutOptions (AvailablePerLine 120 0.4)+        rendered1 = renderLazy (layoutPretty layout rendered0)+    pure (+      BlackBoxD+        "__FOLD_BB_INTERNAL__"+        [] [] []+        (BBTemplate [Text rendered1])+        (emptyBBContext "__FOLD_BB_INTERNAL__")+        )+   where+    call  = Component (Decl fPos fSubPos (resEl:aEl:[bEl]))+    elTyp = [TypElem (Typ (Just vecPos))]+    resEl = ([Text (Id.toLazyText r)], elTyp)+    aEl   = ([Text (Id.toLazyText a)], elTyp)+    bEl   = ([Text (Id.toLazyText b)], elTyp)++  -- Argument no. of function+  fPos = 0++  -- Argument no. of vector+  vecPos = 1++  -- Create the whole tree+  mkTree+    :: Int+    -- ^ Current level+    -> [Identifier]+    -- ^ Elements left to process+    -> State s ( [[FCall]]    -- function calls to be rendered+               , Identifier -- result signal+               )+  mkTree _lvl []  = error "Unreachable?"+  mkTree _lvl [res] = pure ([], res)+  mkTree lvl results0  = do+    (calls0, results1) <- mkLevel (lvl, 0) results0+    (calls1, result) <- mkTree (lvl+1) results1+    pure (calls0 : calls1, result)++  -- Create a single layer of a tree+  mkLevel+    :: (Int, Int)+    -- ^ (level, offset)+    -> [Identifier]+    -> State s ([FCall], [Identifier])+  mkLevel (!lvl, !offset) (a:b:rest) = do+    c <- Id.makeBasic ("acc_" <> showt lvl <> "_" <> showt offset)+    (calls, results) <- mkLevel (lvl, offset+1) rest+    pure (FCall a b c:calls, c:results)+  mkLevel _lvl rest =+    pure ([], rest)++  -- Simple wire without comment+  sigDecl :: HWType -> Identifier -> Declaration+  sigDecl typ nm = NetDecl Nothing nm typ++  -- Index the intermediate vector. This uses a hack in Clash: the 10th+  -- constructor of Vec doesn't exist; using it will be interpreted by the+  -- HDL backends as vector indexing.+  iIndex :: Identifier -> Int -> Expr+  iIndex vecId i = Identifier vecId (Just (Indexed (vecType, 10, i)))++foldTF' args =+  error $ "Unexpected number of arguments: " ++ show (length (bbInputs args))++indexIntVerilog ::  BlackBoxFunction+indexIntVerilog _isD _primName args _ty = return bb+ where+  meta bbKi = emptyBlackBoxMeta{bbKind=bbKi}++  bb = case args of+    [_nTy,_aTy,_kn,Left v,Left ix] | isLiteral ix && isVar v ->+      Right (meta TExpr, BBFunction "Clash.Primitives.Sized.Vector.indexIntVerilogTF" 0 indexIntVerilogTF)+    [_nTy,_aTy,_kn,_v,Left ix] | isLiteral ix ->+      case runParse bbTextLitIx of+        Success t -> Right (meta TDecl, BBTemplate t)+        _         -> Left "internal error: parse fail"++    _ ->+      case runParse bbText of+        Success t -> Right (meta TDecl, BBTemplate t)+        _         -> Left "internal error: parse fail"++  bbText = [I.__i|+    // index begin+    ~IF~SIZE[~TYP[1]]~THENwire ~TYPO ~GENSYM[vecArray][0] [0:~LIT[0]-1];+    genvar ~GENSYM[i][2];+    ~GENERATE+    for (~SYM[2]=0; ~SYM[2] < ~LIT[0]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3]+      assign ~SYM[0][(~LIT[0]-1)-~SYM[2]] = ~VAR[vecFlat][1][~SYM[2]*~SIZE[~TYPO]+:~SIZE[~TYPO]];+    end+    ~ENDGENERATE+    assign ~RESULT = ~SYM[0][~ARG[2]];~ELSEassign ~RESULT = ~ERRORO;~FI+    // index end+    |]++  bbTextLitIx = [I.__i|+    // index lit begin+    ~IF~SIZE[~TYP[1]]~THENassign ~RESULT = ~VAR[vec][1][~SIZE[~TYP[1]]-1-~LIT[2]*~SIZE[~TYPO] -: ~SIZE[~TYPO]];~ELSEassign ~RESULT = ~ERRORO;~FI+    // index lit end+    |]+++indexIntVerilogTF :: TemplateFunction+indexIntVerilogTF = TemplateFunction used valid indexIntVerilogTemplate+ where+  used  = [1,2]+  valid = const True++indexIntVerilogTemplate+  :: Backend s+  => BlackBoxContext+  -> State s Doc+indexIntVerilogTemplate bbCtx+  | [  _kn, (vec, vTy, _), (ix, _, _)] <- bbInputs bbCtx+  , [(_,rTy)] <- bbResults bbCtx+  = getAp $ case typeSize vTy of+  0 -> hdlTypeErrValue rTy+  _ -> case vec of+    Identifier i mM -> do+      let+        ixI :: Expr ->  Int+        ixI ix0 = case ix0 of+          Literal _ (NumLit j) ->+            fromInteger j+          DataCon (Signed _) (DC (Void{},_)) [Literal (Just (Signed _,_)) (NumLit j)] ->+            fromInteger j+          BlackBoxE "GHC.Types.I#" _lib _use _incl _templ Context{bbInputs=[(Literal _ (NumLit j),_,_)]} _paren ->+            fromInteger j+          _ ->+            error ($(curLoc) ++ "Unexpected literal: " ++ show ix)+      case mM of+        Just m ->+            expr False (Identifier i (Just (Nested m (Indexed (vTy,10,ixI ix)))))+        _ -> expr False (Identifier i (Just (Indexed (vTy,10,ixI ix))))+    _ -> error ($(curLoc) ++ "Expected Identifier: " ++ show vec)+  | otherwise+  = error ("indexIntVerilogTemplate: bad bbContext: " <> show bbCtx)
+ src/Clash/Primitives/Types.hs view
@@ -0,0 +1,333 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016-2017, Myrtle Software Ltd+                    2018     , Google Inc.+                    2021     , QBayLogic B.V.+                    2022     , Google Inc.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Type and instance definitions for Primitive+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Primitives.Types+  ( TemplateSource(..)+  , TemplateKind(..)+  , TemplateFormat(..)+  , BlackBoxFunctionName(..)+  , Primitive(..)+  , UsedArguments(..)+  , GuardedCompiledPrimitive+  , GuardedResolvedPrimitive+  , PrimMap+  , UnresolvedPrimitive+  , ResolvedPrimitive+  , ResolvedPrimMap+  , CompiledPrimitive+  , CompiledPrimMap+  ) where++import {-# SOURCE #-} Clash.Netlist.Types (BlackBox, Usage(..))+import           Clash.Annotations.Primitive  (PrimitiveGuard)+import           Clash.Core.Term (WorkInfo (..))+import           Clash.Netlist.BlackBox.Types+  (BlackBoxFunction, BlackBoxTemplate, TemplateKind (..), RenderVoid(..))+import           Control.Applicative          ((<|>))+import           Control.DeepSeq              (NFData)+import           Control.Monad                (when)+import           Data.Aeson+  (FromJSON (..), Value (..), (.:), (.:?), (.!=))+import           Data.Aeson.Types             (Parser)+import           Data.Binary                  (Binary)+import           Data.Char                    (isUpper, isLower, isAlphaNum)+import           Data.Either                  (lefts)+import           Data.Hashable                (Hashable)+import qualified Data.HashMap.Strict          as H+import           Data.List                    (intercalate)+import           Data.Maybe                   (isJust)+import qualified Data.Text                    as S+import           Data.Text.Lazy               (Text)+import           GHC.Generics                 (Generic)+import           GHC.Stack                    (HasCallStack)+import           Text.Read                    (readMaybe)++import qualified Data.Aeson.KeyMap as KeyMap++-- | An unresolved primitive still contains pointers to files.+type UnresolvedPrimitive = Primitive Text ((TemplateFormat,BlackBoxFunctionName),Maybe TemplateSource) (Maybe S.Text) (Maybe TemplateSource)++-- | A parsed primitive does not contain pointers to filesystem files anymore,+-- but holds uncompiled @BlackBoxTemplate@s and @BlackBoxFunction@s.+type ResolvedPrimitive        = Primitive Text ((TemplateFormat,BlackBoxFunctionName),Maybe Text) () (Maybe Text)+type GuardedResolvedPrimitive = PrimitiveGuard ResolvedPrimitive+type ResolvedPrimMap          = PrimMap GuardedResolvedPrimitive++-- | A compiled primitive has compiled all templates and functions from its+-- @ResolvedPrimitive@ counterpart. The Int in the tuple is a hash of the+-- (uncompiled) BlackBoxFunction.+type CompiledPrimitive        = Primitive BlackBoxTemplate BlackBox () (Int, BlackBoxFunction)+type GuardedCompiledPrimitive = PrimitiveGuard CompiledPrimitive+type CompiledPrimMap          = PrimMap GuardedCompiledPrimitive++-- | A @PrimMap@ maps primitive names to a @Primitive@+type PrimMap a = H.HashMap S.Text a++-- | A BBFN is a parsed version of a fully qualified function name. It is+-- guaranteed to have at least one module name which is not /Main/.+data BlackBoxFunctionName =+  BlackBoxFunctionName [String] String+    deriving (Eq, Generic, NFData, Binary, Hashable)++instance Show BlackBoxFunctionName where+  show (BlackBoxFunctionName mods funcName) =+    "BBFN<" ++ intercalate "." mods ++ "." ++ funcName ++ ">"++-- | Quick and dirty implementation of Text.splitOn for Strings+splitOn :: String -> String -> [String]+splitOn (S.pack -> sep) (S.pack -> str) =+  map S.unpack $ S.splitOn sep str++-- | Parses a string into a list of modules and a function name. I.e., it parses+-- the string 'Clash.Primitives.Types.parseBBFN' to+-- @["Clash", "Primitives",Types"]@ and @"parseBBFN"@.+-- The result is stored as a BlackBoxFunctionName.+parseBBFN+  :: HasCallStack+  => String+  -> Either String BlackBoxFunctionName+parseBBFN bbfn =+  case splitOn "." bbfn of+    []  -> Left $ "Empty function name: " ++ bbfn+    [_] -> Left $ "No module or function defined: " ++ bbfn+    nms ->+      let (mods, func) = (init nms, last nms) in+      let errs = lefts $ checkFunc func : map checkMod mods in+      case errs of+        [] -> Right $ BlackBoxFunctionName mods func+        e:_ -> Left $ "Error while parsing " ++ show bbfn ++ ": " ++ e+  where+    checkMod mod'+      | m':_ <- mod'+      , isLower m' =+          Left $ "Module name cannot start with lowercase: " ++ mod'+      | any (not . isAlphaNum) mod' =+          Left $ "Module name must be alphanumerical: " ++ mod'+      | otherwise =+          Right mod'++    checkFunc func+      | f:_ <- func+      , isUpper f =+          Left $ "Function name must start with lowercase: " ++ func+      | otherwise =+          Right func++data TemplateSource+  = TFile FilePath+  -- ^ Template source stored in file on filesystem+  | TInline Text+  -- ^ Template stored inline+  deriving (Show, Eq, Hashable, Generic, NFData)+++data TemplateFormat+  = TTemplate+  | THaskell+  deriving (Show, Generic, Eq, Hashable, NFData)++-- | Data type to indicate what arguments are in use by a BlackBox+data UsedArguments+  = UsedArguments [Int]+  -- ^ Only these are used+  | IgnoredArguments [Int]+  -- ^ All but these are used+  deriving (Show, Generic, Eq, Hashable, NFData, Binary)++-- | Externally defined primitive+data Primitive a b c d+  -- | Primitive template written in a Clash specific templating language+  = BlackBox+  { name      :: !S.Text+    -- ^ Name of the primitive+  , workInfo  :: WorkInfo+    -- ^ Whether the primitive does any work, i.e. takes chip area+  , renderVoid :: RenderVoid+    -- ^ Whether this primitive should be rendered when its result type is+    -- void. Defaults to 'NoRenderVoid'.+  , multiResult :: Bool+    -- ^ Wether this blackbox assigns its results to multiple variables. See+    -- 'Clash.Normalize.Transformations.setupMultiResultPrim'+  , kind      :: TemplateKind+    -- ^ Whether this results in an expression or a declaration+  , warning  :: c+    -- ^ A warning to be outputted when the primitive is instantiated.+    -- This is intended to be used as a warning for primitives that are not+    -- synthesizable, but may also be used for other purposes.+  , outputUsage :: Usage+    -- ^ How the result is assigned in HDL. This is used to determine the+    -- type of declaration used to render the result (wire/reg or+    -- signal/variable). The default usage is continuous assignment.+  , libraries :: [a]+    -- ^ VHDL only: add /library/ declarations for the given names+  , imports   :: [a]+    -- ^ VHDL only: add /use/ declarations for the given names+  , functionPlurality :: [(Int, Int)]  -- Using map ruins Hashable instance+    -- ^ Indicates how often a function will be instantiated in a blackbox. For+    -- example, consider the following higher-order function that creates a tree+    -- structure:+    --+    --   fold :: (a -> a -> a) -> Vec n a -> a+    --+    -- In order to generate HDL for an instance of fold we need log2(n) calls+    -- to the first argument, `a -> a -> a` (plus a few more if n is not a+    -- power of two). Note that this only targets multiple textual instances+    -- of the function. If you can generate the HDL using a for-loop and only+    -- need to call ~INST once, you don't have to worry about this option. See+    -- the blackbox for 'Clash.Sized.Vector.map' for an example of this.+    --+    -- Right now, option can only be generated by BlackBoxHaskell. It cannot be+    -- used within JSON primitives. To see how to use this, see the Haskell+    -- blackbox for 'Clash.Sized.Vector.fold'.+  , includes  :: [((S.Text,S.Text),b)]+    -- ^ Create files to be included with the generated primitive. The fields+    -- are ((name, extension), content), where content is a template of the file+    -- Defaults to @[]@ when not specified in the /.primitives/ file+  , resultNames :: [b]+    -- ^ (Maybe) Control the generated name of the result+  , resultInits :: [b]+    -- ^ (Maybe) Control the initial/power-up value of the result+  , template :: b+    -- ^ Used to indiciate type of template (declaration or expression). Will be+    -- filled with @Template@ or an @Either decl expr@.+  }+  -- | Primitive template rendered by a Haskell function (given as raw source code)+  | BlackBoxHaskell+  { name :: !S.Text+    -- ^ Name of the primitive+  , workInfo  :: WorkInfo+    -- ^ Whether the primitive does any work, i.e. takes chip area+  , usedArguments :: UsedArguments+  -- ^ Arguments used by blackbox. Used to remove arguments during normalization.+  , multiResult :: Bool+  -- ^ Wether this blackbox assigns its results to multiple variables. See+  -- 'Clash.Normalize.Transformations.setupMultiResultPrim'+  , functionName :: BlackBoxFunctionName+  , function :: d+  -- ^ Holds blackbox function and its hash, (Int, BlackBoxFunction), in a+  -- CompiledPrimitive.+  }+  -- | A primitive that carries additional information. These are "real"+  -- primitives, hardcoded in the compiler. For example: 'mapSignal' in+  -- @GHC2Core.coreToTerm@.+  | Primitive+  { name     :: !S.Text+    -- ^ Name of the primitive+  , workInfo  :: WorkInfo+    -- ^ Whether the primitive does any work, i.e. takes chip area+  , primSort :: !Text+    -- ^ Additional information+  }+  deriving (Show, Generic, NFData, Binary, Eq, Hashable, Functor)++instance FromJSON UnresolvedPrimitive where+  parseJSON (Object v) =+    case KeyMap.toList v of+      [(conKey,Object conVal)] ->+        case conKey of+          "BlackBoxHaskell"  -> do+            usedArgs <- conVal .:? "usedArguments"+            ignoredArgs <- conVal .:? "ignoredArguments"+            args <-+              case (usedArgs, ignoredArgs) of+                (Nothing, Nothing) -> pure (IgnoredArguments [])+                (Just a, Nothing) -> pure (UsedArguments a)+                (Nothing, Just a) -> pure (IgnoredArguments a)+                (Just _, Just _) ->+                  fail "[8] Don't use both 'usedArguments' and 'ignoredArguments'"++            name' <- conVal .: "name"+            wf    <- ((conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable)+            fName <- conVal .: "templateFunction"+            isMultiResult <- conVal .:? "multiResult" .!= False+            templ <- (Just . TInline <$> conVal .: "template")+                 <|> (Just . TFile   <$> conVal .: "file")+                 <|> (pure Nothing)+            fName' <- either fail return (parseBBFN fName)+            return (BlackBoxHaskell name' wf args isMultiResult fName' templ)+          "BlackBox"  -> do+            outReg <- conVal .:? "outputReg" :: Parser (Maybe Bool)++            when (isJust outReg) .+              fail $ mconcat+                [ "[9] 'outputReg' is no longer a recognized key.\n"+                , "Use 'outputUsage: Continuous|NonBlocking|Blocking' instead."+                ]++            BlackBox <$> conVal .: "name"+                     <*> (conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable+                     <*> conVal .:? "renderVoid" .!= NoRenderVoid+                     <*> conVal .:? "multiResult" .!= False+                     <*> (conVal .: "kind" >>= parseTemplateKind)+                     <*> conVal .:? "warning"+                     <*> conVal .:? "outputUsage" .!= Cont+                     <*> conVal .:? "libraries" .!= []+                     <*> conVal .:? "imports" .!= []+                     <*> pure [] -- functionPlurality not supported in json+                     <*> (conVal .:? "includes" .!= [] >>= traverse parseInclude)+                     <*> (conVal .:? "resultName" >>= maybe (pure Nothing) parseResult) .!= []+                     <*> (conVal .:? "resultInit" >>= maybe (pure Nothing) parseResult) .!= []+                     <*> parseTemplate conVal+          "Primitive" ->+            Primitive <$> conVal .: "name"+                      <*> (conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable+                      <*> conVal .: "primType"++          e -> fail $ "[1] Expected: BlackBox or Primitive object, got: " ++ show e+      e -> fail $ "[2] Expected: BlackBox or Primitive object, got: " ++ show e+    where+      parseTemplate c =+        (,) <$> ((,) <$> (c .:? "format" >>= traverse parseTemplateFormat) .!= TTemplate+                     <*> (c .:? "templateFunction" >>= traverse parseBBFN') .!= defTemplateFunction)+            <*> (Just . TInline <$> c .: "template" <|>+                 Just . TFile   <$> c .: "file" <|>+                 pure Nothing)++      parseInclude c =+        (,) <$> ((,) <$> c .: "name" <*> c .: "extension")+            <*> parseTemplate c++      parseTemplateKind (String "Declaration") = pure TDecl+      parseTemplateKind (String "Expression")  = pure TExpr+      parseTemplateKind c = fail ("[4] Expected: Declaration or Expression, got " ++ show c)++      parseTemplateFormat (String "Template") = pure TTemplate+      parseTemplateFormat (String "Haskell")  = pure THaskell+      parseTemplateFormat c = fail ("[5] unexpected format: " ++ show c)++      parseWorkInfo (String "Constant") = pure (Just WorkConstant)+      parseWorkInfo (String "Never")    = pure (Just WorkNever)+      parseWorkInfo (String "Variable") = pure (Just WorkVariable)+      parseWorkInfo (String "Always")   = pure (Just WorkAlways)+      parseWorkInfo (parseWorkIdentity -> wi@Just{}) = pure wi+      parseWorkInfo c = fail ("[6] unexpected workInfo: " ++ show c)++      parseWorkIdentity arg = do+        String str   <- return arg+        [iStr,xsStr] <- words . S.unpack <$> S.stripPrefix "Identity" str+        WorkIdentity <$> readMaybe iStr <*> readMaybe xsStr++      parseBBFN' = either fail return . parseBBFN++      defTemplateFunction = BlackBoxFunctionName ["Template"] "template"++      parseResult (Object c) =+        Just . pure <$> parseTemplate c+      parseResult e = fail $ "[7] unexpected result: " ++ show e++  parseJSON unexpected =+    fail $ "[3] Expected: BlackBox or Primitive object, got: " ++ show unexpected
+ src/Clash/Primitives/Util.hs view
@@ -0,0 +1,272 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2017     , Myrtle Software Ltd+                    2018     , Google Inc.+                    2021     , QBayLogic B.V.+                    2022     , Google Inc.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Utility functions to generate Primitives+-}++{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Clash.Primitives.Util+  ( generatePrimMap+  , hashCompiledPrimMap+  , constantArgs+  , decodeOrErrJson+  , decodeOrErrYaml+  , getFunctionPlurality+  ) where++import           Control.DeepSeq        (force)+import           Control.Monad          (forM)+import           Data.Aeson.Extra       (decodeOrErrJson, decodeOrErrYaml)+import qualified Data.ByteString.Lazy   as LZ+import qualified Data.HashMap.Lazy      as HashMap+import qualified Data.HashMap.Strict    as HashMapStrict+import qualified Data.Set               as Set+import           Data.Hashable          (hash)+import           Data.List              (isSuffixOf, sort, find)+import           Data.Maybe             (fromMaybe)+import qualified Data.Text              as TS+import           Data.Text.Lazy         (Text)+import qualified Data.Text.Lazy.IO      as T+import           GHC.Stack              (HasCallStack)+import qualified System.Directory       as Directory+import qualified System.FilePath        as FilePath+import           System.IO.Error        (tryIOError)++import           Clash.Annotations.Primitive+  ( PrimitiveGuard(HasBlackBox, DontTranslate)+  , PrimitiveWarning(WarnNonSynthesizable)+  , extractPrim, extractWarnings)+import           Clash.Core.Term        (Term)+import           Clash.Core.Type        (Type)+import           Clash.Primitives.Types+  ( Primitive(BlackBox), CompiledPrimitive, ResolvedPrimitive, ResolvedPrimMap+  , includes, template, TemplateSource(TFile, TInline), Primitive(..)+  , UnresolvedPrimitive, CompiledPrimMap, GuardedResolvedPrimitive)+import           Clash.Netlist.Types    (BlackBox(..), NetlistMonad)+import           Clash.Netlist.Util     (preserveState)+import           Clash.Netlist.BlackBox.Util+  (walkElement)+import           Clash.Netlist.BlackBox.Types+  (Element(Const, Lit), BlackBoxMeta(..))++hashCompiledPrimitive :: CompiledPrimitive -> Int+hashCompiledPrimitive (Primitive {name, primSort}) = hash (name, primSort)+hashCompiledPrimitive (BlackBoxHaskell {function}) = fst function+hashCompiledPrimitive (BlackBox {name, kind, outputUsage, libraries, imports, includes, template}) =+  hash (name, kind, outputUsage, libraries, imports, includes', hashBlackbox template)+    where+      includes' = map (\(nms, bb) -> (nms, hashBlackbox bb)) includes+      hashBlackbox (BBTemplate bbTemplate) = hash bbTemplate+      hashBlackbox (BBFunction bbName bbHash _bbFunc) = hash (bbName, bbHash)++-- | Hash a compiled primitive map. It needs a separate function (as opposed to+-- just 'hash') as it might contain (obviously unhashable) Haskell functions. This+-- function takes the hash value stored with the function instead.+hashCompiledPrimMap :: CompiledPrimMap -> Int+hashCompiledPrimMap cpm = hash (map (fmap hashCompiledPrimitive) orderedValues)+  where+    -- TODO: switch to 'normal' map instead of hashmap?+    orderedKeys   = sort (HashMap.keys cpm)+    orderedValues = map (cpm HashMapStrict.!) orderedKeys++resolveTemplateSource+  :: HasCallStack+  => FilePath+  -> TemplateSource+  -> IO Text+resolveTemplateSource _metaPath (TInline text) =+  return text+resolveTemplateSource metaPath (TFile path) =+  let path' = FilePath.replaceFileName metaPath path in+  either (error . show) id <$> (tryIOError $ T.readFile path')++-- | Replace file pointers with file contents+resolvePrimitive'+  :: HasCallStack+  => FilePath+  -> UnresolvedPrimitive+  -> IO (TS.Text, GuardedResolvedPrimitive)+resolvePrimitive' _metaPath (Primitive name wf primType) =+  return (name, HasBlackBox [] (Primitive name wf primType))+resolvePrimitive' metaPath BlackBox{template=t, includes=i, resultNames=r, resultInits=ri, ..} = do+  let resolveSourceM = traverse (traverse (resolveTemplateSource metaPath))+  bb <- BlackBox name workInfo renderVoid multiResult kind () outputUsage libraries imports functionPlurality+          <$> mapM (traverse resolveSourceM) i+          <*> traverse resolveSourceM r+          <*> traverse resolveSourceM ri+          <*> resolveSourceM t+  case warning of+    Just w  -> pure (name, HasBlackBox [WarnNonSynthesizable (TS.unpack w)] bb)+    Nothing -> pure (name, HasBlackBox [] bb)+resolvePrimitive' metaPath (BlackBoxHaskell bbName wf usedArgs multiRes funcName t) =+  (bbName,) . HasBlackBox [] . BlackBoxHaskell bbName wf usedArgs multiRes funcName <$>+    (mapM (resolveTemplateSource metaPath) t)++-- | Interprets contents of json file as list of @Primitive@s. Throws+-- exception if it fails.+resolvePrimitive+  :: HasCallStack+  => FilePath+  -> IO [(TS.Text, GuardedResolvedPrimitive)]+resolvePrimitive fileName = do+  prims <- decoder fileName <$> LZ.readFile fileName+  mapM (resolvePrimitive' fileName) prims+ where+  decoder+   | ".primitives.yaml" `isSuffixOf` fileName = decodeOrErrYaml+   | ".primitives" `isSuffixOf` fileName = decodeOrErrJson+   | otherwise = error ("Unexpected filename extension in: " <> fileName)++addGuards+  :: ResolvedPrimMap+  -> [(TS.Text, PrimitiveGuard ())]+  -> ResolvedPrimMap+addGuards = foldl go+ where+  lookupPrim+    :: TS.Text+    -> ResolvedPrimMap+    -> Maybe ([PrimitiveWarning], ResolvedPrimitive)+  lookupPrim nm primMap = do+    guardedPrim <- HashMapStrict.lookup nm primMap+    prim <- extractPrim guardedPrim+    return (extractWarnings guardedPrim, prim)++  go primMap (nm, guard) =+    HashMapStrict.insert+      nm+      (case (lookupPrim nm primMap, guard) of+        (Nothing, DontTranslate) -> DontTranslate+        (Nothing, HasBlackBox _ ()) ->+          error $ "No BlackBox definition for '" ++ TS.unpack nm ++ "' even"+               ++ " though this value was annotated with 'HasBlackBox'."+        (Just _, DontTranslate) ->+          error (TS.unpack nm ++ " was annotated with DontTranslate, but a "+                              ++ "BlackBox definition was found anyway.")+        (Just (ws1, p), HasBlackBox ws2 ()) ->+          HasBlackBox (ws1 ++ ws2) p+      )+      primMap++-- | Generate a set of primitives that are found in the primitive definition+-- files in the given directories.+generatePrimMap+  :: HasCallStack+  => [UnresolvedPrimitive]+  -- ^ unresolved primitives found in annotations (in LoadModules and+  -- LoadInterfaceFiles)+  -> [(TS.Text, PrimitiveGuard ())]+  -- ^ Primitive guards found in annotations+  -> [FilePath]+  -- ^ Directories to search for primitive definitions+  -> IO ResolvedPrimMap+generatePrimMap unresolvedPrims primGuards filePaths = do+  primitiveFiles <- fmap concat $ forM filePaths $ \filePath -> do+    fpExists <- Directory.doesDirectoryExist filePath+    if fpExists then do+      contents <- Directory.getDirectoryContents filePath+      let+        jsonPrims = filter (".primitives" `isSuffixOf`) contents+        yamlPrims = filter (".primitives.yaml" `isSuffixOf`) contents+        relPrims = jsonPrims <> yamlPrims+        absPrims = map (FilePath.combine filePath) relPrims+      return absPrims+    else+      return []++  primitives0 <- concat <$> mapM resolvePrimitive primitiveFiles+  let metapaths = map (TS.unpack . name) unresolvedPrims+  primitives1 <- sequence $ zipWith resolvePrimitive' metapaths unresolvedPrims+  let primMap = HashMap.fromList (primitives0 ++ primitives1)+  return (force (addGuards primMap primGuards))+{-# SCC generatePrimMap #-}++-- | Determine what argument should be constant / literal+constantArgs :: TS.Text -> CompiledPrimitive -> Set.Set Int+constantArgs nm BlackBox {template = templ@(BBTemplate _), resultInits = tRIM} =+  Set.fromList (concat [ fromIntForce+                       , concatMap walkTemplate tRIM+                       , walkTemplate templ+                       ])+ where+  walkTemplate (BBTemplate t) = concatMap (walkElement getConstant) t+  walkTemplate _ = []++  getConstant (Lit i)      = Just i+  getConstant (Const i)    = Just i+  getConstant _            = Nothing++  -- Ensure that if the 'Integer' arguments are constants, that they are reduced+  -- to literals, so that the builtin rules can properly fire.+  --+  -- Only in the the case that 'Integer' arguments are truly variables should+  -- the blackbox rules fire.+  fromIntForce+    | nm == "Clash.Sized.Internal.BitVector.fromInteger#"  = [2]+    | nm == "Clash.Sized.Internal.BitVector.fromInteger##" = [0,1]+    | nm == "Clash.Sized.Internal.Index.fromInteger#"      = [1]+    | nm == "Clash.Sized.Internal.Signed.fromInteger#"     = [1]+    | nm == "Clash.Sized.Internal.Unsigned.fromInteger#"   = [1]++    | nm == "Clash.Sized.Vector.replace_int"               = [1,2]+    | otherwise = []+constantArgs nm (BlackBoxHaskell{}) = Set.fromList fromIntForce+ where+    -- There is a special code-path for `index_int` in the Verilog backend in+    -- case the index is a constant. But this code path only works when the+    -- vector is (a projection of) a variable. By forcing the arguments of+    -- index_int we can be sure that arguments are either:+    --+    -- Constant Variable+    -- Variable Constant+    -- Variable Variable+    --+    -- As all other cases would be reduced by the evaluator, and even expensive+    -- primitives under index_int are fully unrolled.+  fromIntForce+    | nm == "Clash.Sized.Vector.index_int"                 = [2]+    | otherwise = []+constantArgs _ _ = Set.empty++-- | Helper function of 'getFunctionPlurality'+getFunctionPlurality' :: [(Int, Int)] -> Int -> Int+getFunctionPlurality' functionPlurality n =+  fromMaybe 1 (snd <$> (find ((== n) . fst) functionPlurality))++-- | Looks up the plurality of a function's function argument. See+-- 'functionPlurality' for more information. If not set, the returned plurality+-- will default to /1/.+getFunctionPlurality+  :: HasCallStack+  => CompiledPrimitive+  -> [Either Term Type]+  -- ^ Arguments passed to blackbox+  -> [Type]+  -- ^ Result types+  -> Int+  -- ^ Argument number holding the function of interest+  -> NetlistMonad Int+  -- ^ Plurality of function. Defaults to 1. Does not err if argument isn't+  -- a function in the first place. State of monad will not be modified.+getFunctionPlurality (Primitive {}) _args _resTys _n = pure 1+getFunctionPlurality (BlackBoxHaskell {name, function, functionName}) args resTys n = do+  errOrMeta <- preserveState ((snd function) False name args resTys)+  case errOrMeta of+    Left err ->+      error $ concat [ "Tried to determine function plurality for "+                     , TS.unpack name, " by quering ", show functionName+                     , ". Function returned an error message instead:\n\n"+                     , err ]+    Right (BlackBoxMeta {bbFunctionPlurality}, _bb) ->+      pure (getFunctionPlurality' bbFunctionPlurality n)+getFunctionPlurality (BlackBox {functionPlurality}) _args _resTy n =+  pure (getFunctionPlurality' functionPlurality n)
+ src/Clash/Primitives/Verification.hs view
@@ -0,0 +1,148 @@+{-|+  Copyright  :  (C) 2019     , Myrtle Software Ltd+                    2021     , Ellie Hermaszewska+                    2020-2025, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE OverloadedStrings #-}++module Clash.Primitives.Verification (checkBBF) where++import Data.Either+++import qualified Control.Lens                    as Lens+import           Control.Monad.State             (State)+import           Data.List.Infinite              (Infinite(..), (...))+import           Data.Maybe                      (listToMaybe)+import           Data.Monoid                     (Ap(getAp))+import           Data.Text.Prettyprint.Doc.Extra (Doc)+import           Data.Text                       (Text)+import           GHC.Stack                       (HasCallStack)++import           Clash.Annotations.Primitive     (HDL(..))+import           Clash.Backend+  (Backend, blockDecl, hdlKind)+import           Clash.Core.HasType+import           Clash.Core.Term                 (Term(Var))+import           Clash.Core.TermLiteral          (termToDataError)+import           Clash.Util                      (indexNote)+import           Clash.Netlist                   (mkExpr)+import           Clash.Netlist.Util              (stripVoid, contAssign)+import qualified Clash.Netlist.Id                as Id+import           Clash.Netlist.Types+  (BlackBox(BBFunction), TemplateFunction(..), BlackBoxContext, Identifier,+   NetlistMonad, Declaration(NetDecl),+   HWType(Bool, KnownDomain), NetlistId(..),+   DeclarationType(Concurrent), tcCache, bbInputs, Expr(Identifier))+import           Clash.Netlist.BlackBox.Types+  (BlackBoxFunction, BlackBoxMeta(..), TemplateKind(TDecl), RenderVoid(..),+   emptyBlackBoxMeta)++import           Clash.Verification.Internal+import           Clash.Verification.Pretty++checkBBF :: BlackBoxFunction+checkBBF _isD _primName args _ty =+  case litArgs of+    Left err -> pure (Left err)+    Right (propName, renderAs, cvProperty0) -> do+      clkBind <- bindMaybe (Just "clk") (indexNote "clk" (lefts args) clkArg)+      cvProperty1 <- mapM (uncurry bindMaybe) cvProperty0+      let decls = concatMap snd cvProperty1+          cvProperty2 = fmap fst cvProperty1+      pure (Right (meta, bb (checkTF decls clkBind propName renderAs cvProperty2)))+ where+  -- TODO: Improve error handling; currently errors don't indicate what+  -- TODO: blackbox generated them.+  _knownDomainArg+    :< clkArg+    :< _rstArg+    :< propNameArg+    :< renderAsArg+    :< propArg+    :< _ = ((0 :: Int)...)++  litArgs = do+    propName <- termToDataError (indexNote "propName" (lefts args) propNameArg)+    renderAs <- termToDataError (indexNote "renderAs" (lefts args) renderAsArg)+    cvProperty <- termToDataError (indexNote "propArg" (lefts args) propArg)+    Right (propName, renderAs, cvProperty)++  bb = BBFunction "Clash.Primitives.Verification.checkTF" 0+  meta = emptyBlackBoxMeta {bbKind=TDecl, bbRenderVoid=RenderVoid}++  bindMaybe+    :: Maybe Text+    -- ^ Hint for new identifier+    -> Term+    -- ^ Term to bind. Does not bind if it's already a reference to a signal+    -> NetlistMonad (Identifier, [Declaration])+    -- ^ ([new] reference to signal, [declarations need to get it in scope])+  bindMaybe _ (Var vId) = pure (Id.unsafeFromCoreId vId, [])+  bindMaybe Nothing t = bindMaybe (Just "s") t+  bindMaybe (Just nm) t = do+    tcm <- Lens.view tcCache+    newId <- Id.make nm+    (expr0, decls) <- mkExpr False Concurrent (NetlistId newId (inferCoreTypeOf tcm t)) t+    assn <- contAssign newId expr0+    pure+      ( newId+      , decls ++ [sigDecl Bool newId, assn] )++  -- Simple wire without comment+  sigDecl :: HWType -> Identifier -> Declaration+  sigDecl typ nm = NetDecl Nothing nm typ++checkTF+  :: [Declaration]+  -> (Identifier, [Declaration])+  -> Text+  -> RenderAs+  -> Property' Identifier+  -> TemplateFunction+checkTF decls clk propName renderAs prop =+  TemplateFunction [] (const True) (checkTF' decls clk propName renderAs prop)++checkTF'+  :: forall s+   . (HasCallStack, Backend s)+  => [Declaration]+  -- ^ Extra decls needed+  -> (Identifier, [Declaration])+  -- ^ Clock+  -> Text+  -- ^ Prop name+  -> RenderAs+  -> Property' Identifier+  -> BlackBoxContext+  -> State s Doc+checkTF' decls (clkId, clkDecls) propName renderAs prop bbCtx = do+  blockName <- Id.makeBasic (propName <> "_block")+  getAp (blockDecl blockName (clkDecls <> (renderedPslProperty : decls)))++ where+  hdl = hdlKind (undefined :: s)+  clk = Identifier clkId Nothing++  edge =+    case bbInputs bbCtx of+      (_, stripVoid -> KnownDomain _nm _period e _rst _init _polarity, _):_ -> e+      _ -> error $ "Unexpected first argument: " ++ show (listToMaybe (bbInputs bbCtx))++  renderedPslProperty = case renderAs of+    PSL          -> psl+    SVA          -> sva+    AutoRenderAs -> case hdl of+      SystemVerilog -> sva+      _             -> psl+    YosysFormal -> case hdl of+      VHDL -> psl+      _    -> ysva++   where+    sva = pprSvaProperty propName (Id.toText clkId) edge (fmap Id.toText prop)+    ysva = pprYosysSvaProperty propName clk edge (fmap Id.toText prop)+    psl = pprPslProperty hdl propName (Id.toText clkId) edge (fmap Id.toText prop)
+ src/Clash/Primitives/Xilinx/ClockGen.hs view
@@ -0,0 +1,195 @@+{-|+  Copyright   :  (C) 2023, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Blackbox template functions for+  Clash.Xilinx.ClockGen.{clockWizard,clockWizardDifferential}+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module Clash.Primitives.Xilinx.ClockGen+  ( clockWizardTF+  , clockWizardTclTF+  , clockWizardDifferentialTF+  , clockWizardDifferentialTclTF+  ) where++import Control.Monad.State (State)+import Data.List.Infinite (Infinite(..), (...))+import Data.Maybe (fromMaybe)+import Data.String.Interpolate (i)+import qualified Data.Text as T+import Prettyprinter.Interpolate (__di)+import Text.Show.Pretty (ppShow)++import Clash.Signal (periodToHz)++import Clash.Backend (Backend)+import qualified Clash.Netlist.Id as Id+import Clash.Netlist.Types+import Clash.Netlist.Util (stripVoid)+import qualified Clash.Primitives.DSL as DSL+import Data.Text.Extra (showt)+import Data.Text.Prettyprint.Doc.Extra (Doc)++usedArguments :: [Int]+usedArguments = [knownDomIn, clocksCxt, clk, rst]+ where+  knownDomIn+    :< _clocksClass+    :< clocksCxt+    :< _numOutClocks+    :< clk+    :< rst+    :< _ = (0...)++clockWizardTF :: TemplateFunction+clockWizardTF =+  TemplateFunction usedArguments valid (clockWizardTemplate False)+ where+  valid = const True++clockWizardDifferentialTF :: TemplateFunction+clockWizardDifferentialTF =+  TemplateFunction usedArguments valid (clockWizardTemplate True)+ where+  valid = const True++clockWizardTemplate+  :: Backend s+  => Bool+  -> BlackBoxContext+  -> State s Doc+clockWizardTemplate isDifferential bbCtx+  | [ _knownDomIn+    , _clocksClass+    , _clocksCxt+    , _numOutClocks+    , clk+    , rst+    ] <- map fst (DSL.tInputs bbCtx)+  , [DSL.ety -> resultTy] <- DSL.tResults bbCtx+  , Product _ _ (init -> pllOutTys) <- resultTy+  , [compName] <- bbQsysIncName bbCtx+  = do+      clkWizInstName <- Id.makeBasic $ fromMaybe "clk_wiz" $ bbCtxName bbCtx+      DSL.declarationReturn bbCtx blockName $ do++        rstHigh <- DSL.unsafeToActiveHigh "reset" rst+        pllOuts <- DSL.declareN "pllOut" pllOutTys+        locked <- DSL.declare "locked" Bit+        pllLock <- DSL.boolFromBit "pllLock" locked++        let pllOutNames =+              map (\n -> "clk_out" <> showt n) [1 .. length pllOutTys]+            compInps = compClkInps <> [ ("reset", Bit) ]+            compOuts = zip pllOutNames pllOutTys <> [("locked", Bit)]+            inps = clkInps clk <> [ ("reset", rstHigh) ]+            outs = zip pllOutNames pllOuts <> [("locked", locked)]++        DSL.compInBlock compName compInps compOuts+        DSL.instDecl Empty (Id.unsafeMake compName) clkWizInstName [] inps outs++        pure [DSL.constructProduct resultTy (pllOuts <> [pllLock])]+  | otherwise+  = error $ ppShow bbCtx+ where+  blockName | isDifferential = "clockWizardDifferential"+            | otherwise      = "clockWizard"+  compClkInps | isDifferential = [ ("clk_in1_p", Bit)+                                 , ("clk_in1_n", Bit)+                                 ]+              | otherwise      = [ ("clk_in1", Bit) ]+  clkInps clk+    | isDifferential+    , DataCon (Product "Clash.Signal.Internal.DiffClock" _ clkTys) _ clkEs+      <- DSL.eex clk+    , [clkP@(Identifier _ Nothing), clkN@(Identifier _ Nothing)] <- clkEs+    , [clkPTy, clkNTy] <- clkTys+    = [ ("clk_in1_p", DSL.TExpr clkPTy clkP)+      , ("clk_in1_n", DSL.TExpr clkNTy clkN)+      ]+    | not isDifferential+    = [ ("clk_in1", clk) ]+    | otherwise+    = error $ ppShow bbCtx++clockWizardTclTF :: TemplateFunction+clockWizardTclTF =+  TemplateFunction usedArguments valid (clockWizardTclTemplate False)+ where+  valid = const True++clockWizardDifferentialTclTF :: TemplateFunction+clockWizardDifferentialTclTF =+  TemplateFunction usedArguments valid (clockWizardTclTemplate True)+ where+  valid = const True++clockWizardTclTemplate+  :: Backend s+  => Bool+  -> BlackBoxContext+  -> State s Doc+clockWizardTclTemplate isDifferential bbCtx+  |   (_,stripVoid -> kdIn,_)+    : _clocksClass+    : (_,stripVoid -> Product _ _ (init -> kdOuts),_)+    : _ <- bbInputs bbCtx+  , [compName] <- bbQsysIncName bbCtx+  = let+    clkFreq (KnownDomain _ p _ _ _ _) =+      periodToHz (fromInteger p) / 1e6 :: Double+    clkFreq _ =+      error $ "Internal error: not a KnownDomain\n" <> ppShow bbCtx++    clkInFreq = clkFreq kdIn+    clkOutFreqs = map clkFreq kdOuts++    clkOutProps = concat+      [ [ [i|CONFIG.CLKOUT#{n}_USED true \\|]+        , [i|CONFIG.CLKOUT#{n}_REQUESTED_OUT_FREQ #{clkOutFreq} \\|]+        ]+      | (clkOutFreq, n) <- zip clkOutFreqs [(1::Word)..]+      ]++    differentialPinString :: T.Text+    differentialPinString = if isDifferential+      then "Differential_clock_capable_pin"+      else "Single_ended_clock_capable_pin"++    propIndent = T.replicate 18 " "+    props = T.intercalate "\n"  . map (propIndent <>) $+      [ [i|CONFIG.PRIM_SOURCE #{differentialPinString} \\|]+      , [i|CONFIG.PRIM_IN_FREQ #{clkInFreq} \\|]+      ] <> clkOutProps++    bbText = [__di|+      namespace eval $tclIface {+        variable api 1+        variable scriptPurpose createIp+        variable ipName {#{compName}}++        proc createIp {ipName0 args} {+          create_ip \\+            -name clk_wiz \\+            -vendor xilinx.com \\+            -library ip \\+            -version 6.0 \\+            -module_name $ipName0 \\+            {*}$args++          set_property \\+            -dict [list \\+      #{props}+                  ] [get_ips $ipName0]+          return+        }+      }|]+    in pure bbText+  | otherwise+  = error ("clockWizardTclTemplate: bad bbContext: " <> show bbCtx)
+ src/Clash/Rewrite/Combinators.hs view
@@ -0,0 +1,148 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente+                         2021, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Rewriting combinators and traversals+-}++module Clash.Rewrite.Combinators+  ( allR+  , (!->)+  , (>-!)+  , (>-!->)+  , (>->)+  , bottomupR+  , repeatR+  , topdownR+  ) where++import           Control.DeepSeq             (deepseq)+import           Control.Monad               ((>=>))+import qualified Control.Monad.Writer        as Writer+import qualified Data.Monoid                 as Monoid++import           Clash.Core.Term             (Term (..), CoreContext (..), primArg, patIds)+import           Clash.Core.VarEnv+  (extendInScopeSet, extendInScopeSetList)+import           Clash.Rewrite.Types++-- | Apply a transformation on the subtrees of an term+allR+  :: forall m+   . Monad m+  => Transform m+  -- ^ The transformation to apply to the subtrees+  -> Transform m+allR trans (TransformContext is c) (Lam v e) =+  Lam v <$> trans (TransformContext (extendInScopeSet is v) (LamBody v:c)) e++allR trans (TransformContext is c) (TyLam tv e) =+  TyLam tv <$> trans (TransformContext (extendInScopeSet is tv) (TyLamBody tv:c)) e++allR trans (TransformContext is c) (App e1 e2) = do+  e1' <- trans (TransformContext is (AppFun:c)) e1+  e2' <- trans (TransformContext is (AppArg (primArg e1') : c)) e2+  pure (App e1' e2')++allR trans (TransformContext is c) (TyApp e ty) =+  TyApp <$> trans (TransformContext is (TyAppC:c)) e <*> pure ty++allR trans (TransformContext is c) (Cast e ty1 ty2) =+  Cast <$> trans (TransformContext is (CastBody:c)) e <*> pure ty1 <*> pure ty2++allR trans (TransformContext is c) (Letrec xes e) = do+  xes' <- traverse rewriteBind xes+  e'   <- trans (TransformContext is' (LetBody xes:c)) e+  return (Letrec xes' e')+ where+  bndrs              = map fst xes+  is'                = extendInScopeSetList is (map fst xes)+  rewriteBind (b,e') = (b,) <$> trans (TransformContext is' (LetBinding b bndrs:c)) e'++allR trans (TransformContext is c) (Case scrut ty alts) =+  Case <$> trans (TransformContext is (CaseScrut:c)) scrut+       <*> pure ty+       <*> traverse rewriteAlt alts+ where+  rewriteAlt (p,e) =+    let (tvs,ids) = patIds p+        is'       = extendInScopeSetList (extendInScopeSetList is tvs) ids+    in  (p,) <$> trans (TransformContext is' (CaseAlt p : c)) e++allR trans (TransformContext is c) (Tick sp e) =+  Tick sp <$> trans (TransformContext is (TickC sp:c)) e++allR _ _ tm = pure tm++infixr 6 >->+-- | Apply two transformations in succession+(>->) :: Monad m => Transform m -> Transform m -> Transform m+(>->) = \r1 r2 c -> r1 c >=> r2 c+{-# INLINE (>->) #-}++infixr 6 >-!->+-- | Apply two transformations in succession, and perform a deepseq in between.+(>-!->) :: Monad m => Transform m -> Transform m -> Transform m+(>-!->) = \r1 r2 c e -> do+  e' <- r1 c e+  deepseq e' (r2 c e')+{-# INLINE (>-!->) #-}++{-+Note [topdown repeatR]+~~~~~~~~~~~~~~~~~~~~~~+In a topdown traversal we need to repeat the transformation r because+if r replaces a parent node with one of its children+we should still apply r to that child, before continuing with its children.++Example: topdownR (inlineBinders (\_ _ -> return True))+on:+> letrec+>   x = 1+> in letrec+>      y = 2+>    in f x y++inlineBinders would inline x and return:+> letrec+>   y = 2+> in f 1 y++Then we must repeat the transformation to let it also inline y.+-}++-- | Apply a transformation in a topdown traversal+topdownR :: Rewrite m -> Rewrite m+-- See Note [topdown repeatR]+topdownR r = repeatR r >-> allR (topdownR r)++-- | Apply a transformation in a bottomup traversal+bottomupR :: Monad m => Transform m -> Transform m+bottomupR r = allR (bottomupR r) >-> r++infixr 5 !->+-- | Only apply the second transformation if the first one succeeds.+(!->) :: Rewrite m -> Rewrite m -> Rewrite m+(!->) = \r1 r2 c expr -> do+  (expr',changed) <- Writer.listen $ r1 c expr+  if Monoid.getAny changed+    then r2 c expr'+    else return expr'+{-# INLINE (!->) #-}++infixr 5 >-!+-- | Only apply the second transformation if the first one fails.+(>-!) :: Rewrite m -> Rewrite m -> Rewrite m+(>-!) = \r1 r2 c expr -> do+  (expr',changed) <- Writer.listen $ r1 c expr+  if Monoid.getAny changed+    then return expr'+    else r2 c expr'+{-# INLINE (>-!) #-}++-- | Keep applying a transformation until it fails.+repeatR :: Rewrite m -> Rewrite m+repeatR = let go r = r !-> repeatR r in go+{-# INLINE repeatR #-}
+ src/Clash/Rewrite/Types.hs view
@@ -0,0 +1,214 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016     , Myrtle Software Ltd,+                    2017     , Google Inc.,+                    2021-2022, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Type and instance definitions for Rewrite modules+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Rewrite.Types where++import Control.DeepSeq                       (NFData)+import Control.Lens                          (Lens', use, (.=))+import qualified Control.Lens as Lens+import Control.Monad.Fix                     (MonadFix)+import Control.Monad.State.Strict            (State)+import Control.Monad.Reader                  (MonadReader (..))+import Control.Monad.State                   (MonadState (..))+import Control.Monad.Trans.RWS.CPS           (RWST)+import qualified Control.Monad.Trans.RWS.CPS as RWS+import Control.Monad.Writer                  (MonadWriter (..))+import Data.Binary                           (Binary)+import Data.HashMap.Strict                   (HashMap)+import Data.IntMap.Strict                    (IntMap)+import Data.Monoid                           (Any)+import Data.Text                             (Text)+import GHC.Generics++import Clash.Core.PartialEval as PE          (Evaluator)+import Clash.Core.Evaluator.Types as WHNF    (Evaluator, PrimHeap)++import Clash.Core.Term           (Term, Context)+import Clash.Core.Type           (Type)+import Clash.Core.TyCon          (TyConMap, TyConName)+import Clash.Core.Var            (Id)+import Clash.Core.VarEnv         (InScopeSet, VarSet, VarEnv)+import Clash.Driver.Types        (ClashEnv(..), ClashOpts(..), BindingMap, DebugOpts)+import Clash.Netlist.Types       (FilteredHWType, HWMap)+import Clash.Primitives.Types    (CompiledPrimMap)+import Clash.Rewrite.WorkFree    (isWorkFree)+import Clash.Util+import Clash.Util.Supply         (Supply, freshId)++import Clash.Annotations.BitRepresentation.Internal (CustomReprs)++-- | State used by the inspection mechanism for recording rewrite steps.+data RewriteStep+  = RewriteStep+  { t_ctx    :: Context+  -- ^ current context+  , t_name   :: String+  -- ^ Name of the transformation+  , t_bndrS  :: String+  -- ^ Name of the current binder+  , t_before :: Term+  -- ^ Term before `apply`+  , t_after  :: Term+  -- ^ Term after `apply`+  } deriving (Show, Generic, NFData, Binary)++-- | State of a rewriting session+data RewriteState extra+  = RewriteState+    -- TODO Given we now keep transformCounters, this should just be 'fold'+    -- over that map, otherwise the two counts could fall out of sync.+  { _transformCounter :: {-# UNPACK #-} !Word+  -- ^ Total number of applied transformations+  , _transformCounters :: HashMap Text Word+  -- ^ Map that tracks how many times each transformation is applied+  , _bindings         :: !BindingMap+  -- ^ Global binders+  , _uniqSupply       :: !Supply+  -- ^ Supply of unique numbers+  , _curFun           :: (Id,SrcSpan) -- Initially set to undefined: no strictness annotation+  -- ^ Function which is currently normalized+  , _nameCounter      :: {-# UNPACK #-} !Int+  -- ^ Used for 'Fresh'+  , _globalHeap       :: PrimHeap+  -- ^ Used as a heap for compile-time evaluation of primitives that live in I/O+  , _workFreeBinders  :: VarEnv Bool+  -- ^ Map telling whether a binder's definition is work-free+  , _extra            :: !extra+  -- ^ Additional state+  }++Lens.makeLenses ''RewriteState++-- | Read-only environment of a rewriting session+data RewriteEnv+  = RewriteEnv+  { _clashEnv       :: ClashEnv+  -- ^ The global environment of the compiler+  , _typeTranslator :: CustomReprs+                    -> TyConMap+                    -> Type+                    -> State HWMap (Maybe (Either String FilteredHWType))+  -- ^ Hardcode Type -> FilteredHWType translator+  , _peEvaluator    :: PE.Evaluator+  -- ^ Hardcoded evaluator for partial evaluation+  , _evaluator      :: WHNF.Evaluator+  -- ^ Hardcoded evaluator for WHNF (old evaluator)+  , _topEntities    :: VarSet+  -- ^ Functions that are considered TopEntities+  }++Lens.makeLenses ''RewriteEnv++debugOpts :: Lens.Getter RewriteEnv DebugOpts+debugOpts = clashEnv . Lens.to (opt_debug . envOpts)++aggressiveXOpt :: Lens.Getter RewriteEnv Bool+aggressiveXOpt = clashEnv . Lens.to (opt_aggressiveXOpt . envOpts)++tcCache :: Lens.Getter RewriteEnv TyConMap+tcCache = clashEnv . Lens.to envTyConMap++tupleTcCache :: Lens.Getter RewriteEnv (IntMap TyConName)+tupleTcCache = clashEnv . Lens.to envTupleTyCons++customReprs :: Lens.Getter RewriteEnv CustomReprs+customReprs = clashEnv . Lens.to envCustomReprs++fuelLimit :: Lens.Getter RewriteEnv Word+fuelLimit = clashEnv . Lens.to (opt_evaluatorFuelLimit . envOpts)++primitives :: Lens.Getter RewriteEnv CompiledPrimMap+primitives = clashEnv . Lens.to envPrimitives++inlineLimit :: Lens.Getter RewriteEnv Int+inlineLimit = clashEnv . Lens.to (opt_inlineLimit . envOpts)++inlineFunctionLimit :: Lens.Getter RewriteEnv Word+inlineFunctionLimit = clashEnv . Lens.to (opt_inlineFunctionLimit . envOpts)++inlineConstantLimit :: Lens.Getter RewriteEnv Word+inlineConstantLimit = clashEnv . Lens.to (opt_inlineConstantLimit . envOpts)++inlineWFCacheLimit :: Lens.Getter RewriteEnv Word+inlineWFCacheLimit = clashEnv . Lens.to (opt_inlineWFCacheLimit . envOpts)++newInlineStrategy :: Lens.Getter RewriteEnv Bool+newInlineStrategy = clashEnv . Lens.to (opt_newInlineStrat . envOpts)++specializationLimit :: Lens.Getter RewriteEnv Int+specializationLimit = clashEnv . Lens.to (opt_specLimit . envOpts)++normalizeUltra :: Lens.Getter RewriteEnv Bool+normalizeUltra = clashEnv . Lens.to (opt_ultra . envOpts)++-- | Monad that keeps track how many transformations have been applied and can+-- generate fresh variables and unique identifiers. In addition, it keeps track+-- if a transformation/rewrite has been successfully applied.+newtype RewriteMonad extra a = R+  { unR :: RWST RewriteEnv Any (RewriteState extra) IO a }+  deriving newtype+    ( Applicative+    , Functor+    , Monad+    , MonadFix+    , MonadState (RewriteState extra)+    , MonadWriter Any+    , MonadReader RewriteEnv+    )++-- | Run the computation in the RewriteMonad+runR+  :: RewriteMonad extra a+  -> RewriteEnv+  -> RewriteState extra+  -> IO (a, RewriteState extra, Any)+runR m = RWS.runRWST (unR m)++instance MonadUnique (RewriteMonad extra) where+  getUniqueM = do+    sup <- use uniqSupply+    let (a,sup') = freshId sup+    uniqSupply .= sup'+    a `seq` return a++censor :: (Any -> Any) -> RewriteMonad extra a -> RewriteMonad extra a+censor f = R . RWS.censor f . unR+{-# INLINE censor #-}++data TransformContext+  = TransformContext+  { tfInScope :: !InScopeSet+  , tfContext :: Context+  }++-- | Monadic action that transforms a term given a certain context+type Transform m = TransformContext -> Term -> m Term++-- | A 'Transform' action in the context of the 'RewriteMonad'+type Rewrite extra = Transform (RewriteMonad extra)++-- Moved into Clash.Rewrite.WorkFree+{-# SPECIALIZE isWorkFree+      :: Lens' (RewriteState extra) (VarEnv Bool)+      -> BindingMap+      -> Term+      -> RewriteMonad extra Bool+  #-}
+ src/Clash/Rewrite/Util.hs view
@@ -0,0 +1,850 @@+{-|+  Copyright  :  (C) 2012-2016, University of Twente,+                    2016     , Myrtle Software Ltd,+                    2017     , Google Inc.,+                    2021-2023, QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Utilities for rewriting: e.g. inlining, specialisation, etc.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Rewrite.Util+  ( module Clash.Rewrite.Util+  , module Clash.Rewrite.WorkFree+  ) where++import           Control.DeepSeq+import           Control.Exception           (throw)+import           Control.Lens ((%=), (+=), (^.))+import qualified Control.Lens                as Lens+import qualified Control.Monad               as Monad+import qualified Control.Monad.State.Strict  as State+import qualified Control.Monad.Trans.RWS.CPS as RWS+import qualified Control.Monad.Writer        as Writer+import           Data.Bifunctor              (second)+import           Data.Coerce                 (coerce)+import           Data.Functor.Const          (Const (..))+import qualified Data.HashMap.Strict         as HashMap+import           Data.List                   (group, partition, sort, sortOn)+import qualified Data.List                   as List+import qualified Data.List.Extra             as List+import           Data.List.Extra             (partitionM)+import           Data.Maybe+import qualified Data.Monoid                 as Monoid+import qualified Data.Set                    as Set+import qualified Data.Set.Lens               as Lens+import           Data.Text                   (Text)+import qualified Data.Text                   as Text+import           System.IO.Unsafe            (unsafePerformIO)+import           Data.Binary                 (encode)+import qualified Data.ByteString             as BS+import qualified Data.ByteString.Lazy        as BL++import           GHC.Types.Basic             (InlineSpec (..))++import           Clash.Core.Evaluator.Types  (PureHeap, whnf')+import           Clash.Core.FreeVars+  (freeLocalVars, termFreeVars', freeLocalIds, globalIdOccursIn)+import           Clash.Core.HasFreeVars      (elemFreeVars, notElemFreeVars)+import           Clash.Core.HasType+import           Clash.Core.Name+import           Clash.Core.Pretty           (showPpr)+import           Clash.Core.Subst+  (substTmEnv, aeqTerm, aeqType, extendIdSubst, mkSubst, substTm, eqTerm)+import           Clash.Core.Term+import           Clash.Core.TyCon            (TyConMap)+import           Clash.Core.Type             (Type (..), normalizeType)+import           Clash.Core.Var+  (Id, IdScope (..), TyVar, Var (..), mkGlobalId, mkLocalId, mkTyVar)+import           Clash.Core.VarEnv+  (InScopeSet, extendInScopeSet, extendInScopeSetList, mkInScopeSet, notElemInScopeSet,+   uniqAway, uniqAway', mapVarEnv, eltsVarEnv, unitVarSet, emptyVarEnv,+   mkVarEnv, eltsVarSet, elemVarEnv, lookupVarEnv, extendVarEnv, elemVarSet,+   differenceVarEnv)+import           Clash.Data.UniqMap (UniqMap)+import qualified Clash.Data.UniqMap as UniqMap+import           Clash.Debug+import           Clash.Driver.Types+  (TransformationInfo(..), DebugOpts(..), BindingMap, Binding(..), IsPrim(..),+  ClashEnv(..), ClashOpts(..), hasDebugInfo, isDebugging)+import           Clash.Netlist.Util          (representableType)+import           Clash.Pretty                (clashPretty, showDoc)+import           Clash.Rewrite.Types+import           Clash.Rewrite.WorkFree+import           Clash.Unique+import           Clash.Util+import           Clash.Util.Eq               (fastEqBy)+import qualified Clash.Util.Interpolate as I+import           Clash.Util.Supply           (splitSupply)++-- | Lift an action working in the '_extra' state to the 'RewriteMonad'+zoomExtra :: State.State extra a -> RewriteMonad extra a+zoomExtra m = R . RWS.rwsT $ \_ s ->+  let (a, st') = State.runState m (_extra s)+   in pure (a, s { _extra = st' }, mempty)++-- | Some transformations might erroneously introduce shadowing. For example,+-- a transformation might result in:+--+--   let a = ...+--       b = ...+--       a = ...+--+-- where the last 'a', shadows the first, while Clash assumes that this can't+-- happen. This function finds those constructs and a list of found duplicates.+--+findAccidentialShadows :: Term -> [[Id]]+findAccidentialShadows =+  \case+    Var {}      -> []+    Data {}     -> []+    Literal {}  -> []+    Prim {}     -> []+    Lam _ t     -> findAccidentialShadows t+    TyLam _ t   -> findAccidentialShadows t+    App t1 t2   -> concatMap findAccidentialShadows [t1, t2]+    TyApp t _   -> findAccidentialShadows t+    Cast t _ _  -> findAccidentialShadows t+    Tick _ t    -> findAccidentialShadows t+    Case t _ as ->+      concatMap (findInPat . fst) as +++        concatMap findAccidentialShadows (t : map snd as)+    Let NonRec{} t -> findAccidentialShadows t+    Let (Rec bs) t -> findDups (map fst bs) ++ findAccidentialShadows t++ where+  findInPat :: Pat -> [[Id]]+  findInPat (LitPat _)        = []+  findInPat (DefaultPat)      = []+  findInPat (DataPat _ _ ids) = findDups ids++  findDups :: [Id] -> [[Id]]+  findDups ids = filter ((1 <) . length) (group (sort ids))+++-- | Record if a transformation is successfully applied+apply+  :: String+  -- ^ Name of the transformation+  -> Rewrite extra+  -- ^ Transformation to be applied+  -> Rewrite extra+apply = \s rewrite ctx expr0 -> do+  opts <- Lens.view debugOpts+  traceIf (hasDebugInfo TryName s opts) ("Trying: " <> s) (pure ())++  (!expr1,anyChanged) <- Writer.listen (rewrite ctx expr0)+  let hasChanged = Monoid.getAny anyChanged+  Monad.when hasChanged (transformCounter += 1)++  -- NB: When -fclash-debug-history is on, emit binary data holding the recorded rewrite steps+  let rewriteHistFile = dbg_historyFile opts+  Monad.when (isJust rewriteHistFile && hasChanged) $ do+    (curBndr, _) <- Lens.use curFun+    let !_ = unsafePerformIO+             $ BS.appendFile (fromJust rewriteHistFile)+             $ BL.toStrict+             $ encode RewriteStep+                 { t_ctx    = tfContext ctx+                 , t_name   = s+                 , t_bndrS  = showPpr (varName curBndr)+                 , t_before = expr0+                 , t_after  = expr1+                 }+    return ()++  if isDebugging opts+    then applyDebug ctx s expr0 hasChanged expr1+    else return expr1+{-# INLINE apply #-}++applyDebug+  :: TransformContext+  -> String+  -- ^ Name of the transformation+  -> Term+  -- ^ Original expression+  -> Bool+  -- ^ Whether the rewrite indicated change+  -> Term+  -- ^ New expression+  -> RewriteMonad extra Term+applyDebug ctx name exprOld hasChanged exprNew = do+  nTrans <- Lens.use transformCounter+  opts <- Lens.view debugOpts++  let from = fromMaybe 0 (dbg_transformationsFrom opts)+  let limit = fromMaybe maxBound (dbg_transformationsLimit opts)++  if | nTrans - from > limit ->+         error "-fclash-debug-transformations-limit exceeded"+     | nTrans <= from ->+         pure exprNew+     | otherwise ->+         go opts+ where+  go opts = traceIf (hasDebugInfo TryTerm name opts) ("Tried: " ++ name ++ " on:\n" ++ before) $ do+    nTrans <- pred <$> Lens.use transformCounter++    Monad.when (dbg_countTransformations opts && hasChanged) $ do+      transformCounters %= HashMap.insertWith (const succ) (Text.pack name) 1++    Monad.when (dbg_invariants opts && hasChanged) $ do+      tcm                  <- Lens.view tcCache+      let beforeTy          = inferCoreTypeOf tcm exprOld+          beforeFV          = Lens.setOf freeLocalVars exprOld+          afterTy           = inferCoreTypeOf tcm exprNew+          afterFV           = filterFVs (Lens.setOf freeLocalVars exprNew)+          newFV             = not (afterFV `Set.isSubsetOf` beforeFV)+          accidentalShadows = findAccidentialShadows exprNew+          -- see NOTE [Filter free variables]+          allowNewFVsFromCtx = name `elem` ["caseCon", "reduceConst", "constantSpec"]+          filterFVs | allowNewFVsFromCtx = Set.filter notInCtx+                    | otherwise = id+          notInCtx v = notElemInScopeSet v (tfInScope ctx)++      Monad.when newFV $+              error ( concat [ $(curLoc)+                             , "Error when applying rewrite ", name+                             , " to:\n" , before+                             , "\nResult:\n" ++ after ++ "\n"+                             , "It introduces free variables."+                             , "\nBefore: " ++ showPpr (Set.toList beforeFV)+                             , "\nAfter: " ++ showPpr (Set.toList afterFV)+                             ]+                    )+      Monad.when (not (null accidentalShadows)) $+        error ( concat [ $(curLoc)+                       , "Error when applying rewrite ", name+                       , " to:\n" , before+                       , "\nResult:\n" ++ after ++ "\n"+                       , "It accidentally creates shadowing let/case-bindings:\n"+                       , " ", showPpr accidentalShadows, "\n"+                       , "This usually means that a transformation did not extend "+                       , "or incorrectly extended its InScopeSet before applying a "+                       , "substitution."+                       ])++      -- TODO This check should be an error instead of a trace, however this is+      -- currently very fragile as Clash doesn't keep casts in core. This should+      -- be changed when #1064 is merged.+      Monad.when (hasDebugInfo AppliedTerm name opts && not (normalizeType tcm beforeTy `aeqType` normalizeType tcm afterTy)) $+        traceM ( concat [ $(curLoc)+                       , "Error when applying rewrite ", name+                       , " to:\n" , before+                       , "\nResult:\n" ++ after ++ "\n"+                       , "Changes type from:\n", showPpr beforeTy+                       , "\nto:\n", showPpr afterTy+                       ]+              )++    let exprNotEqual = not (fastEqBy eqTerm exprOld exprNew)+    Monad.when (dbg_invariants opts && not hasChanged && exprNotEqual) $+      error $ $(curLoc) ++ "Expression changed without notice(" ++ name ++  "): before"+                        ++ before ++ "\nafter:\n" ++ after++    traceIf (hasDebugInfo AppliedName name opts && hasChanged) (name <> " {" <> show nTrans <> "}") $+      traceIf (hasDebugInfo AppliedTerm name opts && hasChanged) ("Changes when applying rewrite to:\n"+                        ++ before ++ "\nResult:\n" ++ after ++ "\n") $+        traceIf (hasDebugInfo TryTerm name opts && not hasChanged) ("No changes when applying rewrite "+                          ++ name ++ " to:\n" ++ after ++ "\n") $+          return exprNew+   where+    before = showPpr exprOld+    after  = showPpr exprNew++-- NOTE [Filter free variables]+-- Since [Give evaluator access to in-scope let-bindings #2571](https://github.com/clash-lang/clash-compiler/pull/2571)+-- the evaluator can rewrite expressions using let bindings from its 'TransformContext'.+-- These bindings may reference other variables bound in the context which weren't+-- in the expression before. By just looking at the expression (i.e., not accounting+-- for the 'TransformContext'), it would therefore seem that free variables are+-- introduce which would subsequently fail the freevar check. To prevent this we+-- filter out all variables bound in the context, but only during a transformations+-- that call 'whnfRW'.++-- | Perform a transformation on a Term+runRewrite+  :: String+  -- ^ Name of the transformation+  -> InScopeSet+  -> Rewrite extra+  -- ^ Transformation to perform+  -> Term+  -- ^ Term to transform+  -> RewriteMonad extra Term+runRewrite name is rewrite expr = apply name rewrite (TransformContext is []) expr++-- | Evaluate a RewriteSession to its inner monad.+runRewriteSession :: RewriteEnv+                  -> RewriteState extra+                  -> RewriteMonad extra a+                  -> IO a+runRewriteSession r s m = do+  (a, s', _) <- runR m r s+  traceIf (dbg_countTransformations (opt_debug (envOpts (_clashEnv r))))+    ("Clash: Transformations:\n" ++ Text.unpack (showCounters (s' ^. transformCounters))) $+    traceIf (None < dbg_transformationInfo (opt_debug (envOpts (_clashEnv r))))+      ("Clash: Applied " ++ show (s' ^. transformCounter) ++ " transformations")+      pure a+  where+    showCounters =+      Text.unlines+        . map (\(nm,cnt) -> nm <> ": " <> Text.pack (show cnt))+        . sortOn snd+        . HashMap.toList++-- | Notify that a transformation has changed the expression+setChanged :: RewriteMonad extra ()+setChanged = Writer.tell (Monoid.Any True)++-- | Identity function that additionally notifies that a transformation has+-- changed the expression+changed :: a -> RewriteMonad extra a+changed val = do+  Writer.tell (Monoid.Any True)+  return val++closestLetBinder :: Context -> Maybe Id+closestLetBinder [] = Nothing+closestLetBinder (LetBinding id_ _:_) = Just id_+closestLetBinder (_:ctx)              = closestLetBinder ctx++mkDerivedName :: TransformContext -> OccName -> TmName+mkDerivedName (TransformContext _ ctx) sf = case closestLetBinder ctx of+  Just id_ -> appendToName (varName id_) ('_' `Text.cons` sf)+  _ -> mkUnsafeInternalName sf 0++-- | Make a new binder and variable reference for a term+mkTmBinderFor+  :: (MonadUnique m)+  => InScopeSet+  -> TyConMap -- ^ TyCon cache+  -> Name a -- ^ Name of the new binder+  -> Term -- ^ Term to bind+  -> m Id+mkTmBinderFor is tcm name e =+  either id (error "mkTmBinderFor: Result is a TyVar")+    <$> mkBinderFor is tcm name (Left e)++-- | Make a new binder and variable reference for either a term or a type+mkBinderFor+  :: (MonadUnique m)+  => InScopeSet+  -> TyConMap -- ^ TyCon cache+  -> Name a -- ^ Name of the new binder+  -> Either Term Type -- ^ Type or Term to bind+  -> m (Either Id TyVar)+mkBinderFor is tcm name (Left term) = do+  name' <- cloneNameWithInScopeSet is name+  let ty = inferCoreTypeOf tcm term+  return (Left (mkLocalId ty (coerce name')))++mkBinderFor is tcm name (Right ty) = do+  name' <- cloneNameWithInScopeSet is name+  let ki = inferCoreKindOf tcm ty+  return (Right (mkTyVar ki (coerce name')))++-- | Inline the binders in a let-binding that have a certain property+inlineBinders+  :: (Term -> LetBinding -> RewriteMonad extra Bool)+  -- ^ Property test+  -> Rewrite extra+inlineBinders condition (TransformContext inScope0 _) expr@(Let (NonRec i x) res) = do+  inline <- condition expr (i, x)++  if inline && elemFreeVars i res then+    let inScope1 = extendInScopeSet inScope0 i+        subst = extendIdSubst (mkSubst inScope1) i x+     in changed (substTm "inlineBinders" subst res)+  else+    return expr++inlineBinders condition (TransformContext inScope0 _) expr@(Let (Rec xes) res) = do+  (toInline,toKeep) <- partitionM (condition expr) xes+  case toInline of+    [] -> return expr+    _  -> do+      let inScope1 = extendInScopeSetList inScope0 (map fst xes)+          (toInlRec,(toKeep1,res1)) =+            substituteBinders inScope1 toInline toKeep res+      case toInlRec ++ toKeep1 of+        []   -> changed res1+        xes1 -> changed (Letrec xes1 res1)++inlineBinders _ _ e = return e++-- | Determine whether a binder is a join-point created for a complex case+-- expression.+--+-- A join-point is when a local function only occurs in tail-call positions,+-- and when it does, more than once.+isJoinPointIn :: Id   -- ^ 'Id' of the local binder+              -> Term -- ^ Expression in which the binder is bound+              -> Bool+isJoinPointIn id_ e = case tailCalls id_ e of+                      Just n | n > 1 -> True+                      _              -> False++-- | Count the number of (only) tail calls of a function in an expression.+-- 'Nothing' indicates that the function was used in a non-tail call position.+tailCalls :: Id   -- ^ Function to check+          -> Term -- ^ Expression to check it in+          -> Maybe Int+tailCalls id_ = \case+  Var nm | id_ == nm -> Just 1+         | otherwise -> Just 0+  Lam _ e -> tailCalls id_ e+  TyLam _ e -> tailCalls id_ e+  App l r  -> case tailCalls id_ r of+                Just 0 -> tailCalls id_ l+                _      -> Nothing+  TyApp l _ -> tailCalls id_ l+  Letrec bs e ->+    let (bsIds,bsExprs) = unzip bs+        bsTls           = map (tailCalls id_) bsExprs+        bsIdsUsed       = mapMaybe (\(l,r) -> pure l <* r) (zip bsIds bsTls)+        bsIdsTls        = map (`tailCalls` e) bsIdsUsed+        bsCount         = pure . sum $ catMaybes bsTls+    in  case (all isJust bsTls) of+          False -> Nothing+          True  -> case (all (==0) $ catMaybes bsTls) of+            False  -> case all isJust bsIdsTls of+              False -> Nothing+              True  -> (+) <$> bsCount <*> tailCalls id_ e+            True -> tailCalls id_ e+  Case scrut _ alts ->+    let scrutTl = tailCalls id_ scrut+        altsTl  = map (tailCalls id_ . snd) alts+    in  case scrutTl of+          Just 0 | all (/= Nothing) altsTl -> Just (sum (catMaybes altsTl))+          _ -> Nothing+  _ -> Just 0++-- | Determines whether a function has the following shape:+--+-- > \(w :: Void) -> f a b c+--+-- i.e. is a wrapper around a (partially) applied function 'f', where the+-- introduced argument 'w' is not used by 'f'+isVoidWrapper :: Term -> Bool+isVoidWrapper (Lam bndr e@(collectArgs -> (Var _,_))) =+  bndr `notElemFreeVars` e+isVoidWrapper _ = False++-- | Inline the first set of binder into the second set of binders and into the+-- body of the original let expression.+substituteBinders+  :: InScopeSet+  -> [LetBinding]+  -- ^ Let-binders to substitute+  -> [LetBinding]+  -- ^ Let-binders where substitution takes place+  -> Term+  -- ^ Body where substitution takes place+  -> ([LetBinding],([LetBinding],Term))+  -- ^+  -- 1. Let-bindings that we wanted to substitute, but turned out to be recursive+  -- 2.1 Let-binders where substitution took place+  -- 2.2 Body where substitution took place+substituteBinders inScope toInline toKeep body =+  let (subst,toInlRec) = go (mkSubst inScope) [] toInline+  in  ( map (second (substTm "substToInlRec" subst)) toInlRec+      , ( map (second (substTm "substToKeep" subst)) toKeep+        , substTm "substBody" subst body) )+ where+  go subst inlRec [] = (subst,inlRec)+  go !subst !inlRec ((x,e):toInl) =+    let e1      = substTm "substInl" subst e+        substE  = extendIdSubst (mkSubst inScope) x e1+        subst1  = subst { substTmEnv = mapVarEnv (substTm "substSubst" substE)+                                                 (substTmEnv subst)}+        subst2  = extendIdSubst subst1 x e1+    in  if x `elemFreeVars` e1 then+          go subst ((x,e1):inlRec) toInl+        else+          go subst2 inlRec toInl++-- | Lift the first set of binders to the level of global bindings, and substitute+-- these lifted bindings into the second set of binders and the body of the+-- original let expression.+liftAndSubsituteBinders+  :: InScopeSet+  -> [LetBinding]+  -- ^ Let-binders to lift, and substitute the lifted result+  -> [LetBinding]+  -- ^ Lef-binders where substitution takes place+  -> Term+  -- ^ Body where substitution takes place+  -> RewriteMonad extra ([LetBinding],Term)+liftAndSubsituteBinders inScope toLift toKeep body = do+  subst <- go (mkSubst inScope) toLift+  pure ( map (second (substTm "liftToKeep" subst)) toKeep+       , substTm "keepBody" subst body+       )+ where+  go subst [] = pure subst+  go !subst ((x,e):inl) = do+    let e1 = substTm "liftInl" subst e+    (_,e2) <- liftBinding (x,e1)+    let substE = extendIdSubst (mkSubst inScope) x e2+        subst1 = subst { substTmEnv = mapVarEnv (substTm "liftSubst" substE)+                                                (substTmEnv subst) }+        subst2 = extendIdSubst subst1 x e2+    if x `elemFreeVars` e2 then do+      (_,sp) <- Lens.use curFun+      throw (ClashException sp [I.i|+        Internal error: inlineOrLiftBInders failed on:++        #{showPpr (x,e)}++        creating a self-recursive let-binding:++        #{showPpr (x,e2)}++        given the already built subtitution:++        #{showDoc (clashPretty (substTmEnv subst))}+      |] Nothing)+    else+      go subst2 inl++isFromInt :: Text -> Bool+isFromInt nm = nm == "Clash.Sized.Internal.BitVector.fromInteger##" ||+               nm == "Clash.Sized.Internal.BitVector.fromInteger#" ||+               nm == "Clash.Sized.Internal.Index.fromInteger#" ||+               nm == "Clash.Sized.Internal.Signed.fromInteger#" ||+               nm == "Clash.Sized.Internal.Unsigned.fromInteger#"++inlineOrLiftBinders+  :: (LetBinding -> RewriteMonad extra Bool)+  -- ^ Property test+  -> (Term -> LetBinding -> Bool)+  -- ^ Test whether to lift or inline+  --+  -- * True: inline+  -- * False: lift+  -> Rewrite extra+inlineOrLiftBinders condition inlineOrLift (TransformContext inScope0 _) e@(Letrec bndrs body) = do+  (toReplace,toKeep) <- partitionM condition bndrs+  case toReplace of+    [] -> return e+    _  -> do+      let inScope1 = extendInScopeSetList inScope0 (map fst bndrs)+      let (toInline,toLift) = partition (inlineOrLift e) toReplace+      -- We first substitute the binders that we can inline both the binders+      -- that we intend to lift, the other binders, and the body+      let (toLiftExtra,(toReplace1,body1)) =+            substituteBinders inScope1 toInline (toLift ++ toKeep) body+          (toLift1,toKeep1) = splitAt (length toLift) toReplace1+      -- We then substitute the lifted binders in the other binders and the body+      (toKeep2,body2) <- liftAndSubsituteBinders inScope1+                           (toLiftExtra ++ toLift1)+                           toKeep1 body1+      case toKeep2 of+        [] -> changed body2+        _  -> changed (Letrec toKeep2 body2)++inlineOrLiftBinders _ _ _ e = return e++-- | Create a global function for a Let-binding and return a Let-binding where+-- the RHS is a reference to the new global function applied to the free+-- variables of the original RHS+liftBinding :: LetBinding+            -> RewriteMonad extra LetBinding+liftBinding (var@Id {varName = idName} ,e) = do+  -- Get all local FVs, excluding the 'idName' from the let-binding+  let unitFV :: Var a -> Const (UniqMap TyVar,UniqMap Id) (Var a)+      unitFV v@(Id {})    = Const (UniqMap.empty,UniqMap.singletonUnique (coerce v))+      unitFV v@(TyVar {}) = Const (UniqMap.singletonUnique (coerce v),UniqMap.empty)++      interesting :: Var a -> Bool+      interesting Id {idScope = GlobalId} = False+      interesting v@(Id {idScope = LocalId}) = varUniq v /= varUniq var+      interesting _ = True++      (boundFTVsSet,boundFVsSet) =+        getConst (Lens.foldMapOf (termFreeVars' interesting) unitFV e)+      boundFTVs = UniqMap.elems boundFTVsSet+      boundFVs  = UniqMap.elems boundFVsSet++  -- Make a new global ID+  tcm       <- Lens.view tcCache+  let newBodyTy = inferCoreTypeOf tcm $ mkTyLams (mkLams e boundFVs) boundFTVs+  (cf,sp)   <- Lens.use curFun+  binders <- Lens.use bindings+  newBodyNm <-+    cloneNameWithBindingMap+      binders+      (appendToName (varName cf) ("_" `Text.append` nameOcc idName))+  let newBodyId = mkGlobalId newBodyTy newBodyNm {nameSort = Internal}++  -- Make a new expression, consisting of the the lifted function applied to+  -- its free variables+  let newExpr = mkTmApps+                  (mkTyApps (Var newBodyId)+                            (map VarTy boundFTVs))+                  (map Var boundFVs)+      inScope0 = mkInScopeSet (coerce boundFVsSet)+      inScope1 = extendInScopeSetList inScope0 [var,newBodyId]+  let subst    = extendIdSubst (mkSubst inScope1) var newExpr+      -- Substitute the recursive calls by the new expression+      e' = substTm "liftBinding" subst e+      -- Create a new body that abstracts over the free variables+      newBody = mkTyLams (mkLams e' boundFVs) boundFTVs++  -- Check if an alpha-equivalent global binder already exists+  aeqExisting <- (UniqMap.elems . UniqMap.filter ((`aeqTerm` newBody) . bindingTerm)) <$> Lens.use bindings+  case aeqExisting of+    -- If it doesn't, create a new binder+    [] -> do -- Add the created function to the list of global bindings+             let r = newBodyId `globalIdOccursIn` newBody+             bindings %= UniqMap.insert newBodyNm+                                    -- We mark this function as internal so that+                                    -- it can be inlined at the very end of+                                    -- the normalisation pipeline as part of the+                                    -- flattening pass. We don't inline+                                    -- right away because we are lifting this+                                    -- function at this moment for a reason!+                                    -- (termination, CSE and DEC oppertunities,+                                    -- ,etc.)+                                    (Binding newBodyId sp NoUserInlinePrag IsFun newBody r)+             -- Return the new binder+             return (var, newExpr)+    -- If it does, use the existing binder+    (b:_) ->+      let newExpr' = mkTmApps+                      (mkTyApps (Var $ bindingId b)+                                (map VarTy boundFTVs))+                      (map Var boundFVs)+      in  return (var, newExpr')++liftBinding _ = error $ $(curLoc) ++ "liftBinding: invalid core, expr bound to tyvar"++-- | Make a global function for a name-term tuple+mkFunction+  :: TmName+  -- ^ Name of the function+  -> SrcSpan+  -> InlineSpec+  -> Term+  -- ^ Term bound to the function+  -> RewriteMonad extra Id+  -- ^ Name with a proper unique and the type of the function+mkFunction bndrNm sp inl body = do+  tcm <- Lens.view tcCache+  let bodyTy = inferCoreTypeOf tcm body+  binders <- Lens.use bindings+  bodyNm <- cloneNameWithBindingMap binders bndrNm+  addGlobalBind bodyNm bodyTy sp inl body+  return (mkGlobalId bodyTy bodyNm)++-- | Add a function to the set of global binders+addGlobalBind+  :: TmName+  -> Type+  -> SrcSpan+  -> InlineSpec+  -> Term+  -> RewriteMonad extra ()+addGlobalBind vNm ty sp inl body = do+  let vId = mkGlobalId ty vNm+      r = vId `globalIdOccursIn` body+  (ty,body) `deepseq` bindings %= UniqMap.insert vNm (Binding vId sp inl IsFun body r)++-- | Create a new name out of the given name, but with another unique. Resulting+-- unique is guaranteed to not be in the given InScopeSet.+cloneNameWithInScopeSet+  :: (MonadUnique m)+  => InScopeSet+  -> Name a+  -> m (Name a)+cloneNameWithInScopeSet is nm = do+  i <- getUniqueM+  return (uniqAway is (setUnique nm i))++-- | Create a new name out of the given name, but with another unique. Resulting+-- unique is guaranteed to not be in the given BindingMap.+cloneNameWithBindingMap+  :: (MonadUnique m)+  => BindingMap+  -> Name a+  -> m (Name a)+cloneNameWithBindingMap binders nm = do+  i <- getUniqueM+  return (uniqAway' (`UniqMap.elem` binders) i (setUnique nm i))++{-# INLINE isUntranslatable #-}+-- | Determine if a term cannot be represented in hardware+isUntranslatable+  :: Bool+  -- ^ String representable+  -> Term+  -> RewriteMonad extra Bool+isUntranslatable stringRepresentable tm = do+  tcm <- Lens.view tcCache+  not <$> (representableType <$> Lens.view typeTranslator+                             <*> Lens.view customReprs+                             <*> pure stringRepresentable+                             <*> pure tcm+                             <*> pure (inferCoreTypeOf tcm tm))++{-# INLINE isUntranslatableType #-}+-- | Determine if a type cannot be represented in hardware+isUntranslatableType+  :: Bool+  -- ^ String representable+  -> Type+  -> RewriteMonad extra Bool+isUntranslatableType stringRepresentable ty =+  not <$> (representableType <$> Lens.view typeTranslator+                             <*> Lens.view customReprs+                             <*> pure stringRepresentable+                             <*> Lens.view tcCache+                             <*> pure ty)++normalizeTermTypes :: TyConMap -> Term -> Term+normalizeTermTypes tcm e = case e of+  Cast e' ty1 ty2 -> Cast (normalizeTermTypes tcm e') (normalizeType tcm ty1) (normalizeType tcm ty2)+  Var v -> Var (normalizeId tcm v)+  -- TODO other terms?+  _ -> e++normalizeId :: TyConMap -> Id -> Id+normalizeId tcm v@(Id {}) = v {varType = normalizeType tcm (varType v)}+normalizeId _   tyvar     = tyvar++-- | Evaluate an expression to weak-head normal form (WHNF), and apply a+-- transformation on the expression in WHNF.+whnfRW+  :: Bool+  -- ^ Whether the expression we're reducing to WHNF is the subject of a+  -- case expression.+  -> TransformContext+  -> Term+  -> Rewrite extra+  -> RewriteMonad extra Term+whnfRW isSubj ctx@(TransformContext is0 hist) e rw = do+  tcm <- Lens.view tcCache+  bndrs <- Lens.use bindings+  eval <- Lens.view evaluator+  ids <- Lens.use uniqSupply+  let (ids1,ids2) = splitSupply ids+  uniqSupply Lens..= ids2+  gh <- Lens.use globalHeap+  let lh = localBinders mempty hist++  case whnf' eval bndrs lh tcm gh ids1 is0 isSubj e of+    (!gh1,ph,v) -> do+      globalHeap Lens..= gh1+      bindPureHeap tcm (ph `differenceVarEnv` lh) rw ctx v+ where+  localBinders acc [] = acc+  localBinders !acc (h:hs) = case h of+    LetBody ls -> localBinders (acc <> mkVarEnv ls) hs+    _ -> localBinders acc hs++{-# SCC whnfRW #-}++-- | Binds variables on the PureHeap over the result of the rewrite+--+-- To prevent unnecessary rewrites only do this when rewrite changed something.+bindPureHeap+  :: TyConMap+  -> PureHeap+  -> Rewrite extra+  -> Rewrite extra+bindPureHeap tcm heap rw ctx0@(TransformContext is0 hist) e = do+  (e1, Monoid.getAny -> hasChanged) <- Writer.listen $ rw ctx e+  if hasChanged && not (null bndrs) then do+    -- The evaluator results are post-processed with two operations:+    --+    --   1. Inline work free binders. We've seen cases in the wild† where the+    --      evaluator (or rather, 'bindPureHeap') would let-bind work-free+    --      binders that were crucial for eliminating case constructs. If these+    --      case constructs were used in a self-referential (but terminating)+    --      manner, Clash would get stuck in an infinite loop. The proper+    --      solution would be to use 'isWorkFree', instead of 'isWorkFreeIsh',+    --      in 'bindConstantVar' such that these work free constructs would get+    --      inlined again. However, this incurs a great performance penalty so+    --      we opt to prevent the evaluator from introducing this situation in+    --      the first place.+    --+    --      I'd like to stress that this is not a proper solution though, as GHC+    --      might produce a similar situation. We plan on properly solving this+    --      by eliminating the current lift/bind/eval strategy, instead replacing+    --      it by a partial evaluator‡.+    --+    --   2. Remove any unused let-bindings. Similar to (1), we risk Clash getting+    --      stuck in an infinite loop if we don't remove unused (eliminated by+    --      evaluation!) binders.+    --+    -- † https://github.com/clash-lang/clash-compiler/pull/1354#issuecomment-635430374+    -- ‡ https://www.microsoft.com/en-us/research/wp-content/uploads/2016/07/supercomp-by-eval.pdf+    bs <- Lens.use bindings+    inlineBinders (inlineTest bs) ctx0 (Letrec bndrs e1) >>= \case+      e2@(Let bnders1 e3) ->+        pure (fromMaybe e2 (removeUnusedBinders bnders1 e3))+      e2 ->+        pure e2+  else+    return e1+  where+    heapIds = map fst bndrs+    is1 = extendInScopeSetList is0 heapIds+    ctx = TransformContext is1 (LetBody bndrs : hist)++    bndrs = map toLetBinding $ UniqMap.toList heap++    toLetBinding :: (Unique,Term) -> LetBinding+    toLetBinding (uniq,term) = (nm, term)+      where+        ty = inferCoreTypeOf tcm term+        nm = mkLocalId ty (mkUnsafeSystemName "x" uniq) -- See [Note: Name re-creation]++    inlineTest bs _ (_, stripTicks -> e_) = isWorkFree workFreeBinders bs e_++-- | Remove unused binders in given let-binding. Returns /Nothing/ if no unused+-- binders were found.+removeUnusedBinders+  :: Bind Term+  -> Term+  -> Maybe Term+removeUnusedBinders (NonRec i _) body =+  let bodyFVs = Lens.foldMapOf freeLocalIds unitVarSet body+   in if i `elemVarSet` bodyFVs then Nothing else Just body++removeUnusedBinders (Rec binds) body =+  case eltsVarEnv used of+    [] -> Just body+    qqL | not (List.equalLength qqL binds)+        -> Just (Letrec qqL body)+        | otherwise+        -> Nothing+ where+  bodyFVs = Lens.foldMapOf freeLocalIds unitVarSet body+  used = List.foldl' collectUsed emptyVarEnv (eltsVarSet bodyFVs)+  bindsEnv = mkVarEnv (map (\(x,e0) -> (x,(x,e0))) binds)++  collectUsed env v =+    if v `elemVarEnv` env then+      env+    else+      case lookupVarEnv v bindsEnv of+        Just (x,e0) ->+          let eFVs = Lens.foldMapOf freeLocalIds unitVarSet e0+          in  List.foldl' collectUsed+                          (extendVarEnv x (x,e0) env)+                          (eltsVarSet eFVs)+        Nothing -> env
+ src/Clash/Rewrite/WorkFree.hs view
@@ -0,0 +1,209 @@+{-|+Copyright   : (C) 2020-2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qaylogic.com>++Check whether a term is work free or not. This is used by transformations /+evaluation to check whether it is possible to perform changes without+duplicating work in the result, e.g. inlining.+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++module Clash.Rewrite.WorkFree+  ( isWorkFree+  , isWorkFreeClockOrResetOrEnable+  , isWorkFreeIsh+  , isConstant+  , isConstantNotClockReset+  ) where++import Control.Lens (Lens')+import Control.Monad.Extra (allM, andM, eitherM)+import Control.Monad.State.Class (MonadState)+import qualified Data.Text.Extra as Text+import GHC.Stack (HasCallStack)++import Clash.Core.HasFreeVars+import Clash.Core.FreeVars+import Clash.Core.HasType+import Clash.Core.Pretty (showPpr)+import Clash.Core.Term+import Clash.Core.TyCon (TyConMap)+import Clash.Core.Type (isPolyFunTy)+import Clash.Core.Util+import Clash.Core.Var (Id, isLocalId)+import Clash.Core.VarEnv (VarEnv, lookupVarEnv)+import Clash.Driver.Types (BindingMap, Binding(..))+import Clash.Normalize.Primitives (removedArg)+import Clash.Util (makeCachedU)++-- | Determines whether a global binder is work free. Errors if binder does+-- not exist.+isWorkFreeBinder+  :: (HasCallStack, MonadState s m)+  => Lens' s (VarEnv Bool)+  -> BindingMap+  -> Id+  -> m Bool+isWorkFreeBinder cache bndrs bndr =+  makeCachedU bndr cache $+    case lookupVarEnv bndr bndrs of+      Nothing -> error ("isWorkFreeBinder: couldn't find binder: " ++ showPpr bndr)+      Just (bindingTerm -> t) ->+        if bndr `globalIdOccursIn` t+        then pure False+        else isWorkFree cache bndrs t++{-# INLINABLE isWorkFree #-}+-- | Determine whether a term does any work, i.e. adds to the size of the+-- circuit. This function requires a cache (specified as a lens) to store the+-- result for querying work info of global binders.+--+isWorkFree+  :: forall s m+   . (HasCallStack, MonadState s m)+  => Lens' s (VarEnv Bool)+  -> BindingMap+  -> Term+  -> m Bool+isWorkFree cache bndrs = go True+ where+  -- If we are in the outermost level of a term (i.e. not checking a subterm)+  -- then a term is work free if it simply refers to a local variable. This+  -- does not apply to subterms, as we do not want to count expressions like+  --+  --   f[LocalId] x[LocalId]+  --+  -- as being work free, as the term bound to f may introduce work.+  --+  go :: HasCallStack => Bool -> Term -> m Bool+  go isOutermost (collectArgs -> (fun, args)) =+    case fun of+      Var i+        -- We only allow polymorphic / function typed variables to be inlined+        -- if they are locally scoped, and the term is only a variable.+        --+        -- TODO This could be improved later by passing an InScopeSet to+        -- isWorkFree with all the local FVs of the term being checked. PE+        -- would need to be changed to know the FVs of global binders first.+        --+        | isPolyFunTy (coreTypeOf i) ->+            pure (isLocalId i && isOutermost && null args)+        | isLocalId i ->+            pure True+        | otherwise ->+            andM [isWorkFreeBinder cache bndrs i, allM goArg args]++      Data _ -> allM goArg args+      Literal _ -> pure True+      Prim pr ->+        case primWorkInfo pr of+          -- We can ignore arguments because the primitive outputs a constant+          -- regardless of their values.+          WorkConstant -> pure True+          WorkNever -> allM goArg args+          WorkIdentity _ _ -> allM goArg args+          WorkVariable -> pure (all isConstantArg args)+          WorkAlways -> pure False++      Lam _ e -> andM [go False e, allM goArg args]+      TyLam _ e -> andM [go False e, allM goArg args]+      Let (NonRec _ x) e -> andM [go False e, go False x, allM goArg args]+      Let (Rec bs) e -> andM [go False e, allM (go False . snd) bs, allM goArg args]+      Case s _ [(_, a)] -> andM [go False s, go False a, allM goArg args]+      Case e _ _ -> andM [go False e, allM goArg args]+      Cast e _ _ -> andM [go False e, allM goArg args]++      -- (Ty)App's and  Ticks are removed by collectArgs+      Tick _ _ -> error "isWorkFree: unexpected Tick"+      App {}   -> error "isWorkFree: unexpected App"+      TyApp {} -> error "isWorkFree: unexpected TyApp"++  goArg e = eitherM (go False) (pure . const True) (pure e)+  isConstantArg = either isConstant (const True)++-- | Determine if a term represents a constant+isConstant :: Term -> Bool+isConstant e = case collectArgs e of+  (Data _, args)   -> all (either isConstant (const True)) args+  (Prim _, args) -> all (either isConstant (const True)) args+  (Lam _ _, _)     -> isClosed e+  (Literal _,_)    -> True+  _                -> False++isConstantNotClockReset :: TyConMap -> Term -> Bool+isConstantNotClockReset tcm e+  | isClockOrReset tcm eTy =+      case fst (collectArgs e) of+        Prim pr -> primName pr == Text.showt 'removedArg+        _ -> False++  | otherwise = isConstant e+ where+  eTy = inferCoreTypeOf tcm e++-- TODO: Remove function after using WorkInfo in 'isWorkFreeIsh'+isWorkFreeClockOrResetOrEnable+  :: TyConMap+  -> Term+  -> Maybe Bool+isWorkFreeClockOrResetOrEnable tcm e =+  let eTy = inferCoreTypeOf tcm e in+  if isClockOrReset tcm eTy || isEnable tcm eTy then+    case collectArgs e of+      (Prim p,_) -> Just (primName p == Text.showt 'removedArg)+      -- Only local variables with a clock type are work-free. When it is a global+      -- variable, it is probably backed by a clock generator, which is definitely+      -- not work-free.+      --+      -- Inlining let-bindings referencing a global variable with a clock type+      -- can sometimes lead to the post-normalization flattening stage to generate+      -- code that violates the invariants of the netlist generation stage.+      -- Especially when this global binder is defined recursively such as when+      -- using `tbClockGen`.+      -- This then ultimately leads to bad verilog names being generated as+      -- reported in: https://github.com/clash-lang/clash-compiler/issues/2845+      (Var v, []) -> Just (isLocalId v)+      (Data _, [_dom, Left (stripTicks -> Data _)]) -> Just True -- For Enable True/False+      (Literal _,_) -> Just True+      _ -> Just False+  else+    Nothing++-- | A conservative version of 'isWorkFree'. Is used to determine in 'bindConstantVar'+-- to determine whether an expression can be "bound" (locally inlined). While+-- binding workfree expressions won't result in extra work for the circuit, it+-- might very well cause extra work for Clash. In fact, using 'isWorkFree' in+-- 'bindConstantVar' makes Clash two orders of magnitude slower for some of our+-- test cases.+--+-- In effect, this function is a version of 'isConstant' that also considers+-- references to clocks and resets constant. This allows us to bind+-- HiddenClock(ResetEnable) constructs, allowing Clash to constant spec+-- subconstants - most notably KnownDomain. Doing that enables Clash to+-- eliminate any case-constructs on it.+isWorkFreeIsh+  :: TyConMap+  -> Term+  -> Bool+isWorkFreeIsh tcm e =+  case isWorkFreeClockOrResetOrEnable tcm e of+    Just b -> b+    Nothing ->+      case collectArgs e of+        (Data _, args)     -> all isWorkFreeIshArg args+        (Prim pInfo, args) -> case primWorkInfo pInfo of+          WorkAlways   -> False -- Things like clock or reset generator always+                                       -- perform work+          WorkVariable -> all isConstantArg args+          _            -> all isWorkFreeIshArg args++        (Lam _ _, _)       -> isClosed e+        (Literal _,_)      -> True+        _                  -> False+ where+  isWorkFreeIshArg = either (isWorkFreeIsh tcm) (const True)+  isConstantArg    = either isConstant (const True)
+ src/Clash/Unique.hs view
@@ -0,0 +1,74 @@+{-|+  Copyright   :  (C) 2024, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Clash.Unique+  ( Unique+  , pattern Unique#+  , Unique#+  , Uniquable (..)+  , fromGhcUnique+  ) where++#if MIN_VERSION_ghc(9,8,4) || (MIN_VERSION_ghc(9,6,7) && !MIN_VERSION_ghc(9,8,0))+#define UNIQUE_IS_WORD64+#endif++import Data.Word (Word64)++#ifdef UNIQUE_IS_WORD64+import GHC.Word (Word64(W64#))+import GHC.Exts (Word64#)+#else+import GHC.Int (Int(I#))+import GHC.Exts (Int#)+#endif+import qualified GHC.Types.Unique as GHC++#ifdef UNIQUE_IS_WORD64+type Unique = Word64+type Unique# = Word64#++pattern Unique#+  :: Unique#+  -- ^ Type of signal+  -> Unique+pattern Unique# u <- W64# u+  where+    Unique# u = W64# u+#else+type Unique = Int+type Unique# = Int#++pattern Unique#+  :: Unique#+  -- ^ Type of signal+  -> Unique+pattern Unique# u <- I# u+  where+    Unique# u = I# u+#endif++class Uniquable a where+  getUnique :: a -> Unique+  setUnique :: a -> Unique -> a++instance Uniquable Unique where+  getUnique = id+  setUnique = flip const++#ifndef UNIQUE_IS_WORD64+instance Uniquable Word64 where+  getUnique = fromIntegral+  setUnique _ = fromIntegral+#endif++fromGhcUnique :: GHC.Unique -> Unique+fromGhcUnique = GHC.getKey
+ src/Clash/Util.hs view
@@ -0,0 +1,339 @@+{-|+  Copyright   :  (C) 2012-2016, University of Twente+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Assortment of utility function used in the Clash library+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Clash.Util+  ( module Clash.Util+  , SrcSpan+  , noSrcSpan+  , hoistMaybe+  )+where++import qualified Control.Exception    as Exception+import Control.Lens+import Control.Monad.State            (MonadState,StateT)+import qualified Control.Monad.State  as State+import Control.Monad.Trans.Maybe      (hoistMaybe)+import Data.Hashable                  (Hashable)+import Data.HashMap.Lazy              (HashMap)+import qualified Data.HashMap.Lazy    as HashMapL+import qualified Data.List.Extra      as List+import Data.Maybe                     (fromMaybe, listToMaybe, catMaybes)+import Data.Map.Ordered               (OMap)+import qualified Data.Map.Ordered     as OMap++#if MIN_VERSION_prettyprinter(1,7,0)+import Prettyprinter+import Prettyprinter.Render.String+#else+import Data.Text.Prettyprint.Doc+import Data.Text.Prettyprint.Doc.Render.String+#endif++import Data.Time.Clock                (UTCTime)+import qualified Data.Time.Clock      as Clock+import qualified Data.Time.Format     as Clock+import Data.Typeable                  (Typeable)+import Data.Version                   (Version)+import GHC.Base                       (Int(..),isTrue#,(==#),(+#))+import GHC.Integer.Logarithms         (integerLogBase#)+import qualified GHC.LanguageExtensions.Type as LangExt+import GHC.Stack                      (HasCallStack, callStack, prettyCallStack)+import Type.Reflection                (tyConPackage, typeRepTyCon, typeOf)+import qualified Language.Haskell.TH  as TH++import GHC.Types.SrcLoc               (SrcSpan, noSrcSpan)++import Clash.Data.UniqMap (UniqMap)+import qualified Clash.Data.UniqMap as UniqMap+import Clash.Debug+import Clash.Unique++#ifdef CABAL+import qualified Paths_clash_lib      (version)+#endif++{- $setup+>>> :m -Prelude+>>> import Clash.Prelude+-}++data ClashException = ClashException SrcSpan String (Maybe String)++instance Show ClashException where+  show (ClashException _ s eM) = s ++ "\n" ++ maybe "" id eM++instance Exception.Exception ClashException++-- | Construct a string pattern match out of the given @TemplateHaskell@ name+namePat :: TH.Name -> TH.Q TH.Pat+namePat = return . TH.LitP . TH.StringL . show++assertPanic+  :: String -> Int -> a+assertPanic file ln = Exception.throw+  (ClashException noSrcSpan ("ASSERT failed! file " ++ file ++ ", line " ++ show ln) Nothing)++assertPprPanic+  :: HasCallStack => String -> Int -> Doc ann -> a+assertPprPanic _file _line msg = pprPanic "ASSERT failed!" doc+ where+  doc = sep [ msg, callStackDoc ]++pprPanic+  :: String -> Doc ann -> a+pprPanic heading prettyMsg = Exception.throw+  (ClashException noSrcSpan (renderString (layoutPretty defaultLayoutOptions doc)) Nothing)+ where+  doc = sep [pretty heading, nest 2 prettyMsg]++callStackDoc+  :: HasCallStack => Doc ann+callStackDoc =+  "Call stack:" <+> hang 4+    (vcat (map pretty (lines (prettyCallStack callStack))))++warnPprTrace+  :: HasCallStack+  => Bool+  -- ^ Trigger warning?+  -> String+  -- ^ File name+  -> Int+  -- ^ Line number+  -> Doc ann+  -- ^ Message+  -> a+  -- ^ Pass value (like trace)+  -> a+warnPprTrace _     _ _ _ x | not debugIsOn = x+warnPprTrace False _ _ _ x = x+warnPprTrace True  file ln msg x =+  pprDebugAndThen trace (vcat [heading0, heading1]) msg x+ where+  heading0 = hsep ["WARNING: file", pretty file <> comma, "line", pretty ln]+  heading1 = "WARNING CALLSTACK:" <> line <> pretty (prettyCallStack callStack)++pprTrace+  :: String -> Doc ann -> a -> a+pprTrace str = pprDebugAndThen trace (pretty str)++pprTraceDebug+  :: String -> Doc ann -> a -> a+pprTraceDebug str doc x+  | debugIsOn = pprTrace str doc x+  | otherwise = x++pprDebugAndThen+  :: (String -> a) -> Doc ann -> Doc ann -> a+pprDebugAndThen cont heading prettyMsg =+  cont (renderString (layoutPretty defaultLayoutOptions doc))+ where+  doc = sep [heading, nest 2 prettyMsg]++-- | A class that can generate unique numbers+class Monad m => MonadUnique m where+  -- | Get a new unique+  getUniqueM :: m Unique++instance Monad m => MonadUnique (StateT Unique m) where+  getUniqueM = do+    supply <- State.get+    State.modify (+1)+    return supply++-- | Create a TH expression that returns the a formatted string containing the+-- name of the module 'curLoc' is spliced into, and the line where it was spliced.+curLoc :: TH.Q TH.Exp+curLoc = do+  (TH.Loc _ _ modName (startPosL,_) _) <- TH.location+  TH.litE (TH.StringL $ modName ++ "(" ++ show startPosL ++ "): ")++-- | Cache the result of a monadic action+makeCached :: (MonadState s m, Hashable k, Eq k)+           => k -- ^ The key the action is associated with+           -> Lens' s (HashMap k v) -- ^ The Lens to the HashMap that is the cache+           -> m v -- ^ The action to cache+           -> m v+makeCached key l create = do+  cache <- use l+  case HashMapL.lookup key cache of+    Just value -> return value+    Nothing -> do+      value <- create+      l %= HashMapL.insert key value+      return value++-- | Cache the result of a monadic action using a 'UniqMap'+makeCachedU+  :: (MonadState s m, Uniquable k)+  => k+  -- ^ Key the action is associated with+  -> Lens' s (UniqMap v)+  -- ^ Lens to the cache+  -> m v+  -- ^ Action to cache+  -> m v+makeCachedU key l create = do+  cache <- use l+  case UniqMap.lookup key cache of+    Just value -> return value+    Nothing -> do+      value <- create+      l %= UniqMap.insert key value+      return value++-- | Cache the result of a monadic action using a 'OMap'+makeCachedO+  :: (MonadState s m, Uniquable k)+  => k+  -- ^ Key the action is associated with+  -> Lens' s (OMap Unique v)+  -- ^ Lens to the cache+  -> m v+  -- ^ Action to cache+  -> m v+makeCachedO key l create = do+  cache <- use l+  case OMap.lookup (getUnique key) cache of+    Just value -> return value+    Nothing -> do+      value <- create+      l %= (flip (OMap.|>)) (getUnique key, value)+      return value++-- | Same as 'indexNote' with last two arguments swapped+indexNote'+  :: HasCallStack+  => String+  -- ^ Error message to display+  -> Int+  -- ^ Index /n/+  -> [a]+  -- ^ List to index+  -> a+  -- ^ Error or element /n/+indexNote' = flip . indexNote++-- | Unsafe indexing, return a custom error message when indexing fails+indexNote+  :: HasCallStack+  => String+  -- ^ Error message to display+  -> [a]+  -- ^ List to index+  -> Int+  -- ^ Index /n/+  -> a+  -- ^ Error or element /n/+indexNote note = \xs i -> fromMaybe (error note) (List.indexMaybe xs i)++clashLibVersion :: Version+#ifdef CABAL+clashLibVersion = Paths_clash_lib.version+#else+clashLibVersion = error "development version"+#endif++-- | \x y -> floor (logBase x y), x > 1 && y > 0+flogBase :: Integer -> Integer -> Maybe Int+flogBase x y | x > 1 && y > 0 = Just (I# (integerLogBase# x y))+flogBase _ _ = Nothing++-- | \x y -> ceiling (logBase x y), x > 1 && y > 0+clogBase :: Integer -> Integer -> Maybe Int+clogBase x y | x > 1 && y > 0 =+  case y of+    1 -> Just 0+    _ -> let z1 = integerLogBase# x y+             z2 = integerLogBase# x (y-1)+         in  if isTrue# (z1 ==# z2)+                then Just (I# (z1 +# 1#))+                else Just (I# z1)+clogBase _ _ = Nothing++-- | Get the package id of the type of a value+--+-- >>> pkgIdFromTypeable (0 :: Unsigned 32)+-- "clash-prelude-...+--+pkgIdFromTypeable :: Typeable a => a -> String+pkgIdFromTypeable = tyConPackage . typeRepTyCon . typeOf++reportTimeDiff :: UTCTime -> UTCTime -> String+reportTimeDiff end start+  | diff >= Clock.nominalDay = show days <> "d" <> Clock.formatTime Clock.defaultTimeLocale fmt+    (Clock.UTCTime (toEnum 0) (fromRational (toRational hms)))+  | otherwise = Clock.formatTime Clock.defaultTimeLocale fmt+    (Clock.UTCTime (toEnum 0) (fromRational (toRational diff)))+ where+  diff = Clock.diffUTCTime end start+  (days,hms) = divMod @Integer (floor diff) (floor Clock.nominalDay)+  fmt  | diff >= 3600+       = "%-Hh%-Mm%-Ss"+       | diff >= 60+       = "%-Mm%-Ss"+       | otherwise+       = "%-S%03Qs"++-- | Left-biased choice on maybes+orElses :: [Maybe a] -> Maybe a+orElses = listToMaybe . catMaybes++-- These language extensions are used for+--  * the interactive session inside clashi+--  * compiling files with clash+--  * running output tests with runghc+--  * compiling (local) Template/Blackbox functions with Hint+--+-- When changing this list please update docs/developing-hardware/language.rst+wantedLanguageExtensions :: [LangExt.Extension]+wantedLanguageExtensions =+  [ LangExt.BinaryLiterals+  , LangExt.ConstraintKinds+  , LangExt.DataKinds+  , LangExt.DeriveAnyClass+  , LangExt.DeriveGeneric+  , LangExt.DeriveLift+  , LangExt.DerivingStrategies+  , LangExt.ExplicitForAll+  , LangExt.ExplicitNamespaces+  , LangExt.FlexibleContexts+  , LangExt.FlexibleInstances+  , LangExt.KindSignatures+  , LangExt.MagicHash+  , LangExt.MonoLocalBinds+  , LangExt.NumericUnderscores+  , LangExt.QuasiQuotes+  , LangExt.ScopedTypeVariables+  , LangExt.TemplateHaskell+  , LangExt.TemplateHaskellQuotes+  , LangExt.TypeApplications+  , LangExt.TypeFamilies+  , LangExt.TypeOperators+  ]++unwantedLanguageExtensions :: [LangExt.Extension]+unwantedLanguageExtensions =+  [ LangExt.ImplicitPrelude+  , LangExt.StarIsType+  , LangExt.Strict+  , LangExt.StrictData+  ]++thenCompare :: Ordering -> Ordering -> Ordering+thenCompare EQ rel = rel+thenCompare rel _  = rel
+ src/Clash/Util/Eq.hs view
@@ -0,0 +1,46 @@+{-|+  Copyright  :  (C) 2021     , QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Utilities related to the 'Eq' type class.+-}+{-# LANGUAGE MagicHash #-}++module Clash.Util.Eq+  ( fastEq+  , fastEqBy+  ) where++import GHC.Exts (isTrue#, reallyUnsafePtrEquality#)++-- | Compare two values using pointer equality. If that fails, use 'Eq' to+-- determine equality. Note that this function will only shortcut for values+-- that are the same, but will always use 'Eq' for values that differ.+--+-- Values are evaluated to WHNF before comparison. This function can therefore+-- not be used if any of its arguments is expected to be bottom.+fastEq :: Eq a => a -> a -> Bool+fastEq = fastEqBy (==)++-- | Compare two values using pointer equality. If that fails, use given function+-- to determine equality. Note that this function will only shortcut for values+-- that are the same, but will always use the given function for values that+-- differ.+--+-- Values are evaluated to WHNF before comparison. This function can therefore+-- not be used if any of its arguments is expected to be bottom.+fastEqBy :: (a -> a -> Bool) -> a -> a -> Bool+fastEqBy f a1 a2+  | a1 `pointerEq` a2 = True+  | otherwise = f a1 a2++{-# NOINLINE pointerEq #-}+-- | Compares two values by comparing their positions on the heap. This function+-- will return 'True' if the values are the same object, 'False' otherwise. Note+-- that 'False' does *not* mean that the values are *not* the same. Values are+-- evaluated to WHNF before comparison.+--+-- Note: copied from @unordered-containers@.+pointerEq :: a -> a -> Bool+pointerEq !x !y = isTrue# (reallyUnsafePtrEquality# x y)
+ src/Clash/Util/Graph.hs view
@@ -0,0 +1,169 @@+{-|+  Copyright   :  (C) 2018, QBayLogic+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++  Collection of utilities+-}++{-# LANGUAGE CPP #-}++module Clash.Util.Graph+  ( topSort+  , reverseTopSort+  , callGraphBindings+  ) where++#if MIN_VERSION_ghc(9,8,4) || (MIN_VERSION_ghc(9,6,7) && !MIN_VERSION_ghc(9,8,0))+#define UNIQUE_IS_WORD64+#endif++import           Data.Tuple            (swap)+import           Data.Foldable         (foldlM)+#ifdef UNIQUE_IS_WORD64+import qualified GHC.Data.Word64Map.Strict as IntMap+import qualified GHC.Data.Word64Set        as IntSet+#else+import           Data.IntMap.Strict    (IntMap)+import qualified Data.IntMap.Strict    as IntMap+import           Data.IntSet           (IntSet)+import qualified Data.IntSet           as IntSet+#endif++import           Clash.Core.Var (Id)+import           Clash.Core.Term (Term)+import qualified Clash.Data.UniqMap as UniqMap+import           Clash.Driver.Types (BindingMap, Binding (bindingTerm))+import           Clash.Normalize.Util (callGraph)+import           Clash.Unique (Unique)++#ifdef UNIQUE_IS_WORD64+type IntMap = IntMap.Word64Map+type IntSet = IntSet.Word64Set+#endif++data Marker+  = Temporary+  | Permanent++headSafe :: [a] -> Maybe a+headSafe [] = Nothing+headSafe (a:_) = Just a++topSortVisit'+  :: IntMap [Unique]+  -- ^ Edges+  -> IntSet+  -- ^ Unmarked nodes+  -> IntMap Marker+  -- ^ Marked nodes+  -> [Unique]+  -- ^ Sorted so far+  -> Unique+  -- ^ Node to visit+  -> Either String (IntSet, IntMap Marker, [Unique])+topSortVisit' edges unmarked marked sorted node =+  case IntMap.lookup node marked of+    Just Permanent -> Right (unmarked, marked, sorted)+    Just Temporary -> Left "cycle detected: cannot topsort cyclic graph"+    Nothing -> do+      let marked'   = IntMap.insert node Temporary marked+      let unmarked' = IntSet.delete node unmarked+      let nodeToM   = IntMap.findWithDefault [] node edges+      (unmarked'', marked'', sorted'') <-+        foldlM visit (unmarked', marked', sorted) nodeToM+      let marked''' = IntMap.insert node Permanent marked''+      return (unmarked'', marked''', node : sorted'')+  where+    visit (unmarked', marked', sorted') node' =+      topSortVisit' edges unmarked' marked' sorted' node'++topSortVisit+  :: IntMap [Unique]+  -- ^ Edges+  -> IntSet+  -- ^ Unmarked nodes+  -> IntMap Marker+  -- ^ Marked nodes+  -> [Unique]+  -- ^ Sorted so far+  -> Unique+  -- ^ Node to visit+  -> Either String (IntSet, IntMap Marker, [Unique])+topSortVisit edges unmarked marked sorted node = do+  (unmarked', marked', sorted') <-+    topSortVisit' edges unmarked marked sorted node++  case headSafe (IntSet.toList unmarked') of+    Nothing    -> return (unmarked', marked', sorted')+    Just node' -> topSortVisit edges unmarked' marked' sorted' node'++-- | See: https://en.wikipedia.org/wiki/Topological_sorting. This function+-- errors if edges mention nodes not mentioned in the node list or if the+-- given graph contains cycles.+topSort+  :: [(Unique, a)]+  -- ^ Nodes+  -> [(Unique, Unique)]+  -- ^ Edges+  -> Either String [a]+  -- ^ Error message or topologically sorted nodes+topSort []             []     = Right []+topSort []             _edges = Left "Node list was empty, but edges non-empty"+topSort nodes@(node:_)  edges = do+  _ <- mapM (\(n, m) -> checkNode n >> checkNode m) edges++  (_, _, sorted) <-+    topSortVisit edges' (IntMap.keysSet nodes') IntMap.empty [] (fst node)++  mapM lookup' sorted+    where+      nodes' = IntMap.fromList nodes+      edges' = foldl insert IntMap.empty edges++      -- Construction functions for quick lookup of edges from n to m, given n+      insert im (n, m)    = IntMap.alter (insert' m) n im+      insert' m Nothing   = Just [m]+      insert' m (Just ms) = Just (m:ms)++      -- Lookup node in nodes map. If not present, yield error+      lookup' n =+        case IntMap.lookup n nodes' of+          Nothing+            -> Left ("Node " ++ show n ++ " in edge list, but not in node list.")+          Just n'+            -> Right n'++      -- Check if edge is valid (i.e., mentioned nodes are in node list)+      checkNode n+        | IntMap.notMember n nodes' =+            Left ("Node " ++ show n ++ " in edge list, but not in node list.")+        | otherwise =+            Right n++-- | Same as `reverse (topSort nodes edges)` if alternative representations are+-- considered the same. That is, topSort might produce multiple answers and+-- still deliver on its promise of yielding a topologically sorted node list.+-- Likewise, this function promises __one__ of those lists in reverse, but not+-- necessarily the reverse of topSort itself.+reverseTopSort+  :: [(Unique, a)]+  -- ^ Nodes+  -> [(Unique, Unique)]+  -- ^ Edges+  -> Either String [a]+  -- ^ Reversely, topologically sorted nodes+reverseTopSort nodes edges =+  topSort nodes (map swap edges)++-- | Get all the terms corresponding to a call graph+callGraphBindings+  :: BindingMap+  -- ^ All bindings+  -> Id+  -- ^ Root of the call graph+  -> [Term]+callGraphBindings bindingsMap tm =+  map (bindingTerm . (`UniqMap.find` bindingsMap)) (UniqMap.keys cg)+  where+    cg = callGraph bindingsMap tm
+ src/Clash/Util/Interpolate.hs view
@@ -0,0 +1,396 @@+{-|+Copyright  :  (C) 2019-2022, QBayLogic B.V.+                  2013     , Nikita Volkov+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-+This is an adaptation of++  https://github.com/nikita-volkov/neat-interpolation/tree/0fc1dd73ea++which is licensed under MIT. The original license will follow.++---------++Copyright (c) 2013, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.++-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++-- TODO: only export the @i@ quasiquoter when `ghcide` stops type-checking+-- expanded quasiquote splices+module Clash.Util.Interpolate (i, format, toString) where++import           Language.Haskell.Meta.Parse (parseExp)+import           Language.Haskell.TH.Lib     (appE, varE)+import           Language.Haskell.TH.Quote   (QuasiQuoter(..))+import           Language.Haskell.TH.Syntax  (Q, Exp)++import qualified Numeric                as N+import           Data.Char+  (isHexDigit, chr, isOctDigit, isDigit, isSpace)+import           Data.Maybe             (fromMaybe, isJust, catMaybes)+import           Text.Read              (readMaybe)++data Line+  = EmptyLine+  | ExprLine Indent String+  | Line Indent [Node]+  deriving (Show)++data Node+  = Literal String+  | Expression String+  deriving (Show)++type Indent = Int++format :: [Node] -> String+format = stripWhiteSpace . showLines . nodesToLines+ where+  go _ [] = []+  go n (c:cs) | c == ' ' = go (n+1) cs+  go 0 (c:cs) = c : go 0 cs+  go n cs = replicate n ' ' ++ (go 0 cs)++  stripWhiteSpace = go 0 . dropWhile isSpace+++showLines :: [Line] -> String+showLines [] = ""+showLines ns = init (concatMap showLine ns)+ where+  showLine :: Line -> String+  showLine EmptyLine = "\n"+  showLine (Line n ns') =+    let theIndent = replicate (n - commonIndent) ' ' in+    theIndent ++ (concatMap nodeToString ns') ++ "\n"+  showLine (ExprLine n s) =+    let theIndent = replicate (n - commonIndent) ' ' in+    concat [theIndent ++ l ++ "\n" | l <- lines s]++  nodeToString :: Node -> String+  nodeToString (Literal s) = s+  nodeToString (Expression s) = s++  commonIndent :: Indent+  commonIndent = foldl1 min (catMaybes (map indent ns))++  indent :: Line -> Maybe Indent+  indent EmptyLine = Nothing+  indent (ExprLine n _) = Just n+  indent (Line n _) = Just n++-- | Collects nodes into lines. Expressions might still contain newlines! Does+-- not start or end with 'EmptyLine'.+nodesToLines :: [Node] -> [Line]+nodesToLines =+    concatMap splitLines+  . mergeLines+  . dropEmpty+  . map splitWords+  . map toLine+  . map dropTrailingEmpty+  . collectLines []+  . joinLiterals+ where+  emptyLit (Literal s) =+    if all isSpace s then+      Just (length s)+    else+      Nothing+  emptyLit _ = Nothing++  isEmptyLine EmptyLine = True+  isEmptyLine _ = False++  dropEmpty = reverse . dropWhile isEmptyLine . reverse . dropWhile isEmptyLine+  dropTrailingEmpty = reverse . dropWhile (isJust . emptyLit) . reverse++  splitLines :: Line -> [Line]+  splitLines EmptyLine = [EmptyLine]+  splitLines e@(ExprLine {}) = [e]+  splitLines (Line n nodes) = map (Line n) (go 0 [] nodes)+   where+    maxLength = 80++    go :: Int -> [Node] -> [Node] -> [[Node]]+    go accLen acc goNodes | accLen > maxLength = reverse acc : go 0 [] goNodes+    go accLen acc (l@(Literal s):goNodes) = go (accLen + length s) (l:acc) goNodes+    go accLen acc (e@(Expression s):goNodes) = go (accLen + length s) (e:acc) goNodes+    go _accLen acc [] = [reverse acc]++  mergeLines :: [Line] -> [Line]+  mergeLines (l0@(Line n0 nodes0):l1@(Line n1 nodes1):ls) =+    if n0 == n1 then+      mergeLines (Line n0 (nodes0 ++ [Literal " "] ++ nodes1) : ls)+    else+      l0:mergeLines (l1:ls)+  mergeLines (l:ls) = l:mergeLines ls+  mergeLines [] = []++  splitWords :: Line -> Line+  splitWords EmptyLine = EmptyLine+  splitWords e@(ExprLine {})= e+  splitWords (Line n nodes) = Line n (concatMap go nodes)+   where+    go (Expression s) = [Expression s]+    go (Literal "") = []+    go (Literal s0) =+      let+        pre = takeWhile (not . (==' ')) s0+        post = dropWhile (not . (== ' ')) s0+      in case post of+        [] -> [Literal s0]+        (_:s1) -> Literal (pre ++ " ") : go (Literal s1)++  -- Convert to 'Line' type+  toLine = \case+    [] -> EmptyLine+    [emptyLit -> Just _] -> EmptyLine+    [Expression s] -> ExprLine 0 s+    [emptyLit -> Just n, Expression s] -> ExprLine n s+    ns@(Expression _:_) -> Line 0 ns+    (Literal s:ns) ->+      Line+        (length (takeWhile (==' ') s))+        (Literal (dropWhile (==' ') s):ns)++  -- collects list of nodes, where each list is a single line+  collectLines collected todo =+    case (collected, todo) of+      ([], []) -> []+      (_, []) -> [reverse collected]+      (_, s@(Expression _):ns) ->+        collectLines (s:collected) ns+      (_, Literal s0:ns) ->+        let+          pre = takeWhile (/= '\n') s0+          post = dropWhile (/= '\n') s0+        in case post of+          [] ->+            collectLines (Literal s0:collected) ns+          (_:s1) ->+            reverse (Literal pre:collected) : collectLines [] (Literal s1:ns)++  joinLiterals :: [Node] -> [Node]+  joinLiterals [] = []+  joinLiterals (Literal s0:Literal s1:ss) = joinLiterals (Literal (s0 ++ s1):ss)+  joinLiterals (n:ns) = n:joinLiterals ns++{-|+@i@ will reflow the quasi-quoted text to 90 columns wide. If an interpolation+variable is on its own line and expands to a multi-line string, the interpolated+text will be indented the same as the interpolation variable was:++> :set -XQuasiQuotes+> :{+> a = "Multi\nLine\nString"+> b = [i|+>     This line will be reflowed+>     and the interpolated+>     multi-line string here:+>         #{a}+>     will be indented. This+>     text is outdented again.+>   |]+> :}+> putStrLn b+This line will be reflowed and the interpolated multi-line string here:+    Multi+    Line+    String+will be indented. This text is outdented again.+-}+i :: QuasiQuoter+i = QuasiQuoter {+    quoteExp = (varE 'format `appE`) . toExp . parseNodes . decodeNewlines+  , quotePat = err "pattern"+  , quoteType = err "type"+  , quoteDec = err "declaration"+  }+  where+    err name =+      error ("Clash.Util.Interpolate.i: This QuasiQuoter can not be used as a "+           ++ name ++ "!")++    toExp:: [Node] -> Q Exp+    toExp nodes = case nodes of+      [] -> [|[]|]+      (x:xs) -> f x `appE` toExp xs+      where+        f (Literal s) = [|(Literal s:)|]+        f (Expression e) = [|(Expression (toString ($(reifyExpression e))):)|]++        reifyExpression :: String -> Q Exp+        reifyExpression s = case parseExp s of+          Left _ -> do+            fail ("Parse error in expression: " ++ s) :: Q Exp+          Right e -> return e++parseNodes :: String -> [Node]+parseNodes = go ""+  where+    go :: String -> String -> [Node]+    go acc input = case input of+      ""  -> [(lit . reverse) acc]+      '\\':x:xs -> go (x:'\\':acc) xs+      '#':'{':xs -> goExpr input acc [] xs+      x:xs -> go (x:acc) xs+    -- allow '}' to be escaped in code sections+    goExpr input accLit accExpr xs = case span (\x -> x /= '}' && x /= '\\') xs of+      (ys, '}' :zs) -> (lit . reverse) accLit : Expression (reverse accExpr ++ ys) : go "" zs+      (ys, '\\':'}':zs) -> goExpr input accLit ('}' : reverse ys ++ accExpr) zs+      (ys, '\\':zs) -> goExpr input accLit ('\\' : reverse ys ++ accExpr) zs+      (_, "") -> [lit (reverse accLit ++ input)]+      _ -> error "(impossible) parseError in parseNodes"+    lit :: String -> Node+    lit = Literal . unescape++-------------------------------------------------------------------+-- Everything below this line is unchanged from neat-interpolate --+-- apart from updated module identifier strings                  --+-------------------------------------------------------------------+decodeNewlines :: String -> String+decodeNewlines = go+  where+    go xs = case xs of+      '\r' : '\n' : ys -> '\n' : go ys+      y : ys -> y : go ys+      [] -> []++toString :: Show a => a -> String+toString a = let s = show a in fromMaybe s (readMaybe s)+{-# NOINLINE toString #-}+{-# RULES "toString/String" toString = id #-}+{-# RULES "toString/Int" toString = show :: Int -> String #-}+{-# RULES "toString/Integer" toString = show :: Integer -> String #-}+{-# RULES "toString/Float" toString = show :: Float -> String #-}+{-# RULES "toString/Double" toString = show :: Double -> String #-}++-- Haskell 2010 character unescaping, see:+-- http://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6+unescape :: String -> String+unescape = go+  where+    go input = case input of+      "" -> ""+      '\\' : 'x' : x : xs | isHexDigit x -> case span isHexDigit xs of+        (ys, zs) -> (chr . readHex $ x:ys) : go zs+      '\\' : 'o' : x : xs | isOctDigit x -> case span isOctDigit xs of+        (ys, zs) -> (chr . readOct $ x:ys) : go zs+      '\\' : x : xs | isDigit x -> case span isDigit xs of+        (ys, zs) -> (chr . read $ x:ys) : go zs+      '\\' : input_ -> case input_ of+        '\\' : xs -> '\\' : go xs+        'a' : xs -> '\a' : go xs+        'b' : xs -> '\b' : go xs+        'f' : xs -> '\f' : go xs+        'n' : xs -> '\n' : go xs+        'r' : xs -> '\r' : go xs+        't' : xs -> '\t' : go xs+        'v' : xs -> '\v' : go xs+        '&' : xs -> go xs+        'N':'U':'L' : xs -> '\NUL' : go xs+        'S':'O':'H' : xs -> '\SOH' : go xs+        'S':'T':'X' : xs -> '\STX' : go xs+        'E':'T':'X' : xs -> '\ETX' : go xs+        'E':'O':'T' : xs -> '\EOT' : go xs+        'E':'N':'Q' : xs -> '\ENQ' : go xs+        'A':'C':'K' : xs -> '\ACK' : go xs+        'B':'E':'L' : xs -> '\BEL' : go xs+        'B':'S' : xs -> '\BS' : go xs+        'H':'T' : xs -> '\HT' : go xs+        'L':'F' : xs -> '\LF' : go xs+        'V':'T' : xs -> '\VT' : go xs+        'F':'F' : xs -> '\FF' : go xs+        'C':'R' : xs -> '\CR' : go xs+        'S':'O' : xs -> '\SO' : go xs+        'S':'I' : xs -> '\SI' : go xs+        'D':'L':'E' : xs -> '\DLE' : go xs+        'D':'C':'1' : xs -> '\DC1' : go xs+        'D':'C':'2' : xs -> '\DC2' : go xs+        'D':'C':'3' : xs -> '\DC3' : go xs+        'D':'C':'4' : xs -> '\DC4' : go xs+        'N':'A':'K' : xs -> '\NAK' : go xs+        'S':'Y':'N' : xs -> '\SYN' : go xs+        'E':'T':'B' : xs -> '\ETB' : go xs+        'C':'A':'N' : xs -> '\CAN' : go xs+        'E':'M' : xs -> '\EM' : go xs+        'S':'U':'B' : xs -> '\SUB' : go xs+        'E':'S':'C' : xs -> '\ESC' : go xs+        'F':'S' : xs -> '\FS' : go xs+        'G':'S' : xs -> '\GS' : go xs+        'R':'S' : xs -> '\RS' : go xs+        'U':'S' : xs -> '\US' : go xs+        'S':'P' : xs -> '\SP' : go xs+        'D':'E':'L' : xs -> '\DEL' : go xs+        '^':'@' : xs -> '\^@' : go xs+        '^':'A' : xs -> '\^A' : go xs+        '^':'B' : xs -> '\^B' : go xs+        '^':'C' : xs -> '\^C' : go xs+        '^':'D' : xs -> '\^D' : go xs+        '^':'E' : xs -> '\^E' : go xs+        '^':'F' : xs -> '\^F' : go xs+        '^':'G' : xs -> '\^G' : go xs+        '^':'H' : xs -> '\^H' : go xs+        '^':'I' : xs -> '\^I' : go xs+        '^':'J' : xs -> '\^J' : go xs+        '^':'K' : xs -> '\^K' : go xs+        '^':'L' : xs -> '\^L' : go xs+        '^':'M' : xs -> '\^M' : go xs+        '^':'N' : xs -> '\^N' : go xs+        '^':'O' : xs -> '\^O' : go xs+        '^':'P' : xs -> '\^P' : go xs+        '^':'Q' : xs -> '\^Q' : go xs+        '^':'R' : xs -> '\^R' : go xs+        '^':'S' : xs -> '\^S' : go xs+        '^':'T' : xs -> '\^T' : go xs+        '^':'U' : xs -> '\^U' : go xs+        '^':'V' : xs -> '\^V' : go xs+        '^':'W' : xs -> '\^W' : go xs+        '^':'X' : xs -> '\^X' : go xs+        '^':'Y' : xs -> '\^Y' : go xs+        '^':'Z' : xs -> '\^Z' : go xs+        '^':'[' : xs -> '\^[' : go xs+        '^':'\\' : xs -> '\^\' : go xs+        '^':']' : xs -> '\^]' : go xs+        '^':'^' : xs -> '\^^' : go xs+        '^':'_' : xs -> '\^_' : go xs+        xs -> go xs+      x:xs -> x : go xs++    readHex :: String -> Int+    readHex xs = case N.readHex xs of+      [(n, "")] -> n+      _ -> error $ (show 'unescape) <> " readHex: no parse"++    readOct :: String -> Int+    readOct xs = case N.readOct xs of+      [(n, "")] -> n+      _ -> error $ (show 'unescape) <> " readOct: no parse"
+ src/Clash/Util/Supply.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE MagicHash, UnboxedTuples, CPP, PatternSynonyms #-}+{-# LANGUAGE Trustworthy #-}+{-# OPTIONS_GHC -fno-full-laziness #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Clash.Util.Supply+-- Copyright   :  (C) 2011-2013 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- A fast unique identifier supply with local pooling and replay+-- support.+--+-- One often has a desire to generate a bunch of integer identifiers within+-- a single process that are unique within that process. You could use+-- UUIDs, but they can be expensive to generate; you don't want to have+-- your threads contending for a single external counter if the identifier+-- is not going to be used outside the process.+--+-- @concurrent-supply@ builds a tree-like structure which can be split; you+-- can make smaller unique supplies and then you allocate from your supplies+-- locally. Internally it pulls from a unique supply one block at a time as+-- you walk into parts of the tree that haven't been explored.+--+----------------------------------------------------------------------------+module Clash.Util.Supply+  ( Supply+  -- * Variables+  , newSupply+  , freshId+  , splitSupply+  -- * Unboxed API+  , freshId#+  , splitSupply#+  ) where++import Data.Hashable+import Data.IORef+import GHC.IO (unsafeDupablePerformIO, unsafePerformIO)++import Clash.Unique (Unique, Unique#, pattern Unique#)++infixr 5 :-+data Stream a = a :- Stream a++instance Functor Stream where+  fmap f (a :- as) = f a :- fmap f as++extract :: Stream a -> a+extract (a :- _) = a++units :: Stream ()+units = () :- units+{-# NOINLINE units #-}++data Block = Block Unique !(Stream Block)++instance Eq Block where+  Block a (Block b _ :- _) == Block c (Block d _ :- _) = a == c && b == d++instance Ord Block where+  Block a (Block b _ :- _) `compare` Block c (Block d _ :- _) = compare a c `mappend` compare b d++instance Show Block where+  showsPrec d (Block a (Block b _ :- _)) = showParen (d >= 10) $+    showString "Block " . showsPrec 10 a . showString " (Block " . showsPrec 10 b . showString " ... :- ...)"++instance Hashable Block where+  hashWithSalt s (Block a (Block b _ :- _)) = s `hashWithSalt` a `hashWithSalt` b++blockSize :: Unique+blockSize = 1024+{-# INLINE blockSize #-}++-- Minimum size to be worth splitting a supply rather than just CAS'ing twice to avoid multiple subsequent biased splits+minSplitSupplySize :: Unique+minSplitSupplySize = 32 -- based on sqrt blockSize+{-# INLINE minSplitSupplySize #-}++blockCounter :: IORef Unique+blockCounter = unsafePerformIO (newIORef 0)+{-# NOINLINE blockCounter #-}++modifyBlock :: a -> IO Unique+modifyBlock _ = atomicModifyIORef blockCounter $ \ i -> let i' = i + blockSize in i' `seq` (i', i)+{-# NOINLINE modifyBlock #-}++gen :: a -> Block+gen x = Block (unsafeDupablePerformIO (modifyBlock x)) (gen <$> units)+{-# NOINLINE gen #-}++newBlock :: IO Block+newBlock = return $! gen ()+{-# NOINLINE newBlock #-}++splitBlock# :: Block -> (# Block, Block #)+splitBlock# (Block i (x :- xs)) = (# x, Block i xs #)+{-# INLINE splitBlock# #-}++-- | A user managed globally unique variable supply.+data Supply = Supply {-# UNPACK #-} !Unique {-# UNPACK #-} !Unique Block+  deriving (Eq,Ord,Show)++instance Hashable Supply where+  hashWithSalt s (Supply i j b) = s `hashWithSalt` i `hashWithSalt` j `hashWithSalt` b++blockSupply :: Block -> Supply+blockSupply (Block i bs) = Supply i (i + blockSize - 1) (extract bs)+{-# INLINE blockSupply #-}++-- | Grab a new supply. Any two supplies obtained with newSupply are guaranteed to return+-- disjoint sets of identifiers. Replaying the same sequence of operations on the same+-- Supply will yield the same results.+newSupply :: IO Supply+newSupply = blockSupply <$> newBlock+{-# INLINE newSupply #-}++-- | Obtain a fresh Id from a Supply.+freshId :: Supply -> (Unique, Supply)+freshId s = case freshId# s of+  (# i, s' #) -> (Unique# i, s')+{-# INLINE freshId #-}++-- | Split a supply into two supplies that will return disjoint identifiers+splitSupply :: Supply -> (Supply, Supply)+splitSupply s = case splitSupply# s of+  (# l, r #) -> (l, r)+{-# INLINE splitSupply #-}++-- | An unboxed version of freshId+freshId# :: Supply -> (# Unique#, Supply #)+freshId# (Supply i@(Unique# i#) j b)+  | i /= j = (# i#, Supply (i + 1) j b #)+  | otherwise = (# i#, blockSupply b #)+{-# INLINE freshId# #-}++-- | An unboxed version of splitSupply+splitSupply# :: Supply -> (# Supply, Supply #)+splitSupply# (Supply i k b) = case splitBlock# b of+    (# bl, br #)+      | k - i >= minSplitSupplySize+      , j <- i + div (k - i) 2 ->+        (# Supply i j bl, Supply (j + 1) k br #)+      | Block x (l :- r :- _) <- bl+      , y <- x + div blockSize 2+      , z <- x + blockSize - 1 ->+        (# Supply x (y - 1) l, Supply y z r #)+{-# INLINE splitSupply# #-}
+ src/Clash/Verification/Pretty.hs view
@@ -0,0 +1,278 @@+{-|+Copyright  :  (C) 2019, Myrtle Software Ltd+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++Verification+-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Verification.Pretty+  ( pprPslProperty+  , pprSvaProperty+  , pprYosysSvaProperty++  -- * Debugging functions+  , pprProperty+  ) where++import           Clash.Annotations.Primitive      (HDL(..))+import           Clash.Signal.Internal            (ActiveEdge, ActiveEdge(..))+import           Clash.Verification.Internal      hiding (assertion)+import           Clash.Netlist.Types              (Declaration(..), Seq(..), Expr, CommentOrDirective(..))+import           Data.Maybe                       (fromMaybe)+import           Data.Text                        (Text)+import qualified Data.Text as Text                (pack)++data Symbol+  = TImpliesOverlapping+  | TImplies+  | Implies+  | BiImplies+  | Not+  | And+  | Or+  | To+  | Equals+  -- + [] ?+  | Assign+  | Is++------------------------------------------+--                 UTIL                 --+------------------------------------------+-- | Collapse constructs such as `next (next a)` down to `next[2] a`+squashBefore :: Assertion' a -> [Assertion' a]+squashBefore (CvBefore e1 e2) = e1s ++ e2s+ where+  e1s = case squashBefore e1 of {[] -> [e1]; es -> es}+  e2s = case squashBefore e2 of {[] -> [e2]; es -> es}+squashBefore _ = []++parensIf :: Bool -> Text -> Text+parensIf True s = "(" <> s <> ")"+parensIf False s = s++---------------------------------------+--                PSL                --+---------------------------------------+pslBinOp+  :: HDL+  -> Bool+  -> Symbol+  -> Assertion' Text+  -> Assertion' Text+  -> Text+pslBinOp hdl parens op e1 e2 =+  parensIf parens (e1' <> symbol hdl op <> e2')+ where+  e1' = pprPslAssertion hdl True e1+  e2' = pprPslAssertion hdl True e2++pslEdge :: HDL -> ActiveEdge -> Text -> Text+pslEdge SystemVerilog activeEdge clkId = pslEdge Verilog activeEdge clkId+pslEdge Verilog Rising clkId = "posedge " <> clkId+pslEdge Verilog Falling clkId = "negedge " <> clkId+pslEdge VHDL Rising clkId = "rising_edge(" <> clkId <> ")"+pslEdge VHDL Falling clkId = "falling_edge(" <> clkId <> ")"++-- | Taken from IEEE Std 1850-2010a, Annex B.1, p149+symbol :: HDL -> Symbol -> Text+symbol SystemVerilog = symbol Verilog+symbol Verilog = \case+  TImpliesOverlapping -> "|->"+  TImplies  -> "|=>"+  Implies   -> "->"+  BiImplies -> "<->"+  Not       -> "!"+  And       -> "&&"+  Or        -> "||"+  To        -> ":"+  Assign    -> "<="+  Is        -> "="+  Equals    -> "=="++symbol VHDL = \case+  TImpliesOverlapping -> "|->"+  TImplies  -> "|=>"+  Implies   -> " -> "+  BiImplies -> " <-> "+  Not       -> "not"+  And       -> " and "+  Or        -> " or "+  To        -> " to "+  Assign    -> "<="+  Is        -> "is"+  Equals    -> "="++-- | Pretty print Property. Doesn't print valid HDL, but can be used for+-- debugging purposes.+pprProperty :: Property dom -> Declaration+pprProperty (Property prop0) =+  let prop1 = fromMaybe "__autogen__" . fst <$> prop0 in+  pprPslProperty VHDL "prop" "clk" Rising prop1++pprPslProperty+  :: HDL+  -- ^ HDL to generate PSL expression for+  -> Text+  -- ^ Property name+  -> Text+  -- ^ Clock name+  -> ActiveEdge+  -- ^ Edge property should be sensitive to+  -> Property' Text+  -- ^ Assertion / Cover statement+  -> Declaration+pprPslProperty hdl propName clkId edge assertion = TickDecl . Comment $+  "psl property " <> propName <> " " <> symbol hdl Is <> "\n" <>+  "(" <> prop <> ") @(" <> pslEdge hdl edge clkId <> ")" <>+  ";\n" <> "psl " <> coverOrAssert <> " " <>+  propName <> ";"+ where+  (coverOrAssert, prop) =+    case assertion of+      CvCover e -> ("cover", pprPslAssertion hdl False e)+      CvAssert e -> ("assert", pprPslAssertion hdl False e)+      CvAssume e -> ("assume", pprPslAssertion hdl False e)++pprPslAssertion :: HDL -> Bool -> Assertion' Text -> Text+pprPslAssertion hdl parens e =+  case e of+    (CvPure p) -> p++    -- ModelSim/QuastaSim doesn't support booleans in PSL. Anytime we want to+    -- use a boolean literal we use (0 == 0) or (0 == 1) instead.+    (CvLit False) -> parensIf parens ("0" <> symbol hdl Equals <> "1")+    (CvLit True) -> parensIf parens ("0" <> symbol hdl Equals <> "0")++    (CvNot e1) ->+      parensIf parens (symbol hdl Not <> " " <> pprPslAssertion hdl True e1)+    (CvAnd e1 e2) -> pslBinOp1 And e1 e2+    (CvOr e1 e2) -> pslBinOp1 Or e1 e2+    (CvImplies e1 e2) -> pslBinOp1 Implies e1 e2++    (CvToTemporal e1) -> "{" <> pprPslAssertion hdl False e1 <> "}"++    (CvNext 0 e1) -> pprPslAssertion hdl parens e1+    (CvNext 1 e1) -> " ## " <> pprPslAssertion hdl True e1+    (CvNext n e1) -> " ##" <> Text.pack (show n) <> " " <> pprPslAssertion hdl False e1++    (CvBefore _ _) -> "{" <> afters1 <> "}"+     where+      afters0 = map (pprPslAssertion hdl False) (squashBefore e)+      afters1 = foldl1 (\e1 e2 -> e1 <> "; " <> e2) afters0++    (CvTemporalImplies 0 e1 e2) -> pslBinOp1 TImpliesOverlapping e1 e2+    (CvTemporalImplies 1 e1 e2) -> pslBinOp1 TImplies e1 e2+    (CvTemporalImplies n e1 e2) -> pslBinOp1 TImplies e1 (CvNext n e2)++    (CvAlways e1) -> "always " <> pprPslAssertion hdl True e1+    (CvNever e1) -> "never " <> pprPslAssertion hdl True e1+    (CvEventually e1) -> "eventually! " <> pprPslAssertion hdl True e1+ where+  pslBinOp1 = pslBinOp hdl True+++---------------------------------------+--                SVA                --+---------------------------------------+svaEdge :: ActiveEdge -> Text -> Text+svaEdge Rising clkId = "posedge " <> clkId+svaEdge Falling clkId = "negedge " <> clkId++svaBinOp+  :: Bool+  -> Symbol+  -> Assertion' Text+  -> Assertion' Text+  -> Text+svaBinOp parens op e1 e2 =+  parensIf parens (e1' <> symbol SystemVerilog op <> e2')+ where+  e1' = pprSvaAssertion True e1+  e2' = pprSvaAssertion True e2++pprSvaAssertion :: Bool -> Assertion' Text -> Text+pprSvaAssertion parens e =+  case e of+    (CvPure p) -> p+    (CvLit False) -> "false"+    (CvLit True) -> "true"++    (CvNot e1) ->+      parensIf parens (symbol' Not <> pprSvaAssertion True e1)+    (CvAnd e1 e2) -> svaBinOp1 And e1 e2+    (CvOr e1 e2) -> svaBinOp1 Or e1 e2+    (CvImplies e1 e2) -> svaBinOp1 Implies e1 e2++    (CvToTemporal e1) -> "{" <> pprSvaAssertion False e1 <> "}"++    (CvNext 0 e1) -> pprSvaAssertion parens e1+    (CvNext n e1) -> "nexttime[" <> Text.pack (show n) <> "] " <> pprSvaAssertion False e1++    (CvBefore _ _) -> "{" <> afters1 <> "}"+     where+      afters0 = map (pprSvaAssertion False) (squashBefore e)+      afters1 = foldl1 (\e1 e2 -> "(" <> e1 <> ") ##1 (" <> e2 <> ")") afters0++    (CvTemporalImplies 0 e1 e2) -> svaBinOp1 TImpliesOverlapping e1 e2+    (CvTemporalImplies 1 e1 e2) -> svaBinOp1 TImplies e1 e2+    (CvTemporalImplies n e1 e2) -> svaBinOp1 TImplies e1 (CvNext n e2)++    (CvAlways e1) -> "always (" <> pprSvaAssertion False e1 <> ")"+    (CvNever _e) -> error "'never' not supported in SVA"+    (CvEventually e1) -> "s_eventually (" <> pprSvaAssertion False e1 <> ")"+ where+  svaBinOp1 = svaBinOp parens+  symbol' = symbol SystemVerilog++pprSvaProperty+  :: Text+  -- ^ Property name+  -> Text+  -- ^ Clock name+  -> ActiveEdge+  -- ^ Edge property should be sensitive to+  -> Property' Text+  -- ^ Assertion / Cover statement+  -> Declaration+pprSvaProperty propName clkId edge assertion = TickDecl . Comment $+  propName <> ": " <> coverOrAssert <> " property (@(" <>+  svaEdge edge clkId <> ") " <> prop <> ");"+ where+  (coverOrAssert, prop) =+    case assertion of+      CvCover e -> ("cover", pprSvaAssertion False e)+      CvAssert e -> ("assert", pprSvaAssertion False e)+      CvAssume e -> ("assume", pprSvaAssertion False e)++---------------------------------------+--     Yosys Formal Extensions       --+---------------------------------------++-- | Generate something like:+-- @always @(posedge clk_i) isOn: cover (result);@+pprYosysSvaProperty+  :: Text+  -- ^ Property name+  -> Expr+  -- ^ Clock expression+  -> ActiveEdge+  -- ^ Edge property should be sensitive to+  -> Property' Text+  -- ^ Assertion / Cover statement+  -> Declaration+pprYosysSvaProperty propName clk edge assertion = ConditionalDecl+  "FORMAL"+  [Seq [AlwaysClocked edge clk [SeqDecl (TickDecl directive)]]]+ where+  directive = Directive+    (propName <> ": " <> coverOrAssert <> " property (" <> prop <> ")")++  (coverOrAssert, prop) = case assertion of+    CvCover  e -> ("cover", pprSvaAssertion False e)+    CvAssert e -> ("assert", pprSvaAssertion False e)+    CvAssume e -> ("assume", pprSvaAssertion False e)
+ src/ClashDebug.h view
@@ -0,0 +1,5 @@+#pragma once++#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else+#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else+#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $
src/Data/Aeson/Extra.hs view
@@ -1,24 +1,213 @@ {-|   Copyright   :  (C) 2015-2016, University of Twente+                     2024, QBayLogic B.V.   License     :  BSD2 (see the file LICENSE)   Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com> -} +{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_HADDOCK hide #-}+ module Data.Aeson.Extra where -import Data.Aeson           (FromJSON, Result (..), fromJSON, json)-import Data.Attoparsec.Lazy (Result (..), parse)-import Data.ByteString.Lazy (ByteString)-import CLaSH.Util           (traceIf)+import           Control.Exception    (throw)+import qualified Data.IntMap          as IntMap+import           Data.IntMap          (IntMap)+import qualified Data.Ix              as Ix+import qualified Data.Text            as T+import           Data.Text            (Text,pack,unpack)+import qualified Data.Text.Lazy       as LT+import qualified Data.Text.Lazy.Encoding as LT+import           Data.Text.Encoding.Error (UnicodeException(..))+import           Data.List            (intercalate)+import           Data.List.NonEmpty   (NonEmpty (..))+#if MIN_VERSION_base(4,20,0)+import qualified Data.List.NonEmpty   as NE hiding (unzip)+import qualified Data.Functor         as NE+#else+import qualified Data.List.NonEmpty   as NE+#endif+import           Data.Tuple.Extra     (second, first)+import           Data.Aeson           (FromJSON, Result (..), fromJSON)+import           Data.Aeson.Parser    (json)+import           Data.Attoparsec.Lazy (Result (..), parse)+import           Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BSChar+import qualified Data.Yaml            as Yaml+import           System.FilePath      () --- | Parse a ByteString according to the given JSON template. Prints failures--- on @stdout@, and returns 'Nothing' if parsing fails.-decodeAndReport :: (FromJSON a)-                => ByteString -- ^ Bytestring to parse-                -> Maybe a-decodeAndReport s =-  case parse json s of-    Done _ v -> case fromJSON v of-                    Success a -> Just a-                    Error msg -> traceIf True msg Nothing-    Fail _ _ msg -> traceIf True msg Nothing+import qualified Clash.Util.Interpolate as I+import           Clash.Util           (ClashException(..))+import           GHC.Types.SrcLoc     (mkGeneralSrcSpan)+import           GHC.Data.FastString  (mkFastString)+import           GHC.Stack            (HasCallStack)++-- | See 'toSpecNewlines'. A line map maps "virtual" lines to a range of+-- "real" lines. E.g., a map of {0: (0, 3), 1: (4, 5)} would mean that line+-- 0 in the virtual JSON (i.e., the one with newlines replaced) file map to+-- lines 0 up to and including 3 in the original user-supplied one.+type LineMap = IntMap (Int, Int)++-- | Aeson versions <1.5.0 accept unescaped newlines in JSON strings. This is in+-- violation of RFC 7159. Aeson 1.5.0 fixes this bug. Unfortunately, "Clash+-- JSON" files rely on the old behavior. This function replaces newlines (in+-- strings) with their escaped variants.+toSpecNewlines+  :: ByteString+  -> Either UnicodeException (LineMap, ByteString)+toSpecNewlines bs = do+ s0 <- LT.unpack <$> LT.decodeUtf8' bs+ Right ( toLineMap (go2 0 False s0)+       , LT.encodeUtf8 (LT.pack (go False s0)))+ where+  -- replace newlines with escaped ones+  go :: Bool -> String -> String+  go _ [] = []+  go True ('\n':rest) = '\\' : 'n' : go True rest+  go True ('\r':rest) = '\\' : 'r' : go True rest+  go True ('\t':rest) = '\\' : 't' : go True rest+  go inString ('\\':r:rest) = '\\' : r : go inString rest+  go inString ('"':rest) = '"' : go (not inString) rest+  go inString (r:rest) = r : go inString rest++  -- Calculate real:virtual mapping+  go2+    -- virtual line counter.+    :: Int+    -- Processing a JSON string?+    -> Bool+    -- String left to process+    -> String+    -- Virtual line numbers. [0, 1, 1, 2, 2, ..] would mean:+    --+    --  real | virtual+    --  --------------+    --     0 |       0+    --     1 |       1+    --     2 |       1+    --     3 |       2+    --     4 |       2+    --   ... |     ...+    --+    -> [Int]+  go2 n _        [] = [n]+  go2 n True     ('\n':rest) = n : go2 n True rest+  go2 n False    ('\n':rest) = n : go2 (succ n) False rest+  go2 n inString ('\\':_:rest) = go2 n inString rest+  go2 n inString ('"':rest) = go2 n (not inString) rest+  go2 n inString (_:rest) = go2 n inString rest++  toLineMap :: [Int] -> LineMap+  toLineMap [] = IntMap.empty+  toLineMap (v:virtuals) =+      IntMap.fromList+    $ map (second (\reals -> (minimum reals, maximum reals)))+    $ map (first NE.head . NE.unzip)+    $ NE.groupBy (\(a,_) (b,_) -> a == b)+    $ NE.zip (v :| virtuals) (NE.iterate (+1) (0 :: Int))++genLineErr' :: [Text] -> (Int, Int) -> [Int] -> Text+genLineErr' allLines range errorLines =+  T.unlines [ T.concat [ if elem i errorLines then pack ">> " else  pack "   "+            , pack $ show (i + 1)+            , pack ". "+            , allLines !! i+            ] | i <- Ix.range range]++-- | Pretty print part of json file related to error+genLineErr :: LineMap -> ByteString -> ByteString -> ByteString -> Text+genLineErr lineMap fullOrig full part =+    genLineErr' allLinesOrig interval [errorLineMin..errorLineMax]+  where+    -- Determine error line in "virtual" json file+    nLastLines = 1 + (length $ LT.lines $ LT.decodeUtf8 part)+    errorLineN = min (length allLines - 1) (length allLines - nLastLines + 1)+    allLines   = T.lines $ LT.toStrict $ LT.decodeUtf8 full++    -- Convert to error lines in actual json file, and calculate interval+    -- to display to user.+    allLinesOrig = T.lines $ LT.toStrict $ LT.decodeUtf8 fullOrig+    (errorLineMin, errorLineMax) = lineMap IntMap.! errorLineN+    interval = ( max 0 (errorLineMin - 5)+               , min (max 0 $ length allLinesOrig - 1) (errorLineMax + 5) )++-- | Parse a ByteString according to the given JSON template. Throws exception+-- if it fails.+decodeOrErrYaml+  :: (HasCallStack, FromJSON a)+  => FilePath+  -- ^ Path read from (for error message)+  -> ByteString+  -- ^ Bytestring to parse+  -> a+decodeOrErrYaml path contents =+  case Yaml.decodeEither' (BS.toStrict contents) of+    Left (Yaml.prettyPrintParseException -> err) -> clashError [I.i|+      Failed to decode YAML:++        #{path}++      Decoder reported:++        #{err}+    |]+    Right a -> a+ where+  clashError msg = throw (ClashException loc msg Nothing)+  loc = mkGeneralSrcSpan (mkFastString path)++-- | Parse a ByteString according to the given JSON template. Throws exception+-- if it fails.+decodeOrErrJson+  :: (HasCallStack, FromJSON a)+  => FilePath+  -- ^ Path read from (for error message)+  -> ByteString+  -- ^ Bytestring to parse+  -> a+decodeOrErrJson path contents0 =+  case toSpecNewlines contents0 of+    Left (DecodeError err _) -> clashError [I.i|+      Failed to decode JSON file as UTF8:++        #{path}++      Decoder reported:++        #{err}+    |]+    Left _ -> error "unreachable"+    Right (!lineMap, !contents1) ->+      case parse json contents1 of+        Done leftover v ->+          case fromJSON v of+            Success _ | BS.any notWhitespace leftover ->+              clashError ("After parsing " ++  show path+                     ++ ", found unparsed trailing garbage:\n"+                     ++ BSChar.unpack leftover)+            Success a ->+              a+            Error msg ->+              clashError+                ( "Could not deduce valid scheme for json in "+               ++ show path ++ ". Error was: \n\n" ++ msg )++        -- JSON parse error:+        Fail bytes cntxs msg ->+          clashError+            ( "Could not read or parse json in " ++ show path ++ ". "+           ++ (if null cntxs then "" else "Context was:\n  " ++ intercalate "\n  " cntxs)+           ++ "\n\nError reported by Attoparsec was:\n  "+           ++ msg+           ++ "\n\nApproximate location of error:\n\n"+           -- HACK: Replace with proper parser/fail logic in future. Or don't. It's not important.+           ++ (unpack $ genLineErr lineMap contents0 contents1 bytes) )+  where+    loc = mkGeneralSrcSpan $ mkFastString path+    clashError msg = throw $ ClashException loc msg Nothing+    notWhitespace c = BS.notElem c whitespace+      where whitespace = BSChar.pack " \t\n\r"
+ src/Data/List/Extra.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}++module Data.List.Extra+  ( partitionM+  , mapAccumLM+  , mapAccumRM+  , iterateNM+  , (<:>)+  , indexMaybe+  , splitAtList+  , equalLength+  , countEq+  , zipEqual+  , all2++  -- * From Control.Monad.Extra+  , anyM+  , allM+  , orM++  -- * From "extra"+  , module NeilsExtra+  ) where++import "extra" Data.List.Extra as NeilsExtra+import "extra" Control.Monad.Extra (anyM, allM, orM, partitionM)++#if defined(DEBUG)+import GHC.Stack (HasCallStack)+#endif++-- | Monadic version of 'Data.List.mapAccumL'+mapAccumLM+  :: (Monad m)+  => (acc -> x -> m (acc,y))+  -> acc+  -> [x]+  -> m (acc,[y])+mapAccumLM _ acc [] = return (acc,[])+mapAccumLM f acc (x:xs) = do+  (acc',y) <- f acc x+  (acc'',ys) <- mapAccumLM f acc' xs+  return (acc'',y:ys)++-- | Monadic version of 'Data.List.mapAccumR'+mapAccumRM+  :: Monad m+  => (acc -> x -> m (acc,y))+  -> acc+  -> [x]+  -> m (acc,[y])+mapAccumRM _ acc [] = return (acc,[])+mapAccumRM f acc (x:xs) = do+  (acc1,ys) <- mapAccumRM f acc xs+  (acc2,y) <- f acc1 x+  return (acc2,y:ys)++-- | Monadic version of 'iterate'. A carbon copy ('iterateM') would not+-- terminate, hence the first argument.+iterateNM+  :: Monad m+  => Word+  -- ^ Only iterate /n/ times. Note that /n/ is the length of the resulting+  -- list, _not_ the number of times the iteration function has been invoked+  -> (a -> m a)+  -- ^ Iteration function+  -> a+  -- ^ Start value+  -> m [a]+iterateNM 0 _f _a = pure []+iterateNM limit f a = fmap (a:) (go (limit - 1) a)+ where+  go 0 _a0 = pure []+  go n a0 = do+    a1 <- f a0+    fmap (a1:) (go (n - 1) a1)++infixr 5 <:>+-- | Applicative version of 'GHC.Types.(:)'+(<:>) :: Applicative f => f a -> f [a] -> f [a]+(<:>) = liftA2 (:)++-- | Safe indexing, returns a 'Nothing' if the index does not exist+indexMaybe :: [a] -> Int -> Maybe a+indexMaybe [] _     = Nothing+indexMaybe (x:_)  0 = Just x+indexMaybe (_:xs) n = indexMaybe xs (n-1)++splitAtList :: [b] -> [a] -> ([a], [a])+splitAtList [] xs         = ([], xs)+splitAtList _ xs@[]       = (xs, xs)+splitAtList (_:xs) (y:ys) = (y:ys', ys'')+    where+      (ys', ys'') = splitAtList xs ys++equalLength :: [a] -> [b] -> Bool+equalLength [] [] = True+equalLength (_:as) (_:bs) = equalLength as bs+equalLength _ _ = False++-- | Like 'all', but the predicate operates over two lists. Asserts to 'False'+-- when the lists are of unequal length+all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool+all2 _ [] [] = True+all2 p (a:as) (b:bs) = p a b && all2 p as bs+all2 _ _ _ = False++-- | Return number of occurrences of an item in a list+countEq+  :: Eq a+  => a+  --  ^ Needle+  -> [a]+  -- ^ Haystack+  -> Int+  -- ^ Times needle was found in haystack+countEq a as = length (filter (== a) as)++-- | Zip two lists of equal length+--+-- NB Errors out for a DEBUG compiler when the two lists are not of equal length+#if !defined(DEBUG)+zipEqual+  :: [a] -> [b] -> [(a,b)]+zipEqual = zip+{-# INLINE zipEqual #-}+#else+zipEqual ::+  HasCallStack =>+  [a] -> [b] -> [(a,b)]+zipEqual = go+  where+    go [] [] = []+    go (a:as) (b:bs) = (a,b) : go as bs+    go (_:_) [] = error "zipEqual: left list is longer"+    go [] (_:_) = error "zipEqual: right list is longer"+#endif
+ src/Data/Map/Ordered/Extra.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Data.Map.Ordered.Extra where++import Control.DeepSeq (NFData(rnf))+import Data.Map.Ordered (OMap)+import qualified Data.Map.Ordered as OMap++instance (NFData k, NFData v) => NFData (OMap k v) where+  rnf = rnf . OMap.assocs
+ src/Data/Monoid/Extra.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Data.Monoid.Extra where++import Control.Monad.State (MonadState(..))+import Data.Monoid (Ap(Ap))++instance (MonadState s m) => MonadState s (Ap m) where+  get = Ap get+  put = Ap . put+  state = Ap . state+
+ src/Data/Primitive/ByteArray/Extra.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Data.Primitive.ByteArray.Extra where++import Data.Binary (Binary(..))+import Data.Primitive.ByteArray (ByteArray)+import GHC.Exts (IsList(..))++#if !MIN_VERSION_primitive(0,7,1)+import Control.DeepSeq (NFData(..))+#endif++-- hashable 1.4.2 defines Hashable for Data.Array.Byte.ByteArray, either from+-- base or from the data-array-byte compat package for GHC < 9.4.+-- primitive 0.8.0.0 re-exports this ByteArray.+#if !MIN_VERSION_primitive(0,8,0)+-- In primitive < 0.8.0.0, its ByteArray is a distinct type from+-- Data.Array.Byte.ByteArray (insofar as the latter even exists).+#define DEFINE_HASHABLE_BYTEARRAY+#endif++#ifdef DEFINE_HASHABLE_BYTEARRAY+import Data.Hashable (Hashable(..))+#endif++#if !MIN_VERSION_primitive(0,7,1)+instance NFData ByteArray where+  rnf x = x `seq` ()+#endif++instance Binary ByteArray where+  get = fmap fromList get+  put = put . toList++#ifdef DEFINE_HASHABLE_BYTEARRAY+instance Hashable ByteArray where+  hashWithSalt salt = hashWithSalt salt . toList+#endif
+ src/Data/Set/Ordered/Extra.hs view
@@ -0,0 +1,22 @@+{-|+  Copyright   :  (C) 2019,2021, QBayLogic B.V+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V <devops@qbaylogic.com>++  Convenience functions for "Data.Set.Ordered" from the package+  "ordered-containers".+-}++module Data.Set.Ordered.Extra+  ( OLSet+  , toListL+  ) where++import           Data.Coerce                 (coerce)+import           Data.Foldable               (toList)+import qualified Data.Set.Ordered as OSet++type OLSet a = OSet.Bias OSet.L (OSet.OSet a)++toListL :: forall a. OLSet a -> [a]+toListL = toList . coerce @(OLSet a) @(OSet.OSet a)
+ src/Data/Text/Extra.hs view
@@ -0,0 +1,13 @@+module Data.Text.Extra+  ( showt+  , showtl+  ) where++import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL++showt :: (Show a) => a -> TS.Text+showt = TS.pack . show++showtl :: (Show a) => a -> TL.Text+showtl = TL.pack . show
+ src/Data/Text/Prettyprint/Doc/Extra.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Data.Text.Prettyprint.Doc.Extra+  ( module Data.Text.Prettyprint.Doc.Extra+  , LayoutOptions (..)+  , PageWidth (..)+  , layoutCompact+  , layoutPretty+  , renderLazy+  )+where++import           Control.Applicative+import           Data.String                           (IsString (..))+import qualified Data.Text                             as T+import qualified Data.Text.Lazy                        as LT++#if MIN_VERSION_prettyprinter(1,7,0)+import qualified Prettyprinter                         as PP+import           Prettyprinter.Internal                hiding (Doc)+import           Prettyprinter.Render.Text+#else+import qualified Data.Text.Prettyprint.Doc             as PP+import           Data.Text.Prettyprint.Doc.Internal    hiding (Doc)+import           Data.Text.Prettyprint.Doc.Render.Text+#endif++type Doc = PP.Doc ()++layoutOneLine+  :: PP.Doc ann+  -> SimpleDocStream ann+layoutOneLine doc = scan 0 [doc]+  where+    scan _ [] = SEmpty+    scan !col (d:ds) = case d of+        Fail            -> SFail+        Empty           -> scan col ds+        Char c          -> SChar c (scan (col+1) ds)+        Text l t        -> let !col' = col+l in SText l t (scan col' ds)+        FlatAlt x _     -> scan col (x:ds)+        Line            -> scan col ds+        Cat x y         -> scan col (x:y:ds)+        Nest _ x        -> scan col (x:ds)+        Union _ y       -> scan col (y:ds)+        Column f        -> scan col (f col:ds)+        WithPageWidth f -> scan col (f Unbounded : ds)+        Nesting f       -> scan col (f 0 : ds)+        Annotated _ x   -> scan col (x:ds)++renderOneLine+  :: PP.Doc ann+  -> LT.Text+renderOneLine = renderLazy . layoutPretty defaultLayoutOptions++int :: Applicative f => Int -> f Doc+int = pure . PP.pretty++integer :: Applicative f => Integer -> f Doc+integer = pure . PP.pretty++char :: Applicative f => Char -> f Doc+char = pure . PP.pretty++lbrace :: Applicative f => f Doc+lbrace = pure PP.lbrace++rbrace :: Applicative f => f Doc+rbrace = pure PP.rbrace++colon :: Applicative f => f Doc+colon = pure PP.colon++semi :: Applicative f => f Doc+semi = pure PP.semi++equals :: Applicative f => f Doc+equals = pure PP.equals++comma :: Applicative f => f Doc+comma = pure PP.comma++dot :: Applicative f => f Doc+dot = pure PP.dot++lparen :: Applicative f => f Doc+lparen = pure PP.lparen++rparen :: Applicative f => f Doc+rparen = pure PP.rparen++space :: Applicative f => f Doc+space = pure PP.space++brackets :: Functor f => f Doc -> f Doc+brackets = fmap PP.brackets++braces :: Functor f => f Doc -> f Doc+braces = fmap PP.braces++tupled :: Functor f => f [Doc] -> f Doc+tupled = fmap PP.tupled++(<+>) :: Applicative f => f Doc -> f Doc -> f Doc+(<+>) = liftA2 (PP.<+>)+infixr 6 <+>++vcat :: Functor f => f [Doc] -> f Doc+vcat = fmap PP.vcat++hcat :: Functor f => f [Doc] -> f Doc+hcat = fmap PP.hcat++nest :: Functor f => Int -> f Doc -> f Doc+nest i = fmap (PP.nest i)++indent :: Functor f => Int -> f Doc -> f Doc+indent i = fmap (PP.indent i)++parens :: Functor f => f Doc -> f Doc+parens = fmap PP.parens++emptyDoc :: Applicative f => f Doc+emptyDoc = pure PP.emptyDoc++punctuate :: Applicative f => f Doc -> f [Doc] -> f [Doc]+punctuate = liftA2 PP.punctuate++encloseSep :: Applicative f => f Doc -> f Doc -> f Doc -> f [Doc] -> f Doc+encloseSep l r s is = PP.encloseSep <$> l <*> r <*> s <*> is++enclose :: Applicative f => f Doc -> f Doc -> f Doc -> f Doc+enclose = liftA3 PP.enclose++line :: Applicative f => f Doc+line = pure PP.line++line' :: Applicative f => f Doc+line' = pure PP.line'++softline :: Applicative f => f Doc+softline = pure PP.softline++softline' :: Applicative f => f Doc+softline' = pure PP.softline'++pretty :: (Applicative f, Pretty a) => a -> f Doc+pretty = pure . PP.pretty++stringS :: Applicative f => T.Text -> f Doc+stringS = pure . PP.pretty++string :: Applicative f => LT.Text -> f Doc+string = pure . PP.pretty++squotes :: Applicative f => f Doc -> f Doc+squotes = fmap PP.squotes++dquotes :: Functor f => f Doc -> f Doc+dquotes = fmap PP.dquotes++align :: Functor f => f Doc -> f Doc+align = fmap PP.align++hsep :: Functor f => f [Doc] -> f Doc+hsep = fmap PP.hsep++vsep :: Functor f => f [Doc] -> f Doc+vsep = fmap PP.vsep++isEmpty :: Doc -> Bool+isEmpty Empty = True+isEmpty _     = False++fill :: Applicative f => Int -> f Doc -> f Doc+fill = fmap . PP.fill++column :: Functor f => f (Int -> Doc) -> f Doc+column = fmap PP.column++nesting :: Functor f => f (Int -> Doc) -> f Doc+nesting = fmap PP.nesting++flatAlt :: Applicative f => f Doc -> f Doc -> f Doc+flatAlt = liftA2 PP.flatAlt++instance Applicative f => IsString (f Doc) where+  fromString = string . fromString++comment :: Applicative f => T.Text -> T.Text -> f Doc+comment prefix comm =+  let go s = PP.pretty prefix PP.<+> PP.pretty s in+  pure (PP.vsep (Prelude.map go (T.lines comm)))++squote :: Applicative f => f Doc+squote = string (LT.pack "'")
+ src/GHC/BasicTypes/Extra.hs view
@@ -0,0 +1,55 @@+{-|+  Copyright   :  (C) 2017, Google Inc.+                     2023, QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.BasicTypes.Extra where++import GHC.Types.Basic+import Control.DeepSeq+import Data.Binary+import GHC.Generics++import GHC.Types.SourceText++#if MIN_VERSION_ghc(9,8,0)+import Data.ByteString+import GHC.Data.FastString+import Unsafe.Coerce+#endif++deriving instance Generic InlineSpec+instance NFData InlineSpec+instance Binary InlineSpec++#if MIN_VERSION_ghc(9,8,0)+deriving instance Generic FastString+instance Binary FastString+instance Binary FastZString where+  put = put . fastZStringToByteString+  get = unsafeCoerce (get :: Get ByteString)+#endif++deriving instance Generic SourceText+#if !MIN_VERSION_ghc(9,8,0)+instance NFData SourceText+#endif+instance Binary SourceText++-- | Determine whether given 'InlineSpec' is NOINLINE or more strict (OPAQUE)+isNoInline :: InlineSpec -> Bool+isNoInline NoInline{} = True+isNoInline Opaque{} = True+isNoInline _ = False++-- | Determine whether given 'InlineSpec' is OPAQUE. If this function is used on+-- a GHC that does not support OPAQUE yet (<9.4), it will return 'True' if given+-- 'InlineSpec' is NOINLINE instead.+isOpaque :: InlineSpec -> Bool+isOpaque Opaque{} = True+isOpaque _ = False
− src/GHC/Extra.hs 
@@ -1,18 +0,0 @@-{-|-  Copyright   :  (C) 2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module GHC.Extra where--#if !(MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117))-import Control.DeepSeq-import SrcLoc (SrcSpan)--instance NFData SrcSpan where-  rnf x = x `seq` ()-#endif
+ src/GHC/SrcLoc/Extra.hs view
@@ -0,0 +1,63 @@+{-|+  Copyright   :  (C) 2017, Google Inc.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+-}++{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.SrcLoc.Extra where++import Data.Binary+import Data.Hashable                        (Hashable (..))+import GHC.Generics+import GHC.Types.SrcLoc+  (SrcSpan (..), RealSrcLoc, RealSrcSpan, BufSpan (..), BufPos (..), UnhelpfulSpanReason (..),+   mkRealSrcLoc, mkRealSrcSpan,+   realSrcSpanStart, realSrcSpanEnd,+   srcLocFile, srcLocLine, srcLocCol,+   srcSpanFile, srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol)+import GHC.Data.FastString (FastString (..), bytesFS, mkFastStringByteList)+import qualified GHC.Data.Strict++deriving instance Generic (GHC.Data.Strict.Maybe a)+instance Hashable a => Hashable (GHC.Data.Strict.Maybe a)+instance Binary a => Binary (GHC.Data.Strict.Maybe a)++deriving instance Generic SrcSpan+instance Hashable SrcSpan++instance Hashable RealSrcSpan where+  hashWithSalt salt rss =+    hashWithSalt salt (srcSpanFile rss,srcSpanStartLine rss, srcSpanEndLine rss+                      ,srcSpanStartCol rss, srcSpanEndCol rss)++instance Hashable FastString where+  hashWithSalt salt fs = hashWithSalt salt (uniq fs)++instance Binary SrcSpan+instance Binary RealSrcSpan where+  put r = put (realSrcSpanStart r, realSrcSpanEnd r)+  get = uncurry mkRealSrcSpan <$> get++instance Binary RealSrcLoc where+  put r = put (srcLocFile r, srcLocLine r, srcLocCol r)+  get = (\(file,line,col) -> mkRealSrcLoc file line col) <$> get++instance Binary FastString where+  put str = put $ bytesFS str+  get = mkFastStringByteList <$> get++deriving instance Generic BufPos+instance Binary BufPos+instance Hashable BufPos++deriving instance Generic UnhelpfulSpanReason+instance Binary UnhelpfulSpanReason+instance Hashable UnhelpfulSpanReason++deriving instance Generic BufSpan+instance Binary BufSpan+instance Hashable BufSpan
− src/Unbound/Generics/LocallyNameless/Extra.hs 
@@ -1,89 +0,0 @@-{-|-  Copyright   :  (C) 2015-2016, University of Twente-  License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE CPP                   #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Unbound.Generics.LocallyNameless.Extra where--#ifndef MIN_VERSION_unbound_generics-#error MIN_VERSION_unbound_generics undefined-#endif--#if !MIN_VERSION_unbound_generics(0,2,0)-import Control.DeepSeq-#endif-import Data.Hashable                           (Hashable(..),hash)-#if MIN_VERSION_unbound_generics(0,3,0)-import Data.Monoid-#endif-import Data.Text                               (Text)-import GHC.Real                                (Ratio)-#if MIN_VERSION_unbound_generics(0,3,0)-import Unbound.Generics.LocallyNameless.Alpha  (Alpha (..), NamePatFind (..),-                                                NthPatFind (..))-#else-import Unbound.Generics.LocallyNameless.Alpha  (Alpha (..))-#endif-#if !MIN_VERSION_unbound_generics(0,2,0)-import Unbound.Generics.LocallyNameless.Bind   (Bind (..))-import Unbound.Generics.LocallyNameless.Embed  (Embed (..))-#endif-import Unbound.Generics.LocallyNameless.Name   (Name (..))-#if !MIN_VERSION_unbound_generics(0,2,0)-import Unbound.Generics.LocallyNameless.Rebind (Rebind (..))-import Unbound.Generics.LocallyNameless.Rec    (Rec,unrec)-#endif-import Unbound.Generics.LocallyNameless.Subst  (Subst (..))--#if !MIN_VERSION_unbound_generics(0,2,0)-instance (NFData a, NFData b) => NFData (Bind a b)-instance NFData a => NFData (Embed a)-instance NFData (Name a)-instance (NFData a, NFData b) => NFData (Rebind a b)-instance (Alpha a, NFData a) => NFData (Rec a) where-  rnf r = seq (rnf (unrec r)) ()-#endif--instance Subst b (Ratio a) where-  subst  _ _ = id-  substs _   = id--instance Hashable (Name a) where-  hashWithSalt salt (Fn str int) = hashWithSalt salt (hashWithSalt (hash int) str)-  hashWithSalt salt (Bn i0  i1)  = hashWithSalt salt (hash i0 `hashWithSalt` i1)--#if !MIN_VERSION_unbound_generics(0,2,0)-instance (Ord a) => Ord (Embed a) where-  compare (Embed a) (Embed b) = compare a b-#endif--instance Alpha Text where-  aeq' _ctx             = (==)-  fvAny' _ctx _nfn i    = pure i-  close _ctx _b         = id-  open _ctx _b          = id-  isPat _               = mempty-#if MIN_VERSION_unbound_generics(0,3,0)-  isTerm _              = All True-  nthPatFind _          = NthPatFind Left-  namePatFind _         = NamePatFind (const (Left 0))-#else-  isTerm _              = True-  nthPatFind _          = Left-  namePatFind _ _       = Left 0-#endif-  swaps' _ctx _p        = id-  freshen' _ctx i       = return (i, mempty)-  lfreshen' _ctx i cont = cont i mempty-  acompare' _ctx        = compare--instance Subst b Text where-  subst  _ _ = id-  substs _   = id
+ tests/Clash/Tests/Core/FreeVars.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Tests.Core.FreeVars (tests) where++import           GHC.Types.SrcLoc        (noSrcSpan)+import qualified Control.Lens            as Lens++import           Test.Tasty+import           Test.Tasty.HUnit++import           Clash.Core.FreeVars     (globalIds)+import           Clash.Core.Name         (Name(..), NameSort(..))+import           Clash.Core.Term         (Term(Var, App, Lam))+import           Clash.Core.Type         (ConstTy(..), Type(ConstTy))+import           Clash.Core.Var          (IdScope(..), Var(..))++-- TODO: We need tooling to create these mock constructs+fakeName :: Name a+fakeName =+  Name+    { nameSort=User+    , nameOcc="fake"+    , nameUniq=0+    , nameLoc=noSrcSpan+    }++f :: IdScope -> Var Term+f scope =+  let unique = 20 in+  Id { varName = Name { nameSort=User+                      , nameOcc="f"+                      , nameUniq=unique+                      , nameLoc=noSrcSpan }+     , varUniq = unique+     , varType = ConstTy (TyCon fakeName)+     , idScope = scope }++fLocalId, fGlobalId :: Var Term+fLocalId = f LocalId+fGlobalId = f GlobalId++-- 'term1' is a simple lambda function:+--+--   \f -> g f+--+-- where f and g have the same unique, but f has been marked as _local_ while+-- g is _global_. In other words:+--+--   \f[l] -> f[g] f[l]+--+-- This term is tested against to check whether various functions account for+-- the distinction between local/global variables correctly.+term1 :: Term+term1 =+  Lam fLocalId (Var fGlobalId `App` Var fLocalId)++tests :: TestTree+tests =+  let globs1 = Lens.toListOf globalIds term1 in+  testGroup+    "Clash.Tests.Core.FreeVars"+    [ testCase "globalIds1" $ globs1 @=? [fGlobalId]+    , testCase "globalIds2" $+        assertBool+          "Global and local id can't BOTH be in globs1"+          (fLocalId `notElem` globs1)+    ]
+ tests/Clash/Tests/Core/Subst.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Clash.Tests.Core.Subst (tests) where++#if MIN_VERSION_ghc(9,0,0)+import           GHC.Types.SrcLoc        (noSrcSpan)+#else+import           SrcLoc                  (noSrcSpan)+#endif++import           Test.Tasty+import           Test.Tasty.HUnit++import           Clash.Core.Name         (Name(..), NameSort(..))+import           Clash.Core.Term         (Term(Var))+import           Clash.Core.Type         (ConstTy(..), Type(ConstTy))+import           Clash.Core.Subst+import           Clash.Core.VarEnv+import           Clash.Core.Var          (IdScope(..), Var(..))+import           Clash.Unique            (Unique)++fakeName :: Name a+fakeName =+  Name+    { nameSort=User+    , nameOcc="fake"+    , nameUniq=0+    , nameLoc=noSrcSpan+    }++unique :: Unique+unique = 20++termVar :: Var Term+termVar = Id {+    varName = fakeName {nameUniq=unique, nameOcc="term"}+  , varUniq = unique+  , varType = ConstTy (TyCon fakeName)+  , idScope = LocalId+  }++term1 :: Term+term1 = Var termVar++tests :: TestTree+tests =+  testGroup+    "Clash.Tests.Core.Subst"+    [ testCase "deShadow type/term" $+        term1 @=? deShadowTerm (extendInScopeSet emptyInScopeSet termVar) term1+    ]
+ tests/Clash/Tests/Core/TermLiteral.hs view
@@ -0,0 +1,67 @@+{-|+Copyright   :  (C) 2022, Google Inc.+License     :  BSD2 (see the file LICENSE)+Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++Tests for 'Clash.Core.TermLiteral'.+-}+{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Clash.Tests.Core.TermLiteral where++import Data.Proxy+import Data.Typeable+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.TH++import Clash.Core.TermLiteral+import Clash.Promoted.Nat++import Clash.Tests.Core.TermLiteral.Types++showTypeable :: Typeable a => Proxy a -> String+showTypeable proxy = showsPrec 0 (typeRep proxy) ""++eqTest :: (TermLiteral a, Typeable a) => Proxy a -> Assertion+eqTest proxy = showType proxy @=? showTypeable proxy++case_int :: Assertion+case_int = eqTest (Proxy @Int)++case_maybe_int :: Assertion+case_maybe_int = eqTest (Proxy @(Maybe Int))++case_maybe_maybe_int :: Assertion+case_maybe_maybe_int = eqTest (Proxy @(Maybe (Maybe Int)))++case_either_int_int :: Assertion+case_either_int_int = eqTest (Proxy @(Either Int Int))++case_either_int_maybe_int :: Assertion+case_either_int_maybe_int = eqTest (Proxy @(Either Int (Maybe Int)))++case_int_int :: Assertion+case_int_int = eqTest (Proxy @(Int, Int))++case_maybe_int_maybe_int :: Assertion+case_maybe_int_maybe_int = eqTest (Proxy @(Maybe Int, Maybe Int))++case_maybe_int_int :: Assertion+case_maybe_int_int = eqTest (Proxy @(Maybe (Int, Int)))++case_snat :: Assertion+case_snat = "SNat _" @=? showType (Proxy @(SNat 5))++case_maybe_snat :: Assertion+case_maybe_snat = "Maybe (SNat _)" @=? showType (Proxy @(Maybe (SNat 5)))++deriveTermLiteral ''NatTypeArg++case_natTypeArg :: Assertion+case_natTypeArg = "NatTypeArg _" @=? showType (Proxy @(NatTypeArg 10))++tests :: TestTree+tests = testGroup "Clash.Tests.Core.TermLiteral" [$(testGroupGenerator)]
+ tests/Clash/Tests/Core/TermLiteral/Types.hs view
@@ -0,0 +1,5 @@+module Clash.Tests.Core.TermLiteral.Types where++import Clash.Promoted.Nat++data NatTypeArg n = NatTypeArg (SNat n)
+ tests/Clash/Tests/Driver/Manifest.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE NamedFieldPuns  #-}++module Clash.Tests.Driver.Manifest where++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encode.Pretty as Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base16 as Base16+import Data.Coerce (coerce)+import Data.Either (fromRight)+import Data.Text (Text)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++import Test.Tasty++import qualified Test.Tasty.QuickCheck as Q+import qualified Test.QuickCheck.Utf8 as Q++import Clash.Driver.Manifest+import Clash.Explicit.Signal++newtype ArbitraryText = ArbitraryText Text deriving (Show)++instance Q.Arbitrary ArbitraryText where+  arbitrary = coerce Q.genValidUtf8+  shrink = coerce Q.shrinkValidUtf8++newtype ArbitraryPortDirection = ArbitraryPortDirection PortDirection deriving (Show)++instance Q.Arbitrary ArbitraryPortDirection where+  arbitrary = ArbitraryPortDirection <$> Q.elements [In, Out, InOut]++genDigest :: Q.Gen ByteString+genDigest = Base16.encode . Text.encodeUtf8 . coerce @ArbitraryText <$> Q.arbitrary++genString :: Q.Gen FilePath+genString = Text.unpack . coerce @ArbitraryText <$> Q.arbitrary++genDomain :: Q.Gen (Text, VDomainConfiguration)+genDomain = do+  nm <- coerce @(Q.Gen ArbitraryText) Q.arbitrary+  dom <-+    VDomainConfiguration+      <$> pure (Text.unpack nm)+      <*> (fromIntegral @Int . abs <$> Q.arbitraryBoundedIntegral)+      <*> Q.elements [Rising, Falling]+      <*> Q.elements [Synchronous, Asynchronous]+      <*> Q.elements [Defined, Unknown]+      <*> Q.elements [ActiveHigh, ActiveLow]++  pure (nm, dom)++genPort :: Q.Gen ManifestPort+genPort =+  ManifestPort+    <$> coerce @(Q.Gen ArbitraryText) Q.arbitrary+    <*> coerce @(Q.Gen ArbitraryText) Q.arbitrary+    <*> coerce @(Q.Gen ArbitraryPortDirection) Q.arbitrary+    <*> (fromIntegral @Int . abs <$> Q.arbitraryBoundedIntegral)+    <*> Q.elements [False, True]+    <*> coerce @(Q.Gen (Maybe ArbitraryText)) Q.arbitrary++genManifest :: Q.Gen Manifest+genManifest =+  Manifest+    <$> genDigest -- hash+    <*> Q.arbitrary -- flags+    <*> Q.listOf genPort -- ports+    <*> coerce @(Q.Gen [ArbitraryText]) @(Q.Gen [Text]) Q.arbitrary -- comp names+    <*> coerce @(Q.Gen ArbitraryText)   @(Q.Gen Text)   Q.arbitrary -- top name+    <*> Q.listOf ((,) <$> genString <*> genDigest) -- files+    <*> (HashMap.fromList <$> Q.listOf genDomain) -- domains+    <*> coerce @(Q.Gen [ArbitraryText]) @(Q.Gen [Text]) Q.arbitrary -- dependencies++tests :: TestTree+tests =+  adjustOption (\_ -> Q.QuickCheckTests 100) $+  testGroup+    "Clash.Tests.Driver.Manifest"+    [ Q.testProperty "decode . encode ~ id" $ do+        manifest <- genManifest+        let+          encoded = Aeson.encodePretty manifest+          decoded = Aeson.eitherDecode encoded++        pure (decoded Q.=== Right manifest)+    , Q.testProperty "FilesManifest can decode encoded Manifest" $ do+        manifest@Manifest{fileNames} <- genManifest+        let+          encoded = Aeson.encodePretty manifest+          FilesManifest fileNamesDecoded =+            fromRight (error "Failed to decode manifest") (Aeson.eitherDecode encoded)++        pure (fileNamesDecoded Q.=== fileNames)+    ]
+ tests/Clash/Tests/Netlist/Id.hs view
@@ -0,0 +1,221 @@+{-|+Copyright  :  (C) 2019, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MagicHash #-}++module Clash.Tests.Netlist.Id (+    module Clash.Tests.Netlist.Id+  ) where++import qualified Clash.Netlist.Types as Id+import qualified Clash.Netlist.Id as Id++import Clash.Annotations.Primitive+import Control.Monad.Trans.State.Lazy+import qualified Data.ByteString as BS+import Data.Coerce+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import qualified Data.Text as Text+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import Test.QuickCheck.Utf8++newtype NonEmptyText = NonEmptyText Text deriving (Show)+newtype ArbitraryText = ArbitraryText Text deriving (Show)+newtype ArbitraryAsciiText = ArbitraryAsciiText Text deriving (Show)++instance Arbitrary ArbitraryAsciiText where+  arbitrary = coerce (decodeUtf8 . BS.concat <$> listOf oneByte)+  shrink = coerce shrinkValidUtf8++instance Arbitrary ArbitraryText where+  arbitrary = coerce genValidUtf8+  shrink = coerce shrinkValidUtf8++instance Arbitrary NonEmptyText where+  arbitrary = coerce genValidUtf81+  shrink = coerce shrinkValidUtf81++eval :: Bool -> HDL -> State Id.IdentifierSet a -> a+eval esc hdl a = evalState a (Id.emptyIdentifierSet esc Id.PreserveCase hdl)++eval' :: State Id.IdentifierSet a -> a+eval' = eval True VHDL++roundTrip :: Bool -> HDL -> Text -> Text+roundTrip esc hdl = Id.toText . eval esc hdl . Id.make++roundTrip' :: Text -> Text+roundTrip' = roundTrip True VHDL++roundTripTest :: Text -> TestTree+roundTripTest t =+  testCase (Text.unpack ("roundTrip: " <> t)) (t @=? roundTrip' t)++-- | Raw identifiers should always come up the same after 'Id.toText'+rawToIdProperty :: NonEmptyText -> Property+rawToIdProperty t = coerce t === Id.toText (eval' (Id.addRaw (coerce t)))++xor :: Bool -> Bool -> Bool+xor True True = False+xor True False = True+xor False True = True+xor False False = False++tests :: TestTree+tests =+  testGroup+    "Clash.Tests.Netlist.Id"+    [ testCase "roundTrip: empty id" ("clash_internal" @=? roundTrip' "")++    -- Round trip tests tess whether a "make -> to text" roundtrip ~ id+    , roundTripTest "foo_bar"+    , roundTripTest "foo_1"+    , roundTripTest "foo_1_2"+    , roundTripTest "foo_1_2_ab"+    , roundTripTest "foo_1_ab_2"++    , testGroup "no collisions (one id)" $ flip map [minBound..maxBound] $ \hdl ->+        testProperty (show hdl) $ \id0 -> eval True hdl $ do+          id0t <- Id.toText <$> Id.make (coerce @ArbitraryAsciiText id0)+          id1t <- Id.toText <$> Id.make (coerce @ArbitraryAsciiText id0)+          pure (id0t /= id1t)++    , testGroup "no collisions (two ids)" $ flip map [minBound..maxBound] $ \hdl ->+        testProperty (show hdl) $ \id0 id1 -> eval True hdl $ do+          id0t <- Id.toText <$> Id.make (coerce @ArbitraryAsciiText id0)+          id1t <- Id.toText <$> Id.make (coerce @ArbitraryAsciiText id1)+          pure (id0t /= id1t)++    , testGroup "make0" $ eval' $ do+        id0 <- Id.toText <$> Id.make "foo"+        id1 <- Id.toText <$> Id.make "foo"+        id2 <- Id.toText <$> Id.make "foo_0"+        id3 <- Id.toText <$> Id.make "foo"+        id4 <- Id.toText <$> Id.make "foo_0"+        pure [ testCase "id0 == foo"     $ id0 @?= "foo"+             , testCase "id1 == foo_0"   $ id1 @?= "foo_0"+             , testCase "id2 == foo_0_0" $ id2 @?= "foo_0_0"+             , testCase "id3 == foo_0_1" $ id3 @?= "foo_1"+             , testCase "id4 == foo_0_0" $ id4 @?= "foo_0_1"+             ]++    , testGroup "make1" $ eval' $ do+        id0 <- Id.toText <$> Id.make "foo"+        id1 <- Id.toText <$> Id.make "foo_37"+        id2 <- Id.toText <$> Id.make "foo"+        id3 <- Id.toText <$> Id.make "foo_3"+        pure [ testCase "id0 == foo"    $ id0 @?= "foo"+             , testCase "id1 == foo_37" $ id1 @?= "foo_37"+             , testCase "id2 == foo_38" $ id2 @?= "foo_38"+             , testCase "id3 == foo_3"  $ id3 @?= "foo_3"+             ]++    , testGroup "Id.add" $ eval' $ do+        old <- get+        id0 <- Id.addRaw "LED"+        put old+        Id.add id0+        id1 <- Id.toText <$> Id.make "led"+        pure [ testCase "id1 == led_0" $ id1 @?= "led_0" ]++    -- Some tools/hdls are case insensitive, so we should make sure we are too+    , testGroup "case sensitivity" $ eval' $ do+        id0 <- Id.toText <$> Id.make "foobar"+        id1 <- Id.toText <$> Id.make "fOoBAr"+        pure [ testCase "id0 == foobar"   $ id0 @?= "foobar"+             , testCase "id1 == fOoBAr_0" $ id1 @?= "fOoBAr_0"+             ]++    -- An identifier made with 'mkBasic' should pass the 'isBasic' test+    , testGroup "mkBasic" $ concat $ flip map [minBound..maxBound] $ \hdl ->+      [ testProperty (show hdl <> " (ascii)")+          (Id.isBasic# hdl . roundTrip False hdl . coerce @ArbitraryAsciiText)+      , testProperty (show hdl <> " (UTF8)")+          (Id.isBasic# hdl . roundTrip False hdl . coerce @ArbitraryText)+      ]++      -- We expect a processed identifier to be either a valid basic xor+      -- extended identifier. Anything "in between" is an error.+    , testGroup "Basic XOR Extended" $ flip map [minBound..maxBound] $ \hdl ->+        testProperty (show hdl) $ \id0 ->+          let id1 = roundTrip True hdl (coerce @ArbitraryText id0) in+          Id.isBasic# hdl id1 `xor` Id.isExtended# hdl id1++    , testCase "keyword (use => \\use\\)" ("\\use\\" @=? roundTrip' "use")+    , testCase "keyword (else => \\else\\)" ("\\else\\" @=? roundTrip' "else")+    , testCase "keyword (record => \\record\\)" ("\\record\\" @=? roundTrip' "record")+    , testCase "keyword (configuration => \\configuration\\)" ("\\configuration\\" @=? roundTrip' "configuration")+    , testCase "keyword (cOnFiGUrAtiON => \\cOnFiGUrAtiON\\)" ("\\cOnFiGUrAtiON\\" @=? roundTrip' "cOnFiGUrAtiON")+    , testCase "Verilog keyword in VHDL (always => always)" ("always" @=? roundTrip' "always")++    , testGroup "extended identifiers"+      [ testCase "(1) foo bar => \\foo bar\\" $ "\\foo bar\\" @=? roundTrip' "foo bar"+      , testCase "(2) foo bar => \\foo bar\\" $ 9 @=? Text.length (roundTrip' "foo bar")++      , testCase "foo\\bar => foobar" $ "foobar" @=? roundTrip' "foo\\bar"+      , testCase "\\foobar\\ => foobar" $ "foobar" @=? roundTrip' "\\foobar\\"++      -- This behavior makes sense, but it results in ugly identifiers, so+      -- backslashes are stripped+      -- , testCase "foo\\bar => \\foo\\\\bar\\" $ "\\foo\\\\bar\\" @=? roundTrip' "foo\\bar"+      -- , testCase "\\foobar\\ => \\\\\\foobar\\\\\\" $ "\\\\\\foobar\\\\\\" @=? roundTrip' "\\foobar\\"+      ]++    , testGroup "pretty names"+      [ testCase "(# #) => Unit" $ "Unit" @=? roundTrip' "(# #)"+      , testCase "() => Unit" $ "Unit" @=? roundTrip' "()"+      , testCase "(,,) => Tuple3" $ "Tuple3" @=? roundTrip' "(,,)"+      , testCase "(#,,,,#) => Tuple5" $ "Tuple5" @=? roundTrip' "(,,,,)"+      ]++    , testGroup "pretty names (force basic)"+      [ testCase "(# #) => Unit" $ "Unit" @=? roundTrip False VHDL "(# #)"+      , testCase "() => Unit" $ "Unit" @=? roundTrip False VHDL "()"+      , testCase "(,,) => Tuple3" $ "Tuple3" @=? roundTrip False VHDL "(,,)"+      , testCase "(#,,,,#) => Tuple5" $ "Tuple5" @=? roundTrip False VHDL "(,,,,)"+      ]++    , testGroup "disallow escaped identifiers"+      [ testCase "foo bar => foobar" $ "foobar" @=? roundTrip False VHDL "foo bar"+      , testCase "foo\\bar => foobar" $ "foobar" @=? roundTrip False VHDL "foo\\bar"+      ]++      -- Raw identifiers are a bit weird: they're passed in by users and should+      -- be spliced into the HDL at verbatim. Clash shouldn't generate collisions+      -- though.+    , testGroup "raw identifiers"+      [ testProperty "id" rawToIdProperty+      , testGroup "Verilog: \\foo bar␣" $ eval True Verilog $ do+          id0 <- Id.toText <$> Id.addRaw "\\foo bar "+          id1 <- Id.toText <$> Id.make "foo bar"+          pure [ testCase "id0 == \\foo bar " $ id0 @?= "\\foo bar "+               , testCase "id1 == \\foo bar_0 " $ id1 @?= "\\foo bar_0 "+               ]+      , testGroup "Verilog: \\foo bar␣␣" $ eval True Verilog $ do+          id0 <- Id.toText <$> Id.addRaw "\\foo bar  "+          id1 <- Id.toText <$> Id.make "foo bar"+          pure [ testCase "id0 == \\foo bar  " $ id0 @?= "\\foo bar  "+               , testCase "id1 == \\foo bar_0 " $ id1 @?= "\\foo bar_0 "+               ]+      , testGroup "VHDL: \\foo bar\\" $ eval True VHDL $ do+          id0 <- Id.toText <$> Id.addRaw "\\foo bar\\"+          id1 <- Id.toText <$> Id.make "foo bar"+          pure [ testCase "id0 == \\foo bar\\" $ id0 @?= "\\foo bar\\"+               , testCase "id1 == \\foo bar_0\\ " $ id1 @?= "\\foo bar_0\\"+               ]+      , testGroup "VHDL: \\foo bar \\" $ eval True VHDL $ do+          id0 <- Id.toText <$> Id.addRaw "\\foo bar \\"+          id1 <- Id.toText <$> Id.make "foo bar"+          -- While 'id1' could strictly be \foo bar\, it's probably best to be+          -- whitespace insensitive.+          pure [ testCase "id0 == \\foo bar \\" $ id0 @?= "\\foo bar \\"+               , testCase "id1 == \\foo bar_0\\ " $ id1 @?= "\\foo bar_0\\"+               ]+      ]+    ]
+ tests/Clash/Tests/Normalize/Transformations.hs view
@@ -0,0 +1,134 @@+{-|+Copyright  :  (C) 2020, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}+{-# LANGUAGE QuasiQuotes #-}++module Clash.Tests.Normalize.Transformations where++import Data.Maybe (fromMaybe)++import Clash.Normalize.Transformations (inlineBndrsCleanup)+import Clash.Core.VarEnv+  (mkInScopeSet, mkVarSet, mkVarEnv, emptyVarEnv)+import Clash.Core.FreeVars (countFreeOccurances)+import Clash.Core.Term++import Test.Tasty+import Test.Tasty.HUnit++import Test.Clash.Rewrite (parseToTermQQ, parseToTerm)++t1337a :: Term+t1337a = fromMaybe (error "failed to build term") $ do+  Letrec binds result <- pure $+    [parseToTermQQ|+      let+        -- Types don't mean anything for this example+        result_1, a_2, b_3, c_4 :: Int++        result_1 = a_2++        a_2 = b_3+        b_3 = c_4+        c_4 = a_2 b_3+      in+        result_1+    |]++  (keep0:inlines) <- pure (map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds)+  let is = mkInScopeSet (mkVarSet (map fst binds))++  let keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0]++  return (Letrec keep1 result)++t1337a_result :: Term+t1337a_result = [parseToTermQQ|+  let+    result_1, b_3 :: Int+    result_1 = b_3+    b_3 = b_3 b_3+  in+    result_1+|]++t1337b :: Term+t1337b = fromMaybe (error "failed to build term") $ do++  Letrec binds result <- pure $+    [parseToTermQQ|+      let+        -- Types don't mean anything for this example+        result_1, a_2, b_3, c_4, d_5 :: Int++        result_1 = a_2++        a_2 = b_3+        b_3 = c_4+        c_4 = d_5+        d_5 = a_2 b_3 c_4+      in+        result_1+    |]++  (keep0:inlines) <- pure (map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds)+  let is = mkInScopeSet (mkVarSet (map fst binds))++  let keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0]++  return (Letrec keep1 result)++t1337b_result :: Term+t1337b_result = [parseToTermQQ|+  let+    result_1, c_4 :: Int+    result_1 = c_4+    c_4 = c_4 c_4 c_4+  in+    result_1+|]++t1337c :: Term+t1337c = fromMaybe (error "failed to build term") $ do+  Letrec binds result <- pure $+    [parseToTermQQ|+      let+        result_1, a_2, b_3, c_4 :: Int++        result_1 = a_2++        a_2 = b_3+        b_3 = c_4+        c_4 = a_2 b_3 (freevar_5 :: Int)+      in+        result_1+    |]++  (keep0:inlines) <- pure (map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds)+  Var fv <- pure (parseToTerm "freevar_5 :: Int")+  let is = mkInScopeSet (mkVarSet (fv : map fst binds))++  let keep1 = inlineBndrsCleanup is (mkVarEnv inlines) emptyVarEnv [snd keep0]++  return (Letrec keep1 result)++t1337c_result :: Term+t1337c_result = [parseToTermQQ|+  let+    result_1, b_3 :: Int+    result_1 = b_3+    b_3 = b_3 b_3 (freevar_5 :: Int)+  in+    result_1+|]++tests :: TestTree+tests =+  testGroup+    "Clash.Tests.Core.Util.Interpolation"+    [ testCase "T1337a" $ t1337a_result @=? t1337a+    , testCase "T1337b" $ t1337b_result @=? t1337b+    , testCase "T1337c" $ t1337c_result @=? t1337c+    ]
+ tests/Clash/Tests/Util/Interpolate.hs view
@@ -0,0 +1,72 @@+{-|+Copyright  :  (C) 2019, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}+{-# LANGUAGE QuasiQuotes #-}++module Clash.Tests.Util.Interpolate where++import qualified Clash.Util.Interpolate as I++import Test.Tasty+import Test.Tasty.HUnit++test1, test2, test3, test4, test5, test6, test7, test8, test9 :: String+test1 = [I.i| Simple |]+test2 = [I.i|+  Single line+|]+test3 = [I.i|++  Surrounded by newlines++|]+test4 = [I.i|+  One+  Two+  Three+|]+test5 = [I.i|+  One+    Two+  Three+|]+test6 = [I.i|+  #{test5}+|]++test7 = [I.i|+  The big test:++  #{test5}+|]++test8 = [I.i|+  looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong word+|]++data SomeRecord = SomeRecord { getField :: Int }+someRecord :: SomeRecord+someRecord = SomeRecord 5+-- test that we can escape closing '}'+test9 = [I.i| #{ "\\" ++ show (getField someRecord { getField=6*7+                                                  \}+                              )+               }+            |]++tests :: TestTree+tests =+  testGroup+    "Clash.Tests.Core.Util.Interpolation"+    [ testCase "test1" $ "Simple" @=? test1+    , testCase "test2" $ "Single line" @=? test2+    , testCase "test3" $ "Surrounded by newlines" @=? test3+    , testCase "test4" $ "One Two Three" @=? test4+    , testCase "test5" $ "One\n  Two\nThree" @=? test5+    , testCase "test6" $ test5 @=? test6+    , testCase "test7" $ test7 @?= ("The big test:\n\n" ++ test5)+    , testCase "test8" $ test8 @?= "looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong \nword"+    , testCase "test9" $ test9 @?= "\\42"+    ]
+ tests/Test/Clash/Rewrite.hs view
@@ -0,0 +1,301 @@+{-|+  Copyright  :  (C) 2020,2022 QBayLogic B.V.+  License    :  BSD2 (see the file LICENSE)+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++  Utilities to write unit tests on transformations+-}++{-# OPTIONS_GHC -Wno-orphans #-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++module Test.Clash.Rewrite where++import Clash.Annotations.BitRepresentation.Internal (buildCustomReprs)+import qualified Clash.Core.Name as C+import qualified Clash.Core.Term as C+import qualified Clash.Core.Literal as C+import qualified Clash.Core.Type as C+import qualified Clash.Core.Var as C+import Clash.Core.VarEnv (InScopeSet, emptyVarSet, emptyVarEnv, emptyInScopeSet)+import Clash.Driver.Types (ClashEnv(..), ClashOpts(..), defClashOpts, debugSilent)+import Clash.Rewrite.Types+import Clash.Rewrite.Util (runRewrite)+import Clash.Normalize.Types+import qualified Clash.Util.Interpolate as I+import Clash.Util.Supply (newSupply)+import Clash.Unique (Unique)++import Control.Applicative ((<|>))+import Data.Default+import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.Parser (parseExp, fromParseResult)+import System.IO.Unsafe (unsafePerformIO)+import Text.Read (readMaybe)+import GHC.Stack (HasCallStack)++import qualified Language.Haskell.TH.Syntax as TH+import qualified Language.Haskell.TH.Quote as TH++import qualified Data.List as List+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import qualified Data.Text as Text++type TypeMap = HashMap.HashMap Unique C.Type++lookupTM :: Unique -> TypeMap -> C.Type+lookupTM u tm = case HashMap.lookup u tm of+  Just t -> t+  Nothing ->+    error [I.i|+      Tried to lookup unique '#{u}' in typemap, but couldn't find it. This+      usually means you forgot to (explicitely) declare a variable's type.+    |]++instance Default RewriteEnv where+  def = RewriteEnv+    { _clashEnv = ClashEnv+        { envOpts = defClashOpts { opt_debug = debugSilent }+        , envTyConMap = mempty+        , envTupleTyCons = IntMap.empty+        , envPrimitives = HashMap.empty+        , envCustomReprs = buildCustomReprs []+        , envDomains = HashMap.empty+        }+    , _typeTranslator=error "_typeTranslator: NYI"+    , _peEvaluator=error "_peEvaluator: NYI"+    , _evaluator=error "_evaluator: NYI"+    , _topEntities=emptyVarSet+    }++instance Default extra => Default (RewriteState extra) where+  def = RewriteState+    { _transformCounter=0+    , _transformCounters=mempty+    , _bindings=emptyVarEnv+    , _uniqSupply=unsafePerformIO newSupply+    , _curFun=error "_curFun: NYI"+    , _nameCounter=2+    , _workFreeBinders=emptyVarEnv+    , _globalHeap=error "_globalHeap: NYI"+    , _extra=def+    }++instance Default NormalizeState where+  def = NormalizeState+    { _normalized=emptyVarEnv+    , _specialisationCache=Map.empty+    , _specialisationHistory=emptyVarEnv+    , _inlineHistory=emptyVarEnv+    , _primitiveArgs=Map.empty+    , _recursiveComponents=emptyVarEnv+    }++instance Default InScopeSet where+  def = emptyInScopeSet++-- | Run a single transformation given a certain context+runSingleTransformation+  :: RewriteEnv+  -- ^ Rewrite environment+  -> RewriteState extra+  -- ^ Rewrite state+  -> InScopeSet+  -- ^ Variables in scope in transformation+  -> Rewrite extra+  -- ^ Transformation to perform+  -> C.Term+  -- ^ Term to transform+  -> IO C.Term+runSingleTransformation rwEnv rwState is trans term = do+  (t, _, _) <- runR (runRewrite "" is trans term) rwEnv rwState+  pure t++-- | Run a single transformation with an empty environment and empty+-- InScopeSet. See Default instances ^ to inspect the precise definition of+-- "empty".+--+-- Note that at the time of writing (May 2020) the default environment does not+-- include a type translator, evaluator, current function, or global heap. Maps,+-- like the primitive and tycon map, are also empty. If the transformation under+-- test needs these definitions, you should add them manually.+runSingleTransformationDef :: Default extra => Rewrite extra -> C.Term -> IO C.Term+runSingleTransformationDef = runSingleTransformation def def def+++parseType :: Show l => Type l -> C.Type+parseType = \case+  -- Type constructor: T+  TyCon _ (UnQual _ (Ident _ typNm)) ->+    -- TODO: We could/should build a TyConMap here+    C.ConstTy (C.TyCon (C.Name C.User (Text.pack typNm) 0 C.noSrcSpan))++  -- Unsupported type:+  t ->+    error ("parseType: " <> show t)++-- | Parse an identifier into a Clash Name. Identifiers must include a unique+-- and might include a modifier indicating whether its NameSort. Examples:+--+--   * x_3:  User identifier with human readable name "x", unique "3"+--   * x_I3: Internal identifier with human readable name "x", unique "3"+--   * x_S3: System identifier with human readable name "x", unique "3"+--+parseName :: Show l => Name l -> C.Name a+parseName = \case+  Ident _ s -> failOnNothing s (go "" s)+  Symbol _ s -> failOnNothing s (go "" s)+ where+  failOnNothing _ (Just (nmSort, nm, uniq)) =+    C.mkUnsafeName nmSort (Text.pack nm) uniq+  failOnNothing s Nothing = error [I.i|+    Not a valid id: #{s}. Identifiers must be of form 'foobar_123', where+    'foobar' is a human-readable (but ultimately unused) name and '123' is the+    unique. Additionally, 'I', 'U', or 'S' might be prefixed to create an+    Internal, User, or System name respectively. For example, 'foobar_S123'.+  |]++  go _seen "" = Nothing+  go seen0 ('_':s:ss)+    | 'U' <- s = fmap (C.User,seen1,) (readMaybe ss) <|> cont+    | 'S' <- s = fmap (C.System,seen1,) (readMaybe ss) <|> cont+    | 'I' <- s = fmap (C.Internal,seen1,) (readMaybe ss) <|> cont+    | otherwise = fmap (C.User,seen1,) (readMaybe (s:ss)) <|> cont+   where+    seen1 = reverse seen0+    cont = go ('_':seen0) (s:ss)+  go seen (s:ss) = go (s:seen) ss++-- | Parse declarations (as, amongst others, used in let expressions). Note that+-- every binder needs an explicit type annotation, as we don't do any type+-- inference. Type annotations may occur anywhere though. Example, this is OK:+--+--    let+--      x_0 :: Int+--      x_0 = 2+--+--      x_1 :: Int+--      x_1 = x_0+--    in+--      x_1+--+-- But this is not:+--+--    let+--      x_0 :: Int+--      x_0 = 2+--+--      x_1 = x_0+--    in+--      x_1+--+parseDecls+  :: forall l+   . (HasCallStack, Show l)+  => TypeMap+  -> [Decl l]+  -> (TypeMap, [C.LetBinding])+parseDecls typs0 decls = (typs1, map parseOtherDecl otherDecls)+ where+  (typDecls, otherDecls) = List.partition isTypeDecl decls+  insertTyp (nm, t) = HashMap.insert nm t+  typs1 = foldr insertTyp typs0 (concatMap parseTypeDecl typDecls)++  parseOtherDecl :: HasCallStack => Decl l -> C.LetBinding+  parseOtherDecl = \case+    PatBind _ (PVar _ (parseName -> nm)) (UnGuardedRhs _ e) Nothing ->+      let+        uniq = C.nameUniq nm+        typ = lookupTM (C.nameUniq nm) typs1+      in+        (C.Id nm uniq typ C.LocalId, expToTerm typs1 e)+    e ->+      error ("parseOtherDecl: " <> show e)++  parseTypeDecl :: Decl l -> [(Unique, C.Type)]+  parseTypeDecl (TypeSig _ nms t) =+    map (\nm -> (C.nameUniq (parseName nm), parseType t)) nms+  parseTypeDecl _ = error "impossible"++  isTypeDecl :: Decl l -> Bool+  isTypeDecl (TypeSig {}) = True+  isTypeDecl _ = False++-- | Parse a haskell-src-exts expression into Clash Core.+expToTerm+  :: forall l+   . (HasCallStack, Show l)+  => TypeMap+  -> Exp l+  -> C.Term+expToTerm typs0 = \case+  -- Parentheses: (...)+  Paren _ e ->+    expToTerm typs0 e++  -- Local variable reference with type signature: x :: t+  ExpTypeSig _ (Var _ (UnQual _ (parseName -> nm))) (parseType -> t) ->+    C.Var (C.Id nm (C.nameUniq nm) t C.LocalId)++  -- Term application: e1 e2+  App _ e1 e2 ->+    C.App (expToTerm typs0 e1) (expToTerm typs0 e2)++  -- Variable reference: e+  Var _ (UnQual _ (parseName -> nm)) ->+    let+     uniq = C.nameUniq nm+     typ = lookupTM (C.nameUniq nm) typs0+    in+      C.Var (C.Id nm uniq typ C.LocalId)++  -- Literal: 3+  Lit _ (Int _ i _) -> C.Literal (C.IntLiteral i)++  -- Let expression: let {e1 = .., e2 = ..} in r+  Let _ (BDecls _ decls0) body0 ->+    let+      (typs1, decls1) = parseDecls typs0 decls0+      body1 = expToTerm typs1 body0+    in+      C.Letrec decls1 body1++ -- Unsupported expression+  e -> error ("expToTerm: " <> show e)++-- | Parse a string representing a Haskell expression into Clash Core. This can+-- only parse very simple expressions. In the future we should make an effort to+-- build a proper TyConMap (using LoadModules) to faithfully reproduce more+-- complex expressions.+parseToTerm :: String -> C.Term+parseToTerm = expToTerm HashMap.empty . fromParseResult . parseExp++-- | See documentation of 'parseToTerm'. Example usage:+--+--     letrec = [parseToTermQQ|+--        let+--          x_0, x_1 :: Int+--          x_0 = 5+--          x_1 = 6+--        in+--          x_0+--     |]+--+-- Note that this is parsed at runtime, not at compile time. There's no good+-- technical reason for this though. We'd just need to implement a Template+-- Haskell Lift instance for Term.+--+-- For more information on the format of identifiers, see 'parseName'.+parseToTermQQ :: TH.QuasiQuoter+parseToTermQQ = TH.QuasiQuoter{+    TH.quoteExp = fmap (TH.AppE (TH.VarE 'parseToTerm)) . TH.lift+  , TH.quotePat = error "parseToTerm.quotePat: NYI"+  , TH.quoteType = error "parseToTerm.quoteType: NYI"+  , TH.quoteDec = error "parseToTerm.quoteDec: NYI"+  }
+ tests/doctests.hs view
@@ -0,0 +1,7 @@+module Main where++import System.Environment (getArgs)+import Test.DocTest (mainFromCabal)++main :: IO ()+main = mainFromCabal "clash-lib" =<< getArgs
+ tests/unittests.hs view
@@ -0,0 +1,35 @@+module Main where++import Test.Tasty+import Test.Tasty.QuickCheck++import qualified Clash.Tests.Core.FreeVars+import qualified Clash.Tests.Core.Subst+import qualified Clash.Tests.Core.TermLiteral+import qualified Clash.Tests.Driver.Manifest+import qualified Clash.Tests.Netlist.Id+import qualified Clash.Tests.Normalize.Transformations+import qualified Clash.Tests.Util.Interpolate++-- AFAIK there's no good way to override the default, so we just detect the+-- default value and change it.+setDefaultQuickCheckTests :: QuickCheckTests -> QuickCheckTests+setDefaultQuickCheckTests (QuickCheckTests 100) = 10000+setDefaultQuickCheckTests opt = opt++tests :: TestTree+tests = testGroup "Unittests"+  [ Clash.Tests.Core.FreeVars.tests+  , Clash.Tests.Core.Subst.tests+  , Clash.Tests.Core.TermLiteral.tests+  , Clash.Tests.Driver.Manifest.tests+  , Clash.Tests.Netlist.Id.tests+  , Clash.Tests.Normalize.Transformations.tests+  , Clash.Tests.Util.Interpolate.tests+  ]++main :: IO ()+main =+    defaultMain+  $ adjustOption setDefaultQuickCheckTests+  $ tests
+ tools/static-files.hs view
@@ -0,0 +1,71 @@+{-|+Copyright   :  (C) 2022     , Google Inc.+License     :  BSD2 (see the file LICENSE)+Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++Produce static files that are useful when working with Clash designs.+-}++{-# LANGUAGE QuasiQuotes #-}++module Main where++import Control.Monad (when)+import Control.Monad.Extra (whenM, unlessM)+import Prelude+import System.Console.Docopt+  (Docopt, docopt, isPresent, getArg, longOption, parseArgsOrExit)+import System.Directory (copyFile, doesDirectoryExist, doesFileExist)+import System.Environment (getArgs)+import System.Exit (die)+import System.FilePath (takeDirectory)++import Clash.DataFiles++patterns :: Docopt+patterns = [docopt|+Obtain static files useful when working with Clash designs++Currently, only the Tcl connector is available.++Usage:+  static-files [--force] [--verbose] --tcl-connector=<outfile>++Options:+  -f, --force                  Overwrite existing files+  -v, --verbose                Explain what is being done+  --tcl-connector=<outfile>    Write a Tcl script to a file that can parse Clash+                               manifest JSON files and emit the correct commands+                               for loading the design into Vivado+|]++-- Checks whether it looks like we can write a file in the location @path@,+-- accounting for the @--force@ command line argument. Exit with a descriptive+-- error message if something's amiss.+createOkayOrDie ::+  FilePath ->+  Bool ->+  IO ()+createOkayOrDie path force = do+  let pathDir = takeDirectory path+  unlessM (doesDirectoryExist pathDir) $+    die $ "Directory not found: " ++ pathDir+  whenM (doesDirectoryExist path) $+    die $ path ++ " is a directory. Please specify a file name."+  exists <- doesFileExist path+  when (exists && not force) $+    die $ path ++ " already exists and --force not specified. " +++                  "Refusing to overwrite."++main :: IO ()+main = do+  args <- parseArgsOrExit patterns =<< getArgs+  -- Since we got here, we know we got invoked with the sole mandatory option+  -- @--tcl-connector@ and its mandatory argument+  let force = args `isPresent` (longOption "force")+      verbose = args `isPresent` (longOption "verbose")+      Just outFile = args `getArg` (longOption "tcl-connector")+  createOkayOrDie outFile force+  inFile <- tclConnector+  copyFile inFile outFile+  when verbose $ putStrLn $ "Tcl Connector written to " ++ outFile
+ tools/v16-upgrade-primitives.hs view
@@ -0,0 +1,115 @@+{- Utility executable to convert "old-style" JSON primitives to "new-style"+   YAML ones. See https://github.com/clash-lang/clash-compiler/pull/2009.+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import qualified Data.Aeson.KeyMap as Aeson+import Data.String (IsString)+import qualified Data.Text.Lazy as LazyText+import qualified Data.Text.Lazy.Encoding as LazyText++import qualified Data.Aeson.Extra as AesonExtra+import qualified Data.Aeson as Aeson+import qualified Data.Yaml as Yaml+import qualified Data.ByteString.Lazy as ByteString+import qualified Data.Set as Set++import Control.Monad (forM_, when)+import Data.ByteString.Lazy (ByteString)+import System.Directory (removeFile)+import System.Environment (getArgs)+import System.FilePath.Glob (glob)++help :: String+help = unlines+  [ "Convert JSON primitive files into YAML ones. YAML files will be written to "+  , "the original filename with '.yaml' appended."+  , ""+  , "Usage:"+  , "  v16-upgrade-primitives [options]... <file>..."+  , ""+  , "Options:"+  , "  --dry-run        Do not write YAML files."+  , "  --delete         Delete JSON files after writing."+  , "  --help | -h      Show this screen."+  , ""+  , "Example:"+  , "  v16-upgrade-primitives --dry-run prims/**/*.primitives"+  ]++-- | Same as 'glob', but errors on patterns matching no files.+globOrErr :: FilePath -> IO [FilePath]+globOrErr pattern = do+  files <- glob pattern+  when (null files) (error ("Pattern does not match any files: " <> pattern))+  pure files++-- | 'concatMap', but its monadic cousin+concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f = fmap concat . mapM f++-- | Read file and output YAML ByteString+jsonToYaml :: FilePath -> IO ByteString+jsonToYaml path = do+  contents <- ByteString.readFile path+  let decoded = AesonExtra.decodeOrErrJson path contents+  pure . removeTempKey . ByteString.fromStrict . Yaml.encode . customSortOutput $ decoded++{- NOTE [Sorting YAML object keys]++'Yaml.encode' encodes object with their keys in alphabetical order.+For readability we like `name` to be at the top, and `type` to be just above `template`.++We accomplice this here by renaming those keys to something there sorts where+we like them to be. And find-and-replace those temporary names back+in the resulting ByteString.+-}+keySortingRenames :: IsString str => [(str,str)]+keySortingRenames =+  [ ("name", "aaaa_really_should_be_name_but_renamed_to_get_the_sorting_we_like")+  , ("type", "really_should_be_type_but_renamed_to_get_the_sorting_we_like")+  ]++customSortOutput :: Aeson.Value -> Aeson.Value+customSortOutput x = case x of+  Aeson.Object o -> Aeson.Object $ fmap customSortOutput $ renameKeys $ o+  Aeson.Array xs -> Aeson.Array $ fmap customSortOutput xs+  _ -> x+ where+  renameKeys obj = foldl renameKey obj keySortingRenames+  renameKey obj (kOld,kNew) =+    case Aeson.lookup kOld obj of+      Nothing -> obj+      Just val -> Aeson.insert kNew val (Aeson.delete kOld obj)++removeTempKey :: ByteString -> ByteString+removeTempKey inp =+  LazyText.encodeUtf8 (foldl go (LazyText.decodeUtf8 inp) keySortingRenames)+ where+  go txt (orig,temp) = LazyText.replace temp orig txt++main :: IO ()+main = do+  args0 <- Set.fromList <$> getArgs++  let+    doDryRun = Set.member "--dry-run" args0+    doWrite = not doDryRun+    doDelete = Set.member "--delete" args0 && doWrite+    doHelp = Set.member "-h" args0 || Set.member "--help" args0 || Set.null args1+    args1 = foldr Set.delete args0 ["--dry-run", "--delete", "--help", "-h"]++  if doHelp then+    putStrLn help+  else do+    files <- concatMapM globOrErr (Set.toList args1)+    forM_ files $ \path -> do+      let newPath = path <> ".yaml"+      putStrLn $ "Converting " <> path <> ".."+      decoded <- jsonToYaml path+      when doWrite $ ByteString.writeFile newPath decoded+      when doDelete $ removeFile path