clash-lib 1.0.1 → 1.2.0

raw patch · 103 files changed

+9557/−5161 lines, 103 filesdep +data-defaultdep +dlistdep +extradep ~clash-preludedep ~ghcdep ~lensPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default, dlist, extra, ghc-boot-th, haskell-src-meta, ordered-containers

Dependency ranges changed: clash-prelude, ghc, lens

API changes (from Hackage documentation)

Files

• CHANGELOG.md +265/−379
• clash-lib.cabal +58/−21
• prims/common/Clash_Intel_ClockGen.json +12/−0
• prims/common/Clash_Magic.json +15/−0
• prims/common/Clash_XException.json +8/−0
• prims/common/GHC_Natural.json +7/−0
• prims/commonverilog/Clash_Explicit_SimIO.json +127/−0
• prims/commonverilog/Clash_Sized_Internal_BitVector.json +5/−7
• prims/commonverilog/Clash_Sized_Internal_Index.json +2/−4
• prims/commonverilog/Clash_Sized_Internal_Signed.json +2/−4
• prims/commonverilog/Clash_Sized_Internal_Unsigned.json +2/−4
• prims/systemverilog/Clash_Signal_BiSignal.json +1/−0
• prims/systemverilog/Clash_Signal_Internal.json +12/−12
• prims/systemverilog/Clash_Sized_Internal_Signed.json +19/−7
• prims/systemverilog/Clash_Sized_Vector.json +0/−52
• prims/systemverilog/GHC_Classes.json +18/−6
• prims/systemverilog/GHC_Integer_Type.json +70/−6
• prims/systemverilog/GHC_Prim.json +6/−6
• prims/verilog/Clash_Signal_BiSignal.json +1/−0
• prims/verilog/Clash_Signal_Internal.json +17/−13
• prims/verilog/Clash_Sized_Internal_Signed.json +19/−7
• prims/verilog/Clash_Sized_Vector.json +0/−75
• prims/verilog/GHC_Classes.json +18/−6
• prims/verilog/GHC_Integer_Type.json +72/−6
• prims/verilog/GHC_Prim.json +6/−6
• prims/vhdl/Clash_Explicit_BlockRam.json +6/−30
• prims/vhdl/Clash_Explicit_BlockRam_File.json +4/−20
• prims/vhdl/Clash_Explicit_ROM.json +2/−10
• prims/vhdl/Clash_Explicit_ROM_File.json +2/−10
• prims/vhdl/Clash_Explicit_SimIO.json +31/−0
• prims/vhdl/Clash_Signal_BiSignal.json +1/−0
• prims/vhdl/Clash_Signal_Internal.json +47/−99
• prims/vhdl/Clash_Sized_Internal_BitVector.json +2/−4
• prims/vhdl/Clash_Sized_Internal_Index.json +2/−4
• prims/vhdl/Clash_Sized_Internal_Signed.json +13/−8
• prims/vhdl/Clash_Sized_Internal_Unsigned.json +2/−4
• prims/vhdl/Clash_Sized_Vector.json +0/−46
• prims/vhdl/GHC_Classes.json +13/−6
• prims/vhdl/GHC_Integer_Type.json +43/−4
• prims/vhdl/GHC_Prim.json +4/−4
• src/Clash/Annotations/TopEntity/Extra.hs +4/−0
• src/Clash/Backend.hs +22/−0
• src/Clash/Backend/SystemVerilog.hs +363/−125
• src/Clash/Backend/VHDL.hs +176/−101
• src/Clash/Backend/Verilog.hs +214/−106
• src/Clash/Core/DataCon.hs +4/−5
• src/Clash/Core/Evaluator.hs +346/−490
• src/Clash/Core/Evaluator/Types.hs +249/−0
• src/Clash/Core/FreeVars.hs +13/−18
• src/Clash/Core/Literal.hs +2/−3
• src/Clash/Core/Name.hs +4/−5
• src/Clash/Core/Pretty.hs +25/−9
• src/Clash/Core/Subst.hs +73/−6
• src/Clash/Core/Term.hs +65/−16
• src/Clash/Core/TermLiteral.hs +96/−0
• src/Clash/Core/TermLiteral/TH.hs +93/−0
• src/Clash/Core/TyCon.hs +3/−4
• src/Clash/Core/Type.hs +79/−28
• src/Clash/Core/TysPrim.hs +1/−1
• src/Clash/Core/Util.hs +198/−33
• src/Clash/Core/Var.hs +4/−6
• src/Clash/Core/VarEnv.hs +29/−5
• src/Clash/Driver.hs +303/−63
• src/Clash/Driver/Types.hs +85/−12
• src/Clash/Netlist.hs +404/−219
• src/Clash/Netlist.hs-boot +10/−7
• src/Clash/Netlist/BlackBox.hs +485/−94
• src/Clash/Netlist/BlackBox.hs-boot +29/−0
• src/Clash/Netlist/BlackBox/Parser.hs +4/−3
• src/Clash/Netlist/BlackBox/Types.hs +43/−9
• src/Clash/Netlist/BlackBox/Util.hs +95/−63
• src/Clash/Netlist/BlackBox/Util.hs-boot +19/−0
• src/Clash/Netlist/Id.hs +1/−2
• src/Clash/Netlist/Types.hs +144/−20
• src/Clash/Netlist/Util.hs +280/−164
• src/Clash/Normalize.hs +108/−78
• src/Clash/Normalize/DEC.hs +27/−22
• src/Clash/Normalize/PrimitiveReductions.hs +30/−24
• src/Clash/Normalize/Strategy.hs +9/−4
• src/Clash/Normalize/Transformations.hs +2864/−2305
• src/Clash/Normalize/Types.hs +3/−1
• src/Clash/Normalize/Util.hs +123/−30
• src/Clash/Primitives/GHC/Int.hs +1/−2
• src/Clash/Primitives/Intel/ClockGen.hs +127/−17
• src/Clash/Primitives/Sized/ToInteger.hs +109/−0
• src/Clash/Primitives/Sized/Vector.hs +192/−29
• src/Clash/Primitives/Types.hs +58/−9
• src/Clash/Primitives/Util.hs +63/−14
• src/Clash/Rewrite/Combinators.hs +0/−4
• src/Clash/Rewrite/Types.hs +13/−10
• src/Clash/Rewrite/Util.hs +264/−102
• src/Clash/Unique.hs +11/−3
• src/Clash/Util.hs +102/−11
• src/Clash/Util/Graph.hs +1/−0
• src/Clash/Util/Interpolate.hs +369/−0
• src/Data/Aeson/Extra.hs +9/−1
• src/Data/Set/Ordered/Extra.hs +36/−0
• src/Data/Text/Prettyprint/Doc/Extra.hs +8/−1
• src/GHC/BasicTypes/Extra.hs +0/−3
• src/GHC/SrcLoc/Extra.hs +2/−4
• tests/Clash/Tests/Core/Subst.hs +53/−0
• tests/Clash/Tests/Util/Interpolate.hs +72/−0
• tests/unittests.hs +4/−0

@@ -1,22 +1,155 @@-# Changelog for the [`clash-lib`](http://hackage.haskell.org/package/clash-lib) package+# Changelog for the Clash project +## 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.+  * 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)+    * (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@@ -36,95 +169,95 @@     See for example: http://hackage.haskell.org/package/clash-lib/docs/Clash-Primitives-Intel-ClockGen.html  * Fixes issues:-  * [#316](https://github.com/clash-lang/clash-prelude/issues/316)-  * [#319](https://github.com/clash-lang/clash-prelude/issues/319)-  * [#323](https://github.com/clash-lang/clash-prelude/issues/323)-  * [#324](https://github.com/clash-lang/clash-prelude/issues/324)-  * [#329](https://github.com/clash-lang/clash-prelude/issues/329)-  * [#331](https://github.com/clash-lang/clash-prelude/issues/331)-  * [#332](https://github.com/clash-lang/clash-prelude/issues/332)-  * [#335](https://github.com/clash-lang/clash-prelude/issues/335)-  * [#348](https://github.com/clash-lang/clash-prelude/issues/348)-  * [#349](https://github.com/clash-lang/clash-prelude/issues/349)-  * [#350](https://github.com/clash-lang/clash-prelude/issues/350)-  * [#351](https://github.com/clash-lang/clash-prelude/issues/351)-  * [#352](https://github.com/clash-lang/clash-prelude/issues/352)-  * [#353](https://github.com/clash-lang/clash-prelude/issues/353)-  * [#358](https://github.com/clash-lang/clash-prelude/issues/358)-  * [#359](https://github.com/clash-lang/clash-prelude/issues/359)-  * [#363](https://github.com/clash-lang/clash-prelude/issues/363)-  * [#364](https://github.com/clash-lang/clash-prelude/issues/364)-  * [#365](https://github.com/clash-lang/clash-prelude/issues/365)-  * [#371](https://github.com/clash-lang/clash-prelude/issues/371)-  * [#372](https://github.com/clash-lang/clash-prelude/issues/372)-  * [#373](https://github.com/clash-lang/clash-prelude/issues/373)-  * [#378](https://github.com/clash-lang/clash-prelude/issues/378)-  * [#380](https://github.com/clash-lang/clash-prelude/issues/380)-  * [#381](https://github.com/clash-lang/clash-prelude/issues/381)-  * [#382](https://github.com/clash-lang/clash-prelude/issues/382)-  * [#383](https://github.com/clash-lang/clash-prelude/issues/383)-  * [#387](https://github.com/clash-lang/clash-prelude/issues/387)-  * [#393](https://github.com/clash-lang/clash-prelude/issues/393)-  * [#396](https://github.com/clash-lang/clash-prelude/issues/396)-  * [#398](https://github.com/clash-lang/clash-prelude/issues/398)-  * [#399](https://github.com/clash-lang/clash-prelude/issues/399)-  * [#401](https://github.com/clash-lang/clash-prelude/issues/401)-  * [#403](https://github.com/clash-lang/clash-prelude/issues/403)-  * [#407](https://github.com/clash-lang/clash-prelude/issues/407)-  * [#412](https://github.com/clash-lang/clash-prelude/issues/412)-  * [#413](https://github.com/clash-lang/clash-prelude/issues/413)-  * [#420](https://github.com/clash-lang/clash-prelude/issues/420)-  * [#422](https://github.com/clash-lang/clash-prelude/issues/422)-  * [#423](https://github.com/clash-lang/clash-prelude/issues/423)-  * [#424](https://github.com/clash-lang/clash-prelude/issues/424)-  * [#438](https://github.com/clash-lang/clash-prelude/issues/438)-  * [#450](https://github.com/clash-lang/clash-prelude/issues/450)-  * [#452](https://github.com/clash-lang/clash-prelude/issues/452)-  * [#455](https://github.com/clash-lang/clash-prelude/issues/455)-  * [#460](https://github.com/clash-lang/clash-prelude/issues/460)-  * [#461](https://github.com/clash-lang/clash-prelude/issues/461)-  * [#463](https://github.com/clash-lang/clash-prelude/issues/463)-  * [#468](https://github.com/clash-lang/clash-prelude/issues/468)-  * [#475](https://github.com/clash-lang/clash-prelude/issues/475)-  * [#476](https://github.com/clash-lang/clash-prelude/issues/476)-  * [#500](https://github.com/clash-lang/clash-prelude/issues/500)-  * [#507](https://github.com/clash-lang/clash-prelude/issues/507)-  * [#512](https://github.com/clash-lang/clash-prelude/issues/512)-  * [#516](https://github.com/clash-lang/clash-prelude/issues/516)-  * [#517](https://github.com/clash-lang/clash-prelude/issues/517)-  * [#526](https://github.com/clash-lang/clash-prelude/issues/526)-  * [#556](https://github.com/clash-lang/clash-prelude/issues/556)-  * [#560](https://github.com/clash-lang/clash-prelude/issues/560)-  * [#566](https://github.com/clash-lang/clash-prelude/issues/566)-  * [#567](https://github.com/clash-lang/clash-prelude/issues/567)-  * [#569](https://github.com/clash-lang/clash-prelude/issues/569)-  * [#573](https://github.com/clash-lang/clash-prelude/issues/573)-  * [#575](https://github.com/clash-lang/clash-prelude/issues/575)-  * [#581](https://github.com/clash-lang/clash-prelude/issues/581)-  * [#582](https://github.com/clash-lang/clash-prelude/issues/582)-  * [#586](https://github.com/clash-lang/clash-prelude/issues/586)-  * [#588](https://github.com/clash-lang/clash-prelude/issues/588)-  * [#591](https://github.com/clash-lang/clash-prelude/issues/591)-  * [#596](https://github.com/clash-lang/clash-prelude/issues/596)-  * [#601](https://github.com/clash-lang/clash-prelude/issues/601)-  * [#607](https://github.com/clash-lang/clash-prelude/issues/607)-  * [#629](https://github.com/clash-lang/clash-prelude/issues/629)-  * [#637](https://github.com/clash-lang/clash-prelude/issues/637)-  * [#644](https://github.com/clash-lang/clash-prelude/issues/644)-  * [#647](https://github.com/clash-lang/clash-prelude/issues/647)-  * [#661](https://github.com/clash-lang/clash-prelude/issues/661)-  * [#668](https://github.com/clash-lang/clash-prelude/issues/668)-  * [#677](https://github.com/clash-lang/clash-prelude/issues/677)-  * [#678](https://github.com/clash-lang/clash-prelude/issues/678)-  * [#682](https://github.com/clash-lang/clash-prelude/issues/682)-  * [#691](https://github.com/clash-lang/clash-prelude/issues/691)-  * [#703](https://github.com/clash-lang/clash-prelude/issues/703)-  * [#713](https://github.com/clash-lang/clash-prelude/issues/713)-  * [#715](https://github.com/clash-lang/clash-prelude/issues/715)-  * [#727](https://github.com/clash-lang/clash-prelude/issues/727)-  * [#730](https://github.com/clash-lang/clash-prelude/issues/730)-  * [#736](https://github.com/clash-lang/clash-prelude/issues/736)-  * [#738](https://github.com/clash-lang/clash-prelude/issues/738)+  * [#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:@@ -136,15 +269,38 @@   * 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:-  * Support for `clash-prelude-0.99`:-      * Explicit clock and reset arguments-      * Overhaul of `TopEntity` annotations+  * 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@@ -154,280 +310,10 @@   * Improved compile-time computation * Many bug fixes -## 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+## 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 -## 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)

@@ -1,5 +1,6 @@+Cabal-version:        2.2 Name:                 clash-lib-Version:              1.0.1+Version:              1.2.0 Synopsis:             CAES Language for Synchronous Hardware - As a Library Description:   Clash is a functional hardware description language that borrows both its@@ -36,15 +37,15 @@   .   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:               The Clash Authors Maintainer:           QBayLogic B.V. <devops@qbaylogic.com>@@ -56,7 +57,7 @@  Extra-source-files:   README.md,-  CHANGELOG.md+  CHANGELOG.md,   src/ClashDebug.h  Data-files:@@ -66,11 +67,10 @@   prims/systemverilog/*.json,   prims/vhdl/*.json -Cabal-version:        >=1.10- source-repository head   type: git   location: https://github.com/clash-lang/clash-compiler.git+  subdir: clash-lib  flag debug    description:@@ -90,53 +90,79 @@   default: True   manual: True +common common-options+  default-language:   Haskell2010+  default-extensions: BangPatterns+                      BinaryLiterals+                      DataKinds+                      DefaultSignatures+                      DeriveDataTypeable+                      DeriveFoldable+                      DeriveFunctor+                      DeriveGeneric+                      DeriveLift+                      DeriveTraversable+                      DerivingStrategies+                      InstanceSigs+                      KindSignatures+                      ScopedTypeVariables+                      StandaloneDeriving+                      TupleSections+                      TypeApplications+                      TypeOperators+                      ViewPatterns++  if impl(ghc >= 8.6)+      default-extensions: NoStarIsType++ Library+  import:             common-options   HS-Source-Dirs:     src -  default-language:   Haskell2010   ghc-options:        -Wall   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.5,-                      ansi-terminal           >= 0.8.0.0  && < 0.10,+                      ansi-terminal           >= 0.8.0.0  && < 0.11,                       attoparsec              >= 0.10.4.0 && < 0.14,                       base                    >= 4.10     && < 5,                       binary                  >= 0.8.5    && < 0.11,                       bytestring              >= 0.10.0.2 && < 0.11,-                      clash-prelude           >= 1.0      && < 1.1,+                      clash-prelude           == 1.2.0,                       concurrent-supply       >= 0.1.7    && < 0.2,                       containers              >= 0.5.0.0  && < 0.7,                       data-binary-ieee754     >= 0.4.4    && < 0.6,+                      data-default            >= 0.7      && < 0.8,                       deepseq                 >= 1.3.0.2  && < 1.5,+                      dlist                   >= 0.8      && < 0.9,                       directory               >= 1.2.0.1  && < 1.4,                       errors                  >= 1.4.2    && < 2.4,                       exceptions              >= 0.8.3    && < 0.11.0,+                      extra                   >= 1.6.18   && < 1.7,                       filepath                >= 1.3.0.1  && < 1.5,-                      ghc                     >= 8.2.0    && < 8.9,+                      ghc                     >= 8.4.0    && < 8.9,+                      ghc-boot-th,                       hashable                >= 1.2.1.0  && < 1.4,+                      haskell-src-meta        >= 0.8      && < 0.9,                       hint                    >= 0.7      && < 0.10,                       integer-gmp             >= 1.0      && < 1.1,                       interpolate             >= 0.2.0    && < 1.0,-                      lens                    >= 3.9.2    && < 4.19,+                      lens                    >= 4.10     && < 4.20,                       mtl                     >= 2.1.2    && < 2.3,+                      ordered-containers      >= 0.2      && < 0.3,                       parsers                 >= 0.12.8   && < 1.0,                       prettyprinter           >= 1.2.0.1  && < 2.0,                       primitive               >= 0.5.0.1  && < 1.0,@@ -153,6 +179,8 @@                       vector-binary-instances >= 0.2.3.5  && < 0.3,                       unordered-containers    >= 0.2.3.3  && < 0.3 +  Autogen-Modules:    Paths_clash_lib+   Exposed-modules:    Clash.Annotations.BitRepresentation.ClashLib                        Clash.Backend@@ -162,12 +190,15 @@                        Clash.Core.DataCon                       Clash.Core.Evaluator+                      Clash.Core.Evaluator.Types                       Clash.Core.FreeVars                       Clash.Core.Literal                       Clash.Core.Name                       Clash.Core.Pretty                       Clash.Core.Subst                       Clash.Core.Term+                      Clash.Core.TermLiteral+                      Clash.Core.TermLiteral.TH                       Clash.Core.TyCon                       Clash.Core.Type                       Clash.Core.TysPrim@@ -202,6 +233,7 @@                       Clash.Primitives.GHC.Literal                       Clash.Primitives.GHC.Word                       Clash.Primitives.Intel.ClockGen+                      Clash.Primitives.Sized.ToInteger                       Clash.Primitives.Sized.Vector                        Clash.Rewrite.Combinators@@ -211,6 +243,7 @@                       Clash.Unique                       Clash.Util                       Clash.Util.Graph+                      Clash.Util.Interpolate                       Clash.Pretty                        Data.Text.Prettyprint.Doc.Extra@@ -218,6 +251,7 @@   Other-Modules:      Clash.Annotations.TopEntity.Extra                       Data.Aeson.Extra                       Data.Semigroup.Monad.Extra+                      Data.Set.Ordered.Extra                       Data.Vector.Primitive.Extra                       GHC.BasicTypes.Extra                       GHC.SrcLoc.Extra@@ -230,6 +264,7 @@     cpp-options:      -DHISTORY  test-suite unittests+  import:           common-options   type:             exitcode-stdio-1.0   default-language: Haskell2010   main-is:          unittests.hs@@ -252,3 +287,5 @@       tasty-hunit    Other-Modules: Clash.Tests.Core.FreeVars+                 Clash.Tests.Core.Subst+                 Clash.Tests.Util.Interpolate

@@ -2,6 +2,12 @@     { "name"      : "Clash.Intel.ClockGen.altpll"     , "workInfo"  : "Always"     , "kind"      : "Declaration"+    , "includes"  : [ {"extension": "qsys"+                      ,"name": "altpll"+                      ,"format": "Haskell"+                      ,"templateFunction": "Clash.Primitives.Intel.ClockGen.altpllQsysTF"+                      }+                    ]     , "format"    : "Haskell"     , "templateFunction" : "Clash.Primitives.Intel.ClockGen.altpllTF"     }@@ -10,6 +16,12 @@     { "name"      : "Clash.Intel.ClockGen.alteraPll"     , "workInfo"  : "Always"     , "kind"      : "Declaration"+    , "includes"  : [ {"extension": "qsys"+                      ,"name": "altera_pll"+                      ,"format": "Haskell"+                      ,"templateFunction": "Clash.Primitives.Intel.ClockGen.alteraPllQsysTF"+                      }+                    ]     , "format"    : "Haskell"     , "templateFunction" : "Clash.Primitives.Intel.ClockGen.alteraPllTF"     }

@@ -9,6 +9,21 @@     }   } , { "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"     }

@@ -22,4 +22,12 @@      , "template"  : "~ARG[2]"      }   }+, { "BlackBox" :+     { "name"      : "Clash.XException.hwSeqX"+     , "workInfo"  : "Never"+     , "kind"      : "Expression"+     , "type"      : "hwSeqX :: a -> b -> b"+     , "template"  : "~DEVNULL[~VAR[x][0]]~ARG[1]"+     }+  } ]

@@ -32,5 +32,12 @@       "template": "~ARG[0] - ~ARG[1]",       "warning": "GHC.Natural.minusNatural: Naturals are dynamically sized in simulation, but fixed-length after synthesization. Use carefully."     }+  },+  {+    "Primitive": {+      "name": "GHC.Natural.gcdNatural",+      "workInfo" : "Never",+      "primType": "Function"+    }   } ]

@@ -0,0 +1,127 @@+[ { "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" : "$finish_and_return(~LIT[0]);"+    }+  }+, { "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"+    , "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"+    , "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"+    , "template" : "~RESULT = $fseek(~ARG[0],~ARG[1],~ARG[2]);"+    }+  }+, { "BlackBox" :+    { "name"     : "Clash.Explicit.SimIO.rewind"+    , "kind"     : "Declaration"+    , "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"+    }+  }+]

@@ -88,7 +88,7 @@     , "workInfo"  : "Never"     , "kind"      : "Expression"     , "type"      : "fromInteger## :: Integer -> Integer -> Bit"-    , "template"  : "~ARG[0][0] ? 1'bx : ~ARG[1][0]"+    , "template"  : "~VAR[i][0][0] ? 1'bx : ~VAR[i][1][0]"     }   } , { "BlackBox" :@@ -161,12 +161,10 @@     , "template"  : "~IF~SIZE[~TYP[1]]~THEN~ARG[1] <= ~ARG[2]~ELSE1'b1~FI"     }   }-, { "BlackBox" :-    { "name"      : "Clash.Sized.Internal.BitVector.toInteger#"-    , "workInfo"  : "Never"-    , "kind"      : "Expression"-    , "type"      : "toInteger# :: KnownNat n => BitVector n -> Integer"-    , "template"  : "~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$signed(~VAR[bv][1][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[bv][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"+, { "BlackBoxHaskell" :+    { "name"             : "Clash.Sized.Internal.BitVector.toInteger#"+    , "workInfo"         : "Never"+    , "templateFunction" : "Clash.Primitives.Sized.ToInteger.bvToIntegerVerilog"     }   } , { "BlackBox" :

@@ -121,12 +121,10 @@     , "template"  : "~ARG[0] % ~ARG[1]"     }   }-, { "BlackBox" :+, { "BlackBoxHaskell" :     { "name"      : "Clash.Sized.Internal.Index.toInteger#"     , "workInfo"  : "Never"-    , "kind"      : "Expression"-    , "type"      : "toInteger# :: Index n -> Integer"-    , "template"  : "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$signed(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"+    , "templateFunction" : "Clash.Primitives.Sized.ToInteger.indexToIntegerVerilog"     }   } , { "BlackBox" :

@@ -40,12 +40,10 @@     , "template"  : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSE1'b1~FI"     }   }-, { "BlackBox" :+, { "BlackBoxHaskell" :     { "name"      : "Clash.Sized.Internal.Signed.toInteger#"     , "workInfo"  : "Never"-    , "kind"      : "Expression"-    , "type"      : "toInteger# :: Signed n -> Integer"-    , "template"  : "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$signed(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"+    , "templateFunction" : "Clash.Primitives.Sized.ToInteger.signedToIntegerVerilog"     }   } , { "BlackBox" :

@@ -40,12 +40,10 @@     , "template"  : "~IF~SIZE[~TYP[0]]~THEN~ARG[0] <= ~ARG[1]~ELSE1'b1~FI"     }   }-, { "BlackBox" :+, { "BlackBoxHaskell" :     { "name"      : "Clash.Sized.Internal.Unsigned.toInteger#"     , "workInfo"  : "Never"-    , "kind"      : "Expression"-    , "type"      : "toInteger# :: Unsigned n -> Integer"-    , "template"  : "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$signed(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI"+    , "templateFunction" : "Clash.Primitives.Sized.ToInteger.unsignedToIntegerVerilog"     }   } , { "BlackBox" :

@@ -1,6 +1,7 @@ [ { "BlackBox" :     { "name" : "Clash.Signal.BiSignal.writeToBiSignal#",       "kind" : "Declaration",+      "renderVoid": "RenderVoid",       "type" : "writeToBiSignal#   :: HasCallStack                   -- ARG[0]

@@ -10,18 +10,18 @@   -> a                        -- ARG[4]   -> Signal clk a             -- ARG[5]   -> Signal clk a"+    , "resultName" : { "template" : "~CTXNAME" }+    , "resultInit" : { "template" : "~IF~ISINITDEFINED[0]~THEN~CONST[4]~ELSE~FI" }     , "template" :-"// delay begin,-~TYPO ~GENSYM[~RESULT_reg][0] ~IF ~ISINITDEFINED[0] ~THEN = ~CONST[4] ~ELSE ~FI;~IF ~ISACTIVEENABLE[3] ~THEN+"// 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-    ~SYM[0] <= ~ARG[5];+    ~RESULT <= ~ARG[5];   end end~ELSE-always_ff @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~SYM[1]-  ~SYM[0] <= ~ARG[5];+always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~SYM[1]+  ~RESULT <= ~ARG[5]; end~FI-assign ~RESULT = ~SYM[0]; // delay end"     }   }@@ -39,17 +39,17 @@   -> a                        -- ARG[6] (reset value)   -> Signal clk a             -- ARG[7]   -> Signal clk a"+    , "resultName" : { "template" : "~CTXNAME" }+    , "resultInit" : { "template" : "~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI" }     , "template" : "// register begin-~TYPO ~GENSYM[~RESULT_reg][0] ~IF ~ISINITDEFINED[0] ~THEN = ~CONST[5] ~ELSE ~FI;-always_ff @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]~IF ~ISSYNC[0] ~THEN ~ELSE or ~IF ~ISACTIVEHIGH[0] ~THEN posedge ~ELSE negedge ~FI ~ARG[3]~FI) begin : ~GENSYM[~RESULT_register][1]-  if (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI~ARG[3]) begin-    ~SYM[0] <= ~CONST[6];+always_ff @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]~IF ~ISSYNC[0] ~THEN ~ELSE or ~IF ~ISACTIVEHIGH[0] ~THEN posedge ~ELSE negedge ~FI ~VAR[rst][3]~FI) begin : ~GENSYM[~RESULT_register][1]+  if (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI~VAR[rst][3]) begin+    ~RESULT <= ~CONST[6];   end else ~IF ~ISACTIVEENABLE[4] ~THEN if (~ARG[4]) ~ELSE ~FI begin-    ~SYM[0] <= ~ARG[7];+    ~RESULT <= ~ARG[7];   end end-assign ~RESULT = ~SYM[0]; // register end"     }   }

@@ -1,15 +1,27 @@ [ { "BlackBox" :     { "name"      : "Clash.Sized.Internal.Signed.div#"     , "kind"      : "Declaration"-    , "type"      : "div# :: KnownNat n => Signed n -> Signed n -> Signed n"+    , "type"      : "div# :: Signed n -> Signed n -> Signed n"     , "template"  : "// divSigned begin-// divide (rounds towards zero)-~SIGD[~GENSYM[quot_res][0]][1];-assign ~SYM[0] = ~VAR[dividend][1] / ~VAR[divider][2];+logic ~GENSYM[resultPos][1];+logic ~GENSYM[dividerNeg][2];+logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+logic signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6]; -// round toward minus infinity-assign ~RESULT = (~VAR[dividend][1][~LIT[0]-1] == ~VAR[divider][2][~LIT[0]-1]) ? ~SYM[0] : ~SYM[0] - ~LIT[0]'sd1;+assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                         : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                    : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++assign ~SYM[6] = ~SYM[3] / ~SYM[5];+assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]); // divSigned end"     }   }@@ -26,7 +38,7 @@ // 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]);+                 (~SYM[0] == ~SIZE[~TYPO]'sd0 ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modSigned end"     }   }

@@ -249,58 +249,6 @@     }   } , { "BlackBox" :-    { "name"      : "Clash.Sized.Vector.fold"-    , "workInfo"  : "Never"-    , "kind"      : "Declaration"-    , "type"      : "fold :: (a -> a -> a) -> Vec (n+1) a -> a"-    , "comment"   : "THIS ONLY WORKS FOR POWER OF TWO LENGTH VECTORS"-    , "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"-        }-      ]-    , "template" :-"// fold begin-// put flat input array into the first half of the intermediate array-~SIGDO[~GENSYM[intermediate][0]] [0:(2*~LENGTH[~TYP[1]])-2];-assign ~SYM[0][0:~LENGTH[~TYP[1]]-1] = ~ARG[1];--// calculate the depth of the tree-localparam ~GENSYM[levels][4] = $clog2(~LENGTH[~TYP[1]]);--// Create the tree of instantiated components-genvar ~GENSYM[d][5];-genvar ~GENSYM[i][6];-~GENERATE-if (~SYM[4] != 0) begin : ~GENSYM[make_tree][7]-  for (~SYM[5] = ~SYM[4]; ~SYM[5] > 0; ~SYM[5]=~SYM[5]-1) begin : tree_depth-    for (~SYM[6] = 0; ~SYM[6] < (2**(~SYM[5]-1)); ~SYM[6] = ~SYM[6]+1) begin : tree_depth_loop-    ~INST 0-      ~OUTPUT <= ~SYM[0][~INCLUDENAME[0](~SYM[4]+1,~SYM[5])+~SYM[6]]~ ~TYPO~-      ~INPUT  <= ~SYM[0][~INCLUDENAME[0](~SYM[4]+1,~SYM[5]+1)+(2*~SYM[6])]~ ~TYPO~-      ~INPUT  <= ~SYM[0][~INCLUDENAME[0](~SYM[4]+1,~SYM[5]+1)+(2*~SYM[6])+1]~ ~TYPO~-    ~INST-    end-  end-end-~ENDGENERATE--// The last element of the intermediate array holds the result-assign ~RESULT = ~SYM[0][(2*~LENGTH[~TYP[1]])-2];-// fold end"-    }-  }-, { "BlackBox" :     { "name"      : "Clash.Sized.Vector.index_int"     , "kind"      : "Expression"     , "type"      : "index_int :: KnownNat n => Vec n a -> Int -> a"

@@ -4,12 +4,24 @@     , "type"      : "divInt# :: Int# -> Int# -> Int#"     , "template"  : "// divInt# begin-// divide (rounds towards zero)-~SIGD[~GENSYM[quot_res][0]][0];-assign ~SYM[0] = ~VAR[dividend][0] / ~VAR[divider][1];+logic ~GENSYM[resultPos][1];+logic ~GENSYM[dividerNeg][2];+logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+logic signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6]; -// round toward minus infinity-assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ~SYM[0] - ~SIZE[~TYPO]'sd1;+assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                         : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                    : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++assign ~SYM[6] = ~SYM[3] / ~SYM[5];+assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]); // divInt# end"     }   }@@ -26,7 +38,7 @@ // 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]);+                 ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modInt# end"     }   }

@@ -4,12 +4,24 @@     , "type"      : "divInteger :: Integer -> Integer -> Integer"     , "template"  : "// divInteger begin-// divide (rounds towards zero)-~SIGD[~GENSYM[quot_res][0]][0];-assign ~SYM[0] = ~VAR[dividend][0] / ~VAR[divider][1];+logic ~GENSYM[resultPos][1];+logic ~GENSYM[dividerNeg][2];+logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+logic signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+logic signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6]; -// round toward minus infinity-assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ~SYM[0] - ~SIZE[~TYPO]'sd1;+assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                         : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                    : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++assign ~SYM[6] = ~SYM[3] / ~SYM[5];+assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]); // divInteger end"     }   }@@ -26,8 +38,60 @@ // 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]);+                 ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modInteger end"+    }+  }+, { "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"+    }+  }+, { "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"     }   } ]

@@ -331,7 +331,7 @@     , "template" : "// clz8 begin logic [0:7] ~GENSYM[v][1];-assign ~SYM[1] = ~ARG[0][7:0];+assign ~SYM[1] = ~VAR[i][0][7:0];  logic [0:7] ~GENSYM[e][2]; genvar ~GENSYM[n][3];@@ -399,7 +399,7 @@     , "template" : "// clz16 begin logic [0:15] ~GENSYM[v][1];-assign ~SYM[1] = ~ARG[0][15:0];+assign ~SYM[1] = ~VAR[i][0][15:0];  logic [0:15] ~GENSYM[e][2]; genvar ~GENSYM[i][3];@@ -483,7 +483,7 @@     , "template" : "// clz32 begin logic [0:31] ~GENSYM[v][1];-assign ~SYM[1] = ~ARG[0][31:0];+assign ~SYM[1] = ~VAR[i][0][31:0];  logic [0:31] ~GENSYM[e][2]; genvar ~GENSYM[i][3];@@ -583,7 +583,7 @@     , "template" : "// clz64 begin logic [0:63] ~GENSYM[v][1];-assign ~SYM[1] = ~ARG[0][63:0];+assign ~SYM[1] = ~VAR[i][0][63:0];  logic [0:63] ~GENSYM[e][2]; genvar ~GENSYM[i][3];@@ -700,7 +700,7 @@ "// clz begin ~IF ~IW64 ~THEN logic [0:63] ~GENSYM[v][1];-assign ~SYM[1] = ~ARG[0][63:0];+assign ~SYM[1] = ~VAR[i][0][63:0];  logic [0:63] ~GENSYM[e][2]; genvar ~GENSYM[i][3];@@ -790,7 +790,7 @@ ~ENDGENERATE ~ELSE logic [0:31] ~SYM[1];-assign ~SYM[1] = ~ARG[0][31:0];+assign ~SYM[1] = ~VAR[i][0][31:0];  logic [0:31] ~SYM[2]; genvar ~SYM[3];

@@ -1,6 +1,7 @@ [ { "BlackBox" :     { "name" : "Clash.Signal.BiSignal.writeToBiSignal#",       "kind" : "Declaration",+      "renderVoid": "RenderVoid",       "type" : "writeToBiSignal#   :: HasCallStack                   -- ARG[0]

@@ -10,18 +10,19 @@   -> a                        -- ARG[4]   -> Signal clk a             -- ARG[5]   -> Signal clk a"+    , "outputReg" : true+    , "resultName" : { "template" : "~CTXNAME" }+    , "resultInit" : { "template" : "~IF~ISINITDEFINED[0]~THEN~CONST[4]~ELSE~FI" }     , "template" :-"// delay begin,-reg ~TYPO ~GENSYM[~RESULT_reg][0] ~IF ~ISINITDEFINED[0] ~THEN = ~CONST[4] ~ELSE ~FI;~IF ~ISACTIVEENABLE[3] ~THEN+"// 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-    ~SYM[0] <= ~ARG[5];+    ~RESULT <= ~ARG[5];   end end~ELSE always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]) begin : ~SYM[1]-  ~SYM[0] <= ~ARG[5];+  ~RESULT <= ~ARG[5]; end~FI-assign ~RESULT = ~SYM[0]; // delay end"     }   }@@ -39,17 +40,18 @@   -> a                        -- ARG[6] (reset value)   -> Signal clk a             -- ARG[7]   -> Signal clk a"+    , "outputReg" : true+    , "resultName" : { "template" : "~CTXNAME" }+    , "resultInit" : { "template" : "~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI" }     , "template" : "// register begin-reg ~TYPO ~GENSYM[~RESULT_reg][0] ~IF ~ISINITDEFINED[0] ~THEN = ~CONST[5] ~ELSE ~FI;-always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]~IF ~ISSYNC[0] ~THEN ~ELSE or ~IF ~ISACTIVEHIGH[0] ~THEN posedge ~ELSE negedge ~FI ~ARG[3]~FI) begin : ~GENSYM[~RESULT_register][1]-  if (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI~ARG[3]) begin-    ~SYM[0] <= ~CONST[6];+always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[2]~IF ~ISSYNC[0] ~THEN ~ELSE or ~IF ~ISACTIVEHIGH[0] ~THEN posedge ~ELSE negedge ~FI ~VAR[rst][3]~FI) begin : ~GENSYM[~RESULT_register][1]+  if (~IF ~ISACTIVEHIGH[0] ~THEN ~ELSE ! ~FI~VAR[rst][3]) begin+    ~RESULT <= ~CONST[6];   end else ~IF ~ISACTIVEENABLE[4] ~THEN if (~ARG[4]) ~ELSE ~FI begin-    ~SYM[0] <= ~ARG[7];+    ~RESULT <= ~ARG[7];   end end-assign ~RESULT = ~SYM[0]; // register end"     }   }@@ -69,7 +71,8 @@ // 1 = 0.1ps localparam ~GENSYM[half_period][1] = (~PERIOD[0]0 / 2); always begin-  ~SYM[0] = ~IF~ACTIVEEDGE[Rising][0]~THEN 0 ~ELSE 1 ~FI;+  // 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;   #30000 forever begin     ~SYM[0] = ~ ~SYM[0];     #~SYM[1];@@ -99,7 +102,8 @@ // 1 = 0.1ps localparam ~GENSYM[half_period][1] = (~PERIOD[0]0 / 2); always begin-  ~SYM[0] = ~IF~ACTIVEEDGE[Rising][0]~THEN 0 ~ELSE 1 ~FI;+  // 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;   #30000 forever begin     if (~ ~ARG[1]) begin       $finish;

@@ -4,12 +4,24 @@     , "type"      : "div# :: Signed n -> Signed n -> Signed n"     , "template"  : "// divSigned begin-// divide (rounds towards zero)-wire ~SIGD[~GENSYM[quot_res][0]][1];-assign ~SYM[0] = ~VAR[dividend][1] / ~VAR[divider][2];+wire ~GENSYM[resultPos][1];+wire ~GENSYM[dividerNeg][2];+wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+wire signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6]; -// round toward minus infinity-assign ~RESULT = (~VAR[dividend][1][~LIT[0]-1] == ~VAR[divider][2][~LIT[0]-1]) ? ~SYM[0] : ~SYM[0] - ~LIT[0]'sd1;+assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                         : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                    : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++assign ~SYM[6] = ~SYM[3] / ~SYM[5];+assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]); // divSigned end"     }   }@@ -20,13 +32,13 @@     , "template"  : "// modSigned begin // remainder-~SIGD[~GENSYM[rem_res][0]][0];+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]);+                 (~SYM[0] == ~SIZE[~TYPO]'sd0 ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modSigned end"     }   }

@@ -233,81 +233,6 @@ ~FI// foldr end"     }   }-, { "BlackBox" :-    { "name"      : "Clash.Sized.Vector.fold"-    , "workInfo"  : "Never"-    , "kind"      : "Declaration"-    , "type"      : "fold :: (a -> a -> a) -> Vec (n+1) a -> a"-    , "comment"   : "THIS ONLY WORKS FOR POWER OF TWO LENGTH VECTORS"-    , "imports"   : ["~INCLUDENAME[0].inc"]-    , "includes" :-      [ { "name" : "fold"-        , "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"-        }-      ]-    , "template" :-"// fold begin-// put flat input array into the first half of the intermediate array-wire ~TYPO ~GENSYM[intermediate][0] [0:(2*~LENGTH[~TYP[1]])-2];--genvar ~GENSYM[i][2];-~GENERATE-for (~SYM[2]=0; ~SYM[2] < ~LENGTH[~TYP[1]]; ~SYM[2]=~SYM[2]+1) begin : ~GENSYM[mk_array][3]-  assign ~SYM[0][(~LENGTH[~TYP[1]]-1)-~SYM[2]] = ~VAR[vecflat][1][~SYM[2]*~SIZE[~TYPO]+:~SIZE[~TYPO]];-end-~ENDGENERATE--// calculate the depth of the tree-localparam ~GENSYM[levels][4] = ~INCLUDENAME[0]_clog2(~LENGTH[~TYP[1]]);--// Create the tree of instantiated components-genvar ~GENSYM[d][5];-genvar ~GENSYM[i][6];-~GENERATE-if (~SYM[4] != 0) begin : ~GENSYM[make_tree][7]-  for (~SYM[5] = ~SYM[4]; ~SYM[5] > 0; ~SYM[5]=~SYM[5]-1) begin : ~GENSYM[tree_depth][11]-    for (~SYM[6] = 0; ~SYM[6] < (2**(~SYM[5]-1)); ~SYM[6] = ~SYM[6]+1) begin : ~GENSYM[tree_depth_loop][12]-      wire ~TYPO ~GENSYM[fold_in1][8];-      wire ~TYPO ~GENSYM[fold_in2][9];-      ~OUTPUTWIREREG[0] ~TYPO ~GENSYM[fold_out][10];--      assign ~SYM[8] = ~SYM[0][~INCLUDENAME[0]_depth2Index(~SYM[4]+1,~SYM[5]+1)+(2*~SYM[6])];-      assign ~SYM[9] = ~SYM[0][~INCLUDENAME[0]_depth2Index(~SYM[4]+1,~SYM[5]+1)+(2*~SYM[6])+1];-    ~INST 0-      ~OUTPUT <= ~SYM[10]~ ~TYPO~-      ~INPUT  <= ~SYM[8]~ ~TYPO~-      ~INPUT  <= ~SYM[9]~ ~TYPO~-    ~INST-      assign ~SYM[0][~INCLUDENAME[0]_depth2Index(~SYM[4]+1,~SYM[5])+~SYM[6]] = ~SYM[10];-    end-  end-end-~ENDGENERATE--// The last element of the intermediate array holds the result-assign ~RESULT = ~SYM[0][(2*~LENGTH[~TYP[1]])-2];-// fold end"-    }-  } , { "BlackBoxHaskell" :     { "name"             : "Clash.Sized.Vector.index_int"     , "templateFunction" : "Clash.Primitives.Sized.Vector.indexIntVerilog"

@@ -4,12 +4,24 @@     , "type"      : "divInt# :: Int# -> Int# -> Int#"     , "template"  : "// divInt# begin-// divide (rounds towards zero)-wire ~SIGD[~GENSYM[quot_res][0]][0];-assign ~SYM[0] = ~VAR[dividend][0] / ~VAR[divider][1];+wire ~GENSYM[resultPos][1];+wire ~GENSYM[dividerNeg][2];+wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+wire signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6]; -// round toward minus infinity-assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ~SYM[0] - ~SIZE[~TYPO]'sd1;+assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                         : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                    : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++assign ~SYM[6] = ~SYM[3] / ~SYM[5];+assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]); // divInt# end"     }   }@@ -26,7 +38,7 @@ // 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]);+                 ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modInt# end"     }   }

@@ -4,12 +4,24 @@     , "type"      : "divInteger :: Integer -> Integer -> Integer"     , "template"  : "// divInteger begin-// divide (rounds towards zero)-wire ~SIGD[~GENSYM[quot_res][0]][0];-assign ~SYM[0] = ~VAR[dividend][0] / ~VAR[divider][1];+wire ~GENSYM[resultPos][1];+wire ~GENSYM[dividerNeg][2];+wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividend2][3];+wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividendE][4];+wire signed [~SIZE[~TYPO]:0] ~GENSYM[dividerE][5];+wire signed [~SIZE[~TYPO]:0] ~GENSYM[quot_res][6]; -// round toward minus infinity-assign ~RESULT = (~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1]) ? ~SYM[0] : ~SYM[0] - ~SIZE[~TYPO]'sd1;+assign ~SYM[1] = ~VAR[dividend][0][~SIZE[~TYPO]-1] == ~VAR[divider][1][~SIZE[~TYPO]-1];+assign ~SYM[2] = ~VAR[divider][1][~SIZE[~TYPO]-1] == 1'b1;+assign ~SYM[4] = $signed({{~VAR[dividend][0][~SIZE[~TYPO]-1]},~VAR[dividend][0]});  // sign extension+assign ~SYM[5] = $signed({{~VAR[divider][1][~SIZE[~TYPO]-1]} ,~VAR[divider][1]} );  // sign extension++assign ~SYM[3] = ~SYM[1] ? ~SYM[4]+                         : (~SYM[2] ? (~SYM[4] - ~SYM[5] - ~SIZE[~TYPO]'sd1)+                                    : (~SYM[4] - ~SYM[5] + ~SIZE[~TYPO]'sd1));++assign ~SYM[6] = ~SYM[3] / ~SYM[5];+assign ~RESULT = $signed(~SYM[6][~SIZE[~TYPO]-1:0]); // divInteger end"     }   }@@ -26,8 +38,62 @@ // 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]);+                 ((~SYM[0] == ~SIZE[~TYPO]'sd0) ? ~SIZE[~TYPO]'sd0 : ~SYM[0] + ~VAR[divider][1]); // modInteger end"+    }+  }+, { "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"+    }+  }+, { "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"     }   } ]

@@ -381,7 +381,7 @@     , "template" : "// clz8 begin wire [0:7] ~GENSYM[v][1];-assign ~SYM[1] = ~ARG[0][7:0];+assign ~SYM[1] = ~VAR[i][0][7:0];  wire [0:7] ~GENSYM[e][2]; genvar ~GENSYM[n][3];@@ -449,7 +449,7 @@     , "template" : "// clz16 begin wire [0:15] ~GENSYM[v][1];-assign ~SYM[1] = ~ARG[0][15:0];+assign ~SYM[1] = ~VAR[i][0][15:0];  wire [0:15] ~GENSYM[e][2]; genvar ~GENSYM[i][3];@@ -533,7 +533,7 @@     , "template" : "// clz32 begin wire [0:31] ~GENSYM[v][1];-assign ~SYM[1] = ~ARG[0][31:0];+assign ~SYM[1] = ~VAR[i][0][31:0];  wire [0:31] ~GENSYM[e][2]; genvar ~GENSYM[i][3];@@ -633,7 +633,7 @@     , "template" : "// clz64 begin wire [0:63] ~GENSYM[v][1];-assign ~SYM[1] = ~ARG[0][63:0];+assign ~SYM[1] = ~VAR[i][0][63:0];  wire [0:63] ~GENSYM[e][2]; genvar ~GENSYM[i][3];@@ -749,7 +749,7 @@     , "template" : "// clz begin~IF ~IW64 ~THEN wire [0:63] ~GENSYM[v][1];-assign ~SYM[1] = ~ARG[0][63:0];+assign ~SYM[1] = ~VAR[i][0][63:0];  wire [0:63] ~GENSYM[e][2]; genvar ~GENSYM[i][3];@@ -839,7 +839,7 @@ ~ENDGENERATE ~ELSE wire [0:31] ~SYM[1];-assign ~SYM[1] = ~ARG[0][31:0];+assign ~SYM[1] = ~VAR[i][0][31:0];  wire [0:31] ~SYM[2]; genvar ~SYM[3];

@@ -39,11 +39,7 @@       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]))-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;+      ~RESULT <= fromSLV(~SYM[2](~SYM[4]));     end if;   end process; ~ELSE   ~SYM[6] : process(~ARG[3])@@ -52,11 +48,7 @@       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])-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;+      ~RESULT <= ~SYM[2](~SYM[4]);     end if;   end process; ~FI end block;@@ -105,11 +97,7 @@       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]))-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;+      ~RESULT <= fromSLV(~SYM[2](~SYM[4]));     end if;   end process; ~ELSE   ~SYM[6] : process(~ARG[3])@@ -118,11 +106,7 @@       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])-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;+      ~RESULT <= ~SYM[2](~SYM[4]);     end if;   end process; ~FI end block;@@ -172,11 +156,7 @@       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]))-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;+      ~RESULT <= fromSLV(~SYM[2](~SYM[4]));     end if;   end process; ~ELSE   ~SYM[6] : process(~ARG[3])@@ -185,11 +165,7 @@       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])-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;+      ~RESULT <= ~SYM[2](~SYM[4]);     end if;   end process; ~FI end block;

@@ -55,11 +55,7 @@         if ~ARG[8] then           ~SYM[3](~SYM[6]) <= to_bitvector(~ARG[10]);         end if;-        ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5]))-        -- pragma translate_off-        after 1 ps-        -- pragma translate_on-        ;+        ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5]));       end if;     end if;   end process;~ELSE@@ -69,11 +65,7 @@       if ~ARG[8] then         ~SYM[3](~SYM[6]) <= to_bitvector(~ARG[10]);       end if;-      ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5]))-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;+      ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5]));     end if;   end process;~FI ~ELSE ~IF ~ISACTIVEENABLE[4] ~THEN   ~SYM[10] : process(~ARG[3])@@ -83,11 +75,7 @@         ~SYM[3](~SYM[6]) <= to_bitvector(~ARG[10]);       end if;       if ~ARG[4] then-        ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5]))-        -- pragma translate_off-        after 1 ps-        -- pragma translate_on-        ;+        ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5]));       end if;     end if;   end process;~ELSE@@ -97,11 +85,7 @@       if ~ARG[8] then         ~SYM[3](~SYM[6]) <= to_bitvector(~ARG[10]);       end if;-      ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5]))-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;+      ~RESULT <= to_stdlogicvector(~SYM[3](~SYM[5]));     end if;   end process;~FI ~FI end block;

@@ -26,16 +26,8 @@   ~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]-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;~ELSE-      ~RESULT <= ~SYM[2](~SYM[3])-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;~FI+      ~RESULT <= ~FROMBV[~SYM[2](~SYM[3])][~TYPO];~ELSE+      ~RESULT <= ~SYM[2](~SYM[3]);~FI     end if;   end process; end block;

@@ -40,22 +40,14 @@   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]))-        -- pragma translate_off-        after 1 ps-        -- pragma translate_on-        ;+        ~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]))-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;+      ~RESULT <= to_stdlogicvector(~SYM[2](~SYM[3]));     end if;   end process;~FI end block;

@@ -0,0 +1,31 @@+[ { "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"+    }+  }+]

@@ -1,6 +1,7 @@ [ { "BlackBox" :     { "name" : "Clash.Signal.BiSignal.writeToBiSignal#",       "kind" : "Declaration",+      "renderVoid": "RenderVoid",       "type" : "writeToBiSignal#   :: HasCallStack                   -- ARG[0]

@@ -10,40 +10,24 @@   -> a                        -- ARG[4]   -> Signal clk a             -- ARG[5]   -> Signal clk a"+    , "resultName" : { "template" : "~CTXNAME" }+    , "resultInit" : { "template" : "~IF~ISINITDEFINED[0]~THEN~CONST[4]~ELSE~FI" }     , "template" : "-- delay begin~IF ~ISACTIVEENABLE[3] ~THEN-~GENSYM[~RESULT_delay][0] : block-  signal ~GENSYM[~RESULT_reg][1]   : ~TYPO ~IF ~ISINITDEFINED[0] ~THEN := ~CONST[4] ~ELSE ~FI;+~GENSYM[~RESULT_delay][4] : process(~ARG[2]) begin-  ~RESULT <= ~SYM[1];-  ~GENSYM[~RESULT_dly][4] : process(~ARG[2])-  begin-    if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then-      if ~ARG[3] then-        ~SYM[1] <= ~ARG[5]-        -- pragma translate_off-        after 1 ps-        -- pragma translate_on-        ;-      end if;+  if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then+    if ~ARG[3] then+      ~RESULT <= ~ARG[5];     end if;-  end process;-end block;~ELSE-~SYM[0] : block-  signal ~SYM[1] : ~TYPO := ~CONST[4];+  end if;+end process;~ELSE+~SYM[4] : process(~ARG[2]) begin-  ~RESULT <= ~SYM[1];-  ~SYM[4] : process(~ARG[2])-  begin-    if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then-      ~SYM[1] <= ~ARG[5]-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;-    end if;-  end process;-end block;~FI+  if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then+    ~RESULT <= ~ARG[5];+  end if;+end process;~FI -- delay end"     }   }@@ -61,84 +45,48 @@   -> a                        -- ARG[6] (reset value)   -> Signal clk a             -- ARG[7]   -> Signal clk a"+    , "resultName" : { "template" : "~CTXNAME" }+    , "resultInit" : { "template" : "~IF~ISINITDEFINED[0]~THEN~CONST[5]~ELSE~FI" }     , "template" :-"-- register begin~IF ~ISACTIVEENABLE[4] ~THEN-~GENSYM[~COMPNAME_register][0] : block-  signal ~GENSYM[~RESULT_reg][1] : ~TYPO ~IF ~ISINITDEFINED[0] ~THEN := ~CONST[5] ~ELSE ~FI;+"-- register begin~IF ~ISACTIVEENABLE[4] ~THEN ~IF ~ISSYNC[0] ~THEN+~GENSYM[~RESULT_register][2] : process(~ARG[2]) begin-  ~RESULT <= ~SYM[1]; ~IF ~ISSYNC[0] ~THEN-  ~GENSYM[~RESULT_r][2] : process(~ARG[2])-  begin-    if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then-      if ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then-        ~SYM[1] <= ~CONST[6]-        -- pragma translate_off-        after 1 ps-        -- pragma translate_on-        ;-      elsif ~ARG[4] then-        ~SYM[1] <= ~ARG[7]-        -- pragma translate_off-        after 1 ps-        -- pragma translate_on-        ;-      end if;-    end if;-  end process;~ELSE-  ~SYM[2] : process(~ARG[2],~ARG[3])-  begin+  if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then     if ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then-      ~SYM[1] <= ~CONST[6];-    elsif ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then-      if ~ARG[4] then-        ~SYM[1] <= ~ARG[7]-        -- pragma translate_off-        after 1 ps-        -- pragma translate_on-        ;-      end if;+      ~RESULT <= ~CONST[6];+    elsif ~ARG[4] then+      ~RESULT <= ~ARG[7];     end if;-  end process;~FI-end block;~ELSE-~SYM[0] : block-  signal ~SYM[1] : ~TYPO := ~CONST[5];+  end if;+end process;~ELSE+~SYM[2] : process(~ARG[2],~ARG[3]) begin-  ~RESULT <= ~SYM[1]; ~IF ~ISSYNC[0] ~THEN-  ~SYM[2] : process(~ARG[2])-  begin-    if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then-      if ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then-        ~SYM[1] <= ~CONST[6]-        -- pragma translate_off-        after 1 ps-        -- pragma translate_on-        ;-      else-        ~SYM[1] <= ~ARG[7]-        -- pragma translate_off-        after 1 ps-        -- pragma translate_on-        ;-      end if;+  if ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then+    ~RESULT <= ~CONST[6];+  elsif ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then+    if ~ARG[4] then+      ~RESULT <= ~ARG[7];     end if;-  end process;~ELSE-  ~SYM[2] : process(~ARG[2],~ARG[3])-  begin+  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 ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then-      ~SYM[1] <= ~CONST[6]-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;-    elsif ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then-      ~SYM[1] <= ~ARG[7]-      -- pragma translate_off-      after 1 ps-      -- pragma translate_on-      ;+      ~RESULT <= ~CONST[6];+    else+      ~RESULT <= ~ARG[7];     end if;-  end process;~FI-end block;~FI+  end if;+end process;~ELSE+~SYM[2] : process(~ARG[2],~ARG[3])+begin+  if ~ARG[3] = ~IF ~ISACTIVEHIGH[0] ~THEN '1' ~ELSE '0' ~FI then+    ~RESULT <= ~CONST[6];+  elsif ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[2]) then+    ~RESULT <= ~ARG[7];+  end if;+end process;~FI~FI -- register end"     }   }

@@ -491,12 +491,10 @@     , "template"  : "std_logic_vector(unsigned(~ARG[1]) rem unsigned(~ARG[2]))"     }   }-, { "BlackBox" :+, { "BlackBoxHaskell" :     { "name"      : "Clash.Sized.Internal.BitVector.toInteger#"     , "workInfo"  : "Never"-    , "kind"      : "Expression"-    , "type"      : "toInteger# :: KnownNat n => BitVector n -> Integer"-    , "template"  : "~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(unsigned(~ARG[1]),~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"+    , "templateFunction" : "Clash.Primitives.Sized.ToInteger.bvToIntegerVHDL"     }   } , { "BlackBox" :

@@ -121,12 +121,10 @@     , "template"  : "~ARG[0] rem ~ARG[1]"     }   }-, { "BlackBox" :+, { "BlackBoxHaskell" :     { "name"      : "Clash.Sized.Internal.Index.toInteger#"     , "workInfo"  : "Never"-    , "kind"      : "Expression"-    , "type"      : "toInteger# :: Index n -> Integer"-    , "template"  : "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"+    , "templateFunction" : "Clash.Primitives.Sized.ToInteger.indexToIntegerVHDL"     }   } , { "BlackBox" :

@@ -146,11 +146,18 @@     , "template"  : "-- divSigned begin ~GENSYM[divSigned][0] : block-  signal ~GENSYM[quot_res][3] : ~TYP[0];+  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[3] <= ~ARG[0] / ~ARG[1];-  ~RESULT <= ~SYM[3] - to_signed(1,~SIZE[~TYPO]) when ~VAR[dividend][0](~VAR[dividend][0]'high) = not (~VAR[divider][1](~VAR[divider][1]'high)) else-             ~SYM[3];+  ~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];+  ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0)); end block; -- divSigned end"     }@@ -162,12 +169,10 @@     , "template"  : "~ARG[0] mod ~ARG[1]"     }   }-, { "BlackBox" :+, { "BlackBoxHaskell" :     { "name"      : "Clash.Sized.Internal.Signed.toInteger#"     , "workInfo"  : "Never"-    , "kind"      : "Expression"-    , "type"      : "toInteger# :: Signed n -> Integer"-    , "template"  : "~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEto_signed(0,64)~FI"+    , "templateFunction" : "Clash.Primitives.Sized.ToInteger.signedToIntegerVHDL"     }   } , { "BlackBox" :

@@ -130,12 +130,10 @@     , "template"  : "~ARG[0] rem ~ARG[1]"     }   }-, { "BlackBox" :+, { "BlackBoxHaskell" :     { "name"      : "Clash.Sized.Internal.Unsigned.toInteger#"     , "workInfo"  : "Never"-    , "kind"      : "Expression"-    , "type"      : "toInteger# :: Unsigned n -> Integer"-    , "template"  : "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI"+    , "templateFunction" : "Clash.Primitives.Sized.ToInteger.unsignedToIntegerVHDL"     }   } , { "BlackBox" :

@@ -266,52 +266,6 @@     }   } , { "BlackBox" :-    { "name"      : "Clash.Sized.Vector.fold"-    , "workInfo"  : "Never"-    , "kind"      : "Declaration"-    , "type"      : "fold :: (a -> a -> a) -> Vec (n+1) a -> a"-    , "comment"   : "THIS ONLY WORKS FOR POWER OF TWO LENGTH VECTORS"-    , "template"  :-"-- fold begin-~GENSYM[fold][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;-~IF ~VIVADO ~THEN-  type ~GENSYM[fold_res_type][2] is array(natural range <>) of ~TYPO;-  signal ~GENSYM[intermediate][3] : ~SYM[2](0 to (2*~LENGTH[~TYP[1]])-2);~ELSE-  signal ~SYM[3] : ~TYPM[1](0 to (2*~LENGTH[~TYP[1]])-2);~FI-  constant ~GENSYM[levels][5] : natural := natural (ceil (log2 (real (~LENGTH[~TYP[1]]))));-begin-  -- put input array into the first half of the intermediate array~IF ~VIVADO ~THEN-  ~SYM[6] : for ~SYM[7] in 0 to (~LENGTH[~TYP[1]] - 1) generate-    ~SYM[3](~SYM[7]) <= fromSLV(~VAR[vec][1](~SYM[7]));-  end generate;~ELSE-  ~SYM[3](0 to ~LENGTH[~TYP[1]]-1) <= ~VAR[vec][1];~FI--  -- Create the tree of instantiated components-  ~GENSYM[make_tree][8] : if ~SYM[5] /= 0 generate-    ~GENSYM[tree_depth][9] : for ~GENSYM[d][10] in ~SYM[5]-1 downto 0 generate-      ~GENSYM[tree_depth_loop][11] : for ~GENSYM[i][12] in 0 to (natural(2**~SYM[10]) - 1) generate-        ~INST 0-          ~OUTPUT <= ~SYM[3](~SYM[1](~SYM[5]+1,~SYM[10]+1)+~SYM[12])~ ~TYPO~-          ~INPUT  <= ~SYM[3](~SYM[1](~SYM[5]+1,~SYM[10]+2)+(2*~SYM[12]))~ ~TYPO~-          ~INPUT  <= ~SYM[3](~SYM[1](~SYM[5]+1,~SYM[10]+2)+(2*~SYM[12])+1)~ ~TYPO~-        ~INST-      end generate;-    end generate;-  end generate;--  -- The last element of the intermediate array holds the result-  ~RESULT <= ~SYM[3]((2*~LENGTH[~TYP[1]])-2);-end block;--- fold end"-    }-  }-, { "BlackBox" :     { "name"      : "Clash.Sized.Vector.index_int"     , "kind"      : "Declaration"     , "type"      : "index_int :: KnownNat n => Vec n a -> Int -> a"

@@ -38,15 +38,22 @@     , "kind"      : "Declaration"     , "type"      : "divInt# :: Int# -> Int# -> Int#"     , "template"  :-"-- divInt begin+"-- divInt# begin ~GENSYM[divInt][0] : block-  signal ~GENSYM[quot_res][1] : ~TYP[1];+  signal ~GENSYM[resultPos][1] : boolean;+  signal ~GENSYM[dividerNeg][2] : boolean;+  signal ~GENSYM[dividend2][3] : signed(~SIZE[~TYPO] downto 0);+  signal ~GENSYM[quot_res][4] : signed(~SIZE[~TYPO] downto 0); begin-  ~SYM[1] <= ~ARG[0] / ~ARG[1];-  ~RESULT <= ~SYM[1] - 1 when ((~ARG[0] = abs ~ARG[0]) /= (~ARG[1] = abs ~ARG[1])) else-             ~SYM[1];+  ~SYM[1] <= ~VAR[dividend][0](~VAR[dividend][0]'high) = ~VAR[divider][1](~VAR[divider][1]'high);+  ~SYM[2] <= ~VAR[divider][1](~VAR[divider][1]'high) = '1';+  ~SYM[3] <= resize(~VAR[dividend][0],~SIZE[~TYPO]+1)   when ~SYM[1] else+             (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) - 1)   when ~SYM[2] else+             (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) + 1);+  ~SYM[4] <= ~SYM[3] / ~VAR[divider][1];+  ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0)); end block;--- divInt end"+-- divInt# end"     }   } , { "BlackBox" :

@@ -42,11 +42,18 @@     , "template"   : "-- divInteger begin ~GENSYM[divInteger][0] : block-  signal ~GENSYM[quot_res][1] : ~TYP[1];+  signal ~GENSYM[resultPos][1] : boolean;+  signal ~GENSYM[dividerNeg][2] : boolean;+  signal ~GENSYM[dividend2][3] : signed(~SIZE[~TYPO] downto 0);+  signal ~GENSYM[quot_res][4] : signed(~SIZE[~TYPO] downto 0); begin-  ~SYM[1] <= ~ARG[0] / ~ARG[1];-  ~RESULT <= ~SYM[1] - 1 when ((~ARG[0] = abs ~ARG[0]) /= (~ARG[1] = abs ~ARG[1])) else-             ~SYM[1];+  ~SYM[1] <= ~VAR[dividend][0](~VAR[dividend][0]'high) = ~VAR[divider][1](~VAR[divider][1]'high);+  ~SYM[2] <= ~VAR[divider][1](~VAR[divider][1]'high) = '1';+  ~SYM[3] <= resize(~VAR[dividend][0],~SIZE[~TYPO]+1)   when ~SYM[1] else+             (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) - 1)   when ~SYM[2] else+             (resize(~VAR[dividend][0],~SIZE[~TYPO]+1) - resize(~VAR[divider][1],~SIZE[~TYPO]+1) + 1);+  ~SYM[4] <= ~SYM[3] / ~VAR[divider][1];+  ~RESULT <= signed(~SYM[4](~SIZE[~TYPO]-1 downto 0)); end block; -- divInteger end"     }@@ -56,6 +63,38 @@     , "kind"      : "Expression"     , "type"      : "modInteger :: Integer -> Integer -> Integer"     , "template"  : "~ARG[0] mod ~ARG[1]"+    }+  }+, { "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);+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];+  ~SYM[5] <= signed(~SYM[4](~SIZE[~TYP[0]]-1 downto 0));+  ~RESULT <= (~SYM[5], ~VAR[dividend][0] mod ~VAR[divider][1]);+end block;+-- divModInteger end"+    }+  }+, { "BlackBox" :+    { "name"      : "GHC.Integer.Type.quotRemInteger"+    , "kind"      : "Expression"+    , "type"      : "quotRemInteger :: Integer -> Integer -> (# Integer, Integer #)"+    , "template"  : "(~ARG[0] / ~ARG[1], ~ARG[0] rem ~ARG[1])"     }   } , { "BlackBox" :

@@ -549,7 +549,7 @@     , "type"      : "clz16 :: Word# -> Word#"     , "template"  : "-- clz16 begin-clz16~SYM[0] : block+~GENSYM[clz16][0] : block   function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is   begin     case a is@@ -594,7 +594,7 @@     , "type"      : "clz32 :: Word# -> Word#"     , "template"  : "-- clz32 begin-clz32~SYM[0] : block+~GENSYM[clz32][0] : block   function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is   begin     case a is@@ -641,7 +641,7 @@     , "type"      : "clz64 :: Word# -> Word#"     , "template"  : "-- clz64 begin-clz64~SYM[0] : block+~GENSYM[clz64][0] : block   function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is   begin     case a is@@ -690,7 +690,7 @@     , "type"      : "clz :: Word# -> Word#"     , "template"  : "-- clz begin-clz~SYM[0] : block+~GENSYM[clz][0] : block   function ~GENSYM[enc][1] (constant a : unsigned(1 downto 0)) return unsigned is   begin     case a is

@@ -9,12 +9,14 @@ 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 @@ -25,6 +27,7 @@ instance Binary NameSpace instance Binary PkgName +instance Hashable TopEntityT instance Hashable TopEntity instance Hashable PortName @@ -35,6 +38,7 @@ instance Hashable PkgName instance Hashable OccName +instance NFData TopEntityT instance NFData TopEntity instance NFData PortName 

@@ -5,6 +5,7 @@   Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} +{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}  module Clash.Backend where@@ -29,6 +30,27 @@ import Clash.Netlist.BlackBox.Types  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 = Identifier 

@@ -7,14 +7,12 @@   Generate SystemVerilog for assorted Netlist datatypes -} -{-# LANGUAGE CPP               #-}-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecursiveDo       #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE ViewPatterns      #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TemplateHaskell #-}  module Clash.Backend.SystemVerilog (SystemVerilogState) where @@ -37,35 +35,30 @@ import qualified Data.Text.Lazy                       as Text import qualified Data.Text                            as TextS import           Data.Text.Prettyprint.Doc.Extra-#ifdef CABAL-import qualified Data.Version-#endif import qualified System.FilePath  import           Clash.Annotations.Primitive          (HDL (..)) import           Clash.Annotations.BitRepresentation.Internal-  (ConstrRepr'(..))+  (ConstrRepr'(..), DataRepr'(..)) import           Clash.Annotations.BitRepresentation.ClashLib   (bitsToBits) import           Clash.Annotations.BitRepresentation.Util   (BitOrigin(Lit, Field), bitOrigins, bitRanges) import           Clash.Core.Var                       (Attr'(..)) import           Clash.Backend-import           Clash.Backend.Verilog                (bits, bit_char, encodingNote, exprLit, include, uselibs)+import           Clash.Backend.Verilog+  (bits, bit_char, encodingNote, exprLit, include, noEmptyInit, uselibs) import           Clash.Netlist.BlackBox.Types         (HdlSyn (..)) import           Clash.Netlist.BlackBox.Util   (extractLiterals, renderBlackBox, renderFilePath) import           Clash.Netlist.Id                     (IdType (..), mkBasicId') import           Clash.Netlist.Types                  hiding (_intWidth, intWidth) import           Clash.Netlist.Util                   hiding (mkIdentifier, extendIdentifier)+import           Clash.Signal.Internal                (ActiveEdge (..)) import           Clash.Util-  (SrcSpan, noSrcSpan, curLoc, makeCached, (<:>), first, on, traceIf)+  (SrcSpan, noSrcSpan, curLoc, makeCached, (<:>), first, on, traceIf, indexNote) import           Clash.Util.Graph                     (reverseTopSort) -#ifdef CABAL-import qualified Paths_clash_lib-#endif- -- | State for the 'Clash.Backend.SystemVerilog.SystemVerilogM' monad: data SystemVerilogState =   SystemVerilogState@@ -95,16 +88,6 @@  makeLenses ''SystemVerilogState -squote :: Mon (State SystemVerilogState) Doc-squote = string "'"--primsRoot :: IO FilePath-#ifdef CABAL-primsRoot = Paths_clash_lib.getDataFileName "prims"-#else-primsRoot = return ("clash-lib" System.FilePath.</> "prims")-#endif- instance Backend SystemVerilogState where   initBackend     = SystemVerilogState HashSet.empty HashMapS.empty HashMap.empty                                        0 "" HashMapS.empty [] noSrcSpan [] [] []@@ -174,10 +157,10 @@   blockDecl _ ds  = do     decs <- decls ds     if isEmpty decs-      then indent 2 (insts ds)+      then insts ds       else         pure decs <> line <>-        indent 2 (insts ds)+        insts ds   unextend = return rmSlash   addIncludes inc = includes %= (inc++)   addLibraries libs = libraries %= (libs ++)@@ -256,11 +239,6 @@     verilog = commentHeader <> line <>               timescale <> line <>               module_ c-#ifdef CABAL-    clashVer = Data.Version.showVersion Paths_clash_lib.version-#else-    clashVer = "development"-#endif     commentHeader          = "/* AUTOMATICALLY GENERATED SYSTEMVERILOG-2005 SOURCE CODE."       <> line <> "** GENERATED BY CLASH " <> string (Text.pack clashVer) <> ". DO NOT MODIFY."@@ -562,8 +540,8 @@   modBody    = indent 2 (decls (declarations c)) <> line <> line <> indent 2 (insts (declarations c))   modEnding  = "endmodule" -  inPorts  = sequence [ sigPort (Nothing,isBiSignalIn ty) (i,ty) | (i,ty)  <- inputs c  ]-  outPorts = sequence [ sigPort (Just wr,False) p | (wr, p) <- outputs c ]+  inPorts  = sequence [ sigPort (Nothing,isBiSignalIn ty) (i,ty) Nothing | (i,ty)  <- inputs c  ]+  outPorts = sequence [ sigPort (Just wr,False) p iEM | (wr, p, iEM) <- outputs c ]    wr2ty (Nothing,isBidirectional)     | isBidirectional@@ -574,9 +552,11 @@     = "output"    -- map a port to its verilog type, port name, and any encoding notes-  sigPort (wr2ty -> portTy) (nm, hwTy)+  sigPort (wr2ty -> portTy) (nm, hwTy) iEM     = addAttrs (hwTypeAttrs hwTy)-        (portTy <+> sigDecl (stringS nm) hwTy <+> encodingNote hwTy)+        (portTy <+> sigDecl (stringS 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 @@ -599,8 +579,8 @@ addSeen :: Component -> SystemVerilogM () addSeen c = do   let iport = map fst (inputs c)-      oport = map (fst.snd) $ outputs c-      nets  = mapMaybe (\case {NetDecl' _ _ i _ -> Just i; _ -> Nothing}) $ declarations c+      oport = map (fst . (\(_,x,_)->x)) $ outputs c+      nets  = mapMaybe (\case {NetDecl' _ _ i _ _ -> Just i; _ -> Nothing}) $ declarations c   Mon (idSeen %= (HashMapS.unionWith max (HashMapS.fromList (concatMap (map (,0)) [iport,oport,nets]))))   Mon (oports .= oport) @@ -644,6 +624,7 @@     Bit           -> "logic"     Bool          -> "logic"     String        -> "string"+    FileType      -> "integer"     _ -> logicOrWire <+> brackets (int (typeSize t -1) <> colon <> int 0)  sigDecl :: SystemVerilogM Doc -> HWType -> SystemVerilogM Doc@@ -742,13 +723,14 @@       _  -> punctuate' semi (A.pure dsDoc)  decl :: Declaration -> SystemVerilogM (Maybe Doc)-decl (NetDecl' noteM _ id_ tyE) =+decl (NetDecl' noteM _ id_ tyE iEM) =   Just A.<$> maybe id addNote noteM (addAttrs attrs (typ tyE))   where-    typ (Left  ty) = stringS ty <+> stringS id_-    typ (Right ty) = sigDecl (stringS id_) ty+    typ (Left  ty) = stringS ty <+> stringS id_ <> iE+    typ (Right ty) = sigDecl (stringS id_) ty <> iE     addNote n = mappend ("//" <+> stringS n <> line)     attrs = fromMaybe [] (hwTypeAttrs A.<$> either (const Nothing) Just tyE)+    iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM  decl _ = return Nothing @@ -773,7 +755,7 @@  insts :: [Declaration] -> SystemVerilogM Doc insts [] = emptyDoc-insts (TickDecl id_:ds) = "//" <+> stringS id_ <> line <> insts ds+insts (TickDecl id_:ds) = comment "//" id_ <> line <> insts ds insts (d:ds) = do   docM <- inst_ d   case docM of@@ -818,8 +800,8 @@   patLitCustom' size cRepr  patLitCustom x y = error $ $(curLoc) ++ unwords-  [ "You can only pass CustomSP / CustomSum and a NumLit to this function,"-  , "not", show x, "and", show y]+  [ "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))@@ -880,12 +862,15 @@   where     (t,f) = if b then (l,r) else (r,l) -inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSP _ _ _ _) es) =+inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSP {}) es) =   inst_' id_ scrut scrutTy es -inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSum _ _ _ _) 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 <- Mon hdlSyn     ; p <- Mon $ use oports@@ -924,21 +909,140 @@ inst_ (BlackBoxD _ libs imps inc bs bbCtx) =   fmap Just (Mon (column (renderBlackBox libs imps inc bs bbCtx))) -inst_ (NetDecl' _ _ _ _) = return Nothing+inst_ (Seq ds) = Just <$> seqs ds +inst_ (NetDecl' {}) = 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+  -> 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_ e ->+    stringS id_ <+> equals <+> 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 id_):ds) = "//" <+> stringS id_ <> 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)                      = stringS id_-expr_ _ (Identifier id_ (Just (Indexed (CustomSP _id _dataRepr _size args,dcI,fI)))) =-  expFromSLV resultType (braces $ hcat $ punctuate ", " $ sequence ranges)-    where-      (ConstrRepr' _name _n _mask _value anns, _, argTys) = args !! dcI-      resultType = argTys !! fI-      ranges = map range' $ bitRanges (anns !! fI)-      range' (start, end) = stringS id_ <> brackets (int start <> ":" <> int end)+expr_ _ (Literal sizeM lit) = exprLitSV sizeM lit+expr_ _ (Identifier id_ Nothing) = stringS 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) = stringS 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) = stringS 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_ start end   where     argTys   = snd $ args !! dcI@@ -996,40 +1100,31 @@     start = typeSize ty - 1     end   = typeSize ty - conSize ty -expr_ b (Identifier id_ (Just (Nested m1 m2))) = case nestM m1 m2 of-  Just m3 -> expr_ b (Identifier id_ (Just m3))-  _ -> case nestSP 0 m1 m2 of-    Just (argTy,start,end) -> fromSLV argTy id_ start end-    _ -> do-      k <- expr_ b (Identifier id_ (Just m1))-      expr_ b (Identifier (Text.toStrict (renderOneLine k)) (Just m2))+expr_ _ (Identifier id_ (Just m@Nested {})) = case modifier 0 [] m of+  Nothing -> stringS id_+  Just (mods,resTy) -> do+    nm <- Mon $ use modNm+    pkgCtx <- Mon $ use tyPkgCtx+    let prefix = if pkgCtx then emptyDoc else stringS nm <> "_types::"+    let e = stringS id_ <> hcat (mapM (either bracketNMod bracketNMod) (reverse mods))+    case resTy of+      Signed _ -> "$signed" <> parens e+      Vector {}+        | Left (NRange {}):_ <- mods+        -> e+        | otherwise  -> do+        Mon (tyCache %= HashSet.insert resTy)+        prefix <> tyName resTy <> "_from_lv" <> parens e+      RTree {}+        | Left (NRange {}):_ <- mods+        -> e+        | otherwise -> do+        Mon (tyCache %= HashSet.insert resTy)+        prefix <> tyName resTy <> "_from_lv" <> parens e+      _ -> e  where-  nestSP offset k1 k2 = case goSP offset k1 of-    Just (_,_,e) -> goSP e k2-    _ -> Nothing--  goSP offset (Indexed (ty@(SP _ args),dcI,fI)) = Just (argTy,start+offset,end+offset)-   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---  goSP offset (Indexed (CustomSP _id _dataRepr _size args,dcI,fI)) =-    case bitRanges (anns !! fI) of-      [(start,end)] -> Just (argTy,start+offset,end+offset)-      _ -> Nothing--   where-    (ConstrRepr' _name _n _mask _value anns, _, argTys) = args !! dcI-    argTy = argTys !! fI--  goSP offset (Nested k1 k2) = nestSP offset k1 k2--  goSP _ _ = Nothing+  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@@ -1096,39 +1191,13 @@ 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) =-  braces $ hcat $ punctuate ", " $ mapM range' origins-    where-      (cRepr, _, argTys) = args !! i--      -- Build bit representations for all constructor arguments-      argExprs = zipWith toSLV argTys es :: [SystemVerilogM Doc]--      -- Spread bits of constructor arguments using masks-      origins = bitOrigins dataRepr cRepr :: [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+expr_ _ (DataCon (CustomSP _ dataRepr _size args) (DC (_,i)) es) =+  let (cRepr, _, argTys) = args !! i 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) -        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 expr_ _ (DataCon (Product _ _ tys) _ es) = listBraces (zipWithM toSLV tys es)  expr_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)@@ -1197,7 +1266,7 @@ expr_ b (ConvBV topM t True e) = do   nm <- Mon $ use modNm   pkgCtx <- Mon $ use tyPkgCtx-  let prefix = if pkgCtx then stringS nm <> "_types::" else emptyDoc+  let prefix = if pkgCtx then emptyDoc else stringS nm <> "_types::"   case t of     Vector {} -> do       Mon (tyCache %= HashSet.insert t)@@ -1212,7 +1281,7 @@ expr_ b (ConvBV topM t False e) = do   nm <- Mon $ use modNm   pkgCtx <- Mon $ use tyPkgCtx-  let prefix = if pkgCtx then stringS nm <> "_types::" else emptyDoc+  let prefix = if pkgCtx then emptyDoc else stringS nm <> "_types::"   case t of     Vector {} -> do       Mon (tyCache %= HashSet.insert t)@@ -1285,3 +1354,172 @@  punctuate' :: Monad m => Mon m Doc -> Mon m [Doc] -> Mon 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)) =+  Just (Right (NRange (start+offset) (end+offset)):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++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.Driver.TopWrapper.mkOutput+-- 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.Driver.TopWrapper.mkOutput+-- 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

@@ -7,19 +7,17 @@   Generate VHDL for assorted Netlist datatypes -} -{-# LANGUAGE CPP                 #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE MultiWayIf          #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RecursiveDo         #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE TupleSections       #-}-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}  module Clash.Backend.VHDL (VHDLState) where +import           Control.Arrow                        (second) import           Control.Applicative                  (liftA2) import           Control.Lens                         hiding (Indexed, Empty) import           Control.Monad                        (forM,join,zipWithM)@@ -49,7 +47,7 @@  import           Clash.Annotations.Primitive          (HDL (..)) import           Clash.Annotations.BitRepresentation.Internal-  (ConstrRepr'(..))+  (ConstrRepr'(..), DataRepr'(..)) import           Clash.Annotations.BitRepresentation.ClashLib   (bitsToBits) import           Clash.Annotations.BitRepresentation.Util@@ -63,13 +61,10 @@ import           Clash.Netlist.Types                  hiding (_intWidth, intWidth) import           Clash.Netlist.Util                   hiding (mkIdentifier) import           Clash.Util-  (SrcSpan, noSrcSpan, clogBase, curLoc, first, makeCached, on, traceIf, (<:>))+  (SrcSpan, noSrcSpan, clogBase, curLoc, first, makeCached, on, traceIf, (<:>),+   indexNote) import           Clash.Util.Graph                     (reverseTopSort) -#ifdef CABAL-import qualified Paths_clash_lib-#endif- -- | State for the 'Clash.Netlist.VHDL.VHDLM' monad: data VHDLState =   VHDLState@@ -101,16 +96,6 @@  makeLenses ''VHDLState -squote :: Mon (State VHDLState) Doc-squote = string "'"--primsRoot :: IO FilePath-#ifdef CABAL-primsRoot = Paths_clash_lib.getDataFileName "prims"-#else-primsRoot = return ("clash-lib" System.FilePath.</> "prims")-#endif- instance Backend VHDLState where   initBackend     = VHDLState HashSet.empty HashMap.empty HashMap.empty ""                               noSrcSpan [] [] [] [] [] HashMapS.empty@@ -183,7 +168,7 @@   blockDecl nm ds = do     decs <- decls ds     let attrs = [ (id_, attr)-                | NetDecl' _ _ id_ (Right hwtype) <- ds+                | NetDecl' _ _ id_ (Right hwtype) _ <- ds                 , attr <- hwTypeAttrs hwtype]     if isEmpty decs        then insts ds@@ -401,6 +386,8 @@   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@@ -453,6 +440,10 @@       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@@ -516,6 +507,7 @@     SP _ _            -> typAliasDec hwty     Sum _ _           -> typAliasDec hwty     CustomSum _ _ _ _ -> typAliasDec hwty+    CustomProduct {}  -> typAliasDec hwty      -- VHDL builtin types:     BitVector _ -> emptyDoc@@ -781,13 +773,17 @@      -> HWType      -> VHDLM Doc      -> Int+     -> Maybe Expr      -> VHDLM (Doc, t)-port elName hwType portDirection fillToN =-  (,fromIntegral $ TextS.length elName) <$> (encodingNote hwType <> fill fillToN (pretty elName) <+> colon <+> direction <+> sizedQualTyName hwType)+port 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 --@@ -818,15 +814,15 @@           _     -> indent 2 (rports p) <> "end" <> semi       )   where-    ports l = sequence $ [port iName hwType "in" l | (iName, hwType) <- inputs c]-                      ++ [port oName hwType "out" l | (_, (oName, hwType)) <- outputs c]+    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 attrs     attrs       = inputAttrs ++ outputAttrs     inputAttrs  = [(id_, attr) | (id_, hwtype) <- inputs c, attr <- hwTypeAttrs hwtype]-    outputAttrs = [(id_, attr) | (_wireOrReg, (id_, hwtype)) <- outputs c, attr <- hwTypeAttrs hwtype]+    outputAttrs = [(id_, attr) | (_wireOrReg, (id_, hwtype), _) <- outputs c, attr <- hwTypeAttrs hwtype]   architecture :: Component -> VHDLM Doc@@ -847,13 +843,13 @@   }  where    netdecls    = filter isNetDecl (declarations c)-   declAttrs   = [(id_, attr) | NetDecl' _ _ id_ (Right hwtype) <- netdecls, attr <- hwTypeAttrs hwtype]+   declAttrs   = [(id_, attr) | NetDecl' _ _ id_ (Right hwtype) _ <- netdecls, attr <- hwTypeAttrs hwtype]    inputAttrs  = [(id_, attr) | (id_, hwtype) <- inputs c, attr <- hwTypeAttrs hwtype]-   outputAttrs = [(id_, attr) | (_wireOrReg, (id_, hwtype)) <- outputs c, attr <- hwTypeAttrs hwtype]+   outputAttrs = [(id_, attr) | (_wireOrReg, (id_, hwtype), _) <- outputs c, attr <- hwTypeAttrs hwtype]     isNetDecl :: Declaration -> Bool-   isNetDecl (NetDecl' _ _ _ (Right _)) = True-   isNetDecl _                          = False+   isNetDecl (NetDecl' _ _ _ (Right _) _) = True+   isNetDecl _                            = False  attrType   :: t ~ HashMap T.Text T.Text@@ -1006,7 +1002,8 @@ -- Some type names do not have specific names, but are instead basic types -- in VHDL. tyName'-  :: Bool+  :: 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@@ -1023,7 +1020,7 @@     KnownDomain {} ->       return (error ($(curLoc) ++ "Forced to print KnownDomain tyName"))     Void _ ->-      return (error ($(curLoc) ++ "Forced to print Void tyName"))+      return (error ($(curLoc) ++ "Forced to print Void tyName: " ++ show t))     Bool          -> return "boolean"     Signed n      ->       let app = if rec0 then ["_", showt n] else [] in@@ -1068,10 +1065,13 @@       Mon $ makeCached (t, False) nameCache (userTyName "sp" nm t)     Product nm _ _ ->       Mon $ makeCached (t, False) nameCache (userTyName "product" nm t)+    CustomProduct nm _ _ _ _ ->+      Mon $ makeCached (t, False) nameCache (userTyName "product" nm t)     Annotated _ hwTy ->       tyName' rec0 hwTy     BiDirectional _ hwTy ->       tyName' rec0 hwTy+    FileType -> return "file"  -- | Returns underlying type of given HWType. That is, the type by which it -- eventually will be represented in VHDL.@@ -1088,6 +1088,7 @@   String        -> hwty   Integer       -> hwty   Bit           -> hwty+  FileType      -> hwty    -- Complex types, for which a user defined type is made in VHDL:   Vector _ _    -> hwty@@ -1102,6 +1103,7 @@   SP _ _            -> BitVector (typeSize hwty)   Sum _ _           -> BitVector (typeSize hwty)   CustomSum _ _ _ _ -> BitVector (typeSize hwty)+  CustomProduct {}  -> BitVector (typeSize hwty)    -- Transparent types:   Annotated _ elTy -> normaliseType elTy@@ -1122,6 +1124,7 @@   Index _           -> hwty   Sum _ _           -> hwty   CustomSum _ _ _ _ -> hwty+  FileType          -> hwty    Vector n elTy     -> Vector n (filterTransparent elTy)   RTree n elTy      -> RTree n (filterTransparent elTy)@@ -1136,6 +1139,10 @@     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 -> elTy   BiDirectional _ elTy -> elTy@@ -1173,7 +1180,11 @@  -- | Convert a Netlist HWType to an error VHDL value for that type sizedQualTyNameErrValue :: HWType -> VHDLM Doc-sizedQualTyNameErrValue Bool                = "true"+sizedQualTyNameErrValue Bool                = do+  udf <- Mon (use undefValue)+  case udf of+    Just (Just 0) -> "false"+    _             -> "true" sizedQualTyNameErrValue Bit                 = singularErrValue sizedQualTyNameErrValue t@(Vector n elTy)   = do   syn <-Mon hdlSyn@@ -1225,10 +1236,11 @@       _  -> punctuate' semi (pure dsDoc)  decl :: Int ->  Declaration -> VHDLM (Maybe (Doc,Int))-decl l (NetDecl' noteM _ id_ ty) = Just <$> (,fromIntegral (TextS.length id_)) <$>-  maybe id addNote noteM ("signal" <+> fill l (pretty id_) <+> colon <+> either pretty sizedQualTyName ty)+decl l (NetDecl' noteM _ id_ ty iEM) = Just <$> (,fromIntegral (TextS.length id_)) <$>+  maybe id addNote noteM ("signal" <+> fill l (pretty id_) <+> colon <+> either pretty sizedQualTyName ty <> iE)   where     addNote n = mappend ("--" <+> pretty n <> line)+    iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM  decl _ (InstDecl Comp _ nm _ gens 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 ]@@ -1249,6 +1261,13 @@  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@@ -1300,7 +1319,7 @@  insts :: [Declaration] -> VHDLM Doc insts [] = emptyDoc-insts (TickDecl id_:ds) = "--" <+> stringS id_ <> line <> insts ds+insts (TickDecl id_:ds) = comment "--" id_ <> line <> insts ds insts (d:ds) = do   d' <- inst_ d   case d' of@@ -1325,7 +1344,6 @@                                               <+> "else"                                               <:> conds es' - -- | Turn a Netlist Declaration to a VHDL concurrent block inst_ :: Declaration -> VHDLM (Maybe Doc) inst_ (Assignment id_ e) = fmap Just $@@ -1346,6 +1364,9 @@ 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))@@ -1381,27 +1402,89 @@  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_ :: Bool -- ^ Enclose in parentheses?-     -> Expr -- ^ Expr to convert-     -> VHDLM Doc+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 (Indexed (CustomSP _id _dataRepr _size args,dcI,fI)))) = do-  nm <- Mon $ use modNm-  let cast = qualTyName resultType <> squote-  let fSLV = stringS (TextS.toLower nm) <> "_types.fromSLV"-  cast <> parens (fSLV <> parens (hcat $ punctuate " & " $ ranges))-    where-      resultType = fieldTypes !! fI-      (ConstrRepr' _name _n _mask _value anns, _, fieldTypes) = args !! dcI+expr_ _ (Identifier id_ (Just (Indexed (CustomSP _id dataRepr _size args,dcI,fI)))) =+  case fieldTy of+    Void {} ->+      error (unexpectedProjectionErrorMsg dataRepr dcI fI)+    _ -> do+      nm <- Mon $ use modNm+      let cast = qualTyName resultType <> squote+      let fSLV = stringS (TextS.toLower nm) <> "_types.fromSLV"+      cast <> parens (fSLV <> parens (hcat $ punctuate " & " $ ranges))+ where+  resultType = fieldTypes !! fI+  (ConstrRepr' _name _n _mask _value anns, _, fieldTypes) = args !! dcI -      ranges =-        mapM range $ bitRanges (anns !! fI)+  ranges =+    mapM range $ bitRanges (anns !! fI) -      range (start, end) =-        pretty id_ <> parens (int start <+> "downto" <+> int end)+  range (start, end) =+    pretty id_ <> parens (int start <+> "downto" <+> int end) +  fieldTy = indexNote ($(curLoc) ++ "panic") fieldTypes fI+ expr_ b (Identifier id_ (Just (Indexed (ty@(SP _ args),dcI,fI)))) = do   nm <- Mon $ use modNm   case b of@@ -1419,6 +1502,20 @@    start    = typeSize ty - 1 - conSize ty - other    end      = start - argSize + 1 +expr_ _ (Identifier id_ (Just (Indexed (CustomProduct _ dataRepr _ _ tys, dcI, fI)))) =+  case fieldTy of+    Void {} ->+      error (unexpectedProjectionErrorMsg dataRepr dcI fI)+    _ -> do+      modNm' <- Mon (use modNm)+      let cast = qualTyName fieldTy <> squote+      let fSLV = stringS (TextS.toLower modNm') <> "_types.fromSLV"+      cast <> parens (fSLV <> parens (hcat $ punctuate " & " $ ranges))+ where+  (fieldAnn, fieldTy) = indexNote ($(curLoc) ++ "panic") tys fI+  ranges = mapM range (bitRanges fieldAnn)+  range (start, end) = pretty id_ <> parens (int start <+> "downto" <+> int end)+ expr_ _ (Identifier id_ (Just (Indexed (ty@(Product _ labels tys),_,fI)))) =   pretty id_ <> dot <> tyName ty <> selectProductField labels tys fI @@ -1634,47 +1731,12 @@ 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) =-  "std_logic_vector'" <> parens (hcat $ punctuate " & " $ mapM range origins)-    where-      (cRepr, _, argTys) = args !! i--      -- Build bit representations for all constructor arguments-      argExprs = zipWith toSLV argTys es :: [VHDLM Doc]--      -- Spread bits of constructor arguments using masks-      origins = bitOrigins dataRepr cRepr :: [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' = argExprs !! 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+expr_ _ (DataCon (CustomSP _ dataRepr _size args) (DC (_,i)) es) =+  let (cRepr, _, argTys) = args !! i 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 ty@(Product _ labels tys) _ es) =     tupled $ zipWithM (\i e' -> tyName ty <> selectProductField labels tys i <+> rarrow <+> expr_ False e') [0..] es@@ -1888,7 +1950,7 @@     Just (Just i) -> "'" <> int i <> "'" bit_char Z = char 'Z' -toSLV :: HWType -> Expr -> VHDLM Doc+toSLV :: HasCallStack => HWType -> Expr -> VHDLM Doc toSLV Bool         e = do   nm <- Mon $ use modNm   pretty (TextS.toLower nm) <> "_types.toSLV" <> parens (expr_ False e)@@ -1910,6 +1972,7 @@   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')@@ -1919,11 +1982,18 @@     selIds   = map (fmap (\n -> Identifier n Nothing)) selNames toSLV (Product _ _ tys) (DataCon _ _ es) = do   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 (Product _ _ _) e = do   nm <- Mon $ use modNm   pretty (TextS.toLower nm) <> "_types.toSLV" <> parens (expr_ False e) toSLV (SP _ _) e       = expr_ False e-toSLV (CustomSP _ _ _ _) 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 <- Mon hdlSyn@@ -1934,6 +2004,10 @@   where     selNames = map (fmap (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 <- Mon $ use modNm+  pretty (TextS.toLower 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@@ -1963,6 +2037,7 @@     args       = zipWith3 (`fromSLV` id_) tys starts ends  fromSLV (CustomSP _ _ _ _)  id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end)+fromSLV (CustomProduct {})  id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end) fromSLV (SP _ _)            id_ start end = pretty id_ <> parens (int start <+> "downto" <+> int end) fromSLV (Vector n elTy)     id_ start _   =     if n > 1 then tupled args

@@ -7,15 +7,13 @@   Generate Verilog for assorted Netlist datatypes -} -{-# LANGUAGE CPP               #-}-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE RecursiveDo       #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE TupleSections     #-}-{-# LANGUAGE ViewPatterns      #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TemplateHaskell #-}  module Clash.Backend.Verilog   ( VerilogState@@ -25,6 +23,7 @@   , exprLit   , bits   , bit_char+  , noEmptyInit   ) where @@ -46,17 +45,15 @@ import qualified Data.Text.Lazy                       as Text import qualified Data.Text                            as TextS import           Data.Text.Prettyprint.Doc.Extra-#ifdef CABAL-import qualified Data.Version-#endif import qualified System.FilePath+import           GHC.Stack                            (HasCallStack)  import           Clash.Annotations.Primitive          (HDL (..)) import           Clash.Annotations.BitRepresentation  (BitMask) import           Clash.Annotations.BitRepresentation.ClashLib   (bitsToBits) import           Clash.Annotations.BitRepresentation.Internal-  (ConstrRepr'(..))+  (ConstrRepr'(..), DataRepr'(..), ConstrRepr'(..)) import           Clash.Annotations.BitRepresentation.Util   (BitOrigin(Lit, Field), bitOrigins, bitRanges, isContinuousMask) import           Clash.Core.Var                       (Attr'(..))@@ -67,16 +64,11 @@ import           Clash.Netlist.Id                     (IdType (..), mkBasicId') import           Clash.Netlist.Types                  hiding (_intWidth, intWidth) import           Clash.Netlist.Util                   hiding (mkIdentifier, extendIdentifier)+import           Clash.Signal.Internal                (ActiveEdge (..)) import           Clash.Util-  (SrcSpan, noSrcSpan, curLoc, traceIf, (<:>),on,first)--+  (SrcSpan, noSrcSpan, curLoc, traceIf, (<:>), on, first, indexNote)  -#ifdef CABAL-import qualified Paths_clash_lib-#endif- -- | State for the 'Clash.Backend.Verilog.VerilogM' monad: data VerilogState =   VerilogState@@ -99,16 +91,6 @@  makeLenses ''VerilogState -squote :: Mon (State VerilogState) Doc-squote = string "'"--primsRoot :: IO FilePath-#ifdef CABAL-primsRoot = Paths_clash_lib.getDataFileName "prims"-#else-primsRoot = return ("clash-lib" System.FilePath.</> "prims")-#endif- instance Backend VerilogState where   initBackend     = VerilogState 0 HashMap.empty noSrcSpan [] [] [] [] []   hdlKind         = const Verilog@@ -176,10 +158,10 @@   blockDecl _ ds  = do     decs <- decls ds     if isEmpty decs-      then indent 2 (insts ds)+      then insts ds       else         pure decs <> line <>-        indent 2 (insts ds)+        insts ds   unextend = return rmSlash   addIncludes inc = includes %= (inc++)   addLibraries libs = libraries %= (libs ++)@@ -235,11 +217,6 @@     incs <- Mon $ use includes     return ((TextS.unpack cName,v),incs)   where-#ifdef CABAL-    clashVer = Data.Version.showVersion Paths_clash_lib.version-#else-    clashVer = "development"-#endif     cName    = componentName c     commentHeader          = "/* AUTOMATICALLY GENERATED VERILOG-2001 SOURCE CODE."@@ -250,16 +227,19 @@ sigPort :: Maybe WireOrReg         -> TextS.Text         -> HWType+        -> Maybe Expr         -> VerilogM Doc-sigPort wor pName hwType =+sigPort wor pName hwType iEM =     addAttrs (hwTypeAttrs hwType)-      (portType <+> verilogType hwType <+> stringS pName <> encodingNote hwType)+      (portType <+> verilogType hwType <+> stringS pName <> iE <> encodingNote hwType)   where     portType = case wor of                  Nothing   -> if isBiSignalIn hwType then "inout" else "input"                  Just Wire -> "output" <+> "wire"                  Just Reg  -> "output" <+> "reg" +    iE = maybe emptyDoc (noEmptyInit . expr_ False) iEM+ module_ :: Component -> VerilogM Doc module_ c = addSeen c *> modVerilog <* Mon (imports .= [])   where@@ -274,8 +254,8 @@     modBody    = indent 2 (decls (declarations c)) <> line <> line <> indent 2 (insts (declarations c))     modEnding  = "endmodule" -    inPorts  = sequence [ sigPort Nothing id_ hwType | (id_, hwType) <- inputs c  ]-    outPorts = sequence [ sigPort (Just wireOrReg) id_ hwType | (wireOrReg, (id_, hwType)) <- outputs c ]+    inPorts  = sequence [ sigPort Nothing id_ hwType Nothing | (id_, hwType) <- inputs c  ]+    outPorts = sequence [ sigPort (Just wireOrReg) id_ hwType iEM | (wireOrReg, (id_, hwType), iEM) <- outputs c ]      -- slightly more readable than 'tupled', makes the output Haskell-y-er     commafy v = (comma <> space) <> pure v@@ -309,15 +289,16 @@   indent 2 (string "`uselib" <+> (hsep (mapM (\l -> ("lib=" <> string l)) xs)))   <> line <> line -wireOrRegDoc :: WireOrReg -> VerilogM Doc-wireOrRegDoc Wire = "wire"-wireOrRegDoc Reg  = "reg"+wireRegFileDoc :: WireOrReg -> (Either Identifier HWType) -> VerilogM Doc+wireRegFileDoc _    (Right FileType) = "integer"+wireRegFileDoc Wire _                = "wire"+wireRegFileDoc Reg  _                = "reg"  addSeen :: Component -> VerilogM () addSeen c = do   let iport = [iName | (iName, _) <- inputs c]-      oport = [oName | (_, (oName, _)) <- outputs c]-      nets  = mapMaybe (\case {NetDecl' _ _ i _ -> Just i; _ -> Nothing}) $ declarations c+      oport = [oName | (_, (oName, _), _) <- outputs c]+      nets  = mapMaybe (\case {NetDecl' _ _ i _ _ -> Just i; _ -> Nothing}) $ declarations c   Mon $ idSeen %= (HashMap.unionWith max (HashMap.fromList (concatMap (map (,0)) [iport,oport,nets])))  verilogType :: HWType -> VerilogM Doc@@ -327,6 +308,7 @@   Reset {} -> emptyDoc   Bit      -> emptyDoc   Bool     -> emptyDoc+  FileType -> emptyDoc   _        -> brackets (int (typeSize t -1) <> colon <> int 0)  sigDecl :: VerilogM Doc -> HWType -> VerilogM Doc@@ -381,19 +363,27 @@ renderAttr (Attr'        key      ) = pack $ key  decl :: Declaration -> VerilogM (Maybe Doc)-decl (NetDecl' noteM wr id_ tyE) =-  Just A.<$> maybe id addNote noteM (addAttrs attrs (wireOrRegDoc wr <+> tyDec tyE))+decl (NetDecl' noteM wr id_ tyE iEM) =+  Just A.<$> maybe id addNote noteM (addAttrs attrs (wireRegFileDoc wr tyE <+> tyDec tyE))   where-    tyDec (Left  ty) = stringS ty <+> stringS id_-    tyDec (Right ty) = sigDecl (stringS id_) ty+    tyDec (Left  ty) = stringS ty <+> stringS id_ <> iE+    tyDec (Right ty) = sigDecl (stringS id_) ty <> iE     addNote n = mappend ("//" <+> stringS n <> line)     attrs = fromMaybe [] (hwTypeAttrs A.<$> either (const Nothing) 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 id_:ds) = "//" <+> stringS id_ <> line <> insts ds+insts (TickDecl id_:ds) = comment "//" id_ <> line <> insts ds insts (d:ds) = do   docM <- inst_ d   case docM of@@ -437,9 +427,14 @@   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 and a NumLit to this function,"-  , "not", show x, "and", show y]+  [ "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))@@ -491,12 +486,15 @@   where     (t,f) = if b then (l,r) else (r,l) -inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSP _ _ _ _) es) =+inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSP {}) es) =   inst_' id_ scrut scrutTy es -inst_ (CondAssignment id_ _ scrut scrutTy@(CustomSum _ _ _ _) 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_ _ scrut scrutTy es) = fmap Just $     "always @(*) begin" <> line <>     indent 2 ("case" <> parens (expr_ True scrut) <> line <>@@ -521,13 +519,72 @@ inst_ (BlackBoxD _ libs imps inc bs bbCtx) =   fmap Just (Mon (column (renderBlackBox libs imps inc bs bbCtx))) -inst_ (NetDecl' _ _ _ _) = return Nothing+inst_ (Seq ds) = Just <$> seqs ds +inst_ (NetDecl' {}) = return Nothing++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_ e ->+    stringS id_ <+> equals <+> 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 id_):ds) = "//" <+> stringS id_ <> line <> seqs ds+seqs (d:ds) = seq_ d <> line <> line <> seqs ds+ -- | Calculate the beginning and end index into a variable, to get the -- desired field. -- Also returns the HWType of the result. modifier-  :: Int+  :: HasCallStack+  => Int   -- ^ Offset, only used when we have nested modifiers   -> Modifier   -> Maybe (Int,Int,HWType)@@ -556,7 +613,7 @@     start   = typeSize ty - 1     end     = start - argSize + 1 -modifier offset (Indexed (ty@(Vector _ argTy),1,1)) = Just (start+offset,offset, argTy)+modifier offset (Indexed (ty@(Vector n argTy),1,1)) = Just (start+offset,offset,Vector (n-1) argTy)   where     argSize = typeSize argTy     start   = typeSize ty - argSize - 1@@ -565,12 +622,12 @@   where     start   = typeSize ty - 1 -modifier offset (Indexed (ty@(RTree _ argTy),1,0)) = Just (start+offset,end+offset, argTy)+modifier offset (Indexed (ty@(RTree d argTy),1,0)) = Just (start+offset,end+offset,RTree (d-1) argTy)   where     start   = typeSize ty - 1     end     = typeSize ty `div` 2 -modifier offset (Indexed (ty@(RTree _ argTy),1,1)) = Just (start+offset,offset, argTy)+modifier offset (Indexed (ty@(RTree d argTy),1,1)) = Just (start+offset,offset, RTree (d-1) argTy)   where     start   = (typeSize ty `div` 2) - 1 @@ -592,14 +649,33 @@     start   = typeSize ty - (fI * argSize) - 1     end     = start - argSize + 1 -modifier offset (Indexed (CustomSP _id _dataRepr _size args,dcI,fI)) =+modifier offset (Indexed (CustomSP typName _dataRepr _size args,dcI,fI)) =   case bitRanges (anns !! fI) of-    [(start,end)] -> Just (start+offset,end+offset, argTy)-    _ -> error ($(curLoc) ++ "Cannot handle projection out of a non-contiguously encoded field")+    [(start,end)] ->+      Just (start+offset,end+offset, 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 (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)] ->+      Just (start+offset,end+offset, 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 (DC (ty@(SP _ _),_)) = Just (start+offset,end+offset, ty)   where     start = typeSize ty - 1@@ -616,6 +692,56 @@  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 args =+  (flip fromMaybe) (errOnNonContinuous 0 anns) $+  braces $ hcat $ punctuate ", " $ mapM range' origins+    where+      anns = crFieldAnns constrRepr+      size = drSize dataRepr++      errOnNonContinuous :: Int -> [BitMask] -> Maybe a+      errOnNonContinuous _ [] = Nothing+      errOnNonContinuous fieldnr (ann:anns') =+        if isContinuousMask ann then+          errOnNonContinuous (fieldnr + 1) anns'+        else+          error $ $(curLoc) ++ unlines [+              "Error while processing custom bit representation:\n"+            , unwords ["Field", show fieldnr, "of constructor"+            , show (crName constrRepr), "of type\n"]+            , "  " ++ show (drType dataRepr) ++ "\n"+            , "has a non-continuous fieldmask:\n"+            , "  " ++ (map bit_char' $ toBits size ann) ++ "\n"+            , unwords [ "This is not supported in Verilog. Change the mask to a"+                      , "continuous one, or render using VHDL or SystemVerilog."+                      ]+            ]++      -- Build bit representations for all constructor arguments+      argExprs = map (expr_ False) (map snd args) :: [VerilogM Doc]++      -- Spread bits of constructor arguments using masks+      origins = bitOrigins dataRepr constrRepr :: [BitOrigin]++      range'+        :: BitOrigin+        -> VerilogM Doc+      range' (Lit (bitsToBits -> ns)) =+        int (length ns) <> squote <> "b" <> hcat (mapM (bit_char undefValue) ns)+      range' (Field n _start _end) =+        argExprs !! n++ -- | Turn a Netlist expression into a Verilog expression expr_ :: Bool -- ^ Enclose in parentheses?       -> Expr -- ^ Expr to convert@@ -624,13 +750,27 @@  expr_ _ (Identifier id_ Nothing) = stringS id_ -expr_ _ (Identifier id_ (Just (Indexed (CustomSP _id _dataRepr _size args,dcI,fI)))) =-  braces $ hcat $ punctuate ", " $ sequence ranges-    where-      (ConstrRepr' _name _n _mask _value anns, _, _argTys) = args !! dcI-      ranges = map range' $ bitRanges (anns !! fI)-      range' (start, end) = stringS id_ <> brackets (int start <> ":" <> int end)+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) = stringS 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) = stringS d_ <> brackets (int start <> ":" <> int end)+ -- See [Note] integer projection expr_ _ (Identifier id_ (Just (Indexed ((Signed w),_,_))))  = do   iw <- Mon $ use intWidth@@ -698,44 +838,12 @@ 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 args) (DC (_,constrNr)) es) =-  (flip fromMaybe) (errOnNonContinuous 0 anns) $-  braces $ hcat $ punctuate ", " $ mapM range' origins-    where-      (cRepr, _, _) = args !! constrNr-      (ConstrRepr' _name _n _mask _value anns) = cRepr--      errOnNonContinuous :: Int -> [BitMask] -> Maybe a-      errOnNonContinuous _ [] = Nothing-      errOnNonContinuous fieldnr (ann:anns') =-        if isContinuousMask ann then-          errOnNonContinuous (fieldnr + 1) anns'-        else-          error $ $(curLoc) ++ unlines [-              "Error while processing custom bit representation:\n"-            , unwords ["Field", show fieldnr, "of constructor", show constrNr, "of type\n"]-            , "  " ++ show name' ++ "\n"-            , "has a non-continuous fieldmask:\n"-            , "  " ++ (map bit_char' $ toBits size ann) ++ "\n"-            , unwords [ "This is not supported in Verilog. Change the mask to a"-                      , "continuous one, or render using VHDL or SystemVerilog."-                      ]-            ]--      -- Build bit representations for all constructor arguments-      argExprs = map (expr_ False) es :: [VerilogM Doc]--      -- Spread bits of constructor arguments using masks-      origins = bitOrigins dataRepr cRepr :: [BitOrigin]--      range'-        :: BitOrigin-        -> VerilogM Doc-      range' (Lit (bitsToBits -> ns)) =-        int (length ns) <> squote <> "b" <> hcat (mapM (bit_char undefValue) ns)-      range' (Field n _start _end) =-        argExprs !! n-+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_ _ (BlackBoxE pNm _ _ _ _ bbCtx _)

@@ -7,12 +7,11 @@   Data Constructors in CoreHW -} -{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell #-}  module Clash.Core.DataCon   ( DataCon (..)

@@ -10,31 +10,28 @@  -} -{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE MagicHash         #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE ViewPatterns      #-}+{-# LANGUAGE TemplateHaskell #-}  module Clash.Core.Evaluator where -import           Control.Arrow                           (second)+import           Prelude                                 hiding (lookup)+ import           Control.Concurrent.Supply               (Supply, freshId)-import           Control.Lens                            (view, _4)-import           Data.Bits                               (shiftL) import           Data.Either                             (lefts,rights)-import           Data.List-  (foldl',mapAccumL,uncons)-import           Data.IntMap                             (IntMap)+import           Data.List                               (foldl',mapAccumL)+import           Data.Maybe                              (fromMaybe) import qualified Data.Primitive.ByteArray                as BA+import qualified Data.Text as Text import qualified Data.Vector.Primitive                   as PV-import           Data.Text                               (Text)-import           Data.Text.Prettyprint.Doc-import           Debug.Trace                             (trace)+import           Debug.Trace import           GHC.Integer.GMP.Internals   (Integer (..), BigNat (..))+ import           Clash.Core.DataCon+import           Clash.Core.Evaluator.Types import           Clash.Core.FreeVars import           Clash.Core.Literal import           Clash.Core.Name@@ -46,488 +43,361 @@ import           Clash.Core.Util import           Clash.Core.Var import           Clash.Core.VarEnv-import           Clash.Driver.Types                      (BindingMap)-import           Prelude                                 hiding (lookup)+import           Clash.Driver.Types                      (BindingMap, Binding(..))+import           Clash.Pretty import           Clash.Unique import           Clash.Util                              (curLoc)-import           Clash.Pretty --- | The heap-data Heap = Heap GlobalHeap GPureHeap PureHeap Supply InScopeSet--type PureHeap = VarEnv Term-newtype GPureHeap = GPureHeap { unGPureHeap :: PureHeap }---- | Global heap-type GlobalHeap = (IntMap Term, Int)---- | The stack-type Stack = [StackFrame]--data StackFrame-  = Update Id-  | GUpdate Id-  | Apply  Id-  | Instantiate Type-  | PrimApply  Text PrimInfo [Type] [Value] [Term]-  | Scrutinise Type [Alt]-  | Tickish TickInfo-  deriving Show--instance ClashPretty StackFrame where-  clashPretty (Update i) = hsep ["Update", fromPpr i]-  clashPretty (GUpdate i) = hsep ["GUpdate", fromPpr i]-  clashPretty (Apply i) = hsep ["Apply", fromPpr i]-  clashPretty (Instantiate t) = hsep ["Instantiate", fromPpr t]-  clashPretty (PrimApply a b c d e) = do-    hsep ["PrimApply", fromPretty a, "::", fromPpr (primType b),-          "; type args=", fromPpr c,-          "; val args=", fromPpr (map valToTerm d),-          "term args=", fromPpr e]-  clashPretty (Scrutinise a b) =-    hsep ["Scrutinise ", fromPpr a,-          fromPpr (Case (Literal (CharLiteral '_')) a b)]-  clashPretty (Tickish sp) =-    hsep ["Tick", fromPpr sp]--mkTickish-  :: Stack-  -> [TickInfo]-  -> Stack-mkTickish s sps = map Tickish sps ++ s---- Values-data Value-  = Lambda Id Term-  -- ^ Functions-  | TyLambda TyVar Term-  -- ^ Type abstractions-  | DC DataCon [Either Term Type]-  -- ^ Data constructors-  | Lit Literal-  -- ^ Literals-  | PrimVal  Text 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-  deriving Show---- | State of the evaluator-type State = (Heap, Stack, Term)---- | Function that can evaluator primitives, i.e., perform delta-reduction-type PrimEvaluator =-  Bool -> -- Force special primitives? See [Note: forcing special primitives]-  TyConMap -> -- Type constructors-  Heap ->-  Stack ->-  Text -> -- Name of the primitive-  PrimInfo -> -- Type of the primitive-  [Type] -> -- Type arguments of the primitive-  [Value] -> -- Value arguments of the primitive-  Maybe State -- Delta-reduction can get stuck, so Nothing is an option---- | Evaluate to WHNF starting with an empty Heap and Stack whnf'-  :: PrimEvaluator+  :: PrimStep+  -> PrimUnwind   -> BindingMap   -> TyConMap-  -> GlobalHeap+  -> PrimHeap   -> Supply   -> InScopeSet   -> Bool   -> Term-  -> (GlobalHeap, PureHeap, Term)-whnf' eval gbl0 tcm gh ids is isSubj e-  = case whnf eval tcm isSubj (Heap gh gbl1 emptyVarEnv ids is,[],e) of-      (Heap gh' _ ph' _ _,_,e') -> (gh',ph',e')+  -> (PrimHeap, PureHeap, Term)+whnf' eval fu bm tcm ph ids is isSubj e =+  toResult $ whnf tcm isSubj m  where-  gbl1 = GPureHeap (mapVarEnv (view _4) gbl0)+  toResult x = (mHeapPrim x, mHeapLocal x, mTerm x) +  m  = Machine eval fu ph gh emptyVarEnv [] ids is e+  gh = mapVarEnv bindingTerm bm+ -- | Evaluate to WHNF given an existing Heap and Stack whnf-  :: PrimEvaluator-  -> TyConMap+  :: TyConMap   -> Bool-  -> State-  -> State-whnf eval tcm isSubj (h,k,e) =-    if isSubj-       then go (h,Scrutinise ty []:k,e) -- See [Note: empty case expressions]-       else go (h,k,e)+  -> Machine+  -> Machine+whnf tcm isSubj m+  | isSubj =+      -- See [Note: empty case expressions]+      let ty = termType tcm (mTerm m)+       in go (stackPush (Scrutinise ty []) m)+  | otherwise = go m   where-    ty = termType tcm e--    go s = case step eval tcm s of+    go s = case step s tcm of       Just s' -> go s'-      Nothing-        | Just e' <- unwindStack s-        -> e'-        | otherwise-        -> error $ showDoc $ ppr e+      Nothing -> fromMaybe (error . showDoc . ppr $ mTerm m) (unwindStack s) --- | Are we in a context where special primitives must be forced.+-- | 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. ----- See [Note: forcing special primitives]-isScrut :: Stack -> Bool-isScrut (Scrutinise {}:_) = True-isScrut (PrimApply {} :_) = True-isScrut (Tickish {}:k) = isScrut k-isScrut _ = False+type Step = Machine -> TyConMap -> Maybe Machine --- | Completely unwind the stack to get back the complete term-unwindStack :: State -> Maybe State-unwindStack s@(_,[],_) = Just s-unwindStack (h@(Heap gh gbl h' ids is),(kf:k'),e) = case kf of-  PrimApply nm ty tys vs tms ->-    unwindStack-      (h,k'-      ,foldl' App-              (foldl' App (foldl' TyApp (Prim nm ty) tys) (map valToTerm vs))-              (e:tms))-  Instantiate ty ->-    unwindStack (h,k',TyApp e ty)-  Apply id_ -> do-    case lookupVarEnv id_ h' of-      Just e' -> unwindStack (h,k',App e e')-      Nothing -> error $ unlines-                       $ [ "Clash.Core.Evaluator.unwindStack:"-                         , "Stack:"-                         ] ++-                         [ "  "++ showDoc (clashPretty frame) | frame <- kf:k'] ++-                         [ ""-                         , "Expression:"-                         , showPpr e-                         , ""-                         , "Heap:"-                         , showDoc (clashPretty h')-                         ]-  Scrutinise _ [] ->-    unwindStack (h,k',e)-  Scrutinise ty alts ->-    unwindStack (h,k',Case e ty alts)-  Update x ->-    unwindStack (Heap gh gbl (extendVarEnv x e h') ids is,k',e)-  GUpdate _ ->-    unwindStack (h,k',e)-  Tickish sp ->-    unwindStack (h,k',Tick sp e)+stepVar :: Id -> Step+stepVar i m _+  | Just e <- heapLookup LocalId i m+  = go LocalId e -{- [Note: forcing special primitives]-Clash uses the `whnf` function in two places (for now):+  | Just e <- heapLookup GlobalId i m+  , isGlobalId i+  = go GlobalId e -  1. The case-of-known-constructor transformation-  2. The reduceConstant transformation+  | otherwise+  = Nothing+ where+  go s e =+    let term = deShadowTerm (mScopeNames m) (tickExpr e)+     in Just . setTerm term . stackPush (Update s i) $ heapDelete s i m -The first transformation is needed to reach the required normal form. The-second transformation is more of cleanup transformation, so non-essential.+  -- Removing the heap-bound value on a force ensures we do not get stuck on+  -- expressions such as: "let x = x in x"+  tickExpr = Tick (NameMod PrefixName (LitTy . SymTy $ toStr i))+  unQualName = snd . Text.breakOnEnd "."+  toStr = Text.unpack . unQualName . flip Text.snoc '_' . nameOcc . varName -Normally, `whnf` would force the evaluation of all primitives, which is needed-in the `case-of-known-constructor` transformation. However, there are some-primitives which we want to leave unevaluated in the `reduceConstant`-transformation. Such primitives are:+stepData :: DataCon -> Step+stepData dc m tcm = unwind tcm m (DC dc []) -  - Primitives such as `Clash.Sized.Vector.transpose`, `Clash.Sized.Vector.map`,-    etc. that do not reduce to an expression in normal form. Where the-    `reduceConstant` transformation is supposed to be normal-form preserving.-  - Primitives such as `GHC.Int.I8#`, `GHC.Word.W32#`, etc. which seem like-    wrappers around a 64-bit literal, but actually perform truncation to the-    desired bit-size.+stepLiteral :: Literal -> Step+stepLiteral l m tcm = unwind tcm m (Lit l) -This is why the Primitive Evaluator gets a flag telling whether it should-evaluate these special primitives.--}+stepPrim :: PrimInfo -> Step+stepPrim pInfo m tcm+  | primName pInfo == "GHC.Prim.realWorld#" =+      unwind tcm m (PrimVal pInfo [] []) +  | otherwise =+      case fst $ splitFunForallTy (primType pInfo) of+        []  -> mPrimStep m tcm (forcePrims m) pInfo [] [] m+        tys -> newBinder tys (Prim pInfo) m tcm++stepLam :: Id -> Term -> Step+stepLam x e m tcm = unwind tcm m (Lambda x e)++stepTyLam :: TyVar -> Term -> Step+stepTyLam x e m tcm = unwind tcm m (TyLambda x e)++stepApp :: Term -> Term -> Step+stepApp x y m tcm =+  case term of+    Data dc ->+      let tys = fst $ splitFunForallTy (dcType dc)+       in case compare (length args) (length tys) of+            EQ -> unwind tcm m (DC dc args)+            LT -> newBinder tys' (App x y) m tcm+            GT -> error "Overapplied DC"++    Prim p ->+      let tys = fst $ splitFunForallTy (primType p)+       in case compare (length args) (length tys) of+            EQ -> case lefts args of+              -- We make boolean conjunction and disjunction extra lazy by+              -- deferring the evaluation of the arguments during the evaluation+              -- of the primop rule.+              --+              -- This allows us to implement:+              --+              -- x && True  --> x+              -- x && False --> False+              -- x || True  --> True+              -- x || False --> x+              --+              -- even when that 'x' is _|_. This makes the evaluation+              -- rule lazier than the actual Haskel implementations which+              -- are strict in the first argument and lazy in the second.+              [a0, a1] | primName p `elem` ["GHC.Classes.&&","GHC.Classes.||"] ->+                    let (m0,i) = newLetBinding tcm m  a0+                        (m1,j) = newLetBinding tcm m0 a1+                    in  mPrimStep m tcm (forcePrims m) p [] [Suspend (Var i), Suspend (Var j)] m1++              (e':es) ->+                Just . setTerm e' $ stackPush (PrimApply p (rights args) [] es) m++              _ -> error "internal error"++            LT -> newBinder tys' (App x y) m tcm++            GT -> let (m0, n) = newLetBinding tcm m y+                   in Just . setTerm x $ stackPush (Apply n) m0++    _ -> let (m0, n) = newLetBinding tcm m y+          in Just . setTerm x $ stackPush (Apply n) m0+ where+  (term, args, _) = collectArgsTicks (App x y)+  tys' = fst . splitFunForallTy . termType tcm $ App x y++stepTyApp :: Term -> Type -> Step+stepTyApp x ty m tcm =+  case term of+    Data dc ->+      let tys = fst $ splitFunForallTy (dcType dc)+       in case compare (length args) (length tys) of+            EQ -> unwind tcm m (DC dc args)+            LT -> newBinder tys' (TyApp x ty) m tcm+            GT -> error "Overapplied DC"++    Prim p ->+      let tys = fst $ splitFunForallTy (primType p)+       in case compare (length args) (length tys) of+            EQ -> case lefts args of+                    [] | primName p == "Clash.Transformations.removedArg" ->+                            unwind tcm m (PrimVal p (rights args) [])++                       | otherwise ->+                            mPrimStep m tcm (forcePrims m) p (rights args) [] m++                    (e':es) ->+                      Just . setTerm e' $ stackPush (PrimApply p (rights args) [] es) m++            LT -> newBinder tys' (TyApp x ty) m tcm+            GT -> Just . setTerm x $ stackPush (Instantiate ty) m++    _ -> Just . setTerm x $ stackPush (Instantiate ty) m+ where+  (term, args, _) = collectArgsTicks (TyApp x ty)+  tys' = fst . splitFunForallTy . termType tcm $ TyApp x ty++stepLetRec :: [LetBinding] -> Term -> Step+stepLetRec bs x m _ = Just (allocate bs x m)++stepCase :: Term -> Type -> [Alt] -> Step+stepCase scrut ty alts m _ =+  Just . setTerm scrut $ stackPush (Scrutinise ty alts) m++-- TODO Support stepwise evaluation of casts.+--+stepCast :: Term -> Type -> Type -> Step+stepCast _ _ _ _ _ =+  flip trace Nothing $ unlines+    [ "WARNING: " <> $(curLoc) <> "Clash can't symbolically evaluate casts"+    , "Please file an issue at https://github.com/clash-lang/clash-compiler/issues"+    ]++stepTick :: TickInfo -> Term -> Step+stepTick tick x m _ =+  Just . setTerm x $ stackPush (Tickish tick) m+ -- | Small-step operational semantics.-step-  :: PrimEvaluator-  -> TyConMap-  -> State-  -> Maybe State-step eval tcm (h, k, e) = case e of-  Var v        -> force h k v-  (Lam x e')   -> unwind eval tcm h k (Lambda x e')-  (TyLam x e') -> unwind eval tcm h k (TyLambda x e')-  (Literal l)  -> unwind eval tcm h k (Lit l)-  (App e1 e2)-    | (Data dc,args,_ticks) <- collectArgsTicks e-    , (tys,_) <- splitFunForallTy (dcType dc)-    -> case compare (length args) (length tys) of-         EQ -> unwind eval tcm h k (DC dc args)-         LT -> let (tys',_) = splitFunForallTy (termType tcm e)-                   (h2,e')  = mkAbstr (h,e) tys'-               in  step eval tcm (h2,k,e')-         GT -> error "Overapplied DC"-    | (Prim nm pInfo,args,_ticks) <- collectArgsTicks e-    , let ty = primType pInfo-    , (tys,_) <- splitFunForallTy ty-    -> case compare (length args) (length tys) of-         EQ -> let (e':es) = lefts args-               in  Just (h,PrimApply nm pInfo (rights args) [] es:k,e')-         LT -> let (tys',_) = splitFunForallTy (termType tcm e)-                   (h2,e') = mkAbstr (h,e) tys'-               in  step eval tcm (h2,k,e')-         GT -> let (h2,id_) = newLetBinding tcm h e2-               in  Just (h2,Apply id_:k,e1)-  (TyApp e1 ty)-    | (Data dc,args,_ticks) <- collectArgsTicks e-    , (tys,_) <- splitFunForallTy (dcType dc)-    -> case compare (length args) (length tys) of-         EQ -> unwind eval tcm h k (DC dc args)-         LT -> let (tys',_) = splitFunForallTy (termType tcm e)-                   (h2,e') = mkAbstr (h,e) tys'-               in  step eval tcm (h2,k,e')-         GT -> error "Overapplied DC"-    | (Prim nm pInfo,args,_ticks) <- collectArgsTicks e-    , let ty' = primType pInfo-    , (tys,_) <- splitFunForallTy ty'-    -> case compare (length args) (length tys) of-         EQ -> case lefts args of-              [] | nm `elem` ["Clash.Transformations.removedArg"]-                 -- The above primitives are actually values, and not operations.-                 -> unwind eval tcm h k (PrimVal nm pInfo (rights args) [])-                 | otherwise-                 -> eval (isScrut k) tcm h k nm pInfo (rights args) []-              (e':es) -> Just (h,PrimApply nm pInfo (rights args) [] es:k,e')-         LT -> let (tys',_) = splitFunForallTy (termType tcm e)-                   (h2,e') = mkAbstr (h,e) tys'-               in  step eval tcm (h2,k,e')-         GT -> Just (h,Instantiate ty:k,e1)-  (Data dc) -> unwind eval tcm h k (DC dc [])-  (Prim nm pInfo)-    | nm `elem` ["GHC.Prim.realWorld#"]-    -> unwind eval tcm h k (PrimVal nm pInfo [] [])-    | otherwise-    , let ty' = primType pInfo-    -> case fst (splitFunForallTy ty')  of-        []  -> eval (isScrut k) tcm h k nm pInfo [] []-        tys -> let (h2,e') = mkAbstr (h,e) tys-               in  step eval tcm (h2,k,e')-  (App e1 e2)  -> let (h2,id_) = newLetBinding tcm h e2-                  in  Just (h2,Apply id_:k,e1)-  (TyApp e1 ty) -> Just (h,Instantiate ty:k,e1)-  (Case scrut ty alts) -> Just (h,Scrutinise ty alts:k,scrut)-  (Letrec bs e') -> Just (allocate h k bs e')-  Tick sp e' -> Just (h,Tickish sp:k,e')-  Cast _ _ _ -> trace (unlines ["WARNING: " ++ $(curLoc) ++ "Clash currently can't symbolically evaluate casts"-                                    ,"If you have testcase that produces this message, please open an issue about it."]) Nothing+--+step :: Step+step m = case mTerm m of+  Var i -> stepVar i m+  Data dc -> stepData dc m+  Literal l -> stepLiteral l m+  Prim p -> stepPrim p m+  Lam v x -> stepLam v x m+  TyLam v x -> stepTyLam v x m+  App x y -> stepApp x y m+  TyApp x ty -> stepTyApp x ty m+  Letrec bs x -> stepLetRec bs x m+  Case s ty as -> stepCase s ty as m+  Cast x a b -> stepCast x a b m+  Tick t x -> stepTick t x m +-- | Take a list of types or type variables and create a lambda / type lambda+-- for each one around the given term.+--+newBinder :: [Either TyVar Type] -> Term -> Step+newBinder tys x m tcm =+  let (s', iss', x') = mkAbstr (mSupply m, mScopeNames m, x) tys+      m' = m { mSupply = s', mScopeNames = iss', mTerm = x' }+   in step m' tcm+ where+  mkAbstr = foldr go+    where+      go (Left tv) (s', iss', e') =+        (s', iss', TyLam tv (TyApp e' (VarTy tv)))++      go (Right ty) (s', iss', e') =+        let ((s'', _), n) = mkUniqSystemId (s', iss') ("x", ty)+        in  (s'', iss' ,Lam n (App e' (Var n)))+ newLetBinding   :: TyConMap-  -> Heap+  -> Machine   -> Term-  -> (Heap,Id)-newLetBinding tcm h@(Heap gh gbl h' ids is0) e+  -> (Machine, Id)+newLetBinding tcm m e   | Var v <- e-  , Just _ <- lookupVarEnv v h'-  = (h, v)-  | otherwise-  = (Heap gh gbl (extendVarEnv id_ e h') ids' is1,id_)-  where-    ty = termType tcm e-    ((ids',is1),id_) = mkUniqSystemId (ids,is0) ("x",ty)--newLetBindings'-  :: TyConMap-  -> Heap-  -> [Either Term Type]-  -> (Heap,[Either Term Type])-newLetBindings' tcm =-    (second (map (either (Left . toVar) (Right . id))) .) . mapAccumL go-  where-    go h (Left tm)  = second Left (newLetBinding tcm h tm)-    go h (Right ty) = (h,Right ty)--mkAbstr-  :: (Heap,Term)-  -> [Either TyVar Type]-  -> (Heap,Term)-mkAbstr = foldr go-  where-    go (Left tv)  (h,e)          =-      (h,TyLam tv (TyApp e (VarTy tv)))-    go (Right ty) (Heap gh gbl h ids is,e) =-      let ((ids',_),id_) = mkUniqSystemId (ids,is) ("x",ty)-      in  (Heap gh gbl h ids' is,Lam id_ (App e (Var id_)))+  , heapContains LocalId v m+  = (m, v) --- | Force the evaluation of a variable.-force :: Heap -> Stack -> Id -> Maybe State-force (Heap gh g@(GPureHeap gbl) h ids is) k x' = case lookupVarEnv x' h of-    Nothing -> case lookupVarEnv x' gbl of-      Just e | isGlobalId x'-        -> Just (Heap gh (GPureHeap (delVarEnv gbl x')) h ids is,GUpdate x':k,e)-      _ -> Nothing-    Just e -> Just (Heap gh g (delVarEnv h x') ids is,Update x':k,e)-    -- Removing the heap-bound value on a force ensures we do not get stuck on-    -- expressions such as: "let x = x in x"+  | otherwise+  = let m' = heapInsert LocalId id_ e m+     in (m' { mSupply = ids', mScopeNames = is1 }, id_)+ where+  ty = termType tcm e+  ((ids', is1), id_) = mkUniqSystemId (mSupply m, mScopeNames m) ("x", ty)  -- | Unwind the stack by 1 unwind-  :: PrimEvaluator-  -> TyConMap-  -> Heap -> Stack -> Value -> Maybe State-unwind eval tcm h k v = do-  (kf,k') <- uncons k-  case kf of-    Update x                     -> return (update h k' x v)-    GUpdate x                    -> return (gupdate h k' x v)-    Apply x                      -> return (apply  h k' v x)-    Instantiate ty               -> return (instantiate h k' v ty)-    PrimApply nm ty tys vals tms -> primop eval tcm h k' nm ty tys vals v tms-    Scrutinise _ alts            -> return (scrutinise h k' v alts)-    -- Adding back the Tick constructor will make the evaluator loop-    Tickish _                    -> return (h,k',valToTerm v)---- | Update the Heap with the evaluated term-update :: Heap -> Stack -> Id -> Value -> State-update (Heap gh gbl h ids is) k x v = (Heap gh gbl (extendVarEnv x v' h) ids is,k,v')-  where-    v' = valToTerm v---- | Update the Globals with the evaluated term-gupdate :: Heap -> Stack -> Id -> Value -> State-gupdate (Heap gh (GPureHeap gbl) h ids is) k x v =-  (Heap gh (GPureHeap (extendVarEnv x v' gbl)) h ids is,k,v')+  :: TyConMap+  -> Machine+  -> Value+  -> Maybe Machine+unwind tcm m v = do+  (m', kf) <- stackPop m+  go kf m'  where-  v' = valToTerm v--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 nm ty tys vs -> foldl' App (foldl' TyApp (Prim nm ty) tys)-                                 (map valToTerm vs)-  Suspend e            -> e--toVar :: Id -> Term-toVar x = Var x+  go (Update s x)             = return . update s x v+  go (Apply x)                = return . apply v x+  go (Instantiate ty)         = return . instantiate v ty+  go (PrimApply p tys vs tms) = mPrimUnwind m tcm p tys vs v tms+  go (Scrutinise _ as)        = return . scrutinise v as+  go (Tickish _)              = return . setTerm (valToTerm v) -toType :: TyVar -> Type-toType x = VarTy x+-- | Update the Heap with the evaluated term+update :: IdScope -> Id -> Value -> Machine -> Machine+update s x (valToTerm -> term) =+  setTerm term . heapInsert s x term  -- | Apply a value to a function-apply :: Heap -> Stack -> Value -> Id -> State-apply h@(Heap _ _ _ _ is0) k (Lambda x' e) x = (h,k,substTm "Evaluator.apply" subst e)+apply :: Value -> Id -> Machine -> Machine+apply (Lambda x' e) x m =+  setTerm (substTm "Evaluator.apply" subst e) m  where   subst  = extendIdSubst subst0 x' (Var x)-  subst0 = mkSubst (extendInScopeSet is0 x)-apply _ _ _ _ = error "not a lambda"+  subst0 = mkSubst $ extendInScopeSet (mScopeNames m) x +apply _ _ _ = error "Evaluator.apply: Not a lambda"+ -- | Instantiate a type-abstraction-instantiate :: Heap -> Stack -> Value -> Type -> State-instantiate h k (TyLambda x e) ty = (h,k,substTm "Evaluator.instantiate" subst e)+instantiate :: Value -> Type -> Machine -> Machine+instantiate (TyLambda x e) ty =+  setTerm (substTm "Evaluator.instantiate" subst e)  where   subst  = extendTvSubst subst0 x ty-  subst0 = mkSubst is0-  is0    = mkInScopeSet (localFVsOfTerms [e] `unionUniqSet` tyFVsOfTypes [ty])-instantiate _ _ _ _ = error "not a ty lambda"--naturalLiteral :: Value -> Maybe Integer-naturalLiteral v =-  case v of-    Lit (NaturalLiteral i) -> Just i-    DC dc [Left (Literal (WordLiteral i))]-      | dcTag dc == 1-      -> Just i-    DC dc [Left (Literal (ByteArrayLiteral (PV.Vector _ _ (BA.ByteArray ba))))]-      | dcTag dc == 2-      -> Just (Jp# (BN# ba))-    _ -> Nothing--integerLiteral :: Value -> Maybe Integer-integerLiteral v =-  case v of-    Lit (IntegerLiteral i) -> Just i-    DC dc [Left (Literal (IntLiteral i))]-      | dcTag dc == 1-      -> Just i-    DC dc [Left (Literal (ByteArrayLiteral (PV.Vector _ _ (BA.ByteArray ba))))]-      | dcTag dc == 2-      -> Just (Jp# (BN# ba))-      | dcTag dc == 3-      -> Just (Jn# (BN# ba))-    _ -> Nothing+  subst0 = mkSubst iss0+  iss0   = mkInScopeSet (localFVsOfTerms [e] `unionUniqSet` tyFVsOfTypes [ty]) --- | Evaluation of primitive operations-primop-  :: PrimEvaluator-  -> TyConMap-  -> Heap-  -> Stack-  -> Text-  -- ^ Name of the primitive-  -> PrimInfo-  -- ^ Type of the primitive-  -> [Type]-  -- ^ Applied types-  -> [Value]-  -- ^ Applied values-  -> Value-  -- ^ The current value-  -> [Term]-  -- ^ The remaining terms which must be evaluated to a value-  -> Maybe State-primop eval tcm h k nm ty tys vs v []-  | nm `elem` ["Clash.Sized.Internal.Index.fromInteger#"-              ,"GHC.CString.unpackCString#"-              ,"Clash.Transformations.removedArg"-              ,"GHC.Prim.MutableByteArray#"-              ]-              -- The above primitives are actually values, and not operations.-  = unwind eval tcm h k (PrimVal nm ty tys (vs ++ [v]))-  | nm == "Clash.Sized.Internal.BitVector.fromInteger#"-  = case (vs,v) of-    ([naturalLiteral -> Just n,mask], integerLiteral -> Just i) ->-      unwind eval tcm h k (PrimVal nm ty tys [Lit (NaturalLiteral n)-                                             ,mask-                                             ,Lit (IntegerLiteral (wrapUnsigned n i))])-    _ -> error ($(curLoc) ++ "Internal error"  ++ show (vs,v))-  | nm == "Clash.Sized.Internal.BitVector.fromInteger##"-  = case (vs,v) of-    ([mask], integerLiteral -> Just i) ->-      unwind eval tcm h k (PrimVal nm ty tys [mask-                                             ,Lit (IntegerLiteral (wrapUnsigned 1 i))])-    _ -> error ($(curLoc) ++ "Internal error"  ++ show (vs,v))-  | nm == "Clash.Sized.Internal.Signed.fromInteger#"-  = case (vs,v) of-    ([naturalLiteral -> Just n],integerLiteral -> Just i) ->-      unwind eval tcm h k (PrimVal nm ty tys [Lit (NaturalLiteral n)-                                             ,Lit (IntegerLiteral (wrapSigned n i))])-    _ -> error ($(curLoc) ++ "Internal error"  ++ show (vs,v))-  | nm == "Clash.Sized.Internal.Unsigned.fromInteger#"-  = case (vs,v) of-    ([naturalLiteral -> Just n],integerLiteral -> Just i) ->-      unwind eval tcm h k (PrimVal nm ty tys [Lit (NaturalLiteral n)-                                             ,Lit (IntegerLiteral (wrapUnsigned n i))])-    _ -> error ($(curLoc) ++ "Internal error"  ++ show (vs,v))-  | otherwise = eval (isScrut k) tcm h k nm ty tys (vs ++ [v])-primop eval tcm h0 k nm ty tys vs v [e]-  | nm `elem` [ "Clash.Sized.Vector.lazyV"-              , "Clash.Sized.Vector.replicate"-              , "Clash.Sized.Vector.replace_int"-              ]-  = let (h1,i) = newLetBinding tcm h0 e-    in  eval (isScrut k) tcm h1 k nm ty tys (vs ++ [v,Suspend (Var i)])-primop _ _ h k nm ty tys vs v (e:es) =-  Just (h,PrimApply nm ty tys (vs ++ [v]) es:k,e)+instantiate _ _ = error "Evaluator.instantiate: Not a tylambda"  -- | Evaluate a case-expression-scrutinise :: Heap -> Stack -> Value -> [Alt] -> State-scrutinise h k v [] = (h,k,valToTerm v)+scrutinise :: Value -> [Alt] -> Machine -> Machine+scrutinise v [] m = setTerm (valToTerm v) m -- [Note: empty case expressions] -- -- Clash does not have empty case-expressions; instead, empty case-expressions -- are used to indicate that the `whnf` function was called the context of a -- case-expression, which means certain special primitives must be forced. -- See also [Note: forcing special primitives]-scrutinise h k (Lit l) alts = case alts of-  (DefaultPat,altE):alts1 -> (h,k,go altE alts1)-  _ -> (h,k,go (error ("scrutinise: no match " ++-          showPpr (Case (valToTerm (Lit l)) (ConstTy Arrow) alts))) alts)+scrutinise (Lit l) alts m = case alts of+  (DefaultPat, altE):alts1 -> setTerm (go altE alts1) m+  _ -> let term = go (error $ "Evaluator.scrutinise: no match "+                    <> showPpr (Case (valToTerm (Lit l)) (ConstTy Arrow) alts)) alts+        in setTerm term m  where   go def [] = def   go _ ((LitPat l1,altE):_) | l1 == l = altE@@ -567,24 +437,25 @@       in  substTm "Evaluator.scrutinise" subst1 altE   go def (_:alts1) = go def alts1 -scrutinise h k (DC dc xs) alts-  | altE:_ <- [substAlt altDc tvs pxs xs altE+scrutinise (DC dc xs) alts m+  | altE:_ <- [substInAlt altDc tvs pxs xs altE               | (DataPat altDc tvs pxs,altE) <- alts, altDc == dc ] ++               [altE | (DefaultPat,altE) <- alts ]-  = (h,k,altE)+  = setTerm altE m -scrutinise h k v@(PrimVal nm _ _ vs) alts+scrutinise v@(PrimVal p _ vs) alts m   | any (\case {(LitPat {},_) -> True; _ -> False}) alts   = case alts of-      ((DefaultPat,altE):alts1) -> (h,k,go altE alts1)-      _ -> (h,k,go (error ("scrutinise: no match " ++-                showPpr (Case (valToTerm v) (ConstTy Arrow) alts))) alts)+      ((DefaultPat,altE):alts1) -> setTerm (go altE alts1) m+      _ -> let term = go (error $ "Evaluator.scrutinise: no match "+                        <> showPpr (Case (valToTerm v) (ConstTy Arrow) alts)) alts+            in setTerm term m  where   go def [] = def   go _   ((LitPat l1,altE):_) | l1 == l = altE   go def (_:alts1) = go def alts1 -  l = case nm of+  l = case primName p of         "Clash.Sized.Internal.BitVector.fromInteger#"           | [_,Lit (IntegerLiteral 0),Lit l0] <- vs -> l0         "Clash.Sized.Internal.Index.fromInteger#"@@ -595,10 +466,10 @@           | [_,Lit l0] <- vs -> l0         _ -> error ("scrutinise: " ++ showPpr (Case (valToTerm v) (ConstTy Arrow) alts)) -scrutinise _ _ v alts = error ("scrutinise: " ++ showPpr (Case (valToTerm v) (ConstTy Arrow) alts))+scrutinise v alts _ = error ("scrutinise: " ++ showPpr (Case (valToTerm v) (ConstTy Arrow) alts)) -substAlt :: DataCon -> [TyVar] -> [Id] -> [Either Term Type] -> Term -> Term-substAlt dc tvs xs args e = substTm "Evaluator.substAlt" subst e+substInAlt :: DataCon -> [TyVar] -> [Id] -> [Either Term Type] -> Term -> Term+substInAlt dc tvs xs args e = substTm "Evaluator.substInAlt" subst e  where   tys        = rights args   tms        = lefts args@@ -609,53 +480,38 @@   subst0     = mkSubst (mkInScopeSet inScope)  -- | Allocate let-bindings on the heap-allocate :: Heap -> Stack -> [LetBinding] -> Term -> State-allocate (Heap gh gbl h ids is0) k xes e =-  (Heap gh gbl (h `extendVarEnvList` xes') ids' isN,k,e')+allocate :: [LetBinding] -> Term -> Machine -> Machine+allocate xes e m =+  m { mHeapLocal = extendVarEnvList (mHeapLocal m) xes'+    , mSupply = ids'+    , mScopeNames = isN+    , mTerm = e'+    }  where-  xNms     = map fst xes-  is1      = extendInScopeSetList is0 xNms-  (ids',s) = mapAccumL (letSubst h) ids xNms-  (nms,s') = unzip s-  isN      = extendInScopeSetList is1 nms-  subst    = extendIdSubstList subst0 s'-  subst0   = mkSubst (foldl' extendInScopeSet is1 nms)-  xes'     = zip nms (map (substTm "Evaluator.allocate0" subst . snd) xes)-  e'       = substTm "Evaluator.allocate1" subst e+  xNms      = fmap fst xes+  is1       = extendInScopeSetList (mScopeNames m) xNms+  (ids', s) = mapAccumL (letSubst (mHeapLocal m)) (mSupply m) xNms+  (nms, s') = unzip s+  isN       = extendInScopeSetList is1 nms+  subst     = extendIdSubstList subst0 s'+  subst0    = mkSubst (foldl' extendInScopeSet is1 nms)+  xes'      = zip nms (fmap (substTm "Evaluator.allocate0" subst . snd) xes)+  e'        = substTm "Evaluator.allocate1" subst e  -- | Create a unique name and substitution for a let-binder letSubst   :: PureHeap   -> Supply   -> Id-  -> ( Supply-     , (Id,(Id,Term)))+  -> (Supply, (Id, (Id, Term))) letSubst h acc id0 =-  let (acc',id1) = uniqueInHeap h acc id0+  let (acc',id1) = mkUniqueHeapId h acc id0   in  (acc',(id1,(id0,Var id1)))---- | Create a name that's unique in the heap-uniqueInHeap-  :: PureHeap-  -> Supply-  -> Id-  -> (Supply, Id)-uniqueInHeap h ids x = case lookupVarEnv x' h of-  Just _ -> uniqueInHeap h ids' x-  _ -> (ids',x')  where-  (i,ids') = freshId ids-  x'       = modifyVarName (\nm -> nm {nameUniq = i}) x--wrapUnsigned :: Integer -> Integer -> Integer-wrapUnsigned n i = i `mod` sz- where-  sz = 1 `shiftL` fromInteger n+  mkUniqueHeapId :: PureHeap -> Supply -> Id -> (Supply, Id)+  mkUniqueHeapId h' ids x =+    maybe (ids', x') (const $ mkUniqueHeapId h' ids' x) (lookupVarEnv x' h')+   where+    (i,ids') = freshId ids+    x'       = modifyVarName (`setUnique` i) x -wrapSigned :: Integer -> Integer -> Integer-wrapSigned n i = if mask == 0 then 0 else res- where-  mask = 1 `shiftL` fromInteger (n - 1)-  res  = case divMod i mask of-           (s,i1) | even s    -> i1-                  | otherwise -> i1 - mask

@@ -0,0 +1,249 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+  Copyright     : (C) 2020, QBayLogic B.V.+  License       : BSD2 (see the file LICENSE)+  Maintainer    : Christiaan Baaij <christiaan.baaij@gmail.com>++  Types for the Partial Evaluator+-}+module Clash.Core.Evaluator.Types where++import Control.Concurrent.Supply (Supply)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap (insert, lookup)+import Data.List (foldl')+import Data.Maybe (isJust)+import Data.Text.Prettyprint.Doc (hsep)++import Clash.Core.DataCon (DataCon)+import Clash.Core.Literal (Literal(CharLiteral))+import Clash.Core.Pretty (fromPpr)+import Clash.Core.Term (Term(..), PrimInfo(..), TickInfo, Alt)+import Clash.Core.TyCon (TyConMap)+import Clash.Core.Type (Type)+import Clash.Core.Var (Id, IdScope(..), TyVar)+import Clash.Core.VarEnv+import Clash.Pretty (ClashPretty(..), fromPretty)++{- [Note: forcing special primitives]+Clash uses the `whnf` function in two places (for now):++  1. The case-of-known-constructor transformation+  2. The reduceConstant transformation++The first transformation is needed to reach the required normal form. The+second transformation is more of cleanup transformation, so non-essential.++Normally, `whnf` would force the evaluation of all primitives, which is needed+in the `case-of-known-constructor` transformation. However, there are some+primitives which we want to leave unevaluated in the `reduceConstant`+transformation. Such primitives are:++  - Primitives such as `Clash.Sized.Vector.transpose`, `Clash.Sized.Vector.map`,+    etc. that do not reduce to an expression in normal form. Where the+    `reduceConstant` transformation is supposed to be normal-form preserving.+  - Primitives such as `GHC.Int.I8#`, `GHC.Word.W32#`, etc. which seem like+    wrappers around a 64-bit literal, but actually perform truncation to the+    desired bit-size.++This is why the Primitive Evaluator gets a flag telling whether it should+evaluate these special primitives.+-}++type PrimStep+  =  TyConMap+  -> Bool+  -> PrimInfo+  -> [Type]+  -> [Value]+  -> Machine+  -> Maybe Machine++type PrimUnwind+  =  TyConMap+  -> PrimInfo+  -> [Type]+  -> [Value]+  -> Value+  -> [Term]+  -> Machine+  -> Maybe Machine++type PrimEvaluator = (PrimStep, PrimUnwind)++data Machine = Machine+  { mPrimStep   :: PrimStep+  , mPrimUnwind :: PrimUnwind+  , 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 (primType 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++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+  go (Scrutinise{}:_) = True+  go (PrimApply{}:_)  = True+  go (Tickish{}: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 }+

@@ -6,14 +6,12 @@   Free variable calculations -} -{-# LANGUAGE LambdaCase   #-}-{-# LANGUAGE RankNTypes   #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}  module Clash.Core.FreeVars   (-- * Free variable calculation     typeFreeVars-  , termFreeVarsX   , freeIds   , freeLocalVars   , freeLocalIds@@ -30,6 +28,7 @@   , localIdDoesNotOccurIn   , localIdsDoNotOccurIn   , localVarsDoNotOccurIn+  , countFreeOccurances   -- * Internal   , typeFreeVars'   , termFreeVars'@@ -47,7 +46,8 @@ import Clash.Core.Type                  (Type (..)) import Clash.Core.Var   (Id, IdScope (..), TyVar, Var (..), isLocalId)-import Clash.Core.VarEnv                (VarSet, unitVarSet)+import Clash.Core.VarEnv+  (VarEnv, VarSet, emptyVarEnv, unionVarEnvWith, unitVarSet, unitVarEnv)  -- | Gives the free type-variables in a Type, implemented as a 'Fold' --@@ -197,19 +197,6 @@   isTV (TyVar {}) = True   isTV _          = False --- | Gives the free variables of a Term, implemented as a 'Fold'------ The 'Fold' is closed over the types of variables, so:------ @--- foldMapOf termFreeVars unitVarSet (case (x : (a:* -> k) Int)) of {}) = {x, a, k}--- @------ __NB__ this collects both global and local IDs, and you almost __NEVER__ want--- to use this. Use one of the other FV calculations instead-termFreeVarsX :: Fold Term (Var a)-termFreeVarsX = termFreeVars' (const True)- -- | Gives the "interesting" free variables in a Term, implemented as a 'Fold' -- -- The 'Fold' is closed over the types of variables, so:@@ -341,3 +328,11 @@ localFVsOfTerms = foldMap go  where   go = Lens.foldMapOf freeLocalVars unitVarSet++-- | 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))

@@ -8,9 +8,8 @@   Term Literal -} -{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  module Clash.Core.Literal

@@ -6,12 +6,11 @@   Names -} -{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}  module Clash.Core.Name   ( module Clash.Core.Name

@@ -8,10 +8,9 @@ -}  {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE ViewPatterns      #-}-{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE TemplateHaskell #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -30,6 +29,7 @@ where  import Data.Char                        (isSymbol, isUpper, ord)+import Data.Default                     (Default(..)) import Data.Text                        (Text) import Control.Monad.Identity import qualified Data.Text              as T@@ -44,11 +44,11 @@ import Clash.Core.Literal               (Literal (..)) import Clash.Core.Name                  (Name (..)) import Clash.Core.Term-  (Pat (..), Term (..), TickInfo (..), NameMod (..), CoreContext (..), primArg)+  (Pat (..), Term (..), TickInfo (..), NameMod (..), CoreContext (..), primArg, PrimInfo(primName)) import Clash.Core.TyCon                 (TyCon (..), TyConName, isTupleTyConLike) import Clash.Core.Type                  (ConstTy (..), Kind, LitTy (..),                                          Type (..), TypeView (..), tyView)-import Clash.Core.Var                   (Id, TyVar, Var (..))+import Clash.Core.Var                   (Id, TyVar, Var (..), IdScope(..)) import Clash.Util import Clash.Pretty @@ -61,6 +61,12 @@   , displayQualifiers :: Bool   -- ^ whether to display module qualifiers   }+instance Default PrettyOptions where+  def = PrettyOptions+    { displayUniques    = True+    , displayTypes      = True+    , displayQualifiers = True+    }  -- | Annotations carried on pretty-printed code. data ClashAnnotation@@ -160,7 +166,7 @@   pprPrec p (viewName -> (qual, occ, uniq)) = do     qual' <- annotate (AnnSyntax Qualifier) <$> pprPrec p qual     occ'  <- pprPrec p occ-    uniq' <- annotate (AnnSyntax Unique) <$> pprPrec p uniq+    uniq' <- annotate (AnnSyntax Unique) . brackets <$> (pprPrec p uniq)     return $ qual' <> occ' <> uniq'  instance ClashPretty (Name a) where@@ -206,10 +212,13 @@  instance PrettyPrec Term where   pprPrec prec e = case e of-    Var x           -> pprPrec prec (varName x)+    Var x           -> do+      v <- pprPrec prec (varName x)+      s <- pprPrecIdScope x+      pure (v <> brackets s)     Data dc         -> pprPrec prec dc     Literal l       -> pprPrec prec l-    Prim nm _       -> pprPrecPrim prec nm+    Prim p          -> pprPrecPrim prec (primName p)     Lam  v e1       -> annotate (AnnContext $ LamBody v) <$>                          pprPrecLam prec [v] e1     TyLam tv e1     -> annotate (AnnContext $ TyLamBody tv) <$>@@ -229,7 +238,10 @@   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>"  instance PrettyPrec SrcSpan where   pprPrec _ sp = return ("<src>"<>pretty (GHC.showSDocUnsafe (GHC.ppr sp)))@@ -284,6 +296,11 @@     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)@@ -474,4 +491,3 @@  isSymbolASCII :: Char -> Bool isSymbolASCII c = c `elem` ("!#$%&*+./<=>?@\\^|~-" :: String)-

@@ -7,10 +7,9 @@   Capture-free substitution function for CoreHW -} -{-# LANGUAGE CPP               #-}-{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns      #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -40,9 +39,13 @@   , extendGblSubstList     -- ** Applying substitutions   , substTm+  , substAlt+  , substId     -- * Variable renaming   , deShadowTerm+  , deShadowAlt   , freshenTm+  , deshadowLetExpr     -- * Alpha equivalence   , aeqType   , aeqTerm@@ -52,12 +55,13 @@ import           Data.Coerce               (coerce) import           Data.Text.Prettyprint.Doc import qualified Data.List                 as List+import           Data.Ord                  (comparing)  import           Clash.Core.FreeVars   (noFreeVarsOfType, localFVsOfTerms, tyFVsOfTypes) import           Clash.Core.Pretty         (ppr, fromPpr) import           Clash.Core.Term-  (LetBinding, Pat (..), Term (..), TickInfo (..))+  (LetBinding, Pat (..), Term (..), TickInfo (..), PrimInfo(primName)) import           Clash.Core.Type           (Type (..)) import           Clash.Core.VarEnv import           Clash.Core.Var            (Id, Var (..), TyVar, isGlobalId)@@ -488,7 +492,31 @@    goTick t@(SrcSpan _)  = t   goTick (NameMod m ty) = NameMod m (substTy subst ty)+  goTick t@DeDup        = t+  goTick t@NoDeDup      = t +-- | Substitute within a case-alternative+substAlt+  :: HasCallStack+  => Doc ()+  -> Subst+  -- ^ The substitution+  -> (Pat, Term)+  -- ^ The alternative in which to apply the substitution+  -> (Pat, Term)+substAlt doc subst (pat,alt) = case pat of+  DataPat dc tvs ids -> case List.mapAccumL substTyVarBndr' subst tvs of+    (subst1,tvs1) -> case List.mapAccumL substIdBndr subst1 ids of+      (subst2,ids1) -> (DataPat dc tvs1 ids1,substTm doc subst2 alt)+  _ -> (pat, substTm doc subst alt)++substId+  :: HasCallStack+  => Subst+  -> Id+  -> Id+substId subst oldId = snd $ substIdBndr subst oldId+ -- | Find the substitution for an 'Id' in the 'Subst' lookupIdSubst   :: HasCallStack@@ -502,7 +530,14 @@                      _      -> Var v   | Just e <- lookupVarEnv v tmS = e   -- Vital! See 'IdSubstEnv' Note [Extending the Subst]-  | Just v' <- lookupInScope inScope v = Var (coerce v')+  --+  -- 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 @@ -587,6 +622,32 @@   -> 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+  -> [LetBinding]+  -- ^ Bindings of the let-expression+  -> Term+  -- ^ The body of the let-expression+  -> ([LetBinding],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. --@@ -678,6 +739,12 @@   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 _ t1) (AnnType _ t2) =+    -- XXX: maybe ignore annotations, like we ignore ticks, i.e.+    --+    -- go env (AnnType t1) t2 = go env t1 t2+    -- go env t1 (AnnType t2) = go env t1 t2+    go env t1 t2   go _ t1 t2 = compare (getRank t1) (getRank t2)    getRank :: Type -> Word@@ -732,7 +799,7 @@   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 _) = compare p1 p2+  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

@@ -7,13 +7,11 @@   Term representation in the CoreHW language: System F + LetRec + Case -} -{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE ViewPatterns          #-}+{-# LANGUAGE TemplateHaskell #-}  module Clash.Core.Term   ( Term (..)@@ -24,8 +22,8 @@   , TickInfo (..), NameMod (..)   , PrimInfo (..)   , WorkInfo (..)-  , CoreContext (..), Context, isLambdaBodyCtx, isTickCtx-  , collectArgs, collectArgsTicks, collectTicks, primArg+  , CoreContext (..), Context, isLambdaBodyCtx, isTickCtx, walkTerm+  , collectArgs, collectArgsTicks, collectTicks, collectTermIds, primArg   , partitionTicks   ) where@@ -33,7 +31,9 @@ -- External Modules import Control.DeepSeq import Data.Binary                             (Binary)+import qualified Data.DList                    as DList import Data.Either                             (lefts, rights)+import Data.Maybe                              (catMaybes) import Data.Hashable                           (Hashable) import Data.List                               (partition) import Data.Text                               (Text)@@ -53,7 +53,7 @@   = Var     !Id                             -- ^ Variable reference   | Data    !DataCon                        -- ^ Datatype constructor   | Literal !Literal                        -- ^ Literal-  | Prim    !Text !PrimInfo                 -- ^ Primitive+  | Prim    !PrimInfo                       -- ^ Primitive   | Lam     !Id Term                        -- ^ Term-abstraction   | TyLam   !TyVar Term                     -- ^ Type-abstraction   | App     !Term !Term                     -- ^ Application@@ -71,6 +71,11 @@   | NameMod !NameMod !Type   -- ^ Modifier for naming module instantiations and registers, are added by   -- the user by using the functions @Clash.Magic.[prefixName,suffixName,setName]@+  | DeDup+  -- ^ Deduplicate, i.e. try to share expressions between multiple branches.+  | NoDeDup+  -- ^ Do not deduplicate, i.e. /keep/, an expression inside a case-alternative;+  -- do not try to share expressions between multiple branches.   deriving (Eq,Show,Generic,NFData,Hashable,Binary)  -- | Tag to indicate which instance/register name modifier was used@@ -79,16 +84,17 @@   -- ^ @Clash.Magic.prefixName@   | SuffixName   -- ^ @Clash.Magic.suffixName@+  | SuffixNameP+  -- ^ @Clash.Magic.suffixNameP@   | SetName   -- ^ @Clash.Magic.setName@   deriving (Eq,Show,Generic,NFData,Hashable,Binary) -data PrimInfo-  = PrimInfo-  { primType     :: !Type+data PrimInfo = PrimInfo+  { primName     :: !Text+  , primType     :: !Type   , primWorkInfo :: !WorkInfo-  }-  deriving (Show,Generic,NFData,Hashable,Binary)+  } deriving (Show,Generic,NFData,Hashable,Binary)  data WorkInfo   = WorkConstant@@ -225,8 +231,8 @@   -- ^ If @Term@ was a primitive: (name of primitive, #type args, #term args) primArg (collectArgs -> t) =   case t of-    (Prim nm _, args) ->-      Just (nm, length (rights args), length (lefts args))+    (Prim p, args) ->+      Just (primName p, length (rights args), length (lefts args))     _ ->       Nothing @@ -236,3 +242,46 @@   -> ([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 _ -> pure (f t1)+    Letrec bndrs t1 -> pure (f t1) <> mconcat (map (go . snd) bndrs)+    Case t1 _ alts -> pure (f t1) <> mconcat (map (go . snd) alts)+    Cast t1 _ _ -> go t1+    Tick _ t1 -> pure (f 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 (Letrec bndrs _) = map 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 = []

@@ -0,0 +1,96 @@+{-|+Copyright   :  (C) 2019, Myrtle Software Ltd+License     :  BSD2 (see the file LICENSE)+Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>++Tools to convert a 'Term' into its "real" representation+-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Core.TermLiteral+  ( TermLiteral+  , termToData+  , termToDataError+  , uncheckedTermToData+  ) where++import qualified Data.Text                       as Text+import           Data.Text                       (Text)+import           Data.Bifunctor                  (bimap)+import           Data.Either                     (lefts)+import           GHC.Natural+import           GHC.Stack++import           Clash.Core.Term                 (Term(Literal), collectArgs)+import           Clash.Core.Literal+import           Clash.Core.Pretty               (showPpr)++import           Clash.Core.TermLiteral.TH++-- | 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.++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 t = Text.pack <$> termToData t++instance TermLiteral Int where+  termToData (collectArgs -> (_, [Left (Literal (IntLiteral n))])) =+    Right (fromInteger n)+  termToData t = Left t++instance TermLiteral Integer where+  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 (collectArgs -> (_, [Left (Literal (NaturalLiteral n))])) =+    Right (fromInteger n)+  termToData t = Left t++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++instance TermLiteral a => TermLiteral (Maybe a) where+  termToData = $(deriveTermToData ''Maybe)++instance TermLiteral Bool where+  termToData = $(deriveTermToData ''Bool)++-- | Same as 'termToData', but returns printable error message if it couldn't+-- translate a term.+termToDataError :: TermLiteral a => Term -> Either String a+termToDataError term = bimap err id (termToData term)+ where+  err failedTerm =+    "Failed to translate term to literal. Term that failed to translate:\n\n"+    ++ showPpr failedTerm ++ "\n\nIn the full term:\n\n" ++ showPpr term++-- | Same as 'termToData', but errors hard if it can't translate a given term+-- to data.+uncheckedTermToData :: TermLiteral a => Term -> a+uncheckedTermToData = either error id . termToDataError

@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskellQuotes #-}++module Clash.Core.TermLiteral.TH+  (  deriveTermToData+  ) where++import           Data.Either+import qualified Data.Text                       as Text+import           Language.Haskell.TH.Syntax++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 ()++dcName' :: DataCon -> String+dcName' = Text.unpack . nameOcc . dcName++termToDataName :: Name+termToDataName = mkName "Clash.Core.TermLiteral.termToData"++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' c = error $ "Unexpected constructor: " ++ show c++deriveTermToData1 :: [(Name, Int)] -> Exp+deriveTermToData1 constrs =+  LamE+    [pat]+    (if null args then theCase else LetE args theCase)+ where+  nArgs = maximum (map snd constrs)++  args :: [Dec]+  args = zipWith (\n nm -> ValD (VarP nm) (NormalB (arg n)) []) [0..] 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 (head argNames))+  mkCall cName nFields =+    foldl+      (\e aName ->+        UInfixE+          e+          (VarE '(<*>))+          (VarE termToDataName `AppE` VarE aName))+      (mkCall cName 1)+      (take (nFields-1) (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 = [mkName ("arg" ++ show n) | n <- [0..nArgs-1]]+  nameName = mkName "nm"+

@@ -6,10 +6,9 @@   Type Constructors in CoreHW -} -{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}  module Clash.Core.TyCon

@@ -8,16 +8,14 @@   Types in CoreHW -} -{-# LANGUAGE CPP                   #-}-{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MagicHash             #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns        #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE ViewPatterns          #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}  module Clash.Core.Type   ( Type (..)@@ -35,6 +33,7 @@   , typeKind   , mkTyConTy   , mkFunTy+  , mkPolyFunTy   , mkTyConApp   , splitFunTy   , splitFunTys@@ -82,7 +81,8 @@ import           PrelNames   (integerTyConKey, typeNatAddTyFamNameKey, typeNatExpTyFamNameKey,    typeNatLeqTyFamNameKey, typeNatMulTyFamNameKey, typeNatSubTyFamNameKey,-   typeNatCmpTyFamNameKey)+   typeNatCmpTyFamNameKey,+   typeSymbolAppendFamNameKey, typeSymbolCmpTyFamNameKey) import           SrcLoc                 (wiredInSrcSpan) import           Unique                 (getKey) @@ -165,13 +165,48 @@ -- 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-tyView ty@(AppTy _ _) = case splitTyAppM ty of-  Just (ConstTy Arrow, [ty1,ty2]) -> FunTy ty1 ty2-  Just (ConstTy Arrow, [_,_,ty1,ty2]) -> FunTy ty1 ty2 -- See Note [Arrow arguments]-  Just (ConstTy (TyCon tc), args) -> TyConApp tc args-  _ -> OtherType ty-tyView (ConstTy (TyCon tc)) = TyConApp tc []-tyView t = OtherType t+-- 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).@@ -302,6 +337,16 @@     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@@ -352,17 +397,6 @@ applyFunTy _ (tyView -> FunTy _ resTy) _    = resTy applyFunTy _ _ _ = error $ $(curLoc) ++ "Report as bug: not a FunTy" --- | 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@@ -490,6 +524,18 @@         EQ -> Name User "GHC.Types.EQ" (getKey ordEQDataConKey) wiredInSrcSpan         GT -> Name User "GHC.Types.GT" (getKey ordGTDataConKey) wiredInSrcSpan +  | nameUniq tc == getKey typeSymbolCmpTyFamNameKey -- "GHC.TypeNats.CmpSymbol"+  , [s1, s2] <- mapMaybe (symLitView tcm) tys+  = Just $ ConstTy $ TyCon $+      case compare s1 s2 of+        LT -> Name User "GHC.Types.LT" (getKey ordLTDataConKey) wiredInSrcSpan+        EQ -> Name User "GHC.Types.EQ" (getKey ordEQDataConKey) wiredInSrcSpan+        GT -> Name User "GHC.Types.GT" (getKey ordGTDataConKey) wiredInSrcSpan++  | nameUniq tc == getKey typeSymbolAppendFamNameKey  -- GHC.TypeLits.AppendSymbol"+  , [s1, s2] <- mapMaybe (symLitView tcm) tys+  = Just (LitTy (SymTy (s1 ++ s2)))+   | nameOcc tc `elem` ["GHC.TypeLits.Extra.FLog", "GHC.TypeNats.FLog"]   , [i1, i2] <- mapMaybe (litView tcm) tys   , i1 > 1@@ -547,6 +593,11 @@ 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  -- | The type @forall a . a@ undefinedTy ::Type

@@ -7,7 +7,7 @@   Builtin Type and Kind definitions -} -{-# LANGUAGE CPP               #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}  module Clash.Core.TysPrim

@@ -6,11 +6,11 @@   Smart constructor and destructor functions for CoreHW -} -{-# LANGUAGE CPP               #-}-{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}-{-# LANGUAGE ViewPatterns      #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}  module Clash.Core.Util where @@ -18,28 +18,35 @@ import qualified Control.Lens                  as Lens import Control.Monad.Trans.Except              (Except, throwE) import           Data.Coerce                   (coerce)-import qualified Data.IntSet                   as IntSet import qualified Data.HashSet                  as HashSet+import qualified Data.Graph                    as Graph import Data.List   (foldl', mapAccumR, elemIndices, nub)-import Data.Maybe                              (fromJust, mapMaybe, catMaybes)+import Data.Maybe+  (fromJust, isJust, mapMaybe, catMaybes)+import qualified Data.Set                      as Set+import qualified Data.Set.Lens                 as Lens+import qualified Data.String.Interpolate       as I import qualified Data.Text                     as T import           Data.Text.Prettyprint.Doc     (line) #if !MIN_VERSION_base(4,11,0) import           Data.Semigroup #endif +import           PrelNames               (ipClassKey)+import           Unique                  (getKey)+ import Clash.Core.DataCon   (DataCon (MkData), dcType, dcUnivTyVars, dcExtTyVars, dcArgTys) import Clash.Core.FreeVars-  (termFreeVarsX, tyFVsOfTypes, typeFreeVars)+  (tyFVsOfTypes, typeFreeVars, freeLocalIds) import Clash.Core.Literal                      (literalType) import Clash.Core.Name   (Name (..), OccName, mkUnsafeInternalName, mkUnsafeSystemName) import Clash.Core.Pretty                       (ppr, showPpr) import Clash.Core.Subst   (extendTvSubst, mkSubst, mkTvSubst, substTy, substTyWith,-   substTyInVar, extendTvSubstList)+   substTyInVar, extendTvSubstList, aeqType) import Clash.Core.Term   (LetBinding, Pat (..), PrimInfo (..), Term (..), Alt, WorkInfo (..),    TickInfo (..), collectArgs)@@ -277,7 +284,7 @@   Var t          -> varType t   Data dc        -> dcType dc   Literal l      -> literalType l-  Prim _ t       -> primType t+  Prim t         -> primType t   Lam v e'       -> mkFunTy (varType v) (termType m e')   TyLam tv e'    -> ForAllTy tv (termType m e')   App _ _        -> case collectArgs e of@@ -326,7 +333,8 @@ -- Do not iterate 'piResultTy', because it's inefficient to substitute one -- variable at a time; instead use 'piResultTys' piResultTy-  :: TyConMap+  :: HasCallStack+  => TyConMap   -> Type   -> Type   -> Type@@ -339,15 +347,26 @@ -- Do not iterate 'piResultTyMaybe', because it's inefficient to substitute one -- variable at a time; instead use 'piResultTys' piResultTyMaybe-  :: TyConMap+  :: HasCallStack+  => TyConMap   -> Type   -> Type   -> Maybe Type piResultTyMaybe m ty arg   | Just ty' <- coreView1 m ty   = piResultTyMaybe m ty' arg-  | FunTy _ res <- tyView ty-  = Just res+  | FunTy a res <- tyView ty+  = if debugIsOn && not (aeqType a arg) then error [I.i|+      Unexpected application. A function with type:++        #{showPpr ty}++      Got applied to an argument of type:++        #{showPpr arg}+    |]+    else+      Just res   | ForAllTy tv res <- ty   = let emptySubst = mkSubst (mkInScopeSet (tyFVsOfTypes [arg,res]))     in  Just (substTy (extendTvSubst emptySubst tv arg) res)@@ -378,7 +397,8 @@ -- For efficiency reasons, when there are no foralls, we simply drop arrows from -- a function type/kind. piResultTys-  :: TyConMap+  :: HasCallStack+  => TyConMap   -> Type   -> [Type]   -> Type@@ -386,8 +406,18 @@ piResultTys m ty origArgs@(arg:args)   | Just ty' <- coreView1 m ty   = piResultTys m ty' origArgs-  | FunTy _ res <- tyView ty-  = piResultTys m res args+  | FunTy a res <- tyView ty+  = if debugIsOn && not (aeqType a 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@@ -592,15 +622,6 @@                                                    ,resTy                                                    ,(LitTy (NumTy (n-1)))]) --availableUniques-  :: Term-  -> [Unique]-availableUniques t = [ n | n <- [0..] , n `IntSet.notMember` avoid ]- where-  avoid = Lens.foldMapOf termFreeVarsX (\a i -> IntSet.insert (varUniq a) i) t-            IntSet.empty- -- | 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@@ -793,6 +814,17 @@      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@@ -907,13 +939,13 @@ primCo   :: Type   -> Term-primCo ty = Prim "_CO_" (PrimInfo ty WorkNever)+primCo ty = Prim (PrimInfo "_CO_" ty WorkNever)  -- | Make an undefined term undefinedTm   :: Type   -> Term-undefinedTm = TyApp (Prim "Clash.Transformations.undefined" (PrimInfo undefinedTy WorkNever))+undefinedTm = TyApp (Prim (PrimInfo "Clash.Transformations.undefined" undefinedTy WorkNever))  substArgTys   :: DataCon@@ -933,12 +965,145 @@ stripTicks (Tick _ e) = stripTicks e stripTicks e = e --- | Try to reduce an arbitrary type to a Symbol, and subsequently extract its--- String representation-tySym+-- | 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-tySym m (coreView1 m -> Just ty) = tySym m ty-tySym _ (LitTy (SymTy s))        = return s-tySym _ ty = throwE $ $(curLoc) ++ "Cannot reduce to a string:\n" ++ showPpr ty+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++-- | 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,[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 2., creates a value of the examined type+  --+  -- 2. 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), [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,[Type])+shouldSplit0 tcm (TyConApp tcNm tyArgs)+  | Just tc <- lookupUniqMap tcNm tcm+  , [dc] <- tyConDataCons tc+  , let dcArgs  = substArgTys dc tyArgs+  , let dcArgVs = map (tyView . coreView tcm) dcArgs+  = if any shouldSplitTy dcArgVs && not (isHidden tcNm tyArgs) then+      Just (mkApps (Data dc) (map Right tyArgs), dcArgs)+    else+      Nothing+ where+  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 practise this means only+  -- TODO: HiddenClock, HiddenReset, and HiddenEnable are handled. If a user were+  -- TODO: to define their own versions with -for example- the elements of the+  -- TODO: tuple swapped, 'isHidden' wouldn't recognize it. We could generalize+  -- TODO: this in the future.+  --+  isHidden :: Name a -> [Type] -> Bool+  isHidden nm [a1, a2] | TyConApp a2Nm _ <- tyView a2 =+       nameOcc nm == "GHC.Classes.(%,%)"+    && splitTy (tyView (stripIP a1))+    && nameOcc a2Nm == "Clash.Signal.Internal.KnownDomain"+  isHidden _ _ = False++  -- Currently we're only interested in splitting of Clock, Reset, and Enable+  splitTy (TyConApp tcNm0 _)+    = nameOcc tcNm0 `elem` [ "Clash.Signal.Internal.Clock"+                           , "Clash.Signal.Internal.Reset"+                           , "Clash.Signal.Internal.Enable"+                           -- iverilog doesn't like it when we put file handles+                           -- in a bitvector, so we need to make sure Clash+                           -- splits them off+                           , "Clash.Explicit.SimIO.File"+                           , "GHC.IO.Handle.Types.Handle"+                           ]+  splitTy _ = False++shouldSplit0 _ _ = Nothing++-- | Potentially split apart a list of function argument types. e.g. given:+--+-- > [Int,(Clock,(Reset,Bool)),Char]+--+-- we return+--+-- > [Int,Clock,Reset,Bool,Char]+--+-- But we would leave+--+-- > [Int, (Bool,Int), Char]+--+-- unchanged.+splitShouldSplit+  :: TyConMap+  -> [Type]+  -> [Type]+splitShouldSplit tcm = foldr go []+ where+  go ty rest = case shouldSplit tcm ty of+    Just (_,tys) -> splitShouldSplit tcm tys ++ rest+    Nothing      -> ty : rest++-- | Strip implicit parameter wrappers (IP)+stripIP :: Type -> Type+stripIP t@(tyView -> TyConApp tcNm [_a1, a2]) =+  if nameUniq tcNm == getKey ipClassKey then a2 else t+stripIP t = t++-- | Do an inverse topological sorting of the let-bindings in a let-expression+inverseTopSortLetBindings+  :: HasCallStack+  => Term+  -> Term+inverseTopSortLetBindings (Letrec bndrs0 res) =+  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  Letrec bndrs1 res+ 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 :)++inverseTopSortLetBindings e = e+{-# SCC inverseTopSortLetBindings #-}

@@ -7,12 +7,10 @@   Variables in CoreHW -} -{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE ExplicitForAll        #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE NamedFieldPuns        #-}-{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}  module Clash.Core.Var   ( Attr' (..)

@@ -1,9 +1,8 @@-{-# LANGUAGE DeriveAnyClass             #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-}  module Clash.Core.VarEnv   ( -- * Environment with variables as keys@@ -14,6 +13,7 @@     -- ** Indexing   , lookupVarEnv   , lookupVarEnv'+  , lookupVarEnvDirectly     -- ** Construction   , emptyVarEnv   , unitVarEnv@@ -30,6 +30,8 @@     -- *** Mapping   , mapVarEnv   , mapMaybeVarEnv+    -- ** Folding+  , foldlWithUniqueVarEnv'     -- ** Working with predicates     -- *** Searching   , elemVarEnv@@ -52,6 +54,7 @@     -- ** Conversions     -- *** Lists   , mkVarSet+  , eltsVarSet     -- * In-scope sets   , InScopeSet     -- ** Accessors@@ -127,6 +130,13 @@   -> Maybe a lookupVarEnv = lookupUniqMap +-- | Lookup a value based on the unique of a variable+lookupVarEnvDirectly+  :: Unique+  -> VarEnv a+  -> Maybe a+lookupVarEnvDirectly = lookupUniqMap+ -- | Lookup a value based on the variable -- -- Errors out when the variable is not present@@ -220,6 +230,15 @@   -> VarEnv b mapMaybeVarEnv = mapMaybeUniqMap +-- | 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' = foldlWithUnique'+ -- | Extract the elements eltsVarEnv   :: VarEnv a@@ -312,6 +331,11 @@   :: [Var a]   -> VarSet mkVarSet xs = mkUniqSet (coerce xs)++eltsVarSet+  :: VarSet+  -> [Var Any]+eltsVarSet = eltsUniqSet  -- * InScopeSet 

@@ -8,16 +8,18 @@   Module that connects all the parts of the Clash compiler library -} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE ScopedTypeVariables      #-}-{-# LANGUAGE TupleSections            #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}  module Clash.Driver where  import qualified Control.Concurrent.Supply        as Supply import           Control.DeepSeq-import           Control.Exception                (tryJust, bracket)-import           Control.Lens                     (view, (^.), _4)+import           Control.Exception                (tryJust, bracket, throw)+import           Control.Lens                     (view, _4)+import qualified Control.Monad                    as Monad import           Control.Monad                    (guard, when, unless, foldM) import           Control.Monad.Catch              (MonadMask) import           Control.Monad.IO.Class           (MonadIO)@@ -31,6 +33,7 @@ import           Data.List                        (intercalate) import           Data.Maybe                       (fromMaybe) import           Data.Semigroup.Monad+import qualified Data.Set                         as Set import qualified Data.Text import           Data.Text.Lazy                   (Text) import qualified Data.Text.Lazy                   as Text@@ -41,6 +44,7 @@    renderOneLine) import qualified Data.Time.Clock                  as Clock 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.Environment               (getExecutablePath)@@ -53,38 +57,150 @@ import           Text.Trifecta.Result   (Result(Success, Failure), _errDoc) import           Text.Read                        (readMaybe)++import           PrelNames               (eqTyConKey, ipClassKey)+import           Unique                  (getKey)+ import           SrcLoc                           (SrcSpan)+import           Util                             (OverridingBool(Auto)) import           GHC.BasicTypes.Extra             ()  import           Clash.Annotations.Primitive   (HDL (..)) import           Clash.Annotations.BitRepresentation.Internal   (CustomReprs)-import           Clash.Annotations.TopEntity      (TopEntity (..))+import           Clash.Annotations.TopEntity+  (TopEntity (..), PortName(PortName, PortProduct)) import           Clash.Annotations.TopEntity.Extra () import           Clash.Backend-import           Clash.Core.Evaluator             (PrimEvaluator)+import           Clash.Core.Evaluator.Types       (PrimStep, PrimUnwind) import           Clash.Core.Name                  (Name (..))+import           Clash.Core.Pretty                (PrettyOptions(..), showPpr') import           Clash.Core.Term                  (Term)-import           Clash.Core.Type                  (Type)+import           Clash.Core.Type+  (Type(ForAllTy, LitTy, AnnType), TypeView(..), tyView, mkFunTy, LitTy(SymTy)) import           Clash.Core.TyCon                 (TyConMap, TyConName)-import           Clash.Core.Var                   (Id, varName)-import           Clash.Core.VarEnv                (emptyVarEnv)+import           Clash.Core.Util                  (shouldSplit)+import           Clash.Core.Var+  (Id, varName, varUniq, varType)+import           Clash.Core.VarEnv+  (elemVarEnv, emptyVarEnv, lookupVarEnv) import           Clash.Driver.Types import           Clash.Netlist                    (genNetlist) import           Clash.Netlist.Util               (genComponentName, genTopComponentName) import           Clash.Netlist.BlackBox.Parser    (runParse) import           Clash.Netlist.BlackBox.Types     (BlackBoxTemplate, BlackBoxFunction) import           Clash.Netlist.Types-  (BlackBox (..), Component (..), Identifier, FilteredHWType, HWMap)+  (BlackBox (..), Component (..), Identifier, FilteredHWType, HWMap,+   SomeBackend (..), TopEntityT(..), TemplateFunction, ComponentPrefix(..)) import           Clash.Normalize                  (checkNonRecursive, cleanupGraph,                                                    normalize, runNormalization)-import           Clash.Normalize.Util             (callGraph)+import           Clash.Normalize.Util             (callGraph, tvSubstWithTyEq)+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           Clash.Primitives.Types import           Clash.Primitives.Util            (hashCompiledPrimMap) import           Clash.Unique                     (keysUniqMap, lookupUniqMap')-import           Clash.Util                       (first, reportTimeDiff)+import           Clash.Util.Interpolate           (i)+import           Clash.Util+  (ClashException(..), HasCallStack, first, reportTimeDiff,+   wantedLanguageExtensions, unwantedLanguageExtensions, debugIsOn)+import           Clash.Util.Graph                 (reverseTopSort) +-- | 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|+              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) a}++              Given port annotation: #{p}. You might want to use the+              following instead: PortProduct #{show nm} []. This allows Clash to+              autogenerate names based on the name #{show nm}.+            |])+      _ ->+        -- No need to split the port, carrying on..+        p : go res ps+  go (ForAllTy _tyVar ty) ps = go ty ps+  go _ty ps = ps++  prependName :: String -> PortName -> PortName+  prependName "" pn = pn+  prependName p (PortProduct nm ps) = PortProduct (p ++ "_" ++ nm) ps+  prependName p (PortName nm) = PortName (p ++ "_" ++ nm)++  -- Returns True for+  --   * type equality constraints (~)+  --   * HasCallStack+  shouldNotHavePortName :: Type -> Bool+  shouldNotHavePortName (tyView -> TyConApp (nameUniq -> tcUniq) tcArgs)+    | tcUniq == getKey eqTyConKey = True+    | tcUniq == getKey ipClassKey+    , [LitTy (SymTy "callStack"), _] <- tcArgs = True+  shouldNotHavePortName _ = False++splitTopAnn tcm sp (ForAllTy _tyVar typ) t = splitTopAnn tcm sp typ t+splitTopAnn tcm sp (AnnType _anns typ) t = splitTopAnn tcm sp typ t+splitTopAnn _tcm _sp _typ t = t++-- When splitting up a single argument into multiple arguments (see docs of+-- 'separateArguments') we should make sure to update TopEntity annotations+-- accordingly. See: https://github.com/clash-lang/clash-compiler/issues/1033+splitTopEntityT+  :: HasCallStack+  => TyConMap+  -> BindingMap+  -> TopEntityT+  -> TopEntityT+splitTopEntityT tcm bindingsMap tt@(TopEntityT id_ (Just t@(Synthesize {})) _) =+  case lookupVarEnv id_ bindingsMap of+    Just (Binding _id sp _ _) ->+      tt{topAnnotation=Just (splitTopAnn tcm sp (varType id_) t)}+    Nothing ->+      error "Internal error in 'splitTopEntityT'. Please report as a bug."+splitTopEntityT _ _ t = t+ -- | Get modification data of current clash binary. getClashModificationDate :: IO Clock.UTCTime getClashModificationDate = Directory.getModificationTime =<< getExecutablePath@@ -105,27 +221,27 @@   -> (CustomReprs -> TyConMap -> Type ->       State HWMap (Maybe (Either String FilteredHWType)))   -- ^ Hardcoded 'Type' -> 'HWType' translator-  -> PrimEvaluator+  -> (PrimStep, PrimUnwind)   -- ^ Hardcoded evaluator (delta-reduction)-  -> [( Id-      , Maybe TopEntity-      , Maybe Id-      )]-  -- ^ topEntity bndr-  -- + (maybe) TopEntity annotation-  -- + (maybe) testBench bndr+  -> [TopEntityT]+  -- ^ Topentities and associated testbench   -> ClashOpts   -- ^ Debug information level for the normalization process   -> (Clock.UTCTime,Clock.UTCTime)   -> IO () generateHDL reprs bindingsMap hdlState primMap tcm tupTcm typeTrans eval-  topEntities opts (startTime,prepTime) = go prepTime HashMap.empty topEntities where+  topEntities0 opts (startTime,prepTime) =+    go prepTime HashMap.empty (sortTop bindingsMap topEntities2)+ where+  topEntities1 = map (splitTopEntityT tcm bindingsMap) topEntities0+  -- Remove forall's used in type equality constraints+  topEntities2 = map (\(TopEntityT var annM tbM) -> TopEntityT var{varType=tvSubstWithTyEq (varType var)} annM tbM) topEntities1    go prevTime _ [] = putStrLn $ "Clash: Total compilation took " ++                                 reportTimeDiff prevTime startTime    -- Process the next TopEntity-  go prevTime seen ((topEntity,annM,benchM):topEntities') = do+  go prevTime seen (TopEntityT topEntity annM benchM:topEntities') = do   let topEntityS = Data.Text.unpack (nameOcc (varName topEntity))   putStrLn $ "Clash: Compiling " ++ topEntityS @@ -137,19 +253,19 @@             -- Prefix top names with 'p', prefix other with 'p_tname'             Just ann ->               let nm = p ++ ('_':t_name ann)-              in  (nm,(Just (Data.Text.pack p),Just (Data.Text.pack nm)))+              in  (nm,ComponentPrefix (Just (Data.Text.pack p)) (Just (Data.Text.pack nm)))             -- Prefix top names with 'p', prefix other with 'p'-            _ ->  (p ++ '_':modName1,(Just (Data.Text.pack p),Just (Data.Text.pack p)))+            _ ->  (p ++ '_':modName1,ComponentPrefix (Just (Data.Text.pack p)) (Just (Data.Text.pack p)))           | Just ann <- annM -> case hdlKind (undefined :: backend) of               -- Prefix other with 't_name'-              VHDL -> (t_name ann,(Nothing,Just (Data.Text.pack (t_name ann))))-              _    -> (t_name ann,(Nothing,Nothing))+              VHDL -> (t_name ann,ComponentPrefix Nothing (Just (Data.Text.pack (t_name ann))))+              _    -> (t_name ann,ComponentPrefix Nothing Nothing)         _ -> case annM of           Just ann -> case hdlKind (undefined :: backend) of-            VHDL -> (t_name ann, (Nothing,Nothing))+            VHDL -> (t_name ann, ComponentPrefix Nothing Nothing)             -- Prefix other with 't_name'-            _    -> (t_name ann, (Nothing,Just (Data.Text.pack (t_name ann))))-          _ -> (modName1, (Nothing,Nothing))+            _    -> (t_name ann, ComponentPrefix Nothing (Just (Data.Text.pack (t_name ann))))+          _ -> (modName1, ComponentPrefix Nothing Nothing)       iw        = opt_intWidth opts       hdlsyn    = opt_hdlSyn opts       escpIds   = opt_escapedIds opts@@ -169,17 +285,51 @@   unless (opt_cachehdl opts) $ putStrLn "Clash: Ignoring .manifest files"    -- Calculate the hash over the callgraph and the topEntity annotation-  (sameTopHash,sameBenchHash,manifest) <- do+  (useCacheTop,useCacheBench,manifest) <- do     clashModDate <- getClashModificationDate      let primMapHash = hashCompiledPrimMap primMap +    let optsHash = hash opts { -- Ignore the following settings, they don't+                               -- affect the generated HDL:+                               -- 1. Debug+                               opt_dbgLevel           = DebugNone+                             , opt_dbgTransformations = Set.empty+                               -- 2. Caching+                             , opt_cachehdl           = True+                               -- 3. Warnings+                             , opt_primWarn           = True+                             , opt_color              = Auto+                             , opt_errorExtra         = False+                             , opt_checkIDir          = True+                               -- Ignore the following settings, they don't+                               -- affect the generated HDL. However, they do+                               -- influence whether HDL can be generated at all.+                               --+                               -- So later on we 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.+                               --+                               -- 1. termination measures+                             , opt_inlineLimit       = 20+                             , opt_specLimit         = 20+                               -- 2. Float support+                             , opt_floatSupport      = False+                               -- 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+                             }+     let       topHash =         hash ( annM              , primMapHash              , show clashModDate              , callGraphBindings bindingsMap topEntity+             , optsHash              )      let@@ -188,9 +338,10 @@           Nothing -> Nothing           Just bench ->             let terms = callGraphBindings bindingsMap bench in-            Just (hash (annM, primMapHash, show clashModDate, terms))+            Just (hash (annM, primMapHash, show clashModDate, terms, optsHash)) -    let manifestI  = Manifest (topHash,benchHashM) [] [] [] [] []+    let succesFlagsI = (opt_inlineLimit opts,opt_specLimit opts,opt_floatSupport opts)+        manifestI    = Manifest (topHash,benchHashM) succesFlagsI [] [] [] [] []      let       manFile =@@ -203,19 +354,27 @@             else (>>= readMaybe) . either (const Nothing) Just <$>               tryJust (guard . isDoesNotExistError) (readFile manFile)     return (maybe (False,False,manifestI)-                  (\man -> (fst (manifestHash man) == topHash-                           ,snd (manifestHash man) == benchHashM-                           ,man {manifestHash = (topHash,benchHashM)}-                           ))+                  (\man ->+                    let allowCache (inl0,spec0,fl0) (inl1,spec1,fl1) =+                          inl0 <= inl1 && spec0 <= spec1 && (not (fl0 && not fl1))+                        flagsAllowCache = allowCache (succesFlags man) succesFlagsI+                    in  (flagsAllowCache && fst (manifestHash man) == topHash+                        ,flagsAllowCache && snd (manifestHash man) == benchHashM+                        ,man { manifestHash = (topHash,benchHashM)+                             , succesFlags  = if flagsAllowCache+                                                 then succesFlags man+                                                 else succesFlagsI+                             }+                        ))                   manM)    (supplyN,supplyTB) <- Supply.splitSupply                     . snd                     . Supply.freshId                    <$> Supply.newSupply-  let topEntityNames = map (\(x,_,_) -> x) topEntities+  let topEntityNames = map topId topEntities2 -  (topTime,manifest',seen') <- if sameTopHash+  (topTime,manifest',seen') <- if useCacheTop     then do       putStrLn ("Clash: Using cached result for: " ++ Data.Text.unpack (nameOcc (varName topEntity)))       topTime <- Clock.getCurrentTime@@ -241,8 +400,8 @@       prepareDir (opt_cleanhdl opts) (extension hdlState') dir       -- Now start the netlist generation       (netlist,seen') <--        genNetlist False opts reprs transformedBindings topEntities primMap-                   tcm typeTrans iw mkId extId ite seen hdlDir prefixM topEntity+        genNetlist False opts reprs transformedBindings topEntities2 primMap+                   tcm typeTrans iw mkId extId ite (SomeBackend hdlState') seen hdlDir prefixM topEntity        netlistTime <- netlist `deepseq` Clock.getCurrentTime       let normNetDiff = reportTimeDiff netlistTime normTime@@ -260,7 +419,7 @@       return (topTime,manifest',seen')    benchTime <- case benchM of-    Just tb | not sameBenchHash -> do+    Just tb | not useCacheBench -> do       putStrLn $ "Clash: Compiling " ++ Data.Text.unpack (nameOcc (varName tb))        let modName'  = genComponentName (opt_newInlineStrat opts) HashMap.empty@@ -272,7 +431,7 @@                                   typeTrans eval topEntityNames opts supplyTB tb       normTime <- transformedBindings `deepseq` Clock.getCurrentTime       let prepNormDiff = reportTimeDiff normTime topTime-      putStrLn $ "Clash: Testbench normalisation took " ++ prepNormDiff+      putStrLn $ "Clash: Testbench normalization took " ++ prepNormDiff        -- 2. Generate netlist for topEntity @@ -281,8 +440,8 @@       prepareDir (opt_cleanhdl opts) (extension hdlState2) dir       -- Now start the netlist generation       (netlist,seen'') <--        genNetlist True opts reprs transformedBindings topEntities primMap-                   tcm typeTrans iw mkId extId ite seen' hdlDir prefixM tb+        genNetlist True opts reprs transformedBindings topEntities2 primMap+                   tcm typeTrans iw mkId extId ite (SomeBackend hdlState') seen' hdlDir prefixM tb        netlistTime <- netlist `deepseq` Clock.getCurrentTime       let normNetDiff = reportTimeDiff netlistTime normTime@@ -335,6 +494,8 @@   -- ^ Type name ("BlackBoxFunction" or "TemplateFunction")   -> m (Either Hint.InterpreterError a) loadImportAndInterpret iPaths0 interpreterArgs topDir qualMod funcName typ = do+  Hint.liftIO $ Monad.when debugIsOn $+    putStr "Hint: Interpreting " >> putStrLn (qualMod ++ "." ++ funcName)   -- Try to interpret function *without* loading module explicitly. If this   -- succeeds, the module was already in the global package database(s).   bbfE <- Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do@@ -350,13 +511,48 @@       Hint.unsafeRunInterpreterWithArgsLibdir interpreterArgs topDir $ do         Hint.reset         iPaths1 <- (iPaths0++) <$> Hint.get Hint.searchPath-        Hint.set [Hint.searchPath Hint.:= iPaths1]+        Hint.set [ Hint.searchPath Hint.:= iPaths1+                 , Hint.languageExtensions Hint.:= langExts]         Hint.loadModules [qualMod]         Hint.setImports [ "Clash.Netlist.BlackBox.Types", "Clash.Netlist.Types", qualMod]         Hint.unsafeInterpret funcName typ     Right _ -> do       return bbfE+ where+   langExts = map Hint.asExtension $+                map show wantedLanguageExtensions +++                map ("No" ++ ) (map show unwantedLanguageExtensions) +-- | List of known BlackBoxFunctions used to prevent Hint from firing. This+--  improves Clash startup times.+knownBlackBoxFunctions :: HashMap String BlackBoxFunction+knownBlackBoxFunctions =+  HashMap.fromList $ map (first show) $+    [ ('P.bvToIntegerVHDL, P.bvToIntegerVHDL)+    , ('P.bvToIntegerVerilog, P.bvToIntegerVerilog)+    , ('P.foldBBF, P.foldBBF)+    , ('P.indexIntVerilog, P.indexIntVerilog)+    , ('P.indexToIntegerVerilog, P.indexToIntegerVerilog)+    , ('P.indexToIntegerVHDL, P.indexToIntegerVHDL)+    , ('P.intTF, P.intTF)+    , ('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)+    ]+ -- | Compiles blackbox functions and parses blackbox templates. compilePrimitive   :: [FilePath]@@ -369,16 +565,26 @@   -> ResolvedPrimitive   -- ^ Primitive to compile   -> IO CompiledPrimitive-compilePrimitive idirs pkgDbs topDir (BlackBoxHaskell bbName wf bbGenName source) = do-  let interpreterArgs = concatMap (("-package-db":) . (:[])) pkgDbs-  -- Compile a blackbox template function or fetch it from an already compiled file.-  r <- go interpreterArgs source-  processHintError-    (show bbGenName)-    bbName-    (\bbFunc -> BlackBoxHaskell bbName wf bbGenName (hash source, bbFunc))-    r-  where+compilePrimitive idirs pkgDbs topDir (BlackBoxHaskell bbName wf usedArgs bbGenName source) = do+  bbFunc <-+    -- TODO: Use cache for hint targets. Right now Hint will fire multiple times+    -- TODO: if multiple functions use the same blackbox haskell function.+    case HashMap.lookup fullName knownBlackBoxFunctions of+      Just f -> pure f+      Nothing -> do+        Monad.when debugIsOn (putStr "Hint: interpreting " >> putStrLn (show fullName))+        let interpreterArgs = concatMap (("-package-db":) . (:[])) pkgDbs+        -- Compile a blackbox template function or fetch it from an already compiled file.+        r <- go interpreterArgs source+        processHintError+          (show bbGenName)+          bbName+          id+          r++  pure (BlackBoxHaskell bbName wf usedArgs bbGenName (hash source, bbFunc))+ where+    fullName = qualMod ++ "." ++ funcName     qualMod = intercalate "." modNames     BlackBoxFunctionName modNames funcName = bbGenName @@ -409,12 +615,15 @@     go args Nothing = do       loadImportAndInterpret idirs args topDir qualMod funcName "BlackBoxFunction" -compilePrimitive idirs pkgDbs topDir (BlackBox pNm wf tkind () oReg libM imps incs templ) = do+compilePrimitive idirs pkgDbs topDir+  (BlackBox pNm wf rVoid tkind () oReg libM imps fPlural incs rM riM templ) = do   libM'  <- mapM parseTempl libM   imps'  <- mapM parseTempl imps   incs'  <- mapM (traverse parseBB) incs   templ' <- parseBB templ-  return (BlackBox pNm wf tkind () oReg libM' imps' incs' templ')+  rM'    <- traverse parseBB rM+  riM'   <- traverse parseBB riM+  return (BlackBox pNm wf rVoid tkind () oReg libM' imps' fPlural incs' rM' riM' templ')  where   iArgs = concatMap (("-package-db":) . (:[])) pkgDbs @@ -450,11 +659,18 @@     let BlackBoxFunctionName modNames funcName = bbGenName         qualMod = intercalate "." modNames         hsh     = hash qualMod-    r <- loadImportAndInterpret idirs iArgs topDir qualMod funcName "TemplateFunction"-    processHintError (show bbGenName) pNm (BBFunction (Data.Text.unpack pNm) hsh) r+        fullName = qualMod ++ "." ++ funcName+    tf <-+      case HashMap.lookup fullName knownTemplateFunctions of+        Just f -> pure f+        Nothing -> do+          r <- loadImportAndInterpret idirs iArgs topDir qualMod funcName "TemplateFunction"+          processHintError (show bbGenName) pNm id r+    pure (BBFunction (Data.Text.unpack pNm) hsh tf)  compilePrimitive _ _ _ (Primitive pNm wf typ) =   return (Primitive pNm wf typ)+{-# SCC compilePrimitive #-}  processHintError   :: Monad m@@ -515,9 +731,9 @@       let topInNames = map fst (inputs top)       topInTypes  <- mapM (fmap (Text.toStrict . renderOneLine) .                            hdlType (External topName) . snd) (inputs top)-      let topOutNames = map (fst . snd) (outputs top)+      let topOutNames = map (fst . (\(_,x,_) -> x)) (outputs top)       topOutTypes <- mapM (fmap (Text.toStrict . renderOneLine) .-                           hdlType (External topName) . snd . snd) (outputs top)+                           hdlType (External topName) . snd . (\(_,x,_) -> x)) (outputs top)       let compNames = map (componentName . view _4) components       return (m { portInNames    = topInNames                 , portInTypes    = topInTypes@@ -608,7 +824,7 @@   -- ^ Root of the call graph   -> [Term] callGraphBindings bindingsMap tm =-  map ((^. _4) . (bindingsMap `lookupUniqMap'`)) (keysUniqMap cg)+  map (bindingTerm . (bindingsMap `lookupUniqMap'`)) (keysUniqMap cg)   where     cg = callGraph bindingsMap tm @@ -626,7 +842,7 @@   -> (CustomReprs -> TyConMap -> Type ->       State HWMap (Maybe (Either String FilteredHWType)))   -- ^ Hardcoded 'Type' -> 'HWType' translator-  -> PrimEvaluator+  -> (PrimStep, PrimUnwind)   -- ^ Hardcoded evaluator (delta-reduction)   -> [Id]   -- ^ TopEntities@@ -647,3 +863,27 @@     transformedBindings = runNormalization opts supply bindingsMap                             typeTrans reprs tcm tupTcm eval primMap emptyVarEnv                             topEntities doNorm++-- | topologically sort the top entities+sortTop+  :: BindingMap+  -> [TopEntityT]+  -> [TopEntityT]+sortTop bindingsMap topEntities =+  let (nodes,edges) = unzip (map go topEntities)+  in  case reverseTopSort nodes (concat edges) of+        Left msg   -> error msg+        Right tops -> tops+ where+  go t@(TopEntityT topE _ tbM) =+    let topRefs = goRefs topE topE+        tbRefs  = maybe [] (goRefs topE) tbM+    in  ((varUniq topE,t)+         ,map ((\top -> (varUniq topE, varUniq (topId top)))) (tbRefs ++ topRefs))++  goRefs top i_ =+    let cg = callGraph bindingsMap i_+    in+      filter+        (\t -> topId t /= top && topId t /= i_ && topId t `elemVarEnv` cg)+        topEntities