diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`) -* 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) diff --git a/clash-lib.cabal b/clash-lib.cabal --- a/clash-lib.cabal +++ b/clash-lib.cabal @@ -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: . - * + * . * . . - Prelude library: -Homepage: http://www.clash-lang.org/ -bug-reports: http://github.com/clash-lang/clash-compiler/issues -License: BSD2 + Prelude library: +Homepage: https://clash-lang.org/ +bug-reports: https://github.com/clash-lang/clash-compiler/issues +License: BSD-2-Clause License-file: LICENSE Author: The Clash Authors Maintainer: QBayLogic B.V. @@ -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 diff --git a/prims/common/Clash_Intel_ClockGen.json b/prims/common/Clash_Intel_ClockGen.json --- a/prims/common/Clash_Intel_ClockGen.json +++ b/prims/common/Clash_Intel_ClockGen.json @@ -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" } diff --git a/prims/common/Clash_Magic.json b/prims/common/Clash_Magic.json --- a/prims/common/Clash_Magic.json +++ b/prims/common/Clash_Magic.json @@ -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" } diff --git a/prims/common/Clash_XException.json b/prims/common/Clash_XException.json --- a/prims/common/Clash_XException.json +++ b/prims/common/Clash_XException.json @@ -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]" + } + } ] diff --git a/prims/common/GHC_Natural.json b/prims/common/GHC_Natural.json --- a/prims/common/GHC_Natural.json +++ b/prims/common/GHC_Natural.json @@ -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" + } } ] diff --git a/prims/commonverilog/Clash_Explicit_SimIO.json b/prims/commonverilog/Clash_Explicit_SimIO.json new file mode 100644 --- /dev/null +++ b/prims/commonverilog/Clash_Explicit_SimIO.json @@ -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" + } + } +] diff --git a/prims/commonverilog/Clash_Sized_Internal_BitVector.json b/prims/commonverilog/Clash_Sized_Internal_BitVector.json --- a/prims/commonverilog/Clash_Sized_Internal_BitVector.json +++ b/prims/commonverilog/Clash_Sized_Internal_BitVector.json @@ -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" : diff --git a/prims/commonverilog/Clash_Sized_Internal_Index.json b/prims/commonverilog/Clash_Sized_Internal_Index.json --- a/prims/commonverilog/Clash_Sized_Internal_Index.json +++ b/prims/commonverilog/Clash_Sized_Internal_Index.json @@ -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" : diff --git a/prims/commonverilog/Clash_Sized_Internal_Signed.json b/prims/commonverilog/Clash_Sized_Internal_Signed.json --- a/prims/commonverilog/Clash_Sized_Internal_Signed.json +++ b/prims/commonverilog/Clash_Sized_Internal_Signed.json @@ -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" : diff --git a/prims/commonverilog/Clash_Sized_Internal_Unsigned.json b/prims/commonverilog/Clash_Sized_Internal_Unsigned.json --- a/prims/commonverilog/Clash_Sized_Internal_Unsigned.json +++ b/prims/commonverilog/Clash_Sized_Internal_Unsigned.json @@ -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" : diff --git a/prims/systemverilog/Clash_Signal_BiSignal.json b/prims/systemverilog/Clash_Signal_BiSignal.json --- a/prims/systemverilog/Clash_Signal_BiSignal.json +++ b/prims/systemverilog/Clash_Signal_BiSignal.json @@ -1,6 +1,7 @@ [ { "BlackBox" : { "name" : "Clash.Signal.BiSignal.writeToBiSignal#", "kind" : "Declaration", + "renderVoid": "RenderVoid", "type" : "writeToBiSignal# :: HasCallStack -- ARG[0] diff --git a/prims/systemverilog/Clash_Signal_Internal.json b/prims/systemverilog/Clash_Signal_Internal.json --- a/prims/systemverilog/Clash_Signal_Internal.json +++ b/prims/systemverilog/Clash_Signal_Internal.json @@ -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" } } diff --git a/prims/systemverilog/Clash_Sized_Internal_Signed.json b/prims/systemverilog/Clash_Sized_Internal_Signed.json --- a/prims/systemverilog/Clash_Sized_Internal_Signed.json +++ b/prims/systemverilog/Clash_Sized_Internal_Signed.json @@ -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" } } diff --git a/prims/systemverilog/Clash_Sized_Vector.json b/prims/systemverilog/Clash_Sized_Vector.json --- a/prims/systemverilog/Clash_Sized_Vector.json +++ b/prims/systemverilog/Clash_Sized_Vector.json @@ -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" diff --git a/prims/systemverilog/GHC_Classes.json b/prims/systemverilog/GHC_Classes.json --- a/prims/systemverilog/GHC_Classes.json +++ b/prims/systemverilog/GHC_Classes.json @@ -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" } } diff --git a/prims/systemverilog/GHC_Integer_Type.json b/prims/systemverilog/GHC_Integer_Type.json --- a/prims/systemverilog/GHC_Integer_Type.json +++ b/prims/systemverilog/GHC_Integer_Type.json @@ -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" } } ] diff --git a/prims/systemverilog/GHC_Prim.json b/prims/systemverilog/GHC_Prim.json --- a/prims/systemverilog/GHC_Prim.json +++ b/prims/systemverilog/GHC_Prim.json @@ -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]; diff --git a/prims/verilog/Clash_Signal_BiSignal.json b/prims/verilog/Clash_Signal_BiSignal.json --- a/prims/verilog/Clash_Signal_BiSignal.json +++ b/prims/verilog/Clash_Signal_BiSignal.json @@ -1,6 +1,7 @@ [ { "BlackBox" : { "name" : "Clash.Signal.BiSignal.writeToBiSignal#", "kind" : "Declaration", + "renderVoid": "RenderVoid", "type" : "writeToBiSignal# :: HasCallStack -- ARG[0] diff --git a/prims/verilog/Clash_Signal_Internal.json b/prims/verilog/Clash_Signal_Internal.json --- a/prims/verilog/Clash_Signal_Internal.json +++ b/prims/verilog/Clash_Signal_Internal.json @@ -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; diff --git a/prims/verilog/Clash_Sized_Internal_Signed.json b/prims/verilog/Clash_Sized_Internal_Signed.json --- a/prims/verilog/Clash_Sized_Internal_Signed.json +++ b/prims/verilog/Clash_Sized_Internal_Signed.json @@ -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" } } diff --git a/prims/verilog/Clash_Sized_Vector.json b/prims/verilog/Clash_Sized_Vector.json --- a/prims/verilog/Clash_Sized_Vector.json +++ b/prims/verilog/Clash_Sized_Vector.json @@ -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" diff --git a/prims/verilog/GHC_Classes.json b/prims/verilog/GHC_Classes.json --- a/prims/verilog/GHC_Classes.json +++ b/prims/verilog/GHC_Classes.json @@ -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" } } diff --git a/prims/verilog/GHC_Integer_Type.json b/prims/verilog/GHC_Integer_Type.json --- a/prims/verilog/GHC_Integer_Type.json +++ b/prims/verilog/GHC_Integer_Type.json @@ -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" } } ] diff --git a/prims/verilog/GHC_Prim.json b/prims/verilog/GHC_Prim.json --- a/prims/verilog/GHC_Prim.json +++ b/prims/verilog/GHC_Prim.json @@ -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]; diff --git a/prims/vhdl/Clash_Explicit_BlockRam.json b/prims/vhdl/Clash_Explicit_BlockRam.json --- a/prims/vhdl/Clash_Explicit_BlockRam.json +++ b/prims/vhdl/Clash_Explicit_BlockRam.json @@ -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; diff --git a/prims/vhdl/Clash_Explicit_BlockRam_File.json b/prims/vhdl/Clash_Explicit_BlockRam_File.json --- a/prims/vhdl/Clash_Explicit_BlockRam_File.json +++ b/prims/vhdl/Clash_Explicit_BlockRam_File.json @@ -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; diff --git a/prims/vhdl/Clash_Explicit_ROM.json b/prims/vhdl/Clash_Explicit_ROM.json --- a/prims/vhdl/Clash_Explicit_ROM.json +++ b/prims/vhdl/Clash_Explicit_ROM.json @@ -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; diff --git a/prims/vhdl/Clash_Explicit_ROM_File.json b/prims/vhdl/Clash_Explicit_ROM_File.json --- a/prims/vhdl/Clash_Explicit_ROM_File.json +++ b/prims/vhdl/Clash_Explicit_ROM_File.json @@ -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; diff --git a/prims/vhdl/Clash_Explicit_SimIO.json b/prims/vhdl/Clash_Explicit_SimIO.json new file mode 100644 --- /dev/null +++ b/prims/vhdl/Clash_Explicit_SimIO.json @@ -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" + } + } +] diff --git a/prims/vhdl/Clash_Signal_BiSignal.json b/prims/vhdl/Clash_Signal_BiSignal.json --- a/prims/vhdl/Clash_Signal_BiSignal.json +++ b/prims/vhdl/Clash_Signal_BiSignal.json @@ -1,6 +1,7 @@ [ { "BlackBox" : { "name" : "Clash.Signal.BiSignal.writeToBiSignal#", "kind" : "Declaration", + "renderVoid": "RenderVoid", "type" : "writeToBiSignal# :: HasCallStack -- ARG[0] diff --git a/prims/vhdl/Clash_Signal_Internal.json b/prims/vhdl/Clash_Signal_Internal.json --- a/prims/vhdl/Clash_Signal_Internal.json +++ b/prims/vhdl/Clash_Signal_Internal.json @@ -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" } } diff --git a/prims/vhdl/Clash_Sized_Internal_BitVector.json b/prims/vhdl/Clash_Sized_Internal_BitVector.json --- a/prims/vhdl/Clash_Sized_Internal_BitVector.json +++ b/prims/vhdl/Clash_Sized_Internal_BitVector.json @@ -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" : diff --git a/prims/vhdl/Clash_Sized_Internal_Index.json b/prims/vhdl/Clash_Sized_Internal_Index.json --- a/prims/vhdl/Clash_Sized_Internal_Index.json +++ b/prims/vhdl/Clash_Sized_Internal_Index.json @@ -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" : diff --git a/prims/vhdl/Clash_Sized_Internal_Signed.json b/prims/vhdl/Clash_Sized_Internal_Signed.json --- a/prims/vhdl/Clash_Sized_Internal_Signed.json +++ b/prims/vhdl/Clash_Sized_Internal_Signed.json @@ -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" : diff --git a/prims/vhdl/Clash_Sized_Internal_Unsigned.json b/prims/vhdl/Clash_Sized_Internal_Unsigned.json --- a/prims/vhdl/Clash_Sized_Internal_Unsigned.json +++ b/prims/vhdl/Clash_Sized_Internal_Unsigned.json @@ -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" : diff --git a/prims/vhdl/Clash_Sized_Vector.json b/prims/vhdl/Clash_Sized_Vector.json --- a/prims/vhdl/Clash_Sized_Vector.json +++ b/prims/vhdl/Clash_Sized_Vector.json @@ -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" diff --git a/prims/vhdl/GHC_Classes.json b/prims/vhdl/GHC_Classes.json --- a/prims/vhdl/GHC_Classes.json +++ b/prims/vhdl/GHC_Classes.json @@ -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" : diff --git a/prims/vhdl/GHC_Integer_Type.json b/prims/vhdl/GHC_Integer_Type.json --- a/prims/vhdl/GHC_Integer_Type.json +++ b/prims/vhdl/GHC_Integer_Type.json @@ -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" : diff --git a/prims/vhdl/GHC_Prim.json b/prims/vhdl/GHC_Prim.json --- a/prims/vhdl/GHC_Prim.json +++ b/prims/vhdl/GHC_Prim.json @@ -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 diff --git a/src/Clash/Annotations/TopEntity/Extra.hs b/src/Clash/Annotations/TopEntity/Extra.hs --- a/src/Clash/Annotations/TopEntity/Extra.hs +++ b/src/Clash/Annotations/TopEntity/Extra.hs @@ -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 diff --git a/src/Clash/Backend.hs b/src/Clash/Backend.hs --- a/src/Clash/Backend.hs +++ b/src/Clash/Backend.hs @@ -5,6 +5,7 @@ Maintainer : Christiaan Baaij -} +{-# 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 diff --git a/src/Clash/Backend/SystemVerilog.hs b/src/Clash/Backend/SystemVerilog.hs --- a/src/Clash/Backend/SystemVerilog.hs +++ b/src/Clash/Backend/SystemVerilog.hs @@ -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 diff --git a/src/Clash/Backend/VHDL.hs b/src/Clash/Backend/VHDL.hs --- a/src/Clash/Backend/VHDL.hs +++ b/src/Clash/Backend/VHDL.hs @@ -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, 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 diff --git a/src/Clash/Backend/Verilog.hs b/src/Clash/Backend/Verilog.hs --- a/src/Clash/Backend/Verilog.hs +++ b/src/Clash/Backend/Verilog.hs @@ -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 _) diff --git a/src/Clash/Core/DataCon.hs b/src/Clash/Core/DataCon.hs --- a/src/Clash/Core/DataCon.hs +++ b/src/Clash/Core/DataCon.hs @@ -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 (..) diff --git a/src/Clash/Core/Evaluator.hs b/src/Clash/Core/Evaluator.hs --- a/src/Clash/Core/Evaluator.hs +++ b/src/Clash/Core/Evaluator.hs @@ -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 diff --git a/src/Clash/Core/Evaluator/Types.hs b/src/Clash/Core/Evaluator/Types.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/Evaluator/Types.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE OverloadedStrings #-} + +{-| + Copyright : (C) 2020, QBayLogic B.V. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij + + 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 } + diff --git a/src/Clash/Core/FreeVars.hs b/src/Clash/Core/FreeVars.hs --- a/src/Clash/Core/FreeVars.hs +++ b/src/Clash/Core/FreeVars.hs @@ -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)) diff --git a/src/Clash/Core/Literal.hs b/src/Clash/Core/Literal.hs --- a/src/Clash/Core/Literal.hs +++ b/src/Clash/Core/Literal.hs @@ -8,9 +8,8 @@ Term Literal -} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module Clash.Core.Literal diff --git a/src/Clash/Core/Name.hs b/src/Clash/Core/Name.hs --- a/src/Clash/Core/Name.hs +++ b/src/Clash/Core/Name.hs @@ -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 diff --git a/src/Clash/Core/Pretty.hs b/src/Clash/Core/Pretty.hs --- a/src/Clash/Core/Pretty.hs +++ b/src/Clash/Core/Pretty.hs @@ -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) = ("" <>) <$> pprPrec prec t pprPrec prec (NameMod SuffixName t) = ("" <>) <$> pprPrec prec t + pprPrec prec (NameMod SuffixNameP t) = ("" <>) <$> pprPrec prec t pprPrec prec (NameMod SetName t) = ("" <>) <$> pprPrec prec t + pprPrec _ DeDup = pure "" + pprPrec _ NoDeDup = pure "" instance PrettyPrec SrcSpan where pprPrec _ sp = return (""<>pretty (GHC.showSDocUnsafe (GHC.ppr sp))) @@ -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) - diff --git a/src/Clash/Core/Subst.hs b/src/Clash/Core/Subst.hs --- a/src/Clash/Core/Subst.hs +++ b/src/Clash/Core/Subst.hs @@ -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 diff --git a/src/Clash/Core/Term.hs b/src/Clash/Core/Term.hs --- a/src/Clash/Core/Term.hs +++ b/src/Clash/Core/Term.hs @@ -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 = [] diff --git a/src/Clash/Core/TermLiteral.hs b/src/Clash/Core/TermLiteral.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/TermLiteral.hs @@ -0,0 +1,96 @@ +{-| +Copyright : (C) 2019, Myrtle Software Ltd +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +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 diff --git a/src/Clash/Core/TermLiteral/TH.hs b/src/Clash/Core/TermLiteral/TH.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Core/TermLiteral/TH.hs @@ -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" + diff --git a/src/Clash/Core/TyCon.hs b/src/Clash/Core/TyCon.hs --- a/src/Clash/Core/TyCon.hs +++ b/src/Clash/Core/TyCon.hs @@ -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 diff --git a/src/Clash/Core/Type.hs b/src/Clash/Core/Type.hs --- a/src/Clash/Core/Type.hs +++ b/src/Clash/Core/Type.hs @@ -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 diff --git a/src/Clash/Core/TysPrim.hs b/src/Clash/Core/TysPrim.hs --- a/src/Clash/Core/TysPrim.hs +++ b/src/Clash/Core/TysPrim.hs @@ -7,7 +7,7 @@ Builtin Type and Kind definitions -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Clash.Core.TysPrim diff --git a/src/Clash/Core/Util.hs b/src/Clash/Core/Util.hs --- a/src/Clash/Core/Util.hs +++ b/src/Clash/Core/Util.hs @@ -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 #-} diff --git a/src/Clash/Core/Var.hs b/src/Clash/Core/Var.hs --- a/src/Clash/Core/Var.hs +++ b/src/Clash/Core/Var.hs @@ -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' (..) diff --git a/src/Clash/Core/VarEnv.hs b/src/Clash/Core/VarEnv.hs --- a/src/Clash/Core/VarEnv.hs +++ b/src/Clash/Core/VarEnv.hs @@ -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 diff --git a/src/Clash/Driver.hs b/src/Clash/Driver.hs --- a/src/Clash/Driver.hs +++ b/src/Clash/Driver.hs @@ -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 diff --git a/src/Clash/Driver/Types.hs b/src/Clash/Driver/Types.hs --- a/src/Clash/Driver/Types.hs +++ b/src/Clash/Driver/Types.hs @@ -9,29 +9,45 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} module Clash.Driver.Types where -- For Int/Word size #include "MachDeps.h" -import Data.Text (Text) +import Control.DeepSeq (NFData) +import Data.Binary (Binary) +import Data.Hashable +import qualified Data.Set as Set +import Data.Text (Text) +import GHC.Generics (Generic) -import BasicTypes (InlineSpec) -import SrcLoc (SrcSpan) +import BasicTypes (InlineSpec) +import SrcLoc (SrcSpan) +import Util (OverridingBool(..)) -import Clash.Core.Term (Term) -import Clash.Core.Var (Id) -import Clash.Core.VarEnv (VarEnv) +import Clash.Core.Term (Term) +import Clash.Core.Var (Id) +import Clash.Core.VarEnv (VarEnv) +import Clash.Netlist.BlackBox.Types (HdlSyn (..)) -import Clash.Netlist.BlackBox.Types (HdlSyn (..)) -import Util (OverridingBool(..)) +-- A function binder in the global environment. +-- +data Binding = Binding + { bindingId :: Id + , bindingLoc :: SrcSpan + , bindingSpec :: InlineSpec + , bindingTerm :: Term + } deriving (Binary, Generic, NFData, Show) -- | Global function binders -- --- Global functions cannot be mutually recursive, only self-recursive -type BindingMap = VarEnv (Id,SrcSpan,InlineSpec,Term) +-- Global functions cannot be mutually recursive, only self-recursive. +type BindingMap = VarEnv Binding -- | Debug Message Verbosity data DebugLevel @@ -42,18 +58,21 @@ | DebugFinal -- ^ Show completely normalized expressions | DebugName - -- ^ Names of applied transformations + -- ^ Show names of applied transformations + | DebugTry + -- ^ Show names of tried AND applied transformations | DebugApplied -- ^ Show sub-expressions after a successful rewrite | DebugAll -- ^ Show all sub-expressions on which a rewrite is attempted - deriving (Eq,Ord,Read) + deriving (Eq,Ord,Read,Enum,Generic,Hashable) data ClashOpts = ClashOpts { opt_inlineLimit :: Int , opt_specLimit :: Int , opt_inlineFunctionLimit :: Word , opt_inlineConstantLimit :: Word , opt_dbgLevel :: DebugLevel + , opt_dbgTransformations :: Set.Set String , opt_cachehdl :: Bool , opt_cleanhdl :: Bool , opt_primWarn :: Bool @@ -87,13 +106,59 @@ -- * /Just (Just x)/: replace undefined's by /x/ in -- the HDL , opt_checkIDir :: Bool + , opt_aggressiveXOpt :: Bool + -- ^ Enable aggressive X optimization, which may + -- remove undefineds from generated HDL by replaced + -- with defined alternatives. + , opt_inlineWFCacheLimit :: Word + -- ^ At what size do we cache normalized work-free + -- top-level binders. } +instance Hashable ClashOpts where + hashWithSalt s ClashOpts {..} = + s `hashWithSalt` + opt_inlineLimit `hashWithSalt` + opt_specLimit `hashWithSalt` + opt_inlineFunctionLimit `hashWithSalt` + opt_inlineConstantLimit `hashWithSalt` + opt_dbgLevel `hashSet` + opt_dbgTransformations `hashWithSalt` + opt_cachehdl `hashWithSalt` + opt_cleanhdl `hashWithSalt` + opt_primWarn `hashWithSalt` + opt_cleanhdl `hashOverridingBool` + opt_color `hashWithSalt` + opt_intWidth `hashWithSalt` + opt_hdlDir `hashWithSalt` + opt_hdlSyn `hashWithSalt` + opt_errorExtra `hashWithSalt` + opt_floatSupport `hashWithSalt` + opt_importPaths `hashWithSalt` + opt_componentPrefix `hashWithSalt` + opt_newInlineStrat `hashWithSalt` + opt_escapedIds `hashWithSalt` + opt_ultra `hashWithSalt` + opt_forceUndefined `hashWithSalt` + opt_checkIDir `hashWithSalt` + opt_aggressiveXOpt `hashWithSalt` + opt_inlineWFCacheLimit + where + hashOverridingBool :: Int -> OverridingBool -> Int + hashOverridingBool s1 Auto = hashWithSalt s1 (0 :: Int) + hashOverridingBool s1 Always = hashWithSalt s1 (1 :: Int) + hashOverridingBool s1 Never = hashWithSalt s1 (2 :: Int) + infixl 0 `hashOverridingBool` + hashSet :: Hashable a => Int -> Set.Set a -> Int + hashSet = Set.foldl' hashWithSalt + infixl 0 `hashSet` + defClashOpts :: ClashOpts defClashOpts = ClashOpts { opt_dbgLevel = DebugNone + , opt_dbgTransformations = Set.empty , opt_inlineLimit = 20 , opt_specLimit = 20 , opt_inlineFunctionLimit = 15 @@ -114,6 +179,8 @@ , opt_ultra = False , opt_forceUndefined = Nothing , opt_checkIDir = True + , opt_aggressiveXOpt = False + , opt_inlineWFCacheLimit = 10 -- TODO: find "optimal" value } -- | Information about the generated HDL between (sub)runs of the compiler @@ -122,6 +189,12 @@ { manifestHash :: (Int,Maybe Int) -- ^ Hash of the TopEntity and all its dependencies -- + (maybe) Hash of the TestBench and all its dependencies + , succesFlags :: (Int,Int,Bool) + -- ^ Compiler flags used to achieve successful compilation: + -- + -- * opt_inlineLimit + -- * opt_specLimit + -- * opt_floatSupport , portInNames :: [Text] , portInTypes :: [Text] -- ^ The rendered versions of the types of the input ports of the TopEntity diff --git a/src/Clash/Netlist.hs b/src/Clash/Netlist.hs --- a/src/Clash/Netlist.hs +++ b/src/Clash/Netlist.hs @@ -8,17 +8,19 @@ Create Netlists out of normalized CoreHW Terms -} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} module Clash.Netlist where import Control.Exception (throw) -import Control.Lens ((.=),(^.),_2) +import Control.Lens ((.=)) import qualified Control.Lens as Lens import Control.Monad (join) import Control.Monad.IO.Class (liftIO) @@ -26,12 +28,13 @@ import Control.Monad.State.Strict (State, runStateT) import Data.Binary.IEEE754 (floatToWord, doubleToWord) import Data.Char (ord) -import Data.Either (partitionEithers) +import Data.Either (partitionEithers, rights) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMapS import qualified Data.HashMap.Lazy as HashMap -import Data.List (elemIndex, sortOn) -import Data.Maybe (catMaybes, listToMaybe, fromMaybe) +import Data.List (elemIndex, partition, sortOn) +import Data.Maybe + (catMaybes, listToMaybe, mapMaybe, fromMaybe) import qualified Data.Set as Set import Data.Primitive.ByteArray (ByteArray (..)) import qualified Data.Text as StrictText @@ -54,25 +57,25 @@ import Clash.Core.Name (Name(..)) import Clash.Core.Pretty (showPpr) import Clash.Core.Term - (Alt, Pat (..), Term (..), TickInfo (..), collectArgs, collectArgsTicks, collectTicks) + (Alt, Pat (..), Term (..), TickInfo (..), PrimInfo(primName), collectArgs, collectArgsTicks, collectTicks) import qualified Clash.Core.Term as Core import Clash.Core.Type - (Type (..), coreView1, splitFunTys, splitCoreFunForallTy) + (Type (..), coreView1, splitFunForallTy, splitCoreFunForallTy) import Clash.Core.TyCon (TyConMap) import Clash.Core.Util - (mkApps, mkTicks, stripTicks, termType) -import Clash.Core.Var (Id, Var (..)) + (mkApps, mkTicks, splitShouldSplit, stripTicks, termType) +import Clash.Core.Var (Id, Var (..), isGlobalId) import Clash.Core.VarEnv (VarEnv, eltsVarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, lookupVarEnv, lookupVarEnv', mkVarEnv) -import Clash.Driver.Types (BindingMap, ClashOpts (..)) +import Clash.Driver.Types (BindingMap, Binding(..), ClashOpts (..)) import Clash.Netlist.BlackBox import Clash.Netlist.Id import Clash.Netlist.Types as HW import Clash.Netlist.Util import Clash.Primitives.Types as P import Clash.Util - +import qualified Clash.Util.Interpolate as I -- | Generate a hierarchical netlist out of a set of global binders with -- @topEntity@ at the top. @@ -85,7 +88,7 @@ -- ^ Custom bit representations for certain types -> BindingMap -- ^ Global binders - -> [(Id,Maybe TopEntity,Maybe Id)] + -> [TopEntityT] -- ^ All the TopEntities -> CompiledPrimMap -- ^ Primitive definitions @@ -102,27 +105,27 @@ -- ^ extend valid identifiers -> Bool -- ^ Whether the backend supports ifThenElse expressions + -> SomeBackend + -- ^ The current HDL backend -> HashMap Identifier Word -- ^ Seen components -> FilePath -- ^ HDL dir - -> (Maybe Identifier,Maybe Identifier) + -> ComponentPrefix -- ^ Component name prefix -> Id -- ^ Name of the @topEntity@ -> IO ([([Bool],SrcSpan,HashMap Identifier Word,Component)],HashMap Identifier Word) -genNetlist isTb opts reprs globals tops primMap tcm typeTrans iw mkId extId ite seen env prefixM topEntity = do - (_,s) <- runNetlistMonad isTb opts reprs globals (mkTopEntityMap tops) - primMap tcm typeTrans iw mkId extId ite seen env prefixM $ +genNetlist isTb opts reprs globals tops primMap tcm typeTrans iw mkId extId ite be seen env prefixM topEntity = do + (_,s) <- runNetlistMonad isTb opts reprs globals topEntityMap + primMap tcm typeTrans iw mkId extId ite be seen env prefixM $ genComponent topEntity return ( eltsVarEnv $ _components s , _seenComps s ) where - mkTopEntityMap - :: [(Id,Maybe TopEntity,Maybe Id)] - -> VarEnv (Type,Maybe TopEntity) - mkTopEntityMap = mkVarEnv . map (\(a,b,_) -> (a,(varType a,b))) + topEntityMap :: VarEnv TopEntityT + topEntityMap = mkVarEnv (zip (map topId tops) tops) -- | Run a NetlistMonad action in a given environment runNetlistMonad @@ -134,7 +137,7 @@ -- ^ Custom bit representations for certain types -> BindingMap -- ^ Global binders - -> VarEnv (Type, Maybe TopEntity) + -> VarEnv TopEntityT -- ^ TopEntity annotations -> CompiledPrimMap -- ^ Primitive Definitions @@ -151,16 +154,18 @@ -- ^ extend valid identifiers -> Bool -- ^ Whether the backend supports ifThenElse expressions + -> SomeBackend + -- ^ The current HDL backend -> HashMap Identifier Word -- ^ Seen components -> FilePath -- ^ HDL dir - -> (Maybe Identifier,Maybe Identifier) + -> ComponentPrefix -- ^ Component name prefix -> NetlistMonad a -- ^ Action to run -> IO (a, NetlistState) -runNetlistMonad isTb opts reprs s tops p tcm typeTrans iw mkId extId ite seenIds_ env prefixM +runNetlistMonad isTb opts reprs s tops p tcm typeTrans iw mkId extId ite be seenIds_ env prefixM = flip runReaderT (NetlistEnv "" "" Nothing) . flip runStateT s' . runNetlist @@ -168,7 +173,7 @@ s' = NetlistState s 0 emptyVarEnv p typeTrans tcm (StrictText.empty,noSrcSpan) iw mkId - extId HashMapS.empty seenIds' Set.empty names tops env 0 prefixM reprs opts isTb ite + extId HashMapS.empty seenIds' Set.empty names tops env 0 prefixM reprs opts isTb ite be HashMapS.empty (seenIds',names) = genNames (opt_newInlineStrat opts) mkId prefixM seenIds_ @@ -176,17 +181,17 @@ genNames :: Bool -> (IdType -> Identifier -> Identifier) - -> (Maybe Identifier,Maybe Identifier) + -> ComponentPrefix -> HashMap Identifier Word -> VarEnv Identifier -> BindingMap -> (HashMap Identifier Word, VarEnv Identifier) genNames newInlineStrat mkId prefixM s0 m0 = foldr go (s0,m0) where - go (v,_,_,_) (s,m) = - let nm' = genComponentName newInlineStrat s mkId prefixM v + go b (s,m) = + let nm' = genComponentName newInlineStrat s mkId prefixM (bindingId b) s' = HashMapS.insert nm' 0 s - m' = extendVarEnv v nm' m + m' = extendVarEnv (bindingId b) nm' m in (s', m') -- | Generate a component for a given function (caching) @@ -201,8 +206,8 @@ Nothing -> do (_,sp) <- Lens.use curCompNm throw (ClashException sp ($(curLoc) ++ "No normalized expression found for: " ++ show compName) Nothing) - Just (_,_,_,expr_) -> do - makeCachedU compName components $ genComponentT compName expr_ + Just b -> do + makeCachedU compName components $ genComponentT compName (bindingTerm b) -- | Generate a component for a given function genComponentT @@ -215,22 +220,22 @@ genComponentT compName componentExpr = do varCount .= 0 componentName1 <- (`lookupVarEnv'` compName) <$> Lens.use componentNames - topEntMM <- fmap snd . lookupVarEnv compName <$> Lens.use topEntityAnns + topEntMM <- fmap topAnnotation . lookupVarEnv compName <$> Lens.use topEntityAnns prefixM <- Lens.use componentPrefix - let componentName2 = case (prefixM,join topEntMM) of - ((Just p,_),Just ann) -> p `StrictText.append` StrictText.pack ('_':t_name ann) + let componentName2 = case (componentPrefixTop prefixM, join topEntMM) of + (Just p, Just ann) -> p `StrictText.append` StrictText.pack ('_':t_name ann) (_,Just ann) -> StrictText.pack (t_name ann) _ -> componentName1 - sp <- ((^. _2) . (`lookupVarEnv'` compName)) <$> Lens.use bindings + sp <- (bindingLoc . (`lookupVarEnv'` compName)) <$> Lens.use bindings curCompNm .= (componentName2,sp) tcm <- Lens.use tcCache -- HACK: Determine resulttype of this function by looking at its definition - -- in topEntityAnns, instead of looking at its last binder (which obscure + -- in topEntityAnns, instead of looking at its last binder (which obscures -- any attributes [see: Clash.Annotations.SynthesisAttributes]). - topEntityTypeM <- lookupVarEnv compName <$> Lens.use topEntityAnns - let topEntityTypeM' = snd . splitCoreFunForallTy tcm . fst <$> topEntityTypeM + topEntityTypeM <- lookupVarEnv compName <$> Lens.use topEntityAnns + let topEntityTypeM' = snd . splitCoreFunForallTy tcm . varType . topId <$> topEntityTypeM seenIds .= HashMapS.empty (wereVoids,compInps,argWrappers,compOutps,resUnwrappers,binders,resultM) <- @@ -239,20 +244,20 @@ let varType' = fromMaybe (varType res) topEntityTypeM' mkUniqueNormalized emptyInScopeSet topEntMM ((args, binds, res{varType=varType'})) Left err -> - throw (ClashException sp err Nothing) + throw (ClashException sp ($curLoc ++ err) Nothing) netDecls <- fmap catMaybes . mapM mkNetDecl $ filter (maybe (const True) (/=) resultM . fst) binders decls <- concat <$> mapM (uncurry mkDeclarations) binders case resultM of Just result -> do - Just (NetDecl' _ rw _ _) <- mkNetDecl . head $ filter ((==result) . fst) binders + Just (NetDecl' _ rw _ _ rIM) <- mkNetDecl . head $ filter ((==result) . fst) binders let (compOutps',resUnwrappers') = case compOutps of - [oport] -> ([(rw,oport)],resUnwrappers) + [oport] -> ([(rw,oport,rIM)],resUnwrappers) _ -> let NetDecl n res resTy = head resUnwrappers - in (map (Wire,) compOutps - ,NetDecl' n rw res (Right resTy):tail resUnwrappers + in (map (Wire,,Nothing) compOutps + ,NetDecl' n rw res (Right resTy) Nothing:tail resUnwrappers ) component = Component componentName2 compInps compOutps' (netDecls ++ argWrappers ++ decls ++ resUnwrappers') @@ -267,16 +272,18 @@ return (wereVoids, sp, ids, component) mkNetDecl :: (Id, Term) -> NetlistMonad (Maybe Declaration) -mkNetDecl (id_,tm) = do +mkNetDecl (id_,tm) = preserveVarEnv $ do let typ = varType id_ hwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) typ wr <- termToWireOrReg tm + rIM <- getResInit (id_,tm) if isVoid hwTy then return Nothing else return . Just $ NetDecl' (addSrcNote sp) wr (id2identifier id_) (Right hwTy) + rIM where nm = varName id_ @@ -291,10 +298,11 @@ case iteAlts scrutHTy alts0 of Just _ | ite -> return Wire _ -> return Reg - termToWireOrReg (collectArgs -> (Prim nm' _,_)) = do - bbM <- HashMap.lookup nm' <$> Lens.use primitives + termToWireOrReg (collectArgs -> (Prim p,_)) = do + bbM <- HashMap.lookup (primName p) <$> Lens.use primitives case bbM of Just (extractPrim -> Just BlackBox {..}) | outputReg -> return Reg + _ | primName p == "Clash.Explicit.SimIO.mealyIO" -> return Reg _ -> return Wire termToWireOrReg _ = return Wire @@ -302,14 +310,30 @@ then Just (StrictText.pack (showSDocUnsafe (ppr loc))) else Nothing - -isWriteToBiSignalPrimitive :: Term -> Bool -isWriteToBiSignalPrimitive e = case collectArgs e of - (Prim nm _,_) -> nm == StrictText.pack "Clash.Signal.BiSignal.writeToBiSignal#" - _ -> False + -- Set the initialization value of a signal when a primitive wants to set it + getResInit + :: (Id,Term) -> NetlistMonad (Maybe Expr) + getResInit (i,collectArgsTicks -> (k,args,ticks)) = case k of + Prim p -> extractPrimWarnOrFail (primName p) >>= go (primName p) + _ -> return Nothing + where + go pNm (BlackBox {resultInit = Just nmD}) = withTicks ticks $ \_ -> do + (bbCtx,_) <- mkBlackBoxContext pNm i args + (bbTempl,templDecl) <- prepareBlackBox pNm nmD bbCtx + case templDecl of + [] -> return (Just (BlackBoxE pNm [] [] [] bbTempl bbCtx False)) + _ -> do + (_,sloc) <- Lens.use curCompNm + throw (ClashException sloc + (unwords [ $(curLoc) + , "signal initialization requires declarations:\n" + , show templDecl + ]) + Nothing) + go _ _ = return Nothing --- | Generate a list of Declarations for a let-binder, return an empty list --- if the bound expression is represented by 0 bits +-- | Generate a list of concurrent Declarations for a let-binder, return an +-- empty list if the bound expression is represented by 0 bits mkDeclarations :: HasCallStack => Id @@ -317,25 +341,24 @@ -> Term -- ^ RHS of the let-binder -> NetlistMonad [Declaration] -mkDeclarations bndr e = do - hty <- unsafeCoreTypeToHWTypeM' $(curLoc) (varType bndr) - if isVoid hty && not (isBiSignalOut hty) - then return [] - else mkDeclarations' bndr e +mkDeclarations = mkDeclarations' Concurrent --- | Generate a list of Declarations for a let-binder +-- | Generate a list of Declarations for a let-binder, return an empty list if +-- the bound expression is represented by 0 bits mkDeclarations' :: HasCallStack - => Id + => DeclarationType + -- ^ Concurrent of sequential declaration + -> Id -- ^ LHS of the let-binder -> Term -- ^ RHS of the let-binder -> NetlistMonad [Declaration] -mkDeclarations' bndr (collectTicks -> (Var v,ticks)) = +mkDeclarations' _declType bndr (collectTicks -> (Var v,ticks)) = withTicks ticks $ \tickDecls -> do mkFunApp (id2identifier bndr) v [] tickDecls -mkDeclarations' _ e@(collectTicks -> (Case _ _ [],_)) = do +mkDeclarations' _declType _bndr e@(collectTicks -> (Case _ _ [],_)) = do (_,sp) <- Lens.use curCompNm throw $ ClashException sp @@ -346,86 +369,116 @@ ]) Nothing -mkDeclarations' bndr (collectTicks -> (Case scrut altTy alts@(_:_:_),ticks)) = +mkDeclarations' declType bndr (collectTicks -> (Case scrut altTy alts@(_:_:_),ticks)) = withTicks ticks $ \tickDecls -> do - mkSelection (Right bndr) scrut altTy alts tickDecls + mkSelection declType (CoreId bndr) scrut altTy alts tickDecls -mkDeclarations' bndr app = +mkDeclarations' declType bndr app = do let (appF,args0,ticks) = collectArgsTicks app (args,tyArgs) = partitionEithers args0 - in withTicks ticks $ \tickDecls -> do case appF of Var f - | null tyArgs -> mkFunApp (id2identifier bndr) f args tickDecls + | null tyArgs -> withTicks ticks (mkFunApp (id2identifier bndr) f args) | otherwise -> do (_,sp) <- Lens.use curCompNm throw (ClashException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showPpr app) Nothing) - -- Do not generate any assignments writing to a BiSignalOut, as these - -- do not have any significance in a HDL. The single exception occurs - -- when writing to a BiSignal using the primitive 'writeToBiSignal'. In - -- the generate HDL it will write to an inout port, NOT the variable - -- having the actual type BiSignalOut. - -- _ | isBiSignalOut (id2type bndr) && (not $ isWriteToBiSignalPrimitive app) -> - -- return [] _ -> do - hwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (id2type bndr) - if isBiSignalOut hwTy && not (isWriteToBiSignalPrimitive app) - then return [] - else do - (exprApp,declsApp0) <- mkExpr False (Right bndr) (varType bndr) app - let dstId = id2identifier bndr - assn = case exprApp of - Identifier _ Nothing -> [] - _ -> [Assignment dstId exprApp] - declsApp1 = if null declsApp0 then tickDecls else declsApp0 - return (declsApp1 ++ assn) + (exprApp,declsApp0) <- mkExpr False declType (CoreId bndr) app + let dstId = id2identifier bndr + assn = + case exprApp of + Identifier _ Nothing -> + -- Supplied 'bndr' was used to assign a result to, so we + -- don't have to manually turn it into a declaration + [] + Noop -> + -- Rendered expression rendered a "noop" - a list of + -- declarations without a result. Used for things like + -- mealy IO / inline assertions. + [] + _ -> + -- Turn returned expression into declaration by assigning + -- it to 'dstId' + [Assignment dstId exprApp] + declsApp1 <- if null declsApp0 + then withTicks ticks return + else pure declsApp0 + return (declsApp1 ++ assn) -- | Generate a declaration that selects an alternative based on the value of -- the scrutinee mkSelection - :: (Either Identifier Id) + :: DeclarationType + -> NetlistId -> Term -> Type -> [Alt] -> [Declaration] -> NetlistMonad [Declaration] -mkSelection bndr scrut altTy alts0 tickDecls = do - let dstId = either id id2identifier bndr +mkSelection declType bndr scrut altTy alts0 tickDecls = do + let dstId = netlistId1 id id2identifier bndr tcm <- Lens.use tcCache let scrutTy = termType tcm scrut scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy scrutId <- extendIdentifier Extended dstId "_selection" (_,sp) <- Lens.use curCompNm ite <- Lens.use backEndITE + altHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) altTy case iteAlts scrutHTy alts0 of Just (altT,altF) | ite + , Concurrent <- declType -> do (scrutExpr,scrutDecls) <- case scrutHTy of SP {} -> first (mkScrutExpr sp scrutHTy (fst (last alts0))) <$> - mkExpr True (Left scrutId) scrutTy scrut - _ -> mkExpr False (Left scrutId) scrutTy scrut + mkExpr True declType (NetlistId scrutId scrutTy) scrut + _ -> mkExpr False declType (NetlistId scrutId scrutTy) scrut altTId <- extendIdentifier Extended dstId "_sel_alt_t" altFId <- extendIdentifier Extended dstId "_sel_alt_f" - (altTExpr,altTDecls) <- mkExpr False (Left altTId) altTy altT - (altFExpr,altFDecls) <- mkExpr False (Left altFId) altTy altF - return $! scrutDecls ++ altTDecls ++ altFDecls ++ tickDecls ++ + (altTExpr,altTDecls) <- mkExpr False declType (NetlistId altTId altTy) altT + (altFExpr,altFDecls) <- mkExpr False declType (NetlistId altFId altTy) altF + -- This logic (and the same logic a few lines below) is faulty in the + -- sense that it won't generate "void decls" if the alternatives' type + -- is void, but the type of the scrut isn't. Ideally, we'd like to pass + -- a boolean to 'mkExpr' indicating that it should only render "void decls" + -- but that it should skip any others. + -- + -- TODO: Fix ^ + if | isVoid altHTy && isVoid scrutHTy + -> return $! scrutDecls ++ altTDecls ++ altFDecls + | isVoid altHTy + -> return $! altTDecls ++ altFDecls + | otherwise + -> return $! scrutDecls ++ altTDecls ++ altFDecls ++ tickDecls ++ [Assignment dstId (IfThenElse scrutExpr altTExpr altFExpr)] _ -> do reprs <- Lens.use customReprs let alts1 = (reorderDefault . reorderCustom tcm reprs scrutTy) alts0 - altHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) altTy (scrutExpr,scrutDecls) <- first (mkScrutExpr sp scrutHTy (fst (head alts1))) <$> - mkExpr True (Left scrutId) scrutTy scrut - (exprs,altsDecls) <- (second concat . unzip) <$> mapM (mkCondExpr scrutHTy) alts1 - return $! scrutDecls ++ altsDecls ++ tickDecls ++ [CondAssignment dstId altHTy scrutExpr scrutHTy exprs] + mkExpr True declType (NetlistId scrutId scrutTy) scrut + (exprs,altsDecls) <- unzip <$> mapM (mkCondExpr scrutHTy) alts1 + case declType of + Sequential -> do + -- Assign to the result in every branch + let (altNets,exprAlts) = unzip (zipWith (altAssign dstId) + exprs altsDecls) + return $! scrutDecls ++ tickDecls ++ concat altNets ++ + [Seq [Branch scrutExpr scrutHTy exprAlts]] + Concurrent -> + if | isVoid altHTy && isVoid scrutHTy + -> return $! concat altsDecls ++ scrutDecls + | isVoid altHTy + -> return $! concat altsDecls + | otherwise + -> return $! scrutDecls ++ concat altsDecls ++ tickDecls + ++ [CondAssignment dstId altHTy scrutExpr scrutHTy exprs] where mkCondExpr :: HWType -> (Pat,Term) -> NetlistMonad ((Maybe HW.Literal,Expr),[Declaration]) mkCondExpr scrutHTy (pat,alt) = do altId <- extendIdentifier Extended - (either id id2identifier bndr) + (netlistId1 id id2identifier bndr) "_sel_alt" - (altExpr,altDecls) <- mkExpr False (Left altId) altTy alt + (altExpr,altDecls) <- mkExpr False declType (NetlistId altId altTy) alt (,altDecls) <$> case pat of DefaultPat -> return (Nothing,altExpr) DataPat dc _ _ -> return (Just (dcToLiteral scrutHTy (dcTag dc)),altExpr) @@ -448,6 +501,16 @@ _ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: Not a variable reference or primitive as subject of a case-statement:\n\n" ++ show scrutE) Nothing) _ -> scrutE + altAssign :: Identifier -> (Maybe HW.Literal,Expr) -> [Declaration] + -> ([Declaration],(Maybe HW.Literal,[Seq])) + altAssign i (m,expr) ds = + let (nets,rest) = partition isNet ds + assn = case expr of { Noop -> []; _ -> [SeqDecl (Assignment i expr)] } + in (nets,(m,map SeqDecl rest ++ assn)) + where + isNet NetDecl' {} = True + isNet _ = False + -- GHC puts default patterns in the first position, we want them in the -- last position. reorderDefault @@ -501,21 +564,26 @@ mkFunApp dstId fun args tickDecls = do topAnns <- Lens.use topEntityAnns tcm <- Lens.use tcCache - case lookupVarEnv fun topAnns of - Just (ty,annM) - | let (fArgTys,fResTy) = splitFunTys tcm ty - , length fArgTys == length args + case (isGlobalId fun, lookupVarEnv fun topAnns) of + (True, Just topEntity) + | let ty = varType (topId topEntity) + , let (fArgTys0,fResTy) = splitFunForallTy ty + -- Take into account that clocks and stuff are split off from any product + -- types containing them + , let fArgTys1 = splitShouldSplit tcm $ rights fArgTys0 + , length fArgTys1 == length args -> do - argHWTys <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc)) fArgTys - -- Filter out the arguments of hwtype `Void` and only translate them - -- to the intermediate HDL afterwards - let argsBundled = zip argHWTys (zip args fArgTys) - argsFiltered = filter (not . isVoid . fst) argsBundled - argsFiltered' = map snd argsFiltered - hWTysFiltered = filter (not . isVoid) argHWTys - (argExprs,argDecls) <- second concat . unzip <$> - mapM (\(e,t) -> mkExpr False (Left dstId) t e) - argsFiltered' + let annM = topAnnotation topEntity + argHWTys <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc)) fArgTys1 + (argExprs, concat -> argDecls) <- unzip <$> + mapM (\(e,t) -> mkExpr False Concurrent (NetlistId dstId t) e) + (zip args fArgTys1) + + -- Filter void arguments, but make sure to render their declarations: + let + filteredTypeExprs = filter (not . isVoid . fst) (zip argHWTys argExprs) + (hWTysFiltered, argExprsFiltered) = unzip filteredTypeExprs + dstHWty <- unsafeCoreTypeToHWTypeM' $(curLoc) fResTy env <- Lens.use hdlDir mkId <- Lens.use mkIdentifierFn @@ -530,29 +598,38 @@ Nothing -> return (env topName <.> "manifest") Just man <- readMaybe <$> liftIO (readFile manFile) instDecls <- mkTopUnWrapper fun annM man (dstId,dstHWty) - (zip argExprs hWTysFiltered) + (zip argExprsFiltered hWTysFiltered) tickDecls return (argDecls ++ instDecls) - | otherwise -> error $ $(curLoc) ++ "under-applied TopEntity" - _ -> do + | otherwise -> error $ $(curLoc) ++ "under-applied TopEntity: " ++ showPpr fun + (True, Nothing) -> do normalized <- Lens.use bindings case lookupVarEnv fun normalized of - Just _ -> do + Nothing -> error [I.i| + Internal error: unknown normalized binder: + + #{showPpr fun} + |] + Just (Binding{bindingTerm}) -> do (_,_,_,Component compName compInps co _) <- preserveVarEnv $ genComponent fun let argTys = map (termType tcm) args argHWTys <- mapM coreTypeToHWTypeM' argTys - -- Filter out the arguments of hwtype `Void` and only translate - -- them to the intermediate HDL afterwards - let argsBundled = zip argHWTys (zip args argTys) - argsFiltered = filter (maybe True (not . isVoid) . fst) argsBundled - argsFiltered' = map snd argsFiltered - tysFiltered = map snd argsFiltered' - compOutp = snd <$> listToMaybe co - if length tysFiltered == length compInps + + (argExprs, concat -> argDecls) <- unzip <$> + mapM (\(e,t) -> mkExpr False Concurrent (NetlistId dstId t) e) + (zip args argTys) + + -- Filter void arguments, but make sure to render their declarations: + let + argTypeExprs = zip argHWTys (zip argTys argExprs) + filteredTypeExprs = filterOnFst (not . isVoidMaybe True) argTypeExprs + (argTysFiltered, argsFiltered) = unzip filteredTypeExprs + + let compOutp = (\(_,x,_) -> x) <$> listToMaybe co + if length argTysFiltered == length compInps then do - (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr False (Left dstId) t e) argsFiltered' - (argExprs',argDecls') <- (second concat . unzip) <$> mapM (toSimpleVar dstId) (zip argExprs tysFiltered) + (argExprs',argDecls') <- (second concat . unzip) <$> mapM (toSimpleVar dstId) (zip argsFiltered argTysFiltered) let inpAssigns = zipWith (\(i,t) e -> (Identifier i Nothing,In,t,e)) compInps argExprs' outpAssign = case compOutp of Nothing -> [] @@ -563,11 +640,52 @@ instLabel3 <- mkUniqueIdentifier Basic instLabel2 let instDecl = InstDecl Entity Nothing compName instLabel3 [] (outpAssign ++ inpAssigns) return (argDecls ++ argDecls' ++ tickDecls ++ [instDecl]) - else error $ $(curLoc) ++ "under-applied normalized function" - Nothing -> case args of - [] -> return [Assignment dstId (Identifier (nameOcc $ varName fun) Nothing)] - _ -> error $ $(curLoc) ++ "Unknown function: " ++ showPpr fun + else error [I.i| + Under-applied normalized function at component #{compName}: + #{showPpr fun} + + Core: + + #{showPpr bindingTerm} + + Applied to arguments: + #{showPpr args} + + Applied to filtered arguments: + #{argsFiltered} + + Component inputs: + #{compInps} + |] + _ -> + case args of + [] -> + -- TODO: Figure out what to do with zero-width constructs + return [Assignment dstId (Identifier (nameOcc $ varName fun) Nothing)] + _ -> error [I.i| + Netlist generation encountered a local function. This should not + happen. Function: + + #{showPpr fun} + + Arguments: + + #{showPpr args} + + Posssible user issues: + + * A top entity has an higher-order argument, e.g (Int -> Int) or + Maybe (Int -> Int) + + Possible internal compiler issues: + + * 'bindOrLiftNonRep' failed to fire + + * 'caseCon' failed to eliminate something of a type such as + "Maybe (Int -> Int)" + |] + toSimpleVar :: Identifier -> (Expr,Type) -> NetlistMonad (Expr,[Declaration]) @@ -585,8 +703,9 @@ -- | Generate an expression for a term occurring on the RHS of a let-binder mkExpr :: HasCallStack => Bool -- ^ Treat BlackBox expression as declaration - -> (Either Identifier Id) -- ^ Id to assign the result to - -> Type -- ^ Type of the LHS of the let-binder + -> DeclarationType + -- ^ Should the returned declarations be concurrent or sequential? + -> NetlistId -- ^ Id to assign the result to -> Term -- ^ Term to convert to an expression -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations mkExpr _ _ _ (stripTicks -> Core.Literal l) = do @@ -608,25 +727,35 @@ ByteArrayLiteral (PV.Vector _ _ (ByteArray ba)) -> return (HW.Literal Nothing (NumLit (Jp# (BN# ba))),[]) _ -> error $ $(curLoc) ++ "not an integer or char literal" -mkExpr bbEasD bndr ty app = +mkExpr bbEasD declType bndr app = let (appF,args,ticks) = collectArgsTicks app (tmArgs,tyArgs) = partitionEithers args in withTicks ticks $ \tickDecls -> do - hwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) ty + hwTys <- mapM (unsafeCoreTypeToHWTypeM' $(curLoc)) (netlistTypes bndr) (_,sp) <- Lens.use curCompNm + let hwTyA = head hwTys case appF of - Data dc -> mkDcApplication hwTy bndr dc tmArgs - Prim nm _ -> mkPrimitive False bbEasD bndr nm args ty tickDecls + Data dc -> mkDcApplication hwTys bndr dc tmArgs + Prim pInfo -> mkPrimitive False bbEasD bndr pInfo args tickDecls Var f - | null tmArgs -> return (Identifier (nameOcc $ varName f) Nothing,[]) + | null tmArgs -> + if isVoid hwTyA then + return (Noop, []) + else + return (Identifier (nameOcc $ varName f) Nothing, []) | not (null tyArgs) -> - throw (ClashException sp ($(curLoc) ++ "Not in normal form: Var-application with Type arguments:\n\n" ++ showPpr app) Nothing) + throw (ClashException sp ($(curLoc) ++ "Not in normal form: " + ++ "Var-application with Type arguments:\n\n" ++ showPpr app) Nothing) | otherwise -> do - argNm0 <- extendIdentifier Extended (either id id2identifier bndr) "_fun_arg" + argNm0 <- extendIdentifier Extended (netlistId1 id id2identifier bndr) + "_fun_arg" argNm1 <- mkUniqueIdentifier Extended argNm0 - hwTyA <- unsafeCoreTypeToHWTypeM' $(curLoc) ty decls <- mkFunApp argNm1 f tmArgs tickDecls - return (Identifier argNm1 Nothing, NetDecl' Nothing Wire argNm1 (Right hwTyA):decls) + if isVoid hwTyA then + return (Noop, decls) + else + return ( Identifier argNm1 Nothing + , NetDecl' Nothing Wire argNm1 (Right hwTyA) Nothing:decls) Case scrut ty' [alt] -> mkProjection bbEasD bndr scrut ty' alt Case scrut tyA alts -> do tcm <- Lens.use tcCache @@ -636,15 +765,19 @@ let wr = case iteAlts scrutHTy alts of Just _ | ite -> Wire _ -> Reg - argNm0 <- extendIdentifier Extended (either id id2identifier bndr) "_sel_arg" + argNm0 <- extendIdentifier Extended (netlistId1 id id2identifier bndr) "_sel_arg" argNm1 <- mkUniqueIdentifier Extended argNm0 - hwTyA <- unsafeCoreTypeToHWTypeM' $(curLoc) tyA - decls <- mkSelection (Left argNm1) scrut tyA alts tickDecls - return (Identifier argNm1 Nothing, NetDecl' Nothing wr argNm1 (Right hwTyA):decls) + decls <- mkSelection declType (NetlistId argNm1 (netlistTypes1 bndr)) + scrut tyA alts tickDecls + if isVoid hwTyA then + return (Noop, decls) + else + return ( Identifier argNm1 Nothing + , NetDecl' Nothing wr argNm1 (Right hwTyA) Nothing:decls) Letrec binders body -> do netDecls <- fmap catMaybes $ mapM mkNetDecl binders decls <- concat <$> mapM (uncurry mkDeclarations) binders - (bodyE,bodyDecls) <- mkExpr bbEasD bndr ty (mkApps (mkTicks body ticks) args) + (bodyE,bodyDecls) <- mkExpr bbEasD declType bndr (mkApps (mkTicks body ticks) args) return (bodyE,netDecls ++ decls ++ bodyDecls) _ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: application of a Lambda-expression\n\n" ++ showPpr app) Nothing) @@ -654,7 +787,7 @@ mkProjection :: Bool -- ^ Projection must bind to a simple variable - -> Either Identifier Id + -> NetlistId -- ^ The signal to which the projection is (potentially) assigned -> Term -- ^ The subject/scrutinee of the projection @@ -675,59 +808,79 @@ ++ showPpr e) Nothing) sHwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy vHwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) altTy - (selId,modM,decls) <- do - scrutNm <- either return - (\b -> extendIdentifier Extended - (id2identifier b) - "_projection") - bndr - (scrutExpr,newDecls) <- mkExpr False (Left scrutNm) scrutTy scrut + scrutRendered <- do + scrutNm <- + netlistId1 + return + (\b -> extendIdentifier Extended (id2identifier b) "_projection") + bndr + (scrutExpr,newDecls) <- mkExpr False Concurrent (NetlistId scrutNm scrutTy) scrut case scrutExpr of - Identifier newId modM -> return (newId,modM,newDecls) + Identifier newId modM -> + pure (Right (newId, modM, newDecls)) + Noop -> + -- Scrutinee was a zero-width / void construct. We need to render its + -- declarations, but it's no use assigning it to a new variable. + -- TODO: Figure out whether we need to render alternatives too. + -- TODO: seems useless? + pure (Left newDecls) _ -> do scrutNm' <- mkUniqueIdentifier Extended scrutNm let scrutDecl = NetDecl Nothing scrutNm' sHwTy scrutAssn = Assignment scrutNm' scrutExpr - return (scrutNm',Nothing,newDecls ++ [scrutDecl,scrutAssn]) + pure (Right (scrutNm', Nothing, newDecls ++ [scrutDecl, scrutAssn])) - let altVarId = nameOcc (varName varTm) - modifier <- case pat of + case scrutRendered of + Left newDecls -> pure (Noop, newDecls) + Right (selId, modM, decls) -> do + let altVarId = nameOcc (varName varTm) + modifier <- case pat of DataPat dc exts tms -> do - let tms' = if bindsExistentials exts tms - then throw (ClashException sp ($(curLoc) ++ "Not in normal form: Pattern binds existential variables:\n\n" ++ showPpr e) Nothing) - else tms + let + tms' = + if bindsExistentials exts tms then + throw (ClashException sp ($(curLoc) + ++ "Not in normal form: Pattern binds existential variables:\n\n" + ++ showPpr e) Nothing) + else + tms argHWTys <- mapM coreTypeToHWTypeM' (map varType tms) let tmsBundled = zip argHWTys tms' tmsFiltered = filter (maybe False (not . isVoid) . fst) tmsBundled tmsFiltered' = map snd tmsFiltered case elemIndex varTm {varType = altTy} tmsFiltered' of - Nothing -> pure Nothing - Just fI - | sHwTy /= vHwTy -> pure $ nestModifier modM (Just (Indexed (sHwTy,dcTag dc - 1,fI))) - -- When element and subject have the same HW-type, - -- then the projections is just the identity - | otherwise -> pure $ nestModifier modM (Just (DC (Void Nothing,0))) - _ -> throw (ClashException sp ($(curLoc) ++ "Not in normal form: Unexpected pattern in case-projection:\n\n" ++ showPpr e) Nothing) - let extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier - case bndr of - Left scrutNm | mkDec -> do - scrutNm' <- mkUniqueIdentifier Extended scrutNm - let scrutDecl = NetDecl Nothing scrutNm' vHwTy - scrutAssn = Assignment scrutNm' extractExpr - return (Identifier scrutNm' Nothing,scrutDecl:scrutAssn:decls) - _ -> return (extractExpr,decls) + Nothing -> pure Nothing + Just fI + | sHwTy /= vHwTy -> + pure $ nestModifier modM (Just (Indexed (sHwTy,dcTag dc - 1,fI))) + -- When element and subject have the same HW-type, + -- then the projections is just the identity + | otherwise -> + pure $ nestModifier modM (Just (DC (Void Nothing,0))) + _ -> throw (ClashException sp ($(curLoc) + ++ "Not in normal form: Unexpected pattern in case-projection:\n\n" + ++ showPpr e) Nothing) + let extractExpr = Identifier (maybe altVarId (const selId) modifier) modifier + case bndr of + NetlistId scrutNm _ | mkDec -> do + scrutNm' <- mkUniqueIdentifier Extended scrutNm + let scrutDecl = NetDecl Nothing scrutNm' vHwTy + scrutAssn = Assignment scrutNm' extractExpr + return (Identifier scrutNm' Nothing,scrutDecl:scrutAssn:decls) + MultiId {} -> error "mkProjection: MultiId" + _ -> return (extractExpr,decls) where nestModifier Nothing m = m nestModifier m Nothing = m nestModifier (Just m1) (Just m2) = Just (Nested m1 m2) - -- | Generate an expression for a DataCon application occurring on the RHS of a let-binder mkDcApplication :: HasCallStack - => HWType - -- ^ HWType of the LHS of the let-binder - -> (Either Identifier Id) + => [HWType] + -- ^ HWType of the LHS of the let-binder, can multiple types when we're + -- creating a "split" product type (e.g. a tuple of a Clock and Reset) + -> NetlistId -- ^ Id to assign the result to -> DataCon -- ^ Applied DataCon @@ -735,19 +888,26 @@ -- ^ DataCon Arguments -> NetlistMonad (Expr,[Declaration]) -- ^ Returned expression and a list of generate BlackBox declarations -mkDcApplication dstHType bndr dc args = do +mkDcApplication [dstHType] bndr dc args = do let dcNm = nameOcc (dcName dc) - tcm <- Lens.use tcCache - let argTys = map (termType tcm) args - argNm <- either return (\b -> extendIdentifier Extended (nameOcc (varName b)) "_dc_arg") bndr - argHWTys <- mapM coreTypeToHWTypeM' argTys - -- Filter out the arguments of hwtype `Void` and only translate - -- them to the intermediate HDL afterwards - let argsBundled = zip argHWTys (zip args argTys) - (hWTysFiltered,argsFiltered) = unzip - (filter (maybe True (not . isVoid) . fst) argsBundled) - (argExprs,argDecls) <- fmap (second concat . unzip) $! mapM (\(e,t) -> mkExpr False (Left argNm) t e) argsFiltered - fmap (,argDecls) $! case (hWTysFiltered,argExprs) of + tcm <- Lens.use tcCache + let argTys = map (termType tcm) args + argNm <- netlistId1 return (\b -> extendIdentifier Extended (nameOcc (varName b)) "_dc_arg") bndr + argHWTys <- mapM coreTypeToHWTypeM' argTys + + (argExprs, concat -> argDecls) <- unzip <$> + mapM (\(e,t) -> mkExpr False Concurrent (NetlistId argNm t) e) (zip args argTys) + + -- Filter void arguments, but make sure to render their declarations: + let + filteredTypeExprDecls = + filter + (not . isVoidMaybe True . fst) + (zip argHWTys argExprs) + + (hWTysFiltered, argExprsFiltered) = unzip filteredTypeExprDecls + + fmap (,argDecls) $! case (hWTysFiltered,argExprsFiltered) of -- Is the DC just a newtype wrapper? ([Just argHwTy],[argExpr]) | argHwTy == dstHType -> return (HW.DataCon dstHType (DC (Void Nothing,-1)) [argExpr]) @@ -755,15 +915,20 @@ SP _ dcArgPairs -> do let dcI = dcTag dc - 1 dcArgs = snd $ indexNote ($(curLoc) ++ "No DC with tag: " ++ show dcI) dcArgPairs dcI - case compare (length dcArgs) (length argExprs) of - EQ -> return (HW.DataCon dstHType (DC (dstHType,dcI)) argExprs) + case compare (length dcArgs) (length argExprsFiltered) of + EQ -> return (HW.DataCon dstHType (DC (dstHType,dcI)) argExprsFiltered) LT -> error $ $(curLoc) ++ "Over-applied constructor" GT -> error $ $(curLoc) ++ "Under-applied constructor" Product _ _ dcArgs -> - case compare (length dcArgs) (length argExprs) of - EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprs) + case compare (length dcArgs) (length argExprsFiltered) of + EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprsFiltered) LT -> error $ $(curLoc) ++ "Over-applied constructor" GT -> error $ $(curLoc) ++ "Under-applied constructor" + CustomProduct _ _ _ _ dcArgs -> + case compare (length dcArgs) (length argExprsFiltered) of + EQ -> return (HW.DataCon dstHType (DC (dstHType,0)) argExprsFiltered) + LT -> error $ $(curLoc) ++ "Over-applied constructor" + GT -> error $ $(curLoc) ++ "Under-applied constructor" Sum _ _ -> return (HW.DataCon dstHType (DC (dstHType,dcTag dc - 1)) []) CustomSP _ _ _ dcArgsTups -> do @@ -773,8 +938,8 @@ let argTup = indexNote note dcArgsTups dcI let (_, _, dcArgs) = argTup - case compare (length dcArgs) (length argExprs) of - EQ -> return (HW.DataCon dstHType (DC (dstHType, dcI)) argExprs) + case compare (length dcArgs) (length argExprsFiltered) of + EQ -> return (HW.DataCon dstHType (DC (dstHType, dcI)) argExprsFiltered) LT -> error $ $(curLoc) ++ "Over-applied constructor" GT -> error $ $(curLoc) ++ "Under-applied constructor" @@ -787,16 +952,16 @@ tg -> error $ $(curLoc) ++ "unknown bool literal: " ++ showPpr dc ++ "(tag: " ++ show tg ++ ")" in return dc' Vector 0 _ -> return (HW.DataCon dstHType VecAppend []) - Vector 1 _ -> case argExprs of + Vector 1 _ -> case argExprsFiltered of [e] -> return (HW.DataCon dstHType VecAppend [e]) _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showPpr args - Vector _ _ -> case argExprs of + Vector _ _ -> case argExprsFiltered of [e1,e2] -> return (HW.DataCon dstHType VecAppend [e1,e2]) _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `Cons`: " ++ showPpr args - RTree 0 _ -> case argExprs of + RTree 0 _ -> case argExprsFiltered of [e] -> return (HW.DataCon dstHType RTreeAppend [e]) _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `LR`: " ++ showPpr args - RTree _ _ -> case argExprs of + RTree _ _ -> case argExprsFiltered of [e1,e2] -> return (HW.DataCon dstHType RTreeAppend [e1,e2]) _ -> error $ $(curLoc) ++ "Unexpected number of arguments for `BR`: " ++ showPpr args String -> @@ -804,31 +969,51 @@ 1 -> HW.Literal Nothing (StringLit "") _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,dcTag dc,args,argHWTys) in return dc' - Void {} -> return (Identifier "__VOID__" Nothing) + Void {} -> return Noop Signed _ | dcNm == "GHC.Integer.Type.S#" - -> pure (head argExprs) + -> pure (head argExprsFiltered) + -- ByteArray# are non-translatable / void, except when they're literals | dcNm == "GHC.Integer.Type.Jp#" + , HW.Literal Nothing (NumLit _) <- head argExprs -> pure (head argExprs) | dcNm == "GHC.Integer.Type.Jn#" + -- ByteArray# are non-translatable / void, except when they're literals , HW.Literal Nothing (NumLit i) <- head argExprs -> pure (HW.Literal Nothing (NumLit (negate i))) Unsigned _ | dcNm == "GHC.Natural.NatS#" - -> pure (head argExprs) + -> pure (head argExprsFiltered) | dcNm == "GHC.Natural.NatJ#" + -- ByteArray# are non-translatable / void, except when they're literals + , HW.Literal Nothing (NumLit _) <- head argExprs -> pure (head argExprs) --- KnownDomain {} -> --- return (Identifier "__KNOWNDOMAIN__" Nothing) --- pure $ --- error $ $(curLoc) ++ "mkDcApplication undefined for KnownDomain. " --- ++ "Did a blackbox definition try to render it? " --- ++ "Context: \n\n" --- ++ "dstHType: " ++ show dstHType ++ "\n\n" --- ++ "dc: " ++ show dc ++ "\n\n" --- ++ "args: " ++ show args ++ "\n\n" --- ++ "argHWTys: " ++ show argHWTys ++ "\n\n" --- ++ "Callstack: " --- ++ prettyCallStack callStack _ -> error $ $(curLoc) ++ "mkDcApplication undefined for: " ++ show (dstHType,dc,args,argHWTys) + +-- Handle MultiId assignment +mkDcApplication dstHTypes (MultiId argNms) _ args = do + tcm <- Lens.use tcCache + let argTys = map (termType tcm) args + argHWTys <- mapM coreTypeToHWTypeM' argTys + -- Filter out the arguments of hwtype `Void` and only translate + -- them to the intermediate HDL afterwards + let argsBundled = zip argHWTys (zipEqual (map CoreId argNms) args) + (_hWTysFiltered,argsFiltered) = unzip + (filter (maybe True (not . isVoid) . fst) argsBundled) + (argExprs,argDecls) <- fmap (second concat . unzip) $! + mapM (uncurry (mkExpr False Concurrent)) argsFiltered + if length dstHTypes == length argExprs then do + let assns = mapMaybe + (\case (_,Noop) -> Nothing + (dstId,e) -> let nm = netlistId1 id id2identifier dstId + in case e of + Identifier nm0 Nothing + | nm == nm0 -> Nothing + _ -> Just (Assignment nm e)) + (zip (map CoreId argNms) argExprs) + return (Noop,argDecls ++ assns) + else + error "internal error" + +mkDcApplication _ _ _ _ = error "internal error" diff --git a/src/Clash/Netlist.hs-boot b/src/Clash/Netlist.hs-boot --- a/src/Clash/Netlist.hs-boot +++ b/src/Clash/Netlist.hs-boot @@ -9,6 +9,7 @@ ,mkExpr ,mkDcApplication ,mkDeclarations + ,mkDeclarations' ,mkNetDecl ,mkProjection ,mkSelection @@ -21,7 +22,7 @@ import Clash.Core.Type (Type) import Clash.Core.Var (Id) import Clash.Netlist.Types (Expr, HWType, Identifier, NetlistMonad, Component, - Declaration) + Declaration, NetlistId, DeclarationType) import SrcLoc (SrcSpan) import GHC.Stack (HasCallStack) @@ -32,28 +33,29 @@ mkExpr :: HasCallStack => Bool - -> Either Identifier Id - -> Type + -> DeclarationType + -> NetlistId -> Term -> NetlistMonad (Expr,[Declaration]) mkDcApplication :: HasCallStack - => HWType - -> Either Identifier Id + => [HWType] + -> NetlistId -> DataCon -> [Term] -> NetlistMonad (Expr,[Declaration]) mkProjection :: Bool - -> Either Identifier Id + -> NetlistId -> Term -> Type -> Alt -> NetlistMonad (Expr, [Declaration]) mkSelection - :: Either Identifier Id + :: DeclarationType + -> NetlistId -> Term -> Type -> [Alt] @@ -63,6 +65,7 @@ mkNetDecl :: LetBinding -> NetlistMonad (Maybe Declaration) mkDeclarations :: HasCallStack => Id -> Term -> NetlistMonad [Declaration] +mkDeclarations' :: HasCallStack => DeclarationType -> Id -> Term -> NetlistMonad [Declaration] mkFunApp :: HasCallStack diff --git a/src/Clash/Netlist/BlackBox.hs b/src/Clash/Netlist/BlackBox.hs --- a/src/Clash/Netlist/BlackBox.hs +++ b/src/Clash/Netlist/BlackBox.hs @@ -8,32 +8,32 @@ Functions to create BlackBox Contexts and fill in BlackBox templates -} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Netlist.BlackBox where import Control.Exception (throw) import Control.Lens ((<<%=),(%=)) import qualified Control.Lens as Lens -import Control.Monad (when) +import Control.Monad (when, replicateM) import Control.Monad.IO.Class (liftIO) import Data.Char (ord) import Data.Either (lefts, partitionEithers) import qualified Data.HashMap.Lazy as HashMap import qualified Data.IntMap as IntMap -import Data.List (elemIndex) -import Data.Maybe (catMaybes, fromJust) +import Data.List (elemIndex, partition) +import Data.Maybe (catMaybes, fromJust, fromMaybe) import Data.Semigroup.Monad import qualified Data.Set as Set import Data.Text.Lazy (fromStrict) import qualified Data.Text.Lazy as Text import Data.Text (unpack) import qualified Data.Text as TextS +import GHC.Stack + (callStack, prettyCallStack) import qualified System.Console.ANSI as ANSI import System.Console.ANSI ( hSetSGR, SGR(SetConsoleIntensity, SetColor), Color(Magenta) @@ -44,7 +44,10 @@ import Util (OverridingBool(..)) import Clash.Annotations.Primitive - (PrimitiveGuard(HasBlackBox, WarnNonSynthesizable, WarnAlways, DontTranslate)) + (PrimitiveGuard(HasBlackBox, WarnNonSynthesizable, WarnAlways, DontTranslate), + extractPrim) +import Clash.Annotations.TopEntity + (TopEntity(Synthesize), PortName(PortName)) import Clash.Core.DataCon as D (dcTag) import Clash.Core.FreeVars (freeIds) import Clash.Core.Literal as L (Literal (..)) @@ -53,18 +56,19 @@ import Clash.Core.Pretty (showPpr) import Clash.Core.Subst (extendIdSubst, mkSubst, substTm) import Clash.Core.Term as C - (Term (..), collectArgs, collectArgsTicks) -import Clash.Core.Type as C (Type (..), ConstTy (..), - splitFunTys, splitFunTy) -import Clash.Core.TyCon as C (tyConDataCons) -import Clash.Core.Util (isFun, termType) + (PrimInfo (..), Term (..), WorkInfo (..), collectArgs, collectArgsTicks) +import Clash.Core.Type as C + (Type (..), ConstTy (..), TypeView (..), mkFunTy, splitFunTys, splitFunTy, tyView) +import Clash.Core.TyCon as C (TyConMap, tyConDataCons) +import Clash.Core.Util + (collectBndrs, inverseTopSortLetBindings, isFun, mkApps, splitShouldSplit, termType) import Clash.Core.Var as V (Id, Var (..), mkLocalId, modifyVarName) import Clash.Core.VarEnv (extendInScopeSet, mkInScopeSet, lookupVarEnv, uniqAway, unitVarSet) import {-# SOURCE #-} Clash.Netlist (genComponent, mkDcApplication, mkDeclarations, mkExpr, mkNetDecl, - mkProjection, mkSelection, mkFunApp) + mkProjection, mkSelection, mkFunApp, mkDeclarations') import qualified Clash.Backend as Backend import Clash.Driver.Types (opt_primWarn, opt_color, ClashOpts) @@ -74,6 +78,8 @@ import Clash.Netlist.Types as N import Clash.Netlist.Util as N import Clash.Primitives.Types as P +import qualified Clash.Primitives.Util as P +import Clash.Signal.Internal (ActiveEdge (..)) import Clash.Unique (lookupUniqMap') import Clash.Util @@ -102,35 +108,59 @@ -- ^ Blackbox function name -> Id -- ^ Identifier binding the primitive/blackbox application - -> [Term] + -> [Either Term Type] -- ^ Arguments of the primitive/blackbox application -> NetlistMonad (BlackBoxContext,[Declaration]) -mkBlackBoxContext bbName resId args = do +mkBlackBoxContext bbName resId args@(lefts -> termArgs) = do -- Make context inputs - tcm <- Lens.use tcCache let resNm = nameOcc (varName resId) - (imps,impDecls) <- unzip <$> mapM (mkArgument resNm) args - (funs,funDecls) <- mapAccumLM (addFunction tcm) IntMap.empty (zip args [0..]) + resTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (V.varType resId) + (imps,impDecls) <- unzip <$> mapM (mkArgument resNm) termArgs + (funs,funDecls) <- + mapAccumLM + (addFunction (V.varType resId)) + IntMap.empty + (zip termArgs [0..]) -- Make context result let res = Identifier resNm Nothing - resTy <- unsafeCoreTypeToHWTypeM' $(curLoc) (V.varType resId) lvl <- Lens.use curBBlvl (nm,_) <- Lens.use curCompNm - return ( Context bbName (res,resTy) imps funs [] lvl nm + -- Set "context name" to value set by `Clash.Magic.setName`, default to the + -- name of the closest binder + ctxName1 <- fromMaybe resNm <$> Lens.view setName + -- Update "context name" with prefixes and suffixes set by + -- `Clash.Magic.prefixName` and `Clash.Magic.suffixName` + ctxName2 <- affixName ctxName1 + + return ( Context bbName (res,resTy) imps funs [] lvl nm (Just ctxName2) , concat impDecls ++ concat funDecls ) where - addFunction tcm im (arg,i) = if isFun tcm arg - then do curBBlvl Lens.+= 1 - (f,d) <- mkFunInput resId arg - curBBlvl Lens.-= 1 - let im' = IntMap.insert i f im - return (im',d) - else return (im,[]) + addFunction resTy im (arg,i) = do + tcm <- Lens.use tcCache + if isFun tcm arg then do + -- Only try to calculate function plurality when primitive actually + -- exists. Here to prevent crashes on __INTERNAL__ primitives. + prim <- HashMap.lookup bbName <$> Lens.use primitives + funcPlurality <- + case extractPrim <$> prim of + Just (Just p) -> + P.getFunctionPlurality p args resTy i + _ -> + pure 1 + curBBlvl Lens.+= 1 + (fs,ds) <- unzip <$> replicateM funcPlurality (mkFunInput resId arg) + curBBlvl Lens.-= 1 + + let im' = IntMap.insert i fs im + return (im', concat ds) + else + return (im, []) + prepareBlackBox :: TextS.Text -> BlackBox @@ -156,7 +186,7 @@ isLiteral :: Term -> Bool isLiteral e = case collectArgs e of (Data _, args) -> all (either isLiteral (const True)) args - (Prim _ _, args) -> all (either isLiteral (const True)) args + (Prim _, args) -> all (either isLiteral (const True)) args (C.Literal _,_) -> True _ -> False @@ -175,9 +205,9 @@ let eTyMsg = "(" ++ showPpr e ++ " :: " ++ showPpr ty ++ ")" ((e',t,l),d) <- case hwTyM of Nothing - | (Prim nm _,_) <- collectArgs e - , nm == "Clash.Transformations.removedArg" - -> return ((Identifier nm Nothing, Void Nothing, False),[]) + | (Prim p,_) <- collectArgs e + , primName p == "Clash.Transformations.removedArg" + -> return ((Identifier (primName p) Nothing, Void Nothing, False),[]) | otherwise -> return ((error ($(curLoc) ++ "Forced to evaluate untranslatable type: " ++ eTyMsg), Void Nothing, False), []) Just hwTy -> case collectArgsTicks e of @@ -198,16 +228,16 @@ return ((N.Literal (Just (Unsigned 64,64)) (N.NumLit i),hwTy,True),[]) (C.Literal (NaturalLiteral n), [],_) -> return ((N.Literal (Just (Unsigned iw,iw)) (N.NumLit n),hwTy,True),[]) - (Prim f _,args,ticks) -> withTicks ticks $ \tickDecls -> do - (e',d) <- mkPrimitive True False (Left bndr) f args ty tickDecls + (Prim pinfo,args,ticks) -> withTicks ticks $ \tickDecls -> do + (e',d) <- mkPrimitive True False (NetlistId bndr ty) pinfo args tickDecls case e' of (Identifier _ _) -> return ((e',hwTy,False), d) _ -> return ((e',hwTy,isLiteral e), d) (Data dc, args,_) -> do - (exprN,dcDecls) <- mkDcApplication hwTy (Left bndr) dc (lefts args) + (exprN,dcDecls) <- mkDcApplication [hwTy] (NetlistId bndr ty) dc (lefts args) return ((exprN,hwTy,isLiteral e),dcDecls) (Case scrut ty' [alt],[],_) -> do - (projection,decls) <- mkProjection False (Left bndr) scrut ty' alt + (projection,decls) <- mkProjection False (NetlistId bndr ty) scrut ty' alt return ((projection,hwTy,False),decls) _ -> return ((Identifier (error ($(curLoc) ++ "Forced to evaluate unexpected function argument: " ++ eTyMsg)) Nothing @@ -217,7 +247,8 @@ -- | Extract a compiled primitive from a guarded primitive. Emit a warning if -- the guard wants to, or fail entirely. extractPrimWarnOrFail - :: TextS.Text + :: HasCallStack + => TextS.Text -- ^ Name of primitive -> NetlistMonad CompiledPrimitive extractPrimWarnOrFail nm = do @@ -233,6 +264,7 @@ let msg = $(curLoc) ++ "No blackbox found for: " ++ unpack nm ++ ". Did you forget to include directories containing " ++ "primitives? You can use '-i/my/prim/dir' to achieve this." + ++ (if debugIsOn then "\n\n" ++ prettyCallStack callStack ++ "\n\n" else []) throw (ClashException sp msg Nothing) where go @@ -246,6 +278,7 @@ let msg = $(curLoc) ++ "Clash was forced to translate '" ++ unpack nm ++ "', but this value was marked with DontTranslate. Did you forget" ++ " to include a blackbox for one of the constructs using this?" + ++ (if debugIsOn then "\n\n" ++ prettyCallStack callStack ++ "\n\n" else []) throw (ClashException sp msg Nothing) go (WarnAlways warning cp) = do @@ -276,27 +309,27 @@ -- ^ Put BlackBox expression in parenthesis -> Bool -- ^ Treat BlackBox expression as declaration - -> Either Identifier Id + -> NetlistId -- ^ Id to assign the result to - -> TextS.Text - -- ^ Name of primitive + -> PrimInfo + -- ^ Primitive info -> [Either Term Type] -- ^ Arguments - -> Type - -- ^ Result type -> [Declaration] -- ^ Tick declarations -> NetlistMonad (Expr,[Declaration]) -mkPrimitive bbEParen bbEasD dst nm args ty tickDecls = - go =<< extractPrimWarnOrFail nm +mkPrimitive bbEParen bbEasD dst pInfo args tickDecls = + go =<< extractPrimWarnOrFail (primName pInfo) where + ty = head (netlistTypes dst) + go :: CompiledPrimitive -> NetlistMonad (Expr, [Declaration]) go = \case - P.BlackBoxHaskell bbName wf funcName (_fHash, func) -> do - bbFunRes <- func bbEasD nm args ty + P.BlackBoxHaskell bbName wf _usedArgs funcName (_fHash, func) -> do + bbFunRes <- func bbEasD (primName pInfo) args ty case bbFunRes of Left err -> do -- Blackbox template function returned an error: @@ -309,45 +342,68 @@ Right (BlackBoxMeta {..}, bbTemplate) -> -- Blackbox template generation succesful. Rerun 'go', but this time -- around with a 'normal' @BlackBox@ - go (P.BlackBox bbName wf bbKind () bbOutputReg bbLibrary bbImports bbIncludes bbTemplate) - p@P.BlackBox {outputReg = wr} -> + go (P.BlackBox + bbName wf bbRenderVoid bbKind () bbOutputReg bbLibrary bbImports + bbFunctionPlurality bbIncludes Nothing Nothing bbTemplate) + p@P.BlackBox {} -> case kind p of TDecl -> do let tempD = template p pNm = name p - wr' = if wr then Reg else Wire - resM <- resBndr True wr' dst + resM <- resBndr1 True dst case resM of Just (dst',dstNm,dstDecl) -> do - (bbCtx,ctxDcls) <- mkBlackBoxContext nm dst' (lefts args) + (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) dst' args (templ,templDecl) <- prepareBlackBox pNm tempD bbCtx let bbDecl = N.BlackBoxD pNm (libraries p) (imports p) (includes p) templ bbCtx return (Identifier dstNm Nothing,dstDecl ++ ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl]) - Nothing -> return (Identifier "__VOID__" Nothing,[]) + + -- Render declarations as a Noop when requested + Nothing | RenderVoid <- renderVoid p -> do + let dst1 = mkLocalId ty (mkUnsafeSystemName "__VOID_TDECL_NOOP__" 0) + (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) dst1 args + (templ,templDecl) <- prepareBlackBox pNm tempD bbCtx + let bbDecl = N.BlackBoxD pNm (libraries p) (imports p) + (includes p) templ bbCtx + return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl]) + + -- Otherwise don't render them + Nothing -> return (Noop,[]) TExpr -> do let tempE = template p pNm = name p if bbEasD then do - resM <- resBndr True Wire dst + resM <- resBndr1 True dst case resM of Just (dst',dstNm,dstDecl) -> do - (bbCtx,ctxDcls) <- mkBlackBoxContext nm dst' (lefts args) + (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) dst' args (bbTempl,templDecl) <- prepareBlackBox pNm tempE bbCtx let tmpAssgn = Assignment dstNm (BlackBoxE pNm (libraries p) (imports p) (includes p) bbTempl bbCtx bbEParen) return (Identifier dstNm Nothing, dstDecl ++ ctxDcls ++ templDecl ++ [tmpAssgn]) - Nothing -> return (Identifier "__VOID__" Nothing,[]) + + -- Render expression as a Noop when requested + Nothing | RenderVoid <- renderVoid p -> do + let dst1 = mkLocalId ty (mkUnsafeSystemName "__VOID_TEXPRD_NOOP__" 0) + (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) dst1 args + (templ,templDecl) <- prepareBlackBox pNm tempE bbCtx + let bbDecl = N.BlackBoxD pNm (libraries p) (imports p) + (includes p) templ bbCtx + return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl]) + + -- Otherwise don't render them + Nothing -> return (Identifier "__VOID_TEXPRD__" Nothing,[]) else do - resM <- resBndr False Wire dst + resM <- resBndr1 False dst case resM of Just (dst',_,_) -> do - (bbCtx,ctxDcls) <- mkBlackBoxContext nm dst' (lefts args) + (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) dst' args (bbTempl,templDecl0) <- prepareBlackBox pNm tempE bbCtx - let templDecl1 = case nm of + let templDecl1 = case primName pInfo of "Clash.Sized.Internal.BitVector.fromInteger#" | [N.Literal _ (NumLit _), N.Literal _ _, N.Literal _ _] <- extractLiterals bbCtx -> [] "Clash.Sized.Internal.BitVector.fromInteger##" @@ -360,6 +416,16 @@ | [N.Literal _ (NumLit _), N.Literal _ _] <- extractLiterals bbCtx -> [] _ -> templDecl0 return (BlackBoxE pNm (libraries p) (imports p) (includes p) bbTempl bbCtx bbEParen,ctxDcls ++ templDecl1) + -- Render expression as a Noop when requested + Nothing | RenderVoid <- renderVoid p -> do + let dst1 = mkLocalId ty (mkUnsafeSystemName "__VOID_TEXPRE_NOOP__" 0) + (bbCtx,ctxDcls) <- mkBlackBoxContext (primName pInfo) dst1 args + (templ,templDecl) <- prepareBlackBox pNm tempE bbCtx + let bbDecl = N.BlackBoxD pNm (libraries p) (imports p) + (includes p) templ bbCtx + return (Noop, ctxDcls ++ templDecl ++ tickDecls ++ [bbDecl]) + + -- Otherwise don't render them Nothing -> return (Identifier "__VOID__" Nothing,[]) P.Primitive pNm _ _ | pNm == "GHC.Prim.tagToEnum#" -> do @@ -369,12 +435,13 @@ tcm <- Lens.use tcCache let dcs = tyConDataCons (tcm `lookupUniqMap'` tcN) dc = dcs !! fromInteger i - (exprN,dcDecls) <- mkDcApplication hwTy dst dc [] + (exprN,dcDecls) <- mkDcApplication [hwTy] dst dc [] return (exprN,dcDecls) [Right _, Left scrut] -> do tcm <- Lens.use tcCache let scrutTy = termType tcm scrut - (scrutExpr,scrutDecls) <- mkExpr False (Left "c$tte_rhs") scrutTy scrut + (scrutExpr,scrutDecls) <- + mkExpr False Concurrent (NetlistId "c$tte_rhs" scrutTy) scrut case scrutExpr of Identifier id_ Nothing -> return (DataTag hwTy (Left id_),scrutDecls) _ -> do @@ -392,7 +459,8 @@ tcm <- Lens.use tcCache let scrutTy = termType tcm scrut scrutHTy <- unsafeCoreTypeToHWTypeM' $(curLoc) scrutTy - (scrutExpr,scrutDecls) <- mkExpr False (Left "c$dtt_rhs") scrutTy scrut + (scrutExpr,scrutDecls) <- + mkExpr False Concurrent (NetlistId "c$dtt_rhs" scrutTy) scrut case scrutExpr of Identifier id_ Nothing -> return (DataTag scrutHTy (Right id_),scrutDecls) _ -> do @@ -401,37 +469,358 @@ netAssignRhs = Assignment tmpRhs scrutExpr return (DataTag scrutHTy (Right tmpRhs),[netDeclRhs,netAssignRhs] ++ scrutDecls) _ -> error $ $(curLoc) ++ "dataToTag: " ++ show (map (either showPpr showPpr) args) + + | pNm == "Clash.Explicit.SimIO.mealyIO" -> do + resM <- resBndr1 True dst + case resM of + Just (_,dstNm,dstDecl) -> do + tcm <- Lens.use tcCache + mealyDecls <- collectMealy dstNm dst tcm (lefts args) + return (Noop, dstDecl ++ mealyDecls) + Nothing -> return (Noop,[]) + + | pNm == "Clash.Explicit.SimIO.bindSimIO#" -> + collectBindIO dst (lefts args) + + | pNm == "Clash.Explicit.SimIO.apSimIO#" -> do + collectAppIO dst (lefts args) [] + + | pNm == "Clash.Explicit.SimIO.fmapSimIO#" -> do + resM <- resBndr1 True dst + case resM of + Just (_,dstNm,dstDecl) -> do + tcm <- Lens.use tcCache + let (fun0:arg0:_) = lefts args + arg1 = unSimIO tcm arg0 + fun1 = case fun0 of + Lam b bE -> + let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet fun0) + subst = extendIdSubst (mkSubst is0) b arg1 + in substTm "mkPrimitive.fmapSimIO" subst bE + _ -> mkApps fun0 [Left arg1] + (expr,bindDecls) <- mkExpr False Sequential dst fun1 + let assn = case expr of + Noop -> [] + _ -> [Assignment dstNm expr] + return (Identifier dstNm Nothing, dstDecl ++ bindDecls ++ assn) + Nothing -> do + let (_:arg0:_) = lefts args + (_,bindDecls) <- mkExpr True Sequential dst arg0 + return (Noop, bindDecls) + + | pNm == "Clash.Explicit.SimIO.unSimIO#" -> + mkExpr False Sequential dst (head (lefts args)) + + | pNm == "Clash.Explicit.SimIO.pureSimIO#" -> do + (expr,decls) <- mkExpr False Sequential dst (head (lefts args)) + resM <- resBndr True dst + case resM of + Just (_,dstNms,dstDecl) -> case expr of + Noop -> + return (Noop,decls) + _ -> case dstNms of + [dstNm] -> + return ( Identifier dstNm Nothing + , dstDecl ++ decls ++ [Assignment dstNm expr]) + _ -> error "internal error" + _ -> + return (Noop,decls) + | otherwise -> return (BlackBoxE "" [] [] [] (BBTemplate [Text $ mconcat ["NO_TRANSLATION_FOR:",fromStrict pNm]]) (emptyBBContext pNm) False,[]) + -- Do we need to create a new identifier to assign the result? + -- + -- CoreId: No, this is an original LHS of a let-binder, and already has a + -- corresponding NetDecl; unlike NetlistIds, it is not already + -- assigned, it will be assigned by the BlackBox/Primitive. + -- + -- NetlistId: This is a derived (either from an CoreId or other NetlistId) + -- identifier created in the NetlistMonad that's already being + -- used in an assignment, i.e. we cannot assign it again. + -- + -- So if it is a declaration BlackBox (indicated by 'mkDec'), + -- we will have to create a new NetlistId, create a NetDecl for + -- it, and use this new NetlistId for the assignment inside the + -- declaration BlackBox + -- + -- MultiId: This is like a CoreId, but it's split over multiple identifiers + -- because it was originally of a product type where the element + -- types should not be part of an aggregate type in the generated + -- HDL (e.g. Clocks should not be part of an aggregate, because + -- tools like verilator don't like it) resBndr :: Bool - -> WireOrReg - -> (Either Identifier Id) - -> NetlistMonad (Maybe (Id,Identifier,[Declaration])) + -- Do we need to create and declare a new identifier in case we're given + -- a NetlistId? + -> NetlistId + -- CoreId/NetlistId/MultiId + -> NetlistMonad (Maybe ([Id],[Identifier],[Declaration])) -- Nothing when the binder would have type `Void` - resBndr mkDec wr dst' = case dst' of - Left dstL -> case mkDec of - False -> do - -- TODO: check that it's okay to use `mkUnsafeSystemName` - let nm' = mkUnsafeSystemName dstL 0 - id_ = mkLocalId ty nm' - return (Just (id_,dstL,[])) - True -> do - nm' <- extendIdentifier Extended dstL "_res" - nm'' <- mkUniqueIdentifier Extended nm' - -- TODO: check that it's okay to use `mkUnsafeInternalName` - let nm3 = mkUnsafeSystemName nm'' 0 - hwTy <- N.unsafeCoreTypeToHWTypeM' $(curLoc) ty - let id_ = mkLocalId ty nm3 - idDecl = NetDecl' Nothing wr nm'' (Right hwTy) - case hwTy of - Void {} -> return Nothing - _ -> return (Just (id_,nm'',[idDecl])) - Right dstR -> return (Just (dstR,nameOcc . varName $ dstR,[])) + resBndr mkDec dst' = do + resHwTy <- unsafeCoreTypeToHWTypeM' $(curLoc) ty + if isVoid resHwTy then + pure Nothing + else + case dst' of + NetlistId dstL _ -> case mkDec of + False -> do + -- TODO: check that it's okay to use `mkUnsafeSystemName` + let nm' = mkUnsafeSystemName dstL 0 + id_ = mkLocalId ty nm' + return (Just ([id_],[dstL],[])) + True -> do + nm1 <- extendIdentifier Extended dstL "_res" + nm2 <- mkUniqueIdentifier Extended nm1 + -- TODO: check that it's okay to use `mkUnsafeInternalName` + let nm3 = mkUnsafeSystemName nm2 0 + id_ = mkLocalId ty nm3 + idDeclM <- mkNetDecl (id_,mkApps (Prim pInfo) args) + case idDeclM of + Nothing -> return Nothing + Just idDecl -> return (Just ([id_],[nm2],[idDecl])) + CoreId dstR -> return (Just ([dstR],[nameOcc . varName $ dstR],[])) + MultiId ids -> return (Just (ids,map (nameOcc . varName) ids,[])) + -- Like resBndr, but fails on MultiId + resBndr1 + :: HasCallStack + => Bool + -> NetlistId + -> NetlistMonad (Maybe (Id,Identifier,[Declaration])) + resBndr1 mkDec dst' = resBndr mkDec dst' >>= \case + Nothing -> pure Nothing + Just ([id_],[nm_],decls) -> pure (Just (id_,nm_,decls)) + _ -> error "internal error" + +-- | Turn a 'mealyIO' expression into a two sequential processes, one "initial" +-- process for the starting state, and one clocked sequential process. +collectMealy + :: HasCallStack + => Identifier + -- ^ Identifier to assign the final result to + -> NetlistId + -- ^ Id to assign the final result to + -> TyConMap + -> [Term] + -- ^ The arguments to 'mealyIO' + -> NetlistMonad [Declaration] +collectMealy dstNm dst tcm (kd:clk:mealyFun:mealyInit:mealyIn:_) = do + let (lefts -> args0,res0) = collectBndrs mealyFun + is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet res0 <> + Lens.foldMapOf freeIds unitVarSet mealyInit <> + Lens.foldMapOf freeIds unitVarSet mealyIn) + -- Given that we're creating a sequential list of statements from the + -- let-bindings, make sure that everything is inverse topologically sorted + (bs,res) = case inverseTopSortLetBindings res0 of + Letrec bsN (C.Var resN) -> (bsN,resN) + Letrec bsN e -> + let u = case dst of + CoreId u0 -> u0 + _ -> uniqAway is0 + (mkLocalId (termType tcm e) + (mkUnsafeSystemName "mealyres" 0)) + in (bsN ++ [(u,e)], u) + e -> + let u = case dst of + CoreId u0 -> u0 + _ -> uniqAway is0 + (mkLocalId (termType tcm e) + (mkUnsafeSystemName "mealyres" 0)) + in ([(u,e)], u) + -- Drop the 'State# World' argument + args1 = init args0 + -- Take into account that the state argument is split over multiple + -- binders because it contained types that are not allowed to occur in + -- a HDL aggregate type + mealyInitLength = length (splitShouldSplit tcm [termType tcm mealyInit]) + (sArgs,iArgs) = splitAt mealyInitLength args1 + -- Give all binders a unique name + normE <- mkUniqueNormalized is0 + (Just (Just (Synthesize "" [] (PortName "")))) + ([],map (,mealyInit) sArgs ++ map (,mealyIn) iArgs ++ bs,res) + case normE of + -- We're not expecting any input or output wrappers + (_,[],[],_,[],binders0,Just result) -> do + let (sBinders,binders1) = splitAt (length sArgs) binders0 + (iBinders,binders2) = splitAt (length iArgs) binders1 + -- Get all the "original" let-bindings, without the above "mealyres". + -- We don't want to make a NetDecl for it. + bindersN = case res0 of + Letrec _ (C.Var {}) -> binders2 + _ -> init binders2 + + -- Create new net declarations for state-binders, input-binders, and all + -- the "original" let-bindings in 'mealyFun' + -- + -- The first set is only assigned in the always block, so they must be + -- 'reg' in Verilog terminology + netDeclsSeq <- fmap catMaybes (mapM mkNetDecl (sBinders ++ bindersN)) + -- The second set is assigned using concurrent assignment, so don't need + -- to be 'reg' + netDeclsInp <- fmap catMaybes (mapM mkNetDecl iBinders) + + -- If the 'mealyFun' was not a let-expression with a variable reference + -- as a body then we used the LHS of the entire 'mealyIO' expression as + -- a new let-binding; otherwise 'mkUniqueNormalized' would not work. + -- + -- However, 'mkUniqueNormalized' made a new unique name for that LHS, + -- which is not what we want. We want to assign the last expression to the + -- LHS of 'mealyIO'. + let bindersE = case res0 of + Letrec _ (C.Var {}) -> binders2 + _ -> case dst of + -- See above why we do this. + CoreId u0 -> init binders2 ++ [(u0,snd (last binders2))] + _ -> binders2 + seqDecls <- concat <$> mapM (uncurry (mkDeclarations' Sequential)) bindersE + + -- When the body the let-expression of 'mealyFun' was variable reference, + -- or in case we had to create a new identifier because the original LHS + -- was not available: then we need to assign + (resExpr,resDecls) <- case res0 of + Letrec _ (C.Var {}) -> mkExpr False Concurrent dst (C.Var result) + _ -> case dst of + CoreId {} -> pure (Noop,[]) + _ -> mkExpr False Concurrent dst (C.Var result) + let resAssn = case resExpr of + Noop -> [] + _ -> [Seq [AlwaysComb [SeqDecl (Assignment dstNm resExpr)]]] + + -- Create the declarations for the "initial state" block + let sDst = case sBinders of + [(b,_)] -> CoreId b + _ -> MultiId (map fst sBinders) + (exprInit,initDecls) <- mkExpr False Sequential sDst mealyInit + let initAssign = case exprInit of + Identifier _ Nothing -> [] + Noop -> [] + _ -> [Assignment (id2identifier (fst (head sBinders))) exprInit] + + -- Create the declarations that corresponding to the input + let iDst = case iBinders of + [(b,_)] -> CoreId b + _ -> MultiId (map fst iBinders) + (exprArg,inpDeclsMisc) <- mkExpr False Concurrent iDst mealyIn + + -- Split netdecl declarations and other declarations + let (netDeclsSeqMisc,seqDeclsOther) = partition isNet (seqDecls ++ resDecls) + (netDeclsInit,initDeclsOther) = partition isNet initDecls + -- All assignments happens within a sequential block, so the nets need to + -- be of type 'reg' in Verilog nomenclature + let netDeclsSeq1 = map toReg (netDeclsSeq ++ netDeclsSeqMisc ++ netDeclsInit) + + -- We run mealy block in the opposite clock edge of the the ambient system + -- because we're basically clocked logic; so we need to have our outputs + -- ready before the ambient system starts sampling them. The clockGen code + -- ensures that the "opposite" edge always comes first. + kdTy <- unsafeCoreTypeToHWTypeM $(curLoc) (termType tcm kd) + let edge = case stripVoid (stripFiltered kdTy) of + KnownDomain _ _ Rising _ _ _ -> Falling + KnownDomain _ _ Falling _ _ _ -> Rising + _ -> error "internal error" + (clkExpr,clkDecls) <- + mkExpr False Concurrent (NetlistId "__MEALY_CLK__" (termType tcm clk)) clk + + -- collect the declarations related to the input + let netDeclsInp1 = netDeclsInp ++ inpDeclsMisc + + -- Collate everything + return (clkDecls ++ netDeclsSeq1 ++ netDeclsInp1 ++ + [ Assignment (id2identifier (fst (head iBinders))) exprArg + , Seq [Initial (map SeqDecl (initDeclsOther ++ initAssign))] + , Seq [AlwaysClocked edge clkExpr (map SeqDecl seqDeclsOther)] + ] ++ resAssn) + _ -> error "internal error" + where + isNet NetDecl' {} = True + isNet _ = False + + toReg (NetDecl' cmM _ r ty eM) = NetDecl' cmM Reg r ty eM + toReg d = d + +collectMealy _ _ _ _ = error "internal error" + +-- | Collect the sequential declarations for 'bindIO' +collectBindIO :: NetlistId -> [Term] -> NetlistMonad (Expr,[Declaration]) +collectBindIO dst (m:Lam x q@(Lam _ e):_) = do + tcm <- Lens.use tcCache + ds0 <- collectAction tcm + case splitNormalized tcm q of + Right (args,bs0,res) -> do + let Letrec bs _ = inverseTopSortLetBindings (Letrec bs0 (C.Var res)) + let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet q) + normE <- mkUniqueNormalized is0 Nothing (args,bs,res) + case normE of + (_,_,[],_,[],binders,Just result) -> do + ds1 <- concat <$> mapM (uncurry (mkDeclarations' Sequential)) binders + netDecls <- fmap catMaybes (mapM mkNetDecl binders) + let assn = Assignment (netlistId1 id id2identifier dst) + (Identifier (id2identifier result) Nothing) + return (Noop, (netDecls ++ ds0 ++ ds1 ++ [assn])) + _ -> error "internal error" + _ -> case e of + Letrec {} -> error "internal error" + (collectArgs -> (Prim p,args)) + | primName p == "Clash.Explicit.SimIO.bindSimIO#" -> do + (expr,ds1) <- collectBindIO dst (lefts args) + return (expr, ds0 ++ ds1) + _ -> do + (expr,ds1) <- mkExpr False Sequential dst e + return (expr, ds0 ++ ds1) + where + collectAction tcm = case splitNormalized tcm m of + Right (args,bs0,res) -> do + let Letrec bs _ = inverseTopSortLetBindings (Letrec bs0 (C.Var res)) + let is0 = mkInScopeSet (Lens.foldMapOf freeIds unitVarSet m) + normE <- mkUniqueNormalized is0 Nothing (args,(x,m):bs,res) + case normE of + (_,_,[],_,[],binders,Just result) -> do + let binders1 = tail binders ++ [(fst (head binders), C.Var result)] + ds1 <- concat <$> mapM (uncurry (mkDeclarations' Sequential)) binders1 + netDecls <- fmap catMaybes (mapM mkNetDecl binders) + return (netDecls ++ ds1) + _ -> error "internal error" + _ -> do + netDecls <- fmap catMaybes (mapM mkNetDecl [(x,m)]) + ds1 <- mkDeclarations' Sequential x m + return (netDecls ++ ds1) + +collectBindIO _ es = error ("internal error:\n" ++ showPpr es) + +-- | Collect the sequential declarations for 'appIO' +collectAppIO :: NetlistId -> [Term] -> [Term] -> NetlistMonad (Expr,[Declaration]) +collectAppIO dst (fun1:arg1:_) rest = case collectArgs fun1 of + (Prim (PrimInfo "Clash.Explicit.SimIO.fmapSimIO#" _ _),(lefts -> (fun0:arg0:_))) -> do + tcm <- Lens.use tcCache + let argN = map (Left . unSimIO tcm) (arg0:arg1:rest) + mkExpr False Sequential dst (mkApps fun0 argN) + (Prim (PrimInfo "Clash.Explicit.SimIO.apSimIO#" _ _),(lefts -> args)) -> do + collectAppIO dst args (arg1:rest) + _ -> error ("internal error:\n" ++ showPpr (fun1:arg1:rest)) + + +collectAppIO _ es _ = error ("internal error:\n" ++ showPpr es) + +-- | Unwrap the new-type wrapper for things of type SimIO, this is needed to +-- allow applications of the `State# World` token to the underlying IO type. +-- +-- XXX: this is most likely needed because Ghc2Core that threw away the cast +-- that this unwrapping; we should really start to support casts. +unSimIO + :: TyConMap + -> Term + -> Term +unSimIO tcm arg = + let argTy = termType tcm arg + in case tyView argTy of + TyConApp _ [tcArg] -> + mkApps (Prim (PrimInfo "Clash.Explicit.SimIO.unSimIO#" (mkFunTy argTy tcArg) WorkNever)) + [Left arg] + _ -> error ("internal error:\n" ++ showPpr arg) + -- | Create an template instantiation text and a partial blackbox content for an -- argument term, given that the term is a function. Errors if the term is not -- a function @@ -455,18 +844,18 @@ tcm <- Lens.use tcCache -- TODO: Rewrite this function to use blackbox functions. Right now it -- TODO: generates strings that are later parsed/interpreted again. Silly! - (bbCtx,dcls) <- mkBlackBoxContext "__INTERNAL__" resId (lefts args) + (bbCtx,dcls) <- mkBlackBoxContext "__INTERNAL__" resId args templ <- case appE of - Prim nm _ -> do - bb <- extractPrimWarnOrFail nm + Prim p -> do + bb <- extractPrimWarnOrFail (primName p) case bb of P.BlackBox {..} -> - pure (Left (kind,outputReg,libraries,imports,includes,nm,template)) + pure (Left (kind,outputReg,libraries,imports,includes,primName p,template)) P.Primitive pn _ pt -> error $ $(curLoc) ++ "Unexpected blackbox type: " ++ "Primitive " ++ show pn ++ " " ++ show pt - P.BlackBoxHaskell pName _workInfo fName (_, func) -> do + P.BlackBoxHaskell pName _workInfo _usedArgs fName (_, func) -> do -- Determine result type of this blackbox. If it's not a -- function, simply use its term type. let @@ -571,7 +960,7 @@ normalized <- Lens.use bindings case lookupVarEnv fun normalized of Just _ -> do - (wereVoids,_,_,N.Component compName compInps [snd -> compOutp] _) <- + (wereVoids,_,_,N.Component compName compInps [(_,compOutp,_)] _) <- preserveVarEnv $ genComponent fun let inpAssign (i, t) e' = (Identifier i Nothing, In, t, e') @@ -638,7 +1027,7 @@ goExpr e' = do tcm <- Lens.use tcCache let eType = termType tcm e' - (appExpr,appDecls) <- mkExpr False (Left "c$bb_res") eType e' + (appExpr,appDecls) <- mkExpr False Concurrent (NetlistId "c$bb_res" eType) e' let assn = Assignment "~RESULT" appExpr nm <- if null appDecls then return "" @@ -660,7 +1049,9 @@ return (Right (("",[assn]),Wire)) go _ _ (Case scrut ty [alt]) = do - (projection,decls) <- mkProjection False (Left "c$bb_res") scrut ty alt + tcm <- Lens.use tcCache + let sTy = termType tcm scrut + (projection,decls) <- mkProjection False (NetlistId "c$bb_res" sTy) scrut ty alt let assn = Assignment "~RESULT" projection nm <- if null decls then return "" @@ -670,7 +1061,7 @@ go _ _ (Case scrut ty alts@(_:_:_)) = do -- TODO: check that it's okay to use `mkUnsafeSystemName` let resId' = resId {varName = mkUnsafeSystemName "~RESULT" 0} - selectionDecls <- mkSelection (Right resId') scrut ty alts [] + selectionDecls <- mkSelection Concurrent (CoreId resId') scrut ty alts [] nm <- mkUniqueIdentifier Basic "selection" tcm <- Lens.use tcCache let scrutTy = termType tcm scrut @@ -692,7 +1083,7 @@ let binders' = map (\(id_,tm) -> (goR result id_,tm)) binders netDecls <- fmap catMaybes . mapM mkNetDecl $ filter ((/= result) . fst) binders decls <- concat <$> mapM (uncurry mkDeclarations) binders' - Just (NetDecl' _ rw _ _) <- mkNetDecl . head $ filter ((==result) . fst) binders + Just (NetDecl' _ rw _ _ _) <- mkNetDecl . head $ filter ((==result) . fst) binders nm <- mkUniqueIdentifier Basic "fun" return (Right ((nm,netDecls ++ decls),rw)) Nothing -> return (Right (("",[]),Wire)) diff --git a/src/Clash/Netlist/BlackBox.hs-boot b/src/Clash/Netlist/BlackBox.hs-boot new file mode 100644 --- /dev/null +++ b/src/Clash/Netlist/BlackBox.hs-boot @@ -0,0 +1,29 @@ +{-| + Copyright : (C) 2019, Google Inc + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V. +-} + +module Clash.Netlist.BlackBox where + +import Data.Text (Text) +import GHC.Stack (HasCallStack) +import Clash.Core.Term (Term) +import Clash.Core.Type (Type) +import Clash.Core.Var (Id) +import Clash.Netlist.Types (BlackBoxContext, Declaration, NetlistMonad) +import Clash.Primitives.Types (CompiledPrimitive) + +extractPrimWarnOrFail + :: HasCallStack + => Text + -> NetlistMonad CompiledPrimitive + +mkBlackBoxContext + :: Text + -- ^ Blackbox function name + -> Id + -- ^ Identifier binding the primitive/blackbox application + -> [Either Term Type] + -- ^ Arguments of the primitive/blackbox application + -> NetlistMonad (BlackBoxContext,[Declaration]) diff --git a/src/Clash/Netlist/BlackBox/Parser.hs b/src/Clash/Netlist/BlackBox/Parser.hs --- a/src/Clash/Netlist/BlackBox/Parser.hs +++ b/src/Clash/Netlist/BlackBox/Parser.hs @@ -55,13 +55,13 @@ pTagD :: Parser Element pTagD = IF <$> (symbol "~IF" *> pTagE) <*> (spaces *> (string "~THEN" *> pBlackBoxD)) - <*> (string "~ELSE" *> pBlackBoxD <* string "~FI") + <*> (string "~ELSE" *> option ([Text ""]) pBlackBoxD <* string "~FI") <|> Component <$> pDecl <|> pTagE -- | Parse a Declaration pDecl :: Parser Decl -pDecl = Decl <$> (symbol "~INST" *> natural') <*> +pDecl = Decl <$> (symbol "~INST" *> natural') <*> pure 0 <*> ((:) <$> pOutput <*> many pInput) <* string "~INST" -- | Parse the output tag of Declaration @@ -82,7 +82,7 @@ <|> Const <$> (string "~CONST" *> brackets' natural') <|> Lit <$> (string "~LIT" *> brackets' natural') <|> Name <$> (string "~NAME" *> brackets' natural') - <|> Var <$> try (string "~VAR" *> brackets' pSigD) <*> brackets' natural' + <|> ToVar <$> try (string "~VAR" *> brackets' pSigD) <*> brackets' natural' <|> (Sym Text.empty) <$> (string "~SYM" *> brackets' natural') <|> Typ Nothing <$ string "~TYPO" <|> (Typ . Just) <$> try (string "~TYP" *> brackets' natural') @@ -129,6 +129,7 @@ <|> ActiveEdge <$> (string "~ACTIVEEDGE" *> brackets pEdge) <*> brackets' natural' <|> IsSync <$> (string "~ISSYNC" *> brackets' natural') <|> IsInitDefined <$> (string "~ISINITDEFINED" *> brackets' natural') + <|> CtxName <$ string "~CTXNAME" natural' :: TokenParsing m => m Int natural' = fmap fromInteger natural diff --git a/src/Clash/Netlist/BlackBox/Types.hs b/src/Clash/Netlist/BlackBox/Types.hs --- a/src/Clash/Netlist/BlackBox/Types.hs +++ b/src/Clash/Netlist/BlackBox/Types.hs @@ -7,8 +7,12 @@ Types used in BlackBox modules -} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +-- since GHC 8.6 we can haddock individual contructor fields \o/ +#if __GLASGOW_HASKELL__ >= 806 +#define FIELD ^ +#endif module Clash.Netlist.BlackBox.Types ( BlackBoxMeta(..) @@ -19,9 +23,11 @@ , Element(..) , Decl(..) , HdlSyn(..) + , RenderVoid(..) ) where import Control.DeepSeq (NFData) +import Data.Aeson (FromJSON) import Data.Binary (Binary) import Data.Hashable (Hashable) import Data.Text.Lazy (Text) @@ -35,6 +41,15 @@ import qualified Clash.Signal.Internal as Signal +-- | Whether this primitive should be rendered when its result type is void. +-- Defaults to 'NoRenderVoid'. +data RenderVoid + = RenderVoid + -- ^ Render blackbox, even if result type is void + | NoRenderVoid + -- ^ Don't render blackbox result type is void. Default for all blackboxes. + deriving (Show, Generic, NFData, Binary, Hashable, FromJSON) + data TemplateKind = TDecl | TExpr @@ -44,16 +59,18 @@ -- fields. (They are intentionally renamed to prevent name clashes.) data BlackBoxMeta = BlackBoxMeta { bbOutputReg :: Bool - , bbKind :: TemplateKind - , bbLibrary :: [BlackBoxTemplate] - , bbImports :: [BlackBoxTemplate] - , bbIncludes :: [((S.Text, S.Text), BlackBox)] + , bbKind :: TemplateKind + , bbLibrary :: [BlackBoxTemplate] + , bbImports :: [BlackBoxTemplate] + , bbFunctionPlurality :: [(Int, Int)] + , bbIncludes :: [((S.Text, S.Text), BlackBox)] + , bbRenderVoid :: RenderVoid } -- | Use this value in your blackbox template function if you do want to -- accept the defaults as documented in @Clash.Primitives.Types.BlackBox@. emptyBlackBoxMeta :: BlackBoxMeta -emptyBlackBoxMeta = BlackBoxMeta False TExpr [] [] [] +emptyBlackBoxMeta = BlackBoxMeta False TExpr [] [] [] [] NoRenderVoid -- | A BlackBox function generates a blackbox template, given the inputs and -- result type of the function it should provide a blackbox for. This is useful @@ -82,7 +99,7 @@ -- - Clash.Netlist.BlackBox.Types.renderElem -- - Clash.Netlist.BlackBox.Types.renderTag -- - Clash.Netlist.BlackBox.Types.setSym --- - Clash.Netlist.BlackBox.Types.usedArguments +-- - Clash.Netlist.BlackBox.Types.getUsedArguments -- - Clash.Netlist.BlackBox.Types.usedVariables -- - Clash.Netlist.BlackBox.Types.verifyBlackBoxContext -- - Clash.Netlist.BlackBox.Types.walkElement @@ -104,7 +121,7 @@ -- ^ Like Arg, but input hole must be a literal | Name !Int -- ^ Name hole - | Var [Element] !Int + | ToVar [Element] !Int -- ^ Like Arg but only insert variable reference (creating an assignment -- elsewhere if necessary). | Sym !Text !Int @@ -174,6 +191,9 @@ | DevNull [Element] -- ^ Evaluate but swallow output | SigD [Element] !(Maybe Int) + | CtxName + -- ^ The "context name", name set by `Clash.Magic.setName`, defaults to the + -- name of the closest binder deriving (Show, Generic, NFData, Binary, Hashable) -- | Component instantiation hole. First argument indicates which function argument @@ -183,7 +203,21 @@ -- -- The LHS of the tuple is the name of the signal, while the RHS of the tuple -- is the type of the signal -data Decl = Decl !Int [(BlackBoxTemplate,BlackBoxTemplate)] +data Decl + = Decl + !Int + -- FIELD Argument position of the function to instantiate + !Int + -- FIELD Subposition of function: blackboxes can request multiple instances + -- to be rendered of their given functions. This subposition indicates the + -- nth function instance to be rendered (zero-indexed). + -- + -- This is a hack: the proper solution would postpone rendering the + -- function until the very last moment. The blackbox language has no way + -- to indicate the subposition, and every ~INST will default its subposition + -- to zero. Haskell blackboxes can use this data type. + [(BlackBoxTemplate,BlackBoxTemplate)] + -- FIELD (name of signal, type of signal) deriving (Show, Generic, NFData, Binary, Hashable) data HdlSyn = Vivado | Quartus | Other diff --git a/src/Clash/Netlist/BlackBox/Util.hs b/src/Clash/Netlist/BlackBox/Util.hs --- a/src/Clash/Netlist/BlackBox/Util.hs +++ b/src/Clash/Netlist/BlackBox/Util.hs @@ -8,13 +8,12 @@ in templates -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Netlist.BlackBox.Util where @@ -31,7 +30,7 @@ #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif -import Data.Maybe (mapMaybe, maybeToList) +import Data.Maybe (mapMaybe, maybeToList, fromJust) import Data.Semigroup.Monad import qualified Data.Text import Data.Text.Lazy (Text) @@ -44,7 +43,7 @@ import Text.Read (readEither) import Text.Trifecta.Result hiding (Err) -import Clash.Backend (Backend (..), Usage (..)) +import Clash.Backend (Backend (..), Usage (..), mkUniqueIdentifier) import qualified Clash.Backend as Backend import Clash.Netlist.BlackBox.Parser import Clash.Netlist.BlackBox.Types @@ -55,17 +54,11 @@ Modifier (..), Declaration(BlackBoxD)) import qualified Clash.Netlist.Types as N -import Clash.Netlist.Util (typeSize) +import Clash.Netlist.Util (typeSize, isVoid, stripVoid) import Clash.Signal.Internal (ResetKind(..), ResetPolarity(..), InitBehavior(..)) import Clash.Util --- | Strip as many "Void" layers as possible. Might still return a Void if the --- void doesn't contain a hwtype. -stripVoid :: HWType -> HWType -stripVoid (Void (Just e)) = stripVoid e -stripVoid e = e - inputHole :: Element -> Maybe Int inputHole = \case Arg _ n -> pure n @@ -102,23 +95,29 @@ case e of Lit n -> case indexMaybe (bbInputs bbCtx) n of - Just (inp, _, False) -> + Just (inp, isVoid -> False, False) -> Just ( "Argument " ++ show n ++ " should be literal, as blackbox " ++ "used ~LIT[" ++ show n ++ "], but was:\n\n" ++ show inp) _ -> Nothing Const n -> case indexMaybe (bbInputs bbCtx) n of - Just (inp, _, False) -> + Just (inp, isVoid -> False, False) -> Just ( "Argument " ++ show n ++ " should be literal, as blackbox " ++ "used ~CONST[" ++ show n ++ "], but was:\n\n" ++ show inp) _ -> Nothing - Component (Decl n l') -> + Component (Decl n subn l') -> case IntMap.lookup n (bbFunctions bbCtx) of - Just _func -> - orElses $ - map - (verifyBlackBoxContext bbCtx . N.BBTemplate) - (concatTups l') + Just funcs -> + case indexMaybe funcs subn of + Nothing -> + Just ( "Blackbox requested at least " ++ show (subn+1) + ++ " renders of function at argument " ++ show n ++ " but " + ++ "found only " ++ show (length funcs) ) + Just _ -> + orElses $ + map + (verifyBlackBoxContext bbCtx . N.BBTemplate) + (concatTups l') Nothing -> Just ( "Blackbox requested instantiation of function at argument " ++ show n ++ ", but BlackBoxContext did not contain one.") @@ -162,9 +161,9 @@ m Element setSym' e = case e of - Var nm i | i < length (bbInputs bbCtx) -> case bbInputs bbCtx !! i of + ToVar nm i | i < length (bbInputs bbCtx) -> case bbInputs bbCtx !! i of (Identifier nm' Nothing,_,_) -> - return (Var [Text (Text.fromStrict nm')] i) + return (ToVar [Text (Text.fromStrict nm')] i) (e',hwTy,_) -> do varM <- IntMap.lookup i <$> use _2 @@ -177,8 +176,8 @@ ,N.Assignment nm' e' ] _2 %= (IntMap.insert i (nm',decls)) - return (Var [Text (Text.fromStrict nm')] i) - Just (nm',_) -> return (Var [Text (Text.fromStrict nm')] i) + return (ToVar [Text (Text.fromStrict nm')] i) + Just (nm',_) -> return (ToVar [Text (Text.fromStrict nm')] i) Sym _ i -> do symM <- IntMap.lookup i <$> use _1 case symM of @@ -198,8 +197,8 @@ error ("Symbol #" ++ show (t,i) ++ " is already defined in BlackBox for: " ++ bbnm) - Component (Decl n l') -> - Component <$> (Decl n <$> mapM (combineM (mapM setSym') (mapM setSym')) l') + Component (Decl n subN l') -> + Component <$> (Decl n subN <$> mapM (combineM (mapM setSym') (mapM setSym')) l') IF c t f -> IF <$> pure c <*> mapM setSym' t <*> mapM setSym' f SigD e' m -> SigD <$> (mapM setSym' e') <*> pure m BV t e' m -> BV <$> pure t <*> mapM setSym' e' <*> pure m @@ -216,8 +215,21 @@ error $ $(curLoc) ++ "Could not convert ~NAME[" ++ show i ++ "]" ++ " to string:" ++ msg ++ "\n\nError occured while " ++ "processing blackbox for " ++ bbnm + Lit i -> + case elementToText bbCtx (Lit i) of + Right t -> t + Left msg -> + error $ $(curLoc) ++ "Could not convert ~LIT[" ++ show i ++ "]" + ++ " to string:" ++ msg ++ "\n\nError occured while " + ++ "processing blackbox for " ++ bbnm Result _ | Identifier t _ <- fst (bbResult bbCtx) -> Text.fromStrict t CompName -> Text.fromStrict (bbCompName bbCtx) + CtxName -> + case bbCtxName bbCtx of + Just nm -> Text.fromStrict nm + _ | Identifier t _ <- fst (bbResult bbCtx) -> Text.fromStrict t + _ -> error $ $(curLoc) ++ "Internal error when processing blackbox " + ++ "for " ++ bbnm _ -> error $ $(curLoc) ++ "Unexpected element in GENSYM when processing " ++ "blackbox for " ++ bbnm ) @@ -285,7 +297,10 @@ bb' <- case bb of N.BBTemplate bt -> do t <- renderTemplate bbNamedCtx bt - return (\col -> PP.nest (col-2) (PP.pretty (t (col + 2)))) + return (\col -> let t1 = t (col + 2) + in if Text.null t1 + then PP.emptyDoc + else PP.nest (col-2) (PP.pretty t1)) N.BBFunction _ _ (N.TemplateFunction _ _ bf) -> do t <- bf bbNamedCtx return (\_ -> t) @@ -301,27 +316,32 @@ return bb' -- | Render a single template element -renderElem :: Backend backend - => BlackBoxContext - -> Element - -> State backend (Int -> Text) -renderElem b (Component (Decl n (l:ls))) = do +renderElem + :: HasCallStack + => Backend backend + => BlackBoxContext + -> Element + -> State backend (Int -> Text) +renderElem b (Component (Decl n subN (l:ls))) = do (o,oTy,_) <- idToExpr <$> combineM (lineToIdentifier b) (return . lineToType b) l is <- mapM (fmap idToExpr . combineM (lineToIdentifier b) (return . lineToType b)) ls - let Just (templ0,_,libs,imps,inc,pCtx) = IntMap.lookup n (bbFunctions b) + let func0 = IntMap.lookup n (bbFunctions b) + errr = concat [ "renderElem: not enough functions rendered? Needed " + , show (subN +1 ), " got only ", show (length (fromJust func0)) ] + func1 = indexNote' errr subN <$> func0 + Just (templ0,_,libs,imps,inc,pCtx) = func1 b' = pCtx { bbResult = (o,oTy), bbInputs = bbInputs pCtx ++ is } layoutOptions = LayoutOptions (AvailablePerLine 120 0.4) + render = N.BBTemplate . parseFail . renderLazy . layoutPretty layoutOptions templ1 <- case templ0 of Left t -> return t - Right (nm,ds) -> do - block <- getMon (blockDecl nm ds) - return $ N.BBTemplate - $ parseFail - $ renderLazy - $ layoutPretty layoutOptions block + Right (nm0,ds) -> do + nm1 <- mkUniqueIdentifier Basic nm0 + block <- getMon (blockDecl nm1 ds) + return (render block) templ4 <- case templ1 of @@ -337,10 +357,7 @@ nm2 <- Backend.mkUniqueIdentifier Basic "bb" let bbD = BlackBoxD nm1 libs imps inc (N.BBTemplate templ3) b' block <- getMon (blockDecl nm2 (templDecls ++ [bbD])) - return $ N.BBTemplate - $ parseFail - $ renderLazy - $ layoutPretty layoutOptions block + return (render block) case verifyBlackBoxContext b' templ4 of Nothing -> do @@ -568,7 +585,7 @@ Left msg -> error $ $(curLoc) ++ unwords [ "Error when reducing to string" , "in ~NAME construct:", msg ] -renderTag _ (Var [Text t] _) = return t +renderTag _ (ToVar [Text t] _) = return t renderTag _ (Sym t _) = return t renderTag b (BV True es e) = do @@ -649,7 +666,7 @@ Just nm -> return (Text.fromStrict nm) _ -> error $ $(curLoc) ++ "~INCLUDENAME[" ++ show n ++ "] does not correspond to any index of the 'includes' field that is specified in the primitive definition" renderTag b (OutputWireReg n) = case IntMap.lookup n (bbFunctions b) of - Just (_,rw,_,_,_,_) -> case rw of {N.Wire -> return "wire"; N.Reg -> return "reg"} + Just ((_,rw,_,_,_,_):_) -> case rw of {N.Wire -> return "wire"; N.Reg -> return "reg"} _ -> error $ $(curLoc) ++ "~OUTPUTWIREREG[" ++ show n ++ "] used where argument " ++ show n ++ " is not a function" renderTag b (Repeat [es] [i]) = do i' <- Text.unpack <$> renderTag b i @@ -692,6 +709,13 @@ renderTag b CompName = pure (Text.fromStrict (bbCompName b)) +renderTag b CtxName = case bbCtxName b of + Just nm -> return (Text.fromStrict nm) + _ | Identifier t _ <- fst (bbResult b) + -> return (Text.fromStrict t) + _ -> error "internal error" + + renderTag _ e = do e' <- getMon (prettyElem e) error $ $(curLoc) ++ "Unable to evaluate: " ++ show e' @@ -735,6 +759,7 @@ exprToString :: Expr -> Maybe String +exprToString (Literal _ (NumLit i)) = Just (show i) exprToString (Literal _ (StringLit l)) = Just l exprToString (BlackBoxE "Clash.Promoted.Symbol.SSymbol" _ _ _ _ ctx _) = let (e',_,_) = head (bbInputs ctx) @@ -749,23 +774,26 @@ -> Mon m Text prettyBlackBox bbT = Text.concat <$> mapM prettyElem bbT -prettyElem :: Monad m - => Element - -> Mon m Text +prettyElem + :: (HasCallStack, Monad m) + => Element + -> Mon m Text prettyElem (Text t) = return t -prettyElem (Component (Decl i args)) = do +prettyElem (Component (Decl i 0 args)) = do args' <- mapM (\(a,b) -> (,) <$> prettyBlackBox a <*> prettyBlackBox b) args renderOneLine <$> (nest 2 (string "~INST" <+> int i <> line <> string "~OUTPUT" <+> string "=>" <+> string (fst (head args')) <+> string (snd (head args')) <+> string "~" <> line <> vcat (mapM (\(a,b) -> string "~INPUT" <+> string "=>" <+> string a <+> string b <+> string "~") (tail args'))) <> line <> string "~INST") +prettyElem (Component (Decl {})) = + error $ $(curLoc) ++ "prettyElem can't (yet) render ~INST when subfuncion /= 0!" prettyElem (Result b) = if b then return "~ERESULT" else return "~RESULT" prettyElem (Arg b i) = renderOneLine <$> (if b then string "~EARG" else string "~ARG" <> brackets (int i)) prettyElem (Lit i) = renderOneLine <$> (string "~LIT" <> brackets (int i)) prettyElem (Const i) = renderOneLine <$> (string "~CONST" <> brackets (int i)) prettyElem (Name i) = renderOneLine <$> (string "~NAME" <> brackets (int i)) -prettyElem (Var es i) = do +prettyElem (ToVar es i) = do es' <- prettyBlackBox es renderOneLine <$> (string "~VAR" <> brackets (string es') <> brackets (int i)) prettyElem (Sym _ i) = renderOneLine <$> (string "~SYM" <> brackets (int i)) @@ -882,6 +910,7 @@ renderOneLine <$> (string "~TEMPLATE" <> brackets (string $ Text.concat bbname') <> brackets (string $ Text.concat source')) +prettyElem CtxName = return "~CTXNAME" -- | Recursively walk @Element@, applying @f@ to each element in the tree. walkElement @@ -897,7 +926,7 @@ -- TODO: alternatives. It would probably be better to replace it by Lens -- TODO: logic? case el of - Component (Decl _ args) -> + Component (Decl _ _ args) -> concatMap (\(a,b) -> concatMap go a ++ concatMap go b) args IndexType e -> go e FilePath e -> go e @@ -916,7 +945,7 @@ Const _ -> [] Lit _ -> [] Name _ -> [] - Var es _ -> concatMap go es + ToVar es _ -> concatMap go es Sym _ _ -> [] Typ _ -> [] TypM _ -> [] @@ -948,10 +977,12 @@ Vars _ -> [] Repeat es1 es2 -> concatMap go es1 ++ concatMap go es2 + CtxName -> [] -- | Determine variables used in an expression. Used for VHDL sensitivity list. -- Also see: https://github.com/clash-lang/clash-compiler/issues/365 usedVariables :: Expr -> [Identifier] +usedVariables Noop = [] usedVariables (Identifier i _) = [i] usedVariables (DataCon _ _ es) = concatMap usedVariables es usedVariables (DataTag _ e') = [either id id e'] @@ -963,8 +994,8 @@ matchArg (Arg _ i) = Just i matchArg _ = Nothing - matchVar (Var [Text v] _) = Just (Text.toStrict v) - matchVar _ = Nothing + matchVar (ToVar [Text v] _) = Just (Text.toStrict v) + matchVar _ = Nothing t' = onBlackBox id (\_ _ _ -> []) t usedIs = mapMaybe (indexMaybe (bbInputs bb)) (concatMap (walkElement matchArg) t') @@ -972,20 +1003,20 @@ sList' = concatMap (walkElement matchVar) t' -- | Collect arguments (e.g., ~ARG, ~LIT) used in this blackbox -usedArguments :: N.BlackBox -> [Int] -usedArguments (N.BBFunction _nm _hsh (N.TemplateFunction k _ _)) = k -usedArguments (N.BBTemplate t) = nub (concatMap (walkElement matchArg) t) +getUsedArguments :: N.BlackBox -> [Int] +getUsedArguments (N.BBFunction _nm _hsh (N.TemplateFunction k _ _)) = k +getUsedArguments (N.BBTemplate t) = nub (concatMap (walkElement matchArg) t) where matchArg = \case Arg _ i -> Just i - Component (Decl i _) -> Just i + Component (Decl i _ _) -> Just i Const i -> Just i IsLit i -> Just i IsActiveEnable i -> Just i Lit i -> Just i Name i -> Just i - Var _ i -> Just i + ToVar _ i -> Just i -- Domain properties (only need type): IsInitDefined _ -> Nothing @@ -1030,6 +1061,7 @@ TypElem _ -> Nothing TypM _ -> Nothing Vars _ -> Nothing + CtxName -> Nothing onBlackBox :: (BlackBoxTemplate -> r) diff --git a/src/Clash/Netlist/BlackBox/Util.hs-boot b/src/Clash/Netlist/BlackBox/Util.hs-boot new file mode 100644 --- /dev/null +++ b/src/Clash/Netlist/BlackBox/Util.hs-boot @@ -0,0 +1,19 @@ +{-| + Copyright : (C) 2019, Google Inc + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V. +-} + +module Clash.Netlist.BlackBox.Util where + +import Data.Text.Lazy (Text) +import Control.Monad.State (State) +import Clash.Backend (Backend) +import Clash.Netlist.Types (BlackBoxContext) +import Clash.Netlist.BlackBox.Types (BlackBoxTemplate) + +renderTemplate + :: Backend backend + => BlackBoxContext -- ^ Context used to fill in the hole + -> BlackBoxTemplate -- ^ Blackbox template + -> State backend (Int -> Text) diff --git a/src/Clash/Netlist/Id.hs b/src/Clash/Netlist/Id.hs --- a/src/Clash/Netlist/Id.hs +++ b/src/Clash/Netlist/Id.hs @@ -6,9 +6,8 @@ Transform/format a Netlist Identifier so that it is acceptable as a HDL identifier -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module Clash.Netlist.Id ( IdType (..) diff --git a/src/Clash/Netlist/Types.hs b/src/Clash/Netlist/Types.hs --- a/src/Clash/Netlist/Types.hs +++ b/src/Clash/Netlist/Types.hs @@ -8,17 +8,14 @@ Type and instance definitions for Netlist modules -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} -- since GHC 8.6 we can haddock individual contructor fields \o/ #if __GLASGOW_HASKELL__ >= 806 @@ -53,10 +50,11 @@ import SrcLoc (SrcSpan) +import Clash.Annotations.BitRepresentation (FieldAnn) import Clash.Annotations.TopEntity (TopEntity) import Clash.Backend (Backend) import Clash.Core.Type (Type) -import Clash.Core.Var (Attr') +import Clash.Core.Var (Attr', Id, varType) import Clash.Core.TyCon (TyConMap) import Clash.Core.VarEnv (VarEnv) import Clash.Driver.Types (BindingMap, ClashOpts) @@ -65,11 +63,22 @@ import Clash.Primitives.Types (CompiledPrimMap) import Clash.Signal.Internal (ResetPolarity, ActiveEdge, ResetKind, InitBehavior) -import Clash.Util (makeLenses) +import Clash.Util (HasCallStack, makeLenses) import Clash.Annotations.BitRepresentation.Internal (CustomReprs, DataRepr', ConstrRepr') +-- | Structure describing a top entity: it's id, its port annotations, and +-- associated testbench. +data TopEntityT = TopEntityT + { topId :: Id + -- ^ Id of top entity + , topAnnotation :: Maybe TopEntity + -- ^ (Maybe) a topentity annotation + , associatedTestbench :: Maybe Id + -- ^ (Maybe) a test bench associated with the topentity + } deriving (Generic) + -- | Monad that caches generated components (StateT) and remembers hidden inputs -- of components that are being generated (WriterT) newtype NetlistMonad a = @@ -117,12 +126,11 @@ -- filter duplicate warning invocations for dubious blackbox instantiations, -- see GitHub pull request #286. , _componentNames :: VarEnv Identifier - , _topEntityAnns :: VarEnv (Type, Maybe TopEntity) + , _topEntityAnns :: VarEnv TopEntityT , _hdlDir :: FilePath , _curBBlvl :: Int -- ^ The current scoping level assigned to black box contexts - , _componentPrefix :: (Maybe Identifier,Maybe Identifier) - -- ^ Prefix for top-level components, and prefix for all other components + , _componentPrefix :: ComponentPrefix , _customReprs :: CustomReprs , _clashOpts :: ClashOpts -- ^ Settings Clash was called with @@ -130,9 +138,21 @@ -- ^ Whether we're compiling a testbench (suppresses some warnings) , _backEndITE :: Bool -- ^ Whether the backend supports ifThenElse expressions + , _backend :: SomeBackend + -- ^ The current HDL backend , _htyCache :: HWMap } +data ComponentPrefix + = ComponentPrefix + { componentPrefixTop :: Maybe Identifier -- ^ Prefix for top-level components + , componentPrefixOther :: Maybe Identifier -- ^ Prefix for all other components + } deriving Show + +-- | Existentially quantified backend +data SomeBackend where + SomeBackend :: Backend backend => backend -> SomeBackend + -- | Signal reference type Identifier = Text @@ -143,7 +163,7 @@ = Component { componentName :: !Identifier -- ^ Name of the component , inputs :: [(Identifier,HWType)] -- ^ Input ports - , outputs :: [(WireOrReg,(Identifier,HWType))] -- ^ Output ports + , outputs :: [(WireOrReg,(Identifier,HWType),Maybe Expr)] -- ^ Output ports , declarations :: [Declaration] -- ^ Internal declarations } deriving Show @@ -210,10 +230,15 @@ | CustomSum !Identifier !DataRepr' !Size [(ConstrRepr', Identifier)] -- ^ Same as Sum, but with a user specified bit representation. For more info, -- see: Clash.Annotations.BitRepresentations. + | CustomProduct !Identifier !DataRepr' !Size (Maybe [Text]) [(FieldAnn, HWType)] + -- ^ Same as Product, but with a user specified bit representation. For more + -- info, see: Clash.Annotations.BitRepresentations. | Annotated [Attr'] !HWType -- ^ Annotated with HDL attributes | KnownDomain !Identifier !Integer !ActiveEdge !ResetKind !InitBehavior !ResetPolarity -- ^ Domain name, period, active edge, reset kind, initial value behavior + | FileType + -- ^ File type for simulation-level I/O deriving (Eq, Ord, Show, Generic, NFData, Hashable) -- | Extract hardware attributes from Annotated. Returns an empty list if @@ -261,11 +286,37 @@ WireOrReg -- FIELD Wire or register !Identifier -- FIELD Name of signal (Either Identifier HWType) -- FIELD Pointer to type of signal or type of signal + (Maybe Expr) -- FIELD Initial value -- ^ Signal declaration | TickDecl Comment -- ^ HDL tick corresponding to a Core tick + -- | Sequential statement + | Seq [Seq] deriving Show +-- | Sequential statements +data Seq + -- | Clocked sequential statements + = AlwaysClocked + ActiveEdge -- FIELD Edge of the clock the statement should be executed + Expr -- FIELD Clock expression + [Seq] -- FIELD Statements to be executed on the active clock edge + -- | Statements running at simulator start + | Initial + [Seq] -- FIELD Statements to run at simulator start + -- | Statements to run always + | AlwaysComb + [Seq] -- FIELD Statements to run always + -- | Declaration in sequential form + | SeqDecl + Declaration -- FIELD The declaration + -- | Branching statement + | Branch + !Expr -- FIELD Scrutinized expresson + !HWType -- FIELD Type of the scrutinized expression + [(Maybe Literal,[Seq])] -- FIELD List of: (Maybe match, RHS of Alternative) + deriving Show + data EntityOrComponent = Entity | Comp | Empty deriving Show @@ -282,9 +333,9 @@ -> HWType -- ^ Type of signal -> Declaration -pattern NetDecl note d ty <- NetDecl' note Wire d (Right ty) +pattern NetDecl note d ty <- NetDecl' note Wire d (Right ty) _ where - NetDecl note d ty = NetDecl' note Wire d (Right ty) + NetDecl note d ty = NetDecl' note Wire d (Right ty) Nothing data PortDirection = In | Out deriving (Eq,Ord,Show,Generic,NFData,Hashable) @@ -320,8 +371,13 @@ !Bool -- FIELD Wrap in paretheses? | ConvBV (Maybe Identifier) HWType Bool Expr | IfThenElse Expr Expr Expr + -- | Do nothing + | Noop deriving Show +instance NFData Expr where + rnf x = x `seq` () + -- | Literals used in an expression data Literal = NumLit !Integer -- ^ Number literal @@ -354,12 +410,12 @@ { bbName :: Text -- ^ Blackbox function name (for error reporting) , bbResult :: (Expr,HWType) -- ^ Result name and type , bbInputs :: [(Expr,HWType,Bool)] -- ^ Argument names, types, and whether it is a literal - , bbFunctions :: IntMap (Either BlackBox (Identifier,[Declaration]) + , bbFunctions :: IntMap [(Either BlackBox (Identifier,[Declaration]) ,WireOrReg ,[BlackBoxTemplate] ,[BlackBoxTemplate] ,[((Text,Text),BlackBox)] - ,BlackBoxContext) + ,BlackBoxContext)] -- ^ Function arguments (subset of inputs): -- -- * ( Blackbox Template @@ -373,6 +429,9 @@ -- is equal to the scoping level of this context. , bbCompName :: Identifier -- ^ The component the BlackBox is instantiated in + , bbCtxName :: Maybe Identifier + -- ^ The "context name", name set by `Clash.Magic.setName`, defaults to the + -- name of the closest binder } deriving Show @@ -405,6 +464,70 @@ get = (\is -> TemplateFunction is err err) <$> get where err = const $ error "TemplateFunction functions can't be preserved by serialisation" +-- | Netlist-level identifier +data NetlistId + = NetlistId Identifier Type + -- ^ Identifier generated in the NetlistMonad, always derived from another + -- 'NetlistId' + | CoreId Id + -- ^ An original Core identifier + | MultiId [Id] + -- ^ A split identifier (into several sub-identifiers), needed to assign + -- expressions of types that have to be split apart (e.g. tuples of Files) + deriving Show + +-- | Eliminator for 'NetlistId' +netlistId + :: (Identifier -> r) + -- ^ Eliminator for Identifiers generated in the NetlistMonad + -> (Id -> r) + -- ^ Eliminator for original Core Identifiers + -> NetlistId + -> [r] +netlistId f g = \case + NetlistId i _ -> [f i] + CoreId i -> [g i] + MultiId is -> map g is + +-- | Eliminator for 'NetlistId', fails on 'MultiId' +netlistId1 + :: HasCallStack + => (Identifier -> r) + -- ^ Eliminator for Identifiers generated in the NetlistMonad + -> (Id -> r) + -- ^ Eliminator for original Core Identifiers + -> NetlistId + -> r +netlistId1 f g = \case + NetlistId i _ -> f i + CoreId i -> g i + m -> error ("netlistId1 MultiId: " ++ show m) + +-- | Return the type(s) of a 'NetListId', returns multiple types when given a +-- 'MultiId' +netlistTypes + :: NetlistId + -> [Type] +netlistTypes = \case + NetlistId _ t -> [t] + CoreId i -> [varType i] + MultiId is -> map varType is + +-- | Return the type of a 'NetlistId', fails on 'MultiId' +netlistTypes1 + :: HasCallStack + => NetlistId + -> Type +netlistTypes1 = \case + NetlistId _ t -> t + CoreId i -> varType i + m -> error ("netlistTypes1 MultiId: " ++ show m) + +-- | Type of declaration, concurrent or sequential +data DeclarationType + = Concurrent + | Sequential + emptyBBContext :: Text -> BlackBoxContext emptyBBContext n = Context @@ -415,6 +538,7 @@ , bbQsysIncName = [] , bbLevel = (-1) , bbCompName = pack "__NOCOMPNAME__" + , bbCtxName = Nothing } makeLenses ''NetlistEnv diff --git a/src/Clash/Netlist/Util.hs b/src/Clash/Netlist/Util.hs --- a/src/Clash/Netlist/Util.hs +++ b/src/Clash/Netlist/Util.hs @@ -8,17 +8,15 @@ Utilities for converting Core Type/Term to Netlist datatypes -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} #if !MIN_VERSION_ghc(8,8,0) {-# LANGUAGE MonadFailDesugaring #-} #endif -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Netlist.Util where @@ -28,6 +26,7 @@ import qualified Control.Lens as Lens import Control.Monad (unless, when, zipWithM, join) import Control.Monad.Reader (ask, local) +import qualified Control.Monad.State as State import Control.Monad.State.Strict (State, evalState, get, modify, runState) import Control.Monad.Trans.Except @@ -36,7 +35,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.String (fromString) -import Data.List (intersperse, unzip4, sort, intercalate) +import Data.List (intersperse, unzip4, intercalate) import qualified Data.List as List import Data.Maybe (catMaybes,fromMaybe,isNothing) import Data.Monoid (First (..)) @@ -46,6 +45,7 @@ #endif import Data.Text (Text) import qualified Data.Text as Text +import Data.Text.Lazy (toStrict) import Data.Text.Prettyprint.Doc (Doc) import Outputable (ppr, showSDocUnsafe) @@ -53,11 +53,12 @@ import Clash.Annotations.BitRepresentation.ClashLib (coreToType') import Clash.Annotations.BitRepresentation.Internal - (CustomReprs, ConstrRepr'(..), DataRepr'(..), getDataRepr, getConstrRepr) + (CustomReprs, ConstrRepr'(..), DataRepr'(..), getDataRepr, + uncheckedGetConstrRepr) import Clash.Annotations.TopEntity (PortName (..), TopEntity (..)) import Clash.Driver.Types (Manifest (..), ClashOpts (..)) import Clash.Core.DataCon (DataCon (..)) -import Clash.Core.FreeVars (freeLocalIds, typeFreeVars) +import Clash.Core.FreeVars (localIdOccursIn, typeFreeVars) import qualified Clash.Core.Literal as C import Clash.Core.Name (Name (..), appendToName, nameOcc) @@ -66,19 +67,23 @@ (Subst (..), extendIdSubst, extendIdSubstList, extendInScopeId, extendInScopeIdList, mkSubst, substTm) import Clash.Core.Term - (Alt, LetBinding, Pat (..), Term (..), TickInfo (..), NameMod (..)) + (Alt, LetBinding, Pat (..), Term (..), TickInfo (..), NameMod (..), + collectArgsTicks, collectTicks, PrimInfo(primName)) import Clash.Core.TyCon (TyConName, TyConMap, tyConDataCons) import Clash.Core.Type (Type (..), TypeView (..), coreView1, splitTyConAppM, tyView, TyVar) import Clash.Core.Util - (collectBndrs, stripTicks, substArgTys, termType, tySym) + (collectBndrs, stripTicks, substArgTys, termType, tyLitShow, mkTicks) import Clash.Core.Var (Id, Var (..), mkLocalId, modifyVarName, Attr') import Clash.Core.VarEnv (InScopeSet, extendInScopeSetList, uniqAway) +import {-# SOURCE #-} Clash.Netlist.BlackBox +import {-# SOURCE #-} Clash.Netlist.BlackBox.Util import Clash.Netlist.Id (IdType (..), stripDollarPrefixes) import Clash.Netlist.Types as HW +import Clash.Primitives.Types import Clash.Unique import Clash.Util @@ -87,9 +92,19 @@ stripFiltered :: FilteredHWType -> HWType stripFiltered (FilteredHWType hwty _filtered) = hwty +-- | Strip as many "Void" layers as possible. Might still return a Void if the +-- void doesn't contain a hwtype. +stripVoid :: HWType -> HWType +stripVoid (Void (Just e)) = stripVoid e +stripVoid e = e + flattenFiltered :: FilteredHWType -> [[Bool]] flattenFiltered (FilteredHWType _hwty filtered) = map (map fst) filtered +isVoidMaybe :: Bool -> Maybe HWType -> Bool +isVoidMaybe dflt Nothing = dflt +isVoidMaybe _dflt (Just t) = isVoid t + -- | Determines if type is a zero-width construct ("void") isVoid :: HWType -> Bool isVoid Void {} = True @@ -99,12 +114,6 @@ isFilteredVoid :: FilteredHWType -> Bool isFilteredVoid = isVoid . stripFiltered -isBiSignalOut :: HWType -> Bool -isBiSignalOut (Void (Just (BiDirectional Out _))) = True -isBiSignalOut (Vector n ty) | n /= 0 = isBiSignalOut ty -isBiSignalOut (RTree _ ty) = isBiSignalOut ty -isBiSignalOut _ = False - mkIdentifier :: IdType -> Identifier -> NetlistMonad Identifier mkIdentifier typ nm = Lens.use mkIdentifierFn <*> pure typ <*> pure nm @@ -124,9 +133,9 @@ -> Term -> (Either String ([Id],[LetBinding],Id)) splitNormalized tcm expr = case collectBndrs expr of - (args,Letrec xes e) + (args, collectTicks -> (Letrec xes e, ticks)) | (tmArgs,[]) <- partitionEithers args -> case stripTicks e of - Var v -> Right (tmArgs,xes,v) + Var v -> Right (tmArgs, fmap (second (`mkTicks` ticks)) xes,v) _ -> Left ($(curLoc) ++ "Not in normal form: res not simple var") | otherwise -> Left ($(curLoc) ++ "Not in normal form: tyArgs") _ -> @@ -163,7 +172,7 @@ -> State HWMap FilteredHWType unsafeCoreTypeToHWType sp loc builtInTranslation reprs m ty = either (\msg -> throw (ClashException sp (loc ++ msg) Nothing)) id <$> - coreTypeToHWType builtInTranslation reprs m ty + coreTypeToHWType builtInTranslation reprs m ty -- | Same as @unsafeCoreTypeToHWTypeM@, but discards void filter information unsafeCoreTypeToHWTypeM' @@ -211,83 +220,102 @@ htyCache Lens..= htm1 return (hush hty) -packSP - :: CustomReprs - -> (Text, c) - -> (ConstrRepr', Text, c) -packSP reprs (name, tys) = - case getConstrRepr name reprs of - Just repr -> (repr, name, tys) - Nothing -> error $ $(curLoc) ++ unwords - [ "Could not find custom representation for", Text.unpack name ] +-- | Constructs error message for unexpected projections out of a type annotated +-- with a custom bit representation. +unexpectedProjectionErrorMsg + :: DataRepr' + -> Int + -- ^ Constructor index + -> Int + -- ^ Field index + -> String +unexpectedProjectionErrorMsg dataRepr cI fI = + "Unexpected projection of zero-width type: " ++ show (drType dataRepr) + ++ ". Tried to make a projection of field " ++ show fI ++ " of " + ++ constrNm ++ ". Did you try to project a field marked as zero-width" + ++ " by a custom bit representation annotation?" + where + constrNm = show (crName (drConstrs dataRepr !! cI)) -packSum - :: CustomReprs - -> Text - -> (ConstrRepr', Text) -packSum reprs name = - case getConstrRepr name reprs of - Just repr -> (repr, name) - Nothing -> error $ $(curLoc) ++ unwords - [ "Could not find custom representation for", Text.unpack name ] +-- | Helper function of 'maybeConvertToCustomRepr' +convertToCustomRepr + :: HasCallStack + => CustomReprs + -> DataRepr' + -> HWType + -> HWType +convertToCustomRepr reprs dRepr@(DataRepr' name' size constrs) hwTy = + if length constrs == nConstrs then + if size <= 0 then + Void (Just cs) + else + cs + else + error (unwords + [ "Type", show name', "has", show nConstrs, "constructor(s), " + , "but the custom bit representation only specified", show (length constrs) + , "constructors." + ]) + where + cs = insertVoids $ case hwTy of + Sum name conIds -> + CustomSum name dRepr size (map packSum conIds) + SP name conIdsAndFieldTys -> + CustomSP name dRepr size (map packSP conIdsAndFieldTys) + Product name maybeFieldNames fieldTys + | [ConstrRepr' _cName _pos _mask _val fieldAnns] <- constrs -> + CustomProduct name dRepr size maybeFieldNames (zip fieldAnns fieldTys) + _ -> + error + ( "Found a custom bit representation annotation " ++ show dRepr ++ ", " + ++ "but it was applied to an unsupported HWType: " ++ show hwTy ++ ".") -fixCustomRepr + nConstrs :: Int + nConstrs = case hwTy of + (Sum _name conIds) -> length conIds + (SP _name conIdsAndFieldTys) -> length conIdsAndFieldTys + (Product {}) -> 1 + _ -> error ("Unexpected HWType: " ++ show hwTy) + + packSP (name, tys) = (uncheckedGetConstrRepr name reprs, name, tys) + packSum name = (uncheckedGetConstrRepr name reprs, name) + + -- Replace some "hwTy" with "Void (Just hwTy)" if the custom bit + -- representation indicated that field is represented by zero bits. We can't + -- simply remove them, as we'll later have to deal with an "overapplied" + -- constructor. If we remove the arguments altogether, we wouldn't know which + -- - on their own potentially non-void! - arguments to ignore. + insertVoids :: HWType -> HWType + insertVoids (CustomSP i d s constrs0) = + CustomSP i d s (map go0 constrs0) + where + go0 (con@(ConstrRepr' _ _ _ _ fieldAnns), i0, hwTys) = + (con, i0, zipWith go1 fieldAnns hwTys) + go1 0 hwTy0 = Void (Just hwTy0) + go1 _ hwTy0 = hwTy0 + insertVoids (CustomProduct i d s f fieldAnns) = + CustomProduct i d s f (map go fieldAnns) + where + go (0, hwTy0) = (0, Void (Just hwTy0)) + go (n, hwTy0) = (n, hwTy0) + insertVoids hwTy0 = hwTy0 + +-- | Given a map containing custom bit representation, a type, and the same +-- type represented as HWType, convert the HWType to a CustomSP/CustomSum if +-- it has a custom bit representation. +maybeConvertToCustomRepr :: CustomReprs + -- ^ Map containing all custom representations index on its type -> Type + -- ^ Custom reprs are index on type, so we need the clash core type to look + -- it up. -> HWType + -- ^ Type of previous argument represented as a HWType -> HWType -fixCustomRepr reprs (coreToType' -> Right tyName) sum_@(Sum name subtys) = - case getDataRepr tyName reprs of - Just dRepr@(DataRepr' name' size constrs) -> - if length constrs == length subtys then - CustomSum - name - dRepr - (fromIntegral size) - [packSum reprs ty | ty <- subtys] - else - error $ $(curLoc) ++ (Text.unpack $ Text.unwords - [ "Type " - , Text.pack $ show name' - , "has" - , Text.pack $ show $ length subtys - , "constructors: \n\n" - , Text.intercalate "\n" $ sort [Text.append " * " id_ | id_ <- subtys] - , "\n\nBut the custom bit representation only specified" - , Text.pack $ show $ length constrs - , "constructors:\n\n" - , Text.intercalate "\n" $ sort [Text.append " * " id_ | (ConstrRepr' id_ _ _ _ _) <- constrs] - ]) - Nothing -> - -- No custom representation found - sum_ - -fixCustomRepr reprs (coreToType' -> Right tyName) sp@(SP name subtys) = - case getDataRepr tyName reprs of - Just dRepr@(DataRepr' name' size constrs) -> - if length constrs == length subtys then - CustomSP - name - dRepr - (fromIntegral size) - [packSP reprs ty | ty <- subtys] - else - error $ $(curLoc) ++ (Text.unpack $ Text.unwords - [ "Type " - , Text.pack $ show $ name' - , "has" - , Text.pack $ show $ length subtys - , "constructors: \n\n" - , Text.intercalate "\n" $ sort [Text.append " * " id_ | (id_, _) <- subtys] - , "\n\nBut the custom bit representation only specified" - , Text.pack $ show $ length constrs, "constructors:\n\n" - , Text.intercalate "\n" $ sort [Text.append " * " id_ | (ConstrRepr' id_ _ _ _ _) <- constrs] - ]) - Nothing -> - -- No custom representation found - sp - -fixCustomRepr _ _ typ = typ +maybeConvertToCustomRepr reprs (coreToType' -> Right tyName) hwTy + | Just dRepr <- getDataRepr tyName reprs = + convertToCustomRepr reprs dRepr hwTy +maybeConvertToCustomRepr _reprs _ty hwTy = hwTy -- | Same as @coreTypeToHWType@, but discards void filter information coreTypeToHWType' @@ -330,14 +358,14 @@ (Either String FilteredHWType) go (Just hwtyE) _ = pure $ (\(FilteredHWType hwty filtered) -> - (FilteredHWType (fixCustomRepr reprs ty hwty) filtered)) <$> hwtyE + (FilteredHWType (maybeConvertToCustomRepr reprs ty hwty) filtered)) <$> hwtyE -- Strip transparant types: go _ (coreView1 m -> Just ty') = coreTypeToHWType builtInTranslation reprs m ty' -- Try to create hwtype based on AST: go _ (tyView -> TyConApp tc args) = runExceptT $ do FilteredHWType hwty filtered <- mkADT builtInTranslation reprs m (showPpr ty) tc args - return (FilteredHWType (fixCustomRepr reprs ty hwty) filtered) + return (FilteredHWType (maybeConvertToCustomRepr reprs ty hwty) filtered) -- All methods failed: go _ _ = return $ Left $ "Can't translate non-tycon type: " ++ showPpr ty @@ -434,8 +462,14 @@ -- If none of the dataconstructors have fields, and there are 1 or less -- of them, this type only has one inhabitant. It can therefore be -- represented by zero bits, and is therefore empty: - | length dcs <= 1 -> - return (FilteredHWType (Void Nothing) argHTyss1) + | length dcs <= 1 -> case argHTyss0 of + [argHTys0] -> + -- We need this to preserve constraint-tuples of `KnownDomains` + let argHTys1 = map (stripVoid . stripFiltered) argHTys0 + in return (FilteredHWType + (Void (Just (Product tcName Nothing argHTys1))) + argHTyss1) + _ -> return (FilteredHWType (Void Nothing) argHTyss1) -- None of the dataconstructors have fields. This type is therefore a -- simple Sum type. | otherwise -> @@ -489,6 +523,7 @@ typeSize :: HWType -> Int typeSize (Void {}) = 0 +typeSize FileType = 32 -- (ref. page 287 of IEEE 1364-2005) typeSize String = 0 typeSize Integer = 0 typeSize (KnownDomain {}) = 0 @@ -512,6 +547,7 @@ typeSize (BiDirectional Out _) = 0 typeSize (CustomSP _ _ size _) = fromIntegral size typeSize (CustomSum _ _ size _) = fromIntegral size +typeSize (CustomProduct _ _ size _ _) = fromIntegral size typeSize (Annotated _ ty) = typeSize ty -- | Determines the bitsize of the constructor of a type @@ -609,7 +645,8 @@ -- | Uniquely rename all the variables and their references in a normalized -- term mkUniqueNormalized - :: InScopeSet + :: HasCallStack + => InScopeSet -> Maybe (Maybe TopEntity) -- ^ Top entity annotation where: -- @@ -642,7 +679,7 @@ -- Make arguments unique let is1 = is0 `extendInScopeSetList` (args ++ bndrs) - (wereVoids, iports,iwrappers,substArgs) <- mkUniqueArguments (mkSubst is1) topMM args + (wereVoids,iports,iwrappers,substArgs) <- mkUniqueArguments (mkSubst is1) topMM args -- Make result unique. This might yield 'Nothing' in which case the result -- was a single BiSignalOut. This is superfluous in the HDL, as the argument @@ -650,35 +687,90 @@ resM <- mkUniqueResult substArgs topMM res case resM of Just (oports,owrappers,res1,substRes) -> do - let usesOutput = concatMap (filter ( == res) - . Lens.toListOf freeLocalIds - ) exprs - -- If the let-binder carrying the result is used in a feedback loop - -- rename the let-binder to "_rec", and assign the "_rec" to - -- "". We do this because output ports in most HDLs cannot be read. - (res2,subst'',extraBndr) <- case usesOutput of - [] -> return (varName res1 - ,substRes - ,[] :: [(Id, Term)]) - _ -> do - ([res3],substRes') <- mkUnique substRes [modifyVarName (`appendToName` "_rec") res] - return (varName res3,substRes' - ,[(res1, Var res3)]) - -- Replace occurences of "" by "_rec" - let resN = varName res - bndrs' = map (\i -> if varName i == resN then modifyVarName (const res2) i else i) bndrs - (bndrsL,r:bndrsR) = break ((== res2).varName) bndrs' - -- Make let-binders unique - (bndrsL',substL) <- mkUnique subst'' bndrsL - (bndrsR',substR) <- mkUnique substL bndrsR + -- Check whether any of the binders reference the result + let resRead = any (localIdOccursIn res) exprs + -- Rename some of the binders, see 'setBinderName' when this happens. + ((res2,subst1,extraBndr),bndrs1) <- + mapAccumLM (setBinderName substRes res resRead) (res1,substRes,[]) binds + -- Make let-binders unique, the result binder is already unique, so we + -- can skip it. + let (bndrsL,r:bndrsR) = break ((== res2)) bndrs1 + (bndrsL1,substL) <- mkUnique subst1 bndrsL + (bndrsR1,substR) <- mkUnique substL bndrsR -- Replace old IDs by updated unique IDs in the RHSs of the let-binders - let exprs' = map (substTm ("mkUniqueNormalized1" :: Doc ()) substR) exprs + let exprs1 = map (substTm ("mkUniqueNormalized1" :: Doc ()) substR) exprs -- Return the uniquely named arguments, let-binders, and result - return (wereVoids,iports,iwrappers,oports,owrappers,zip (bndrsL' ++ r:bndrsR') exprs' ++ extraBndr,Just res1) + return ( wereVoids + , iports + , iwrappers + , oports + , owrappers + , zip (bndrsL1 ++ r:bndrsR1) exprs1 ++ extraBndr + , Just res1) Nothing -> do - (bndrs', substArgs') <- mkUnique substArgs bndrs - return (wereVoids,iports,iwrappers,[],[],zip bndrs' (map (substTm ("mkUniqueNormalized2" :: Doc ()) substArgs') exprs),Nothing) + (bndrs1, substArgs1) <- mkUnique substArgs bndrs + return ( wereVoids + , iports + , iwrappers + , [] + , [] + , zip bndrs1 + (map (substTm ("mkUniqueNormalized2" :: Doc ()) substArgs1) exprs) + ,Nothing) +-- | Set the name of the binder +-- +-- Normally, it just keeps the existing name, but there are two exceptions: +-- +-- 1. It's the binding for the result which is also referenced by another binding; +-- in this case it's suffixed with `_rec` +-- 2. The binding binds a primitive that has a name control field +-- +-- 2. takes priority over 1. Additionally, we create an additional binder when +-- the return value gets a new name. +setBinderName + :: Subst + -- ^ Current substitution + -> Id + -- ^ The binder for the result + -> Bool + -- ^ Whether the result binder is referenced by another binder + -> (Id, Subst, [(Id,Term)]) + -- ^ * The (renamed) binder for the result + -- * The updated substitution in case the result binder is renamed + -- * A new binding, to assign the result in case the original binder for + -- the result got renamed. + -> (Id,Term) + -- ^ The binding + -> NetlistMonad ((Id, Subst, [(Id,Term)]),Id) +setBinderName subst res resRead m@(resN,_,_) (i,collectArgsTicks -> (k,args,ticks)) = case k of + Prim p -> let nm = primName p in extractPrimWarnOrFail nm >>= go nm + _ -> goDef + where + go nm (BlackBox {resultName = Just (BBTemplate nmD)}) = withTicks ticks $ \_ -> do + (bbCtx,_) <- preserveVarEnv (mkBlackBoxContext nm i args) + be <- Lens.use backend + let bbRetValName = case be of + SomeBackend s -> toStrict ((State.evalState (renderTemplate bbCtx nmD) s) 0) + i1 = modifyVarName (\n -> n {nameOcc = bbRetValName}) i + if res == i1 then do + ([i2],subst1) <- mkUnique subst [i1] + return ((i2,subst1,[(resN,Var i2)]),i2) + else + return (m,i1) + + go _ _ = goDef + + goDef + | i == res && resRead + = do + ([i1],subst1) <- mkUnique subst [modifyVarName (`appendToName` "_rec") res] + return ((i1, subst1, [(resN,Var i1)]),i1) + | i == res + = return (m,resN) + | otherwise + = return (m,i) + mkUniqueArguments :: Subst -> Maybe (Maybe TopEntity) @@ -851,9 +943,22 @@ seenIds %= HashMap.insert i' 0 return i' --- | Preserve the Netlist '_varCount','_curCompNm','_seenIds' when executing a monadic action -preserveVarEnv :: NetlistMonad a - -> NetlistMonad a +-- | Preserve the complete state before running an action, and restore it +-- afterwards. +preserveState + :: NetlistMonad a + -> NetlistMonad a +preserveState action = do + state <- State.get + val <- action + State.put state + pure val + +-- | Preserve the Netlist '_varCount','_curCompNm','_seenIds' when executing +-- a monadic action +preserveVarEnv + :: NetlistMonad a + -> NetlistMonad a preserveVarEnv action = do -- store state vCnt <- Lens.use varCount @@ -1068,14 +1173,14 @@ :: Bool -> HashMap Identifier Word -> (IdType -> Identifier -> Identifier) - -> (Maybe Identifier,Maybe Identifier) + -> ComponentPrefix -> Id -> Identifier genComponentName newInlineStrat seen mkIdFn prefixM nm = let nm' = Text.splitOn (Text.pack ".") (nameOcc (varName nm)) fn = mkIdFn Basic (stripDollarPrefixes (last nm')) fn' = if Text.null fn then Text.pack "Component" else fn - prefix = maybe id (:) (snd prefixM) (if newInlineStrat then [] else init nm') + prefix = maybe id (:) (componentPrefixOther prefixM) (if newInlineStrat then [] else init nm') nm2 = Text.concat (intersperse (Text.pack "_") (prefix ++ [fn'])) nm3 = mkIdFn Basic nm2 in case HashMap.lookup nm3 seen of @@ -1092,16 +1197,19 @@ genTopComponentName :: Bool -> (IdType -> Identifier -> Identifier) - -> (Maybe Identifier,Maybe Identifier) + -> ComponentPrefix -> Maybe TopEntity -> Id -> Identifier -genTopComponentName _oldInlineStrat _mkIdFn prefixM (Just ann) _nm = - case prefixM of - (Just p,_) -> p `Text.append` Text.pack ('_':t_name ann) - _ -> Text.pack (t_name ann) -genTopComponentName oldInlineStrat mkIdFn prefixM Nothing nm = - genComponentName oldInlineStrat HashMap.empty mkIdFn prefixM nm +genTopComponentName _newInlineStrat _mkIdFn prefixM (Just ann) _nm = + case componentPrefixTop prefixM of + Just p -> p `Text.append` Text.pack ('_':t_name ann) + _ -> Text.pack (t_name ann) +genTopComponentName newInlineStrat mkIdFn prefixM Nothing nm = + genComponentName newInlineStrat HashMap.empty mkIdFn prefixM' nm + where + -- use the prefix for top-level components + prefixM' = prefixM{componentPrefixOther = componentPrefixTop prefixM} -- | Strips one or more layers of attributes from a HWType; stops at first @@ -1179,8 +1287,8 @@ pN <- uniquePortName p o return ([(pN,hwty)],[],pN) - go' (PortProduct p ps) (o,hwty) = do - pN <- uniquePortName p o + go' (PortProduct p ps) (_,hwty) = do + pN <- mkUniqueIdentifier Basic (Text.pack p) let (attrs, hwty') = stripAttributes hwty case hwty' of Vector sz hwty'' -> do @@ -1205,12 +1313,12 @@ results <- zipWithM appendIdentifier (map (pN,) hwtys) [0..] let ps' = extendPorts $ map (prefixParent p) ps (ports,decls,ids) <- unzip3 <$> uncurry (zipWithM mkOutput') (ps', results) + let netdecl = NetDecl Nothing pN hwty' case ids of - [i] -> let netdecl = NetDecl Nothing pN hwty' - assign = Assignment i (Identifier pN Nothing) + [i] -> let assign = Assignment i (Identifier pN Nothing) in return (concat ports,netdecl:assign:concat decls,pN) - _ -> let netdecl = NetDecl Nothing pN hwty' - assigns = zipWith (assignId pN hwty' 0) ids [0..] + + _ -> let assigns = zipWith (assignId pN hwty' 0) ids [0..] in if null attrs then return (concat ports,netdecl:assigns ++ concat decls,pN) else @@ -1292,28 +1400,29 @@ let iResult = inpAssigns ++ concat wrappers result = ("result",snd dstId) - topOutputM <- mkTopOutput - topM - (zip outNames outTys) - (head oPortSupply) - result + instLabel0 <- extendIdentifier Basic topName ("_" `Text.append` fst dstId) + instLabel1 <- fromMaybe instLabel0 <$> Lens.view setName + instLabel2 <- affixName instLabel1 + instLabel3 <- mkUniqueIdentifier Basic instLabel2 + topOutputM <- mkTopOutput topM (zip outNames outTys) (head oPortSupply) result - (iResult ++) <$> case topOutputM of - Nothing -> return [] + let + topCompDecl oports = + InstDecl + Entity + (Just topName) + topName + instLabel3 + [] + ( map (\(p,i,t) -> (Identifier p Nothing,In, t,Identifier i Nothing)) (concat iports) ++ + map (\(p,o,t) -> (Identifier p Nothing,Out,t,Identifier o Nothing)) oports) + + case topOutputM of + Nothing -> + pure (topCompDecl [] : iResult) Just (_, (oports, unwrappers, idsO)) -> do - instLabel0 <- extendIdentifier Basic topName ("_" `Text.append` fst dstId) - instLabel1 <- mkUniqueIdentifier Basic instLabel0 let outpAssign = Assignment (fst dstId) (resBV topM idsO) - let topCompDecl = InstDecl - Entity - (Just topName) - topName - instLabel1 - [] - ( map (\(p,i,t) -> (Identifier p Nothing,In, t,Identifier i Nothing)) (concat iports) ++ - map (\(p,o,t) -> (Identifier p Nothing,Out,t,Identifier o Nothing)) oports) - - return $ tickDecls ++ (topCompDecl:unwrappers) ++ [outpAssign] + pure (iResult ++ tickDecls ++ (topCompDecl oports:unwrappers) ++ [outpAssign]) -- | Convert between BitVector for an argument argBV @@ -1439,7 +1548,7 @@ go' (PortName _) ((iN,iTy):inps') (_,hwty) = do iN' <- mkUniqueIdentifier Extended iN return (inps',([(iN,iN',hwty)] - ,[NetDecl' Nothing Wire iN' (Left iTy)] + ,[NetDecl' Nothing Wire iN' (Left iTy) Nothing] ,Right (iN',hwty))) go' (PortName _) [] _ = error "This shouldnt happen" @@ -1630,7 +1739,7 @@ go' (PortName _) ((oN,oTy):outps') (_,hwty) = do oN' <- mkUniqueIdentifier Extended oN return (outps',([(oN,oN',hwty)] - ,[NetDecl' Nothing Wire oN' (Left oTy)] + ,[NetDecl' Nothing Wire oN' (Left oTy) Nothing] ,Right (oN',hwty))) go' (PortName _) [] _ = error "This shouldnt happen" @@ -1807,12 +1916,16 @@ where go decls [] = k (reverse decls) + go decls (DeDup:ticks) = go decls ticks + + go decls (NoDeDup:ticks) = go decls ticks + go decls (SrcSpan sp:ticks) = go (TickDecl (Text.pack (showSDocUnsafe (ppr sp))):decls) ticks go decls (NameMod m nm0:ticks) = do tcm <- Lens.use tcCache - case runExcept (tySym tcm nm0) of + case runExcept (tyLitShow tcm nm0) of Right nm1 -> local (modName m nm1) (go decls ticks) _ -> go decls ticks @@ -1822,6 +1935,9 @@ modName SuffixName (Text.pack -> s2) env@(NetlistEnv {_suffixName = s1}) | Text.null s1 = env {_suffixName = s2} | otherwise = env {_suffixName = s2 <> "_" <> s1} + modName SuffixNameP (Text.pack -> s2) env@(NetlistEnv {_suffixName = s1}) + | Text.null s1 = env {_suffixName = s2} + | otherwise = env {_suffixName = s1 <> "_" <> s2} modName SetName (Text.pack -> s) env = env {_setName = Just s} -- | Add the pre- and suffix names in the current environment to the given diff --git a/src/Clash/Normalize.hs b/src/Clash/Normalize.hs --- a/src/Clash/Normalize.hs +++ b/src/Clash/Normalize.hs @@ -8,82 +8,83 @@ Turn CoreHW terms into normalized CoreHW Terms -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE BangPatterns #-} - -{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Normalize where -import Data.Either - import Control.Concurrent.Supply (Supply) -import Control.Lens ((.=),(^.),_1,_4) +import Control.Exception (throw) import qualified Control.Lens as Lens +import Control.Monad (when) import Control.Monad.State.Strict (State) -import Data.Binary (encode) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import Data.Either (partitionEithers) +import Data.Default (def) +import Data.Either (lefts,partitionEithers) import qualified Data.IntMap as IntMap import Data.IntMap.Strict (IntMap) import Data.List - (groupBy, intersect, mapAccumL, sortBy) + (intersect, mapAccumL) import qualified Data.Map as Map import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Data.Set.Lens as Lens -import Data.Semigroup ((<>)) import Data.Text.Prettyprint.Doc (vcat) -import System.IO.Unsafe (unsafePerformIO) import BasicTypes (InlineSpec (..)) -import SrcLoc (SrcSpan,noSrcSpan) import Clash.Annotations.BitRepresentation.Internal (CustomReprs) -import Clash.Core.Evaluator (PrimEvaluator) +import Clash.Core.Evaluator.Types (PrimStep, PrimUnwind) import Clash.Core.FreeVars (freeLocalIds, globalIds, globalIdOccursIn, localIdDoesNotOccurIn) -import Clash.Core.Pretty (showPpr, ppr) +import Clash.Core.Pretty (PrettyOptions(..), showPpr, showPpr', ppr) import Clash.Core.Subst - (deShadowTerm, extendGblSubstList, mkSubst, substTm) + (extendGblSubstList, mkSubst, substTm) import Clash.Core.Term (Term (..), collectArgsTicks) import Clash.Core.Type (Type, splitCoreFunForallTy) import Clash.Core.TyCon (TyConMap, TyConName) -import Clash.Core.Util (mkApps, mkTicks, termType) +import Clash.Core.Type (isPolyTy) +import Clash.Core.Util (mkApps, mkTicks) import Clash.Core.Var (Id, varName, varType) import Clash.Core.VarEnv (VarEnv, elemVarSet, eltsVarEnv, emptyInScopeSet, emptyVarEnv, - extendVarEnv, lookupVarEnv, mapVarEnv, mapMaybeVarEnv, mkInScopeSet, + extendVarEnv, lookupVarEnv, mapVarEnv, mapMaybeVarEnv, mkVarEnv, mkVarSet, notElemVarEnv, notElemVarSet, nullVarEnv, unionVarEnv) import Clash.Driver.Types - (BindingMap, ClashOpts (..), DebugLevel (..)) + (BindingMap, Binding(..), ClashOpts (..), DebugLevel (..)) import Clash.Netlist.Types - (HWType (..), HWMap, FilteredHWType(..)) + (HWMap, FilteredHWType(..)) import Clash.Netlist.Util - (splitNormalized, coreTypeToHWType') + (splitNormalized) import Clash.Normalize.Strategy import Clash.Normalize.Transformations - (appProp, bindConstantVar, caseCon, flattenLet, reduceConst, topLet, + (appPropFast, bindConstantVar, caseCon, flattenLet, reduceConst, topLet, reduceNonRepPrim, removeUnusedExpr) import Clash.Normalize.Types import Clash.Normalize.Util import Clash.Primitives.Types (CompiledPrimMap) -import Clash.Rewrite.Combinators ((>->),(!->)) +import Clash.Rewrite.Combinators ((>->),(!->),repeatR,topdownR) import Clash.Rewrite.Types - (RewriteEnv (..), RewriteState (..), bindings, curFun, dbgLevel, extra, - tcCache, topEntities, typeTranslator, customReprs, RewriteStep (..)) + (RewriteEnv (..), RewriteState (..), bindings, dbgLevel, extra, + tcCache, topEntities) import Clash.Rewrite.Util - (apply, isUntranslatableType, runRewrite, runRewriteSession) -import Clash.Signal.Internal (ResetKind (..)) + (apply, isUntranslatableType, runRewriteSession) import Clash.Util +import Clash.Util.Interpolate (i) +#ifdef HISTORY +import Data.Binary (encode) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL + +import System.IO.Unsafe (unsafePerformIO) +import Clash.Rewrite.Types (RewriteStep(..)) +#endif + + -- | Run a NormalizeSession in a given environment runNormalization :: ClashOpts @@ -100,7 +101,7 @@ -- ^ TyCon cache -> IntMap TyConName -- ^ Tuple TyCon cache - -> PrimEvaluator + -> (PrimStep, PrimUnwind) -- ^ Hardcoded evaluator (delta-reduction) -> CompiledPrimMap -- ^ Primitive Definitions @@ -116,6 +117,8 @@ where rwEnv = RewriteEnv (opt_dbgLevel opts) + (opt_dbgTransformations opts) + (opt_aggressiveXOpt opts) typeTrans tcm tupTcm @@ -146,6 +149,7 @@ rcsMap (opt_newInlineStrat opts) (opt_ultra opts) + (opt_inlineWFCacheLimit opts) normalize @@ -157,45 +161,74 @@ newNormalized <- normalize (concat new) return (unionVarEnv (mkVarEnv topNormalized) newNormalized) -normalize' - :: Id - -> NormalizeSession ([Id],(Id,(Id,SrcSpan,InlineSpec,Term))) +normalize' :: Id -> NormalizeSession ([Id], (Id, Binding)) normalize' nm = do exprM <- lookupVarEnv nm <$> Lens.use bindings let nmS = showPpr (varName nm) case exprM of - Just (nm',sp,inl,tm) -> do + Just (Binding nm' sp inl tm) -> do tcm <- Lens.view tcCache - let (_,resTy) = splitCoreFunForallTy tcm (varType nm') + topEnts <- Lens.view topEntities + let isTop = nm `elemVarSet` topEnts + ty0 = varType nm' + ty1 = if isTop then tvSubstWithTyEq ty0 else ty0 + + -- check for polymorphic types + when (isPolyTy ty1) $ + let msg = $curLoc ++ [i| + Clash can only normalize monomorphic functions, but this is polymorphic: + #{showPpr' def{displayUniques=False\} nm'} + |] + msgExtra | ty0 == ty1 = Nothing + | otherwise = Just $ [i| + Even after applying type equality constraints it remained polymorphic: + #{showPpr' def{displayUniques=False\} nm'{varType=ty1\}} + |] + in throw (ClashException sp msg msgExtra) + + -- check for unrepresentable result type + let (args,resTy) = splitCoreFunForallTy tcm ty1 + isTopEnt = nm `elemVarSet` topEnts + isFunction = not $ null $ lefts args resTyRep <- not <$> isUntranslatableType False resTy if resTyRep then do - tmNorm <- normalizeTopLvlBndr nm (nm',sp,inl,tm) - let usedBndrs = Lens.toListOf globalIds (tmNorm ^. _4) + tmNorm <- normalizeTopLvlBndr isTopEnt nm (Binding nm' sp inl tm) + let usedBndrs = Lens.toListOf globalIds (bindingTerm tmNorm) traceIf (nm `elem` usedBndrs) (concat [ $(curLoc),"Expr belonging to bndr: ",nmS ," (:: " - , showPpr (varType (tmNorm ^. _1)) + , showPpr (varType (bindingId tmNorm)) , ") remains recursive after normalization:\n" - , showPpr (tmNorm ^. _4) ]) + , showPpr (bindingTerm tmNorm) ]) (return ()) - prevNorm <- mapVarEnv (Lens.view _1) <$> Lens.use (extra.normalized) - topEnts <- Lens.view topEntities + prevNorm <- mapVarEnv bindingId <$> Lens.use (extra.normalized) let toNormalize = filter (`notElemVarSet` topEnts) $ filter (`notElemVarEnv` (extendVarEnv nm nm prevNorm)) usedBndrs return (toNormalize,(nm,tmNorm)) - else do - let usedBndrs = Lens.toListOf globalIds tm - prevNorm <- mapVarEnv (Lens.view _1) <$> Lens.use (extra.normalized) - topEnts <- Lens.view topEntities - let toNormalize = filter (`notElemVarSet` topEnts) - $ filter (`notElemVarEnv` (extendVarEnv nm nm prevNorm)) usedBndrs + else + do + -- Throw an error for unrepresentable topEntities and functions + when (isTopEnt || isFunction) $ + let msg = $(curLoc) ++ [i| + This bndr has a non-representable return type and can't be normalized: + #{showPpr' def{displayUniques=False\} nm'} + |] + in throw (ClashException sp msg Nothing) + + -- But allow the compilation to proceed for nonrepresentable values. + -- This can happen for example when GHC decides to create a toplevel binder + -- for the ByteArray# inside of a Natural constant. + -- (GHC-8.4 does this with tests/shouldwork/Numbers/Exp.hs) + -- It will later be inlined by flattenCallTree. lvl <- Lens.view dbgLevel - traceIf (lvl >= DebugFinal) + traceIf (lvl > DebugNone) (concat [$(curLoc), "Expr belonging to bndr: ", nmS, " (:: " , showPpr (varType nm') , ") has a non-representable return type." , " Not normalising:\n", showPpr tm] ) - (return (toNormalize,(nm,(nm',sp,inl,tm)))) + (return ([],(nm,(Binding nm' sp inl tm)))) + + Nothing -> error $ $(curLoc) ++ "Expr belonging to bndr: " ++ nmS ++ " not found" -- | Check whether the normalized bindings are non-recursive. Errors when one @@ -206,12 +239,12 @@ -> BindingMap checkNonRecursive norm = case mapMaybeVarEnv go norm of rcs | nullVarEnv rcs -> norm - rcs -> error $ $(curLoc) ++ "Callgraph after normalisation contains following recursive components: " + rcs -> error $ $(curLoc) ++ "Callgraph after normalization contains following recursive components: " ++ show (vcat [ ppr a <> ppr b | (a,b) <- eltsVarEnv rcs ]) where - go (nm,_,_,tm) = + go (Binding nm _ _ tm) = if nm `globalIdOccursIn` tm then Just (nm,tm) else Nothing @@ -231,8 +264,12 @@ return (mkVarEnv $ snd $ callTreeToList [] ctFlat) cleanupGraph _ norm = return norm -data CallTree = CLeaf (Id,(Id,SrcSpan,InlineSpec,Term)) - | CBranch (Id,(Id,SrcSpan,InlineSpec,Term)) [CallTree] +-- | A tree of identifiers and their bindings, with branches containing +-- additional bindings which are used. See "Clash.Driver.Types.Binding". +-- +data CallTree + = CLeaf (Id, Binding) + | CBranch (Id, Binding) [CallTree] mkCallTree :: [Id] @@ -244,7 +281,7 @@ -> Maybe CallTree mkCallTree visited bindingMap root | Just rootTm <- lookupVarEnv root bindingMap - = let used = Set.toList $ Lens.setOf globalIds $ (rootTm ^. _4) + = let used = Set.toList $ Lens.setOf globalIds $ (bindingTerm rootTm) other = Maybe.mapMaybe (mkCallTree (root:visited) bindingMap) (filter (`notElem` visited) used) in case used of [] -> Just (CLeaf (root,rootTm)) @@ -273,8 +310,8 @@ flattenNode :: CallTree -> NormalizeSession (Either CallTree ((Id,Term),[CallTree])) -flattenNode c@(CLeaf (_,(_,_,NoInline,_))) = return (Left c) -flattenNode c@(CLeaf (nm,(_,_,_,e))) = do +flattenNode c@(CLeaf (_,(Binding _ _ NoInline _))) = return (Left c) +flattenNode c@(CLeaf (nm,(Binding _ _ _ e))) = do isTopEntity <- elemVarSet nm <$> Lens.view topEntities if isTopEntity then return (Left c) else do tcm <- Lens.view tcCache @@ -287,9 +324,9 @@ return (Right ((nm,mkApps (mkTicks fun ticks) (reverse remainder)),[])) _ -> return (Right ((nm,e),[])) _ -> return (Right ((nm,e),[])) -flattenNode b@(CBranch (_,(_,_,NoInline,_)) _) = +flattenNode b@(CBranch (_,(Binding _ _ NoInline _)) _) = return (Left b) -flattenNode b@(CBranch (nm,(_,_,_,e)) us) = do +flattenNode b@(CBranch (nm,(Binding _ _ _ e)) us) = do isTopEntity <- elemVarSet nm <$> Lens.view topEntities if isTopEntity then return (Left b) else do tcm <- Lens.view tcCache @@ -311,7 +348,7 @@ :: CallTree -> NormalizeSession CallTree flattenCallTree c@(CLeaf _) = return c -flattenCallTree (CBranch (nm,(nm',sp,inl,tm)) used) = do +flattenCallTree (CBranch (nm,(Binding nm' sp inl tm)) used) = do flattenedUsed <- mapM flattenCallTree used (newUsed,il_ct) <- partitionEithers <$> mapM flattenNode flattenedUsed let (toInline,il_used) = unzip il_ct @@ -319,9 +356,7 @@ newExpr <- case toInline of [] -> return tm _ -> do - -- To have a cheap `appProp` transformation we need to - -- deshadow, see also Note [AppProp no-shadow invariant] - let tm1 = deShadowTerm emptyInScopeSet (substTm "flattenCallTree.flattenExpr" subst tm) + let tm1 = substTm "flattenCallTree.flattenExpr" subst tm #ifdef HISTORY -- NB: When HISTORY is on, emit binary data holding the recorded rewrite steps let !_ = unsafePerformIO @@ -345,34 +380,29 @@ let (toInline',allUsed') = unzip (map goCheap allUsed) subst' = extendGblSubstList (mkSubst emptyInScopeSet) (Maybe.catMaybes toInline') - -- To have a cheap `appProp` transformation we need to - -- deshadow, see also Note [AppProp no-shadow invariant] - let tm1 = deShadowTerm emptyInScopeSet (substTm "flattenCallTree.flattenCheap" subst' newExpr) + let tm1 = substTm "flattenCallTree.flattenCheap" subst' newExpr newExpr' <- rewriteExpr ("flattenCheap",flatten) (showPpr nm, tm1) (nm', sp) - return (CBranch (nm,(nm',sp,inl,newExpr')) (concat allUsed')) - else return (CBranch (nm,(nm',sp,inl,newExpr)) allUsed) + return (CBranch (nm,(Binding nm' sp inl newExpr')) (concat allUsed')) + else return (CBranch (nm,(Binding nm' sp inl newExpr)) allUsed) where flatten = - innerMost (apply "appProp" appProp >-> + repeatR (topdownR (apply "appPropFast" appPropFast >-> apply "bindConstantVar" bindConstantVar >-> apply "caseCon" caseCon >-> apply "reduceConst" reduceConst >-> apply "reduceNonRepPrim" reduceNonRepPrim >-> apply "removeUnusedExpr" removeUnusedExpr >-> - apply "flattenLet" flattenLet) !-> + apply "flattenLet" flattenLet)) !-> topdownSucR (apply "topLet" topLet) - goCheap c@(CLeaf (nm2,(_,_,inl2,e))) + goCheap c@(CLeaf (nm2,(Binding _ _ inl2 e))) | inl2 == NoInline = (Nothing ,[c]) | otherwise = (Just (nm2,e),[]) - goCheap c@(CBranch (nm2,(_,_,inl2,e)) us) + goCheap c@(CBranch (nm2,(Binding _ _ inl2 e)) us) | inl2 == NoInline = (Nothing, [c]) | otherwise = (Just (nm2,e),us) -callTreeToList - :: [Id] - -> CallTree - -> ([Id],[(Id,(Id,SrcSpan,InlineSpec,Term))]) +callTreeToList :: [Id] -> CallTree -> ([Id], [(Id, Binding)]) callTreeToList visited (CLeaf (nm,bndr)) | nm `elem` visited = (visited,[]) | otherwise = (nm:visited,[(nm,bndr)]) diff --git a/src/Clash/Normalize/DEC.hs b/src/Clash/Normalize/DEC.hs --- a/src/Clash/Normalize/DEC.hs +++ b/src/Clash/Normalize/DEC.hs @@ -26,13 +26,9 @@ > C -> h x -} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Normalize.DEC (collectGlobals @@ -62,7 +58,8 @@ (termFreeVars', typeFreeVars', localVarsDoNotOccurIn) import Clash.Core.Literal (Literal (..)) import Clash.Core.Term - (LetBinding, Pat (..), PrimInfo (..), Term (..), collectArgs, collectArgsTicks) + (LetBinding, Pat (..), PrimInfo (..), Term (..), TickInfo (..), collectArgs, + collectArgsTicks) import Clash.Core.TyCon (tyConDataCons) import Clash.Core.Type (Type, isPolyFunTy, mkTyConApp, splitFunForallTy) import Clash.Core.Util (mkApps, mkTicks, patIds, termType) @@ -142,19 +139,19 @@ | not eIsconstant = do tcm <- Lens.view tcCache bndrs <- Lens.use bindings - primEval <- Lens.view evaluator + (primEval, primUnwind) <- Lens.view evaluator gh <- Lens.use globalHeap ids <- Lens.use uniqSupply let (ids1,ids2) = splitSupply ids uniqSupply Lens..= ids2 - let eval = (Lens.view Lens._3) . whnf' primEval bndrs tcm gh ids1 inScope False + let eval = (Lens.view Lens._3) . whnf' primEval primUnwind bndrs tcm gh ids1 inScope False eTy = termType tcm e untran <- isUntranslatableType False eTy case untran of -- Don't lift out non-representable values, because they cannot be let-bound -- in our desired normal form. False -> do - isInteresting <- interestingToLift inScope eval fun args + isInteresting <- interestingToLift inScope eval fun args ticks case isInteresting of Just fun' | fun' `notElem` seen -> do (args',collected) <- collectGlobalsArgs inScope substitution @@ -183,6 +180,10 @@ ,map (second (second (LB lbs'))) (collected ++ collected') ) +collectGlobals' inScope substitution seen (Tick t e) eIsConstant = do + (e',collected) <- collectGlobals' inScope substitution seen e eIsConstant + return (Tick t e',collected) + collectGlobals' _ _ _ e _ = return (e,[]) -- | Collect 'CaseTree's for (potentially) disjoint applications of globals out @@ -442,17 +443,21 @@ -- ^ Term in function position -> [Either Term Type] -- ^ Arguments + -> [TickInfo] + -- ^ Tick annoations -> RewriteMonad extra (Maybe Term) -interestingToLift inScope _ e@(Var v) _ = - if isGlobalId v || v `elemInScopeSet` inScope +interestingToLift inScope _ e@(Var v) _ ticks = + if NoDeDup `notElem` ticks && (isGlobalId v || v `elemInScopeSet` inScope) then pure (Just e) else pure Nothing -interestingToLift inScope eval e@(Prim nm pInfo) args = do +interestingToLift inScope eval e@(Prim pInfo) args ticks + | NoDeDup `notElem` ticks = do let anyArgNotConstant = any (not . isConstant) lArgs - case List.lookup nm interestingPrims of + case List.lookup (primName pInfo) interestingPrims of Just t | t || anyArgNotConstant -> pure (Just e) + _ | DeDup `elem` ticks -> pure (Just e) _ -> do - let isInteresting = uncurry (interestingToLift inScope eval) . collectArgs + let isInteresting = uncurry3 (interestingToLift inScope eval) . collectArgsTicks if isHOTy (primType pInfo) then do anyInteresting <- anyM (fmap Maybe.isJust . isInteresting) lArgs if anyInteresting then pure (Just e) else pure Nothing @@ -507,12 +512,12 @@ termIsPow2 e' = case eval e' of Literal (IntegerLiteral n) -> isPow2 n a -> case collectArgs a of - (Prim nm' _,[Right _,Left _,Left (Literal (IntegerLiteral n))]) - | isFromInteger nm' -> isPow2 n - (Prim nm' _,[Right _,Left _,Left _,Left (Literal (IntegerLiteral n))]) - | nm' == "Clash.Sized.Internal.BitVector.fromInteger#" -> isPow2 n - (Prim nm' _,[Right _, Left _,Left (Literal (IntegerLiteral n))]) - | nm' == "Clash.Sized.Internal.BitVector.fromInteger##" -> isPow2 n + (Prim p,[Right _,Left _,Left (Literal (IntegerLiteral n))]) + | isFromInteger (primName p) -> isPow2 n + (Prim p,[Right _,Left _,Left _,Left (Literal (IntegerLiteral n))]) + | primName p == "Clash.Sized.Internal.BitVector.fromInteger#" -> isPow2 n + (Prim p,[Right _, Left _,Left (Literal (IntegerLiteral n))]) + | primName p == "Clash.Sized.Internal.BitVector.fromInteger##" -> isPow2 n _ -> False @@ -527,4 +532,4 @@ isHOTy t = case splitFunForallTy t of (args',_) -> any isPolyFunTy (Either.rights args') -interestingToLift _ _ _ _ = pure Nothing +interestingToLift _ _ _ _ _ = pure Nothing diff --git a/src/Clash/Normalize/PrimitiveReductions.hs b/src/Clash/Normalize/PrimitiveReductions.hs --- a/src/Clash/Normalize/PrimitiveReductions.hs +++ b/src/Clash/Normalize/PrimitiveReductions.hs @@ -30,10 +30,9 @@ * Clash.Sized.Vector.transpose -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Normalize.PrimitiveReductions where @@ -49,7 +48,8 @@ import Clash.Core.Name (nameOcc) import Clash.Core.Pretty (showPpr) import Clash.Core.Term - (CoreContext (..), PrimInfo (..), Term (..), WorkInfo (..), Pat (..)) + (CoreContext (..), PrimInfo (..), Term (..), WorkInfo (..), Pat (..), + collectTermIds) import Clash.Core.Type (LitTy (..), Type (..), TypeView (..), coreView1, mkFunTy, mkTyConApp, @@ -129,8 +129,9 @@ = do uniqs0 <- Lens.use uniqSupply fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun - let (uniqs1,(varsL,elemsL)) = second (second concat . unzip) - $ extractElems uniqs0 is0 consCon lhsElTy 'L' n lhsArg + let is1 = extendInScopeSetList is0 (collectTermIds fun1) + (uniqs1,(varsL,elemsL)) = second (second concat . unzip) + $ extractElems uniqs0 is1 consCon lhsElTy 'L' n lhsArg is2 = extendInScopeSetList is0 (map fst elemsL) (uniqs2,(varsR,elemsR)) = second (second concat . unzip) $ extractElems uniqs1 is2 consCon rhsElTy 'R' n rhsArg @@ -165,8 +166,9 @@ = do uniqs0 <- Lens.use uniqSupply fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun - let (uniqs1,(vars,elems)) = second (second concat . unzip) - $ extractElems uniqs0 is0 consCon argElTy 'A' n arg + let is1 = extendInScopeSetList is0 (collectTermIds fun1) + (uniqs1,(vars,elems)) = second (second concat . unzip) + $ extractElems uniqs0 is1 consCon argElTy 'A' n arg funApps = map (fun1 `App`) vars lbody = mkVec nilCon consCon resElTy n funApps lb = Letrec (init elems) lbody @@ -198,7 +200,8 @@ = do uniqs0 <- Lens.use uniqSupply fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun - let (uniqs1,nTv) = mkUniqSystemTyVar (uniqs0,is0) ("n",typeNatKind) + let is1 = extendInScopeSetList is0 (collectTermIds fun1) + (uniqs1,nTv) = mkUniqSystemTyVar (uniqs0,is1) ("n",typeNatKind) (uniqs2,(vars,elems)) = second (second concat . unzip) $ uncurry extractElems uniqs1 consCon argElTy 'I' n arg (Right idxTy:_,_) = splitFunForallTy (termType tcm fun) @@ -209,8 +212,7 @@ (mkTyConApp idxTcNm [VarTy nTv]) [integerPrimTy,integerPrimTy]) - idxFromInteger = Prim "Clash.Sized.Internal.Index.fromInteger#" - (PrimInfo idxFromIntegerTy WorkNever) + idxFromInteger = Prim (PrimInfo "Clash.Sized.Internal.Index.fromInteger#" idxFromIntegerTy WorkNever) idxs = map (App (App (TyApp idxFromInteger (LitTy (NumTy n))) (Literal (IntegerLiteral (toInteger n)))) . Literal . IntegerLiteral . toInteger) [0..(n-1)] @@ -248,11 +250,12 @@ = do uniqs0 <- Lens.use uniqSupply fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun - let (Just apDictTc) = lookupUniqMap apDictTcNm tcm + let is1 = extendInScopeSetList is0 (collectTermIds fun1) + (Just apDictTc) = lookupUniqMap apDictTcNm tcm [apDictCon] = tyConDataCons apDictTc (Just apDictIdTys) = dataConInstArgTys apDictCon [fTy] (uniqs1,apDictIds@[functorDictId,pureId,apId,_,_]) = - mapAccumR mkUniqInternalId (uniqs0,is0) + mapAccumR mkUniqInternalId (uniqs0,is1) (zip ["functorDict","pure","ap","apConstL","apConstR"] apDictIdTys) @@ -381,8 +384,9 @@ = do uniqs0 <- Lens.use uniqSupply fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun - let (uniqs1,(vars,elems)) = second (second concat . unzip) - $ extractElems uniqs0 is0 consCon aTy 'G' n arg + let is1 = extendInScopeSetList is0 (collectTermIds fun1) + (uniqs1,(vars,elems)) = second (second concat . unzip) + $ extractElems uniqs0 is1 consCon aTy 'G' n arg lbody = foldr (\l r -> mkApps fun1 [Left l,Left r]) start vars lb = Letrec (init elems) lbody uniqSupply Lens..= uniqs1 @@ -416,8 +420,9 @@ = do uniqs0 <- Lens.use uniqSupply fun1 <- constantPropagation (TransformContext is0 (AppArg Nothing:ctx)) fun - let (uniqs1,(vars,elems)) = second (second concat . unzip) - $ extractElems uniqs0 is0 consCon aTy 'F' n arg + let is1 = extendInScopeSetList is0 (collectTermIds fun1) + (uniqs1,(vars,elems)) = second (second concat . unzip) + $ extractElems uniqs0 is1 consCon aTy 'F' n arg lbody = foldV fun1 vars lb = Letrec (init elems) lbody uniqSupply Lens..= uniqs1 @@ -447,7 +452,7 @@ -- ^ The vector to fold -> NormalizeSession Term reduceDFold _ 0 _ _ start _ = changed start -reduceDFold inScope n aTy fun start arg = do +reduceDFold is0 n aTy fun start arg = do tcm <- Lens.view tcCache let ty = termType tcm arg go tcm ty @@ -459,8 +464,11 @@ , [_,consCon] <- tyConDataCons vecTc = do uniqs0 <- Lens.use uniqSupply - let (uniqs1,(vars,elems)) = second (second concat . unzip) - $ extractElems uniqs0 inScope consCon aTy 'D' n arg + let is1 = extendInScopeSetList is0 (collectTermIds fun) + -- TODO: Should 'constantPropagation' be used on 'fun'? It seems to + -- TOOD: be used for every other function in this module. + (uniqs1,(vars,elems)) = second (second concat . unzip) + $ extractElems uniqs0 is1 consCon aTy 'D' n arg (_ltv:Right snTy:_,_) = splitFunForallTy (termType tcm fun) (TyConApp snatTcNm _) = tyView snTy (Just snatTc) = lookupUniqMap snatTcNm tcm @@ -769,8 +777,7 @@ -> Type -> Term eqIntPrim intTy boolTy = - Prim "Clash.Transformations.eqInt" - (PrimInfo (mkFunTy intTy (mkFunTy intTy boolTy)) WorkVariable) + Prim (PrimInfo "Clash.Transformations.eqInt" (mkFunTy intTy (mkFunTy intTy boolTy)) WorkVariable) go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) @@ -870,8 +877,7 @@ -> Type -> Term eqIntPrim intTy boolTy = - Prim "Clash.Transformations.eqInt" - (PrimInfo (mkFunTy intTy (mkFunTy intTy boolTy)) WorkVariable) + Prim (PrimInfo "Clash.Transformations.eqInt" (mkFunTy intTy (mkFunTy intTy boolTy)) WorkVariable) go tcm (coreView1 tcm -> Just ty') = go tcm ty' go tcm (tyView -> TyConApp vecTcNm _) diff --git a/src/Clash/Normalize/Strategy.hs b/src/Clash/Normalize/Strategy.hs --- a/src/Clash/Normalize/Strategy.hs +++ b/src/Clash/Normalize/Strategy.hs @@ -28,10 +28,11 @@ -- | Normalisation transformation normalization :: NormRewrite -normalization = rmDeadcode >-> constantPropagation >-> etaTL >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >-> - bindConst >-> letTL >-> evalConst >-!-> cse >-!-> cleanup >-> recLetRec +normalization = rmDeadcode >-> constantPropagation >-> rmUnusedExpr >-!-> anf >-!-> rmDeadcode >-> + bindConst >-> letTL >-> evalConst >-!-> cse >-!-> cleanup >-> + xOptim >-> rmDeadcode >-> + cleanup >-> recLetRec >-> splitArgs where - etaTL = apply "etaTL" etaExpansionTL !-> topdownR (apply "applicationPropagation" appPropFast) anf = topdownR (apply "nonRepANF" nonRepANF) >-> apply "ANF" makeANF >-> topdownR (apply "caseCon" caseCon) letTL = topdownSucR (apply "topLet" topLet) recLetRec = apply "recToLetRec" recToLetRec @@ -41,19 +42,23 @@ -- See [Note] bottomup traversal evalConst: evalConst = bottomupR (apply "evalConst" reduceConst) cse = topdownR (apply "CSE" simpleCSE) + xOptim = bottomupR (apply "xOptimize" xOptimize) cleanup = topdownR (apply "etaExpandSyn" etaExpandSyn) >-> topdownSucR (apply "inlineCleanup" inlineCleanup) !-> innerMost (applyMany [("caseCon" , caseCon) ,("bindConstantVar", bindConstantVar) ,("letFlat" , flattenLet)]) >-> rmDeadcode >-> letTL + splitArgs = topdownR (apply "separateArguments" separateArguments) !-> + topdownR (apply "caseCon" caseCon) constantPropagation :: NormRewrite constantPropagation = inlineAndPropagate >-> - caseFlattening >-> dec >-> spec >-> dec >-> + caseFlattening >-> etaTL >-> dec >-> spec >-> dec >-> conSpec where + etaTL = apply "etaTL" etaExpansionTL !-> topdownR (apply "applicationPropagation" appPropFast) inlineAndPropagate = repeatR (topdownR (applyMany transPropagateAndInline) >-> inlineNR) spec = bottomupR (applyMany specTransformations) caseFlattening = repeatR (topdownR (apply "caseFlat" caseFlat)) diff --git a/src/Clash/Normalize/Transformations.hs b/src/Clash/Normalize/Transformations.hs --- a/src/Clash/Normalize/Transformations.hs +++ b/src/Clash/Normalize/Transformations.hs @@ -8,2308 +8,2867 @@ Transformations of the Normalization process -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - -module Clash.Normalize.Transformations - ( appProp - , caseLet - , caseCon - , caseCase - , caseElemNonReachable - , elemExistentials - , inlineNonRep - , inlineOrLiftNonRep - , typeSpec - , nonRepSpec - , etaExpansionTL - , nonRepANF - , bindConstantVar - , constantSpec - , makeANF - , deadCode - , topLet - , recToLetRec - , inlineWorkFree - , inlineHO - , inlineSmall - , simpleCSE - , reduceConst - , reduceNonRepPrim - , caseFlat - , disjointExpressionConsolidation - , removeUnusedExpr - , inlineCleanup - , flattenLet - , splitCastWork - , inlineCast - , caseCast - , letCast - , eliminateCastCast - , argCastSpec - , etaExpandSyn - , appPropFast - ) -where - -import Control.Concurrent.Supply (splitSupply) -import Control.Exception (throw) -import Control.Lens (_2) -import qualified Control.Lens as Lens -import qualified Control.Monad as Monad -import Control.Monad.State (StateT (..), modify) -import Control.Monad.State.Strict (evalState) -import Control.Monad.Writer (lift, listen) -import Control.Monad.Trans.Except (runExcept) -import Data.Bits ((.&.), complement) -import Data.Coerce (coerce) -import qualified Data.Either as Either -import qualified Data.HashMap.Lazy as HashMap -import qualified Data.HashMap.Strict as HashMapS -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import qualified Data.Monoid as Monoid -import qualified Data.Primitive.ByteArray as BA -import qualified Data.Text as Text -import qualified Data.Vector.Primitive as PV -import Debug.Trace (trace) -import GHC.Integer.GMP.Internals (Integer (..), BigNat (..)) - -import BasicTypes (InlineSpec (..)) - -import Clash.Annotations.Primitive (extractPrim) -import Clash.Core.DataCon (DataCon (..)) -import Clash.Core.Evaluator (PureHeap, whnf') -import Clash.Core.Name - (Name (..), NameSort (..), mkUnsafeSystemName) -import Clash.Core.FreeVars - (localIdOccursIn, localIdsDoNotOccurIn, freeLocalIds, termFreeTyVars, typeFreeVars, localVarsDoNotOccurIn) -import Clash.Core.Literal (Literal (..)) -import Clash.Core.Pretty (showPpr) -import Clash.Core.Subst - (substTm, mkSubst, extendIdSubst, extendIdSubstList, extendTvSubst, - extendTvSubstList, freshenTm, substTyInVar, deShadowTerm) -import Clash.Core.Term - (LetBinding, Pat (..), Term (..), CoreContext (..), PrimInfo (..), TickInfo, - isLambdaBodyCtx, isTickCtx, collectArgs, collectArgsTicks, collectTicks, - partitionTicks) -import Clash.Core.Type (Type, TypeView (..), applyFunTy, - isPolyFunCoreTy, isClassTy, - normalizeType, splitFunForallTy, - splitFunTy, - tyView) -import Clash.Core.TyCon (TyConMap, tyConDataCons) -import Clash.Core.Util - (isCon, isFun, isLet, isPolyFun, isPrim, - isSignalType, isVar, mkApps, mkLams, mkVec, piResultTy, termSize, termType, - tyNatSize, patVars, isAbsurdAlt, altEqs, substInExistentialsList, - solveNonAbsurds, patIds, isLocalVar, undefinedTm, stripTicks, mkTicks) -import Clash.Core.Var - (Id, Var (..), isGlobalId, isLocalId, mkLocalId) -import Clash.Core.VarEnv - (InScopeSet, VarEnv, VarSet, elemVarSet, - emptyVarEnv, emptyVarSet, extendInScopeSet, extendInScopeSetList, lookupVarEnv, - notElemVarSet, unionVarEnvWith, unionVarSet, unionInScope, unitVarEnv, - unitVarSet, mkVarSet, mkInScopeSet, uniqAway) -import Clash.Driver.Types (DebugLevel (..)) -import Clash.Netlist.BlackBox.Util (usedArguments) -import Clash.Netlist.Types (HWType (..), FilteredHWType(..)) -import Clash.Netlist.Util - (coreTypeToHWType, representableType, splitNormalized, bindsExistentials) -import Clash.Normalize.DEC -import Clash.Normalize.PrimitiveReductions -import Clash.Normalize.Types -import Clash.Normalize.Util -import Clash.Primitives.Types - (Primitive(..), TemplateKind(TExpr), CompiledPrimMap) -import Clash.Rewrite.Combinators -import Clash.Rewrite.Types -import Clash.Rewrite.Util -import Clash.Unique - (Unique, lookupUniqMap, toListUniqMap) -import Clash.Util - -inlineOrLiftNonRep :: HasCallStack => NormRewrite -inlineOrLiftNonRep = inlineOrLiftBinders nonRepTest inlineTest - where - nonRepTest :: (Id, Term) -> RewriteMonad extra Bool - nonRepTest (Id {varType = ty}, _) - = not <$> (representableType <$> Lens.view typeTranslator - <*> Lens.view customReprs - <*> pure False - <*> Lens.view tcCache - <*> pure ty) - nonRepTest _ = return False - - inlineTest :: Term -> (Id, Term) -> RewriteMonad extra Bool - inlineTest e (id_, e') - = not . or <$> sequence -- We do __NOT__ inline: - [ -- 1. recursive let-binders - pure (id_ `localIdOccursIn` e') - -- 2. join points (which are not void-wrappers) - , pure (isJoinPointIn id_ e && not (isVoidWrapper e')) - -- 3. binders that are used more than once in the body, because - -- it makes CSE a whole lot more difficult. - , pure (freeOccurances > 1) - ] - where - -- The number of free occurrences of the binder in the entire - -- let-expression - freeOccurances :: Int - freeOccurances = case e of - Letrec _ res -> do - Monoid.getSum - (Lens.foldMapOf freeLocalIds - (\i -> if i == id_ - then Monoid.Sum 1 - else Monoid.Sum 0) - res) - _ -> 0 - -{- [Note] join points and void wrappers -Join points are functions that only occur in tail-call positions within an -expression, and only when they occur in a tail-call position more than once. - -Normally bindNonRep binds/inlines all non-recursive local functions. However, -doing so for join points would significantly increase compilation time, so we -avoid it. The only exception to this rule are so-called void wrappers. Void -wrappers are functions of the form: - -> \(w :: Void) -> f a b c - -i.e. a wrapper around the function 'f' where the argument 'w' is not used. We -do bind/line these join-points because these void-wrappers interfere with the -'disjoint expression consolidation' (DEC) and 'common sub-expression elimination' -(CSE) transformation, sometimes resulting in circuits that are twice as big -as they'd need to be. --} - --- | Specialize functions on their type -typeSpec :: HasCallStack => NormRewrite -typeSpec ctx e@(TyApp e1 ty) - | (Var {}, args) <- collectArgs e1 - , null $ Lens.toListOf typeFreeVars ty - , (_, []) <- Either.partitionEithers args - = specializeNorm ctx e - -typeSpec _ e = return e - --- | Specialize functions on their non-representable argument -nonRepSpec :: HasCallStack => NormRewrite -nonRepSpec ctx@(TransformContext is0 _) e@(App e1 e2) - | (Var {}, args) <- collectArgs e1 - , (_, []) <- Either.partitionEithers args - , null $ Lens.toListOf termFreeTyVars e2 - = do tcm <- Lens.view tcCache - let e2Ty = termType tcm e2 - let localVar = isLocalVar e2 - nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator - <*> Lens.view customReprs - <*> pure False - <*> Lens.view tcCache - <*> pure e2Ty) - if nonRepE2 && not localVar - then do - e2' <- inlineInternalSpecialisationArgument e2 - specializeNorm ctx (App e1 e2') - else return e - where - -- | If the argument on which we're specialising ia an internal function, - -- one created by the compiler, then inline that function before we - -- specialise. - -- - -- We need to do this because otherwise the specialisation history won't - -- recognize the new specialisation argument as something the function has - -- already been specialized on - inlineInternalSpecialisationArgument - :: Term - -> NormalizeSession Term - inlineInternalSpecialisationArgument app - | (Var f,fArgs,ticks) <- collectArgsTicks app - = do - fTmM <- lookupVarEnv f <$> Lens.use bindings - case fTmM of - Just (fNm,_,_,tm) - | nameSort (varName fNm) == Internal - -> do - tm' <- censor (const mempty) - (bottomupR appProp ctx - (mkApps (mkTicks tm ticks) fArgs)) - -- See Note [AppProp no-shadow invariant] - return (deShadowTerm is0 tm') - _ -> return app - | otherwise = return app - -nonRepSpec _ e = return e - --- | Lift the let-bindings out of the subject of a Case-decomposition -caseLet :: HasCallStack => NormRewrite -caseLet _ (Case (Letrec xes e) ty alts) = - changed (Letrec xes (Case e ty alts)) - -caseLet _ e = return e - --- | Remove non-reachable alternatives. For example, consider: --- --- data STy ty where --- SInt :: Int -> STy Int --- SBool :: Bool -> STy Bool --- --- f :: STy ty -> ty --- f (SInt b) = b + 1 --- f (SBool True) = False --- f (SBool False) = True --- {-# NOINLINE f #-} --- --- g :: STy Int -> Int --- g = f --- --- @f@ is always specialized on @STy Int@. The SBool alternatives are therefore --- unreachable. Additional information can be found at: --- https://github.com/clash-lang/clash-compiler/pull/465 -caseElemNonReachable :: HasCallStack => NormRewrite -caseElemNonReachable _ case0@(Case scrut altsTy alts0) = do - tcm <- Lens.view tcCache - - let (altsAbsurd, altsOther) = List.partition (isAbsurdAlt tcm) alts0 - case altsAbsurd of - [] -> return case0 - _ -> changed =<< caseOneAlt (Case scrut altsTy altsOther) - -caseElemNonReachable _ e = return e - --- | Tries to eliminate existentials by using heuristics to determine what the --- existential should be. For example, consider Vec: --- --- data Vec :: Nat -> Type -> Type where --- Nil :: Vec 0 a --- Cons x xs :: a -> Vec n a -> Vec (n + 1) a --- --- Thus, 'null' (annotated with existentials) could look like: --- --- null :: forall n . Vec n Bool -> Bool --- null v = --- case v of --- Nil {n ~ 0} -> True --- Cons {n1:Nat} {n~n1+1} (x :: a) (xs :: Vec n1 a) -> False --- --- When it's applied to a vector of length 5, this becomes: --- --- null :: Vec 5 Bool -> Bool --- null v = --- case v of --- Nil {5 ~ 0} -> True --- Cons {n1:Nat} {5~n1+1} (x :: a) (xs :: Vec n1 a) -> False --- --- This function solves 'n1' and replaces every occurrence with its solution. A --- very limited number of solutions are currently recognized: only adds (such --- as in the example) will be solved. -elemExistentials :: HasCallStack => NormRewrite -elemExistentials (TransformContext is0 _) (Case scrut altsTy alts0) = do - tcm <- Lens.view tcCache - - alts1 <- mapM (go is0 tcm) alts0 - caseOneAlt (Case scrut altsTy alts1) - - where - -- Eliminate free type variables if possible - go :: InScopeSet -> TyConMap -> (Pat, Term) -> NormalizeSession (Pat, Term) - go is2 tcm alt@(DataPat dc exts0 xs0, term0) = - case solveNonAbsurds tcm (altEqs tcm alt) of - -- No equations solved: - [] -> return alt - -- One or more equations solved: - sols -> - changed =<< go is2 tcm (DataPat dc exts1 xs1, term1) - where - -- Substitute solution in existentials and applied types - is3 = extendInScopeSetList is2 exts0 - xs1 = map (substTyInVar (extendTvSubstList (mkSubst is3) sols)) xs0 - exts1 = substInExistentialsList is2 exts0 sols - - -- Substitute solution in term. - is4 = extendInScopeSetList is3 xs1 - subst = extendTvSubstList (mkSubst is4) sols - term1 = substTm "Replacing tyVar due to solved eq" subst term0 - - go _ _ alt = return alt - -elemExistentials _ e = return e - --- | Move a Case-decomposition from the subject of a Case-decomposition to the alternatives -caseCase :: HasCallStack => NormRewrite -caseCase _ e@(Case (stripTicks -> Case scrut alts1Ty alts1) alts2Ty alts2) - = do - ty1Rep <- representableType <$> Lens.view typeTranslator - <*> Lens.view customReprs - <*> pure False - <*> Lens.view tcCache - <*> pure alts1Ty - if not ty1Rep - then let newAlts = map (second (\altE -> Case altE alts2Ty alts2)) alts1 - in changed $ Case scrut alts2Ty newAlts - else return e - -caseCase _ e = return e - --- | Inline function with a non-representable result if it's the subject --- of a Case-decomposition -inlineNonRep :: HasCallStack => NormRewrite -inlineNonRep (TransformContext localScope _) e@(Case scrut altsTy alts) - | (Var f, args,ticks) <- collectArgsTicks scrut - , isGlobalId f - = do - (cf,_) <- Lens.use curFun - isInlined <- zoomExtra (alreadyInlined f cf) - limit <- Lens.use (extra.inlineLimit) - tcm <- Lens.view tcCache - let scrutTy = termType tcm scrut - noException = not (exception tcm scrutTy) - if noException && (Maybe.fromMaybe 0 isInlined) > limit - then do - traceIf True (concat [$(curLoc) ++ "InlineNonRep: " ++ showPpr (varName f) - ," already inlined " ++ show limit ++ " times in:" - , showPpr (varName cf) - , "\nType of the subject is: " ++ showPpr scrutTy - , "\nFunction " ++ showPpr (varName cf) - , " will not reach a normal form, and compilation" - , " might fail." - , "\nRun with '-fclash-inline-limit=N' to increase" - , " the inlining limit to N." - ]) - (return e) - else do - bodyMaybe <- lookupVarEnv f <$> Lens.use bindings - nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator - <*> Lens.view customReprs - <*> pure False - <*> Lens.view tcCache - <*> pure scrutTy) - case (nonRepScrut, bodyMaybe) of - (True,Just (_,_,_,scrutBody0)) -> do - Monad.when noException (zoomExtra (addNewInline f cf)) - -- See Note [AppProp no-shadow invariant] - let scrutBody1 = deShadowTerm localScope scrutBody0 - changed $ Case (mkApps (mkTicks scrutBody1 ticks) args) altsTy alts - _ -> return e - where - exception = isClassTy - -inlineNonRep _ e = return e - --- | Specialize a Case-decomposition (replace by the RHS of an alternative) if --- the subject is (an application of) a DataCon; or if there is only a single --- alternative that doesn't reference variables bound by the pattern. --- --- Note [CaseCon deshadow] --- --- Imagine: --- --- @ --- case D (f a b) (g x y) of --- D a b -> h a --- @ --- --- rewriting this to: --- --- @ --- let a = f a b --- in h a --- @ --- --- is very bad because the newly introduced let-binding now captures the free --- variable 'a' in 'f a b'. --- --- instead me must rewrite to: --- --- @ --- let a1 = f a b --- in h a1 --- @ -caseCon :: HasCallStack => NormRewrite -caseCon (TransformContext is0 _) (Case scrut ty alts) - | (Data dc, args) <- collectArgs scrut - = case List.find (equalCon dc . fst) alts of - Just (DataPat _ tvs xs, e) -> do - let is1 = extendInScopeSetList (extendInScopeSetList is0 tvs) xs - let fvs = Lens.foldMapOf freeLocalIds unitVarSet e - (binds,_) = List.partition ((`elemVarSet` fvs) . fst) - $ zip xs (Either.lefts args) - e' = case binds of - [] -> e - _ -> - -- See Note [CaseCon deshadow] - let ((is3,substIds),binds') = List.mapAccumL newBinder - (is1,[]) binds - subst = extendIdSubstList (mkSubst is3) substIds - in Letrec binds' (substTm "caseCon0" subst e) - let subst = extendTvSubstList (mkSubst is1) - $ zip tvs (drop (length (dcUnivTyVars dc)) (Either.rights args)) - changed (substTm "caseCon1" subst e') - _ -> case alts of - ((DefaultPat,e):_) -> changed e - _ -> changed (undefinedTm ty) - where - equalCon dc (DataPat dc' _ _) = dcTag dc == dcTag dc' - equalCon _ _ = False - - newBinder (isN0,substN) (x,arg) = - let x' = uniqAway isN0 x - isN1 = extendInScopeSet isN0 x' - in ((isN1,(x,Var x'):substN),(x',arg)) - -caseCon _ c@(Case (stripTicks -> Literal l) _ alts) = case List.find (equalLit . fst) alts of - Just (LitPat _,e) -> changed e - _ -> matchLiteralContructor c l alts - where - equalLit (LitPat l') = l == l' - equalLit _ = False - -caseCon ctx@(TransformContext is0 _) e@(Case subj ty alts) - | (Prim _ _,_) <- collectArgs subj = do - reprs <- Lens.view customReprs - tcm <- Lens.view tcCache - bndrs <- Lens.use bindings - primEval <- Lens.view evaluator - ids <- Lens.use uniqSupply - let (ids1,ids2) = splitSupply ids - uniqSupply Lens..= ids2 - gh <- Lens.use globalHeap - lvl <- Lens.view dbgLevel - case whnf' primEval bndrs tcm gh ids1 is0 True subj of - (gh',ph',v) -> do - globalHeap Lens..= gh' - bindPureHeap ctx tcm ph' $ \ctx' -> case stripTicks v of - Literal l -> caseCon ctx' (Case (Literal l) ty alts) - subj' -> case collectArgsTicks subj' of - (Data _,_,_) -> caseCon ctx' (Case subj' ty alts) -#if MIN_VERSION_ghc(8,2,2) - (Prim nm ty',_:msgOrCallStack:_,ticks) - | nm == "Control.Exception.Base.absentError" -> - let e' = mkApps (mkTicks (Prim nm ty') ticks) - [Right ty,msgOrCallStack] - in changed e' -#endif - - (Prim nm ty',repTy:_:msgOrCallStack:_,ticks) - | nm `elem` ["Control.Exception.Base.patError" -#if !MIN_VERSION_ghc(8,2,2) - ,"Control.Exception.Base.absentError" -#endif - ,"GHC.Err.undefined"] -> - let e' = mkApps (mkTicks (Prim nm ty') ticks) - [repTy,Right ty,msgOrCallStack] - in changed e' - (Prim nm ty',[_],ticks) - | nm `elem` [ "Clash.Transformations.undefined" - , "Clash.GHC.Evaluator.undefined" - , "EmptyCase"] -> - let e' = mkApps (mkTicks (Prim nm ty') ticks) [Right ty] - in changed e' - _ -> do - let subjTy = termType tcm subj - tran <- Lens.view typeTranslator - case (`evalState` HashMapS.empty) (coreTypeToHWType tran reprs tcm subjTy) of - Right (FilteredHWType (Void (Just hty)) _areVoids) - | hty `elem` [BitVector 0, Unsigned 0, Signed 0, Index 1] - -> caseCon ctx' (Case (Literal (IntegerLiteral 0)) ty alts) - _ -> do - let ret = caseOneAlt e - if lvl > DebugNone then do - let subjIsConst = isConstant subj - traceIf (lvl > DebugNone && subjIsConst) ("Irreducible constant as case subject: " ++ showPpr subj ++ "\nCan be reduced to: " ++ showPpr subj') ret - else - ret - -caseCon ctx e@(Case subj ty alts) = do - reprs <- Lens.view customReprs - tcm <- Lens.view tcCache - let subjTy = termType tcm subj - tran <- Lens.view typeTranslator - case (`evalState` HashMapS.empty) (coreTypeToHWType tran reprs tcm subjTy) of - Right (FilteredHWType (Void (Just hty)) _areVoids) - | hty `elem` [BitVector 0, Unsigned 0, Signed 0, Index 1] - -> caseCon ctx (Case (Literal (IntegerLiteral 0)) ty alts) - _ -> caseOneAlt e - -caseCon _ e = return e - - --- | Binds variables on the PureHeap over the result of the rewrite --- --- To prevent unnecessary rewrites only do this when rewrite changed something. -bindPureHeap - :: TransformContext - -> TyConMap - -> PureHeap - -> (TransformContext -> RewriteMonad extra Term) - -> RewriteMonad extra Term -bindPureHeap (TransformContext is0 ctxs) tcm heap rw = do - (e, Monoid.getAny -> hasChanged) <- listen $ rw ctx' - if hasChanged && not (null bndrs) - then return $ Letrec bndrs e - else return e - where - bndrs = map toLetBinding $ toListUniqMap heap - heapIds = map fst bndrs - is1 = extendInScopeSetList is0 heapIds - ctx' = TransformContext is1 (LetBody heapIds : ctxs) - - toLetBinding :: (Unique,Term) -> LetBinding - toLetBinding (uniq,term) = (nm, term) - where - ty = termType tcm term - nm = mkLocalId ty (mkUnsafeSystemName "x" uniq) -- See [Note: Name re-creation] - -{- [Note: Name re-creation] -The names of heap bound variables are safely generate with mkUniqSystemId in Clash.Core.Evaluator.newLetBinding. -But only their uniqs end up in the heap, not the complete names. -So we use mkUnsafeSystemName to recreate the same Name. --} - -matchLiteralContructor - :: Term - -> Literal - -> [(Pat,Term)] - -> NormalizeSession Term -matchLiteralContructor c (IntegerLiteral l) alts = go (reverse alts) - where - go [(DefaultPat,e)] = changed e - go ((DataPat dc [] xs,e):alts') - | dcTag dc == 1 - , l >= ((-2)^(63::Int)) && l < 2^(63::Int) - = let fvs = Lens.foldMapOf freeLocalIds unitVarSet e - (binds,_) = List.partition ((`elemVarSet` fvs) . fst) - $ zip xs [Literal (IntLiteral l)] - e' = case binds of - [] -> e - _ -> Letrec binds e - in changed e' - | dcTag dc == 2 - , l >= 2^(63::Int) - = let !(Jp# !(BN# ba)) = l - ba' = BA.ByteArray ba - bv = PV.Vector 0 (BA.sizeofByteArray ba') ba' - fvs = Lens.foldMapOf freeLocalIds unitVarSet e - (binds,_) = List.partition ((`elemVarSet` fvs) . fst) - $ zip xs [Literal (ByteArrayLiteral bv)] - e' = case binds of - [] -> e - _ -> Letrec binds e - in changed e' - | dcTag dc == 3 - , l < ((-2)^(63::Int)) - = let !(Jn# !(BN# ba)) = l - ba' = BA.ByteArray ba - bv = PV.Vector 0 (BA.sizeofByteArray ba') ba' - fvs = Lens.foldMapOf freeLocalIds unitVarSet e - (binds,_) = List.partition ((`elemVarSet` fvs) . fst) - $ zip xs [Literal (ByteArrayLiteral bv)] - e' = case binds of - [] -> e - _ -> Letrec binds e - in changed e' - | otherwise - = go alts' - go ((LitPat l', e):alts') - | IntegerLiteral l == l' - = changed e - | otherwise - = go alts' - go _ = error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showPpr c - -matchLiteralContructor c (NaturalLiteral l) alts = go (reverse alts) - where - go [(DefaultPat,e)] = changed e - go ((DataPat dc [] xs,e):alts') - | dcTag dc == 1 - , l >= 0 && l < 2^(64::Int) - = let fvs = Lens.foldMapOf freeLocalIds unitVarSet e - (binds,_) = List.partition ((`elemVarSet` fvs) . fst) - $ zip xs [Literal (WordLiteral l)] - e' = case binds of - [] -> e - _ -> Letrec binds e - in changed e' - | dcTag dc == 2 - , l >= 2^(64::Int) - = let !(Jp# !(BN# ba)) = l - ba' = BA.ByteArray ba - bv = PV.Vector 0 (BA.sizeofByteArray ba') ba' - fvs = Lens.foldMapOf freeLocalIds unitVarSet e - (binds,_) = List.partition ((`elemVarSet` fvs) . fst) - $ zip xs [Literal (ByteArrayLiteral bv)] - e' = case binds of - [] -> e - _ -> Letrec binds e - in changed e' - | otherwise - = go alts' - go ((LitPat l', e):alts') - | NaturalLiteral l == l' - = changed e - | otherwise - = go alts' - go _ = error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showPpr c - -matchLiteralContructor _ _ ((DefaultPat,e):_) = changed e -matchLiteralContructor c _ _ = - error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showPpr c - -caseOneAlt :: Term -> RewriteMonad extra Term -caseOneAlt e@(Case _ _ [(pat,altE)]) = case pat of - DefaultPat -> changed altE - LitPat _ -> changed altE - DataPat _ tvs xs - | (coerce tvs ++ coerce xs) `localVarsDoNotOccurIn` altE - -> changed altE - | otherwise - -> return e - -caseOneAlt e = return e - --- | Bring an application of a DataCon or Primitive in ANF, when the argument is --- is considered non-representable -nonRepANF :: HasCallStack => NormRewrite -nonRepANF ctx e@(App appConPrim arg) - | (conPrim, _) <- collectArgs e - , isCon conPrim || isPrim conPrim - = do - untranslatable <- isUntranslatable False arg - case (untranslatable,stripTicks arg) of - (True,Letrec binds body) -> changed (Letrec binds (App appConPrim body)) - (True,Case {}) -> specializeNorm ctx e - (True,Lam {}) -> specializeNorm ctx e - (True,TyLam {}) -> specializeNorm ctx e - _ -> return e - -nonRepANF _ e = return e - --- | Ensure that top-level lambda's eventually bind a let-expression of which --- the body is a variable-reference. -topLet :: HasCallStack => NormRewrite -topLet (TransformContext is0 ctx) e - | all (\c -> isLambdaBodyCtx c || isTickCtx c) ctx && not (isLet e) - = do - untranslatable <- isUntranslatable False e - if untranslatable - then return e - else do tcm <- Lens.view tcCache - argId <- mkTmBinderFor is0 tcm (mkUnsafeSystemName "result" 0) e - changed (Letrec [(argId, e)] (Var argId)) - -topLet (TransformContext is0 ctx) e@(Letrec binds body) - | all (\c -> isLambdaBodyCtx c || isTickCtx c) ctx - = do - let localVar = isLocalVar body - untranslatable <- isUntranslatable False body - if localVar || untranslatable - then return e - else do - tcm <- Lens.view tcCache - let is2 = extendInScopeSetList is0 (map fst binds) - argId <- mkTmBinderFor is2 tcm (mkUnsafeSystemName "result" 0) body - changed (Letrec (binds ++ [(argId,body)]) (Var argId)) - -topLet _ e = return e - --- Misc rewrites - --- | Remove unused let-bindings -deadCode :: HasCallStack => NormRewrite -deadCode _ e@(Letrec xes body) = do - let bodyFVs = Lens.foldMapOf freeLocalIds unitVarSet body - (xesUsed,xesOther) = List.partition((`elemVarSet` bodyFVs) . fst) xes - xesUsed' = findUsedBndrs [] xesUsed xesOther - if length xesUsed' /= length xes - then case xesUsed' of - [] -> changed body - _ -> changed (Letrec xesUsed' body) - else return e - where - findUsedBndrs :: [(Id, Term)] -> [(Id, Term)] - -> [(Id, Term)] -> [(Id, Term)] - findUsedBndrs used [] _ = used - findUsedBndrs used explore other = - let fvsUsed = List.foldl' unionVarSet - emptyVarSet - (map (Lens.foldMapOf freeLocalIds unitVarSet . snd) explore) - (explore',other') = List.partition - ((`elemVarSet` fvsUsed) . fst) other - in findUsedBndrs (used ++ explore) explore' other' - -deadCode _ e = return e - -removeUnusedExpr :: HasCallStack => NormRewrite -removeUnusedExpr _ e@(collectArgsTicks -> (p@(Prim nm pInfo),args,ticks)) = do - bbM <- HashMap.lookup nm <$> Lens.use (extra.primitives) - case bbM of - Just (extractPrim -> Just (BlackBox pNm _ _ _ _ _ _ inc templ)) -> do - let usedArgs | isFromInt pNm - = [0,1,2] - | nm `elem` ["Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL" - ] - = [0,1] - | otherwise - = usedArguments templ ++ concatMap (usedArguments . snd) inc - tcm <- Lens.view tcCache - args' <- go tcm 0 usedArgs args - if args == args' - then return e - else changed (mkApps (mkTicks p ticks) args') - _ -> return e - where - arity = length . Either.rights . fst $ splitFunForallTy (primType pInfo) - - go _ _ _ [] = return [] - go tcm n used (Right ty:args') = do - args'' <- go tcm n used args' - return (Right ty : args'') - go tcm n used (Left tm : args') = do - args'' <- go tcm (n+1) used args' - let ty = termType tcm tm - p' = removedTm ty - if n < arity && n `notElem` used - then return (Left p' : args'') - else return (Left tm : args'') - -removeUnusedExpr _ e@(Case _ _ [(DataPat _ [] xs,altExpr)]) = - if xs `localIdsDoNotOccurIn` altExpr - then changed altExpr - else return e - --- Replace any expression that creates a Vector of size 0 within the application --- of the Cons constructor, by the Nil constructor. -removeUnusedExpr _ e@(collectArgsTicks -> (Data dc, [_,Right aTy,Right nTy,_,Left a,Left nil],ticks)) - | nameOcc (dcName dc) == "Clash.Sized.Vector.Cons" - = do - tcm <- Lens.view tcCache - case runExcept (tyNatSize tcm nTy) of - Right 0 - | (con, _) <- collectArgs nil - , not (isCon con) - -> let eTy = termType tcm e - (TyConApp vecTcNm _) = tyView eTy - (Just vecTc) = lookupUniqMap vecTcNm tcm - [nilCon,consCon] = tyConDataCons vecTc - v = mkTicks (mkVec nilCon consCon aTy 1 [a]) ticks - in changed v - _ -> return e - -removeUnusedExpr _ e = return e - --- | Inline let-bindings when the RHS is either a local variable reference or --- is constant (except clock or reset generators) -bindConstantVar :: HasCallStack => NormRewrite -bindConstantVar = inlineBinders test - where - test _ (_,stripTicks -> e) = case isLocalVar e of - True -> return True - _ -> isWorkFreeIsh e >>= \case - True -> Lens.use (extra.inlineConstantLimit) >>= \case - 0 -> return True - n -> return (termSize e <= n) - _ -> return False - -- test _ _ = return False - --- | Push a cast over a case into it's alternatives. -caseCast :: HasCallStack => NormRewrite -caseCast _ (Cast (stripTicks -> Case subj ty alts) ty1 ty2) = do - let alts' = map (\(p,e) -> (p, Cast e ty1 ty2)) alts - changed (Case subj ty alts') -caseCast _ e = return e - --- | Push a cast over a Letrec into it's body -letCast :: HasCallStack => NormRewrite -letCast _ (Cast (stripTicks -> Letrec binds body) ty1 ty2) = - changed $ Letrec binds (Cast body ty1 ty2) -letCast _ e = return e - - --- | Push cast over an argument to a function into that function --- --- This is done by specializing on the casted argument. --- Example: --- @ --- y = f (cast a) --- where f x = g x --- @ --- transforms to: --- @ --- y = f' a --- where f' x' = (\x -> g x) (cast x') --- @ --- --- The reason d'etre for this transformation is that we hope to end up with --- and expression where two casts are "back-to-back" after which we can --- eliminate them in 'eliminateCastCast'. -argCastSpec :: HasCallStack => NormRewrite -argCastSpec ctx e@(App _ (stripTicks -> Cast e' _ _)) = - if isWorkFree e' then - go - else - warn go - where - go = specializeNorm ctx e - warn = trace (unwords - [ "WARNING:", $(curLoc), "specializing a function on a non work-free" - , "cast. Generated HDL implementation might contain duplicate work." - , "Please report this as a bug.", "\n\nExpression where this occured:" - , "\n\n" ++ showPpr e - ]) -argCastSpec _ e = return e - --- | Only inline casts that just contain a 'Var', because these are guaranteed work-free. --- These are the result of the 'splitCastWork' transformation. -inlineCast :: HasCallStack => NormRewrite -inlineCast = inlineBinders test - where - test _ (_, (Cast (stripTicks -> Var {}) _ _)) = return True - test _ _ = return False - --- | Eliminate two back to back casts where the type going in and coming out are the same --- --- @ --- (cast :: b -> a) $ (cast :: a -> b) x ==> x --- @ -eliminateCastCast :: HasCallStack => NormRewrite -eliminateCastCast _ c@(Cast (stripTicks -> Cast e tyA tyB) tyB' tyC) = do - tcm <- Lens.view tcCache - let ntyA = normalizeType tcm tyA - ntyB = normalizeType tcm tyB - ntyB' = normalizeType tcm tyB' - ntyC = normalizeType tcm tyC - if ntyB == ntyB' && ntyA == ntyC then changed e - else throwError - where throwError = do - (nm,sp) <- Lens.use curFun - throw (ClashException sp ($(curLoc) ++ showPpr nm - ++ ": Found 2 nested casts whose types don't line up:\n" - ++ showPpr c) - Nothing) - -eliminateCastCast _ e = return e - --- | Make a cast work-free by splitting the work of to a separate binding --- --- @ --- let x = cast (f a b) --- ==> --- let x = cast x' --- x' = f a b --- @ -splitCastWork :: HasCallStack => NormRewrite -splitCastWork ctx@(TransformContext is0 _) unchanged@(Letrec vs e') = do - (vss', Monoid.getAny -> hasChanged) <- listen (mapM (splitCastLetBinding is0) vs) - let vs' = concat vss' - if hasChanged then changed (Letrec vs' e') - else return unchanged - where - splitCastLetBinding - :: InScopeSet - -> LetBinding - -> RewriteMonad extra [LetBinding] - splitCastLetBinding isN x@(nm, e) = case stripTicks e of - Cast (Var {}) _ _ -> return [x] -- already work-free - Cast (Cast {}) _ _ -> return [x] -- casts will be eliminated - Cast e0 ty1 ty2 -> do - tcm <- Lens.view tcCache - nm' <- mkTmBinderFor isN tcm (mkDerivedName ctx (nameOcc $ varName nm)) e0 - changed [(nm',e0) - ,(nm, Cast (Var nm') ty1 ty2) - ] - _ -> return [x] - -splitCastWork _ e = return e - - --- | Inline work-free functions, i.e. fully applied functions that evaluate to --- a constant -inlineWorkFree :: HasCallStack => NormRewrite -inlineWorkFree (TransformContext localScope _) e@(collectArgsTicks -> (Var f,args@(_:_),ticks)) - = do - tcm <- Lens.view tcCache - let eTy = termType tcm e - argsHaveWork <- or <$> mapM (either expressionHasWork - (const (pure False))) - args - untranslatable <- isUntranslatableType True eTy - let isSignal = isSignalType tcm eTy - let lv = isLocalId f - if untranslatable || isSignal || argsHaveWork || lv - then return e - else do - bndrs <- Lens.use bindings - case lookupVarEnv f bndrs of - -- Don't inline recursive expressions - Just (_,_,_,body) -> do - isRecBndr <- isRecursiveBndr f - if isRecBndr - then return e - else do - -- See Note [AppProp no-shadow invariant] - changed (mkApps (mkTicks (deShadowTerm localScope body) ticks) args) - _ -> return e - where - -- an expression is has work when it contains free local variables, - -- or has a Signal type, i.e. it does not evaluate to a work-free - -- constant. - expressionHasWork e' = do - let fvIds = Lens.toListOf freeLocalIds e' - tcm <- Lens.view tcCache - let e'Ty = termType tcm e' - isSignal = isSignalType tcm e'Ty - return (not (null fvIds) || isSignal) - -inlineWorkFree (TransformContext localScope _) e@(Var f) = do - tcm <- Lens.view tcCache - let fTy = varType f - closed = not (isPolyFunCoreTy tcm fTy) - isSignal = isSignalType tcm fTy - untranslatable <- isUntranslatableType True fTy - let gv = isGlobalId f - if closed && not untranslatable && not isSignal && gv - then do - bndrs <- Lens.use bindings - case lookupVarEnv f bndrs of - -- Don't inline recursive expressions - Just top -> do - isRecBndr <- isRecursiveBndr f - if isRecBndr - then return e - else do - (_,_,_,body) <- normalizeTopLvlBndr f top - -- See Note [AppProp no-shadow invariant] - changed (deShadowTerm localScope body) - _ -> return e - else return e - -inlineWorkFree _ e = return e - --- | Inline small functions -inlineSmall :: HasCallStack => NormRewrite -inlineSmall (TransformContext localScope _) e@(collectArgsTicks -> (Var f,args,ticks)) = do - untranslatable <- isUntranslatable True e - topEnts <- Lens.view topEntities - let lv = isLocalId f - if untranslatable || f `elemVarSet` topEnts || lv - then return e - else do - bndrs <- Lens.use bindings - sizeLimit <- Lens.use (extra.inlineFunctionLimit) - case lookupVarEnv f bndrs of - -- Don't inline recursive expressions - Just (_,_,inl,body) -> do - isRecBndr <- isRecursiveBndr f - if not isRecBndr && inl /= NoInline && termSize body < sizeLimit - then do - -- See Note [AppProp no-shadow invariant] - changed (mkApps (mkTicks (deShadowTerm localScope body) ticks) args) - else return e - _ -> return e - -inlineSmall _ e = return e - --- | Specialise functions on arguments which are constant, except when they --- are clock, reset generators. -constantSpec :: HasCallStack => NormRewrite -constantSpec ctx@(TransformContext is0 tfCtx) e@(App e1 e2) - | (Var {}, args) <- collectArgs e1 - , (_, []) <- Either.partitionEithers args - , null $ Lens.toListOf termFreeTyVars e2 - = do specInfo<- constantSpecInfo ctx e2 - if csrFoundConstant specInfo then - let newBindings = csrNewBindings specInfo in - if null newBindings then - -- Whole of e2 is constant - specializeNorm ctx (App e1 e2) - else do - -- Parts of e2 are constant - let is1 = extendInScopeSetList is0 (fst <$> csrNewBindings specInfo) - -- Deshadow because appPropFast will be called after constantSpec - deShadowTerm is0 - <$> Letrec newBindings - <$> specializeNorm - (TransformContext is1 tfCtx) - (App e1 (csrNewTerm specInfo)) - - else - -- e2 has no constant parts - return e -constantSpec _ e = return e - - --- Experimental - --- | Propagate arguments of application inwards; except for 'Lam' where the --- argument becomes let-bound. --- --- Note [AppProp deshadow] --- --- Imagine: --- --- @ --- (case x of --- D a b -> h a) (f x y) --- @ --- --- rewriting this to: --- --- @ --- let b = f x y --- in case x of --- D a b -> h a b --- @ --- --- is very bad because 'b' in 'h a b' is now bound by the pattern instead of the --- newly introduced let-binding --- --- instead me must rewrite to: --- --- @ --- let b1 = f x y --- in case x of --- D a b -> h a b1 --- @ --- --- Note [AppProp no-shadow invariant] --- --- Imagine --- --- @ --- (\x -> e) u --- @ --- --- where @u@ has a free variable named @x@, rewriting this to: --- --- @ --- let x = u --- in e --- @ --- --- would be very bad, because the let-binding suddenly captures the free --- variable in @u@. The same for: --- --- @ --- (let x = w in e) u --- @ --- --- where @u@ again has a free variable @x@, rewriting this to: --- --- @ --- let x = w in (e u) --- @ --- --- would be bad because the let-binding now captures the free variable in @u@. --- --- To prevent this from happening, we can either: --- --- 1. Rename the bindings, so that they cannot capture --- 2. Ensure that @AppProp@ is only called in a context where there is no --- shadowing, i.e. the bindings can never never collide with the current --- inScopeSet. --- --- We have gone for option 2 so that AppProp requires less computation and --- because AppProp is such a commonly applied transformation. This --- means that when normalisation starts we deshadow the expression, and when --- we inline global binders, we ensure that inlined expression is deshadowed --- taking the InScopeSet of the context into account. -appProp :: HasCallStack => NormRewrite -appProp (TransformContext is0 _) (App (collectTicks -> (Lam v e,ticks)) arg) = - if isWorkFree arg || isVar arg - then do - let subst = extendIdSubst (mkSubst is0) v arg - changed $ mkTicks (substTm "appProp.AppLam" subst e) ticks - else changed $ Letrec [(v, arg)] (mkTicks e ticks) - -appProp _ (App (collectTicks -> (Letrec v e, ticks)) arg) = do - changed (Letrec v (App (mkTicks e ticks) arg)) - -appProp ctx@(TransformContext is0 _) (App (collectTicks -> (Case scrut ty alts,ticks)) arg) = do - tcm <- Lens.view tcCache - let argTy = termType tcm arg - ty' = applyFunTy tcm ty argTy - if isWorkFree arg || isVar arg - then do - let alts' = map (second (`App` arg)) alts - changed $ mkTicks (Case scrut ty' alts') ticks - else do - -- See Note [AppProp deshadow] - let is2 = unionInScope is0 ((mkInScopeSet . mkVarSet . concatMap (patVars . fst)) alts) - boundArg <- mkTmBinderFor is2 tcm (mkDerivedName ctx "app_arg") arg - let alts' = map (second (`App` (Var boundArg))) alts - changed (Letrec [(boundArg, arg)] (mkTicks (Case scrut ty' alts') ticks)) - -appProp (TransformContext is0 _) (TyApp (collectTicks -> (TyLam tv e,ticks)) t) = do - let subst = extendTvSubst (mkSubst is0) tv t - changed $ mkTicks (substTm "appProp.TyAppTyLam" subst e) ticks - -appProp _ (TyApp (collectTicks -> (Letrec v e,ticks)) t) = do - changed (Letrec v (mkTicks (TyApp e t) ticks)) - -appProp _ (TyApp (collectTicks -> (Case scrut altsTy alts,ticks)) ty) = do - let alts' = map (second (`TyApp` ty)) alts - tcm <- Lens.view tcCache - let ty' = piResultTy tcm altsTy ty - changed (mkTicks (Case scrut ty' alts') ticks) - -appProp _ e = return e - --- | Unlike 'appProp', which propagates a single argument in an application one --- level down (and should be called in an innermost traversal), 'appPropFast' --- tries to propagate as many arguments as possible, down as many levels as --- possible; and should be called in a top-down traversal. --- --- The idea is that this reduces the number of traversals, which hopefully leads --- to shorter compile times. --- --- Implementation only works if terms are fully deshadowed, see --- Note [AppProp deshadow] -appPropFast :: HasCallStack => NormRewrite -appPropFast ctx@(TransformContext is _) = \case - e@App {} -> uncurry3 (go is) (collectArgsTicks e) - e@TyApp {} -> uncurry3 (go is) (collectArgsTicks e) - e -> return e - where - go :: InScopeSet -> Term -> [Either Term Type] -> [TickInfo] - -> NormalizeSession Term - go is0 (collectArgsTicks -> (fun,args0@(_:_),ticks0)) args1 ticks1 = - go is0 fun (args0 ++ args1) (ticks0 ++ ticks1) - - go is0 (Lam v e) (Left arg:args) ticks = do - setChanged - if isWorkFree arg || isVar arg - then do - let subst = extendIdSubst (mkSubst is0) v arg - (`mkTicks` ticks) <$> go is0 (substTm "appPropFast.AppLam" subst e) args [] - else do - let is1 = extendInScopeSet is0 v - Letrec [(v, arg)] <$> go is1 e args ticks - - go is0 (Letrec vs e) args@(_:_) ticks = do - setChanged - let vbs = map fst vs - is1 = extendInScopeSetList is0 vbs - Letrec vs <$> go is1 e args ticks - - go is0 (TyLam tv e) (Right t:args) ticks = do - setChanged - let subst = extendTvSubst (mkSubst is0) tv t - (`mkTicks` ticks) <$> go is0 (substTm "appPropFast.TyAppTyLam" subst e) args [] - - go is0 (Case scrut ty0 alts) args0@(_:_) ticks = do - setChanged - let isA1 = unionInScope - is0 - ((mkInScopeSet . mkVarSet . concatMap (patVars . fst)) alts) - (ty1,vs,args1) <- goCaseArg isA1 ty0 [] args0 - case vs of - [] -> (`mkTicks` ticks) . Case scrut ty1 <$> mapM (goAlt is0 args1) alts - _ -> do - let vbs = map fst vs - is1 = extendInScopeSetList is0 vbs - Letrec vs . (`mkTicks` ticks) . Case scrut ty1 <$> mapM (goAlt is1 args1) alts - - go is0 (Tick sp e) args ticks = do - setChanged - go is0 e args (sp:ticks) - - go _ fun args ticks = return (mkApps (mkTicks fun ticks) args) - - goAlt is0 args0 (p,e) = do - let (tvs,ids) = patIds p - is1 = extendInScopeSetList (extendInScopeSetList is0 tvs) ids - (p,) <$> go is1 e args0 [] - - goCaseArg isA ty0 ls0 (Right t:args0) = do - tcm <- Lens.view tcCache - let ty1 = piResultTy tcm ty0 t - (ty2,ls1,args1) <- goCaseArg isA ty1 ls0 args0 - return (ty2,ls1,Right t:args1) - - goCaseArg isA0 ty0 ls0 (Left arg:args0) = do - tcm <- Lens.view tcCache - let argTy = termType tcm arg - ty1 = applyFunTy tcm ty0 argTy - case isWorkFree arg || isVar arg of - True -> do - (ty2,ls1,args1) <- goCaseArg isA0 ty1 ls0 args0 - return (ty2,ls1,Left arg:args1) - False -> do - boundArg <- mkTmBinderFor isA0 tcm (mkDerivedName ctx "app_arg") arg - let isA1 = extendInScopeSet isA0 boundArg - (ty2,ls1,args1) <- goCaseArg isA1 ty1 ls0 args0 - return (ty2,(boundArg,arg):ls1,Left (Var boundArg):args1) - - goCaseArg _ ty ls [] = return (ty,ls,[]) - --- | Flatten ridiculous case-statements generated by GHC --- --- For case-statements in haskell of the form: --- --- @ --- f :: Unsigned 4 -> Unsigned 4 --- f x = case x of --- 0 -> 3 --- 1 -> 2 --- 2 -> 1 --- 3 -> 0 --- @ --- --- GHC generates Core that looks like: --- --- @ --- f = \(x :: Unsigned 4) -> case x == fromInteger 3 of --- False -> case x == fromInteger 2 of --- False -> case x == fromInteger 1 of --- False -> case x == fromInteger 0 of --- False -> error "incomplete case" --- True -> fromInteger 3 --- True -> fromInteger 2 --- True -> fromInteger 1 --- True -> fromInteger 0 --- @ --- --- Which would result in a priority decoder circuit where a normal decoder --- circuit was desired. --- --- This transformation transforms the above Core to the saner: --- --- @ --- f = \(x :: Unsigned 4) -> case x of --- _ -> error "incomplete case" --- 0 -> fromInteger 3 --- 1 -> fromInteger 2 --- 2 -> fromInteger 1 --- 3 -> fromInteger 0 --- @ -caseFlat :: HasCallStack => NormRewrite -caseFlat _ e@(Case (collectEqArgs -> Just (scrut',_)) ty _) - = do - case collectFlat scrut' e of - Just alts' -> changed (Case scrut' ty (last alts' : init alts')) - Nothing -> return e - -caseFlat _ e = return e - -collectFlat :: Term -> Term -> Maybe [(Pat,Term)] -collectFlat scrut (Case (collectEqArgs -> Just (scrut', val)) _ty [lAlt,rAlt]) - | scrut' == scrut - = case collectArgs val of - (Prim nm' _,args') | isFromInt nm' -> - go (last args') - (Data dc,args') | nameOcc (dcName dc) == "GHC.Types.I#" -> - go (last args') - _ -> Nothing - where - go (Left (Literal i)) = case (lAlt,rAlt) of - ((pl,el),(pr,er)) - | isFalseDcPat pl || isTrueDcPat pr -> - case collectFlat scrut el of - Just alts' -> Just ((LitPat i, er) : alts') - Nothing -> Just [(LitPat i, er) - ,(DefaultPat, el) - ] - | otherwise -> - case collectFlat scrut er of - Just alts' -> Just ((LitPat i, el) : alts') - Nothing -> Just [(LitPat i, el) - ,(DefaultPat, er) - ] - go _ = Nothing - - isFalseDcPat (DataPat p _ _) - = ((== "GHC.Types.False") . nameOcc . dcName) p - isFalseDcPat _ = False - - isTrueDcPat (DataPat p _ _) - = ((== "GHC.Types.True") . nameOcc . dcName) p - isTrueDcPat _ = False - -collectFlat _ _ = Nothing - -collectEqArgs :: Term -> Maybe (Term,Term) -collectEqArgs (collectArgsTicks -> (Prim nm _, args, ticks)) - | nm == "Clash.Sized.Internal.BitVector.eq#" - = let [_,_,Left scrut,Left val] = args - in Just (mkTicks scrut ticks,val) - | nm == "Clash.Sized.Internal.Index.eq#" || - nm == "Clash.Sized.Internal.Signed.eq#" || - nm == "Clash.Sized.Internal.Unsigned.eq#" - = let [_,Left scrut,Left val] = args - in Just (mkTicks scrut ticks,val) - | nm == "Clash.Transformations.eqInt" - = let [Left scrut,Left val] = args - in Just (mkTicks scrut ticks,val) -collectEqArgs _ = Nothing - -type NormRewriteW = Transform (StateT ([LetBinding],InScopeSet) (RewriteMonad NormalizeState)) - --- | See Note [ANF InScopeSet] -tellBinders :: Monad m => [LetBinding] -> StateT ([LetBinding],InScopeSet) m () -tellBinders bs = modify ((bs ++) *** (`extendInScopeSetList` (map fst bs))) - --- | Turn an expression into a modified ANF-form. As opposed to standard ANF, --- constants do not become let-bound. -makeANF :: HasCallStack => NormRewrite -makeANF (TransformContext is0 ctx) (Lam bndr e) = do - e' <- makeANF (TransformContext (extendInScopeSet is0 bndr) - (LamBody bndr:ctx)) - e - return (Lam bndr e') - -makeANF _ e@(TyLam {}) = return e - -makeANF ctx@(TransformContext is0 _) e0 - = do - -- We need to freshen all binders in `e` because we're shuffling them around - -- into a single let-binder, because even when binders don't shadow, they - -- don't have to be unique within an expression. And so lifting them all - -- to a single let-binder will cause issues when they're not unique. - -- - -- We cannot make freshening part of collectANF, because when we generate - -- new binders, we need to make sure those names do not conflict with _any_ - -- of the existing binders in the expression. - -- - -- See also Note [ANF InScopeSet] - let (is2,e1) = freshenTm is0 e0 - (e2,(bndrs,_)) <- runStateT (bottomupR collectANF ctx e1) ([],is2) - case bndrs of - [] -> return e0 - _ -> do - let (e3,ticks) = collectTicks e2 - (srcTicks,nmTicks) = partitionTicks ticks - -- Ensure that `AppendName` ticks still scope over the entire expression - changed (mkTicks (Letrec bndrs (mkTicks e3 srcTicks)) nmTicks) - --- | Note [ANF InScopeSet] --- --- The InScopeSet contains: --- --- 1. All the free variables of the expression we are traversing --- --- 2. All the bound variables of the expression we are traversing --- --- 3. The newly created let-bindings as we recurse back up the traversal --- --- All of these are needed to created let-bindings that --- --- * Do not shadow --- * Are not shadowed --- * Nor conflict with each other (i.e. have the same unique) --- --- Initially we start with the local InScopeSet and add the global variables: --- --- @ --- is1 <- unionInScope is0 <$> Lens.use globalInScope --- @ --- --- Which will gives us the (superset of) free variables of the expression. Then --- we call 'freshenTm' --- --- @ --- let (is2,e1) = freshenTm is1 e0 --- @ --- --- Which extends the InScopeSet with all the bound variables in 'e1', the --- version of 'e0' where all binders are unique (not just deshadowed). --- --- So we start out with an InScopeSet that satisfies points 1 and 2, now every --- time we create a new binder we must add it to the InScopeSet to satisfy --- point 3. -collectANF :: HasCallStack => NormRewriteW -collectANF ctx e@(App appf arg) - | (conVarPrim, _) <- collectArgs e - , isCon conVarPrim || isPrim conVarPrim || isVar conVarPrim - = do - untranslatable <- lift (isUntranslatable False arg) - let localVar = isLocalVar arg - constantNoCR <- lift (isConstantNotClockReset arg) - case (untranslatable,localVar || constantNoCR,arg) of - (False,False,_) -> do - tcm <- Lens.view tcCache - -- See Note [ANF InScopeSet] - is1 <- Lens.use _2 - argId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "app_arg") arg) - -- See Note [ANF InScopeSet] - tellBinders [(argId,arg)] - return (App appf (Var argId)) - (True,False,Letrec binds body) -> do - tellBinders binds - return (App appf body) - _ -> return e - -collectANF _ (Letrec binds body) = do - tellBinders binds - untranslatable <- lift (isUntranslatable False body) - let localVar = isLocalVar body - if localVar || untranslatable - then return body - else do - tcm <- Lens.view tcCache - -- See Note [ANF InScopeSet] - is1 <- Lens.use _2 - argId <- lift (mkTmBinderFor is1 tcm (mkUnsafeSystemName "result" 0) body) - -- See Note [ANF InScopeSet] - tellBinders [(argId,body)] - return (Var argId) - --- TODO: The code below special-cases ANF for the ':-' constructor for the --- 'Signal' type. The 'Signal' type is essentially treated as a "transparent" --- type by the Clash compiler, so observing its constructor leads to all kinds --- of problems. In this case that "Clash.Rewrite.Util.mkSelectorCase" will --- try to project the LHS and RHS of the ':-' constructor, however, --- 'mkSelectorCase' uses 'coreView1' to find the "real" data-constructor. --- 'coreView1' however looks through the 'Signal' type, and hence 'mkSelector' --- finds the data constructors for the element type of Signal. This resulted in --- error #24 (https://github.com/christiaanb/clash2/issues/24), where we --- try to get the first field out of the 'Vec's 'Nil' constructor. --- --- Ultimately we should stop treating Signal as a "transparent" type and deal --- handling of the Signal type, and the involved co-recursive functions, --- properly. At the moment, Clash cannot deal with this recursive type and the --- recursive functions involved, hence the need for special-casing code. After --- everything is done properly, we should remove the two lines below. -collectANF _ e@(Case _ _ [(DataPat dc _ _,_)]) - | nameOcc (dcName dc) == "Clash.Signal.Internal.:-" = return e - -collectANF ctx (Case subj ty alts) = do - let localVar = isLocalVar subj - let isConstantSubj = isConstant subj - - subj' <- if localVar || isConstantSubj - then return subj - else do - tcm <- Lens.view tcCache - -- See Note [ANF InScopeSet] - is1 <- Lens.use _2 - argId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "case_scrut") subj) - -- See Note [ANF InScopeSet] - tellBinders [(argId,subj)] - return (Var argId) - - alts' <- mapM (doAlt subj') alts - - case alts' of - [(DataPat _ [] xs,altExpr)] - | xs `localIdsDoNotOccurIn` altExpr - -> return altExpr - _ -> return (Case subj' ty alts') - where - doAlt - :: Term -> (Pat,Term) - -> StateT ([LetBinding],InScopeSet) (RewriteMonad NormalizeState) - (Pat,Term) - doAlt subj' alt@(DataPat dc exts xs,altExpr) | not (bindsExistentials exts xs) = do - let lv = isLocalVar altExpr - patSels <- Monad.zipWithM (doPatBndr subj' dc) xs [0..] - let altExprIsConstant = isConstant altExpr - let usesXs (Var n) = any (== n) xs - usesXs _ = False - if (lv && (not (usesXs altExpr) || length alts == 1)) || altExprIsConstant - then do - -- See Note [ANF InScopeSet] - tellBinders patSels - return alt - else do - tcm <- Lens.view tcCache - -- See Note [ANF InScopeSet] - is1 <- Lens.use _2 - altId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "case_alt") altExpr) - -- See Note [ANF InScopeSet] - tellBinders ((altId,altExpr):patSels) - return (DataPat dc exts xs,Var altId) - doAlt _ alt@(DataPat {}, _) = return alt - doAlt _ alt@(pat,altExpr) = do - let lv = isLocalVar altExpr - let altExprIsConstant = isConstant altExpr - if lv || altExprIsConstant - then return alt - else do - tcm <- Lens.view tcCache - -- See Note [ANF InScopeSet] - is1 <- Lens.use _2 - altId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "case_alt") altExpr) - tellBinders [(altId,altExpr)] - return (pat,Var altId) - - doPatBndr - :: Term -> DataCon -> Id -> Int - -> StateT ([LetBinding],InScopeSet) (RewriteMonad NormalizeState) - LetBinding - doPatBndr subj' dc pId i - = do - tcm <- Lens.view tcCache - -- See Note [ANF InScopeSet] - is1 <- Lens.use _2 - patExpr <- lift (mkSelectorCase ($(curLoc) ++ "doPatBndr") is1 tcm subj' (dcTag dc) i) - -- No need to 'tellBinders' here because 'pId' is already in the ANF - -- InScopeSet. - -- - -- See also Note [ANF InScopeSet] - return (pId,patExpr) - -collectANF _ e = return e - --- | Eta-expand top-level lambda's (DON'T use in a traversal!) -etaExpansionTL :: HasCallStack => NormRewrite -etaExpansionTL (TransformContext is0 ctx) (Lam bndr e) = do - e' <- etaExpansionTL - (TransformContext (extendInScopeSet is0 bndr) (LamBody bndr:ctx)) - e - return $ Lam bndr e' - -etaExpansionTL (TransformContext is0 ctx) (Letrec xes e) = do - let bndrs = map fst xes - e' <- etaExpansionTL - (TransformContext (extendInScopeSetList is0 bndrs) - (LetBody bndrs:ctx)) - e - case stripLambda e' of - (bs@(_:_),e2) -> do - let e3 = Letrec xes e2 - changed (mkLams e3 bs) - _ -> return (Letrec xes e') - where - stripLambda :: Term -> ([Id],Term) - stripLambda (Lam bndr e0) = - let (bndrs,e1) = stripLambda e0 - in (bndr:bndrs,e1) - stripLambda e' = ([],e') - -etaExpansionTL (TransformContext is0 ctx) e - = do - tcm <- Lens.view tcCache - if isFun tcm e - then do - let argTy = ( fst - . Maybe.fromMaybe (error $ $(curLoc) ++ "etaExpansion splitFunTy") - . splitFunTy tcm - . termType tcm - ) e - newId <- mkInternalVar is0 "arg" argTy - e' <- etaExpansionTL (TransformContext (extendInScopeSet is0 newId) - (LamBody newId:ctx)) - (App e (Var newId)) - changed (Lam newId e') - else return e - --- | Eta-expand functions with a Synthesize annotation, needed to allow such --- functions to appear as arguments to higher-order primitives. -etaExpandSyn :: HasCallStack => NormRewrite -etaExpandSyn (TransformContext is0 ctx) e@(collectArgs -> (Var f, _)) = do - topEnts <- Lens.view topEntities - tcm <- Lens.view tcCache - let isTopEnt = f `elemVarSet` topEnts - isAppFunCtx = - \case - AppFun:_ -> True - TickC _:c -> isAppFunCtx c - _ -> False - argTyM = fmap fst (splitFunTy tcm (termType tcm e)) - case argTyM of - Just argTy | isTopEnt && not (isAppFunCtx ctx) -> do - newId <- mkInternalVar is0 "arg" argTy - changed (Lam newId (App e (Var newId))) - _ -> return e - -etaExpandSyn _ e = return e - -isClassConstraint :: Type -> Bool -isClassConstraint (tyView -> TyConApp nm0 _) = - if -- Constraint tuple: - | "GHC.Classes.(%" `Text.isInfixOf` nm1 -> True - -- Constraint class: - | "C:" `Text.isInfixOf` nm2 -> True - | otherwise -> False - where - nm1 = nameOcc nm0 - nm2 = snd (Text.breakOnEnd "." nm1) - -isClassConstraint _ = False - - --- | Turn a normalized recursive function, where the recursive calls only pass --- along the unchanged original arguments, into let-recursive function. This --- means that all recursive calls are replaced by the same variable reference as --- found in the body of the top-level let-expression. -recToLetRec :: HasCallStack => NormRewrite -recToLetRec (TransformContext is0 []) e = do - (fn,_) <- Lens.use curFun - tcm <- Lens.view tcCache - case splitNormalized tcm e of - Right (args,bndrs,res) -> do - let args' = map Var args - (toInline,others) = List.partition (eqApp tcm fn args' . snd) bndrs - resV = Var res - case (toInline,others) of - (_:_,_:_) -> do - let is1 = extendInScopeSetList is0 (args ++ map fst bndrs) - let substsInline = extendIdSubstList (mkSubst is1) - $ map (second (const resV)) toInline - others' = map (second (substTm "recToLetRec" substsInline)) - others - changed $ mkLams (Letrec others' resV) args - _ -> return e - _ -> return e - where - -- This checks whether things are semantically equal. For example, say we - -- have: - -- - -- x :: (a, (b, c)) - -- - -- and - -- - -- y :: (a, (b, c)) - -- - -- If we can determine that 'y' is constructed solely using the - -- corresponding fields in 'x', then we can say they are semantically - -- equal. The algorithm below keeps track of what (sub)field it is - -- constructing, and checks if the field-expression projects the - -- corresponding (sub)field from the target variable. - -- - -- TODO: See [Note: Breaks on constants and predetermined equality] - eqApp tcm v args (collectArgs -> (Var v',args')) - | isGlobalId v' - , v == v' - , let args2 = Either.lefts args' - , length args == length args2 - = and (zipWith (eqArg tcm) args args2) - eqApp _ _ _ _ = False - - eqArg _ v1 v2@(Var {}) - = v1 == v2 - eqArg tcm v1 v2@(collectArgs -> (Data _, args')) - | let t1 = termType tcm v1 - , let t2 = termType tcm v2 - , t1 == t2 - = if isClassConstraint t1 then - -- Class constraints are equal if their types are equal, so we can - -- take a shortcut here. - True - else - -- Check whether all arguments to the data constructor are projections - -- - and (zipWith (eqDat v1) (map pure [0..]) (Either.lefts args')) - eqArg _ _ _ - = False - - -- Recursively check whether a term /e/ is semantically equal to some variable /v/. - -- Currently it can only assert equality when /e/ is syntactically equal - -- to /v/, or is constructed out of projections of /v/, importantly: - -- - -- [Note: Breaks on constants and predetermined equality] - -- This function currently breaks if: - -- - -- * One or more subfields are constants. Constants might have been - -- inlined for the construction, instead of being a projection of the - -- target variable. - -- - -- * One or more subfields are determined to be equal and one is simply - -- swapped / replaced by the other. For example, say we have - -- `x :: (a, a)`. If GHC determines that both elements of the tuple will - -- always be the same, it might replace the (semantically equal to 'x') - -- construction of `y` with `(fst x, fst x)`. - -- - eqDat :: Term -> [Int] -> Term -> Bool - eqDat v fTrace (collectArgs -> (Data _, args)) = - and (zipWith (eqDat v) (map (:fTrace) [0..]) (Either.lefts args)) - eqDat v1 fTrace v2 = - case stripProjection (reverse fTrace) v1 v2 of - Just [] -> True - _ -> False - - stripProjection :: [Int] -> Term -> Term -> Maybe [Int] - stripProjection fTrace0 vTarget0 (Case v _ [(DataPat _ _ xs, r)]) = do - -- Get projection made in subject of case: - fTrace1 <- stripProjection fTrace0 vTarget0 v - - -- Extract projection of this case statement. Subsequent calls to - -- 'stripProjection' will check if new target is actually used. - n <- headMaybe fTrace1 - vTarget1 <- indexMaybe xs n - fTrace2 <- tailMaybe fTrace1 - - stripProjection fTrace2 (Var vTarget1) r - - stripProjection fTrace (Var sTarget) (Var s) = - if sTarget == s then Just fTrace else Nothing - - stripProjection _fTrace _vTarget _v = - Nothing - -recToLetRec _ e = return e - --- | Inline a function with functional arguments -inlineHO :: HasCallStack => NormRewrite -inlineHO (TransformContext is0 _) e@(App _ _) - | (Var f, args, ticks) <- collectArgsTicks e - = do - tcm <- Lens.view tcCache - let hasPolyFunArgs = or (map (either (isPolyFun tcm) (const False)) args) - if hasPolyFunArgs - then do (cf,_) <- Lens.use curFun - isInlined <- zoomExtra (alreadyInlined f cf) - limit <- Lens.use (extra.inlineLimit) - if (Maybe.fromMaybe 0 isInlined) > limit - then do - lvl <- Lens.view dbgLevel - traceIf (lvl > DebugNone) ($(curLoc) ++ "InlineHO: " ++ show f ++ " already inlined " ++ show limit ++ " times in:" ++ show cf) (return e) - else do - bodyMaybe <- lookupVarEnv f <$> Lens.use bindings - case bodyMaybe of - Just (_,_,_,body) -> do - zoomExtra (addNewInline f cf) - -- See Note [AppProp no-shadow invariant] - changed (mkApps (mkTicks (deShadowTerm is0 body) ticks) args) - _ -> return e - else return e - -inlineHO _ e = return e - --- | Simplified CSE, only works on let-bindings, works from top to bottom -simpleCSE :: HasCallStack => NormRewrite -simpleCSE (TransformContext is0 _) e@(Letrec binders body) = do - let is1 = extendInScopeSetList is0 (map fst binders) - let (reducedBindings,body') = reduceBindersFix is1 binders body - if length binders /= length reducedBindings - then changed (Letrec reducedBindings body') - else return e - -simpleCSE _ e = return e - -reduceBindersFix - :: InScopeSet - -> [LetBinding] - -> Term - -> ([LetBinding],Term) -reduceBindersFix is binders body = - if length binders /= length reduced - then reduceBindersFix is reduced body' - else (binders,body) - where - (reduced,body') = reduceBinders is [] body binders - -reduceBinders - :: InScopeSet - -> [LetBinding] - -> Term - -> [LetBinding] - -> ([LetBinding],Term) -reduceBinders _ processed body [] = (processed,body) -reduceBinders is processed body ((id_,expr):binders) = case List.find ((== expr) . snd) processed of - Just (id2,_) -> - let subst = extendIdSubst (mkSubst is) id_ (Var id2) - processed' = map (second (substTm "reduceBinders.processed" subst)) processed - binders' = map (second (substTm "reduceBinders.binders" subst)) binders - body' = substTm "reduceBinders.body" subst body - in reduceBinders is processed' body' binders' - Nothing -> reduceBinders is ((id_,expr):processed) body binders - -reduceConst :: HasCallStack => NormRewrite -reduceConst ctx@(TransformContext is0 _) e@(App _ _) - | (Prim nm0 _, _) <- collectArgs e - = do - tcm <- Lens.view tcCache - bndrs <- Lens.use bindings - primEval <- Lens.view evaluator - ids <- Lens.use uniqSupply - let (ids1,ids2) = splitSupply ids - uniqSupply Lens..= ids2 - gh <- Lens.use globalHeap - case whnf' primEval bndrs tcm gh ids1 is0 False e of - (gh',ph',e') -> do - globalHeap Lens..= gh' - bindPureHeap ctx tcm ph' $ \_ctx' -> case e' of - (collectArgs -> (Prim nm1 _, _)) | nm0 == nm1 -> return e - _ -> changed e' - -reduceConst _ e = return e - --- | Replace primitives by their "definition" if they would lead to let-bindings --- with a non-representable type when a function is in ANF. This happens for --- example when Clash.Size.Vector.map consumes or produces a vector of --- non-representable elements. --- --- Basically what this transformation does is replace a primitive the completely --- unrolled recursive definition that it represents. e.g. --- --- > zipWith ($) (xs :: Vec 2 (Int -> Int)) (ys :: Vec 2 Int) --- --- is replaced by: --- --- > let (x0 :: (Int -> Int)) = case xs of (:>) _ x xr -> x --- > (xr0 :: Vec 1 (Int -> Int)) = case xs of (:>) _ x xr -> xr --- > (x1 :: (Int -> Int)( = case xr0 of (:>) _ x xr -> x --- > (y0 :: Int) = case ys of (:>) _ y yr -> y --- > (yr0 :: Vec 1 Int) = case ys of (:>) _ y yr -> xr --- > (y1 :: Int = case yr0 of (:>) _ y yr -> y --- > in (($) x0 y0 :> ($) x1 y1 :> Nil) --- --- Currently, it only handles the following functions: --- --- * Clash.Sized.Vector.zipWith --- * Clash.Sized.Vector.map --- * Clash.Sized.Vector.traverse# --- * Clash.Sized.Vector.fold --- * Clash.Sized.Vector.foldr --- * Clash.Sized.Vector.dfold --- * Clash.Sized.Vector.(++) --- * Clash.Sized.Vector.head --- * Clash.Sized.Vector.tail --- * Clash.Sized.Vector.last --- * Clash.Sized.Vector.init --- * Clash.Sized.Vector.unconcat --- * Clash.Sized.Vector.transpose --- * Clash.Sized.Vector.replicate --- * Clash.Sized.Vector.replace_int --- * Clash.Sized.Vector.imap --- * Clash.Sized.Vector.dtfold --- * Clash.Sized.RTree.tdfold --- * Clash.Sized.RTree.treplicate --- * Clash.Sized.Internal.BitVector.split# --- * Clash.Sized.Internal.BitVector.eq# -reduceNonRepPrim :: HasCallStack => NormRewrite -reduceNonRepPrim c@(TransformContext is0 ctx) e@(App _ _) | (Prim nm _, args, ticks) <- collectArgsTicks e = do - tcm <- Lens.view tcCache - shouldReduce1 <- shouldReduce ctx - ultra <- Lens.use (extra.normalizeUltra) - let eTy = termType tcm e - case tyView eTy of - (TyConApp vecTcNm@(nameOcc -> "Clash.Sized.Vector.Vec") - [runExcept . tyNatSize tcm -> Right 0, aTy]) -> do - let (Just vecTc) = lookupUniqMap vecTcNm tcm - [nilCon,consCon] = tyConDataCons vecTc - nilE = mkVec nilCon consCon aTy 0 [] - changed (mkTicks nilE ticks) - tv -> case nm of - "Clash.Sized.Vector.zipWith" | length args == 7 -> do - let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTys <- mapM isUntranslatableType_not_poly [lhsElTy,rhsElty,resElTy] - if or untranslatableTys || shouldReduce1 || ultra || n < 2 - then let [fun,lhsArg,rhsArg] = Either.lefts args - in (`mkTicks` ticks) <$> - reduceZipWith c n lhsElTy rhsElty resElTy fun lhsArg rhsArg - else return e - _ -> return e - "Clash.Sized.Vector.map" | length args == 5 -> do - let [argElTy,resElTy,nTy] = Either.rights args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTys <- mapM isUntranslatableType_not_poly [argElTy,resElTy] - if or untranslatableTys || shouldReduce1 || ultra || n < 2 - then let [fun,arg] = Either.lefts args - in (`mkTicks` ticks) <$> reduceMap c n argElTy resElTy fun arg - else return e - _ -> return e - "Clash.Sized.Vector.traverse#" | length args == 7 -> - let [aTy,fTy,bTy,nTy] = Either.rights args - in case runExcept (tyNatSize tcm nTy) of - Right n -> - let [dict,fun,arg] = Either.lefts args - in (`mkTicks` ticks) <$> reduceTraverse c n aTy fTy bTy dict fun arg - _ -> return e - "Clash.Sized.Vector.fold" | length args == 4 -> do - let [aTy,nTy] = Either.rights args - isPow2 x = x /= 0 && (x .&. (complement x + 1)) == x - untranslatableTy <- isUntranslatableType_not_poly aTy - case runExcept (tyNatSize tcm nTy) of - Right n | not (isPow2 (n + 1)) || untranslatableTy || shouldReduce1 || ultra || n == 0 -> - let [fun,arg] = Either.lefts args - in (`mkTicks` ticks) <$> reduceFold c (n + 1) aTy fun arg - _ -> return e - "Clash.Sized.Vector.foldr" | length args == 6 -> - let [aTy,bTy,nTy] = Either.rights args - in case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTys <- mapM isUntranslatableType_not_poly [aTy,bTy] - if or untranslatableTys || shouldReduce1 || ultra - then let [fun,start,arg] = Either.lefts args - in (`mkTicks` ticks) <$> reduceFoldr c n aTy fun start arg - else return e - _ -> return e - "Clash.Sized.Vector.dfold" | length args == 8 -> - let ([_kn,_motive,fun,start,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args - in case runExcept (tyNatSize tcm nTy) of - Right n -> (`mkTicks` ticks) <$> reduceDFold is0 n aTy fun start arg - _ -> return e - "Clash.Sized.Vector.++" | length args == 5 -> - let [nTy,aTy,mTy] = Either.rights args - [lArg,rArg] = Either.lefts args - in case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of - (Right n, Right m) - | n == 0 -> changed rArg - | m == 0 -> changed lArg - | otherwise -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy || shouldReduce1 - then (`mkTicks` ticks) <$> reduceAppend is0 n m aTy lArg rArg - else return e - _ -> return e - "Clash.Sized.Vector.head" | length args == 3 -> do - let [nTy,aTy] = Either.rights args - [vArg] = Either.lefts args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy || shouldReduce1 - then (`mkTicks` ticks) <$> reduceHead is0 (n+1) aTy vArg - else return e - _ -> return e - "Clash.Sized.Vector.tail" | length args == 3 -> do - let [nTy,aTy] = Either.rights args - [vArg] = Either.lefts args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy || shouldReduce1 - then (`mkTicks` ticks) <$> reduceTail is0 (n+1) aTy vArg - else return e - _ -> return e - "Clash.Sized.Vector.last" | length args == 3 -> do - let [nTy,aTy] = Either.rights args - [vArg] = Either.lefts args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy || shouldReduce1 - then (`mkTicks` ticks) <$> reduceLast is0 (n+1) aTy vArg - else return e - _ -> return e - "Clash.Sized.Vector.init" | length args == 3 -> do - let [nTy,aTy] = Either.rights args - [vArg] = Either.lefts args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy || shouldReduce1 - then (`mkTicks` ticks) <$> reduceInit is0 (n+1) aTy vArg - else return e - _ -> return e - "Clash.Sized.Vector.unconcat" | length args == 6 -> do - let ([_knN,_sm,arg],[mTy,nTy,aTy]) = Either.partitionEithers args - case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of - (Right n, Right 0) -> (`mkTicks` ticks) <$> reduceUnconcat n 0 aTy arg - _ -> return e - "Clash.Sized.Vector.transpose" | length args == 5 -> do - let ([_knN,arg],[mTy,nTy,aTy]) = Either.partitionEithers args - case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of - (Right n, Right 0) -> (`mkTicks` ticks) <$> reduceTranspose n 0 aTy arg - _ -> return e - "Clash.Sized.Vector.replicate" | length args == 4 -> do - let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy || shouldReduce1 - then (`mkTicks` ticks) <$> reduceReplicate n aTy eTy vArg - else return e - _ -> return e - -- replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a - "Clash.Sized.Vector.replace_int" | length args == 6 -> do - let ([_knArg,vArg,iArg,aArg],[nTy,aTy]) = Either.partitionEithers args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy || shouldReduce1 || ultra - then (`mkTicks` ticks) <$> reduceReplace_int is0 n aTy eTy vArg iArg aArg - else return e - _ -> return e - - "Clash.Sized.Vector.index_int" | length args == 5 -> do - let ([_knArg,vArg,iArg],[nTy,aTy]) = Either.partitionEithers args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType_not_poly aTy - if untranslatableTy || shouldReduce1 || ultra - then (`mkTicks` ticks) <$> reduceIndex_int is0 n aTy vArg iArg - else return e - _ -> return e - - "Clash.Sized.Vector.imap" | length args == 6 -> do - let [nTy,argElTy,resElTy] = Either.rights args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTys <- mapM isUntranslatableType_not_poly [argElTy,resElTy] - if or untranslatableTys || shouldReduce1 || ultra || n < 2 - then let [_,fun,arg] = Either.lefts args - in (`mkTicks` ticks) <$> reduceImap c n argElTy resElTy fun arg - else return e - _ -> return e - "Clash.Sized.Vector.dtfold" | length args == 8 -> - let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args - in case runExcept (tyNatSize tcm nTy) of - Right n -> (`mkTicks` ticks) <$> reduceDTFold is0 n aTy lrFun brFun arg - _ -> return e - - "Clash.Sized.Vector.reverse" - | ultra - , ([vArg],[nTy,aTy]) <- Either.partitionEithers args - , Right n <- runExcept (tyNatSize tcm nTy) - -> (`mkTicks` ticks) <$> reduceReverse is0 n aTy vArg - - "Clash.Sized.RTree.tdfold" | length args == 8 -> - let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args - in case runExcept (tyNatSize tcm nTy) of - Right n -> (`mkTicks` ticks) <$> reduceTFold is0 n aTy lrFun brFun arg - _ -> return e - "Clash.Sized.RTree.treplicate" | length args == 4 -> do - let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args - case runExcept (tyNatSize tcm nTy) of - Right n -> do - untranslatableTy <- isUntranslatableType False aTy - if untranslatableTy || shouldReduce1 - then (`mkTicks` ticks) <$> reduceTReplicate n aTy eTy vArg - else return e - _ -> return e - "Clash.Sized.Internal.BitVector.split#" | length args == 4 -> do - let ([_knArg,bvArg],[nTy,mTy]) = Either.partitionEithers args - case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy), tv) of - (Right n, Right m, TyConApp tupTcNm [lTy,rTy]) - | n == 0 -> do - let (Just tupTc) = lookupUniqMap tupTcNm tcm - [tupDc] = tyConDataCons tupTc - tup = mkApps (Data tupDc) - [Right lTy - ,Right rTy - ,Left bvArg - ,Left (removedTm rTy) - ] - - changed (mkTicks tup ticks) - | m == 0 -> do - let (Just tupTc) = lookupUniqMap tupTcNm tcm - [tupDc] = tyConDataCons tupTc - tup = mkApps (Data tupDc) - [Right lTy - ,Right rTy - ,Left (removedTm lTy) - ,Left bvArg - ] - - changed (mkTicks tup ticks) - _ -> return e - "Clash.Sized.Internal.BitVector.eq#" - | ([_,_],[nTy]) <- Either.partitionEithers args - , Right 0 <- runExcept (tyNatSize tcm nTy) - , TyConApp boolTcNm [] <- tv - -> let (Just boolTc) = lookupUniqMap boolTcNm tcm - [_falseDc,trueDc] = tyConDataCons boolTc - in changed (mkTicks (Data trueDc) ticks) - _ -> return e - where - isUntranslatableType_not_poly t = do - u <- isUntranslatableType False t - if u - then return (null $ Lens.toListOf typeFreeVars t) - else return False - -reduceNonRepPrim _ e = return e - --- | This transformation lifts applications of global binders out of --- alternatives of case-statements. --- --- e.g. It converts: --- --- @ --- case x of --- A -> f 3 y --- B -> f x x --- C -> h x --- @ --- --- into: --- --- @ --- let f_arg0 = case x of {A -> 3; B -> x} --- f_arg1 = case x of {A -> y; B -> x} --- f_out = f f_arg0 f_arg1 --- in case x of --- A -> f_out --- B -> f_out --- C -> h x --- @ -disjointExpressionConsolidation :: HasCallStack => NormRewrite -disjointExpressionConsolidation ctx@(TransformContext is0 _) e@(Case _scrut _ty _alts@(_:_:_)) = do - (_,collected) <- collectGlobals is0 [] [] e - let disJoint = filter (isDisjoint . snd . snd) collected - if null disJoint - then return e - else do - exprs <- mapM (mkDisjointGroup is0) disJoint - tcm <- Lens.view tcCache - lids <- Monad.zipWithM (mkFunOut is0 tcm) disJoint exprs - let substitution = zip (map fst disJoint) (map Var lids) - subsMatrix = l2m substitution - (exprs',_) <- unzip <$> Monad.zipWithM - (\s (e',seen) -> collectGlobals is0 s seen e') - subsMatrix - exprs - (e',_) <- collectGlobals is0 substitution [] e - let lb = Letrec (zip lids exprs') e' - lb' <- bottomupR deadCode ctx lb - changed lb' - where - mkFunOut isN tcm (fun,_) (e',_) = do - let ty = termType tcm e' - nm = case collectArgs fun of - (Var v,_) -> nameOcc (varName v) - (Prim nm' _,_) -> nm' - _ -> "complex_expression_" - nm'' = last (Text.splitOn "." nm) `Text.append` "Out" - mkInternalVar isN nm'' ty - - l2m = go [] - where - go _ [] = [] - go xs (y:ys) = (xs ++ ys) : go (xs ++ [y]) ys - -disjointExpressionConsolidation _ e = return e - --- | Given a function in the desired normal form, inline all the following --- let-bindings: --- --- Let-bindings with an internal name that is only used once, where it binds: --- * a primitive that will be translated to an HDL expression (as opposed to --- a HDL declaration) --- * a projection case-expression (1 alternative) --- * a data constructor -inlineCleanup :: HasCallStack => NormRewrite -inlineCleanup (TransformContext is0 _) (Letrec binds body) = do - prims <- Lens.use (extra.primitives) - -- For all let-bindings, count the number of times they are referenced. - -- We only inline let-bindings which are referenced only once, otherwise - -- we would lose sharing. - -- let allOccs = List.foldl' (HashMap.unionWith (+)) HashMap.empty - -- $ map ( List.foldl' countOcc HashMap.empty - -- . Lens.toListOf termFreeIds . unembed . snd) binds - let is1 = extendInScopeSetList is0 (map fst binds) - let allOccs = List.foldl' (unionVarEnvWith (+)) emptyVarEnv - $ map (Lens.foldMapByOf freeLocalIds (unionVarEnvWith (+)) - emptyVarEnv (`unitVarEnv` 1) . snd) - binds - bodyFVs = Lens.foldMapOf freeLocalIds unitVarSet body - (il,keep) = List.partition (isInteresting allOccs prims bodyFVs) binds - keep' = inlineBndrs is1 keep il - if null il then return (Letrec binds body) - else changed (Letrec keep' body) - where - -- Determine whether a let-binding is interesting to inline - isInteresting - :: VarEnv Int - -> CompiledPrimMap - -> VarSet - -> (Id, Term) - -> Bool - isInteresting allOccs prims bodyFVs (id_,(fst.collectArgs) -> tm) - | nameSort (varName id_) /= User - , id_ `notElemVarSet` bodyFVs - = case tm of - Prim nm _ - | Just (extractPrim -> Just p@(BlackBox {})) <- HashMap.lookup nm prims - , TExpr <- kind p - , Just occ <- lookupVarEnv id_ allOccs - , occ < 2 - -> True - Case _ _ [_] -> True - Data _ -> True - _ -> False - | id_ `notElemVarSet` bodyFVs - = case tm of - Case _ _ [(DataPat dcE _ _,_)] - -> let nm = (nameOcc (dcName dcE)) - in -- Inlines WW projection that exposes internals of the BitVector types - nm == "Clash.Sized.Internal.BitVector.BV" || - nm == "Clash.Sized.Internal.BitVector.Bit" || - -- Inlines projections out of constraint-tuples (e.g. HiddenClockReset) - "GHC.Classes" `Text.isPrefixOf` nm - _ -> False - - isInteresting _ _ _ _ = False - - -- Inline let-bindings we want to inline into let-bindings we want to keep. - inlineBndrs - :: InScopeSet - -> [(Id, Term)] - -- let-bindings we keep - -> [(Id, Term)] - -- let-bindings we want to inline - -> [(Id, Term)] - inlineBndrs _ keep [] = keep - inlineBndrs isN keep ((v,e):il) = - let subst = extendIdSubst (mkSubst isN) v e - in if v `localIdOccursIn` e -- don't inline recursive binders - then inlineBndrs isN ((v,e):keep) il - else inlineBndrs isN - (map (second (substTm "inlineCleanup.inlineBndrs" subst)) keep) - (map (second (substTm "inlineCleanup.inlineBndrs" subst)) il) - -- We must not forget to inline the /current/ @to-inline@ let-binding into - -- the list of /remaining/ @to-inline@ let-bindings, because it might - -- only occur in /remaining/ @to-inline@ bindings. If we don't, we would - -- introduce free variables, because the @to-inline@ bindings are removed. - -inlineCleanup _ e = return e - --- | Flatten's letrecs after `inlineCleanup` --- --- `inlineCleanup` sometimes exposes additional possibilities for `caseCon`, --- which then introduces let-bindings in what should be ANF. This transformation --- flattens those nested let-bindings again. --- --- NB: must only be called in the cleaning up phase. -flattenLet :: HasCallStack => NormRewrite -flattenLet (TransformContext is0 _) letrec@(Letrec _ _) = do - let (is2, Letrec binds body) = freshenTm is0 letrec - bodyOccs = Lens.foldMapByOf - freeLocalIds (unionVarEnvWith (+)) - emptyVarEnv (`unitVarEnv` (1 :: Int)) - body - binds' <- concat <$> mapM (go is2) binds - case binds' of - -- inline binders into the body when there's only a single binder, and only - -- if that binder doesn't perform any work or is only used once in the body - [(id',e')] | Just occ <- lookupVarEnv id' bodyOccs, isWorkFree e' || occ < 2 -> - if id' `localIdOccursIn` e' - -- Except when the binder is recursive! - then return (Letrec binds' body) - else let subst = extendIdSubst (mkSubst is2) id' e' - in changed (substTm "flattenLet" subst body) - _ -> return (Letrec binds' body) - where - go :: InScopeSet -> LetBinding -> NormalizeSession [LetBinding] - go isN (id_,collectTicks -> (Letrec binds' body',ticks)) = do - let bodyOccs = Lens.foldMapByOf - freeLocalIds (unionVarEnvWith (+)) - emptyVarEnv (`unitVarEnv` (1 :: Int)) - body' - (srcTicks,nmTicks) = partitionTicks ticks - -- Distribute the name ticks of the let-expression over all the bindings - map (second (`mkTicks` nmTicks)) <$> case binds' of - -- inline binders into the body when there's only a single binder, and - -- only if that binder doesn't perform any work or is only used once in - -- the body - [(id',e')] | Just occ <- lookupVarEnv id' bodyOccs, isWorkFree e' || occ < 2 -> - if id' `localIdOccursIn` e' - -- Except when the binder is recursive! - then changed [(id',e'),(id_, body')] - else let subst = extendIdSubst (mkSubst isN) id' e' - in changed [(id_ - -- Only apply srcTicks to the body - ,mkTicks (substTm "flattenLetGo" subst body') - srcTicks)] - bs -> changed (bs ++ [(id_ - -- Only apply srcTicks to the body - ,mkTicks body' srcTicks)]) - go _ b = return [b] - -flattenLet _ e = return e +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Clash.Normalize.Transformations + ( caseLet + , caseCon + , caseCase + , caseElemNonReachable + , elemExistentials + , inlineNonRep + , inlineOrLiftNonRep + , typeSpec + , nonRepSpec + , etaExpansionTL + , nonRepANF + , bindConstantVar + , constantSpec + , makeANF + , deadCode + , topLet + , recToLetRec + , inlineWorkFree + , inlineHO + , inlineSmall + , simpleCSE + , reduceConst + , reduceNonRepPrim + , caseFlat + , disjointExpressionConsolidation + , removeUnusedExpr + , inlineCleanup + , flattenLet + , splitCastWork + , inlineCast + , caseCast + , letCast + , eliminateCastCast + , argCastSpec + , etaExpandSyn + , appPropFast + , separateArguments + , separateLambda + , xOptimize + ) +where + +import Control.Exception (throw) +import Control.Lens (_2) +import qualified Control.Lens as Lens +import qualified Control.Monad as Monad +import Control.Monad.State (StateT (..), modify) +import Control.Monad.State.Strict (evalState) +import Control.Monad.Writer (lift, listen) +import Control.Monad.Trans.Except (runExcept) +import Data.Coerce (coerce) +import qualified Data.Either as Either +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.HashMap.Strict as HashMapS +import qualified Data.List as List +import Data.List ((\\)) +import qualified Data.Maybe as Maybe +import qualified Data.Monoid as Monoid +import qualified Data.Primitive.ByteArray as BA +import qualified Data.Text as Text +import qualified Data.Vector.Primitive as PV +import Debug.Trace +import GHC.Integer.GMP.Internals (Integer (..), BigNat (..)) + +import BasicTypes (InlineSpec (..)) + +import Clash.Annotations.Primitive (extractPrim) +import Clash.Core.DataCon (DataCon (..)) +import Clash.Core.Name + (Name (..), NameSort (..), mkUnsafeSystemName, nameOcc) +import Clash.Core.FreeVars + (localIdOccursIn, localIdsDoNotOccurIn, freeLocalIds, termFreeTyVars, + typeFreeVars, localVarsDoNotOccurIn, localIdDoesNotOccurIn, + countFreeOccurances) +import Clash.Core.Literal (Literal (..)) +import Clash.Core.Pretty (showPpr) +import Clash.Core.Subst + (Subst, substTm, mkSubst, extendIdSubst, extendIdSubstList, extendTvSubst, + extendTvSubstList, freshenTm, substTyInVar, deShadowTerm, deShadowAlt, + deshadowLetExpr) +import Clash.Core.Term + ( LetBinding, Pat (..), Term (..), CoreContext (..), PrimInfo (..) + , TickInfo(..) , WorkInfo(WorkConstant), Alt, TickInfo + , isLambdaBodyCtx, isTickCtx, collectArgs + , collectArgsTicks, collectTicks , partitionTicks + ) +import Clash.Core.Type (Type (..), TypeView (..), applyFunTy, + isPolyFunCoreTy, isClassTy, + normalizeType, splitFunForallTy, + splitFunTy, + tyView, mkPolyFunTy, coreView, + LitTy (..), coreView1) +import Clash.Core.TyCon (TyConMap, tyConDataCons) +import Clash.Core.Util + (isCon, isFun, isLet, isPolyFun, isPrim, + isSignalType, isVar, mkApps, mkLams, mkVec, piResultTy, termSize, termType, + tyNatSize, patVars, isAbsurdAlt, altEqs, substInExistentialsList, + solveNonAbsurds, patIds, isLocalVar, undefinedTm, stripTicks, mkTicks, + shouldSplit, inverseTopSortLetBindings) +import Clash.Core.Var + (Id, TyVar, Var (..), isGlobalId, isLocalId, mkLocalId) +import Clash.Core.VarEnv + (InScopeSet, VarEnv, VarSet, elemVarSet, + emptyVarEnv, extendInScopeSet, extendInScopeSetList, lookupVarEnv, + notElemVarSet, unionVarEnvWith, unionInScope, unitVarEnv, + unitVarSet, mkVarSet, mkInScopeSet, uniqAway, elemInScopeSet, elemVarEnv, + foldlWithUniqueVarEnv', lookupVarEnvDirectly, extendVarEnv, unionVarEnv, + eltsVarEnv, mkVarEnv, eltsVarSet) +import Clash.Driver.Types (Binding(..), DebugLevel (..)) +import Clash.Netlist.BlackBox.Types (Element(Err)) +import Clash.Netlist.BlackBox.Util (getUsedArguments) +import Clash.Netlist.Types (BlackBox(..), HWType (..), FilteredHWType(..)) +import Clash.Netlist.Util + (coreTypeToHWType, representableType, splitNormalized, bindsExistentials) +import Clash.Normalize.DEC +import Clash.Normalize.PrimitiveReductions +import Clash.Normalize.Types +import Clash.Normalize.Util +import Clash.Primitives.Types + (Primitive(..), TemplateKind(TExpr), CompiledPrimMap, UsedArguments(..)) +import Clash.Rewrite.Combinators +import Clash.Rewrite.Types +import Clash.Rewrite.Util +import Clash.Unique (Unique, lookupUniqMap) +import Clash.Util + +inlineOrLiftNonRep :: HasCallStack => NormRewrite +inlineOrLiftNonRep ctx eLet@(Letrec _ body) = + inlineOrLiftBinders nonRepTest inlineTest ctx eLet + where + bodyFreeOccs = countFreeOccurances body + + nonRepTest :: (Id, Term) -> RewriteMonad extra Bool + nonRepTest (Id {varType = ty}, _) + = not <$> (representableType <$> Lens.view typeTranslator + <*> Lens.view customReprs + <*> pure False + <*> Lens.view tcCache + <*> pure ty) + nonRepTest _ = return False + + inlineTest :: Term -> (Id, Term) -> Bool + inlineTest e (id_, e') = + -- We do __NOT__ inline: + not $ or + [ -- 1. recursive let-binders + -- id_ `localIdOccursIn` e' -- <= already checked in inlineOrLiftBinders + -- 2. join points (which are not void-wrappers) + isJoinPointIn id_ e && not (isVoidWrapper e') + -- 3. binders that are used more than once in the body, because + -- it makes CSE a whole lot more difficult. + -- + -- XXX: Check whether we can extend this to the binders as well + , maybe False (>1) (lookupVarEnv id_ bodyFreeOccs) + ] + +inlineOrLiftNonRep _ e = return e +{-# SCC inlineOrLiftNonRep #-} + +{- [Note] join points and void wrappers +Join points are functions that only occur in tail-call positions within an +expression, and only when they occur in a tail-call position more than once. + +Normally bindNonRep binds/inlines all non-recursive local functions. However, +doing so for join points would significantly increase compilation time, so we +avoid it. The only exception to this rule are so-called void wrappers. Void +wrappers are functions of the form: + +> \(w :: Void) -> f a b c + +i.e. a wrapper around the function 'f' where the argument 'w' is not used. We +do bind/line these join-points because these void-wrappers interfere with the +'disjoint expression consolidation' (DEC) and 'common sub-expression elimination' +(CSE) transformation, sometimes resulting in circuits that are twice as big +as they'd need to be. +-} + +-- | Specialize functions on their type +typeSpec :: HasCallStack => NormRewrite +typeSpec ctx e@(TyApp e1 ty) + | (Var {}, args) <- collectArgs e1 + , null $ Lens.toListOf typeFreeVars ty + , (_, []) <- Either.partitionEithers args + = specializeNorm ctx e + +typeSpec _ e = return e +{-# SCC typeSpec #-} + +-- | Specialize functions on their non-representable argument +nonRepSpec :: HasCallStack => NormRewrite +nonRepSpec ctx e@(App e1 e2) + | (Var {}, args) <- collectArgs e1 + , (_, []) <- Either.partitionEithers args + , null $ Lens.toListOf termFreeTyVars e2 + = do tcm <- Lens.view tcCache + let e2Ty = termType tcm e2 + let localVar = isLocalVar e2 + nonRepE2 <- not <$> (representableType <$> Lens.view typeTranslator + <*> Lens.view customReprs + <*> pure False + <*> Lens.view tcCache + <*> pure e2Ty) + if nonRepE2 && not localVar + then do + e2' <- inlineInternalSpecialisationArgument e2 + specializeNorm ctx (App e1 e2') + else return e + where + -- | If the argument on which we're specialising ia an internal function, + -- one created by the compiler, then inline that function before we + -- specialise. + -- + -- We need to do this because otherwise the specialisation history won't + -- recognize the new specialisation argument as something the function has + -- already been specialized on + inlineInternalSpecialisationArgument + :: Term + -> NormalizeSession Term + inlineInternalSpecialisationArgument app + | (Var f,fArgs,ticks) <- collectArgsTicks app + = do + fTmM <- lookupVarEnv f <$> Lens.use bindings + case fTmM of + Just b + | nameSort (varName (bindingId b)) == Internal + -> censor (const mempty) + (topdownR appPropFast ctx + (mkApps (mkTicks (bindingTerm b) ticks) fArgs)) + _ -> return app + | otherwise = return app + +nonRepSpec _ e = return e +{-# SCC nonRepSpec #-} + +-- | Lift the let-bindings out of the subject of a Case-decomposition +caseLet :: HasCallStack => NormRewrite +caseLet (TransformContext is0 _) (Case (collectTicks -> (Letrec xes e,ticks)) ty alts) = do + -- Note [CaseLet deshadow] + -- Imagine + -- + -- @ + -- case (let x = u in e) of {p -> a} + -- @ + -- + -- where `a` has a free variable named `x`. + -- + -- Simply transforming the above to: + -- + -- @ + -- let x = u in case e of {p -> a} + -- @ + -- + -- would be very bad, because now the let-binding captures the free x variable + -- in a. + -- + -- We must therefor rename `x` so that it doesn't capture the free variables + -- in the alternative: + -- + -- @ + -- let x1 = u[x:=x1] in case e[x:=x1] of {p -> a} + -- @ + -- + -- It is safe to over-approximate the free variables in `a` by simply taking + -- the current InScopeSet. + let (xes1,e1) = deshadowLetExpr is0 xes e + changed (Letrec (map (second (`mkTicks` ticks)) xes1) + (Case (mkTicks e1 ticks) ty alts)) + +caseLet _ e = return e +{-# SCC caseLet #-} + +-- | Remove non-reachable alternatives. For example, consider: +-- +-- data STy ty where +-- SInt :: Int -> STy Int +-- SBool :: Bool -> STy Bool +-- +-- f :: STy ty -> ty +-- f (SInt b) = b + 1 +-- f (SBool True) = False +-- f (SBool False) = True +-- {-# NOINLINE f #-} +-- +-- g :: STy Int -> Int +-- g = f +-- +-- @f@ is always specialized on @STy Int@. The SBool alternatives are therefore +-- unreachable. Additional information can be found at: +-- https://github.com/clash-lang/clash-compiler/pull/465 +caseElemNonReachable :: HasCallStack => NormRewrite +caseElemNonReachable _ case0@(Case scrut altsTy alts0) = do + tcm <- Lens.view tcCache + + let (altsAbsurd, altsOther) = List.partition (isAbsurdAlt tcm) alts0 + case altsAbsurd of + [] -> return case0 + _ -> changed =<< caseOneAlt (Case scrut altsTy altsOther) + +caseElemNonReachable _ e = return e +{-# SCC caseElemNonReachable #-} + +-- | Tries to eliminate existentials by using heuristics to determine what the +-- existential should be. For example, consider Vec: +-- +-- data Vec :: Nat -> Type -> Type where +-- Nil :: Vec 0 a +-- Cons x xs :: a -> Vec n a -> Vec (n + 1) a +-- +-- Thus, 'null' (annotated with existentials) could look like: +-- +-- null :: forall n . Vec n Bool -> Bool +-- null v = +-- case v of +-- Nil {n ~ 0} -> True +-- Cons {n1:Nat} {n~n1+1} (x :: a) (xs :: Vec n1 a) -> False +-- +-- When it's applied to a vector of length 5, this becomes: +-- +-- null :: Vec 5 Bool -> Bool +-- null v = +-- case v of +-- Nil {5 ~ 0} -> True +-- Cons {n1:Nat} {5~n1+1} (x :: a) (xs :: Vec n1 a) -> False +-- +-- This function solves 'n1' and replaces every occurrence with its solution. A +-- very limited number of solutions are currently recognized: only adds (such +-- as in the example) will be solved. +elemExistentials :: HasCallStack => NormRewrite +elemExistentials (TransformContext is0 _) (Case scrut altsTy alts0) = do + tcm <- Lens.view tcCache + + alts1 <- mapM (go is0 tcm) alts0 + caseOneAlt (Case scrut altsTy alts1) + + where + -- Eliminate free type variables if possible + go :: InScopeSet -> TyConMap -> (Pat, Term) -> NormalizeSession (Pat, Term) + go is2 tcm alt@(DataPat dc exts0 xs0, term0) = + case solveNonAbsurds tcm (altEqs tcm alt) of + -- No equations solved: + [] -> return alt + -- One or more equations solved: + sols -> + changed =<< go is2 tcm (DataPat dc exts1 xs1, term1) + where + -- Substitute solution in existentials and applied types + is3 = extendInScopeSetList is2 exts0 + xs1 = map (substTyInVar (extendTvSubstList (mkSubst is3) sols)) xs0 + exts1 = substInExistentialsList is2 exts0 sols + + -- Substitute solution in term. + is4 = extendInScopeSetList is3 xs1 + subst = extendTvSubstList (mkSubst is4) sols + term1 = substTm "Replacing tyVar due to solved eq" subst term0 + + go _ _ alt = return alt + +elemExistentials _ e = return e +{-# SCC elemExistentials #-} + +-- | Move a Case-decomposition from the subject of a Case-decomposition to the alternatives +caseCase :: HasCallStack => NormRewrite +caseCase (TransformContext is0 _) e@(Case (stripTicks -> Case scrut alts1Ty alts1) alts2Ty alts2) + = do + ty1Rep <- representableType <$> Lens.view typeTranslator + <*> Lens.view customReprs + <*> pure False + <*> Lens.view tcCache + <*> pure alts1Ty + if not ty1Rep + -- Deshadow to prevent accidental capture of free variables of inner + -- case. Imagine: + -- + -- case (case a of {x -> x}) of {_ -> x} + -- + -- 'x' is introduced the inner 'case' and used (as a free variable) in + -- the outer one. The goal of 'caseCase' is to rewrite cases such that + -- their subjects aren't cases. This is achieved by 'pushing' the outer + -- case to all the alternatives of the inner one. Naively doing so in + -- this example would cause an accidental capture: + -- + -- case a of {x -> case x of {_ -> x}} + -- + -- Suddenly, the 'x' in the alternative of the inner case statement + -- refers to the one introduced by the outer one, instead of being a + -- free variable. To prevent this, we deshadow the alternatives of the + -- original inner case. We now end up with: + -- + -- case a of {x1 -> case x1 of {_ -> x}} + -- + then let newAlts = map + (second (\altE -> Case altE alts2Ty alts2)) + (map (deShadowAlt is0) alts1) + in changed $ Case scrut alts2Ty newAlts + else return e + +caseCase _ e = return e +{-# SCC caseCase #-} + +-- | Inline function with a non-representable result if it's the subject +-- of a Case-decomposition +inlineNonRep :: HasCallStack => NormRewrite +inlineNonRep _ e@(Case scrut altsTy alts) + | (Var f, args,ticks) <- collectArgsTicks scrut + , isGlobalId f + = do + (cf,_) <- Lens.use curFun + isInlined <- zoomExtra (alreadyInlined f cf) + limit <- Lens.use (extra.inlineLimit) + tcm <- Lens.view tcCache + let scrutTy = termType tcm scrut + noException = not (exception tcm scrutTy) + if noException && (Maybe.fromMaybe 0 isInlined) > limit + then + trace (concat [ $(curLoc) ++ "InlineNonRep: " ++ showPpr (varName f) + ," already inlined " ++ show limit ++ " times in:" + , showPpr (varName cf) + , "\nType of the subject is: " ++ showPpr scrutTy + , "\nFunction " ++ showPpr (varName cf) + , " will not reach a normal form, and compilation" + , " might fail." + , "\nRun with '-fclash-inline-limit=N' to increase" + , " the inlining limit to N." + ]) + (return e) + else do + bodyMaybe <- lookupVarEnv f <$> Lens.use bindings + nonRepScrut <- not <$> (representableType <$> Lens.view typeTranslator + <*> Lens.view customReprs + <*> pure False + <*> Lens.view tcCache + <*> pure scrutTy) + case (nonRepScrut, bodyMaybe) of + (True,Just b) -> do + Monad.when noException (zoomExtra (addNewInline f cf)) + + let scrutBody0 = mkTicks (bindingTerm b) (mkInlineTick f : ticks) + let scrutBody1 = mkApps scrutBody0 args + + changed $ Case scrutBody1 altsTy alts + + _ -> return e + where + exception = isClassTy + +inlineNonRep _ e = return e +{-# SCC inlineNonRep #-} + +-- | Specialize a Case-decomposition (replace by the RHS of an alternative) if +-- the subject is (an application of) a DataCon; or if there is only a single +-- alternative that doesn't reference variables bound by the pattern. +-- +-- Note [CaseCon deshadow] +-- +-- Imagine: +-- +-- @ +-- case D (f a b) (g x y) of +-- D a b -> h a +-- @ +-- +-- rewriting this to: +-- +-- @ +-- let a = f a b +-- in h a +-- @ +-- +-- is very bad because the newly introduced let-binding now captures the free +-- variable 'a' in 'f a b'. +-- +-- instead me must rewrite to: +-- +-- @ +-- let a1 = f a b +-- in h a1 +-- @ +caseCon :: HasCallStack => NormRewrite +caseCon ctx@(TransformContext is0 _) e@(Case subj ty alts) = do + tcm <- Lens.view tcCache + case collectArgsTicks subj of + -- The subject is an applied data constructor + (Data dc, args, ticks) -> case List.find (equalCon . fst) alts of + Just (DataPat _ tvs xs, altE) -> do + let is1 = extendInScopeSetList (extendInScopeSetList is0 tvs) xs + let fvs = Lens.foldMapOf freeLocalIds unitVarSet altE + (binds,_) = List.partition ((`elemVarSet` fvs) . fst) + $ zip xs (Either.lefts args) + binds1 = map (second (`mkTicks` ticks)) binds + altE1 = case binds1 of + [] -> altE + _ -> + -- See Note [CaseCon deshadow] + let + ((is3,substIds),binds2) = List.mapAccumL newBinder (is1,[]) binds1 + subst = extendIdSubstList (mkSubst is3) substIds + body = substTm "caseCon0" subst altE + in + case Maybe.catMaybes binds2 of + [] -> body + binds3 -> Letrec binds3 body + -- Use the original inScopeSet 'is0' here, not the extended inScopeSet + -- 'is1', otherwise we'd make the "caseCon1" substitution substitute + -- free variables that were shadowed by the pattern! + let subst = extendTvSubstList (mkSubst is0) + $ zip tvs (drop (length (dcUnivTyVars dc)) (Either.rights args)) + changed (substTm "caseCon1" subst altE1) + _ -> case alts of + -- In Core, default patterns always come first, so we match against + -- that if there is one, and we couldn't match with any of the data + -- patterns. + ((DefaultPat,altE):_) -> changed altE + _ -> changed (undefinedTm ty) + where + -- Check whether the pattern matches the data constructor + equalCon (DataPat dcPat _ _) = dcTag dc == dcTag dcPat + equalCon _ = False + + -- Decide whether the applied arguments of the data constructor should + -- be let-bound, or substituted into the alternative. We decide this + -- based on the fact on whether the argument has the potential to make + -- the circuit larger than needed if we were to duplicate that argument. + newBinder (isN0,substN) (x,arg) + | isWorkFree arg + = ((isN0,(x,arg):substN),Nothing) + | otherwise + = let x' = uniqAway isN0 x + isN1 = extendInScopeSet isN0 x' + in ((isN1,(x,Var x'):substN),Just (x',arg)) + + + -- The subject is a literal + (Literal l,_,_) -> case List.find (equalLit . fst) alts of + Just (LitPat _,altE) -> changed altE + _ -> matchLiteralContructor e l alts + where + equalLit (LitPat l') = l == l' + equalLit _ = False + + + -- The subject is an applied primitive + (Prim _,_,_) -> + -- We try to reduce the applied primitive to WHNF + whnfRW True ctx subj $ \ctx1 subj1 -> case collectArgsTicks subj1 of + -- WHNF of subject is a literal, try `caseCon` with that + (Literal l,_,_) -> caseCon ctx1 (Case (Literal l) ty alts) + -- WHNF of subject is a data-constructor, try `caseCon` with that + (Data _,_,_) -> caseCon ctx1 (Case subj1 ty alts) +#if MIN_VERSION_ghc(8,2,2) + -- WHNF of subject is _|_, in the form of `absentError`: that means that + -- the entire case-expression is evaluates to _|_ + (Prim pInfo,_:msgOrCallStack:_,ticks) + | primName pInfo == "Control.Exception.Base.absentError" -> + let e1 = mkApps (mkTicks (Prim pInfo) ticks) + [Right ty,msgOrCallStack] + in changed e1 +#endif + -- WHNF of subject is _|_, in the form of `absentError`, `patError`, + -- or `undefined`: that means the entire case-expression is _|_ + (Prim pInfo,repTy:_:msgOrCallStack:_,ticks) + | primName pInfo `elem` ["Control.Exception.Base.patError" +#if !MIN_VERSION_ghc(8,2,2) + ,"Control.Exception.Base.absentError" +#endif + ,"GHC.Err.undefined"] -> + let e1 = mkApps (mkTicks (Prim pInfo) ticks) + [repTy,Right ty,msgOrCallStack] + in changed e1 + -- WHNF of subject is _|_, in the form of our internal _|_-values: that + -- means the entire case-expression is _|_ + (Prim pInfo,[_],ticks) + | primName pInfo `elem` [ "Clash.Transformations.undefined" + , "Clash.GHC.Evaluator.undefined" + , "EmptyCase"] -> + let e1 = mkApps (mkTicks (Prim pInfo) ticks) [Right ty] + in changed e1 + -- WHNF of subject is non of the above, so either a variable reference, + -- or a primitive for which the evaluator doesn't have any evaluation + -- rules. + _ -> do + let subjTy = termType tcm subj + tran <- Lens.view typeTranslator + reprs <- Lens.view customReprs + case (`evalState` HashMapS.empty) (coreTypeToHWType tran reprs tcm subjTy) of + Right (FilteredHWType (Void (Just hty)) _areVoids) + | hty `elem` [BitVector 0, Unsigned 0, Signed 0, Index 1] + -- If we know that the type of the subject is zero-bits wide and + -- one of the Clash number types. Then the only valid alternative is + -- the one that can match on the literal "0", so try 'caseCon' with + -- that. + -> caseCon ctx1 (Case (Literal (IntegerLiteral 0)) ty alts) + _ -> do + let ret = caseOneAlt e + -- Otherwise check whether the entire case-expression has a single + -- alternative, and pick that one. + lvl <- Lens.view dbgLevel + if lvl > DebugNone then do + let subjIsConst = isConstant subj + -- In debug mode we always report missing evaluation rules for the + -- primitive evaluator + traceIf (lvl > DebugNone && subjIsConst) + ("Irreducible constant as case subject: " ++ showPpr subj ++ + "\nCan be reduced to: " ++ showPpr subj1) ret + else + ret + + + -- The subject is a variable + (Var v, [], _) | isNum0 (varType v) -> + -- If we know that the type of the subject is zero-bits wide and + -- one of the Clash number types. Then the only valid alternative is + -- the one that can match on the literal "0", so try 'caseCon' with + -- that. + caseCon ctx (Case (Literal (IntegerLiteral 0)) ty alts) + where + isNum0 (tyView -> TyConApp (nameOcc -> tcNm) [arg]) + | tcNm `elem` + ["Clash.Sized.Internal.BitVector.BitVector" + ,"Clash.Sized.Internal.Unsigned.Unsigned" + ,"Clash.Sized.Internal.Signed.Signed" + ] + = isLitX 0 arg + | tcNm == + "Clash.Sized.Internal.Index.Index" + = isLitX 1 arg + isNum0 (coreView1 tcm -> Just t) = isNum0 t + isNum0 _ = False + + isLitX n (LitTy (NumTy m)) = n == m + isLitX n (coreView1 tcm -> Just t) = isLitX n t + isLitX _ _ = False + + -- Otherwise check whether the entire case-expression has a single + -- alternative, and pick that one. + _ -> caseOneAlt e + +caseCon _ e = return e +{-# SCC caseCon #-} + +{- [Note: Name re-creation] +The names of heap bound variables are safely generate with mkUniqSystemId in Clash.Core.Evaluator.newLetBinding. +But only their uniqs end up in the heap, not the complete names. +So we use mkUnsafeSystemName to recreate the same Name. +-} + +matchLiteralContructor + :: Term + -> Literal + -> [(Pat,Term)] + -> NormalizeSession Term +matchLiteralContructor c (IntegerLiteral l) alts = go (reverse alts) + where + go [(DefaultPat,e)] = changed e + go ((DataPat dc [] xs,e):alts') + | dcTag dc == 1 + , l >= ((-2)^(63::Int)) && l < 2^(63::Int) + = let fvs = Lens.foldMapOf freeLocalIds unitVarSet e + (binds,_) = List.partition ((`elemVarSet` fvs) . fst) + $ zip xs [Literal (IntLiteral l)] + e' = case binds of + [] -> e + _ -> Letrec binds e + in changed e' + | dcTag dc == 2 + , l >= 2^(63::Int) + = let !(Jp# !(BN# ba)) = l + ba' = BA.ByteArray ba + bv = PV.Vector 0 (BA.sizeofByteArray ba') ba' + fvs = Lens.foldMapOf freeLocalIds unitVarSet e + (binds,_) = List.partition ((`elemVarSet` fvs) . fst) + $ zip xs [Literal (ByteArrayLiteral bv)] + e' = case binds of + [] -> e + _ -> Letrec binds e + in changed e' + | dcTag dc == 3 + , l < ((-2)^(63::Int)) + = let !(Jn# !(BN# ba)) = l + ba' = BA.ByteArray ba + bv = PV.Vector 0 (BA.sizeofByteArray ba') ba' + fvs = Lens.foldMapOf freeLocalIds unitVarSet e + (binds,_) = List.partition ((`elemVarSet` fvs) . fst) + $ zip xs [Literal (ByteArrayLiteral bv)] + e' = case binds of + [] -> e + _ -> Letrec binds e + in changed e' + | otherwise + = go alts' + go ((LitPat l', e):alts') + | IntegerLiteral l == l' + = changed e + | otherwise + = go alts' + go _ = error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showPpr c + +matchLiteralContructor c (NaturalLiteral l) alts = go (reverse alts) + where + go [(DefaultPat,e)] = changed e + go ((DataPat dc [] xs,e):alts') + | dcTag dc == 1 + , l >= 0 && l < 2^(64::Int) + = let fvs = Lens.foldMapOf freeLocalIds unitVarSet e + (binds,_) = List.partition ((`elemVarSet` fvs) . fst) + $ zip xs [Literal (WordLiteral l)] + e' = case binds of + [] -> e + _ -> Letrec binds e + in changed e' + | dcTag dc == 2 + , l >= 2^(64::Int) + = let !(Jp# !(BN# ba)) = l + ba' = BA.ByteArray ba + bv = PV.Vector 0 (BA.sizeofByteArray ba') ba' + fvs = Lens.foldMapOf freeLocalIds unitVarSet e + (binds,_) = List.partition ((`elemVarSet` fvs) . fst) + $ zip xs [Literal (ByteArrayLiteral bv)] + e' = case binds of + [] -> e + _ -> Letrec binds e + in changed e' + | otherwise + = go alts' + go ((LitPat l', e):alts') + | NaturalLiteral l == l' + = changed e + | otherwise + = go alts' + go _ = error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showPpr c + +matchLiteralContructor _ _ ((DefaultPat,e):_) = changed e +matchLiteralContructor c _ _ = + error $ $(curLoc) ++ "Report as bug: caseCon error: " ++ showPpr c +{-# SCC matchLiteralContructor #-} + +caseOneAlt :: Term -> RewriteMonad extra Term +caseOneAlt e@(Case _ _ [(pat,altE)]) = case pat of + DefaultPat -> changed altE + LitPat _ -> changed altE + DataPat _ tvs xs + | (coerce tvs ++ coerce xs) `localVarsDoNotOccurIn` altE + -> changed altE + | otherwise + -> return e + +caseOneAlt (Case _ _ alts@((_,alt):_:_)) + | all ((== alt) . snd) (tail alts) + = changed alt + +caseOneAlt e = return e +{-# SCC caseOneAlt #-} + +-- | Bring an application of a DataCon or Primitive in ANF, when the argument is +-- is considered non-representable +nonRepANF :: HasCallStack => NormRewrite +nonRepANF ctx@(TransformContext is0 _) e@(App appConPrim arg) + | (conPrim, _) <- collectArgs e + , isCon conPrim || isPrim conPrim + = do + untranslatable <- isUntranslatable False arg + case (untranslatable,stripTicks arg) of + (True,Letrec binds body) -> + -- This is a situation similar to Note [CaseLet deshadow] + let (binds1,body1) = deshadowLetExpr is0 binds body + in changed (Letrec binds1 (App appConPrim body1)) + (True,Case {}) -> specializeNorm ctx e + (True,Lam {}) -> specializeNorm ctx e + (True,TyLam {}) -> specializeNorm ctx e + _ -> return e + +nonRepANF _ e = return e +{-# SCC nonRepANF #-} + +-- | Ensure that top-level lambda's eventually bind a let-expression of which +-- the body is a variable-reference. +topLet :: HasCallStack => NormRewrite +topLet (TransformContext is0 ctx) e + | all (\c -> isLambdaBodyCtx c || isTickCtx c) ctx && not (isLet e) && not (isTick e) + = do + untranslatable <- isUntranslatable False e + if untranslatable + then return e + else do tcm <- Lens.view tcCache + argId <- mkTmBinderFor is0 tcm (mkUnsafeSystemName "result" 0) e + changed (Letrec [(argId, e)] (Var argId)) + where + isTick Tick{} = True + isTick _ = False + +topLet (TransformContext is0 ctx) e@(Letrec binds body) + | all (\c -> isLambdaBodyCtx c || isTickCtx c) ctx + = do + let localVar = isLocalVar body + untranslatable <- isUntranslatable False body + if localVar || untranslatable + then return e + else do + tcm <- Lens.view tcCache + let is2 = extendInScopeSetList is0 (map fst binds) + argId <- mkTmBinderFor is2 tcm (mkUnsafeSystemName "result" 0) body + changed (Letrec (binds ++ [(argId,body)]) (Var argId)) + +topLet _ e = return e +{-# SCC topLet #-} + +-- Misc rewrites + +-- | Remove unused let-bindings +deadCode :: HasCallStack => NormRewrite +deadCode _ e@(Letrec binds body) = do + let bodyFVs = Lens.foldMapOf freeLocalIds unitVarSet body + used = List.foldl' collectUsed emptyVarEnv (eltsVarSet bodyFVs) + case eltsVarEnv used of + [] -> changed body + qqL | neLength qqL binds + -> changed (Letrec qqL body) + | otherwise + -> return e + where + bindsEnv = mkVarEnv (map (\(x,e0) -> (x,(x,e0))) binds) + + collectUsed env v = + if v `elemVarEnv` env then + env + else + case lookupVarEnv v bindsEnv of + Just (x,e0) -> + let eFVs = Lens.foldMapOf freeLocalIds unitVarSet e0 + in List.foldl' collectUsed + (extendVarEnv x (x,e0) env) + (eltsVarSet eFVs) + Nothing -> env + +deadCode _ e = return e +{-# SCC deadCode #-} + +removeUnusedExpr :: HasCallStack => NormRewrite +removeUnusedExpr _ e@(collectArgsTicks -> (p@(Prim pInfo),args,ticks)) = do + bbM <- HashMap.lookup (primName pInfo) <$> Lens.use (extra.primitives) + let + usedArgs0 = + case Monad.join (extractPrim <$> bbM) of + Just (BlackBoxHaskell{usedArguments}) -> + case usedArguments of + UsedArguments used -> Just used + IgnoredArguments ignored -> Just ([0..length args - 1] \\ ignored) + Just (BlackBox pNm _ _ _ _ _ _ _ _ inc r ri templ) -> Just $ + if | isFromInt pNm -> [0,1,2] + | primName pInfo `elem` [ "Clash.Annotations.BitRepresentation.Deriving.dontApplyInHDL" + , "Clash.Sized.Vector.splitAt" + ] -> [0,1] + | otherwise -> concat [ maybe [] getUsedArguments r + , maybe [] getUsedArguments ri + , getUsedArguments templ + , concatMap (getUsedArguments . snd) inc ] + _ -> + Nothing + + case usedArgs0 of + Nothing -> + return e + Just usedArgs1 -> do + tcm <- Lens.view tcCache + (args1, Monoid.getAny -> hasChanged) <- listen (go tcm 0 usedArgs1 args) + if hasChanged then + return (mkApps (mkTicks p ticks) args1) + else + return e + + where + arity = length . Either.rights . fst $ splitFunForallTy (primType pInfo) + + go _ _ _ [] = return [] + go tcm !n used (Right ty:args') = do + args'' <- go tcm n used args' + return (Right ty : args'') + go tcm !n used (Left tm : args') = do + args'' <- go tcm (n+1) used args' + case tm of + TyApp (Prim p0) _ + | primName p0 == "Clash.Transformations.removedArg" + -> return (Left tm : args'') + _ -> do + let ty = termType tcm tm + p' = removedTm ty + if n < arity && n `notElem` used + then changed (Left p' : args'') + else return (Left tm : args'') + +removeUnusedExpr _ e@(Case _ _ [(DataPat _ [] xs,altExpr)]) = + if xs `localIdsDoNotOccurIn` altExpr + then changed altExpr + else return e + +-- Replace any expression that creates a Vector of size 0 within the application +-- of the Cons constructor, by the Nil constructor. +removeUnusedExpr _ e@(collectArgsTicks -> (Data dc, [_,Right aTy,Right nTy,_,Left a,Left nil],ticks)) + | nameOcc (dcName dc) == "Clash.Sized.Vector.Cons" + = do + tcm <- Lens.view tcCache + case runExcept (tyNatSize tcm nTy) of + Right 0 + | (con, _) <- collectArgs nil + , not (isCon con) + -> let eTy = termType tcm e + (TyConApp vecTcNm _) = tyView eTy + (Just vecTc) = lookupUniqMap vecTcNm tcm + [nilCon,consCon] = tyConDataCons vecTc + v = mkTicks (mkVec nilCon consCon aTy 1 [a]) ticks + in changed v + _ -> return e + +removeUnusedExpr _ e = return e +{-# SCC removeUnusedExpr #-} + +-- | Inline let-bindings when the RHS is either a local variable reference or +-- is constant (except clock or reset generators) +bindConstantVar :: HasCallStack => NormRewrite +bindConstantVar = inlineBinders test + where + test _ (i,stripTicks -> e) = case isLocalVar e of + -- Don't inline `let x = x in x`, it throws us in an infinite loop + True -> return (i `localIdDoesNotOccurIn` e) + _ -> isWorkFreeIsh e >>= \case + True -> Lens.use (extra.inlineConstantLimit) >>= \case + 0 -> return True + n -> return (termSize e <= n) + _ -> return False +{-# SCC bindConstantVar #-} + +-- | Push a cast over a case into it's alternatives. +caseCast :: HasCallStack => NormRewrite +caseCast _ (Cast (stripTicks -> Case subj ty alts) ty1 ty2) = do + let alts' = map (\(p,e) -> (p, Cast e ty1 ty2)) alts + changed (Case subj ty alts') +caseCast _ e = return e +{-# SCC caseCast #-} + + +-- | Push a cast over a Letrec into it's body +letCast :: HasCallStack => NormRewrite +letCast _ (Cast (stripTicks -> Letrec binds body) ty1 ty2) = + changed $ Letrec binds (Cast body ty1 ty2) +letCast _ e = return e +{-# SCC letCast #-} + + +-- | Push cast over an argument to a function into that function +-- +-- This is done by specializing on the casted argument. +-- Example: +-- @ +-- y = f (cast a) +-- where f x = g x +-- @ +-- transforms to: +-- @ +-- y = f' a +-- where f' x' = (\x -> g x) (cast x') +-- @ +-- +-- The reason d'etre for this transformation is that we hope to end up with +-- and expression where two casts are "back-to-back" after which we can +-- eliminate them in 'eliminateCastCast'. +argCastSpec :: HasCallStack => NormRewrite +argCastSpec ctx e@(App _ (stripTicks -> Cast e' _ _)) = + if isWorkFree e' then + go + else + warn go + where + go = specializeNorm ctx e + warn = trace (unwords + [ "WARNING:", $(curLoc), "specializing a function on a non work-free" + , "cast. Generated HDL implementation might contain duplicate work." + , "Please report this as a bug.", "\n\nExpression where this occured:" + , "\n\n" ++ showPpr e + ]) +argCastSpec _ e = return e +{-# SCC argCastSpec #-} + +-- | Only inline casts that just contain a 'Var', because these are guaranteed work-free. +-- These are the result of the 'splitCastWork' transformation. +inlineCast :: HasCallStack => NormRewrite +inlineCast = inlineBinders test + where + test _ (_, (Cast (stripTicks -> Var {}) _ _)) = return True + test _ _ = return False +{-# SCC inlineCast #-} + +-- | Eliminate two back to back casts where the type going in and coming out are the same +-- +-- @ +-- (cast :: b -> a) $ (cast :: a -> b) x ==> x +-- @ +eliminateCastCast :: HasCallStack => NormRewrite +eliminateCastCast _ c@(Cast (stripTicks -> Cast e tyA tyB) tyB' tyC) = do + tcm <- Lens.view tcCache + let ntyA = normalizeType tcm tyA + ntyB = normalizeType tcm tyB + ntyB' = normalizeType tcm tyB' + ntyC = normalizeType tcm tyC + if ntyB == ntyB' && ntyA == ntyC then changed e + else throwError + where throwError = do + (nm,sp) <- Lens.use curFun + throw (ClashException sp ($(curLoc) ++ showPpr nm + ++ ": Found 2 nested casts whose types don't line up:\n" + ++ showPpr c) + Nothing) + +eliminateCastCast _ e = return e +{-# SCC eliminateCastCast #-} + +-- | Make a cast work-free by splitting the work of to a separate binding +-- +-- @ +-- let x = cast (f a b) +-- ==> +-- let x = cast x' +-- x' = f a b +-- @ +splitCastWork :: HasCallStack => NormRewrite +splitCastWork ctx@(TransformContext is0 _) unchanged@(Letrec vs e') = do + (vss', Monoid.getAny -> hasChanged) <- listen (mapM (splitCastLetBinding is0) vs) + let vs' = concat vss' + if hasChanged then changed (Letrec vs' e') + else return unchanged + where + splitCastLetBinding + :: InScopeSet + -> LetBinding + -> RewriteMonad extra [LetBinding] + splitCastLetBinding isN x@(nm, e) = case stripTicks e of + Cast (Var {}) _ _ -> return [x] -- already work-free + Cast (Cast {}) _ _ -> return [x] -- casts will be eliminated + Cast e0 ty1 ty2 -> do + tcm <- Lens.view tcCache + nm' <- mkTmBinderFor isN tcm (mkDerivedName ctx (nameOcc $ varName nm)) e0 + changed [(nm',e0) + ,(nm, Cast (Var nm') ty1 ty2) + ] + _ -> return [x] + +splitCastWork _ e = return e +{-# SCC splitCastWork #-} + + +-- | Inline work-free functions, i.e. fully applied functions that evaluate to +-- a constant +inlineWorkFree :: HasCallStack => NormRewrite +inlineWorkFree _ e@(collectArgsTicks -> (Var f,args@(_:_),ticks)) + = do + tcm <- Lens.view tcCache + let eTy = termType tcm e + argsHaveWork <- or <$> mapM (either expressionHasWork + (const (pure False))) + args + untranslatable <- isUntranslatableType True eTy + let isSignal = isSignalType tcm eTy + let lv = isLocalId f + if untranslatable || isSignal || argsHaveWork || lv + then return e + else do + bndrs <- Lens.use bindings + case lookupVarEnv f bndrs of + -- Don't inline recursive expressions + Just b -> do + isRecBndr <- isRecursiveBndr f + if isRecBndr + then return e + else do + let tm = mkTicks (bindingTerm b) (mkInlineTick f : ticks) + changed $ mkApps tm args + + _ -> return e + where + -- an expression is has work when it contains free local variables, + -- or has a Signal type, i.e. it does not evaluate to a work-free + -- constant. + expressionHasWork e' = do + let fvIds = Lens.toListOf freeLocalIds e' + tcm <- Lens.view tcCache + let e'Ty = termType tcm e' + isSignal = isSignalType tcm e'Ty + return (not (null fvIds) || isSignal) + +inlineWorkFree _ e@(Var f) = do + tcm <- Lens.view tcCache + let fTy = varType f + closed = not (isPolyFunCoreTy tcm fTy) + isSignal = isSignalType tcm fTy + untranslatable <- isUntranslatableType True fTy + topEnts <- Lens.view topEntities + let gv = isGlobalId f + if closed && f `notElemVarSet` topEnts && not untranslatable && not isSignal && gv + then do + bndrs <- Lens.use bindings + case lookupVarEnv f bndrs of + -- Don't inline recursive expressions + Just top -> do + isRecBndr <- isRecursiveBndr f + if isRecBndr + then return e + else do + let topB = bindingTerm top + sizeLimit <- Lens.use (extra.inlineWFCacheLimit) + -- caching only worth it from a certain size onwards, otherwise + -- the caching mechanism itself brings more of an overhead. + if termSize topB < sizeLimit then + changed topB + else do + b <- normalizeTopLvlBndr False f top + changed (bindingTerm b) + _ -> return e + else return e + +inlineWorkFree _ e = return e +{-# SCC inlineWorkFree #-} + +-- | Inline small functions +inlineSmall :: HasCallStack => NormRewrite +inlineSmall _ e@(collectArgsTicks -> (Var f,args,ticks)) = do + untranslatable <- isUntranslatable True e + topEnts <- Lens.view topEntities + let lv = isLocalId f + if untranslatable || f `elemVarSet` topEnts || lv + then return e + else do + bndrs <- Lens.use bindings + sizeLimit <- Lens.use (extra.inlineFunctionLimit) + case lookupVarEnv f bndrs of + -- Don't inline recursive expressions + Just b -> do + isRecBndr <- isRecursiveBndr f + if not isRecBndr && bindingSpec b /= NoInline && termSize (bindingTerm b) < sizeLimit + then do + let tm = mkTicks (bindingTerm b) (mkInlineTick f : ticks) + changed $ mkApps tm args + else return e + + _ -> return e + +inlineSmall _ e = return e +{-# SCC inlineSmall #-} + +-- | Specialise functions on arguments which are constant, except when they +-- are clock, reset generators. +constantSpec :: HasCallStack => NormRewrite +constantSpec ctx@(TransformContext is0 tfCtx) e@(App e1 e2) + | (Var {}, args) <- collectArgs e1 + , (_, []) <- Either.partitionEithers args + , null $ Lens.toListOf termFreeTyVars e2 + = do specInfo<- constantSpecInfo ctx e2 + if csrFoundConstant specInfo then + let newBindings = csrNewBindings specInfo in + if null newBindings then + -- Whole of e2 is constant + specializeNorm ctx (App e1 e2) + else do + -- Parts of e2 are constant + let is1 = extendInScopeSetList is0 (fst <$> csrNewBindings specInfo) + Letrec newBindings + <$> specializeNorm + (TransformContext is1 tfCtx) + (App e1 (csrNewTerm specInfo)) + + else + -- e2 has no constant parts + return e +constantSpec _ e = return e +{-# SCC constantSpec #-} + + +-- Experimental + +-- | Propagate arguments of application inwards; except for 'Lam' where the +-- argument becomes let-bound. 'appPropFast' tries to propagate as many arguments +-- as possible, down as many levels as possible; and should be called in a +-- top-down traversal. +-- +-- The idea is that this reduces the number of traversals, which hopefully leads +-- to shorter compile times. +-- +-- Note [AppProp no shadowing] +-- +-- Case 1. +-- +-- Imagine: +-- +-- @ +-- (case x of +-- D a b -> h a) (f x y) +-- @ +-- +-- rewriting this to: +-- +-- @ +-- let b = f x y +-- in case x of +-- D a b -> h a b +-- @ +-- +-- is very bad because 'b' in 'h a b' is now bound by the pattern instead of the +-- newly introduced let-binding +-- +-- instead me must deshadow w.r.t. the new variable and rewrite to: +-- +-- @ +-- let b = f x y +-- in case x of +-- D a b1 -> h a b +-- @ +-- +-- Case 2. +-- +-- Imagine +-- +-- @ +-- (\x -> e) u +-- @ +-- +-- where @u@ has a free variable named @x@, rewriting this to: +-- +-- @ +-- let x = u +-- in e +-- @ +-- +-- would be very bad, because the let-binding suddenly captures the free +-- variable in @u@. To prevent this from happening we over-approximate and check +-- whether @x@ is in the current InScopeSet, and deshadow if that's the case, +-- i.e. we then rewrite to: +-- +-- let x1 = u +-- in e [x:=x1] +-- +-- Case 3. +-- +-- The same for: +-- +-- @ +-- (let x = w in e) u +-- @ +-- +-- where @u@ again has a free variable @x@, rewriting this to: +-- +-- @ +-- let x = w in (e u) +-- @ +-- +-- would be bad because the let-binding now captures the free variable in @u@. +-- +-- To prevent this from happening, we unconditionally deshadow the function part +-- of the application w.r.t. the free variables in the argument part of the +-- application. It is okay to over-approximate in this case and deshadow w.r.t +-- the current InScopeSet. +appPropFast :: HasCallStack => NormRewrite +appPropFast ctx@(TransformContext is _) = \case + e@App {} + | let (fun,args,ticks) = collectArgsTicks e + -> go is (deShadowTerm is fun) args ticks + e@TyApp {} + | let (fun,args,ticks) = collectArgsTicks e + -> go is (deShadowTerm is fun) args ticks + e -> return e + where + go :: InScopeSet -> Term -> [Either Term Type] -> [TickInfo] + -> NormalizeSession Term + go is0 (collectArgsTicks -> (fun,args0@(_:_),ticks0)) args1 ticks1 = + go is0 fun (args0 ++ args1) (ticks0 ++ ticks1) + + go is0 (Lam v e) (Left arg:args) ticks = do + setChanged + if isWorkFree arg || isVar arg + then do + let subst = extendIdSubst (mkSubst is0) v arg + (`mkTicks` ticks) <$> go is0 (substTm "appPropFast.AppLam" subst e) args [] + else do + let is1 = extendInScopeSet is0 v + Letrec [(v, arg)] <$> go is1 (deShadowTerm is1 e) args ticks + + go is0 (Letrec vs e) args@(_:_) ticks = do + setChanged + let vbs = map fst vs + is1 = extendInScopeSetList is0 vbs + -- XXX: 'vs' should already be deshadowed w.r.t. 'is0' + Letrec vs <$> go is1 e args ticks + + go is0 (TyLam tv e) (Right t:args) ticks = do + setChanged + let subst = extendTvSubst (mkSubst is0) tv t + (`mkTicks` ticks) <$> go is0 (substTm "appPropFast.TyAppTyLam" subst e) args [] + + go is0 (Case scrut ty0 alts) args0@(_:_) ticks = do + setChanged + let isA1 = unionInScope + is0 + ((mkInScopeSet . mkVarSet . concatMap (patVars . fst)) alts) + (ty1,vs,args1) <- goCaseArg isA1 ty0 [] args0 + case vs of + [] -> (`mkTicks` ticks) . Case scrut ty1 <$> mapM (goAlt is0 args1) alts + _ -> do + let vbs = map fst vs + is1 = extendInScopeSetList is0 vbs + alts1 = map (deShadowAlt is1) alts + Letrec vs . (`mkTicks` ticks) . Case scrut ty1 <$> mapM (goAlt is1 args1) alts1 + + go is0 (Tick sp e) args ticks = do + setChanged + go is0 e args (sp:ticks) + + go _ fun args ticks = return (mkApps (mkTicks fun ticks) args) + + goAlt is0 args0 (p,e) = do + let (tvs,ids) = patIds p + is1 = extendInScopeSetList (extendInScopeSetList is0 tvs) ids + (p,) <$> go is1 e args0 [] + + goCaseArg isA ty0 ls0 (Right t:args0) = do + tcm <- Lens.view tcCache + let ty1 = piResultTy tcm ty0 t + (ty2,ls1,args1) <- goCaseArg isA ty1 ls0 args0 + return (ty2,ls1,Right t:args1) + + goCaseArg isA0 ty0 ls0 (Left arg:args0) = do + tcm <- Lens.view tcCache + let argTy = termType tcm arg + ty1 = applyFunTy tcm ty0 argTy + case isWorkFree arg || isVar arg of + True -> do + (ty2,ls1,args1) <- goCaseArg isA0 ty1 ls0 args0 + return (ty2,ls1,Left arg:args1) + False -> do + boundArg <- mkTmBinderFor isA0 tcm (mkDerivedName ctx "app_arg") arg + let isA1 = extendInScopeSet isA0 boundArg + (ty2,ls1,args1) <- goCaseArg isA1 ty1 ls0 args0 + return (ty2,(boundArg,arg):ls1,Left (Var boundArg):args1) + + goCaseArg _ ty ls [] = return (ty,ls,[]) +{-# SCC appPropFast #-} + +-- | Flatten ridiculous case-statements generated by GHC +-- +-- For case-statements in haskell of the form: +-- +-- @ +-- f :: Unsigned 4 -> Unsigned 4 +-- f x = case x of +-- 0 -> 3 +-- 1 -> 2 +-- 2 -> 1 +-- 3 -> 0 +-- @ +-- +-- GHC generates Core that looks like: +-- +-- @ +-- f = \(x :: Unsigned 4) -> case x == fromInteger 3 of +-- False -> case x == fromInteger 2 of +-- False -> case x == fromInteger 1 of +-- False -> case x == fromInteger 0 of +-- False -> error "incomplete case" +-- True -> fromInteger 3 +-- True -> fromInteger 2 +-- True -> fromInteger 1 +-- True -> fromInteger 0 +-- @ +-- +-- Which would result in a priority decoder circuit where a normal decoder +-- circuit was desired. +-- +-- This transformation transforms the above Core to the saner: +-- +-- @ +-- f = \(x :: Unsigned 4) -> case x of +-- _ -> error "incomplete case" +-- 0 -> fromInteger 3 +-- 1 -> fromInteger 2 +-- 2 -> fromInteger 1 +-- 3 -> fromInteger 0 +-- @ +caseFlat :: HasCallStack => NormRewrite +caseFlat _ e@(Case (collectEqArgs -> Just (scrut',_)) ty _) + = do + case collectFlat scrut' e of + Just alts' -> changed (Case scrut' ty (last alts' : init alts')) + Nothing -> return e + +caseFlat _ e = return e +{-# SCC caseFlat #-} + +collectFlat :: Term -> Term -> Maybe [(Pat,Term)] +collectFlat scrut (Case (collectEqArgs -> Just (scrut', val)) _ty [lAlt,rAlt]) + | scrut' == scrut + = case collectArgs val of + (Prim p,args') | isFromInt (primName p) -> + go (last args') + (Data dc,args') | nameOcc (dcName dc) == "GHC.Types.I#" -> + go (last args') + _ -> Nothing + where + go (Left (Literal i)) = case (lAlt,rAlt) of + ((pl,el),(pr,er)) + | isFalseDcPat pl || isTrueDcPat pr -> + case collectFlat scrut el of + Just alts' -> Just ((LitPat i, er) : alts') + Nothing -> Just [(LitPat i, er) + ,(DefaultPat, el) + ] + | otherwise -> + case collectFlat scrut er of + Just alts' -> Just ((LitPat i, el) : alts') + Nothing -> Just [(LitPat i, el) + ,(DefaultPat, er) + ] + go _ = Nothing + + isFalseDcPat (DataPat p _ _) + = ((== "GHC.Types.False") . nameOcc . dcName) p + isFalseDcPat _ = False + + isTrueDcPat (DataPat p _ _) + = ((== "GHC.Types.True") . nameOcc . dcName) p + isTrueDcPat _ = False + +collectFlat _ _ = Nothing +{-# SCC collectFlat #-} + +collectEqArgs :: Term -> Maybe (Term,Term) +collectEqArgs (collectArgsTicks -> (Prim p, args, ticks)) + | nm == "Clash.Sized.Internal.BitVector.eq#" + = let [_,_,Left scrut,Left val] = args + in Just (mkTicks scrut ticks,val) + | nm == "Clash.Sized.Internal.Index.eq#" || + nm == "Clash.Sized.Internal.Signed.eq#" || + nm == "Clash.Sized.Internal.Unsigned.eq#" + = let [_,Left scrut,Left val] = args + in Just (mkTicks scrut ticks,val) + | nm == "Clash.Transformations.eqInt" + = let [Left scrut,Left val] = args + in Just (mkTicks scrut ticks,val) + where + nm = primName p + +collectEqArgs _ = Nothing + +type NormRewriteW = Transform (StateT ([LetBinding],InScopeSet) (RewriteMonad NormalizeState)) + +-- | See Note [ANF InScopeSet] +tellBinders :: Monad m => [LetBinding] -> StateT ([LetBinding],InScopeSet) m () +tellBinders bs = modify ((bs ++) *** (`extendInScopeSetList` (map fst bs))) + +-- | See Note [ANF InScopeSet]; only extends the inscopeset +notifyBinders :: Monad m => [LetBinding] -> StateT ([LetBinding],InScopeSet) m () +notifyBinders bs = modify (second (`extendInScopeSetList` (map fst bs))) + +-- | Is the given type IO-like +isSimIOTy + :: TyConMap + -> Type + -- ^ Type to check for IO-likeness + -> Bool +isSimIOTy tcm ty = case tyView (coreView tcm ty) of + TyConApp tcNm args + | nameOcc tcNm == "Clash.Explicit.SimIO.SimIO" + -> True + | nameOcc tcNm == "GHC.Prim.(#,#)" + , [_,_,st,_] <- args + -> isStateTokenTy tcm st + FunTy _ res -> isSimIOTy tcm res + _ -> False + +-- | Is the given type the state token +isStateTokenTy + :: TyConMap + -> Type + -- ^ Type to check for state tokenness + -> Bool +isStateTokenTy tcm ty = case tyView (coreView tcm ty) of + TyConApp tcNm _ -> nameOcc tcNm == "GHC.Prim.State#" + _ -> False + +-- | Turn an expression into a modified ANF-form. As opposed to standard ANF, +-- constants do not become let-bound. +makeANF :: HasCallStack => NormRewrite +makeANF (TransformContext is0 ctx) (Lam bndr e) = do + e' <- makeANF (TransformContext (extendInScopeSet is0 bndr) + (LamBody bndr:ctx)) + e + return (Lam bndr e') + +makeANF _ e@(TyLam {}) = return e + +makeANF ctx@(TransformContext is0 _) e0 + = do + -- We need to freshen all binders in `e` because we're shuffling them around + -- into a single let-binder, because even when binders don't shadow, they + -- don't have to be unique within an expression. And so lifting them all + -- to a single let-binder will cause issues when they're not unique. + -- + -- We cannot make freshening part of collectANF, because when we generate + -- new binders, we need to make sure those names do not conflict with _any_ + -- of the existing binders in the expression. + -- + -- See also Note [ANF InScopeSet] + let (is2,e1) = freshenTm is0 e0 + ((e2,(bndrs,_)),Monoid.getAny -> hasChanged) <- + listen (runStateT (bottomupR collectANF ctx e1) ([],is2)) + case bndrs of + [] -> if hasChanged then return e2 else return e0 + _ -> do + let (e3,ticks) = collectTicks e2 + (srcTicks,nmTicks) = partitionTicks ticks + -- Ensure that `AppendName` ticks still scope over the entire expression + changed (mkTicks (Letrec bndrs (mkTicks e3 srcTicks)) nmTicks) +{-# SCC makeANF #-} + +-- | Note [ANF InScopeSet] +-- +-- The InScopeSet contains: +-- +-- 1. All the free variables of the expression we are traversing +-- +-- 2. All the bound variables of the expression we are traversing +-- +-- 3. The newly created let-bindings as we recurse back up the traversal +-- +-- All of these are needed to created let-bindings that +-- +-- * Do not shadow +-- * Are not shadowed +-- * Nor conflict with each other (i.e. have the same unique) +-- +-- Initially we start with the local InScopeSet and add the global variables: +-- +-- @ +-- is1 <- unionInScope is0 <$> Lens.use globalInScope +-- @ +-- +-- Which will gives us the (superset of) free variables of the expression. Then +-- we call 'freshenTm' +-- +-- @ +-- let (is2,e1) = freshenTm is1 e0 +-- @ +-- +-- Which extends the InScopeSet with all the bound variables in 'e1', the +-- version of 'e0' where all binders are unique (not just deshadowed). +-- +-- So we start out with an InScopeSet that satisfies points 1 and 2, now every +-- time we create a new binder we must add it to the InScopeSet to satisfy +-- point 3. +-- +-- Note [ANF no let-bind] +-- +-- | Do not let-bind: +-- +-- 1. Arguments with an untranslatable type: untranslatable expressions +-- should be propagated down as far as possible +-- +-- 2. Local variables or constants: they don't add any work, so no reason +-- to let-bind to enable sharing +-- +-- 3. IO actions, the translation of IO actions to sequential HDL constructs +-- depends on IO actions to be propagated down as far as possible. +collectANF :: HasCallStack => NormRewriteW +collectANF ctx e@(App appf arg) + | (conVarPrim, _) <- collectArgs e + , isCon conVarPrim || isPrim conVarPrim || isVar conVarPrim + = do + untranslatable <- lift (isUntranslatable False arg) + let localVar = isLocalVar arg + constantNoCR <- lift (isConstantNotClockReset arg) + -- See Note [ANF no let-bind] + case (untranslatable,localVar || constantNoCR, isSimBind conVarPrim,arg) of + (False,False,False,_) -> do + tcm <- Lens.view tcCache + -- See Note [ANF InScopeSet] + is1 <- Lens.use _2 + argId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "app_arg") arg) + -- See Note [ANF InScopeSet] + tellBinders [(argId,arg)] + return (App appf (Var argId)) + (True,False,_,Letrec binds body) -> do + tellBinders binds + return (App appf body) + _ -> return e + where + isSimBind (Prim p) = primName p == "Clash.Explicit.SimIO.bindSimIO#" + isSimBind _ = False + +collectANF _ (Letrec binds body) = do + tcm <- Lens.view tcCache + let isSimIO = isSimIOTy tcm (termType tcm body) + untranslatable <- lift (isUntranslatable False body) + let localVar = isLocalVar body + -- See Note [ANF no let-bind] + if localVar || untranslatable || isSimIO + then do + tellBinders binds + return body + else do + -- See Note [ANF InScopeSet] + is1 <- Lens.use _2 + argId <- lift (mkTmBinderFor is1 tcm (mkUnsafeSystemName "result" 0) body) + -- See Note [ANF InScopeSet] + tellBinders [(argId,body)] + tellBinders binds + return (Var argId) + +-- TODO: The code below special-cases ANF for the ':-' constructor for the +-- 'Signal' type. The 'Signal' type is essentially treated as a "transparent" +-- type by the Clash compiler, so observing its constructor leads to all kinds +-- of problems. In this case that "Clash.Rewrite.Util.mkSelectorCase" will +-- try to project the LHS and RHS of the ':-' constructor, however, +-- 'mkSelectorCase' uses 'coreView1' to find the "real" data-constructor. +-- 'coreView1' however looks through the 'Signal' type, and hence 'mkSelector' +-- finds the data constructors for the element type of Signal. This resulted in +-- error #24 (https://github.com/christiaanb/clash2/issues/24), where we +-- try to get the first field out of the 'Vec's 'Nil' constructor. +-- +-- Ultimately we should stop treating Signal as a "transparent" type and deal +-- handling of the Signal type, and the involved co-recursive functions, +-- properly. At the moment, Clash cannot deal with this recursive type and the +-- recursive functions involved, hence the need for special-casing code. After +-- everything is done properly, we should remove the two lines below. +collectANF _ e@(Case _ _ [(DataPat dc _ _,_)]) + | nameOcc (dcName dc) == "Clash.Signal.Internal.:-" = return e + +collectANF ctx (Case subj ty alts) = do + let localVar = isLocalVar subj + let isConstantSubj = isConstant subj + + (subj',subjBinders) <- if localVar || isConstantSubj + then return (subj,[]) + else do + tcm <- Lens.view tcCache + -- See Note [ANF InScopeSet] + is1 <- Lens.use _2 + argId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "case_scrut") subj) + -- See Note [ANF InScopeSet] + notifyBinders [(argId,subj)] + return (Var argId,[(argId,subj)]) + + tcm <- Lens.view tcCache + let isSimIOAlt = isSimIOTy tcm ty + + alts' <- mapM (doAlt isSimIOAlt subj') alts + tellBinders subjBinders + + case alts' of + [(DataPat _ [] xs,altExpr)] + | xs `localIdsDoNotOccurIn` altExpr || isSimIOAlt + -> return altExpr + _ -> return (Case subj' ty alts') + where + doAlt + :: Bool -> Term -> (Pat,Term) + -> StateT ([LetBinding],InScopeSet) (RewriteMonad NormalizeState) + (Pat,Term) + doAlt isSimIOAlt subj' alt@(DataPat dc exts xs,altExpr) | not (bindsExistentials exts xs) = do + let lv = isLocalVar altExpr + patSels <- Monad.zipWithM (doPatBndr subj' dc) xs [0..] + let altExprIsConstant = isConstant altExpr + let usesXs (Var n) = any (== n) xs + usesXs _ = False + -- See [ANF no let-bind] + if or [isSimIOAlt, lv && (not (usesXs altExpr) || length alts == 1), altExprIsConstant] + then do + -- See Note [ANF InScopeSet] + tellBinders patSels + return alt + else do + tcm <- Lens.view tcCache + -- See Note [ANF InScopeSet] + is1 <- Lens.use _2 + altId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "case_alt") altExpr) + -- See Note [ANF InScopeSet] + tellBinders (patSels ++ [(altId,altExpr)]) + return (DataPat dc exts xs,Var altId) + doAlt _ _ alt@(DataPat {}, _) = return alt + doAlt isSimIOAlt _ alt@(pat,altExpr) = do + let lv = isLocalVar altExpr + let altExprIsConstant = isConstant altExpr + -- See [ANF no let-bind] + if isSimIOAlt || lv || altExprIsConstant + then return alt + else do + tcm <- Lens.view tcCache + -- See Note [ANF InScopeSet] + is1 <- Lens.use _2 + altId <- lift (mkTmBinderFor is1 tcm (mkDerivedName ctx "case_alt") altExpr) + tellBinders [(altId,altExpr)] + return (pat,Var altId) + + doPatBndr + :: Term -> DataCon -> Id -> Int + -> StateT ([LetBinding],InScopeSet) (RewriteMonad NormalizeState) + LetBinding + doPatBndr subj' dc pId i + = do + tcm <- Lens.view tcCache + -- See Note [ANF InScopeSet] + is1 <- Lens.use _2 + patExpr <- lift (mkSelectorCase ($(curLoc) ++ "doPatBndr") is1 tcm subj' (dcTag dc) i) + -- No need to 'tellBinders' here because 'pId' is already in the ANF + -- InScopeSet. + -- + -- See also Note [ANF InScopeSet] + return (pId,patExpr) + +collectANF _ e = return e +{-# SCC collectANF #-} + +-- | Eta-expand top-level lambda's (DON'T use in a traversal!) +etaExpansionTL :: HasCallStack => NormRewrite +etaExpansionTL (TransformContext is0 ctx) (Lam bndr e) = do + e' <- etaExpansionTL + (TransformContext (extendInScopeSet is0 bndr) (LamBody bndr:ctx)) + e + return $ Lam bndr e' + +etaExpansionTL (TransformContext is0 ctx) (Letrec xes e) = do + let bndrs = map fst xes + e' <- etaExpansionTL + (TransformContext (extendInScopeSetList is0 bndrs) + (LetBody bndrs:ctx)) + e + case stripLambda e' of + (bs@(_:_),e2) -> do + let e3 = Letrec xes e2 + changed (mkLams e3 bs) + _ -> return (Letrec xes e') + where + stripLambda :: Term -> ([Id],Term) + stripLambda (Lam bndr e0) = + let (bndrs,e1) = stripLambda e0 + in (bndr:bndrs,e1) + stripLambda e' = ([],e') + +etaExpansionTL (TransformContext is0 ctx) e + = do + tcm <- Lens.view tcCache + if isFun tcm e + then do + let argTy = ( fst + . Maybe.fromMaybe (error $ $(curLoc) ++ "etaExpansion splitFunTy") + . splitFunTy tcm + . termType tcm + ) e + newId <- mkInternalVar is0 "arg" argTy + e' <- etaExpansionTL (TransformContext (extendInScopeSet is0 newId) + (LamBody newId:ctx)) + (App e (Var newId)) + changed (Lam newId e') + else return e +{-# SCC etaExpansionTL #-} + +-- | Eta-expand functions with a Synthesize annotation, needed to allow such +-- functions to appear as arguments to higher-order primitives. +etaExpandSyn :: HasCallStack => NormRewrite +etaExpandSyn (TransformContext is0 ctx) e@(collectArgs -> (Var f, _)) = do + topEnts <- Lens.view topEntities + tcm <- Lens.view tcCache + let isTopEnt = f `elemVarSet` topEnts + isAppFunCtx = + \case + AppFun:_ -> True + TickC _:c -> isAppFunCtx c + _ -> False + argTyM = fmap fst (splitFunTy tcm (termType tcm e)) + case argTyM of + Just argTy | isTopEnt && not (isAppFunCtx ctx) -> do + newId <- mkInternalVar is0 "arg" argTy + changed (Lam newId (App e (Var newId))) + _ -> return e + +etaExpandSyn _ e = return e +{-# SCC etaExpandSyn #-} + +isClassConstraint :: Type -> Bool +isClassConstraint (tyView -> TyConApp nm0 _) = + if -- Constraint tuple: + | "GHC.Classes.(%" `Text.isInfixOf` nm1 -> True + -- Constraint class: + | "C:" `Text.isInfixOf` nm2 -> True + | otherwise -> False + where + nm1 = nameOcc nm0 + nm2 = snd (Text.breakOnEnd "." nm1) + +isClassConstraint _ = False + + +-- | Turn a normalized recursive function, where the recursive calls only pass +-- along the unchanged original arguments, into let-recursive function. This +-- means that all recursive calls are replaced by the same variable reference as +-- found in the body of the top-level let-expression. +recToLetRec :: HasCallStack => NormRewrite +recToLetRec (TransformContext is0 []) e = do + (fn,_) <- Lens.use curFun + tcm <- Lens.view tcCache + case splitNormalized tcm e of + Right (args,bndrs,res) -> do + let args' = map Var args + (toInline,others) = List.partition (eqApp tcm fn args' . snd) bndrs + resV = Var res + case (toInline,others) of + (_:_,_:_) -> do + let is1 = extendInScopeSetList is0 (args ++ map fst bndrs) + let substsInline = extendIdSubstList (mkSubst is1) + $ map (second (const resV)) toInline + others' = map (second (substTm "recToLetRec" substsInline)) + others + changed $ mkLams (Letrec others' resV) args + _ -> return e + _ -> return e + where + -- This checks whether things are semantically equal. For example, say we + -- have: + -- + -- x :: (a, (b, c)) + -- + -- and + -- + -- y :: (a, (b, c)) + -- + -- If we can determine that 'y' is constructed solely using the + -- corresponding fields in 'x', then we can say they are semantically + -- equal. The algorithm below keeps track of what (sub)field it is + -- constructing, and checks if the field-expression projects the + -- corresponding (sub)field from the target variable. + -- + -- TODO: See [Note: Breaks on constants and predetermined equality] + eqApp tcm v args (collectArgs . stripTicks -> (Var v',args')) + | isGlobalId v' + , v == v' + , let args2 = Either.lefts args' + , length args == length args2 + = and (zipWith (eqArg tcm) args args2) + eqApp _ _ _ _ = False + + eqArg _ v1 v2@(stripTicks -> Var {}) + = v1 == v2 + eqArg tcm v1 v2@(collectArgs . stripTicks -> (Data _, args')) + | let t1 = termType tcm v1 + , let t2 = termType tcm v2 + , t1 == t2 + = if isClassConstraint t1 then + -- Class constraints are equal if their types are equal, so we can + -- take a shortcut here. + True + else + -- Check whether all arguments to the data constructor are projections + -- + and (zipWith (eqDat v1) (map pure [0..]) (Either.lefts args')) + eqArg _ _ _ + = False + + -- Recursively check whether a term /e/ is semantically equal to some variable /v/. + -- Currently it can only assert equality when /e/ is syntactically equal + -- to /v/, or is constructed out of projections of /v/, importantly: + -- + -- [Note: Breaks on constants and predetermined equality] + -- This function currently breaks if: + -- + -- * One or more subfields are constants. Constants might have been + -- inlined for the construction, instead of being a projection of the + -- target variable. + -- + -- * One or more subfields are determined to be equal and one is simply + -- swapped / replaced by the other. For example, say we have + -- `x :: (a, a)`. If GHC determines that both elements of the tuple will + -- always be the same, it might replace the (semantically equal to 'x') + -- construction of `y` with `(fst x, fst x)`. + -- + eqDat :: Term -> [Int] -> Term -> Bool + eqDat v fTrace (collectArgs . stripTicks -> (Data _, args)) = + and (zipWith (eqDat v) (map (:fTrace) [0..]) (Either.lefts args)) + eqDat v1 fTrace v2 = + case stripProjection (reverse fTrace) v1 v2 of + Just [] -> True + _ -> False + + stripProjection :: [Int] -> Term -> Term -> Maybe [Int] + stripProjection fTrace0 vTarget0 (Case v _ [(DataPat _ _ xs, r)]) = do + -- Get projection made in subject of case: + fTrace1 <- stripProjection fTrace0 vTarget0 v + + -- Extract projection of this case statement. Subsequent calls to + -- 'stripProjection' will check if new target is actually used. + n <- headMaybe fTrace1 + vTarget1 <- indexMaybe xs n + fTrace2 <- tailMaybe fTrace1 + + stripProjection fTrace2 (Var vTarget1) r + + stripProjection fTrace (Var sTarget) (Var s) = + if sTarget == s then Just fTrace else Nothing + + stripProjection _fTrace _vTarget _v = + Nothing + +recToLetRec _ e = return e +{-# SCC recToLetRec #-} + +-- | Inline a function with functional arguments +inlineHO :: HasCallStack => NormRewrite +inlineHO _ e@(App _ _) + | (Var f, args, ticks) <- collectArgsTicks e + = do + tcm <- Lens.view tcCache + let hasPolyFunArgs = or (map (either (isPolyFun tcm) (const False)) args) + if hasPolyFunArgs + then do (cf,_) <- Lens.use curFun + isInlined <- zoomExtra (alreadyInlined f cf) + limit <- Lens.use (extra.inlineLimit) + if (Maybe.fromMaybe 0 isInlined) > limit + then do + lvl <- Lens.view dbgLevel + traceIf (lvl > DebugNone) ($(curLoc) ++ "InlineHO: " ++ show f ++ " already inlined " ++ show limit ++ " times in:" ++ show cf) (return e) + else do + bodyMaybe <- lookupVarEnv f <$> Lens.use bindings + case bodyMaybe of + Just b -> do + zoomExtra (addNewInline f cf) + changed (mkApps (mkTicks (bindingTerm b) ticks) args) + _ -> return e + else return e + +inlineHO _ e = return e +{-# SCC inlineHO #-} + +-- | Simplified CSE, only works on let-bindings, does an inverse topological +-- sort of the let-bindings and then works from top to bottom +-- +-- XXX: Check whether inverse top-sort followed by single traversal removes as +-- many binders as the previous "apply-until-fixpoint" approach in the presence +-- of recursive groups in the let-bindings. If not but just for checking whether +-- changes to transformation affect the eventual size of the circuit, it would +-- be really helpful if we tracked circuit size in the regression/test suite. +-- On the two examples that were tested, Reducer and PipelinesViaFolds, this new +-- version of CSE removed the same amount of let-binders. +simpleCSE :: HasCallStack => NormRewrite +simpleCSE (TransformContext is0 _) (inverseTopSortLetBindings -> Letrec bndrs body) = do + let is1 = extendInScopeSetList is0 (map fst bndrs) + (subst,bndrs1) <- reduceBinders (mkSubst is1) [] bndrs + -- TODO: check whether a substitution over the body is enough, the reason I'm + -- doing a substitution over the the binders as well is that I don't know in + -- what order a recursive group shows up in a inverse topological sort. + -- Depending on the order and forgetting to apply the substitution over the + -- let-bindings might lead to the introduction of free variables. + -- + -- NB: don't apply the substitution to the entire let-expression, and that + -- would rename the let-bindings because they've been added to the InScopeSet + -- of the substitution. + let bndrs2 = map (second (substTm "simpleCSE.bndrs" subst)) bndrs1 + body1 = substTm "simpleCSE.body" subst body + return (Letrec bndrs2 body1) + +simpleCSE _ e = return e +{-# SCC simpleCSE #-} + +-- | XXX: is given inverse topologically sorted binders, but returns +-- topologically sorted binders +-- +-- TODO: check further speed improvements: +-- +-- 1. Store the processed binders in a `Map Expr LetBinding`: +-- * Trades O(1) `cons` and O(n)*aeqTerm `find` for: +-- * O(log n)*aeqTerm `insert` and O(log n)*aeqTerm `lookup` +-- 2. Store the processed binders in a `AEQTrie Expr LetBinding` +-- * Trades O(1) `cons` and O(n)*aeqTerm `find` for: +-- * O(e) `insert` and O(e) `lookup` +reduceBinders + :: Subst + -> [LetBinding] + -> [LetBinding] + -> RewriteMonad NormalizeState (Subst, [LetBinding]) +reduceBinders !subst processed [] = return (subst,processed) +reduceBinders !subst processed ((i,substTm "reduceBinders" subst -> e):rest) + | (_,_,ticks) <- collectArgsTicks e + , NoDeDup `notElem` ticks + , Just (i1,_) <- List.find ((== e) . snd) processed + = do + let subst1 = extendIdSubst subst i (Var i1) + setChanged + reduceBinders subst1 processed rest + | otherwise + = reduceBinders subst ((i,e):processed) rest +{-# SCC reduceBinders #-} + +reduceConst :: HasCallStack => NormRewrite +reduceConst ctx e@(App _ _) + | (Prim p0, _) <- collectArgs e + = whnfRW False ctx e $ \_ctx1 e1 -> case e1 of + (collectArgs -> (Prim p1, _)) | primName p0 == primName p1 -> return e + _ -> changed e1 + +reduceConst _ e = return e +{-# SCC reduceConst #-} + +-- | Replace primitives by their "definition" if they would lead to let-bindings +-- with a non-representable type when a function is in ANF. This happens for +-- example when Clash.Size.Vector.map consumes or produces a vector of +-- non-representable elements. +-- +-- Basically what this transformation does is replace a primitive the completely +-- unrolled recursive definition that it represents. e.g. +-- +-- > zipWith ($) (xs :: Vec 2 (Int -> Int)) (ys :: Vec 2 Int) +-- +-- is replaced by: +-- +-- > let (x0 :: (Int -> Int)) = case xs of (:>) _ x xr -> x +-- > (xr0 :: Vec 1 (Int -> Int)) = case xs of (:>) _ x xr -> xr +-- > (x1 :: (Int -> Int)( = case xr0 of (:>) _ x xr -> x +-- > (y0 :: Int) = case ys of (:>) _ y yr -> y +-- > (yr0 :: Vec 1 Int) = case ys of (:>) _ y yr -> xr +-- > (y1 :: Int = case yr0 of (:>) _ y yr -> y +-- > in (($) x0 y0 :> ($) x1 y1 :> Nil) +-- +-- Currently, it only handles the following functions: +-- +-- * Clash.Sized.Vector.zipWith +-- * Clash.Sized.Vector.map +-- * Clash.Sized.Vector.traverse# +-- * Clash.Sized.Vector.fold +-- * Clash.Sized.Vector.foldr +-- * Clash.Sized.Vector.dfold +-- * Clash.Sized.Vector.(++) +-- * Clash.Sized.Vector.head +-- * Clash.Sized.Vector.tail +-- * Clash.Sized.Vector.last +-- * Clash.Sized.Vector.init +-- * Clash.Sized.Vector.unconcat +-- * Clash.Sized.Vector.transpose +-- * Clash.Sized.Vector.replicate +-- * Clash.Sized.Vector.replace_int +-- * Clash.Sized.Vector.imap +-- * Clash.Sized.Vector.dtfold +-- * Clash.Sized.RTree.tdfold +-- * Clash.Sized.RTree.treplicate +-- * Clash.Sized.Internal.BitVector.split# +-- * Clash.Sized.Internal.BitVector.eq# +reduceNonRepPrim :: HasCallStack => NormRewrite +reduceNonRepPrim c@(TransformContext is0 ctx) e@(App _ _) | (Prim p, args, ticks) <- collectArgsTicks e = do + tcm <- Lens.view tcCache + ultra <- Lens.use (extra.normalizeUltra) + let eTy = termType tcm e + case tyView eTy of + (TyConApp vecTcNm@(nameOcc -> "Clash.Sized.Vector.Vec") + [runExcept . tyNatSize tcm -> Right 0, aTy]) -> do + let (Just vecTc) = lookupUniqMap vecTcNm tcm + [nilCon,consCon] = tyConDataCons vecTc + nilE = mkVec nilCon consCon aTy 0 [] + changed (mkTicks nilE ticks) + tv -> let argLen = length args in case primName p of + "Clash.Sized.Vector.zipWith" | argLen == 7 -> do + let [lhsElTy,rhsElty,resElTy,nTy] = Either.rights args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ pure (ultra || n < 2) + , shouldReduce ctx + , anyM isUntranslatableType_not_poly + [lhsElTy,rhsElty,resElTy] ] + if shouldReduce1 + then let [fun,lhsArg,rhsArg] = Either.lefts args + in (`mkTicks` ticks) <$> + reduceZipWith c n lhsElTy rhsElty resElTy fun lhsArg rhsArg + else return e + _ -> return e + "Clash.Sized.Vector.map" | argLen == 5 -> do + let [argElTy,resElTy,nTy] = Either.rights args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ pure (ultra || n < 2 ) + , shouldReduce ctx + , anyM isUntranslatableType_not_poly + [argElTy,resElTy] ] + if shouldReduce1 + then let [fun,arg] = Either.lefts args + in (`mkTicks` ticks) <$> reduceMap c n argElTy resElTy fun arg + else return e + _ -> return e + "Clash.Sized.Vector.traverse#" | argLen == 7 -> + let [aTy,fTy,bTy,nTy] = Either.rights args + in case runExcept (tyNatSize tcm nTy) of + Right n -> + let [dict,fun,arg] = Either.lefts args + in (`mkTicks` ticks) <$> reduceTraverse c n aTy fTy bTy dict fun arg + _ -> return e + "Clash.Sized.Vector.fold" | argLen == 4 -> do + let [aTy,nTy] = Either.rights args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ pure (ultra || n == 0) + , shouldReduce ctx + , isUntranslatableType_not_poly aTy ] + if shouldReduce1 then + let [fun,arg] = Either.lefts args + in (`mkTicks` ticks) <$> reduceFold c (n + 1) aTy fun arg + else return e + _ -> return e + "Clash.Sized.Vector.foldr" | argLen == 6 -> + let [aTy,bTy,nTy] = Either.rights args + in case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ pure ultra + , shouldReduce ctx + , anyM isUntranslatableType_not_poly [aTy,bTy] ] + if shouldReduce1 + then let [fun,start,arg] = Either.lefts args + in (`mkTicks` ticks) <$> reduceFoldr c n aTy fun start arg + else return e + _ -> return e + "Clash.Sized.Vector.dfold" | argLen == 8 -> + let ([_kn,_motive,fun,start,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args + in case runExcept (tyNatSize tcm nTy) of + Right n -> (`mkTicks` ticks) <$> reduceDFold is0 n aTy fun start arg + _ -> return e + "Clash.Sized.Vector.++" | argLen == 5 -> + let [nTy,aTy,mTy] = Either.rights args + [lArg,rArg] = Either.lefts args + in case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of + (Right n, Right m) + | n == 0 -> changed rArg + | m == 0 -> changed lArg + | otherwise -> do + shouldReduce1 <- orM [ shouldReduce ctx + , isUntranslatableType_not_poly aTy ] + if shouldReduce1 + then (`mkTicks` ticks) <$> reduceAppend is0 n m aTy lArg rArg + else return e + _ -> return e + "Clash.Sized.Vector.head" | argLen == 3 -> do + let [nTy,aTy] = Either.rights args + [vArg] = Either.lefts args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ shouldReduce ctx + , isUntranslatableType_not_poly aTy ] + if shouldReduce1 + then (`mkTicks` ticks) <$> reduceHead is0 (n+1) aTy vArg + else return e + _ -> return e + "Clash.Sized.Vector.tail" | argLen == 3 -> do + let [nTy,aTy] = Either.rights args + [vArg] = Either.lefts args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ shouldReduce ctx + , isUntranslatableType_not_poly aTy ] + if shouldReduce1 + then (`mkTicks` ticks) <$> reduceTail is0 (n+1) aTy vArg + else return e + _ -> return e + "Clash.Sized.Vector.last" | argLen == 3 -> do + let [nTy,aTy] = Either.rights args + [vArg] = Either.lefts args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ shouldReduce ctx + , isUntranslatableType_not_poly aTy + ] + if shouldReduce1 + then (`mkTicks` ticks) <$> reduceLast is0 (n+1) aTy vArg + else return e + _ -> return e + "Clash.Sized.Vector.init" | argLen == 3 -> do + let [nTy,aTy] = Either.rights args + [vArg] = Either.lefts args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ shouldReduce ctx + , isUntranslatableType_not_poly aTy ] + if shouldReduce1 + then (`mkTicks` ticks) <$> reduceInit is0 (n+1) aTy vArg + else return e + _ -> return e + "Clash.Sized.Vector.unconcat" | argLen == 6 -> do + let ([_knN,_sm,arg],[mTy,nTy,aTy]) = Either.partitionEithers args + case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of + (Right n, Right 0) -> (`mkTicks` ticks) <$> reduceUnconcat n 0 aTy arg + _ -> return e + "Clash.Sized.Vector.transpose" | argLen == 5 -> do + let ([_knN,arg],[mTy,nTy,aTy]) = Either.partitionEithers args + case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy)) of + (Right n, Right 0) -> (`mkTicks` ticks) <$> reduceTranspose n 0 aTy arg + _ -> return e + "Clash.Sized.Vector.replicate" | argLen == 4 -> do + let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ shouldReduce ctx + , isUntranslatableType_not_poly aTy + ] + if shouldReduce1 + then (`mkTicks` ticks) <$> reduceReplicate n aTy eTy vArg + else return e + _ -> return e + -- replace_int :: KnownNat n => Vec n a -> Int -> a -> Vec n a + "Clash.Sized.Vector.replace_int" | argLen == 6 -> do + let ([_knArg,vArg,iArg,aArg],[nTy,aTy]) = Either.partitionEithers args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ pure ultra + , shouldReduce ctx + , isUntranslatableType_not_poly aTy + ] + if shouldReduce1 + then (`mkTicks` ticks) <$> reduceReplace_int is0 n aTy eTy vArg iArg aArg + else return e + _ -> return e + + "Clash.Sized.Vector.index_int" | argLen == 5 -> do + let ([_knArg,vArg,iArg],[nTy,aTy]) = Either.partitionEithers args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ pure ultra + , shouldReduce ctx + , isUntranslatableType_not_poly aTy ] + if shouldReduce1 + then (`mkTicks` ticks) <$> reduceIndex_int is0 n aTy vArg iArg + else return e + _ -> return e + + "Clash.Sized.Vector.imap" | argLen == 6 -> do + let [nTy,argElTy,resElTy] = Either.rights args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ pure (ultra || n < 2) + , shouldReduce ctx + , anyM isUntranslatableType_not_poly [argElTy,resElTy] ] + if shouldReduce1 + then let [_,fun,arg] = Either.lefts args + in (`mkTicks` ticks) <$> reduceImap c n argElTy resElTy fun arg + else return e + _ -> return e + "Clash.Sized.Vector.dtfold" | argLen == 8 -> + let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args + in case runExcept (tyNatSize tcm nTy) of + Right n -> (`mkTicks` ticks) <$> reduceDTFold is0 n aTy lrFun brFun arg + _ -> return e + + "Clash.Sized.Vector.reverse" + | ultra + , ([vArg],[nTy,aTy]) <- Either.partitionEithers args + , Right n <- runExcept (tyNatSize tcm nTy) + -> (`mkTicks` ticks) <$> reduceReverse is0 n aTy vArg + + "Clash.Sized.RTree.tdfold" | argLen == 8 -> + let ([_kn,_motive,lrFun,brFun,arg],[_mTy,nTy,aTy]) = Either.partitionEithers args + in case runExcept (tyNatSize tcm nTy) of + Right n -> (`mkTicks` ticks) <$> reduceTFold is0 n aTy lrFun brFun arg + _ -> return e + "Clash.Sized.RTree.treplicate" | argLen == 4 -> do + let ([_sArg,vArg],[nTy,aTy]) = Either.partitionEithers args + case runExcept (tyNatSize tcm nTy) of + Right n -> do + shouldReduce1 <- orM [ shouldReduce ctx + , isUntranslatableType False aTy ] + if shouldReduce1 + then (`mkTicks` ticks) <$> reduceTReplicate n aTy eTy vArg + else return e + _ -> return e + "Clash.Sized.Internal.BitVector.split#" | argLen == 4 -> do + let ([_knArg,bvArg],[nTy,mTy]) = Either.partitionEithers args + case (runExcept (tyNatSize tcm nTy), runExcept (tyNatSize tcm mTy), tv) of + (Right n, Right m, TyConApp tupTcNm [lTy,rTy]) + | n == 0 -> do + let (Just tupTc) = lookupUniqMap tupTcNm tcm + [tupDc] = tyConDataCons tupTc + tup = mkApps (Data tupDc) + [Right lTy + ,Right rTy + ,Left bvArg + ,Left (removedTm rTy) + ] + + changed (mkTicks tup ticks) + | m == 0 -> do + let (Just tupTc) = lookupUniqMap tupTcNm tcm + [tupDc] = tyConDataCons tupTc + tup = mkApps (Data tupDc) + [Right lTy + ,Right rTy + ,Left (removedTm lTy) + ,Left bvArg + ] + + changed (mkTicks tup ticks) + _ -> return e + "Clash.Sized.Internal.BitVector.eq#" + | ([_,_],[nTy]) <- Either.partitionEithers args + , Right 0 <- runExcept (tyNatSize tcm nTy) + , TyConApp boolTcNm [] <- tv + -> let (Just boolTc) = lookupUniqMap boolTcNm tcm + [_falseDc,trueDc] = tyConDataCons boolTc + in changed (mkTicks (Data trueDc) ticks) + _ -> return e + where + isUntranslatableType_not_poly t = do + u <- isUntranslatableType False t + if u + then return (null $ Lens.toListOf typeFreeVars t) + else return False + +reduceNonRepPrim _ e = return e +{-# SCC reduceNonRepPrim #-} + +-- | This transformation lifts applications of global binders out of +-- alternatives of case-statements. +-- +-- e.g. It converts: +-- +-- @ +-- case x of +-- A -> f 3 y +-- B -> f x x +-- C -> h x +-- @ +-- +-- into: +-- +-- @ +-- let f_arg0 = case x of {A -> 3; B -> x} +-- f_arg1 = case x of {A -> y; B -> x} +-- f_out = f f_arg0 f_arg1 +-- in case x of +-- A -> f_out +-- B -> f_out +-- C -> h x +-- @ +disjointExpressionConsolidation :: HasCallStack => NormRewrite +disjointExpressionConsolidation ctx@(TransformContext is0 _) e@(Case _scrut _ty _alts@(_:_:_)) = do + (_,collected) <- collectGlobals is0 [] [] e + let disJoint = filter (isDisjoint . snd . snd) collected + if null disJoint + then return e + else do + exprs <- mapM (mkDisjointGroup is0) disJoint + tcm <- Lens.view tcCache + lids <- Monad.zipWithM (mkFunOut is0 tcm) disJoint exprs + let substitution = zip (map fst disJoint) (map Var lids) + subsMatrix = l2m substitution + (exprs',_) <- unzip <$> Monad.zipWithM + (\s (e',seen) -> collectGlobals is0 s seen e') + subsMatrix + exprs + (e',_) <- collectGlobals is0 substitution [] e + let lb = Letrec (zip lids exprs') e' + lb' <- bottomupR deadCode ctx lb + changed lb' + where + mkFunOut isN tcm (fun,_) (e',_) = do + let ty = termType tcm e' + nm = case collectArgs fun of + (Var v,_) -> nameOcc (varName v) + (Prim p,_) -> primName p + _ -> "complex_expression_" + nm'' = last (Text.splitOn "." nm) `Text.append` "Out" + mkInternalVar isN nm'' ty + + l2m = go [] + where + go _ [] = [] + go xs (y:ys) = (xs ++ ys) : go (xs ++ [y]) ys + +disjointExpressionConsolidation _ e = return e +{-# SCC disjointExpressionConsolidation #-} + +-- | Given a function in the desired normal form, inline all the following +-- let-bindings: +-- +-- Let-bindings with an internal name that is only used once, where it binds: +-- * a primitive that will be translated to an HDL expression (as opposed to +-- a HDL declaration) +-- * a projection case-expression (1 alternative) +-- * a data constructor +-- * I/O actions +inlineCleanup :: HasCallStack => NormRewrite +inlineCleanup (TransformContext is0 _) (Letrec binds body) = do + prims <- Lens.use (extra.primitives) + -- For all let-bindings, count the number of times they are referenced. + -- We only inline let-bindings which are referenced only once, otherwise + -- we would lose sharing. + let is1 = extendInScopeSetList is0 (map fst binds) + bindsFvs = map (\(v,e) -> (v,((v,e),countFreeOccurances e))) binds + allOccs = List.foldl' (unionVarEnvWith (+)) emptyVarEnv + $ map (snd.snd) bindsFvs + bodyFVs = Lens.foldMapOf freeLocalIds unitVarSet body + (il,keep) = List.partition (isInteresting allOccs prims bodyFVs) + bindsFvs + keep' = inlineBndrsCleanup is1 (mkVarEnv il) emptyVarEnv + $ map snd keep + + if | null il -> return (Letrec binds body) + | null keep' -> changed body + | otherwise -> changed (Letrec keep' body) + where + -- Determine whether a let-binding is interesting to inline + isInteresting + :: VarEnv Int + -> CompiledPrimMap + -> VarSet + -> (Id,((Id, Term), VarEnv Int)) + -> Bool + isInteresting allOccs prims bodyFVs (id_,((_,(fst.collectArgs) -> tm),_)) + | nameSort (varName id_) /= User + , id_ `notElemVarSet` bodyFVs + = case tm of + Prim pInfo + | let nm = primName pInfo + , Just (extractPrim -> Just p@(BlackBox {})) <- HashMap.lookup nm prims + , TExpr <- kind p + , Just occ <- lookupVarEnv id_ allOccs + , occ < 2 + -> True + | otherwise + -> primName pInfo `elem` ["Clash.Explicit.SimIO.bindSimIO#"] + Case _ _ [_] -> True + Data _ -> True + Case _ aTy (_:_:_) + | TyConApp (nameOcc -> "Clash.Explicit.SimIO.SimIO") _ <- tyView aTy + -> True + _ -> False + | id_ `notElemVarSet` bodyFVs + = case tm of + Prim pInfo + | primName pInfo `elem` [ "Clash.Explicit.SimIO.openFile" + , "Clash.Explicit.SimIO.fgetc" + , "Clash.Explicit.SimIO.feof" + ] + , Just occ <- lookupVarEnv id_ allOccs + , occ < 2 + -> True + | otherwise + -> primName pInfo `elem` ["Clash.Explicit.SimIO.bindSimIO#"] + Case _ _ [(DataPat dcE _ _,_)] + -> let nm = (nameOcc (dcName dcE)) + in -- Inlines WW projection that exposes internals of the BitVector types + nm == "Clash.Sized.Internal.BitVector.BV" || + nm == "Clash.Sized.Internal.BitVector.Bit" || + -- Inlines projections out of constraint-tuples (e.g. HiddenClockReset) + "GHC.Classes" `Text.isPrefixOf` nm + Case _ aTy (_:_:_) + | TyConApp (nameOcc -> "Clash.Explicit.SimIO.SimIO") _ <- tyView aTy + -> True + _ -> False + + isInteresting _ _ _ _ = False + +inlineCleanup _ e = return e +{-# SCC inlineCleanup #-} + +-- | Mark to track progress of 'reduceBindersCleanup' +data Mark = Temp | Done | Rec + +-- | Used by 'inlineCleanup' to inline binders that we want to inline into the +-- binders that we want to keep. +inlineBndrsCleanup + :: InScopeSet + -- ^ Current InScopeSet + -> VarEnv ((Id,Term),VarEnv Int) + -- ^ Original let-binders with their free variables (+ #occurrences), that we + -- want to inline + -> VarEnv ((Id,Term),VarEnv Int,Mark) + -- ^ Processed let-binders with their free variables and a tag to mark the + -- progress: + -- * Temp: Will eventually form a recursive cycle + -- * Done: Processed, non-recursive + -- * Rec: Processed, recursive + -> [((Id,Term),VarEnv Int)] + -- ^ The let-binders with their free variables (+ #occurrences), that we want + -- to keep + -> [(Id,Term)] +inlineBndrsCleanup isN origInl = go + where + go doneInl [] = + -- If some of the let-binders that we wanted to inline turn out to be + -- recursive, then we have to keep those around as well, as we weren't able + -- to inline them. + [ (v,e) | ((v,e),_,Rec) <- eltsVarEnv doneInl ] + go !doneInl (((v,e),eFVs):il) = + let (sM,_,doneInl1) = foldlWithUniqueVarEnv' + (reduceBindersCleanup isN origInl) + (Nothing, emptyVarEnv, doneInl) + eFVs + e1 = case sM of + Nothing -> e + Just s -> substTm "inlineBndrsCleanup" s e + in (v,e1):go doneInl1 il +{-# SCC inlineBndrsCleanup #-} + +-- | Used (transitively) by 'inlineCleanup' inline to-inline let-binders into +-- the other to-inline let-binders. +reduceBindersCleanup + :: InScopeSet + -- ^ Current InScopeSet + -> VarEnv ((Id,Term),VarEnv Int) + -- ^ Original let-binders with their free variables (+ #occurrences) + -> (Maybe Subst,VarEnv Int,VarEnv ((Id,Term),VarEnv Int,Mark)) + -- ^ Accumulated: + -- + -- 1. (Maybe) the build up substitution so far + -- 2. The free variables of the range of the substitution + -- 3. Processed let-binders with their free variables and a tag to mark + -- the progress: + -- * Temp: Will eventually form a recursive cycle + -- * Done: Processed, non-recursive + -- * Rec: Processed, recursive + -> Unique + -- ^ The unique of the let-binding that we want to simplify + -> Int + -- ^ Ignore, artifact of 'foldlWithUniqueVarEnv' + -> (Maybe Subst,VarEnv Int,VarEnv ((Id,Term),VarEnv Int,Mark)) + -- ^ Same as the third argument +reduceBindersCleanup isN origInl (!substM,!substFVs,!doneInl) u _ = case lookupVarEnvDirectly u doneInl of + Nothing -> case lookupVarEnvDirectly u origInl of + Nothing -> + -- let-binding not found, cannot extend the substitution + (substM,substFVs,doneInl) + Just ((v,e),eFVs) -> + -- Simplify the transitive dependencies + let (sM,substFVsE,doneInl1) = + foldlWithUniqueVarEnv' + (reduceBindersCleanup isN origInl) + ( Nothing + -- It's okay/needed to over-approximate the free variables of + -- the range of the new substitution by including the free + -- variables of the original let-binder, because this set of + -- free variables is only used to check whether let-binding will + -- become self-recursive after applying the substitution. + -- + -- That is, it was already self-recursive, or becomes + -- self-recursive after applying the substitution because it was + -- part of a recursive group. And we do not want to inline + -- recursive binders. + , eFVs + -- Temporarily extend the processing environment with the + -- let-binding so we don't end up in a loop in case there is a + -- recursive group. + , extendVarEnv v ((v,e),eFVs,Temp) doneInl) + eFVs + + e1 = case sM of + Nothing -> e + Just s -> substTm "reduceBindersCleanup" s e + in if v `elemVarEnv` substFVsE then + -- We cannot inline recursive let-bindings, so we do not extend + -- the substitution environment. + ( substM + , substFVs + -- And we explicitly mark the let-binding as recursive in the + -- processing environment. So that it will be kept around at the + -- end of 'inlineCleanup' + , extendVarEnv v ((v,e1),substFVsE,Rec) doneInl1 + ) + else + -- Extend the substitution + ( Just (extendIdSubst (Maybe.fromMaybe (mkSubst isN) substM) v e1) + , unionVarEnv substFVsE substFVs + -- Mark the let-binding a fully "reduced", so we don't repeat + -- this process when we encounter it again. + , extendVarEnv v ((v,e1),substFVsE,Done) doneInl1 + ) + -- It's already been process, just extend the substitution environment + Just ((v,e),eFVs,Done) -> + ( Just (extendIdSubst (Maybe.fromMaybe (mkSubst isN) substM) v e) + , unionVarEnv eFVs substFVs + , doneInl + ) + + -- It's either recursive (Rec), or part of a recursive group (Temp) where we + -- originally entered a different part of the cycle. Regardless, we do not + -- extend the substitution environment. + Just _ -> + ( substM + , substFVs + , doneInl + ) +{-# SCC reduceBindersCleanup #-} + +-- | Flatten's letrecs after `inlineCleanup` +-- +-- `inlineCleanup` sometimes exposes additional possibilities for `caseCon`, +-- which then introduces let-bindings in what should be ANF. This transformation +-- flattens those nested let-bindings again. +-- +-- NB: must only be called in the cleaning up phase. +flattenLet :: HasCallStack => NormRewrite +flattenLet (TransformContext is0 _) (Letrec binds body) = do + let is1 = extendInScopeSetList is0 (map fst binds) + bodyOccs = Lens.foldMapByOf + freeLocalIds (unionVarEnvWith (+)) + emptyVarEnv (`unitVarEnv` (1 :: Int)) + body + (is2,binds1) <- second concat <$> mapAccumLM go is1 binds + case binds1 of + -- inline binders into the body when there's only a single binder, and only + -- if that binder doesn't perform any work or is only used once in the body + [(id1,e1)] | Just occ <- lookupVarEnv id1 bodyOccs, isWorkFree e1 || occ < 2 -> + if id1 `localIdOccursIn` e1 + -- Except when the binder is recursive! + then return (Letrec binds1 body) + else let subst = extendIdSubst (mkSubst is2) id1 e1 + in changed (substTm "flattenLet" subst body) + _ -> return (Letrec binds1 body) + where + go :: InScopeSet -> LetBinding -> NormalizeSession (InScopeSet,[LetBinding]) + go isN (id1,collectTicks -> (Letrec binds1 body1,ticks)) = do + let bs1 = map fst binds1 + let (binds2,body2,isN1) = + -- We need to deshadow because we're merging nested let-expressions + -- into a single let-expression: and within a let-expression, the + -- bindings are not allowed to shadow each-other. Of course, we + -- only need to deshadow if any shadowing is happening in the + -- first place. + -- + -- This is much better than blindly calling freshenTm, and saves + -- almost 30% run-time of the normalization phase on some examples. + if any (`elemInScopeSet` isN) bs1 then + let Letrec bindsN bodyN = deShadowTerm isN (Letrec binds1 body1) + in (bindsN,bodyN,extendInScopeSetList isN (map fst bindsN)) + else + (binds1,body1,extendInScopeSetList isN bs1) + let bodyOccs = Lens.foldMapByOf + freeLocalIds (unionVarEnvWith (+)) + emptyVarEnv (`unitVarEnv` (1 :: Int)) + body2 + (srcTicks,nmTicks) = partitionTicks ticks + -- Distribute the name ticks of the let-expression over all the bindings + (isN1,) . map (second (`mkTicks` nmTicks)) <$> case binds2 of + -- inline binders into the body when there's only a single binder, and + -- only if that binder doesn't perform any work or is only used once in + -- the body + [(id2,e2)] | Just occ <- lookupVarEnv id2 bodyOccs, isWorkFree e2 || occ < 2 -> + if id2 `localIdOccursIn` e2 + -- Except when the binder is recursive! + then changed ([(id2,e2),(id1, body2)]) + else let subst = extendIdSubst (mkSubst isN1) id2 e2 + in changed [(id1 + -- Only apply srcTicks to the body + ,mkTicks (substTm "flattenLetGo" subst body2) + srcTicks)] + bs -> changed (bs ++ [(id1 + -- Only apply srcTicks to the body + ,mkTicks body2 srcTicks)]) + go isN b = return (isN,[b]) + +flattenLet _ e = return e +{-# SCC flattenLet #-} + +-- | Worker function of 'separateArguments'. +separateLambda + :: TyConMap + -> TransformContext + -> Id + -- ^ Lambda binder + -> Term + -- ^ Lambda body + -> Maybe Term + -- ^ If lambda is split up, this function returns a Just containing the new term +separateLambda tcm ctx@(TransformContext is0 _) b eb0 = + case shouldSplit tcm (varType b) of + Just (dc,argTys@(_:_:_)) -> + let + nm = mkDerivedName ctx (nameOcc (varName b)) + bs0 = map (`mkLocalId` nm) argTys + (is1, bs1) = List.mapAccumL newBinder is0 bs0 + subst = extendIdSubst (mkSubst is1) b (mkApps dc (map (Left . Var) bs1)) + eb1 = substTm "separateArguments" subst eb0 + in + Just (mkLams eb1 bs1) + _ -> + Nothing + where + newBinder isN0 x = + let + x' = uniqAway isN0 x + isN1 = extendInScopeSet isN0 x' + in + (isN1, x') +{-# SCC separateLambda #-} + +-- | Split apart (global) function arguments that contain types that we +-- want to separate off, e.g. Clocks. Works on both the definition side (i.e. the +-- lambda), and the call site (i.e. the application of the global variable). e.g. +-- turns +-- +-- > f :: (Clock System, Reset System) -> Signal System Int +-- +-- into +-- +-- > f :: Clock System -> Reset System -> Signal System Int +separateArguments :: HasCallStack => NormRewrite +separateArguments ctx e0@(Lam b eb) = do + tcm <- Lens.view tcCache + case separateLambda tcm ctx b eb of + Just e1 -> changed e1 + Nothing -> return e0 + +separateArguments (TransformContext is0 _) e@(collectArgsTicks -> (Var g, args, ticks)) + | isGlobalId g = do + -- We ensure that both the type of the global variable reference is updated + -- to take into account the changed arguments, and that we apply the global + -- function with the split apart arguments. + let (argTys0,resTy) = splitFunForallTy (varType g) + (concat -> args1, Monoid.getAny -> hasChanged) + <- listen (mapM (uncurry splitArg) (zip argTys0 args)) + if hasChanged then + let (argTys1,args2) = unzip args1 + gTy = mkPolyFunTy resTy argTys1 + in return (mkApps (mkTicks (Var g {varType = gTy}) ticks) args2) + else + return e + + where + -- Split a single argument + splitArg + :: Either TyVar Type + -- The quantifier/function argument type of the global variable + -> Either Term Type + -- The applied type argument or term argument + -> NormalizeSession [(Either TyVar Type,Either Term Type)] + splitArg tv arg@(Right _) = return [(tv,arg)] + splitArg ty arg@(Left tmArg) = do + tcm <- Lens.view tcCache + let argTy = termType tcm tmArg + case shouldSplit tcm argTy of + Just (_,argTys@(_:_:_)) -> do + tmArgs <- mapM (mkSelectorCase ($(curLoc) ++ "splitArg") is0 tcm tmArg 1) + [0..length argTys - 1] + changed (map ((ty,) . Left) tmArgs) + _ -> + return [(ty,arg)] + +separateArguments _ e = return e +{-# SCC separateArguments #-} + +-- | Remove all undefined alternatives from case expressions, replacing them +-- with the value of another defined alternative. If there is one defined +-- alternative, the entire expression is replaced with that alternative. If +-- there are no defined alternatives, the entire expression is replaced with +-- a call to 'errorX'. +-- +-- e.g. It converts +-- +-- case x of +-- D1 a -> f a +-- D2 -> undefined +-- D3 -> undefined +-- +-- to +-- +-- let subj = x +-- a = case subj of +-- D1 a -> field0 +-- in f a +-- +-- where fieldN is an internal variable referring to the nth argument of a +-- data constructor. +-- +xOptimize :: HasCallStack => NormRewrite +xOptimize (TransformContext is0 _) e@(Case subj ty alts) = do + runXOpt <- Lens.view aggressiveXOpt + + if runXOpt then do + defPart <- partitionM (isPrimError . snd) alts + + case defPart of + ([], _) -> return e + (_, []) -> changed (Prim (PrimInfo "Clash.XException.errorX" ty WorkConstant)) + (_, [alt]) -> xOptimizeSingle is0 subj alt + (_, defs) -> xOptimizeMany is0 subj ty defs + else + return e + +xOptimize _ e = return e +{-# SCC xOptimize #-} + +-- Return an expression equivalent to the alternative given. When only one +-- alternative is defined the result of this function is used to replace the +-- case expression. +-- +xOptimizeSingle :: InScopeSet -> Term -> Alt -> NormalizeSession Term +xOptimizeSingle is subj (DataPat dc tvs vars, expr) = do + tcm <- Lens.view tcCache + subjId <- mkInternalVar is "subj" (termType tcm subj) + + let fieldTys = fmap varType vars + lets <- Monad.zipWithM (mkFieldSelector is subjId dc tvs fieldTys) vars [0..] + + changed (Letrec ((subjId, subj) : lets) expr) + +xOptimizeSingle _ _ (_, expr) = changed expr + +-- Given a list of alternatives which are defined, create a new case +-- expression which only ever returns a defined value. +-- +xOptimizeMany + :: HasCallStack + => InScopeSet + -> Term + -> Type + -> [Alt] + -> NormalizeSession Term +xOptimizeMany is subj ty defs@(d:ds) + | isAnyDefault defs = changed (Case subj ty defs) + | otherwise = do + newAlt <- xOptimizeSingle is subj d + changed (Case subj ty $ ds <> [(DefaultPat, newAlt)]) + where + isAnyDefault :: [Alt] -> Bool + isAnyDefault = any ((== DefaultPat) . fst) + +xOptimizeMany _ _ _ [] = + error $ $(curLoc) ++ "Report as bug: xOptimizeMany error: No defined alternatives" + +mkFieldSelector + :: MonadUnique m + => InScopeSet + -> Id + -- ^ subject id + -> DataCon + -> [TyVar] + -> [Type] + -- ^ concrete types of fields + -> Id + -> Int + -> m LetBinding +mkFieldSelector is0 subj dc tvs fieldTys nm index = do + fields <- mapM (\ty -> mkInternalVar is0 "field" ty) fieldTys + let alt = (DataPat dc tvs fields, Var $ fields !! index) + return (nm, Case (Var subj) (fieldTys !! index) [alt]) + +-- Check whether a term is really a black box primitive representing an error. +-- Such values are undefined and are removed in X Optimization. +-- +isPrimError :: Term -> NormalizeSession Bool +isPrimError (collectArgs -> (Prim pInfo, _)) = do + prim <- Lens.use (extra . primitives . Lens.at (primName pInfo)) + + case prim >>= extractPrim of + Just p -> return (isErr p) + Nothing -> return False + where + isErr BlackBox{template=(BBTemplate [Err _])} = True + isErr _ = False + +isPrimError _ = return False + diff --git a/src/Clash/Normalize/Types.hs b/src/Clash/Normalize/Types.hs --- a/src/Clash/Normalize/Types.hs +++ b/src/Clash/Normalize/Types.hs @@ -7,7 +7,7 @@ Types used in Normalize modules -} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Normalize.Types where @@ -68,6 +68,8 @@ -- ^ High-effort normalization session, trading performance improvement for -- potentially much longer compile times. Follows the 'Clash.Driver.opt_ultra' -- flag. + , _inlineWFCacheLimit :: !Word + -- ^ At what size do we cache normalized work-free top-level binders. } makeLenses ''NormalizeState diff --git a/src/Clash/Normalize/Util.hs b/src/Clash/Normalize/Util.hs --- a/src/Clash/Normalize/Util.hs +++ b/src/Clash/Normalize/Util.hs @@ -6,11 +6,9 @@ Utility functions used by the normalisation transformations -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} module Clash.Normalize.Util ( ConstantSpecInfo(..) @@ -29,10 +27,13 @@ , normalizeTopLvlBndr , rewriteExpr , removedTm + , mkInlineTick + , substWithTyEq + , tvSubstWithTyEq ) where -import Control.Lens ((&),(+~),(%=),(^.),_4,(.=)) +import Control.Lens ((&),(+~),(%=),(.=)) import qualified Control.Lens as Lens import Data.Bifunctor (bimap) import Data.Either (lefts) @@ -40,26 +41,33 @@ import qualified Data.Map as Map import qualified Data.HashMap.Strict as HashMapS import Data.Text (Text) +import qualified Data.Text as Text -import BasicTypes (InlineSpec) +import PrelNames (eqTyConKey) +import Unique (getKey) import Clash.Annotations.Primitive (extractPrim) import Clash.Core.FreeVars (globalIds, hasLocalFreeVars, globalIdOccursIn) +import Clash.Core.Name (Name(nameOcc,nameUniq)) import Clash.Core.Pretty (showPpr) -import Clash.Core.Subst (deShadowTerm) +import Clash.Core.Subst + (deShadowTerm, extendTvSubst, extendTvSubstList, mkSubst, substTm, substTy, + substId, extendIdSubst) import Clash.Core.Term (Context, CoreContext(AppArg), PrimInfo (..), Term (..), WorkInfo (..), - TickInfo, collectArgs, collectArgsTicks) + TickInfo(NameMod), NameMod(PrefixName), collectArgs, collectArgsTicks) import Clash.Core.TyCon (TyConMap) -import Clash.Core.Type (Type, undefinedTy) +import Clash.Core.Type + (Type(LitTy, VarTy), LitTy(SymTy), TypeView (..), tyView, undefinedTy, + splitFunForallTy, splitTyConAppM, mkPolyFunTy) import Clash.Core.Util (isClockOrReset, isPolyFun, termType, mkApps, mkTicks) -import Clash.Core.Var (Id, Var (..), isGlobalId) +import Clash.Core.Var (Id, TyVar, Var (..), isGlobalId) import Clash.Core.VarEnv (VarEnv, emptyInScopeSet, emptyVarEnv, extendVarEnv, extendVarEnvWith, lookupVarEnv, unionVarEnvWith, unitVarEnv, extendInScopeSetList) -import Clash.Driver.Types (BindingMap, DebugLevel (..)) +import Clash.Driver.Types (BindingMap, Binding(..), DebugLevel (..)) import {-# SOURCE #-} Clash.Normalize.Strategy (normalization) import Clash.Normalize.Types import Clash.Primitives.Util (constantArgs) @@ -83,6 +91,7 @@ -- ^ Yields @DontCare@ for if given primitive name is not found, if the -- argument does not exist, or if the argument was not mentioned by the -- blackbox. +isConstantArg "Clash.Explicit.SimIO.mealyIO" i = pure (i == 2 || i == 3) isConstantArg nm i = do argMap <- Lens.use (extra.primitiveArgs) case Map.lookup nm argMap of @@ -170,11 +179,11 @@ fBodyM <- lookupVarEnv f <$> Lens.use bindings case fBodyM of Nothing -> return False - Just (_,_,_,fBody) -> do + Just b -> do -- There are no global mutually-recursive functions, only self-recursive -- ones, so checking whether 'f' is part of the free variables of the -- body of 'f' is sufficient. - let isR = f `globalIdOccursIn` fBody + let isR = f `globalIdOccursIn` bindingTerm b (extra.recursiveComponents) %= extendVarEnv f isR return isR @@ -290,17 +299,17 @@ -- primitive's workinfo. if isClockOrReset tcm (termType tcm e) then case collectArgs e of - (Prim "Clash.Transformations.removedArg" _, _) -> - pure (constantCsr e) - _ -> do - bindCsr ctx e + (Prim p, _) + | primName p == "Clash.Transformations.removedArg" -> + pure (constantCsr e) + _ -> bindCsr ctx e else case collectArgsTicks e of (dc@(Data _), args, ticks) -> mergeCsrs ctx ticks e (mkApps dc) args -- TODO: Work with prim's WorkInfo? - (prim@(Prim _ _), args, ticks) -> do + (prim@(Prim _), args, ticks) -> do csr <- mergeCsrs ctx ticks e (mkApps prim) args if null (csrNewBindings csr) then pure csr @@ -346,7 +355,7 @@ | Nothing <- lookupUniqMap root cg , Just rootTm <- lookupUniqMap root bndrs = let used = Lens.foldMapByOf globalIds (unionVarEnvWith (+)) - emptyVarEnv (`unitUniqMap` 1) (rootTm ^. _4) + emptyVarEnv (`unitUniqMap` 1) (bindingTerm rootTm) cg' = extendUniqMap root used cg in List.foldl' go cg' (keysUniqMap used) go cg _ = cg @@ -388,10 +397,11 @@ | otherwise -> False normalizeTopLvlBndr - :: Id - -> (Id, SrcSpan, InlineSpec, Term) - -> NormalizeSession (Id, SrcSpan, InlineSpec, Term) -normalizeTopLvlBndr nm (nm',sp,inl,tm) = makeCachedU nm (extra.normalized) $ do + :: Bool + -> Id + -> Binding + -> NormalizeSession Binding +normalizeTopLvlBndr isTop nm (Binding nm' sp inl tm) = makeCachedU nm (extra.normalized) $ do tcm <- Lens.view tcCache let nmS = showPpr (varName nm) -- We deshadow the term because sometimes GHC gives us @@ -399,16 +409,83 @@ -- global binder, sometimes causing the inliner to go -- into a loop. Deshadowing freshens all the bindings -- to avoid this. - -- - -- Additionally, it allows for a much cheaper `appProp` - -- transformation, see Note [AppProp no-shadow invariant] let tm1 = deShadowTerm emptyInScopeSet tm + tm2 = if isTop then substWithTyEq tm1 else tm1 old <- Lens.use curFun - tm2 <- rewriteExpr ("normalization",normalization) (nmS,tm1) (nm',sp) + tm3 <- rewriteExpr ("normalization",normalization) (nmS,tm2) (nm',sp) curFun .= old - let ty' = termType tcm tm2 - return (nm' {varType = ty'},sp,inl,tm2) + let ty' = termType tcm tm3 + return (Binding nm'{varType = ty'} sp inl tm3) +-- | Turn type equality constraints into substitutions and apply them. +-- +-- So given: +-- +-- > /\dom . \(eq : dom ~ "System") . \(eta : Signal dom Bool) . eta +-- +-- we create the substitution [dom := "System"] and apply it to create: +-- +-- > \(eq : "System" ~ "System") . \(eta : Signal "System" Bool) . eta +-- +-- __NB:__ Users of this function should ensure it's only applied to TopEntities +substWithTyEq + :: Term + -> Term +substWithTyEq e0 = go [] False [] e0 + where + go + :: [TyVar] + -> Bool + -> [Id] + -> Term + -> Term + go tvs changed ids_ (TyLam tv e) = go (tv:tvs) changed ids_ e + go tvs changed ids_ (Lam v e) + | TyConApp (nameUniq -> tcUniq) (tvFirst -> Just (tv, ty)) <- tyView (varType v) + , tcUniq == getKey eqTyConKey + , tv `elem` tvs + = let + subst0 = extendTvSubst (mkSubst emptyInScopeSet) tv ty + subst1 = extendIdSubst subst0 v (removedTm (varType v)) + in go (tvs List.\\ [tv]) True (substId subst0 v : ids_) (substTm "substWithTyEq e" subst1 e) + | otherwise = go tvs changed (v:ids_) e + go tvs True ids_ e = + let + e1 = List.foldl' (flip TyLam) e tvs + e2 = List.foldl' (flip Lam) e1 ids_ + in e2 + go _ False _ _ = e0 + +-- Type equality (~) is symmetrical, so users could write: (dom ~ System) or (System ~ dom) +tvFirst :: [Type] -> Maybe (TyVar, Type) +tvFirst [_, VarTy tv, ty] = Just (tv, ty) +tvFirst [_, ty, VarTy tv] = Just (tv, ty) +tvFirst _ = Nothing + +-- | The type equivalent of 'substWithTyEq' +tvSubstWithTyEq + :: Type + -> Type +tvSubstWithTyEq ty0 = go [] args0 + where + (args0,tyRes) = splitFunForallTy ty0 + + go :: [(TyVar,Type)] -> [Either TyVar Type] -> Type + go eqs (Right arg : args) + | Just (tc,tcArgs) <- splitTyConAppM arg + , nameUniq tc == getKey eqTyConKey + , Just eq <- tvFirst tcArgs + = go (eq:eqs) args + | otherwise = go eqs args + go eqs (Left _tv : args) + = go eqs args -- drop (ForAll) tv + go [] [] = ty0 -- no eq constraints, returning original type + go eqs [] = substTy subst ty2 + where + subst = extendTvSubstList (mkSubst emptyInScopeSet) eqs + args2 = args0 List.\\ (map (Left . fst) eqs) + ty2 = mkPolyFunTy tyRes args2 + -- | Rewrite a term according to the provided transformation rewriteExpr :: (String,NormRewrite) -- ^ Transformation to apply -> (String,Term) -- ^ Term to transform @@ -431,4 +508,20 @@ :: Type -> Term removedTm = - TyApp (Prim "Clash.Transformations.removedArg" (PrimInfo undefinedTy WorkNever)) + TyApp (Prim (PrimInfo "Clash.Transformations.removedArg" undefinedTy WorkNever)) + +-- | A tick to prefix an inlined expression with it's original name. +-- For example, given +-- +-- foo = bar -- ... +-- bar = baz -- ... +-- baz = quuz -- ... +-- +-- if bar is inlined into foo, then the name of the component should contain +-- the name of the inlined component. This tick ensures that the component in +-- foo is called bar_baz instead of just baz. +-- +mkInlineTick :: Id -> TickInfo +mkInlineTick n = NameMod PrefixName (LitTy . SymTy $ toStr n) + where + toStr = Text.unpack . snd . Text.breakOnEnd "." . nameOcc . varName diff --git a/src/Clash/Primitives/GHC/Int.hs b/src/Clash/Primitives/GHC/Int.hs --- a/src/Clash/Primitives/GHC/Int.hs +++ b/src/Clash/Primitives/GHC/Int.hs @@ -5,9 +5,8 @@ Blackbox generation for GHC.Int.IntX# data constructors. (System)Verilog only! -} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module Clash.Primitives.GHC.Int (intTF) where diff --git a/src/Clash/Primitives/Intel/ClockGen.hs b/src/Clash/Primitives/Intel/ClockGen.hs --- a/src/Clash/Primitives/Intel/ClockGen.hs +++ b/src/Clash/Primitives/Intel/ClockGen.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ViewPatterns #-} module Clash.Primitives.Intel.ClockGen where @@ -15,10 +16,12 @@ import Clash.Netlist.BlackBox.Util import Clash.Netlist.Id import Clash.Netlist.Types +import Clash.Netlist.Util hiding (mkUniqueIdentifier) import Control.Monad.State import Data.Semigroup.Monad +import qualified Data.String.Interpolate.IsString as I import Data.Text.Prettyprint.Doc.Extra import qualified Data.Text as TextS @@ -26,25 +29,45 @@ altpllTF :: TemplateFunction altpllTF = TemplateFunction used valid altpllTemplate where - used = [0,1,2] + used = [0..4] valid bbCtx - | [(nm,_,_),_,_] <- bbInputs bbCtx + | [_,_,(nm,_,_),_,_] <- bbInputs bbCtx , Just _ <- exprToString nm , (Identifier _ Nothing,Product {}) <- bbResult bbCtx = True valid _ = False +altpllQsysTF :: TemplateFunction +altpllQsysTF = TemplateFunction used valid altpllQsysTemplate + where + used = [0..4] + valid bbCtx + | [_,_,(nm,_,_),_,_] <- bbInputs bbCtx + , Just _ <- exprToString nm + , (Identifier _ Nothing,Product {}) <- bbResult bbCtx + = True + valid _ = False + alteraPllTF :: TemplateFunction alteraPllTF = TemplateFunction used valid alteraPllTemplate where - used = [1,2,3] + used = [1..20] valid bbCtx - | [_,(nm,_,_),_,_] <- bbInputs bbCtx + | ((nm,_,_):_) <- drop 3 (bbInputs bbCtx) , Just _ <- exprToString nm - , (Identifier _ Nothing,Product {}) <- bbResult bbCtx = True valid _ = False +alteraPllQsysTF :: TemplateFunction +alteraPllQsysTF = TemplateFunction used valid alteraPllQsysTemplate + where + used = [1..20] + valid bbCtx + | ((nm,_,_):_) <- drop 3 (bbInputs bbCtx) + , Just _ <- exprToString nm + = True + valid _ = False + alteraPllTemplate :: Backend s => BlackBoxContext @@ -53,14 +76,14 @@ let mkId = mkUniqueIdentifier Basic locked <- mkId "locked" pllLock <- mkId "pllLock" - alteraPll <- mkId "alteraPll" - alteraPll_inst <- mkId "alterPll_inst" + alteraPll <- mkId "altera_pll_block" + alteraPll_inst <- mkId instname0 clocks <- traverse (mkUniqueIdentifier Extended) [TextS.pack ("pllOut" ++ show n) | n <- [0..length tys - 1]] getMon $ blockDecl alteraPll $ concat [[ NetDecl Nothing locked rstTy - , NetDecl Nothing pllLock Bool] + , NetDecl' Nothing Reg pllLock (Right Bool) Nothing] ,[ NetDecl Nothing clkNm ty | (clkNm,ty) <- zip clocks tys] ,[ InstDecl Comp Nothing compName alteraPll_inst [] $ concat [[(Identifier "refclk" Nothing,In,clkTy,clk) @@ -78,10 +101,11 @@ ] ] where - [_,(nm,_,_),(clk,clkTy,_),(rst,rstTy,_)] = bbInputs bbCtx - (Identifier result Nothing,resTy@(Product _ _ (tail -> tys))) = bbResult bbCtx + (Identifier result Nothing,resTy@(Product _ _ (init -> tys))) = bbResult bbCtx + [(nm,_,_),(clk,clkTy,_),(rst,rstTy,_)] = drop 3 (bbInputs bbCtx) Just nm' = exprToString nm - compName = TextS.pack nm' + instname0 = TextS.pack nm' + compName = head (bbQsysIncName bbCtx) altpllTemplate :: Backend s @@ -92,14 +116,14 @@ pllOut <- mkId "pllOut" locked <- mkId "locked" pllLock <- mkId "pllLock" - alteraPll <- mkId "altpll" - alteraPll_inst <- mkId "altpll_inst" + alteraPll <- mkId "altpll_block" + alteraPll_inst <- mkId instname0 getMon $ blockDecl alteraPll [ NetDecl Nothing locked Bit - , NetDecl Nothing pllLock Bool + , NetDecl' Nothing Reg pllLock (Right Bool) Nothing , NetDecl Nothing pllOut clkOutTy , InstDecl Comp Nothing compName alteraPll_inst [] - [(Identifier "inclk0" Nothing,In,clkTy,clk) + [(Identifier "clk" Nothing,In,clkTy,clk) ,(Identifier "areset" Nothing,In,rstTy,rst) ,(Identifier "c0" Nothing,Out,clkOutTy,Identifier pllOut Nothing) ,(Identifier "locked" Nothing,Out,Bit,Identifier locked Nothing)] @@ -112,8 +136,94 @@ ] where - [(nm,_,_),(clk,clkTy,_),(rst,rstTy,_)] = bbInputs bbCtx + [_,_,(nm,_,_),(clk,clkTy,_),(rst,rstTy,_)] = bbInputs bbCtx (Identifier result Nothing,resTy@(Product _ _ [clkOutTy,_])) = bbResult bbCtx Just nm' = exprToString nm - compName = TextS.pack nm' + instname0 = TextS.pack nm' + compName = head (bbQsysIncName bbCtx) + +altpllQsysTemplate + :: Backend s + => BlackBoxContext + -> State s Doc +altpllQsysTemplate bbCtx = pure bbText + where + ((_,stripVoid -> kdIn,_):(_,stripVoid -> kdOut,_):_) = bbInputs bbCtx + KnownDomain _ clkInPeriod _ _ _ _ = kdIn + KnownDomain _ clkOutPeriod _ _ _ _ = kdOut + clkOutFreq :: Double + clkOutFreq = (1.0 / (fromInteger clkOutPeriod * 1.0e-12)) / 1e6 + clklcm = lcm clkInPeriod clkOutPeriod + clkmult = clklcm `quot` clkOutPeriod + clkdiv = clklcm `quot` clkInPeriod + -- Note [QSys file templates] + -- This QSys file template was derived from a "full" QSys system with a single + -- "altpll" IP. Module parameters were then stripped on a trial-and-error + -- basis to get a template that has the minimal number of parameters, but + -- still has the desired, working, configuration. + bbText = [I.i| + + + + + + + + + + + + + + + + + + + PT#EFF_OUTPUT_FREQ_VALUE0 #{clkOutFreq} + +|] + +alteraPllQsysTemplate + :: Backend s + => BlackBoxContext + -> State s Doc +alteraPllQsysTemplate bbCtx = pure bbText + where + (_:(_,stripVoid -> kdIn,_):(_,stripVoid -> kdOutsProd,_):_) = bbInputs bbCtx + kdOuts = case kdOutsProd of + Product _ _ ps -> ps + KnownDomain {} -> [kdOutsProd] + _ -> error "internal error: not a Product or KnownDomain" + + cklFreq (KnownDomain _ p _ _ _ _) + = (1.0 / (fromInteger p * 1.0e-12 :: Double)) / 1e6 + cklFreq _ = error "internal error: not a KnownDomain" + + clkOuts = TextS.unlines + [[I.i||] + | (n,f) <- zip [(0 :: Word)..] (map cklFreq kdOuts) + ] + + -- See Note [QSys file templates] on how this qsys template was derived. + bbText = [I.i| + + + + + + #{clkOuts} + + + + +|] diff --git a/src/Clash/Primitives/Sized/ToInteger.hs b/src/Clash/Primitives/Sized/ToInteger.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Primitives/Sized/ToInteger.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE TupleSections #-} +module Clash.Primitives.Sized.ToInteger + ( bvToIntegerVerilog + , bvToIntegerVHDL + , indexToIntegerVerilog + , indexToIntegerVHDL + , signedToIntegerVerilog + , signedToIntegerVHDL + , unsignedToIntegerVerilog + , unsignedToIntegerVHDL + ) +where + +import qualified Control.Lens as Lens +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Data.Text.Lazy (pack) +import System.IO (hPutStrLn, stderr) +import Text.Trifecta.Result (Result(Success)) + +import DynFlags (unsafeGlobalDynFlags) +import ErrUtils (mkPlainWarnMsg, pprLocErrMsg) +import Outputable + (blankLine, empty, int, integer, showSDocUnsafe, text, ($$), ($+$), (<+>)) +import qualified Outputable +import SrcLoc (isGoodSrcSpan) + +import Clash.Annotations.Primitive (HDL (Verilog,VHDL)) +import Clash.Core.Type (Type (LitTy), LitTy (NumTy)) +import Clash.Netlist.BlackBox.Parser (runParse) +import Clash.Netlist.BlackBox.Types + (BlackBoxFunction, BlackBoxMeta (bbKind), TemplateKind (TExpr), + emptyBlackBoxMeta) +import Clash.Netlist.Types + (BlackBox (BBTemplate), HWType (..), curCompNm, intWidth) +import Clash.Util (clogBase) + +bvToIntegerVerilog, bvToIntegerVHDL, indexToIntegerVerilog, + indexToIntegerVHDL, signedToIntegerVerilog, signedToIntegerVHDL, + unsignedToIntegerVerilog, unsignedToIntegerVHDL :: BlackBoxFunction + +bvToIntegerVerilog = toIntegerBB Verilog (BitVector 0) +bvToIntegerVHDL = toIntegerBB VHDL (BitVector 0) +indexToIntegerVerilog = toIntegerBB Verilog (Index 0) +indexToIntegerVHDL = toIntegerBB VHDL (Index 0) +signedToIntegerVerilog = toIntegerBB Verilog (Signed 0) +signedToIntegerVHDL = toIntegerBB VHDL (Signed 0) +unsignedToIntegerVerilog = toIntegerBB Verilog (Unsigned 0) +unsignedToIntegerVHDL = toIntegerBB VHDL (Unsigned 0) + +toIntegerBB :: HDL -> HWType -> BlackBoxFunction +toIntegerBB hdl hty _isD _primName args _ty = do + case args of + (Right (LitTy (NumTy i)):_) -> do + iw <- Lens.use intWidth + let i1 = width i + when (fromInteger i1 > iw) $ do + (_,sp) <- Lens.use curCompNm + let srcInfo1 | isGoodSrcSpan sp = srcInfo + | otherwise = empty + + warnMsg1 = mkPlainWarnMsg unsafeGlobalDynFlags sp (warnMsg i1 iw $+$ blankLine $+$ srcInfo1) + + liftIO (hPutStrLn stderr (showSDocUnsafe (pprLocErrMsg warnMsg1))) + _ -> return () + return ((meta,) <$> bb) + where + meta = emptyBlackBoxMeta{bbKind=TExpr} + + bb = BBTemplate <$> case runParse (pack bbText) of + Success t -> Right t + _ -> Left "internal error: parse fail" + + bbText = case hdl of + VHDL -> case hty of + BitVector {} -> "~IF~SIZE[~TYP[1]]~THENsigned(std_logic_vector(resize(unsigned(~ARG[1]),~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI" + Index {} -> "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI" + Signed {} -> "~IF~SIZE[~TYP[0]]~THENresize(~ARG[0],~SIZE[~TYPO])~ELSEto_signed(0,64)~FI" + Unsigned {} -> "~IF~SIZE[~TYP[0]]~THENsigned(std_logic_vector(resize(~ARG[0],~SIZE[~TYPO])))~ELSEto_signed(0,64)~FI" + _ -> error "internal error" + _ -> case hty of + BitVector {} -> "~IF~SIZE[~TYP[1]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[1]]]~THEN$unsigned(~VAR[bv][1][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[1]]) {1'b0}},~VAR[bv][1]})~FI~ELSE~SIZE[~TYPO]'sd0~FI" + Index {} -> "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$unsigned(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI" + Signed {} -> "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$signed(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$signed({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI" + Unsigned {} -> "~IF~SIZE[~TYP[0]]~THEN~IF~CMPLE[~SIZE[~TYPO]][~SIZE[~TYP[0]]]~THEN$unsigned(~VAR[i][0][0+:~SIZE[~TYPO]])~ELSE$unsigned({{(~SIZE[~TYPO]-~SIZE[~TYP[0]]) {1'b0}},~VAR[i][0]})~FI~ELSE~SIZE[~TYPO]'sd0~FI" + _ -> error "internal error" + + tyName = case hty of + BitVector {} -> text "BitVector" + Index {} -> text "Index" + Signed {} -> text "Signed" + Unsigned {} -> text "Unsigned" + _ -> error "internal error" + + width i = case hty of + Index {} -> maybe 0 toInteger (clogBase 2 i) + _ -> i + + warnMsg i iw = + tyName Outputable.<> text ".toInteger: Integer width," <+> int iw Outputable.<> + text ", is smaller than" <+> tyName <+> text "width," <+> integer i Outputable.<> + text ". Dropping MSBs." $+$ + text "Are you using 'fromIntegral' to convert between types?" <+> + text "Use 'bitCoerce' instead." + + srcInfo = + text "NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." $$ + text "The actual location of the error can be in a function that is inlined." $$ + text "To prevent inlining of those functions, annotate them with a NOINLINE pragma." diff --git a/src/Clash/Primitives/Sized/Vector.hs b/src/Clash/Primitives/Sized/Vector.hs --- a/src/Clash/Primitives/Sized/Vector.hs +++ b/src/Clash/Primitives/Sized/Vector.hs @@ -1,36 +1,197 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Primitives.Sized.Vector where -import Control.Monad.State -import Data.Semigroup.Monad -import Data.Text.Lazy (pack) -import Data.Text.Prettyprint.Doc.Extra -import Text.Trifecta.Result +import Control.Monad.State (State, zipWithM) +import qualified Control.Lens as Lens +import Data.Either (rights) +import qualified Data.IntMap as IntMap +import Data.Semigroup.Monad (getMon) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText +import Data.Text.Lazy (pack) +import Data.Text.Prettyprint.Doc.Extra + (Doc, string, renderLazy, layoutPretty, LayoutOptions(..), + PageWidth(AvailablePerLine)) +import Text.Trifecta.Result (Result(Success)) +import qualified Data.String.Interpolate as I +import qualified Data.String.Interpolate.Util as I -import Clash.Backend -import Clash.Netlist.BlackBox -import Clash.Netlist.BlackBox.Parser -import Clash.Netlist.BlackBox.Types -import Clash.Netlist.Types -import Clash.Netlist.Util +import Clash.Backend + (Backend, hdlTypeErrValue, expr, mkUniqueIdentifier, blockDecl) +import Clash.Core.Type + (Type(LitTy), LitTy(NumTy), coreView) +import Clash.Netlist.BlackBox (isLiteral) +import Clash.Netlist.BlackBox.Util (renderElem) +import Clash.Netlist.BlackBox.Parser (runParse) +import Clash.Netlist.BlackBox.Types + (BlackBoxFunction, BlackBoxMeta(..), TemplateKind(TExpr, TDecl), + Element(Component, Typ, TypElem, Text), Decl(Decl), emptyBlackBoxMeta) +import Clash.Netlist.Types + (Identifier, TemplateFunction, BlackBoxContext, HWType(Vector), + Declaration(..), Expr(BlackBoxE, Literal, Identifier), Literal(NumLit), + BlackBox(BBTemplate, BBFunction), TemplateFunction(..), WireOrReg(Wire), + Modifier(Indexed, Nested), bbInputs, bbResult, emptyBBContext, tcCache, + bbFunctions) +import Clash.Netlist.Id (IdType(Basic)) +import Clash.Netlist.Util (typeSize) -import qualified Data.String.Interpolate as I -import qualified Data.String.Interpolate.Util as I +import Clash.Util (HasCallStack, curLoc) +data FCall = + FCall + Identifier -- left + Identifier -- right + Identifier -- result + +-- | Calculates the number of function calls needed for an evaluation of +-- 'Clash.Sized.Vector.fold', given the length of the vector given to fold. +foldFunctionPlurality :: HasCallStack => Int -> Int +foldFunctionPlurality 1 = 0 +foldFunctionPlurality 2 = 1 +foldFunctionPlurality n + | n <= 0 = error $ "functionPlurality: unexpected n: " ++ show n + | otherwise = + let (d, r) = n `divMod` 2 in + 1 + foldFunctionPlurality d + foldFunctionPlurality (d+r) + +foldBBF :: HasCallStack => BlackBoxFunction +foldBBF _isD _primName args _resTy = do + tcm <- Lens.use tcCache + pure (Right (meta tcm, bb)) + where + bb = BBFunction "Clash.Primitives.Sized.Vector.foldTF" 0 foldTF + [_, vecLengthMinusOne] = rights args + vecLength tcm = + case coreView tcm vecLengthMinusOne of + (LitTy (NumTy n)) -> n + 1 + vl -> error $ "Unexpected vector length: " ++ show vl + funcPlural tcm = foldFunctionPlurality (fromInteger (vecLength tcm)) + meta tcm = emptyBlackBoxMeta {bbKind=TDecl, bbFunctionPlurality=[(0, funcPlural tcm)]} + +-- | Type signature of function we're generating netlist for: +-- +-- fold :: (a -> a -> a) -> Vec (n + 1) a -> a +-- +-- The implementation promises to create a (balanced) tree structure. +foldTF :: TemplateFunction +foldTF = TemplateFunction [] (const True) foldTF' + +foldTF' :: forall s . (HasCallStack, Backend s) => BlackBoxContext -> State s Doc +foldTF' bbCtx@(bbInputs -> [_f, (vec, vecType@(Vector n aTy), _isLiteral)]) = do + -- Create an id for every element in the vector + vecIds <- mapM (\i -> mkId ("acc_0_" <> show i)) [0..n-1] + + vecId <- mkId "vec" + let vecDecl = sigDecl vecType Wire vecId + vecAssign = Assignment vecId vec + elemAssigns = zipWith Assignment vecIds (map (iIndex vecId) [0..]) + resultId = + case bbResult bbCtx of + (Identifier t _, _) -> t + _ -> error "Unexpected result identifier" + + -- Create a list of function calls to be made (creates identifiers for + -- intermediate result signals) + (concat -> fCalls, result) <- mkTree 1 vecIds + + let intermediateResultIds = concatMap (\(FCall l r _) -> [l, r]) fCalls + wr = case IntMap.lookup 0 (bbFunctions bbCtx) of + Just ((_,rw,_,_,_,_):_) -> rw + _ -> error "internal error" + sigDecls = zipWith (sigDecl aTy) (wr:replicate n Wire ++ repeat wr) + (result : intermediateResultIds) + resultAssign = Assignment resultId (Identifier result Nothing) + + callDecls <- zipWithM callDecl [0..] fCalls + foldNm <- mkId "fold" + + getMon $ blockDecl foldNm $ + resultAssign : + vecAssign : + vecDecl : + elemAssigns ++ + sigDecls ++ + callDecls + + where + mkId :: String -> State s Identifier + mkId = mkUniqueIdentifier Basic . Text.pack + + callDecl :: Int -> FCall -> State s Declaration + callDecl fSubPos (FCall a b r) = do + rendered0 <- string =<< (renderElem bbCtx call <*> pure 0) + let layout = LayoutOptions (AvailablePerLine 120 0.4) + rendered1 = renderLazy (layoutPretty layout rendered0) + pure ( + BlackBoxD + "__FOLD_BB_INTERNAL__" + [] [] [] + (BBTemplate [Text rendered1]) + (emptyBBContext "__FOLD_BB_INTERNAL__") + ) + where + call = Component (Decl fPos fSubPos (resEl:aEl:[bEl])) + elTyp = [TypElem (Typ (Just vecPos))] + resEl = ([Text (LText.fromStrict r)], elTyp) + aEl = ([Text (LText.fromStrict a)], elTyp) + bEl = ([Text (LText.fromStrict b)], elTyp) + + -- Argument no. of function + fPos = 0 + + -- Argument no. of vector + vecPos = 1 + + -- Create the whole tree + mkTree + :: Int + -- ^ Current level + -> [Identifier] + -- ^ Elements left to process + -> State s ( [[FCall]] -- function calls to be rendered + , Identifier -- result signal + ) + mkTree _lvl [] = error "Unreachable?" + mkTree _lvl [res] = pure ([], res) + mkTree lvl results0 = do + (calls0, results1) <- mkLevel (lvl, 0) results0 + (calls1, result) <- mkTree (lvl+1) results1 + pure (calls0 : calls1, result) + + -- Create a single layer of a tree + mkLevel + :: (Int, Int) + -- ^ (level, offset) + -> [Identifier] + -> State s ([FCall], [Identifier]) + mkLevel (!lvl, !offset) (a:b:rest) = do + c <- mkId ("acc_" <> show lvl <> "_" <> show offset) + (calls, results) <- mkLevel (lvl, offset+1) rest + pure (FCall a b c:calls, c:results) + mkLevel _lvl rest = + pure ([], rest) + + -- Simple wire without comment + sigDecl :: HWType -> WireOrReg -> Identifier -> Declaration + sigDecl typ rw nm = NetDecl' Nothing rw nm (Right typ) Nothing + + -- Index the intermediate vector. This uses a hack in Clash: the 10th + -- constructor of Vec doesn't exist; using it will be interpreted by the + -- HDL backends as vector indexing. + iIndex :: Identifier -> Int -> Expr + iIndex vecId i = Identifier vecId (Just (Indexed (vecType, 10, i))) + +foldTF' args = + error $ "Unexpected number of arguments: " ++ show (length (bbInputs args)) + indexIntVerilog :: BlackBoxFunction indexIntVerilog _isD _primName args _ty = return ((meta,) <$> bb) where - meta = BlackBoxMeta - { bbOutputReg = False - , bbKind = bbKi - , bbLibrary = [] - , bbImports = [] - , bbIncludes = [] - } + meta = emptyBlackBoxMeta{bbKind=bbKi} bbKi = case args of [_nTy,_aTy,_kn,_v,Left ix] @@ -74,7 +235,7 @@ Just m -> expr False (Identifier i (Just (Nested m (Indexed (vTy,10,ixI ix))))) _ -> expr False (Identifier i (Just (Indexed (vTy,10,ixI ix)))) - _ -> error ("Expected Identifier: " ++ show vec) + _ -> error ($(curLoc) ++ "Expected Identifier: " ++ show vec) where [ _kn , (vec, vTy, _) @@ -85,8 +246,10 @@ ixI :: Expr -> Int ixI ix0 = case ix0 of - Literal _ (NumLit i) -> fromInteger i - BlackBoxE "GHC.Types.I#" _ _ _ _ ixCtx _ -> - let (ix1,_,_) = head (bbInputs ixCtx) - in ixI ix1 - _ -> error ("Unexpected literal" ++ show ix) + Literal _ (NumLit i) -> + fromInteger i + BlackBoxE "GHC.Types.I#" _ _ _ _ ixCtx _ -> + let (ix1,_,_) = head (bbInputs ixCtx) + in ixI ix1 + _ -> + error ($(curLoc) ++ "Unexpected literal: " ++ show ix) diff --git a/src/Clash/Primitives/Types.hs b/src/Clash/Primitives/Types.hs --- a/src/Clash/Primitives/Types.hs +++ b/src/Clash/Primitives/Types.hs @@ -8,15 +8,11 @@ Type and instance definitions for Primitive -} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module Clash.Primitives.Types ( TemplateSource(..) @@ -24,6 +20,7 @@ , TemplateFormat(..) , BlackBoxFunctionName(..) , Primitive(..) + , UsedArguments(..) , GuardedCompiledPrimitive , GuardedResolvedPrimitive , PrimMap @@ -38,7 +35,7 @@ import Clash.Annotations.Primitive (PrimitiveGuard) import Clash.Core.Term (WorkInfo (..)) import Clash.Netlist.BlackBox.Types - (BlackBoxFunction, BlackBoxTemplate, TemplateKind (..)) + (BlackBoxFunction, BlackBoxTemplate, TemplateKind (..), RenderVoid(..)) import Control.Applicative ((<|>)) import Control.DeepSeq (NFData) import Data.Aeson @@ -133,6 +130,14 @@ | THaskell deriving (Show, Generic, Hashable, NFData) +-- | Data type to indicate what arguments are in use by a BlackBox +data UsedArguments + = UsedArguments [Int] + -- ^ Only these are used + | IgnoredArguments [Int] + -- ^ All but these are used + deriving (Show, Generic, Hashable, NFData, Binary) + -- | Externally defined primitive data Primitive a b c d -- | Primitive template written in a Clash specific templating language @@ -141,6 +146,9 @@ -- ^ Name of the primitive , workInfo :: WorkInfo -- ^ Whether the primitive does any work, i.e. takes chip area + , renderVoid :: RenderVoid + -- ^ Whether this primitive should be rendered when its result type is + -- void. Defaults to 'NoRenderVoid'. , kind :: TemplateKind -- ^ Whether this results in an expression or a declaration , warning :: c @@ -155,10 +163,31 @@ -- ^ VHDL only: add /library/ declarations for the given names , imports :: [a] -- ^ VHDL only: add /use/ declarations for the given names + , functionPlurality :: [(Int, Int)] -- Using map ruins Hashable instance + -- ^ Indicates how often a function will be instantiated in a blackbox. For + -- example, consider the following higher-order function that creates a tree + -- structure: + -- + -- fold :: (a -> a -> a) -> Vec n a -> a + -- + -- In order to generate HDL for an instance of fold we need log2(n) calls + -- to the first argument, `a -> a -> a` (plus a few more if n is not a + -- power of two). Note that this only targets multiple textual instances + -- of the function. If you can generate the HDL using a for-loop and only + -- need to call ~INST once, you don't have to worry about this option. See + -- the blackbox for 'Clash.Sized.Vector.map' for an example of this. + -- + -- Right now, option can only be generated by BlackBoxHaskell. It cannot be + -- used within JSON primitives. To see how to use this, see the Haskell + -- blackbox for 'Clash.Sized.Vector.fold'. , includes :: [((S.Text,S.Text),b)] -- ^ Create files to be included with the generated primitive. The fields -- are ((name, extension), content), where content is a template of the file -- Defaults to @[]@ when not specified in the /.json/ file + , resultName :: Maybe b + -- ^ (Maybe) Control the generated name of the result + , resultInit :: Maybe b + -- ^ (Maybe) Control the initial/power-up value of the result , template :: b -- ^ Used to indiciate type of template (declaration or expression). Will be -- filled with @Template@ or an @Either decl expr@. @@ -169,6 +198,8 @@ -- ^ Name of the primitive , workInfo :: WorkInfo -- ^ Whether the primitive does any work, i.e. takes chip area + , usedArguments :: UsedArguments + -- ^ Arguments used by blackbox. Used to remove arguments during normalization. , functionName :: BlackBoxFunctionName , function :: d -- ^ Holds blackbox function and its hash, (Int, BlackBoxFunction), in a @@ -193,6 +224,16 @@ [(conKey,Object conVal)] -> case conKey of "BlackBoxHaskell" -> do + usedArguments <- conVal .:? "usedArguments" + ignoredArguments <- conVal .:? "ignoredArguments" + args <- + case (usedArguments, ignoredArguments) of + (Nothing, Nothing) -> pure (IgnoredArguments []) + (Just a, Nothing) -> pure (UsedArguments a) + (Nothing, Just a) -> pure (IgnoredArguments a) + (Just _, Just _) -> + fail "[8] Don't use both 'usedArguments' and 'ignoredArguments'" + name' <- conVal .: "name" wf <- ((conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable) fName <- conVal .: "templateFunction" @@ -200,16 +241,20 @@ <|> (Just . TFile <$> conVal .: "file") <|> (pure Nothing) fName' <- either fail return (parseBBFN fName) - return (BlackBoxHaskell name' wf fName' templ) + return (BlackBoxHaskell name' wf args fName' templ) "BlackBox" -> BlackBox <$> conVal .: "name" <*> (conVal .:? "workInfo" >>= maybe (pure Nothing) parseWorkInfo) .!= WorkVariable + <*> conVal .:? "renderVoid" .!= NoRenderVoid <*> (conVal .: "kind" >>= parseTemplateKind) <*> conVal .:? "warning" <*> conVal .:? "outputReg" .!= False <*> conVal .:? "libraries" .!= [] <*> conVal .:? "imports" .!= [] + <*> pure [] -- functionPlurality not supported in json <*> (conVal .:? "includes" .!= [] >>= traverse parseInclude) + <*> (conVal .:? "resultName" >>= maybe (pure Nothing) parseResult) .!= Nothing + <*> (conVal .:? "resultInit" >>= maybe (pure Nothing) parseResult) .!= Nothing <*> parseTemplate conVal "Primitive" -> Primitive <$> conVal .: "name" @@ -247,6 +292,10 @@ parseBBFN' = either fail return . parseBBFN defTemplateFunction = BlackBoxFunctionName ["Template"] "template" + + parseResult (Object c) = + Just . Just <$> parseTemplate c + parseResult e = fail $ "[7] unexpected result: " ++ show e parseJSON unexpected = fail $ "[3] Expected: BlackBox or Primitive object, got: " ++ show unexpected diff --git a/src/Clash/Primitives/Util.hs b/src/Clash/Primitives/Util.hs --- a/src/Clash/Primitives/Util.hs +++ b/src/Clash/Primitives/Util.hs @@ -8,16 +8,16 @@ Utility functions to generate Primitives -} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} module Clash.Primitives.Util ( generatePrimMap , hashCompiledPrimMap , constantArgs , decodeOrErr + , getFunctionPlurality ) where import Control.DeepSeq (force) @@ -28,7 +28,8 @@ import qualified Data.HashMap.Strict as HashMapStrict import qualified Data.Set as Set import Data.Hashable (hash) -import Data.List (isSuffixOf, sort) +import Data.List (isSuffixOf, sort, find) +import Data.Maybe (fromMaybe) import qualified Data.Text as TS import Data.Text.Lazy (Text) import qualified Data.Text.Lazy.IO as T @@ -40,15 +41,18 @@ import Clash.Annotations.Primitive ( PrimitiveGuard(HasBlackBox, WarnNonSynthesizable, WarnAlways, DontTranslate) , extractPrim) +import Clash.Core.Term (Term) +import Clash.Core.Type (Type) import Clash.Primitives.Types ( Primitive(BlackBox), CompiledPrimitive, ResolvedPrimitive, ResolvedPrimMap , includes, template, TemplateSource(TFile, TInline), Primitive(..) , UnresolvedPrimitive, CompiledPrimMap, GuardedResolvedPrimitive) -import Clash.Netlist.Types (BlackBox(..)) +import Clash.Netlist.Types (BlackBox(..), NetlistMonad) +import Clash.Netlist.Util (preserveState) import Clash.Netlist.BlackBox.Util (walkElement) import Clash.Netlist.BlackBox.Types - (Element(Const, Lit)) + (Element(Const, Lit), BlackBoxMeta(..)) hashCompiledPrimitive :: CompiledPrimitive -> Int hashCompiledPrimitive (Primitive {name, primSort}) = hash (name, primSort) @@ -89,15 +93,19 @@ -> IO (TS.Text, GuardedResolvedPrimitive) resolvePrimitive' _metaPath (Primitive name wf primType) = return (name, HasBlackBox (Primitive name wf primType)) -resolvePrimitive' metaPath BlackBox{template=t, includes=i, ..} = do - let resolvedIncludes = mapM (traverse (traverse (traverse (resolveTemplateSource metaPath)))) i - resolved = traverse (traverse (resolveTemplateSource metaPath)) t - bb <- BlackBox name workInfo kind () outputReg libraries imports <$> resolvedIncludes <*> resolved +resolvePrimitive' metaPath BlackBox{template=t, includes=i, resultName=r, resultInit=ri, ..} = do + let resolveSourceM = traverse (traverse (resolveTemplateSource metaPath)) + bb <- BlackBox name workInfo renderVoid kind () outputReg libraries imports functionPlurality + <$> mapM (traverse resolveSourceM) i + <*> traverse resolveSourceM r + <*> traverse resolveSourceM ri + <*> resolveSourceM t case warning of Just w -> pure (name, WarnNonSynthesizable (TS.unpack w) bb) Nothing -> pure (name, HasBlackBox bb) -resolvePrimitive' metaPath (BlackBoxHaskell bbName wf funcName t) = - (bbName,) . HasBlackBox . BlackBoxHaskell bbName wf funcName <$> (mapM (resolveTemplateSource metaPath) t) +resolvePrimitive' metaPath (BlackBoxHaskell bbName wf usedArgs funcName t) = + (bbName,) . HasBlackBox . BlackBoxHaskell bbName wf usedArgs funcName <$> + (mapM (resolveTemplateSource metaPath) t) -- | Interprets contents of json file as list of @Primitive@s. Throws -- exception if it fails. @@ -169,12 +177,19 @@ primitives1 <- sequence $ zipWith resolvePrimitive' metapaths unresolvedPrims let primMap = HashMap.fromList (primitives0 ++ primitives1) return (force (addGuards primMap primGuards)) +{-# SCC generatePrimMap #-} -- | Determine what argument should be constant / literal constantArgs :: TS.Text -> CompiledPrimitive -> Set.Set Int -constantArgs nm BlackBox {template = BBTemplate template} = - Set.fromList (fromIntForce ++ concatMap (walkElement getConstant) template) +constantArgs nm BlackBox {template = templ@(BBTemplate _), resultInit = tRIM} = + Set.fromList (concat [ fromIntForce + , maybe [] walkTemplate tRIM + , walkTemplate templ + ]) where + walkTemplate (BBTemplate t) = concatMap (walkElement getConstant) t + walkTemplate _ = [] + getConstant (Lit i) = Just i getConstant (Const i) = Just i getConstant _ = Nothing @@ -205,3 +220,37 @@ | nm == "Clash.Sized.Vector.replace_int" = [1,2] | otherwise = [] constantArgs _ _ = Set.empty + +-- | Helper function of 'getFunctionPlurality' +getFunctionPlurality' :: [(Int, Int)] -> Int -> Int +getFunctionPlurality' functionPlurality n = + fromMaybe 1 (snd <$> (find ((== n) . fst) functionPlurality)) + +-- | Looks up the plurality of a function's function argument. See +-- 'functionPlurality' for more information. If not set, the returned plurality +-- will default to /1/. +getFunctionPlurality + :: HasCallStack + => CompiledPrimitive + -> [Either Term Type] + -- ^ Arguments passed to blackbox + -> Type + -- ^ Result type + -> Int + -- ^ Argument number holding the function of interest + -> NetlistMonad Int + -- ^ Plurality of function. Defaults to 1. Does not err if argument isn't + -- a function in the first place. State of monad will not be modified. +getFunctionPlurality (Primitive {}) _args _resTy _n = pure 1 +getFunctionPlurality (BlackBoxHaskell {name, function, functionName}) args resTy n = do + errOrMeta <- preserveState ((snd function) False name args resTy) + case errOrMeta of + Left err -> + error $ concat [ "Tried to determine function plurality for " + , TS.unpack name, " by quering ", show functionName + , ". Function returned an error message instead:\n\n" + , err ] + Right (BlackBoxMeta {bbFunctionPlurality}, _bb) -> + pure (getFunctionPlurality' bbFunctionPlurality n) +getFunctionPlurality (BlackBox {functionPlurality}) _args _resTy n = + pure (getFunctionPlurality' functionPlurality n) diff --git a/src/Clash/Rewrite/Combinators.hs b/src/Clash/Rewrite/Combinators.hs --- a/src/Clash/Rewrite/Combinators.hs +++ b/src/Clash/Rewrite/Combinators.hs @@ -6,10 +6,6 @@ Rewriting combinators and traversals -} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} - module Clash.Rewrite.Combinators ( allR , (!->) diff --git a/src/Clash/Rewrite/Types.hs b/src/Clash/Rewrite/Types.hs --- a/src/Clash/Rewrite/Types.hs +++ b/src/Clash/Rewrite/Types.hs @@ -8,13 +8,12 @@ Type and instance definitions for Rewrite modules -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Rewrite.Types where @@ -33,9 +32,10 @@ import Data.Hashable (Hashable) import Data.IntMap.Strict (IntMap) import Data.Monoid (Any) +import qualified Data.Set as Set import GHC.Generics -import Clash.Core.Evaluator (GlobalHeap, PrimEvaluator) +import Clash.Core.Evaluator.Types (PrimHeap, PrimStep, PrimUnwind) import Clash.Core.Term (Term, Context) import Clash.Core.Type (Type) import Clash.Core.TyCon (TyConName, TyConMap) @@ -75,7 +75,7 @@ -- ^ Function which is currently normalized , _nameCounter :: {-# UNPACK #-} !Int -- ^ Used for 'Fresh' - , _globalHeap :: GlobalHeap + , _globalHeap :: PrimHeap -- ^ Used as a heap for compile-time evaluation of primitives that live in I/O , _extra :: !extra -- ^ Additional state @@ -87,7 +87,10 @@ data RewriteEnv = RewriteEnv { _dbgLevel :: DebugLevel - -- ^ Lvl at which we print debugging messages + -- ^ Level at which we print debugging messages + , _dbgTransformations :: Set.Set String + , _aggressiveXOpt :: Bool + -- ^ Transformations to print debugging info for , _typeTranslator :: CustomReprs -> TyConMap -> Type @@ -97,7 +100,7 @@ -- ^ TyCon cache , _tupleTcCache :: IntMap TyConName -- ^ Tuple TyCon cache - , _evaluator :: PrimEvaluator + , _evaluator :: (PrimStep, PrimUnwind) -- ^ Hardcoded evaluator (delta-reduction)} , _topEntities :: VarSet -- ^ Functions that are considered TopEntities diff --git a/src/Clash/Rewrite/Util.hs b/src/Clash/Rewrite/Util.hs --- a/src/Clash/Rewrite/Util.hs +++ b/src/Clash/Rewrite/Util.hs @@ -8,24 +8,22 @@ Utilities for rewriting: e.g. inlining, specialisation, etc. -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Rewrite.Util where +import Control.Concurrent.Supply (splitSupply) import Control.DeepSeq import Control.Exception (throw) import Control.Lens - (Lens', (%=), (+=), (^.), _3, _4, _Left) + (Lens', (%=), (+=), (^.), _Left) import qualified Control.Lens as Lens import qualified Control.Monad as Monad #if !MIN_VERSION_base(4,13,0) @@ -33,15 +31,18 @@ #endif import qualified Control.Monad.State.Strict as State import qualified Control.Monad.Writer as Writer +import Data.Bool (bool) import Data.Bifunctor (bimap) import Data.Coerce (coerce) import Data.Functor.Const (Const (..)) -import Data.List (group, sort) +import Data.List (group, partition, sort) import qualified Data.Map as Map import Data.Maybe (catMaybes,isJust,mapMaybe) import qualified Data.Monoid as Monoid import qualified Data.Set as Set import qualified Data.Set.Lens as Lens +import qualified Data.Set.Ordered as OSet +import qualified Data.Set.Ordered.Extra as OSet import Data.Text (Text) import qualified Data.Text as Text @@ -55,13 +56,15 @@ import BasicTypes (InlineSpec (..)) import Clash.Core.DataCon (dcExtTyVars) +import Clash.Core.Evaluator (whnf') +import Clash.Core.Evaluator.Types (PureHeap) import Clash.Core.FreeVars (freeLocalVars, hasLocalFreeVars, localIdDoesNotOccurIn, localIdOccursIn, - typeFreeVars, termFreeVars', freeIds) + typeFreeVars, termFreeVars') import Clash.Core.Name import Clash.Core.Pretty (showPpr) import Clash.Core.Subst - (aeqTerm, aeqType, extendIdSubst, mkSubst, substTm) + (substTmEnv, aeqTerm, aeqType, extendIdSubst, mkSubst, substTm) import Clash.Core.Term (LetBinding, Pat (..), Term (..), CoreContext (..), Context, PrimInfo (..), TmName, WorkInfo (..), TickInfo, collectArgs, collectArgsTicks) @@ -73,18 +76,21 @@ typeKind, tyView, isPolyFunTy) import Clash.Core.Util (isPolyFun, mkAbstraction, mkApps, mkLams, mkTicks, - mkTmApps, mkTyApps, mkTyLams, termType, dataConInstArgTysE, isClockOrReset) + mkTmApps, mkTyApps, mkTyLams, termType, dataConInstArgTysE, isClockOrReset, + isEnable, piResultTy) import Clash.Core.Var (Id, IdScope (..), TyVar, Var (..), isLocalId, mkGlobalId, mkLocalId, mkTyVar) import Clash.Core.VarEnv (InScopeSet, VarEnv, elemVarSet, extendInScopeSetList, mkInScopeSet, - notElemVarEnv, uniqAway, uniqAway') + uniqAway, uniqAway', mapVarEnv) import Clash.Driver.Types - (DebugLevel (..), BindingMap) + (DebugLevel (..), BindingMap, Binding(..)) import Clash.Netlist.Util (representableType) +import Clash.Pretty (clashPretty, showDoc) import Clash.Rewrite.Types import Clash.Unique import Clash.Util +import qualified Clash.Util.Interpolate as I -- | Lift an action working in the '_extra' state to the 'RewriteMonad' zoomExtra :: State.State extra a @@ -140,6 +146,11 @@ -> Rewrite extra apply = \s rewrite ctx expr0 -> do lvl <- Lens.view dbgLevel + dbgTranss <- Lens.view dbgTransformations + let isTryLvl = lvl == DebugTry || lvl >= DebugAll + isRelevantTrans = s `Set.member` dbgTranss || Set.null dbgTranss + traceIf (isTryLvl && isRelevantTrans) ("Trying: " ++ s) (pure ()) + (expr1,anyChanged) <- Writer.listen (rewrite ctx expr0) let hasChanged = Monoid.getAny anyChanged !expr2 = if hasChanged then expr1 else expr0 @@ -160,14 +171,17 @@ } return () #endif + if lvl == DebugNone then return expr2 - else applyDebug lvl s expr0 hasChanged expr2 + else applyDebug lvl dbgTranss s expr0 hasChanged expr2 {-# INLINE apply #-} applyDebug :: DebugLevel -- ^ The current debugging level + -> Set.Set String + -- ^ Transformations to debug -> String -- ^ Name of the transformation -> Term @@ -177,8 +191,13 @@ -> Term -- ^ New expression -> RewriteMonad extra Term -applyDebug lvl name exprOld hasChanged exprNew = - traceIf (lvl >= DebugAll) ("Trying: " ++ name ++ " on:\n" ++ before) $ do +applyDebug lvl transformations name exprOld hasChanged exprNew + | not (Set.null transformations) = + let newLvl = bool DebugNone lvl (name `Set.member` transformations) in + applyDebug newLvl Set.empty name exprOld hasChanged exprNew + +applyDebug lvl _transformations name exprOld hasChanged exprNew = + traceIf (lvl >= DebugAll) ("Tried: " ++ name ++ " on:\n" ++ before) $ do Monad.when (lvl > DebugNone && hasChanged) $ do tcm <- Lens.view tcCache let beforeTy = termType tcm exprOld @@ -210,7 +229,7 @@ , "substitution." ]) - traceIf (lvl >= DebugAll && (beforeTy `aeqType` afterTy)) + traceIf (lvl >= DebugApplied && (not (beforeTy `aeqType` afterTy))) ( concat [ $(curLoc) , "Error when applying rewrite ", name , " to:\n" , before @@ -251,10 +270,10 @@ -> RewriteState extra -> RewriteMonad extra a -> a -runRewriteSession r s m = traceIf True ("Clash: Applied " ++ - show (s' ^. transformCounter) ++ - " transformations") - a +runRewriteSession r s m = + traceIf (_dbgLevel r > DebugNone) + ("Clash: Applied " ++ show (s' ^. transformCounter) ++ " transformations") + a where (a,s',_) = runR m r s @@ -281,7 +300,7 @@ -- | Make a new binder and variable reference for a term mkTmBinderFor - :: (Monad m, MonadUnique m, MonadFail m) + :: (MonadUnique m, MonadFail m) => InScopeSet -> TyConMap -- ^ TyCon cache -> Name a -- ^ Name of the new binder @@ -293,7 +312,7 @@ -- | Make a new binder and variable reference for either a term or a type mkBinderFor - :: (Monad m, MonadUnique m, MonadFail m) + :: (MonadUnique m, MonadFail m) => InScopeSet -> TyConMap -- ^ TyCon cache -> Name a -- ^ Name of the new binder @@ -311,7 +330,7 @@ -- | Make a new, unique, identifier mkInternalVar - :: (Monad m, MonadUnique m) + :: (MonadUnique m) => InScopeSet -> OccName -- ^ Name of the identifier @@ -328,17 +347,16 @@ -- ^ Property test -> Rewrite extra inlineBinders condition (TransformContext inScope0 _) expr@(Letrec xes res) = do - (replace,others) <- partitionM (condition expr) xes - case replace of + (toInline,toKeep) <- partitionM (condition expr) xes + case toInline of [] -> return expr _ -> do let inScope1 = extendInScopeSetList inScope0 (map fst xes) - (others',res') = substituteBinders inScope1 replace others res - newExpr = case others' of - [] -> res' - _ -> Letrec others' res' - - changed newExpr + (toInlRec,(toKeep1,res1)) = + substituteBinders inScope1 toInline toKeep res + case toInlRec ++ toKeep1 of + [] -> changed res1 + xes1 -> changed (Letrec xes1 res1) inlineBinders _ _ e = return e @@ -400,9 +418,8 @@ bndr `localIdDoesNotOccurIn` e isVoidWrapper _ = False --- | Substitute the RHS of the first set of Let-binders for references to the --- first set of Let-binders in: the second set of Let-binders and the additional --- term +-- | Inline the first set of binder into the second set of binders and into the +-- body of the original let expression. substituteBinders :: InScopeSet -> [LetBinding] @@ -410,21 +427,74 @@ -> [LetBinding] -- ^ Let-binders where substitution takes place -> Term - -- ^ Expression where substitution takes place - -> ([LetBinding],Term) -substituteBinders _ [] others res = (others,res) -substituteBinders inScope ((bndr,val):rest) others res = - substituteBinders inScope rest' others' res' + -- ^ Body where substitution takes place + -> ([LetBinding],([LetBinding],Term)) + -- ^ + -- 1. Let-bindings that we wanted to substitute, but turned out to be recursive + -- 2.1 Let-binders where substitution took place + -- 2.2 Body where substitution took place +substituteBinders inScope toInline toKeep body = + let (subst,toInlRec) = go (mkSubst inScope) [] toInline + in ( map (second (substTm "substToInlRec" subst)) toInlRec + , ( map (second (substTm "substToKeep" subst)) toKeep + , substTm "substBody" subst body) ) where - subst = extendIdSubst (mkSubst inScope) bndr val - selfRef = bndr `localIdOccursIn` val - (res',rest',others') = if selfRef - then (res,rest,(bndr,val):others) - else ( substTm "substituteBindersRes" subst res - , map (second (substTm "substituteBindersRest" subst)) rest - , map (second (substTm "substituteBindersOthers" subst)) others - ) + go subst inlRec [] = (subst,inlRec) + go !subst !inlRec ((x,e):toInl) = + let e1 = substTm "substInl" subst e + substE = extendIdSubst (mkSubst inScope) x e1 + subst1 = subst { substTmEnv = mapVarEnv (substTm "substSubst" substE) + (substTmEnv subst)} + subst2 = extendIdSubst subst1 x e1 + in if x `localIdOccursIn` e1 then + go subst ((x,e1):inlRec) toInl + else + go subst2 inlRec toInl +-- | Lift the first set of binders to the level of global bindings, and substitute +-- these lifted bindings into the second set of binders and the body of the +-- original let expression. +liftAndSubsituteBinders + :: InScopeSet + -> [LetBinding] + -- ^ Let-binders to lift, and substitute the lifted result + -> [LetBinding] + -- ^ Lef-binders where substitution takes place + -> Term + -- ^ Body where substitution takes place + -> RewriteMonad extra ([LetBinding],Term) +liftAndSubsituteBinders inScope toLift toKeep body = do + subst <- go (mkSubst inScope) toLift + pure ( map (second (substTm "liftToKeep" subst)) toKeep + , substTm "keepBody" subst body + ) + where + go subst [] = pure subst + go !subst ((x,e):inl) = do + let e1 = substTm "liftInl" subst e + (_,e2) <- liftBinding (x,e1) + let substE = extendIdSubst (mkSubst inScope) x e2 + subst1 = subst { substTmEnv = mapVarEnv (substTm "liftSubst" substE) + (substTmEnv subst) } + subst2 = extendIdSubst subst1 x e2 + if x `localIdOccursIn` e2 then do + (_,sp) <- Lens.use curFun + throw (ClashException sp [I.i| + Internal error: inlineOrLiftBInders failed on: + + #{showPpr (x,e)} + + creating a self-recursive let-binding: + + #{showPpr (x,e2)} + + given the already built subtitution: + + #{showDoc (clashPretty (substTmEnv subst))} + |] Nothing) + else + go subst2 inl + -- | Determine whether a term does any work, i.e. adds to the size of the circuit isWorkFree :: Term @@ -433,7 +503,7 @@ Var i -> isLocalId i && not (isPolyFunTy (varType i)) Data {} -> all isWorkFreeArg args Literal {} -> True - Prim _ pInfo -> case primWorkInfo pInfo of + Prim pInfo -> case primWorkInfo pInfo of WorkConstant -> True -- We can ignore the arguments, because this -- primitive outputs a constant regardless of its -- arguments @@ -463,7 +533,7 @@ isConstant :: Term -> Bool isConstant e = case collectArgs e of (Data _, args) -> all (either isConstant (const True)) args - (Prim _ _, args) -> all (either isConstant (const True)) args + (Prim _, args) -> all (either isConstant (const True)) args (Lam _ _, _) -> not (hasLocalFreeVars e) (Literal _,_) -> True _ -> False @@ -476,21 +546,23 @@ let eTy = termType tcm e if isClockOrReset tcm eTy then case collectArgs e of - (Prim nm _,_) -> return (nm == "Clash.Transformations.removedArg") + (Prim p,_) -> return (primName p == "Clash.Transformations.removedArg") _ -> return False else pure (isConstant e) -- TODO: Remove function after using WorkInfo in 'isWorkFreeIsh' -isWorkFreeClockOrReset +isWorkFreeClockOrResetOrEnable :: TyConMap -> Term -> Maybe Bool -isWorkFreeClockOrReset tcm e = +isWorkFreeClockOrResetOrEnable tcm e = let eTy = termType tcm e in - if isClockOrReset tcm eTy then + if isClockOrReset tcm eTy || isEnable tcm eTy then case collectArgs e of - (Prim nm _,_) -> Just (nm == "Clash.Transformations.removedArg") + (Prim p,_) -> Just (primName p == "Clash.Transformations.removedArg") (Var _, []) -> Just True + (Data _, []) -> Just True -- For Enable True/False + (Literal _,_) -> Just True _ -> Just False else Nothing @@ -512,44 +584,51 @@ -> RewriteMonad extra Bool isWorkFreeIsh e = do tcm <- Lens.view tcCache - case isWorkFreeClockOrReset tcm e of + case isWorkFreeClockOrResetOrEnable tcm e of Just b -> pure b Nothing -> case collectArgs e of - (Data _, args) -> allM (either isWorkFreeIsh (pure . const True)) args - -- TODO: Use WorkInfo - (Prim _ _, args) -> allM (either isWorkFreeIsh (pure . const True)) args + (Data _, args) -> allM isWorkFreeIshArg args + (Prim pInfo, args) -> case primWorkInfo pInfo of + WorkAlways -> pure False -- Things like clock or reset generator always + -- perform work + WorkVariable -> pure (all isConstantArg args) + _ -> allM isWorkFreeIshArg args (Lam _ _, _) -> pure (not (hasLocalFreeVars e)) (Literal _,_) -> pure True _ -> pure False + where + isWorkFreeIshArg = either isWorkFreeIsh (pure . const True) + isConstantArg = either isConstant (const True) inlineOrLiftBinders :: (LetBinding -> RewriteMonad extra Bool) -- ^ Property test - -> (Term -> LetBinding -> RewriteMonad extra Bool) + -> (Term -> LetBinding -> Bool) -- ^ Test whether to lift or inline -- -- * True: inline -- * False: lift -> Rewrite extra -inlineOrLiftBinders condition inlineOrLift (TransformContext inScope0 _) expr@(Letrec xes res) = do - (replace,others) <- partitionM condition xes - case replace of - [] -> return expr +inlineOrLiftBinders condition inlineOrLift (TransformContext inScope0 _) e@(Letrec bndrs body) = do + (toReplace,toKeep) <- partitionM condition bndrs + case toReplace of + [] -> return e _ -> do - let inScope1 = extendInScopeSetList inScope0 (map fst xes) - (doInline,doLift) <- partitionM (inlineOrLift expr) replace + let inScope1 = extendInScopeSetList inScope0 (map fst bndrs) + let (toInline,toLift) = partition (inlineOrLift e) toReplace -- We first substitute the binders that we can inline both the binders -- that we intend to lift, the other binders, and the body - let (others',res') = substituteBinders inScope1 doInline (doLift ++ others) res - (doLift',others'') = splitAt (length doLift) others' - doLift'' <- mapM liftBinding doLift' + let (toLiftExtra,(toReplace1,body1)) = + substituteBinders inScope1 toInline (toLift ++ toKeep) body + (toLift1,toKeep1) = splitAt (length toLift) toReplace1 -- We then substitute the lifted binders in the other binders and the body - let (others3,res'') = substituteBinders inScope1 doLift'' others'' res' - newExpr = case others3 of - [] -> res'' - _ -> Letrec others3 res'' - changed newExpr + (toKeep2,body2) <- liftAndSubsituteBinders inScope1 + (toLiftExtra ++ toLift1) + toKeep1 body1 + case toKeep2 of + [] -> changed body2 + _ -> changed (Letrec toKeep2 body2) inlineOrLiftBinders _ _ _ e = return e @@ -600,7 +679,7 @@ newBody = mkTyLams (mkLams e' boundFVs) boundFTVs -- Check if an alpha-equivalent global binder already exists - aeqExisting <- (eltsUniqMap . filterUniqMap ((`aeqTerm` newBody) . (^. _4))) <$> Lens.use bindings + aeqExisting <- (eltsUniqMap . filterUniqMap ((`aeqTerm` newBody) . bindingTerm)) <$> Lens.use bindings case aeqExisting of -- If it doesn't, create a new binder [] -> do -- Add the created function to the list of global bindings @@ -613,20 +692,21 @@ -- function at this moment for a reason! -- (termination, CSE and DEC oppertunities, -- ,etc.) - (newBodyId - ,sp + (Binding + newBodyId + sp #if MIN_VERSION_ghc(8,4,1) - ,NoUserInline + NoUserInline #else - ,EmptyInlineSpec + EmptyInlineSpec #endif - ,newBody) + newBody) -- Return the new binder return (var, newExpr) -- If it does, use the existing binder - ((k,_,_,_):_) -> + (b:_) -> let newExpr' = mkTmApps - (mkTyApps (Var k) + (mkTyApps (Var $ bindingId b) (map VarTy boundFTVs)) (map Var boundFVs) in return (var, newExpr') @@ -669,12 +749,12 @@ -> RewriteMonad extra () addGlobalBind vNm ty sp inl body = do let vId = mkGlobalId ty vNm - (ty,body) `deepseq` bindings %= extendUniqMap vNm (vId,sp,inl,body) + (ty,body) `deepseq` bindings %= extendUniqMap vNm (Binding vId sp inl body) -- | Create a new name out of the given name, but with another unique. Resulting -- unique is guaranteed to not be in the given InScopeSet. cloneNameWithInScopeSet - :: (Monad m, MonadUnique m) + :: (MonadUnique m) => InScopeSet -> Name a -> m (Name a) @@ -685,7 +765,7 @@ -- | Create a new name out of the given name, but with another unique. Resulting -- unique is guaranteed to not be in the given BindingMap. cloneNameWithBindingMap - :: (Monad m, MonadUnique m) + :: (MonadUnique m) => BindingMap -> Name a -> m (Name a) @@ -724,7 +804,7 @@ -- | Make a binder that should not be referenced mkWildValBinder - :: (Monad m, MonadUnique m) + :: (MonadUnique m) => InScopeSet -> Type -> m Id @@ -733,7 +813,7 @@ -- | Make a case-decomposition that extracts a field out of a (Sum-of-)Product type mkSelectorCase :: HasCallStack - => (Functor m, Monad m, MonadUnique m) + => (Functor m, MonadUnique m) => String -- ^ Name of the caller of this function -> InScopeSet -> TyConMap -- ^ TyCon cache @@ -786,15 +866,24 @@ -> RewriteMonad extra Term specialise' specMapLbl specHistLbl specLimitLbl (TransformContext is0 _) e (Var f, args, ticks) specArgIn = do lvl <- Lens.view dbgLevel + tcm <- Lens.view tcCache -- Don't specialise TopEntities topEnts <- Lens.view topEntities if f `elemVarSet` topEnts - then traceIf (lvl >= DebugNone) ("Not specialising TopEntity: " ++ showPpr (varName f)) (return e) + then do + case specArgIn of + Left _ -> traceIf (lvl >= DebugNone) ("Not specializing TopEntity: " ++ showPpr (varName f)) (return e) + Right tyArg -> traceIf (lvl >= DebugApplied) ("Dropping type application on TopEntity: " ++ showPpr (varName f) ++ "\ntype:\n" ++ showPpr tyArg) $ + -- TopEntities aren't allowed to be semantically polymorphic. + -- But using type equality constraints they may be syntactically polymorphic. + -- > topEntity :: forall dom . (dom ~ "System") => Signal dom Bool -> Signal dom Bool + -- The TyLam's in the body will have been removed by 'Clash.Normalize.Util.substWithTyEq'. + -- So we drop the TyApp ("specialising" on it) and change the varType to match. + let newVarTy = piResultTy tcm (varType f) tyArg + in changed (mkApps (mkTicks (Var f{varType = newVarTy}) ticks) args) else do -- NondecreasingIndentation - tcm <- Lens.view tcCache - let specArg = bimap (normalizeTermTypes tcm) (normalizeType tcm) specArgIn -- Create binders and variable references for free variables in 'specArg' -- (specBndrsIn,specVars) :: ([Either Id TyVar], [Either Term Type]) @@ -818,7 +907,7 @@ -- Determine if we can specialize f bodyMaybe <- fmap (lookupUniqMap (varName f)) $ Lens.use bindings case bodyMaybe of - Just (_,sp,inl,bodyTm) -> do + Just (Binding _ sp inl bodyTm) -> do -- Determine if we see a sequence of specialisations on a growing argument specHistM <- lookupUniqMap f <$> Lens.use (extra.specHistLbl) specLim <- Lens.use (extra . specLimitLbl) @@ -860,7 +949,7 @@ -- are inlined, meaning the state-transition-function -- and the memory element will be in a single function. gTmM <- fmap (lookupUniqMap (varName g)) $ Lens.use bindings - return (g,maybe inl (^. _3) gTmM, maybe specArg (Left . (`mkApps` gArgs) . (^. _4)) gTmM) + return (g,maybe inl bindingSpec gTmM, maybe specArg (Left . (`mkApps` gArgs) . bindingTerm) gTmM) else return (f,inl,specArg) _ -> return (f,inl,specArg) -- Create specialized functions @@ -894,7 +983,7 @@ newBody = mkAbstraction specArg specBndrs -- See if there's an existing binder that's alpha-equivalent to the -- specialized function - existing <- filterUniqMap ((`aeqTerm` newBody) . (^. _4)) <$> Lens.use bindings + existing <- filterUniqMap ((`aeqTerm` newBody) . bindingTerm) <$> Lens.use bindings -- Create a new function if an alpha-equivalent binder doesn't exist newf <- case eltsUniqMap existing of [] -> do (cf,sp) <- Lens.use curFun @@ -906,7 +995,7 @@ EmptyInlineSpec #endif newBody - ((k,_,_,_):_) -> return k + (b:_) -> return (bindingId b) -- Create specialized argument let newArg = Left $ mkApps (Var newf) specVars -- Use specialized argument @@ -926,18 +1015,42 @@ normalizeId tcm v@(Id {}) = v {varType = normalizeType tcm (varType v)} normalizeId _ tyvar = tyvar +-- Note [Collect free-variables in an insertion-ordered set] +-- +-- In order for the specialization cache to work, 'specArgBndrsAndVars' should +-- yield (alpha equivalent) results for the same specialization. While collecting +-- free variables in a given term or type it should therefore keep a stable +-- ordering based on the order in which it finds free vars. To see why, +-- consider the following two pseudo-code calls to 'specialise': +-- +-- specialise {f ('a', x[123], y[456])} +-- specialise {f ('b', x[456], y[123])} +-- +-- Collecting the binders in a VarSet would yield the following (unique ordered) +-- sets: +-- +-- {x[123], y[456]} +-- {y[123], x[456]} +-- +-- ..and therefore breaking specializing caching. We now track them in insert- +-- ordered sets, yielding: +-- +-- {x[123], y[456]} +-- {x[456], y[123]} +-- -- | Create binders and variable references for free variables in 'specArg' specArgBndrsAndVars :: Either Term Type -> ([Either Id TyVar], [Either Term Type]) specArgBndrsAndVars specArg = - let unitFV :: Var a -> Const (UniqSet TyVar,UniqSet Id) (Var a) - unitFV v@(Id {}) = Const (emptyUniqSet,unitUniqSet (coerce v)) - unitFV v@(TyVar {}) = Const (unitUniqSet (coerce v),emptyUniqSet) + -- See Note [Collect free-variables in an insertion-ordered set] + let unitFV :: Var a -> Const (OSet.OLSet TyVar, OSet.OLSet Id) (Var a) + unitFV v@(Id {}) = Const (mempty, coerce (OSet.singleton (coerce v))) + unitFV v@(TyVar {}) = Const (coerce (OSet.singleton (coerce v)), mempty) (specFTVs,specFVs) = case specArg of - Left tm -> (eltsUniqSet *** eltsUniqSet) . getConst $ + Left tm -> (OSet.toListL *** OSet.toListL) . getConst $ Lens.foldMapOf freeLocalVars unitFV tm Right ty -> (eltsUniqSet (Lens.foldMapOf typeFreeVars unitUniqSet ty),[] :: [Id]) @@ -948,3 +1061,52 @@ specTmVars = map (Left . Var) specFVs in (specTyBndrs ++ specTmBndrs,specTyVars ++ specTmVars) + +-- | Evaluate an expression to weak-head normal form (WHNF), and apply a +-- transformation on the expression in WHNF. +whnfRW + :: Bool + -- ^ Whether the expression we're reducing to WHNF is the subject of a + -- case expression. + -> TransformContext + -> Term + -> Rewrite extra + -> RewriteMonad extra Term +whnfRW isSubj ctx@(TransformContext is0 _) e rw = do + tcm <- Lens.view tcCache + bndrs <- Lens.use bindings + (primEval, primUnwind) <- Lens.view evaluator + ids <- Lens.use uniqSupply + let (ids1,ids2) = splitSupply ids + uniqSupply Lens..= ids2 + gh <- Lens.use globalHeap + case whnf' primEval primUnwind bndrs tcm gh ids1 is0 isSubj e of + (!gh1,ph,v) -> do + globalHeap Lens..= gh1 + bindPureHeap tcm ph rw ctx v +{-# SCC whnfRW #-} + +-- | Binds variables on the PureHeap over the result of the rewrite +-- +-- To prevent unnecessary rewrites only do this when rewrite changed something. +bindPureHeap + :: TyConMap + -> PureHeap + -> Rewrite extra + -> Rewrite extra +bindPureHeap tcm heap rw (TransformContext is0 hist) e = do + (e1, Monoid.getAny -> hasChanged) <- Writer.listen $ rw ctx e + if hasChanged && not (null bndrs) + then return $ Letrec bndrs e1 + else return e1 + where + bndrs = map toLetBinding $ toListUniqMap heap + heapIds = map fst bndrs + is1 = extendInScopeSetList is0 heapIds + ctx = TransformContext is1 (LetBody heapIds : hist) + + toLetBinding :: (Unique,Term) -> LetBinding + toLetBinding (uniq,term) = (nm, term) + where + ty = termType tcm term + nm = mkLocalId ty (mkUnsafeSystemName "x" uniq) -- See [Note: Name re-creation] diff --git a/src/Clash/Unique.hs b/src/Clash/Unique.hs --- a/src/Clash/Unique.hs +++ b/src/Clash/Unique.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Clash.Unique ( -- * Unique @@ -40,6 +39,7 @@ , elemUniqMapDirectly -- ** Folding , foldrWithUnique + , foldlWithUnique' -- ** Conversions -- *** Lists , eltsUniqMap @@ -302,6 +302,14 @@ -> UniqMap a -> b foldrWithUnique f s (UniqMap m) = IntMap.foldrWithKey f s m + +-- | Strict left-fold over a map using both the key and the value +foldlWithUnique' + :: (a -> Unique -> b -> a) + -> a + -> UniqMap b + -> a +foldlWithUnique' f s (UniqMap m) = IntMap.foldlWithKey' f s m -- | Set of things that have a 'Unique' -- diff --git a/src/Clash/Util.hs b/src/Clash/Util.hs --- a/src/Clash/Util.hs +++ b/src/Clash/Util.hs @@ -6,12 +6,11 @@ Assortment of utility function used in the Clash library -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -47,6 +46,7 @@ import Debug.Trace (trace) import GHC.Base (Int(..),isTrue#,(==#),(+#)) import GHC.Integer.Logarithms (integerLogBase#) +import qualified GHC.LanguageExtensions.Type as LangExt import GHC.Stack (HasCallStack, callStack, prettyCallStack) import Type.Reflection (tyConPackage, typeRepTyCon, typeOf) import qualified Language.Haskell.TH as TH @@ -128,7 +128,7 @@ doc = sep [heading, nest 2 prettyMsg] -- | A class that can generate unique numbers -class MonadUnique m where +class Monad m => MonadUnique m where -- | Get a new unique getUniqueM :: m Int @@ -217,6 +217,11 @@ traceIf False _ = id {-# INLINE traceIf #-} +-- | A version of 'concatMap' that works with a monadic predicate. +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f as = concat <$> sequence (map f as) +{-# INLINE concatMapM #-} + -- | Monadic version of 'Data.List.partition' partitionM :: Monad m => (a -> m Bool) @@ -264,11 +269,30 @@ indexMaybe (x:_) 0 = Just x indexMaybe (_:xs) n = indexMaybe xs (n-1) +-- | Same as 'indexNote' with last two arguments swapped +indexNote' + :: HasCallStack + => String + -- ^ Error message to display + -> Int + -- ^ Index /n/ + -> [a] + -- ^ List to index + -> a + -- ^ Error or element /n/ +indexNote' = flip . indexNote + -- | Unsafe indexing, return a custom error message when indexing fails -indexNote :: String - -> [a] - -> Int - -> a +indexNote + :: HasCallStack + => String + -- ^ Error message to display + -> [a] + -- ^ List to index + -> Int + -- ^ Index /n/ + -> a + -- ^ Error or element /n/ indexNote note = \xs i -> fromMaybe (error note) (indexMaybe xs i) -- | Safe version of 'head' @@ -374,6 +398,18 @@ else anyM p xs +-- | short-circuiting monadic version of 'or' +orM + :: (Monad m) + => [m Bool] + -> m Bool +orM [] = pure False +orM (x:xs) = do + p <- x + if p then + pure True + else + orM xs -- | Get the package id of the type of a value -- >>> pkgIdFromTypeable (undefined :: TopEntity) @@ -411,6 +447,12 @@ else return False +traceWith :: (a -> String) -> a -> a +traceWith f a = trace (f a) a + +traceShowWith :: Show b => (a -> b) -> a -> a +traceShowWith f a = trace (show (f a)) a + -- | Left-biased choice on maybes orElse :: Maybe a -> Maybe a -> Maybe a orElse x@(Just _) _y = x @@ -419,3 +461,52 @@ -- | Left-biased choice on maybes orElses :: [Maybe a] -> Maybe a orElses = listToMaybe . catMaybes + +-- These language extensions are used for +-- * the interactive session inside clashi +-- * compiling files with clash +-- * running output tests with runghc +-- * compiling (local) Template/Blackbox functions with Hint +wantedLanguageExtensions, unwantedLanguageExtensions :: [LangExt.Extension] +wantedLanguageExtensions = + [ LangExt.BinaryLiterals + , LangExt.ConstraintKinds + , LangExt.DataKinds + , LangExt.DeriveAnyClass + , LangExt.DeriveGeneric + , LangExt.DeriveLift + , LangExt.DerivingStrategies + , LangExt.ExplicitForAll + , LangExt.ExplicitNamespaces + , LangExt.FlexibleContexts + , LangExt.FlexibleInstances + , LangExt.KindSignatures + , LangExt.MagicHash + , LangExt.MonoLocalBinds + , LangExt.QuasiQuotes + , LangExt.ScopedTypeVariables + , LangExt.TemplateHaskell + , LangExt.TemplateHaskellQuotes + , LangExt.TypeApplications + , LangExt.TypeFamilies + , LangExt.TypeOperators +#if !MIN_VERSION_ghc(8,6,0) + , LangExt.TypeInType +#endif + ] + +unwantedLanguageExtensions = + [ LangExt.ImplicitPrelude + , LangExt.MonomorphismRestriction +#if MIN_VERSION_ghc(8,6,0) + , LangExt.StarIsType +#endif + , LangExt.Strict + , LangExt.StrictData + ] + +filterOnFst :: (a -> Bool) -> [(a, b)] -> [b] +filterOnFst f xs = map snd (filter (f . fst) xs) + +filterOnSnd :: (b -> Bool) -> [(a, b)] -> [a] +filterOnSnd f xs = map fst (filter (f . snd) xs) diff --git a/src/Clash/Util/Graph.hs b/src/Clash/Util/Graph.hs --- a/src/Clash/Util/Graph.hs +++ b/src/Clash/Util/Graph.hs @@ -5,6 +5,7 @@ Collection of utilities -} + module Clash.Util.Graph (topSort, reverseTopSort) where import Data.Tuple (swap) diff --git a/src/Clash/Util/Interpolate.hs b/src/Clash/Util/Interpolate.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Util/Interpolate.hs @@ -0,0 +1,369 @@ +{-| +Copyright : (C) 2019, QBayLogic B.V. + 2013, Nikita Volkov +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. +-} + +{- +This is an adaptation of + + https://github.com/nikita-volkov/neat-interpolation/tree/0fc1dd73ea + +which is licensed under MIT. The original license will follow. + +--------- + +Copyright (c) 2013, Nikita Volkov + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +-} + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} + +module Clash.Util.Interpolate(i) where + +import Language.Haskell.Meta.Parse (parseExp) +import Language.Haskell.TH.Lib (appE, varE) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH.Syntax (Q, Exp) + +import qualified Numeric as N +import Data.Char + (isHexDigit, chr, isOctDigit, isDigit, isSpace) +import Data.Maybe (fromMaybe, isJust, catMaybes) +import Text.Read (readMaybe) + +data Line + = EmptyLine + | ExprLine Indent String + | Line Indent [Node] + deriving (Show) + +data Node + = Literal String + | Expression String + deriving (Show) + +type Indent = Int + +format :: [Node] -> String +format = stripWhiteSpace . showLines . nodesToLines + where + go _ [] = [] + go n (c:cs) | c == ' ' = go (n+1) cs + go 0 (c:cs) = c : go 0 cs + go n cs = replicate n ' ' ++ (go 0 cs) + + stripWhiteSpace = go 0 . dropWhile isSpace + + +showLines :: [Line] -> String +showLines [] = "" +showLines ns = init (concatMap showLine ns) + where + showLine :: Line -> String + showLine EmptyLine = "\n" + showLine (Line n ns') = + let theIndent = replicate (n - commonIndent) ' ' in + theIndent ++ (concatMap nodeToString ns') ++ "\n" + showLine (ExprLine n s) = + let theIndent = replicate (n - commonIndent) ' ' in + concat [theIndent ++ l ++ "\n" | l <- lines s] + + nodeToString :: Node -> String + nodeToString (Literal s) = s + nodeToString (Expression s) = s + + commonIndent :: Indent + commonIndent = foldl1 min (catMaybes (map indent ns)) + + indent :: Line -> Maybe Indent + indent EmptyLine = Nothing + indent (ExprLine n _) = Just n + indent (Line n _) = Just n + +-- | Collects nodes into lines. Expressions might still contain newlines! Does +-- not start or end with 'EmptyLine'. +nodesToLines :: [Node] -> [Line] +nodesToLines = + concatMap splitLines + . mergeLines + . dropEmpty + . map splitWords + . map toLine + . map dropTrailingEmpty + . collectLines [] + . joinLiterals + where + emptyLit (Literal s) = + if all isSpace s then + Just (length s) + else + Nothing + emptyLit _ = Nothing + + isEmptyLine EmptyLine = True + isEmptyLine _ = False + + dropEmpty = reverse . dropWhile isEmptyLine . reverse . dropWhile isEmptyLine + dropTrailingEmpty = reverse . dropWhile (isJust . emptyLit) . reverse + + splitLines :: Line -> [Line] + splitLines EmptyLine = [EmptyLine] + splitLines e@(ExprLine {}) = [e] + splitLines (Line n nodes) = map (Line n) (go 0 [] nodes) + where + maxLength = 80 + + go :: Int -> [Node] -> [Node] -> [[Node]] + go accLen acc goNodes | accLen > maxLength = reverse acc : go 0 [] goNodes + go accLen acc (l@(Literal s):goNodes) = go (accLen + length s) (l:acc) goNodes + go accLen acc (e@(Expression s):goNodes) = go (accLen + length s) (e:acc) goNodes + go _accLen acc [] = [reverse acc] + + mergeLines :: [Line] -> [Line] + mergeLines (l0@(Line n0 nodes0):l1@(Line n1 nodes1):ls) = + if n0 == n1 then + mergeLines (Line n0 (nodes0 ++ [Literal " "] ++ nodes1) : ls) + else + l0:mergeLines (l1:ls) + mergeLines (l:ls) = l:mergeLines ls + mergeLines [] = [] + + splitWords :: Line -> Line + splitWords EmptyLine = EmptyLine + splitWords e@(ExprLine {})= e + splitWords (Line n nodes) = Line n (concatMap go nodes) + where + go (Expression s) = [Expression s] + go (Literal "") = [] + go (Literal s0) = + let + pre = takeWhile (not . (==' ')) s0 + post = dropWhile (not . (== ' ')) s0 + in case post of + [] -> [Literal s0] + (_:s1) -> Literal (pre ++ " ") : go (Literal s1) + + -- Convert to 'Line' type + toLine = \case + [] -> EmptyLine + [emptyLit -> Just _] -> EmptyLine + [Expression s] -> ExprLine 0 s + [emptyLit -> Just n, Expression s] -> ExprLine n s + ns@(Expression _:_) -> Line 0 ns + (Literal s:ns) -> + Line + (length (takeWhile (==' ') s)) + (Literal (dropWhile (==' ') s):ns) + + -- collects list of nodes, where each list is a single line + collectLines collected todo = + case (collected, todo) of + ([], []) -> [] + (_, []) -> [reverse collected] + (_, s@(Expression _):ns) -> + collectLines (s:collected) ns + (_, Literal s0:ns) -> + let + pre = takeWhile (/= '\n') s0 + post = dropWhile (/= '\n') s0 + in case post of + [] -> + collectLines (Literal s0:collected) ns + (_:s1) -> + reverse (Literal pre:collected) : collectLines [] (Literal s1:ns) + + joinLiterals :: [Node] -> [Node] + joinLiterals [] = [] + joinLiterals (Literal s0:Literal s1:ss) = joinLiterals (Literal (s0 ++ s1):ss) + joinLiterals (n:ns) = n:joinLiterals ns + +i :: QuasiQuoter +i = QuasiQuoter { + quoteExp = (varE 'format `appE`) . toExp . parseNodes . decodeNewlines + , quotePat = err "pattern" + , quoteType = err "type" + , quoteDec = err "declaration" + } + where + err name = + error ("Clash.Util.Interpolate.i: This QuasiQuoter can not be used as a " + ++ name ++ "!") + + toExp:: [Node] -> Q Exp + toExp nodes = case nodes of + [] -> [|[]|] + (x:xs) -> f x `appE` toExp xs + where + f (Literal s) = [|(Literal s:)|] + f (Expression e) = [|(Expression (toString ($(reifyExpression e))):)|] + + reifyExpression :: String -> Q Exp + reifyExpression s = case parseExp s of + Left _ -> do + fail ("Parse error in expression: " ++ s) :: Q Exp + Right e -> return e + +parseNodes :: String -> [Node] +parseNodes = go "" + where + go :: String -> String -> [Node] + go acc input = case input of + "" -> [(lit . reverse) acc] + '\\':x:xs -> go (x:'\\':acc) xs + '#':'{':xs -> goExpr input acc [] xs + x:xs -> go (x:acc) xs + -- allow '}' to be escaped in code sections + goExpr input accLit accExpr xs = case span (\x -> x /= '}' && x /= '\\') xs of + (ys, '}' :zs) -> (lit . reverse) accLit : Expression (reverse accExpr ++ ys) : go "" zs + (ys, '\\':'}':zs) -> goExpr input accLit ('}' : reverse ys ++ accExpr) zs + (ys, '\\':zs) -> goExpr input accLit ('\\' : reverse ys ++ accExpr) zs + (_, "") -> [lit (reverse accLit ++ input)] + _ -> error "(impossible) parseError in parseNodes" + lit :: String -> Node + lit = Literal . unescape + +------------------------------------------------------------------- +-- Everything below this line is unchanged from neat-interpolate -- +------------------------------------------------------------------- +decodeNewlines :: String -> String +decodeNewlines = go + where + go xs = case xs of + '\r' : '\n' : ys -> '\n' : go ys + y : ys -> y : go ys + [] -> [] + +toString :: Show a => a -> String +toString a = let s = show a in fromMaybe s (readMaybe s) +{-# NOINLINE toString #-} +{-# RULES "toString/String" toString = id #-} +{-# RULES "toString/Int" toString = show :: Int -> String #-} +{-# RULES "toString/Integer" toString = show :: Integer -> String #-} +{-# RULES "toString/Float" toString = show :: Float -> String #-} +{-# RULES "toString/Double" toString = show :: Double -> String #-} + +-- Haskell 2010 character unescaping, see: +-- http://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6 +unescape :: String -> String +unescape = go + where + go input = case input of + "" -> "" + '\\' : 'x' : x : xs | isHexDigit x -> case span isHexDigit xs of + (ys, zs) -> (chr . readHex $ x:ys) : go zs + '\\' : 'o' : x : xs | isOctDigit x -> case span isOctDigit xs of + (ys, zs) -> (chr . readOct $ x:ys) : go zs + '\\' : x : xs | isDigit x -> case span isDigit xs of + (ys, zs) -> (chr . read $ x:ys) : go zs + '\\' : input_ -> case input_ of + '\\' : xs -> '\\' : go xs + 'a' : xs -> '\a' : go xs + 'b' : xs -> '\b' : go xs + 'f' : xs -> '\f' : go xs + 'n' : xs -> '\n' : go xs + 'r' : xs -> '\r' : go xs + 't' : xs -> '\t' : go xs + 'v' : xs -> '\v' : go xs + '&' : xs -> go xs + 'N':'U':'L' : xs -> '\NUL' : go xs + 'S':'O':'H' : xs -> '\SOH' : go xs + 'S':'T':'X' : xs -> '\STX' : go xs + 'E':'T':'X' : xs -> '\ETX' : go xs + 'E':'O':'T' : xs -> '\EOT' : go xs + 'E':'N':'Q' : xs -> '\ENQ' : go xs + 'A':'C':'K' : xs -> '\ACK' : go xs + 'B':'E':'L' : xs -> '\BEL' : go xs + 'B':'S' : xs -> '\BS' : go xs + 'H':'T' : xs -> '\HT' : go xs + 'L':'F' : xs -> '\LF' : go xs + 'V':'T' : xs -> '\VT' : go xs + 'F':'F' : xs -> '\FF' : go xs + 'C':'R' : xs -> '\CR' : go xs + 'S':'O' : xs -> '\SO' : go xs + 'S':'I' : xs -> '\SI' : go xs + 'D':'L':'E' : xs -> '\DLE' : go xs + 'D':'C':'1' : xs -> '\DC1' : go xs + 'D':'C':'2' : xs -> '\DC2' : go xs + 'D':'C':'3' : xs -> '\DC3' : go xs + 'D':'C':'4' : xs -> '\DC4' : go xs + 'N':'A':'K' : xs -> '\NAK' : go xs + 'S':'Y':'N' : xs -> '\SYN' : go xs + 'E':'T':'B' : xs -> '\ETB' : go xs + 'C':'A':'N' : xs -> '\CAN' : go xs + 'E':'M' : xs -> '\EM' : go xs + 'S':'U':'B' : xs -> '\SUB' : go xs + 'E':'S':'C' : xs -> '\ESC' : go xs + 'F':'S' : xs -> '\FS' : go xs + 'G':'S' : xs -> '\GS' : go xs + 'R':'S' : xs -> '\RS' : go xs + 'U':'S' : xs -> '\US' : go xs + 'S':'P' : xs -> '\SP' : go xs + 'D':'E':'L' : xs -> '\DEL' : go xs + '^':'@' : xs -> '\^@' : go xs + '^':'A' : xs -> '\^A' : go xs + '^':'B' : xs -> '\^B' : go xs + '^':'C' : xs -> '\^C' : go xs + '^':'D' : xs -> '\^D' : go xs + '^':'E' : xs -> '\^E' : go xs + '^':'F' : xs -> '\^F' : go xs + '^':'G' : xs -> '\^G' : go xs + '^':'H' : xs -> '\^H' : go xs + '^':'I' : xs -> '\^I' : go xs + '^':'J' : xs -> '\^J' : go xs + '^':'K' : xs -> '\^K' : go xs + '^':'L' : xs -> '\^L' : go xs + '^':'M' : xs -> '\^M' : go xs + '^':'N' : xs -> '\^N' : go xs + '^':'O' : xs -> '\^O' : go xs + '^':'P' : xs -> '\^P' : go xs + '^':'Q' : xs -> '\^Q' : go xs + '^':'R' : xs -> '\^R' : go xs + '^':'S' : xs -> '\^S' : go xs + '^':'T' : xs -> '\^T' : go xs + '^':'U' : xs -> '\^U' : go xs + '^':'V' : xs -> '\^V' : go xs + '^':'W' : xs -> '\^W' : go xs + '^':'X' : xs -> '\^X' : go xs + '^':'Y' : xs -> '\^Y' : go xs + '^':'Z' : xs -> '\^Z' : go xs + '^':'[' : xs -> '\^[' : go xs + '^':'\\' : xs -> '\^\' : go xs + '^':']' : xs -> '\^]' : go xs + '^':'^' : xs -> '\^^' : go xs + '^':'_' : xs -> '\^_' : go xs + xs -> go xs + x:xs -> x : go xs + + readHex :: String -> Int + readHex xs = case N.readHex xs of + [(n, "")] -> n + _ -> error "Data.String.Interpolate.Util.readHex: no parse" + + readOct :: String -> Int + readOct xs = case N.readOct xs of + [(n, "")] -> n + _ -> error "Data.String.Interpolate.Util.readHex: no parse" diff --git a/src/Data/Aeson/Extra.hs b/src/Data/Aeson/Extra.hs --- a/src/Data/Aeson/Extra.hs +++ b/src/Data/Aeson/Extra.hs @@ -14,6 +14,8 @@ import Data.Aeson (FromJSON, Result (..), fromJSON, json) import Data.Attoparsec.Lazy (Result (..), parse) import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BSChar import System.FilePath () import Clash.Util (ClashException(..)) @@ -55,8 +57,12 @@ -> a decodeOrErr path contents = case parse json contents of - Done _ v -> + Done leftover v -> case fromJSON v of + Success _ | BS.any notWhitespace leftover -> + clashError ("After parsing " ++ show path + ++ ", found unparsed trailing garbage:\n" + ++ BSChar.unpack leftover) Success a -> a Error msg -> @@ -77,3 +83,5 @@ where loc = mkGeneralSrcSpan $ mkFastString path clashError msg = throw $ ClashException loc msg Nothing + notWhitespace c = BS.notElem c whitespace + where whitespace = BSChar.pack " \t\n\r" diff --git a/src/Data/Set/Ordered/Extra.hs b/src/Data/Set/Ordered/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Set/Ordered/Extra.hs @@ -0,0 +1,36 @@ +{-| + Copyright : (C) 2019, QBayLogic B.V + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V + + Convenience functions for "Data.Set.Ordered" from the package + "ordered-containers". +-} + +module Data.Set.Ordered.Extra + ( OLSet + , ORSet + , toSetL + , toSetR + , toListL + , toListR + ) where + +import Data.Coerce (coerce) +import Data.Foldable (toList) +import qualified Data.Set.Ordered as OSet + +type OLSet a = OSet.Bias OSet.L (OSet.OSet a) +type ORSet a = OSet.Bias OSet.R (OSet.OSet a) + +toSetL :: Ord a => [a] -> OLSet a +toSetL = coerce . OSet.fromList + +toSetR :: Ord a => [a] -> ORSet a +toSetR = coerce . OSet.fromList + +toListL :: forall a. OLSet a -> [a] +toListL = toList . coerce @(OLSet a) @(OSet.OSet a) + +toListR :: forall a. ORSet a -> [a] +toListR = toList . coerce @(ORSet a) @(OSet.OSet a) diff --git a/src/Data/Text/Prettyprint/Doc/Extra.hs b/src/Data/Text/Prettyprint/Doc/Extra.hs --- a/src/Data/Text/Prettyprint/Doc/Extra.hs +++ b/src/Data/Text/Prettyprint/Doc/Extra.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -179,3 +178,11 @@ instance Applicative f => IsString (f Doc) where fromString = string . fromString + +comment :: Applicative f => T.Text -> T.Text -> f Doc +comment prefix comm = + let go s = PP.pretty prefix PP.<+> PP.pretty s in + pure (PP.vsep (Prelude.map go (T.lines comm))) + +squote :: Applicative f => f Doc +squote = string (LT.pack "'") diff --git a/src/GHC/BasicTypes/Extra.hs b/src/GHC/BasicTypes/Extra.hs --- a/src/GHC/BasicTypes/Extra.hs +++ b/src/GHC/BasicTypes/Extra.hs @@ -4,9 +4,6 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.BasicTypes.Extra where diff --git a/src/GHC/SrcLoc/Extra.hs b/src/GHC/SrcLoc/Extra.hs --- a/src/GHC/SrcLoc/Extra.hs +++ b/src/GHC/SrcLoc/Extra.hs @@ -4,10 +4,8 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/tests/Clash/Tests/Core/Subst.hs b/tests/Clash/Tests/Core/Subst.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/Core/Subst.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Clash.Tests.Core.Subst (tests) where + +import SrcLoc (noSrcSpan) + +import Test.Tasty +import Test.Tasty.HUnit + +import Clash.Core.Name (Name(..), NameSort(..)) +import Clash.Core.Term (Term(Var)) +import Clash.Core.Type (ConstTy(..), Type(ConstTy)) +import Clash.Core.Subst +import Clash.Core.VarEnv +import Clash.Core.Var (IdScope(..), Var(..)) + +fakeName :: Name a +fakeName = + Name + { nameSort=User + , nameOcc="fake" + , nameUniq=0 + , nameLoc=noSrcSpan + } + +unique :: Int +unique = 20 + +termVar :: Var Term +termVar = Id { + varName = fakeName {nameUniq=unique, nameOcc="term"} + , varUniq = unique + , varType = ConstTy (TyCon fakeName) + , idScope = LocalId + } + +typeVar :: Var Type +typeVar = TyVar { + varName = fakeName {nameUniq=unique, nameOcc="type"} + , varUniq = unique + , varType = ConstTy (TyCon fakeName) + } + +term1 :: Term +term1 = Var termVar + +tests :: TestTree +tests = + testGroup + "Clash.Tests.Core.Subst" + [ testCase "deShadow type/term" $ + term1 @=? deShadowTerm (extendInScopeSet emptyInScopeSet typeVar) term1 + ] diff --git a/tests/Clash/Tests/Util/Interpolate.hs b/tests/Clash/Tests/Util/Interpolate.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/Util/Interpolate.hs @@ -0,0 +1,72 @@ +{-| +Copyright : (C) 2019, QBayLogic B.V. +License : BSD2 (see the file LICENSE) +Maintainer : QBayLogic B.V. +-} +{-# LANGUAGE QuasiQuotes #-} + +module Clash.Tests.Util.Interpolate where + +import qualified Clash.Util.Interpolate as I + +import Test.Tasty +import Test.Tasty.HUnit + +test1, test2, test3, test4, test5, test6, test7, test8, test9 :: String +test1 = [I.i| Simple |] +test2 = [I.i| + Single line +|] +test3 = [I.i| + + Surrounded by newlines + +|] +test4 = [I.i| + One + Two + Three +|] +test5 = [I.i| + One + Two + Three +|] +test6 = [I.i| + #{test5} +|] + +test7 = [I.i| + The big test: + + #{test5} +|] + +test8 = [I.i| + looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong word +|] + +data SomeRecord = SomeRecord { getField :: Int } +someRecord :: SomeRecord +someRecord = SomeRecord 5 +-- test that we can escape closing '}' +test9 = [I.i| #{ "\\" ++ show (getField someRecord { getField=6*7 + \} + ) + } + |] + +tests :: TestTree +tests = + testGroup + "Clash.Tests.Core.Util.Interpolation" + [ testCase "test1" $ "Simple" @=? test1 + , testCase "test2" $ "Single line" @=? test2 + , testCase "test3" $ "Surrounded by newlines" @=? test3 + , testCase "test4" $ "One Two Three" @=? test4 + , testCase "test5" $ "One\n Two\nThree" @=? test5 + , testCase "test6" $ test5 @=? test6 + , testCase "test7" $ test7 @?= ("The big test:\n\n" ++ test5) + , testCase "test8" $ test8 @?= "looooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooong \nword" + , testCase "test9" $ test9 @?= "\\42" + ] diff --git a/tests/unittests.hs b/tests/unittests.hs --- a/tests/unittests.hs +++ b/tests/unittests.hs @@ -3,10 +3,14 @@ import Test.Tasty import qualified Clash.Tests.Core.FreeVars +import qualified Clash.Tests.Core.Subst +import qualified Clash.Tests.Util.Interpolate tests :: TestTree tests = testGroup "Unittests" [ Clash.Tests.Core.FreeVars.tests + , Clash.Tests.Core.Subst.tests + , Clash.Tests.Util.Interpolate.tests ] main :: IO ()