diff --git a/AUTHORS.md b/AUTHORS.md --- a/AUTHORS.md +++ b/AUTHORS.md @@ -1,2 +1,1 @@ -* [Christiaan Baaij](mailto:christiaan.baaij@gmail.com) [@christiaanb](https://github.com/christiaanb) -* John Ericson [@Ericson2314](https://github.com/Ericson2314) +See [GitHub contributors statistics](https://github.com/clash-lang/clash-compiler/graphs/contributors) and [clash-lang.org/publications](https://clash-lang.org/publications/). diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,21 +1,155 @@ -# Changelog for [`clash-prelude` package](http://hackage.haskell.org/package/clash-prelude) +# 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 @@ -35,404 +169,151 @@ 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 26th 2018* -* Bundle and BitPack instances up to and including 62-tuples -* Handle undefined writes to RAM properly -* Handle undefined clock enables properly +## 0.99.3 *July 28th 2018* +* Fixes bugs: + * Evaluator recognizes `Bit` literals [#329](https://github.com/clash-lang/clash-compiler/issues/329) + * Use existential type-variables in context of GADT pattern match + * Do not create zero-bit temporary variables in generated HDL + * Use correct arguments in nested primitives [#323](https://github.com/clash-lang/clash-compiler/issues/329) + * Zero-constructor data type needs 0 bits [#238](https://github.com/clash-lang/clash-compiler/issues/238) + * Create empty component when result needs 0 bits + * Evaluator performs BigNat arithmetic +* Features: + * Bundle and BitPack instances up to and including 62-tuples + * Handle undefined writes to RAM properly + * Handle undefined clock enables properly + + ## 0.99.1 *May 12th 2018* +* Allow `~NAME[N]` tag inside `~GENSYM[X]` +* Support HDL record selector generation [#313](https://github.com/clash-lang/clash-compiler/pull/313) +* `InlinePrimitive` support: specify HDL primitives inline with Haskell code * Support for `ghc-typelits-natnormalise-0.6.1` * `Lift` instances for `TopEntity` and `PortName` * `InlinePrimitive` support: specify HDL primitives inline with Haskell code ## 0.99 *March 31st 2018* -* 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 + * 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: + * 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` + * DDR registers: + * Generic/ASIC: `Clash.Explicit.DDR` + * Intel: `Clash.Intel.DDR` + * Xilinx: `Clash.Intel.Xilinx` * `Bit` is now a `newtype` instead of a `type` synonym and will be mapped to a HDL scalar instead of an array of one (e.g `std_logic` instead of `std_logic_vector(0 downto 0)`) + * Hierarchies with multiple synthesisable boundaries by allowing more than one + function in scope to have a `Synthesize` annotation. + * Local caching of functions with a `Synthesize` annotation + * `Bit` type is mapped to a HDL scalar type (e.g. `std_logic` in VHDL) + * Improved name preservation + * Zero-bit values are filtered out of the generated HDL + * Improved compile-time computation +* Many bug fixes -## 0.11.2 -* New features: - * Add `riseEvery`: Give a pulse every @n@ clock cycles. (Thanks to @thoughtpolice) - * Add `oscillate`: Oscillate a @'Bool'@ with a given half-period of cycles. (Thanks to @thoughtpolice) -* Fixes bugs: - * Eagerness bug in `regEn` [#104](https://github.com/clash-lang/clash-prelude/issues/104) (Thanks to @cbiffle) +## 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.11.1 -* Changes: - * Bundle instance for `()` behaves like a product-type instance [#96](https://github.com/clash-lang/clash-prelude/issues/96) -* Fixes bugs: - * Ensure that `fold` gets correctly type-applied in `Vec.==` [#202](https://github.com/clash-lang/clash-compiler/issues/202) -## 0.11 -* New features: - * `CLaSH.XException`: a module defining an exception representing uninitialised values. Additionally adds the `ShowX` class which has methods that prints values as "X" where they would normally raise an `XException` exception. - * Add `BNat` (and supporting functions) to `CLaSH.Promoted.Nat`: base-2 encoded natural numbers. - * Add `divSNat` and `logBaseSNat` to `CLaSH.Promoted.Nat`: division and logarithm for singleton natural numbers. - * Add `predUNat` and `subUNat` to `CLaSH.Promoted.Nat`: predecessor and subtraction for unary-encoded natural numbers. - * Add `dtfold` to `CLaSH.Sized.Vector`: a dependently-typed tree-fold over `Vec`. - * Add the perfect-depth binary trees module `CLaSH.Sized.RTree` - * Synthesisable definitions of `countLeadingZeros` and `countTrailingZeros` for: `BitVector`, `Signed`, `Unsigned`, and `Fixed` - * Add the `(:::)` type alias in `CLaSH.NamedTypes` which allows you to annotate types with documentation -* Changes: - * `asyncRam`, `blockRam`, `blockRamFile` have a `Maybe (addr,a)` as write input instead of three separate `Bool`, `addr`, and `a` inputs. - * `asyncFIFOSynchronizer` has a `Maybe a` as write-request instead of a separate `Bool` and `a` input - * `bundle'` and `unbundle'` are removed; `bundle` now has type `Unbundled' clk a -> Signal' clk a`, `unbundle` now has type `Signal' clk a -> Unbundled' clk a` - * `subSNat` now has the type `SNat (a+b) -> SNat b -> SNat a` (where it used to be `SNat a -> SNat b -> SNat (a-b)`) - * Renamed `multUNat` to `mulUNat` to be in sync with `mulSNat` and `mulBNat`. - * The function argument of `vfold` in `CLaSH.Sized.Vector` is now `(forall l . SNat l -> a -> Vec l b -> Vec (l + 1) b)` (where it used to be `(forall l . a -> Vec l b -> Vec (l + 1) b)`) - * `Cons` constructor of `Vec` is no longer visible; `(:>)` and `(:<)` are now listed as constructors of `Vec` - * Simulation speed improvements for numeric types - -## 0.10.12 -* Fixes bugs: - * `Vec`s `unbundle` is too strict, i.e. `register (undefined :: Vec 2 Int)` /= `bundle . unbundle . register (undefined :: Vec 2 Int)` - -## 0.10.11 *August 3rd 2016* -* New features: - * Add strict version of: `sample`, `sampleN`, `fromList`, and `simulate` - * Make `Signal`s `<*>` slightly stricter: - * Feedback loops still work with this new implementation - * No more space-leaks when used in combination with the strict version of `sample`, `sampleN`, and `simulate` - * Add `NFData` instances for the numeric types -* Speed up arithmetic operations of `Signed`, `Unsigned` and `BitVector` -* Fixes bugs: - * CLaSH compiler sees internals of numeric types in their `Lift` functions - -## 0.10.10 *July 15th 2016* -* Fixes bugs: - * `shrink` functions for numeric types throw exceptions [#153](https://github.com/clash-lang/clash-compiler/issues/153) - * CLaSH compiler sees internals of numeric types in their Show functions - -## 0.10.9 *June 9th 2016* -* Fixes bugs: - * `Eq` instance of `Vec` sometimes not synthesisable - -## 0.10.8 *June 7th 2016* -* New features: - * Instances of `Data` for numeric types. - * Instances of `Read` for {Index, Signed, Unsigned, Fixed} - * Instances of `BitPack` for 3-8 tuples - -## 0.10.7 *April 7th 2016* -* Support doctest-0.11.0 - -## 0.10.6 *February 10th 2016* -* Fixes bugs: - * `CLaSH.Prelude.DataFlow.parNDF` is not lazy enough - -## 0.10.5 *January 13th 2016* -* New features: - * Add `readNew` to `CLaSH.Prelude.BlockRam`: create a read-after-write blockRAM from a read-before-write blockRAM. - * `popCount` functions for `BitVector`, `Signed`, and `Unsigned` are now synthesisable. - * Add `parNDF` to `CLaSH.Prelude.DataFlow`: compose _N_ dataflow circuits in parallel. - * Add and instance `Vec n a` for `LockStep` in `CLaSH.Prelude.DataFlow`: have _N_ dataflow circuits operate in lock-step. - -## 0.10.4 *December 11th 2015* -* New features: - * Add `pureDF` to `CLaSH.Prelude.DataFlow`: lift combinational circuits to `DataFlow` circuits. - * Add `fifoDF` to `CLaSH.Prelude.DataFlow`: a simple FIFO buffer adhering to the `DataFlow` protocol. - * `loopDF` no longer uses the `lockStep` and `stepLock` automatically, and now includes a FIFO buffer on the feedback path. - * Add `loopDF_nobuf` to `CLaSH.Prelude.DataFlow`: a version of `loopDF` with no FIFO buffer on the feedback path. - * Add `boolToBV` to `CLaSH.CLass.BitPack`: convert `Bool`eans to `n`-bit `BitVector`s. - * `ClockSource` in `CLaSH.Annotations.TopEntity` can now have multiple clock inputs [#33](https://github.com/clash-lang/clash-prelude/issues/33) -* Bug fixes: - * `asyncRomFile` reads file multiple times. - -## 0.10.3 *October 24th 2015* -* Disable CPR analysis (See https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c): - * GHC < 7.11: In all modules using `-fcpr-off` - * GHC >= 7.11: In `CLaSH.Signal.Internal` and `CLaSH.Prelude.RAM` using `-fno-cpr-anal` - -## 0.10.2 *October 21st 2015* -* New features: - * `ExtendingNum`, `BitPack`, and `Resize` instance for `Index` - * Add `bv2i`: convert `BitVector n` to `Index (2^n)` - * Export type-level operations from [ghc-typelits-extra](http://hackage.haskell.org/package/ghc-typelits-extra) - -## 0.10.1 *October 16th 2015* -* New features: - * The `f` in `dfold p f`, now has an `SNat l` instead of a `Proxy l` as its first argument. - * Add `bv2v` and `v2bv` functions that convert between `Vec n Bit` and `BitVector n`. - * Add `smap`: apply a function to every element of a vector and the element's position (as an 'SNat' value) in the vector. - -## 0.10 *October 3rd 2015* -* New features: - * The Vec constructor `:>` is now an explicitly bidirectional pattern synonym (the actual constructor has been renamed to Cons). - As a result, pattern matching on `:>` is now synthesisable by the CLaSH compiler. - * The function `<:` is replaced by the the explicitly bidirectional pattern synonym `:<`. - This allows you to pattern match on: "all but the last element of a vector" and "the last element" of the vector. - Because it is a bidirectional pattern, `:<` can also be used as an expression that appends an element to the tail of a vector. - * Add a `transpose` function in `CLaSH.Sized.Vector`. - * Add `stencil1d` and `stensil2d` stencil computation functions in `CLaSH.Sized.Vector`. - * Add `permute`, `backpermute`, `scatter`, and `gather` permutation functions in `CLaSH.Sized.Vector`. - * Add specialised permutation functions `interleave`, `rotateLeft`, and `rotateRight` in `CLaSH.Sized.Vector`. - * `sscanl` and `sscanr` in `CLaSH.Sized.Vector` are renamed to `postscanl` and postscanr` to be more in line with existing Haskell packages such as `vector` and `accelerate`. - * The `Foldable` and `Traversable` instances of `Vec` now only works for non-empty vectors. - * Where possible, members of the `Foldable` instance of `Vec` are described in terms of `fold`, which builds a tree (of depth `log(n)`) of computations, instead of `foldr` which had depth `n` computations. - This reduces the critical path length in your circuits when using these functions. - * `maxIndex` and `length` in `CLaSH.Sized.Vector` return an `Int` instead of an `Integer`. - * Add functions that involve an index into a vector to the `CLaSH.Sized.Vector` module: `indices`, `indicesI`, `imap`, `izipWith`, `ifoldr`, `ifoldl`, `findIndex`, `elemIndex`. - * `CLaSH.Sized.Vector`'s `fold`, `dfold`, `vfold`, and `toList` are now synthesisable by the CLaSH compiler. - -## 0.9.3 *September 21st 2015* -* Fixes bugs: - * Cannot build against singletons-0.2 - * Numerous documentation fixes - -## 0.9.2 *August 2nd 2015* -* Disable strictness analysis in `CLaSH.Signal.Internal`, this allows turning on strictness analysis in the GHC front-end of the CLaSH compiler. - -## 0.9.1 *June 26th 2015* -* Updated documentation on data-file support on Altera/Quartus - -## 0.9 *June 25th 2015* -* New features: - * Add operations on singleton natural numbers: `addSNat`, `subSNat`, `mulSNat`, and `powSNat`. - * Add asynchronous RAM functions in `CLaSH.Prelude.RAM`, which have an asynchronous/combinational read port. - * Add ROM functions in modules `CLaSH.Prelude.ROM` and `CLaSH.Prelude.ROM.File`, where the latter module contains functions that instantiate a ROM from the content specified in an external data-file. - * Add BlockRam functions, in the `CLaSH.Prelude.BlockRam.File` module, whose content can be initialised with the content specified in an external data-file. - * `assert` now takes an extra `String` argument so you can distinguish one `assert` from the others. - Additionally, `assert'` is added which takes an additional `SClock` argument. - This is needed, because `assert` now reports the clock cycle, and clock domain, when an assertion fails. - * `defClkAltera` and `defClkXilinx` are replaced by, `altpll` and `alteraPll` for Altera clock sources, and `clockWizard` for Xilinx clock sources. - These names correspond to the names of the generator utilities in Quartus and ISE/Vivado. - * Add [Safe](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/safe_haskell.html) versions of the prelude modules: `CLaSH.Prelude.Safe` and `CLaSH.Prelude.Explicit.Safe` - * Add synchronizers in the `CLaSH.Prelude.Synchronizer` module - -## 0.8 *June 3rd 2015* -* New features: - * Make the (Bit)Vector argument the _last_ argument for the following functions: `slice`, `setSlice`, `replaceBit`, `replace`. The signatures for the above functions are now: - - ``` - slice :: BitPack a => SNat m -> SNat n -> a -> BitVector (m + 1 - n) - setSlice :: BitPack a => SNat m -> SNat n -> BitVector (m + 1 - n) -> a -> a - replaceBit :: Integral i => i -> Bit -> a -> a - replace :: Integral i => i -> a -> Vec n a -> Vec n a - ``` - - This allows for easier chaining, e.g.: - - ``` - replaceBit 0 1 $ - repleceBit 4 0 $ - replaceBit 6 1 bv - ``` - * Until version 0.7.5, given `x :: Vec 8 Bit` and `y :: BitVector 8`, it used to be `last x == msb y`. - This is quite confusing when printing converted values. - Until version 0.7.5 we would get: - - ``` - > 0x0F :: BitVector 8 - 0000_1111 - > unpack 0x0F :: Vec 8 Bit - <1,1,1,1,0,0,0,0> - ``` - - As of version 0.8, we have `head x == msb y`: - - ``` - > 0x0F :: BitVector 8 - 0000_1111 - > unpack 0x0F :: Vec 8 Bit - <0,0,0,0,1,1,1,1> - ``` - - So converting for `Vec`tors of `Bit`s to `BitVector`s is no longer _index_-preserving, but it is _order_-preserving. - * Add [QuickCheck](http://hackage.haskell.org/package/QuickCheck) `Arbitary` and `CoArbitary` instances for all data types - * Add [lens](http://hackage.haskell.org/package/lens) `Ixed` instances for `BitVector`, `Signed`, `Unsigned`, and `Vec` - -## 0.7.5 **May 7th 2015** -* New features: - * Moore machine combinators - -## 0.7.4 **May 5th 2015* -* New features: - * Add `TopEntity` annotations - -## 0.7.3 *April 22nd 2015* -* New features: - * Add the vector functions: `zip3`, `unzip3`, and `zipWith3` - * Use version 0.2 of the [`ghc-typelits-natnormalise` package](http://hackage.haskell.org/package/ghc-typelits-natnormalise) - -## 0.7.2 *April 20th 2015* -* New features: - * Support for GHC 7.10 => only works with GHC 7.10 and higher - * Use http://hackage.haskell.org/package/ghc-typelits-natnormalise typechecker plugin for better type-level natural number handling - -## 0.7.1 *March 25th 2015* -* Fixes bugs: - * Fix laziness bug in Vector.(!!) and Vector.replace - -## 0.7 *March 13th 2015* -* New features: - * Switch types of `bundle` and `bundle'`, and `unbundle` and `unbundle'`. - * Rename all explicitly clocked versions of Signal functions, to the primed - name of the implicitly clocked Signal functions. E.g. `cregister` is now - called `register'` (where the implicitly clocked function is callled `register`) - * Add new instances for `DSignal` - * Add experimental `antiDelay` function for `DSignal` - * Generalize lifted functions over Signals (e.g. (.==.)) - -* Fixes bugs: - * Faster versions of Vector.(!!) and Vector.replace - -## 0.6.0.1 *November 17th 2014* -* Fixes bugs: - * Add missing 'CLaSH.Sized.BitVector' module to .cabal file. - -## 0.6 *November 17th 2014* - -* New features: - * Add `Fractional` instance for `Fixed` [#9](https://github.com/christiaanb/clash-prelude/issues/9) - * Make indexing/subscript of `Vec` ascending [#4](https://github.com/christiaanb/clash-prelude/issues/4) - * Add separate `BitVector` type, which has a descending index. - * Add bit indexing operators, including the index/subscript operator `(!)`. - * Add bit reduction operators: `reduceOr`, `reduceAnd`, `reduceOr`. - * Rename `BitVector` class to `BitPack` with `pack` and `unpack` class methods. - * Rename `Pack` class to `Bundle` with `bundle` and `unbundle` class methods. - * Strip all `Vec` functions from their `v` prefix, i.e. `vmap` -> `map`. - * Rename `Vec` indexing operator from `(!)` to `(!!)`. - * Combine `Add` and `Mult` class into `ExtendingNum` class. - * Add extend and truncate methods to the `Resize` class. - * Add `SaturatingNum` class with saturating numeric operators. - * Add multitude of lifted `Signal` operators, i.e. `(.==.) :: Eq a => Signal a -> Signal a -> Signal Bool` - * Add `CLaSH.Signal.Delayed` with functions and data types for delay-annotated signals to support safe synchronisation. - * Add `CLASH.Prelude.DataFlow` with functions and data types to create self-synchronising circuits based on data-flow principles. - -* Fixes bugs: - * Remove deprecated 'Arrow' instance for and related functions for `Comp` [#5](https://github.com/christiaanb/clash-prelude/issues/5) - -## 0.5.1 *June 5th 2014* - -* New features: - * Add `Default` instance for `Vec` [#2](https://github.com/christiaanb/clash-prelude/issues/2) - * Instantiation for `blockRam` [#3](https://github.com/christiaanb/clash-prelude/issues/2) - -* Fixes bugs: - * Fixed error on documentation of fLit in Fixed.hs [#6](https://github.com/christiaanb/clash-prelude/issues/6) - * Non-translatable `Enum` function interfere with `sassert` compilation [#7](https://github.com/christiaanb/clash-prelude/issues/7) - * Substituted the word 'list' into 'vector' in some places in the documentation. [#8](https://github.com/christiaanb/clash-prelude/issues/8) - * mark vselectI INLINEABLE [#10](https://github.com/christiaanb/clash-prelude/issues/10) - -## 0.5 *April 3rd 2014* - * Add explicitly clocked synchronous signals for multi-clock circuits - -## 0.4.1 *March 27th 2014* - * Add saturation to fixed-point operators - * Finalize most documentation - -## 0.4 *March 20th 2014* - * Add fixed-point integers - * Extend documentation - * 'bit' and 'testBit' functions give run-time errors on out-of-bound positions - -## 0.3 *March 14th 2014* - * Add Documentation - * Easy SNat literals for 0..1024, e.g. d4 = snat :: SNat 4 - * Fix blockRamPow2 - -## 0.2 *March 5th 2014* - * Initial release diff --git a/benchmarks/BenchBitVector.hs b/benchmarks/BenchBitVector.hs --- a/benchmarks/BenchBitVector.hs +++ b/benchmarks/BenchBitVector.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE NoStarIsType #-} +#endif {-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-} @@ -6,12 +9,53 @@ module BenchBitVector where -import Clash.Sized.Internal.BitVector +import Data.Bits +import Clash.Sized.BitVector import Clash.Class.Num +import Clash.Prelude.BitIndex import GHC.TypeLits (type (*)) -import Criterion (Benchmark, env, bench, nf) +import Criterion (Benchmark, env, bench, nf, bgroup) import Language.Haskell.TH.Syntax (lift) +import BenchCommon + +bitVectorBench :: Benchmark +bitVectorBench = bgroup "BitVector" + [ fromIntegerBench + , addBench + , addBenchL + , negateBench + , negateBenchL + , subBench + , subBenchL + , multBench + , multBenchL + , plusBench + , minusBench + , timesBench + , boundedAddBench + , boundedSubBench + , boundedMulBench + , msbBench + , msbBenchL + , appendBench + , appendBenchL + , splitBench + , splitBenchL + , xorBench + , xorBenchL + , andBench + , andBenchL + , orBench + , orBenchL + , complementBench + , complementBenchL + ] + +smallValueI :: Integer +smallValueI = $(lift (2^(16::Int)-10 :: Integer)) +{-# INLINE smallValueI #-} + smallValue1 :: BitVector WORD_SIZE_IN_BITS smallValue1 = $(lift (2^(16::Int)-10 :: BitVector WORD_SIZE_IN_BITS)) {-# INLINE smallValue1 #-} @@ -21,105 +65,184 @@ {-# INLINE smallValue2 #-} largeValue1 :: BitVector (3*WORD_SIZE_IN_BITS) -largeValue1 = 2^(2*WORD_SIZE_IN_BITS :: Int)-10 :: BitVector (3*WORD_SIZE_IN_BITS) +largeValue1 = $(lift (2^(2*WORD_SIZE_IN_BITS :: Int)-10 :: BitVector (3*WORD_SIZE_IN_BITS))) {-# INLINE largeValue1 #-} largeValue2 :: BitVector (3*WORD_SIZE_IN_BITS) -largeValue2 = 2^(2*WORD_SIZE_IN_BITS :: Int)-100 :: BitVector (3*WORD_SIZE_IN_BITS) +largeValue2 = $(lift (2^(2*WORD_SIZE_IN_BITS :: Int)-100 :: BitVector (3*WORD_SIZE_IN_BITS))) {-# INLINE largeValue2 #-} +fromIntegerBench :: Benchmark +fromIntegerBench = env setup $ \m -> + bench "fromInteger WORD_SIZE_IN_BITS" $ + nf (fromInteger :: Integer -> BitVector WORD_SIZE_IN_BITS) m + where + setup = return smallValueI + addBench :: Benchmark addBench = env setup $ \m -> - bench "+# WORD_SIZE_IN_BITS" $ nf (uncurry (+#)) m + bench "+ WORD_SIZE_IN_BITS" $ nf (apSwapAp (+)) m where setup = return (smallValue1,smallValue2) +addBenchL :: Benchmark +addBenchL = env setup $ \m -> + bench "+ 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (+)) m + where + setup = return (largeValue1,largeValue2) + negateBench :: Benchmark negateBench = env setup $ \m -> - bench "negate# WORD_SIZE_IN_BITS" $ nf negate# m + bench "negate WORD_SIZE_IN_BITS" $ nf negate m where setup = return smallValue1 +negateBenchL :: Benchmark +negateBenchL = env setup $ \m -> + bench "negate 3*WORD_SIZE_IN_BITS" $ nf negate m + where + setup = return largeValue1 + subBench :: Benchmark subBench = env setup $ \m -> - bench "-# WORD_SIZE_IN_BITS" $ nf (uncurry (-#)) m + bench "- WORD_SIZE_IN_BITS" $ nf (apSwapAp (-)) m where setup = return (smallValue1,smallValue2) +subBenchL :: Benchmark +subBenchL = env setup $ \m -> + bench "- 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (-)) m + where + setup = return (largeValue1,largeValue2) + multBench :: Benchmark multBench = env setup $ \m -> - bench "*# WORD_SIZE_IN_BITS" $ nf (uncurry (*#)) m + bench "* WORD_SIZE_IN_BITS" $ nf (apSwapAp (*)) m where setup = return (smallValue1,smallValue2) +multBenchL :: Benchmark +multBenchL = env setup $ \m -> + bench "* 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (*)) m + where + setup = return (largeValue1,largeValue2) + plusBench :: Benchmark plusBench = env setup $ \m -> - bench "plus# WORD_SIZE_IN_BITS" $ nf (uncurry (plus#)) m + bench "plus WORD_SIZE_IN_BITS" $ nf (apSwapAp2 add add) m where setup = return (smallValue1,smallValue2) minusBench :: Benchmark minusBench = env setup $ \m -> - bench "minus# WORD_SIZE_IN_BITS" $ nf (uncurry (minus#)) m + bench "minus WORD_SIZE_IN_BITS" $ nf (apSwapAp2 sub sub) m where setup = return (smallValue1,smallValue2) timesBench :: Benchmark timesBench = env setup $ \m -> - bench "times# WORD_SIZE_IN_BITS" $ nf (uncurry (times#)) m + bench "times WORD_SIZE_IN_BITS" $ nf (apSwapAp2 mul mul) m where setup = return (smallValue1,smallValue2) boundedAddBench :: Benchmark boundedAddBench = env setup $ \m -> - bench "boundedAdd WORD_SIZE_IN_BITS" $ nf (uncurry (boundedAdd)) m + bench "boundedAdd WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedAdd) m where setup = return (smallValue1,smallValue2) boundedSubBench :: Benchmark boundedSubBench = env setup $ \m -> - bench "boundedSub WORD_SIZE_IN_BITS" $ nf (uncurry (boundedSub)) m + bench "boundedSub WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedSub) m where setup = return (smallValue1,smallValue2) boundedMulBench :: Benchmark boundedMulBench = env setup $ \m -> - bench "boundedMul WORD_SIZE_IN_BITS" $ nf (uncurry (boundedMul)) m + bench "boundedMul WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedMul) m where setup = return (smallValue1,smallValue2) msbBench :: Benchmark msbBench = env setup $ \m -> - bench "msb# WORD_SIZE_IN_BITS" $ nf msb# m + bench "msb# WORD_SIZE_IN_BITS" $ nf msb m where setup = return smallValue1 msbBenchL :: Benchmark msbBenchL = env setup $ \m -> - bench "msb# (3*WORD_SIZE_IN_BITS)" $ nf msb# m + bench "msb# (3*WORD_SIZE_IN_BITS)" $ nf msb m where setup = return largeValue1 appendBench :: Benchmark appendBench = env setup $ \m -> - bench "++# WORD_SIZE_IN_BITS" $ nf (uncurry (++#)) m + bench "++# WORD_SIZE_IN_BITS" $ nf (apSwapAp2 (++#) (++#)) m where setup = return (smallValue1,smallValue2) appendBenchL :: Benchmark appendBenchL = env setup $ \m -> - bench "++# (3*WORD_SIZE_IN_BITS)" $ nf (uncurry (++#)) m + bench "++# (3*WORD_SIZE_IN_BITS)" $ nf (apSwapAp2 (++#) (++#)) m where setup = return (largeValue1,largeValue2) splitBench :: Benchmark splitBench = env setup $ \m -> - bench "split# WORD_SIZE_IN_BITS" $ nf (split# :: BitVector WORD_SIZE_IN_BITS -> (BitVector 18, BitVector 46)) m + bench "split# WORD_SIZE_IN_BITS" $ nf (split :: BitVector WORD_SIZE_IN_BITS -> (BitVector 18, BitVector 46)) m where setup = return smallValue1 splitBenchL :: Benchmark splitBenchL = env setup $ \m -> - bench "split# (3*WORD_SIZE_IN_BITS)" $ nf (split# :: BitVector (3*WORD_SIZE_IN_BITS) -> (BitVector 18, BitVector 174)) m + bench "split# (3*WORD_SIZE_IN_BITS)" $ nf (split :: BitVector (3*WORD_SIZE_IN_BITS) -> (BitVector 18, BitVector 174)) m + where + setup = return largeValue1 + +xorBench :: Benchmark +xorBench = env setup $ \m -> + bench "xor WORD_SIZE_IN_BITS" $ nf (apSwapAp xor) m + where + setup = return (smallValue1,smallValue2) + +xorBenchL :: Benchmark +xorBenchL = env setup $ \m -> + bench "xor 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp xor) m + where + setup = return (largeValue1,largeValue2) + +andBench :: Benchmark +andBench = env setup $ \m -> + bench ".&. WORD_SIZE_IN_BITS" $ nf (apSwapAp (.&.)) m + where + setup = return (smallValue1,smallValue2) + +andBenchL :: Benchmark +andBenchL = env setup $ \m -> + bench ".&. 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (.&.)) m + where + setup = return (largeValue1,largeValue2) + +orBench :: Benchmark +orBench = env setup $ \m -> + bench ".|. WORD_SIZE_IN_BITS" $ nf (apSwapAp (.|.)) m + where + setup = return (smallValue1,smallValue2) + +orBenchL :: Benchmark +orBenchL = env setup $ \m -> + bench ".|. 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (.|.)) m + where + setup = return (largeValue1,largeValue2) + +complementBench :: Benchmark +complementBench = env setup $ \m -> + bench "complement WORD_SIZE_IN_BITS" $ nf complement m + where + setup = return smallValue1 + +complementBenchL :: Benchmark +complementBenchL = env setup $ \m -> + bench "complement 3*WORD_SIZE_IN_BITS" $ nf complement m where setup = return largeValue1 diff --git a/benchmarks/BenchCommon.hs b/benchmarks/BenchCommon.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchCommon.hs @@ -0,0 +1,9 @@ +module BenchCommon where + +apSwapAp :: (a -> a -> a) -> (a,a) -> a +apSwapAp f (a,b) = f (f a b) (f b a) +{-# INLINE apSwapAp #-} + +apSwapAp2 :: (a -> a -> b) -> (b -> b -> c) -> (a,a) -> c +apSwapAp2 f g (a,b) = g (f a b) (f b a) +{-# INLINE apSwapAp2 #-} diff --git a/benchmarks/BenchFixed.hs b/benchmarks/BenchFixed.hs --- a/benchmarks/BenchFixed.hs +++ b/benchmarks/BenchFixed.hs @@ -4,13 +4,22 @@ #define WORD_SIZE_IN_BITS 64 -module BenchFixed where +module BenchFixed (fixedBench) where import Clash.Class.Num import Clash.Sized.Fixed import Clash.Sized.Unsigned -import Criterion (Benchmark, env, bench, nf) +import Criterion (Benchmark, env, bench, nf, bgroup) import Language.Haskell.TH.Syntax (lift) + +fixedBench :: Benchmark +fixedBench = bgroup "Fixed" + [ fromRationalBench + , addBench + , subBench + , multBench + , multBench_wrap + ] smallValueR_pos :: Rational smallValueR_pos = $(lift (5126.889117 :: Rational)) diff --git a/benchmarks/BenchRAM.hs b/benchmarks/BenchRAM.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchRAM.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE MagicHash, TypeApplications #-} +module BenchRAM (ramBench) where + +import Criterion (Benchmark, env, bench, nf, bgroup) + +import Clash.Explicit.BlockRam +import Clash.Explicit.RAM +import Clash.Explicit.ROM +import Clash.Explicit.Signal +import Clash.Prelude.ROM +import Clash.Promoted.Nat.Literals +import qualified Clash.Sized.Vector as V + +ramBench :: Benchmark +ramBench = bgroup "RAMs" + [ asyncRamBench + , asyncRomBench + , blockRamBench + , blockRamROBench + , romBench + ] + +asyncRamBench :: Benchmark +asyncRamBench = env setup $ \m -> + bench "asyncRam#" $ + nf (take 98 . drop 2 . simulate_lazy + (\rw -> let (r,w) = unbundle rw + in asyncRam# @System + clockGen + clockGen + enableGen + d1024 + r + (pure True) + w + w + )) m + where + setup = pure (zip [556,557..856] [557,558..857]) + +asyncRomBench :: Benchmark +asyncRomBench = env setup $ \m -> + bench "asyncRom#" $ + nf (take 98 . drop 2 . fmap (asyncRom# ramInit)) m + where + ramInit = V.replicate d1024 (1 :: Int) + setup = pure ([557,558..857]) + +blockRamBench :: Benchmark +blockRamBench = env setup $ \m -> + bench "blockRam# (100% writes)" $ + nf (take 98 . drop 2 . simulate_lazy + (\w -> blockRam# @System + clockGen + enableGen + ramInit + w + (pure True) + w + w + )) m + where + ramInit = V.replicate d1024 (1 :: Int) + setup = pure ([557,558..857]) + +blockRamROBench :: Benchmark +blockRamROBench = env setup $ \m -> + bench "blockRam# (0% writes)" $ + nf (take 98 . drop 2 . simulate_lazy + (\w -> blockRam# @System + clockGen + enableGen + ramInit + w + (pure False) + w + w + )) m + where + ramInit = V.replicate d1024 (1 :: Int) + setup = pure ([557,558..857]) + +romBench :: Benchmark +romBench = env setup $ \m -> + bench "rom#" $ + nf (take 98 . drop 2 . simulate_lazy + (\r -> rom# @System + clockGen + enableGen + ramInit + r + )) m + where + ramInit = V.replicate d1024 (1 :: Int) + setup = pure ([557,558..857]) diff --git a/benchmarks/BenchSigned.hs b/benchmarks/BenchSigned.hs --- a/benchmarks/BenchSigned.hs +++ b/benchmarks/BenchSigned.hs @@ -1,94 +1,226 @@ {-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE NoStarIsType #-} +#endif {-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-} #define WORD_SIZE_IN_BITS 64 -module BenchSigned where +module BenchSigned (signedBench) where +import Data.Bits +import Clash.Class.Num +import Clash.Class.BitPack import Clash.Sized.BitVector -import Clash.Sized.Internal.Signed -import Criterion (Benchmark, env, bench, nf) +import Clash.Sized.Signed +import Criterion (Benchmark, env, bench, nf, bgroup) import Language.Haskell.TH.Syntax (lift) +import GHC.TypeLits (type (*)) -smallValueI_pos :: Integer -smallValueI_pos = $(lift (2^(16::Int)-10 :: Integer)) -{-# INLINE smallValueI_pos #-} +import BenchCommon -smallValue_pos1 :: Signed WORD_SIZE_IN_BITS -smallValue_pos1 = $(lift (2^(16::Int)-100 :: Signed WORD_SIZE_IN_BITS)) -{-# INLINE smallValue_pos1 #-} +signedBench :: Benchmark +signedBench = bgroup "Signed" + [ fromIntegerBench + , addBench + , addBenchL + , negateBench + , negateBenchL + , subBench + , subBenchL + , multBench + , multBenchL + , plusBench + , minusBench + , timesBench + , boundedAddBench + , boundedSubBench + , boundedMulBench + , packBench + , unpackBench + , xorBench + , xorBenchL + , andBench + , andBenchL + , orBench + , orBenchL + , complementBench + , complementBenchL + ] -smallValue_pos2 :: Signed WORD_SIZE_IN_BITS -smallValue_pos2 = $(lift (2^(16::Int)-100 :: Signed WORD_SIZE_IN_BITS)) -{-# INLINE smallValue_pos2 #-} +smallValueI :: Integer +smallValueI = $(lift (2^(16::Int)-10 :: Integer)) +{-# INLINE smallValueI #-} +smallValue1 :: Signed WORD_SIZE_IN_BITS +smallValue1 = $(lift (2^(16::Int)-10 :: Signed WORD_SIZE_IN_BITS)) +{-# INLINE smallValue1 #-} + +smallValue2 :: Signed WORD_SIZE_IN_BITS +smallValue2 = $(lift (2^(16::Int)-100 :: Signed WORD_SIZE_IN_BITS)) +{-# INLINE smallValue2 #-} + smallValueBV :: BitVector WORD_SIZE_IN_BITS smallValueBV = $(lift (2^(16::Int)-10 :: BitVector WORD_SIZE_IN_BITS)) {-# INLINE smallValueBV #-} +largeValue1 :: Signed (3*WORD_SIZE_IN_BITS) +largeValue1 = $(lift (2^(2*WORD_SIZE_IN_BITS :: Int)-10 :: Signed (3*WORD_SIZE_IN_BITS))) +{-# INLINE largeValue1 #-} + +largeValue2 :: Signed (3*WORD_SIZE_IN_BITS) +largeValue2 = $(lift (2^(2*WORD_SIZE_IN_BITS :: Int)-100 :: Signed (3*WORD_SIZE_IN_BITS))) +{-# INLINE largeValue2 #-} + +fromIntegerBench :: Benchmark +fromIntegerBench = env setup $ \m -> + bench "fromInteger WORD_SIZE_IN_BITS" $ + nf (fromInteger :: Integer -> Signed WORD_SIZE_IN_BITS) m + where + setup = return smallValueI + addBench :: Benchmark addBench = env setup $ \m -> - bench "+# WORD_SIZE_IN_BITS" $ nf (uncurry (+#)) m + bench "+ WORD_SIZE_IN_BITS" $ nf (apSwapAp (+)) m where - setup = return (smallValue_pos1,smallValue_pos2) + setup = return (smallValue1,smallValue2) +addBenchL :: Benchmark +addBenchL = env setup $ \m -> + bench "+ 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (+)) m + where + setup = return (largeValue1,largeValue2) + negateBench :: Benchmark negateBench = env setup $ \m -> - bench "negate# WORD_SIZE_IN_BITS" $ nf negate# m + bench "negate WORD_SIZE_IN_BITS" $ nf negate m where - setup = return smallValue_pos1 + setup = return smallValue1 -absBench :: Benchmark -absBench = env setup $ \m -> - bench "abs# WORD_SIZE_IN_BITS" $ nf abs# m +negateBenchL :: Benchmark +negateBenchL = env setup $ \m -> + bench "negate 3*WORD_SIZE_IN_BITS" $ nf negate m where - setup = return smallValue_pos1 + setup = return largeValue1 subBench :: Benchmark subBench = env setup $ \m -> - bench "-# WORD_SIZE_IN_BITS" $ nf (uncurry (-#)) m + bench "- WORD_SIZE_IN_BITS" $ nf (apSwapAp (-)) m where - setup = return (smallValue_pos1,smallValue_pos2) + setup = return (smallValue1,smallValue2) +subBenchL :: Benchmark +subBenchL = env setup $ \m -> + bench "- 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (-)) m + where + setup = return (largeValue1,largeValue2) + multBench :: Benchmark multBench = env setup $ \m -> - bench "*# WORD_SIZE_IN_BITS" $ nf (uncurry (*#)) m + bench "* WORD_SIZE_IN_BITS" $ nf (apSwapAp (*)) m where - setup = return (smallValue_pos1,smallValue_pos2) + setup = return (smallValue1,smallValue2) +multBenchL :: Benchmark +multBenchL = env setup $ \m -> + bench "* 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (*)) m + where + setup = return (largeValue1,largeValue2) + plusBench :: Benchmark plusBench = env setup $ \m -> - bench "plus# WORD_SIZE_IN_BITS" $ nf (uncurry (plus#)) m + bench "plus WORD_SIZE_IN_BITS" $ nf (apSwapAp2 add add) m where - setup = return (smallValue_pos1,smallValue_pos2) + setup = return (smallValue1,smallValue2) minusBench :: Benchmark minusBench = env setup $ \m -> - bench "minus# WORD_SIZE_IN_BITS" $ nf (uncurry (minus#)) m + bench "minus WORD_SIZE_IN_BITS" $ nf (apSwapAp2 sub sub) m where - setup = return (smallValue_pos1,smallValue_pos2) + setup = return (smallValue1,smallValue2) timesBench :: Benchmark timesBench = env setup $ \m -> - bench "times# WORD_SIZE_IN_BITS" $ nf (uncurry (times#)) m + bench "times WORD_SIZE_IN_BITS" $ nf (apSwapAp2 mul mul) m where - setup = return (smallValue_pos1,smallValue_pos2) + setup = return (smallValue1,smallValue2) -fromIntegerBench :: Benchmark -fromIntegerBench = env setup $ \m -> - bench "fromInteger# WORD_SIZE_IN_BITS" $ nf (fromInteger# :: Integer -> Signed WORD_SIZE_IN_BITS) m +boundedAddBench :: Benchmark +boundedAddBench = env setup $ \m -> + bench "boundedAdd WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedAdd) m where - setup = return smallValueI_pos + setup = return (smallValue1,smallValue2) +boundedSubBench :: Benchmark +boundedSubBench = env setup $ \m -> + bench "boundedSub WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedSub) m + where + setup = return (smallValue1,smallValue2) + +boundedMulBench :: Benchmark +boundedMulBench = env setup $ \m -> + bench "boundedMul WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedMul) m + where + setup = return (smallValue1,smallValue2) + packBench :: Benchmark packBench = env setup $ \m -> - bench "pack# WORD_SIZE_IN_BITS" $ nf pack# m + bench "pack WORD_SIZE_IN_BITS" $ nf pack m where - setup = return smallValue_pos1 + setup = return smallValue1 unpackBench :: Benchmark unpackBench = env setup $ \m -> - bench "unpack# WORD_SIZE_IN_BITS" $ nf unpack# m + bench "unpack WORD_SIZE_IN_BITS" $ + nf (unpack :: BitVector WORD_SIZE_IN_BITS -> Signed WORD_SIZE_IN_BITS) m where setup = return smallValueBV + +xorBench :: Benchmark +xorBench = env setup $ \m -> + bench "xor WORD_SIZE_IN_BITS" $ nf (apSwapAp xor) m + where + setup = return (smallValue1,smallValue2) + +xorBenchL :: Benchmark +xorBenchL = env setup $ \m -> + bench "xor 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp xor) m + where + setup = return (largeValue1,largeValue2) + +andBench :: Benchmark +andBench = env setup $ \m -> + bench ".&. WORD_SIZE_IN_BITS" $ nf (apSwapAp (.&.)) m + where + setup = return (smallValue1,smallValue2) + +andBenchL :: Benchmark +andBenchL = env setup $ \m -> + bench ".&. 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (.&.)) m + where + setup = return (largeValue1,largeValue2) + +orBench :: Benchmark +orBench = env setup $ \m -> + bench ".|. WORD_SIZE_IN_BITS" $ nf (apSwapAp (.|.)) m + where + setup = return (smallValue1,smallValue2) + +orBenchL :: Benchmark +orBenchL = env setup $ \m -> + bench ".|. 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (.|.)) m + where + setup = return (largeValue1,largeValue2) + +complementBench :: Benchmark +complementBench = env setup $ \m -> + bench "complement WORD_SIZE_IN_BITS" $ nf complement m + where + setup = return smallValue1 + +complementBenchL :: Benchmark +complementBenchL = env setup $ \m -> + bench "complement 3*WORD_SIZE_IN_BITS" $ nf complement m + where + setup = return largeValue1 diff --git a/benchmarks/BenchUnsigned.hs b/benchmarks/BenchUnsigned.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchUnsigned.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE NoStarIsType #-} +#endif + +{-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-} + +#define WORD_SIZE_IN_BITS 64 + +module BenchUnsigned (unsignedBench) where + +import Data.Bits +import Clash.Class.Num +import Clash.Class.BitPack +import Clash.Sized.BitVector +import Clash.Sized.Unsigned +import Criterion (Benchmark, env, bench, nf, bgroup) +import Language.Haskell.TH.Syntax (lift) +import GHC.TypeLits (type (*)) + +import BenchCommon + +unsignedBench :: Benchmark +unsignedBench = bgroup "Unsigned" + [ fromIntegerBench + , addBench + , addBenchL + , negateBench + , negateBenchL + , subBench + , subBenchL + , multBench + , multBenchL + , plusBench + , minusBench + , timesBench + , boundedAddBench + , boundedSubBench + , boundedMulBench + , packBench + , unpackBench + , xorBench + , xorBenchL + , andBench + , andBenchL + , orBench + , orBenchL + , complementBench + , complementBenchL + ] + +smallValueI :: Integer +smallValueI = $(lift (2^(16::Int)-10 :: Integer)) +{-# INLINE smallValueI #-} + +smallValue1 :: Unsigned WORD_SIZE_IN_BITS +smallValue1 = $(lift (2^(16::Int)-10 :: Unsigned WORD_SIZE_IN_BITS)) +{-# INLINE smallValue1 #-} + +smallValue2 :: Unsigned WORD_SIZE_IN_BITS +smallValue2 = $(lift (2^(16::Int)-100 :: Unsigned WORD_SIZE_IN_BITS)) +{-# INLINE smallValue2 #-} + +smallValueBV :: BitVector WORD_SIZE_IN_BITS +smallValueBV = $(lift (2^(16::Int)-10 :: BitVector WORD_SIZE_IN_BITS)) +{-# INLINE smallValueBV #-} + +largeValue1 :: Unsigned (3*WORD_SIZE_IN_BITS) +largeValue1 = $(lift (2^(2*WORD_SIZE_IN_BITS :: Int)-10 :: Unsigned (3*WORD_SIZE_IN_BITS))) +{-# INLINE largeValue1 #-} + +largeValue2 :: Unsigned (3*WORD_SIZE_IN_BITS) +largeValue2 = $(lift (2^(2*WORD_SIZE_IN_BITS :: Int)-100 :: Unsigned (3*WORD_SIZE_IN_BITS))) +{-# INLINE largeValue2 #-} + +fromIntegerBench :: Benchmark +fromIntegerBench = env setup $ \m -> + bench "fromInteger WORD_SIZE_IN_BITS" $ + nf (fromInteger :: Integer -> Unsigned WORD_SIZE_IN_BITS) m + where + setup = return smallValueI + +addBench :: Benchmark +addBench = env setup $ \m -> + bench "+ WORD_SIZE_IN_BITS" $ nf (apSwapAp (+)) m + where + setup = return (smallValue1,smallValue2) + +addBenchL :: Benchmark +addBenchL = env setup $ \m -> + bench "+ 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (+)) m + where + setup = return (largeValue1,largeValue2) + +negateBench :: Benchmark +negateBench = env setup $ \m -> + bench "negate WORD_SIZE_IN_BITS" $ nf negate m + where + setup = return smallValue1 + +negateBenchL :: Benchmark +negateBenchL = env setup $ \m -> + bench "negate 3*WORD_SIZE_IN_BITS" $ nf negate m + where + setup = return largeValue1 + +subBench :: Benchmark +subBench = env setup $ \m -> + bench "- WORD_SIZE_IN_BITS" $ nf (apSwapAp (-)) m + where + setup = return (smallValue1,smallValue2) + +subBenchL :: Benchmark +subBenchL = env setup $ \m -> + bench "- 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (-)) m + where + setup = return (largeValue1,largeValue2) + +multBench :: Benchmark +multBench = env setup $ \m -> + bench "* WORD_SIZE_IN_BITS" $ nf (apSwapAp (*)) m + where + setup = return (smallValue1,smallValue2) + +multBenchL :: Benchmark +multBenchL = env setup $ \m -> + bench "* 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (*)) m + where + setup = return (largeValue1,largeValue2) + +plusBench :: Benchmark +plusBench = env setup $ \m -> + bench "plus WORD_SIZE_IN_BITS" $ nf (apSwapAp2 add add) m + where + setup = return (smallValue1,smallValue2) + +minusBench :: Benchmark +minusBench = env setup $ \m -> + bench "minus WORD_SIZE_IN_BITS" $ nf (apSwapAp2 sub sub) m + where + setup = return (smallValue1,smallValue2) + +timesBench :: Benchmark +timesBench = env setup $ \m -> + bench "times WORD_SIZE_IN_BITS" $ nf (apSwapAp2 mul mul) m + where + setup = return (smallValue1,smallValue2) + +boundedAddBench :: Benchmark +boundedAddBench = env setup $ \m -> + bench "boundedAdd WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedAdd) m + where + setup = return (smallValue1,smallValue2) + +boundedSubBench :: Benchmark +boundedSubBench = env setup $ \m -> + bench "boundedSub WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedSub) m + where + setup = return (smallValue1,smallValue2) + +boundedMulBench :: Benchmark +boundedMulBench = env setup $ \m -> + bench "boundedMul WORD_SIZE_IN_BITS" $ nf (apSwapAp boundedMul) m + where + setup = return (smallValue1,smallValue2) + +packBench :: Benchmark +packBench = env setup $ \m -> + bench "pack WORD_SIZE_IN_BITS" $ nf pack m + where + setup = return smallValue1 + +unpackBench :: Benchmark +unpackBench = env setup $ \m -> + bench "unpack WORD_SIZE_IN_BITS" $ + nf (unpack :: BitVector WORD_SIZE_IN_BITS -> Unsigned WORD_SIZE_IN_BITS) m + where + setup = return smallValueBV + +xorBench :: Benchmark +xorBench = env setup $ \m -> + bench "xor WORD_SIZE_IN_BITS" $ nf (apSwapAp xor) m + where + setup = return (smallValue1,smallValue2) + +xorBenchL :: Benchmark +xorBenchL = env setup $ \m -> + bench "xor 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp xor) m + where + setup = return (largeValue1,largeValue2) + +andBench :: Benchmark +andBench = env setup $ \m -> + bench ".&. WORD_SIZE_IN_BITS" $ nf (apSwapAp (.&.)) m + where + setup = return (smallValue1,smallValue2) + +andBenchL :: Benchmark +andBenchL = env setup $ \m -> + bench ".&. 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (.&.)) m + where + setup = return (largeValue1,largeValue2) + +orBench :: Benchmark +orBench = env setup $ \m -> + bench ".|. WORD_SIZE_IN_BITS" $ nf (apSwapAp (.|.)) m + where + setup = return (smallValue1,smallValue2) + +orBenchL :: Benchmark +orBenchL = env setup $ \m -> + bench ".|. 3*WORD_SIZE_IN_BITS" $ nf (apSwapAp (.|.)) m + where + setup = return (largeValue1,largeValue2) + +complementBench :: Benchmark +complementBench = env setup $ \m -> + bench "complement WORD_SIZE_IN_BITS" $ nf complement m + where + setup = return smallValue1 + +complementBenchL :: Benchmark +complementBenchL = env setup $ \m -> + bench "complement 3*WORD_SIZE_IN_BITS" $ nf complement m + where + setup = return largeValue1 diff --git a/benchmarks/benchmark-main.hs b/benchmarks/benchmark-main.hs --- a/benchmarks/benchmark-main.hs +++ b/benchmarks/benchmark-main.hs @@ -2,50 +2,18 @@ import Criterion.Main -import qualified BenchBitVector as BV -import qualified BenchFixed as F -import qualified BenchSigned as S +import BenchRAM +import BenchBitVector +import BenchFixed +import BenchSigned +import BenchUnsigned main :: IO () main = defaultMain - [ - bgroup "BitVector" - [ BV.addBench - , BV.negateBench - , BV.subBench - , BV.multBench - , BV.plusBench - , BV.minusBench - , BV.timesBench - , BV.boundedAddBench - , BV.boundedSubBench - , BV.boundedMulBench - , BV.msbBench - , BV.msbBenchL - , BV.appendBench - , BV.appendBenchL - , BV.splitBench - , BV.splitBenchL - ] - , bgroup "Signed" - [ S.fromIntegerBench - , S.addBench - , S.negateBench - , S.absBench - , S.subBench - , S.multBench - , S.plusBench - , S.minusBench - , S.timesBench - , S.packBench - , S.unpackBench - ] - , bgroup "Fixed" - [ F.fromRationalBench - , F.addBench - , F.subBench - , F.multBench - , F.multBench_wrap - ] + [ ramBench + , bitVectorBench + , fixedBench + , signedBench + , unsignedBench ] diff --git a/clash-prelude.cabal b/clash-prelude.cabal --- a/clash-prelude.cabal +++ b/clash-prelude.cabal @@ -1,5 +1,6 @@ +Cabal-version: 2.2 Name: clash-prelude -Version: 1.0.1 +Version: 1.2.0 Synopsis: CAES Language for Synchronous Hardware - Prelude library Description: Clash is a functional hardware description language that borrows both its @@ -41,9 +42,9 @@ A preliminary version of a tutorial can be found in "Clash.Tutorial", for a general overview of the library you should however check out "Clash.Prelude". Some circuit examples can be found in "Clash.Examples". -Homepage: http://www.clash-lang.org/ -bug-reports: http://github.com/clash-lang/clash-compiler/issues -License: BSD2 +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. @@ -59,13 +60,25 @@ extra-doc-files: doc/*.svg -Cabal-version: >=1.18 -Tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1 - source-repository head type: git - location: https://github.com/clash-lang/clash-prelude.git + location: https://github.com/clash-lang/clash-compiler.git + subdir: clash-prelude +flag large-tuples + description: + Generate instances for classes such as `NFDataX` and `BitPack` for tuples + up to and including 62 elements - the GHC imposed maximum. This greatly + increases compile times for `clash-prelude` and therefore mostly impacts the + Clash developers themselves. Hence its default is set to disabled on + development versions and enabled on releases. + -- I have no idea to pass cabal flags to nix, so the comment below, + -- "-- large-tuples", is there to enable a call to 'sed' that replaces + -- True with False. This is done to prevent OOM on CircleCI. + -- large-tuples + default: True + manual: True + flag super-strict description: Use `deepseqX` (instead of `seqX`) in register-like constructs. This can @@ -75,6 +88,13 @@ default: False manual: True +flag strict-mapSignal + description: + Use `seqX` in 'mapSignal#'. This can help to eliminate space leaks in long + running simulations. + default: False + manual: True + flag multiple-hidden description: Allow multiple hidden clocks, resets, and enables to be used. This is an @@ -102,22 +122,56 @@ 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 + MagicHash + 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 -fexpose-all-unfoldings -fno-worker-wrapper CPP-Options: -DCABAL + if flag(large-tuples) + CPP-Options: -DLARGE_TUPLES + if flag(super-strict) CPP-Options: -DCLASH_SUPER_STRICT + if flag(strict-mapSignal) + CPP-Options: -DCLASH_STRICT_MAPSIGNAL + if flag(multiple-hidden) CPP-Options: -DCLASH_MULTIPLE_HIDDEN if flag(multiple-hidden) Exposed-modules: Clash.Prelude.Synchronizer + Autogen-Modules: Paths_clash_prelude + Exposed-modules: Clash.Annotations.TopEntity Clash.Annotations.Primitive Clash.Annotations.BitRepresentation @@ -125,7 +179,9 @@ Clash.Annotations.BitRepresentation.Internal Clash.Annotations.BitRepresentation.Util Clash.Annotations.SynthesisAttributes + Clash.Annotations.TH + Clash.Class.AutoReg Clash.Class.BitPack Clash.Class.Exp Clash.Class.HasDomain @@ -134,6 +190,7 @@ Clash.Class.HasDomain.CodeGen Clash.Class.HasDomain.Common Clash.Class.Num + Clash.Class.Parity Clash.Class.Resize Clash.Clocks @@ -149,6 +206,7 @@ Clash.Explicit.ROM.File Clash.Explicit.Prelude Clash.Explicit.Prelude.Safe + Clash.Explicit.SimIO Clash.Explicit.Signal Clash.Explicit.Signal.Delayed Clash.Explicit.Synchronizer @@ -209,6 +267,7 @@ Clash.Sized.Internal.Unsigned Clash.XException + Clash.XException.TH Clash.Xilinx.ClockGen Clash.Xilinx.DDR @@ -216,39 +275,27 @@ Clash.Tutorial Clash.Examples - other-modules: Clash.Class.BitPack.Internal + other-modules: + Clash.Class.AutoReg.Instances + Clash.Class.AutoReg.Internal + Clash.Class.BitPack.Internal Clash.CPP Clash.Signal.Bundle.Internal Language.Haskell.TH.Compat Paths_clash_prelude other-extensions: CPP - BangPatterns ConstraintKinds - DataKinds - DefaultSignatures - DeriveDataTypeable - DeriveTraversable - DeriveLift FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - MagicHash MultiParamTypeClasses PatternSynonyms - Rank2Types - ScopedTypeVariables - StandaloneDeriving + RankNTypes TemplateHaskell - TupleSections - TypeApplications TypeFamilies - TypeOperators UndecidableInstances - ViewPatterns Build-depends: array >= 0.5.1.0 && < 0.6, base >= 4.10 && < 5, @@ -262,19 +309,22 @@ integer-gmp >= 0.5.1.0 && < 1.1, deepseq >= 1.4.1.0 && < 1.5, ghc-prim >= 0.5.1.0 && < 0.6, - ghc-typelits-extra >= 0.3.1 && < 0.4, - ghc-typelits-knownnat >= 0.6 && < 0.8, - ghc-typelits-natnormalise >= 0.6 && < 0.8, + ghc-typelits-extra >= 0.3.3 && < 0.4, + ghc-typelits-knownnat >= 0.7.2 && < 0.8, + ghc-typelits-natnormalise >= 0.7.1 && < 0.8, hashable >= 1.2.1.0 && < 1.4, half >= 0.2.2.3 && < 1.0, - lens >= 4.9 && < 4.19, + lens >= 4.10 && < 4.20, + recursion-schemes >= 5.1 && < 5.2, QuickCheck >= 2.7 && < 2.14, reflection >= 2 && < 2.2, singletons >= 1.0 && < 3.0, template-haskell >= 2.12.0.0 && < 2.16, + th-abstraction >= 0.2.10 && < 0.4.0, th-lift >= 0.7.0 && < 0.9, th-orphans >= 0.13.1 && < 1.0, text >= 0.11.3.1 && < 1.3, + text-show >= 3.8 && < 3.9, time >= 1.8 && < 1.10, transformers >= 0.5.2.0 && < 0.6, type-errors >= 0.2.0.0 && < 0.3, @@ -299,8 +349,8 @@ doctest >= 0.16.1 test-suite unittests + import: common-options type: exitcode-stdio-1.0 - default-language: Haskell2010 main-is: unittests.hs ghc-options: -Wall hs-source-dirs: tests @@ -315,15 +365,24 @@ base, hint >= 0.7 && < 0.10, + quickcheck-classes-base >= 0.6 && < 1.0, tasty >= 1.2 && < 1.3, - tasty-hunit + tasty-hunit, + tasty-quickcheck, + template-haskell - Other-Modules: Clash.Tests.BitPack + Other-Modules: + Clash.Tests.AutoReg + Clash.Tests.BitPack Clash.Tests.BitVector Clash.Tests.DerivingDataRepr Clash.Tests.DerivingDataReprTypes Clash.Tests.Signal + Clash.Tests.Signed + Clash.Tests.SizedNum Clash.Tests.NFDataX + Clash.Tests.TopEntityGeneration + Clash.Tests.Unsigned benchmark benchmark-clash-prelude @@ -344,5 +403,8 @@ template-haskell Other-Modules: BenchBitVector + BenchCommon BenchFixed + BenchRAM BenchSigned + BenchUnsigned diff --git a/src/Clash/Annotations/BitRepresentation.hs b/src/Clash/Annotations/BitRepresentation.hs --- a/src/Clash/Annotations/BitRepresentation.hs +++ b/src/Clash/Annotations/BitRepresentation.hs @@ -8,12 +8,9 @@ -} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -43,6 +40,7 @@ type Value = Integer type Size = Int +-- | BitMask used to mask fields type FieldAnn = BitMask -- | Lift values inside of 'TH.Q' to a Template Haskell expression @@ -105,6 +103,9 @@ -- underlying @Color@ field of @Just@ by passing /[0b11]/ to ConstrRepr. This -- indicates that the first field is encoded in the first and second bit of the -- whole datatype (0b11). +-- +-- __NB__: BitPack for a custom encoding can be derived using +-- 'Clash.Annotations.BitRepresentation.Deriving.deriveBitPack'. data DataReprAnn = DataReprAnn -- Type this annotation is for: diff --git a/src/Clash/Annotations/BitRepresentation/Deriving.hs b/src/Clash/Annotations/BitRepresentation/Deriving.hs --- a/src/Clash/Annotations/BitRepresentation/Deriving.hs +++ b/src/Clash/Annotations/BitRepresentation/Deriving.hs @@ -13,20 +13,13 @@ e.g. one-hot, for a data type. -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE TemplateHaskell #-} -- See: https://ghc.haskell.org/trac/ghc/ticket/14959. TODO: Consider putting -- the offending function (bitsToInteger') in a separate module. {-# OPTIONS_GHC -O0 #-} @@ -201,7 +194,7 @@ bitSizeInstances <- reifyInstances ''BitSize [typ] case bitSizeInstances of [] -> - error $ unwords [ + fail $ unwords [ "Could not find custom bit representation nor BitSize instance" , "for", show typ ++ "." ] #if MIN_VERSION_template_haskell(2,15,0) @@ -213,7 +206,7 @@ [_impl] -> [| fromIntegral $ natVal (Proxy :: Proxy (BitSize $(return typ))) |] unexp -> - error $ "Unexpected result from reifyInstances: " ++ show unexp + fail $ "Unexpected result from reifyInstances: " ++ show unexp -- | Generate bitmask from a given bit, with a certain size bitmask @@ -394,7 +387,7 @@ ($dataSize + constrSize) $(listE constrReprs) |] _ -> - error $ "Could not derive dataRepr for: " ++ show info + fail $ "Could not derive dataRepr for: " ++ show info where (ConT tyConstrName, typeArgs) = collectTypeArgs typ @@ -572,16 +565,17 @@ packedMaybeDerivator (DataReprAnn _ size _) typ = case maybeCon of ConT nm -> - if nm == ''Maybe then + if nm == ''Maybe then do let err = unwords [ "Could not derive packed maybe for:", show typ , ";", "Does its subtype have any space left to store" - , "the constructor in?" ] in - lift =<< (fromMaybe $ error err) <$> (packedMaybe (size - 1) maybeTyp) + , "the constructor in?" ] + packedM <- packedMaybe (size - 1) maybeTyp + (fromMaybe (fail err) . fmap lift) packedM else - error $ unwords [ "You can only pass Maybe types to packedMaybeDerivator," + fail $ unwords [ "You can only pass Maybe types to packedMaybeDerivator," , "not", show nm] unexpected -> - error $ "packedMaybeDerivator: unexpected constructor: " ++ show unexpected + fail $ "packedMaybeDerivator: unexpected constructor: " ++ show unexpected where (maybeCon, head -> maybeTyp) = collectTypeArgs typ @@ -739,7 +733,7 @@ rest = group tail' bitToExpr' :: (Int, Bit) -> Q Exp -- BitVector n -bitToExpr' (0, _) = error $ "Unexpected group length: 0" +bitToExpr' (0, _) = fail $ "Unexpected group length: 0" bitToExpr' (numTyLit' -> n, Util.H) = [| complement (resize (pack low) :: BitVector $n) |] bitToExpr' (numTyLit' -> n, Util.L) = @@ -748,7 +742,7 @@ [| undefined# :: BitVector $n |] bitsToExpr :: [Bit] -> Q Exp -- BitVector n -bitsToExpr [] = error $ "Unexpected empty bit list" +bitsToExpr [] = fail $ "Unexpected empty bit list" bitsToExpr bits = foldl1 (\v1 v2 -> [| $v1 ++# $v2 |]) @@ -763,7 +757,7 @@ -> [(Int, Int)] -> Q Exp select' _vec [] = - error $ "Unexpected empty list of intervals" + fail $ "Unexpected empty list of intervals" select' vec ranges = foldl1 (\v1 v2 -> [| $v1 ++# $v2 |]) $ map (return . select'') ranges where @@ -793,7 +787,7 @@ -- ^ Select bits -> Q Exp select _fields (Lit []) = - error $ "Unexpected empty literal." + fail $ "Unexpected empty literal." select _fields (Lit lits) = do let size = length lits vec <- bitsToExpr lits @@ -894,15 +888,38 @@ -- the generated instance might conflict with existing implementations (for -- example, an instance for /Maybe a/ exists, yielding conflicts for any -- alternative implementations). +-- +-- +-- Usage: +-- +-- @ +-- data Color = R | G | B +-- {-# ANN module (DataReprAnn +-- $(liftQ [t|Color|]) +-- 2 +-- [ ConstrRepr 'R 0b11 0b00 [] +-- , ConstrRepr 'G 0b11 0b01 [] +-- , ConstrRepr 'B 0b11 0b10 [] +-- ]) #-} +-- deriveBitPack [t| Color |] +-- +-- data MaybeColor = JustColor Color +-- | NothingColor deriving (Generic,BitPack) +-- +-- @ +-- +-- __NB__: Because of the way template haskell works the order here matters, +-- if you try to derive MaybeColor before deriveBitPack Color it will complain +-- about missing an instance BitSize Color. deriveBitPack :: Q Type -> Q [Dec] deriveBitPack typQ = do anns <- collectDataReprs typ <- typQ - let ann = case filter (\(DataReprAnn t _ _) -> t == typ) anns of - [a] -> a - [] -> error $ "No custom bit annotation found." - _ -> error $ "Overlapping bit annotations found." + ann <- case filter (\(DataReprAnn t _ _) -> t == typ) anns of + [a] -> return a + [] -> fail "No custom bit annotation found." + _ -> fail "Overlapping bit annotations found." packFunc <- buildPack ann unpackFunc <- buildUnpack ann @@ -923,6 +940,6 @@ ] alreadyIsInstance <- isInstance ''BitPack [typ] if alreadyIsInstance then - error $ show typ ++ " already has a BitPack instance." + fail $ show typ ++ " already has a BitPack instance." else return bpInst diff --git a/src/Clash/Annotations/BitRepresentation/Internal.hs b/src/Clash/Annotations/BitRepresentation/Internal.hs --- a/src/Clash/Annotations/BitRepresentation/Internal.hs +++ b/src/Clash/Annotations/BitRepresentation/Internal.hs @@ -4,18 +4,18 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Annotations.BitRepresentation.Internal ( buildCustomReprs , dataReprAnnToDataRepr' , constrReprToConstrRepr' , getConstrRepr + , uncheckedGetConstrRepr , getDataRepr , thTypeToType' , ConstrRepr'(..) @@ -27,12 +27,17 @@ import Clash.Annotations.BitRepresentation (BitMask, Value, Size, FieldAnn, DataReprAnn(..), ConstrRepr(..)) import Control.DeepSeq (NFData) +import Data.Coerce (coerce) import Data.Hashable (Hashable) import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import qualified Data.Text as Text import Data.Typeable (Typeable) import qualified Language.Haskell.TH.Syntax as TH import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) +import qualified TextShow as TS +import qualified TextShow.Generic as TS -- | Simple version of template haskell type. Used internally to match on. @@ -45,31 +50,40 @@ -- ^ Numeral literal (used in BitVector 10, for example) deriving (Generic, NFData, Eq, Typeable, Hashable, Ord, Show) +-- Replace with +-- +-- deriving TS.TextShow via TS.FromGeneric (Type') +-- +-- after dropping support for GHC 8.4 +instance TS.TextShow Type' where + showt = TS.showt . coerce @_ @(TS.FromGeneric (Type')) + showb = TS.showb . coerce @_ @(TS.FromGeneric (Type')) + -- | Internal version of DataRepr -data DataRepr' = - DataRepr' - -- Qualified name of type (recursive): - Type' - -- Size of data type: - Size - -- Constructors: - [ConstrRepr'] - deriving (Show, Generic, NFData, Eq, Typeable, Hashable, Ord) +data DataRepr' = DataRepr' + { drType :: Type' + -- ^ Simple representation of data type + , drSize :: Size + -- ^ Size of data type + , drConstrs :: [ConstrRepr'] + -- ^ Constructors + } + deriving (Show, Generic, NFData, Eq, Typeable, Hashable, Ord) -- | Internal version of ConstrRepr -data ConstrRepr' = - ConstrRepr' - -- Qualified name of constructor: - Text.Text - -- Syntactical position in the custom representations definition: - Int - -- Mask needed to determine constructor: - BitMask - -- Value after applying mask: - Value - -- Indicates where fields are stored: - [FieldAnn] - deriving (Show, Generic, NFData, Eq, Typeable, Ord, Hashable) +data ConstrRepr' = ConstrRepr' + { crName :: Text.Text + -- ^ Qualified name of constructor + , crPosition :: Int + -- ^ Syntactical position in the custom representations definition + , crMask :: BitMask + -- ^ Mask needed to determine constructor + , crValue :: Value + -- ^ Value after applying mask + , crFieldAnns :: [FieldAnn] + -- ^ Indicates where fields are stored + } + deriving (Show, Generic, NFData, Eq, Typeable, Ord, Hashable) constrReprToConstrRepr' :: Int -> ConstrRepr -> ConstrRepr' constrReprToConstrRepr' n (ConstrRepr name mask value fieldanns) = @@ -107,12 +121,23 @@ getConstrRepr :: Text.Text -> CustomReprs -> Maybe ConstrRepr' getConstrRepr name (_, reprs) = Map.lookup name reprs +-- | Unchecked version of getConstrRepr +uncheckedGetConstrRepr + :: HasCallStack + => Text.Text + -> CustomReprs + -> ConstrRepr' +uncheckedGetConstrRepr name (_, reprs) = + fromMaybe + (error ("Could not find custom representation for" ++ Text.unpack name)) + (Map.lookup name reprs) + -- | Add CustomRepr to existing index -buildCustomRepr :: CustomReprs -> DataRepr' -> CustomReprs -buildCustomRepr (dMap, cMap) d@(DataRepr' name _size constrReprs) = +addCustomRepr :: CustomReprs -> DataRepr' -> CustomReprs +addCustomRepr (dMap, cMap) d@(DataRepr' name _size constrReprs) = let insertConstr c@(ConstrRepr' name' _ _ _ _) cMap' = Map.insert name' c cMap' in (Map.insert name d dMap, foldr insertConstr cMap constrReprs) -- | Create indices based on names of constructors and data types buildCustomReprs :: [DataRepr'] -> CustomReprs -buildCustomReprs = foldl buildCustomRepr (Map.empty, Map.empty) +buildCustomReprs = foldl addCustomRepr (Map.empty, Map.empty) diff --git a/src/Clash/Annotations/Primitive.hs b/src/Clash/Annotations/Primitive.hs --- a/src/Clash/Annotations/Primitive.hs +++ b/src/Clash/Annotations/Primitive.hs @@ -8,12 +8,8 @@ templates. -} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Safe #-} @@ -154,7 +150,7 @@ = SystemVerilog | Verilog | VHDL - deriving (Eq, Show, Read, Data, Generic, NFData, Hashable) + deriving (Eq, Show, Read, Data, Generic, NFData, Hashable, Enum, Bounded) -- | The 'Primitive' constructor instructs the clash compiler to look for primitive -- HDL templates in the indicated directory. 'InlinePrimitive' is equivalent but @@ -197,7 +193,7 @@ -- import qualified Paths_myfancyip -- import System.IO.Unsafe -- --- {\-\# ANN module (Primitive VHDL (unsafePerformIO Paths_myfancyip.getDataDir \<\/\> "path" \<\/\> "to")) \#-\} +-- {\-\# ANN module (Primitive [VHDL] (unsafePerformIO Paths_myfancyip.getDataDir \<\/\> "path" \<\/\> "to")) \#-\} -- \#endif -- @ -- @@ -218,10 +214,10 @@ -- import Data.String.Interpolate (i) -- import Data.String.Interpolate.Util (unindent) -- --- {\-\# ANN example (InlinePrimitive VHDL $ unindent [i| +-- {\-\# ANN example (InlinePrimitive [VHDL] $ unindent [i| -- [ { \"BlackBox\" : -- { "name" : "InlinePrimitive.example" --- , "kind": "Declaration" +-- , "kind": \"Declaration\" -- , "template" : -- "-- begin InlinePrimitive example: -- ~GENSYM[example][0] : block @@ -237,10 +233,10 @@ -- example = fmap succ -- @ data Primitive - = Primitive HDL FilePath - -- ^ Description of a primitive for a given 'HDL' in a file at 'FilePath' - | InlinePrimitive HDL String - -- ^ Description of a primitive for a given 'HDL' as an inline 'String' + = Primitive [HDL] FilePath + -- ^ Description of a primitive for a given 'HDL's in a file at 'FilePath' + | InlinePrimitive [HDL] String + -- ^ Description of a primitive for a given 'HDL's as an inline 'String' deriving (Show, Read, Data, Generic, NFData, Hashable) -- | Guard primitive functions. This will help Clash generate better error diff --git a/src/Clash/Annotations/SynthesisAttributes.hs b/src/Clash/Annotations/SynthesisAttributes.hs --- a/src/Clash/Annotations/SynthesisAttributes.hs +++ b/src/Clash/Annotations/SynthesisAttributes.hs @@ -9,9 +9,8 @@ (). -} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} + {-# LANGUAGE Safe #-} module Clash.Annotations.SynthesisAttributes diff --git a/src/Clash/Annotations/TH.hs b/src/Clash/Annotations/TH.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Annotations/TH.hs @@ -0,0 +1,520 @@ +{-| + +This module can automatically generate TopEntity definitions from 'Clash.NamedTypes' +annotations. Annotations involving data/type families must be inspected for correctness. +Not all cases can be handled with automatic generation due to the difficulty of type manipulation +in template Haskell. In particular annotations _inside_ the following is unlikely to work: + +- Data/type family referencing other data/type families. +- Annotations inside recursive data types +- Clock constraints other than a single HiddenClockResetEnable. (You can still + use arbitrary explicit clock/reset/enables!) + +See "Clash.Tests.TopEntityGeneration" for more examples. + +@ +import Clash.Annotations.TH + +data Named + = Named + { name1 :: "named1" ::: BitVector 3 + , name2 :: "named2" ::: BitVector 5 + } + +topEntity :: "tup1" ::: Signal System (Int, Bool) + -> "tup2" ::: (Signal System Int, Signal System Bool) + -> "tup3" ::: Signal System ("int":::Int, "bool":::Bool) + -> "tup4" ::: ("int":::Signal System Int, "bool":::Signal System Bool) + -> "custom" ::: Signal System Named + -> "outTup" ::: Signal System ("outint":::Int, "outbool":::Bool) +topEntity = undefined +makeTopEntity 'topEntity +-- ===> +-- {-# ANN topEntity Synthesize "topEntity3" +-- [ PortName "tup1" +-- , PortName "tup2" +-- , PortProduct "tup3" [PortName "int",PortName "bool"] +-- , PortProduct "tup4" [PortName "int",PortName "bool"] +-- , PortProduct "custom" [PortName "named1",PortName "named2"] +-- ] +-- (PortProduct "outTup" [PortName "outint",PortName "outbool"]) +-- #-} +@ + +-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- Required to 'makeBaseFunctor' of 'Language.Haskell.TH.Syntax.Type' + +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Clash.Annotations.TH + ( -- * To create a Synthesize annotation pragma + makeTopEntity + , makeTopEntityWithName + , makeTopEntityWithName' + -- * To create a TopEntity value + , buildTopEntity + , maybeBuildTopEntity + , getNameBinding + ) +where + +import Data.Foldable ( fold) +import qualified Data.Set as Set +import qualified Data.Map as Map +#if !(MIN_VERSION_base(4,11,0)) +import Data.Semigroup as Semigroup +#endif +import Language.Haskell.TH + +import Data.Functor.Foldable ( para ) +import Data.Functor.Foldable.TH +import Control.Lens ( (%~), (&), (.~) + , _1, _2, _3, view + ) +import Control.Monad (mfilter, liftM2) +import Control.Monad.Trans.Reader (ReaderT(..), asks, local) +import Control.Monad.Trans.Class (lift) +import Language.Haskell.TH.Instances ( ) +import Language.Haskell.TH.Datatype + +import Clash.Annotations.TopEntity ( PortName(..) + , TopEntity(..) + ) +import Clash.NamedTypes ((:::)) +import Clash.Signal ( HiddenClockResetEnable + , HiddenClock, HiddenReset, HiddenEnable + , Signal) +import Clash.Signal.Delayed (DSignal) + +$(makeBaseFunctor ''Type) + +-- | A datatype to track failing naming in a subtree. +data Naming a = Complete a | HasFail String | BackTrack (Set.Set Name) + deriving Functor + +instance Semigroup a => Semigroup (Naming a) where + Complete a <> Complete b = Complete $ a <> b + BackTrack n1 <> BackTrack n2 = BackTrack $ n1 <> n2 + BackTrack n <> _ = BackTrack n + _ <> BackTrack n = BackTrack n + HasFail e1 <> HasFail e2 = HasFail $ e1 ++ "\n" ++ e2 + _ <> HasFail e = HasFail e + HasFail e <> _ = HasFail e + +instance (Semigroup a, Monoid a) => Monoid (Naming a) where + mempty = Complete mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = (Semigroup.<>) +#endif + +-- | Track seen 'Name's, and track current 'Info' for error reporting. +type ErrorContext = String +type TrackData = (Set.Set Name, ErrorContext) +type Tracked m a = ReaderT TrackData m a + +-- * Utility functions + +-- | Matches a type `a -> b` +pattern ArrowTy :: Type -> Type -> Type +pattern ArrowTy a b = AppT (AppT ArrowT a) b + +-- | Greedily split on top level 'AppT' to recover basic type +-- application as a list of 'Type'. +unapp :: Type -> [Type] +unapp (AppT l r) = unapp l ++ [r] +unapp t = [t] + +-- | Greedily split on top level outer arrows, splitting a function 'Type' into +-- it's arguments. (Result type discarded) +unarrow :: Type -> [Type] +unarrow (ArrowTy x y) = x : unarrow y +unarrow _ = [] + +-- | Collapse a list of 'PortNames' into a single 'PortName' +collapseNames :: [PortName] -> [PortName] +collapseNames [] = [] +collapseNames [x] = [x] +collapseNames xs = [PortProduct "" xs] + +-- | Failure message with a prefix to add some context for end users. +failMsg :: String -> String +failMsg s = "TopEntity generation error: " ++ s + +-- | Retrieve current error context +errorContext :: Tracked Q String +errorContext = asks snd + +-- | Failure message with prefix in a 'Tracked' context +failMsgWithContext :: String -> Tracked Q String +failMsgWithContext s = (++) (failMsg s) <$> errorContext + +-- | Track a new seen 'Name' and update 'Info' for error handling +visit :: (Show b) => Name -> b -> Tracked m a -> Tracked m a +visit name a = local (\t -> t & _1 %~ Set.insert name + & _2 .~ show a) + +-- | Grab the 'Name's of type variables in a datatype +datatypeVars' :: DatatypeInfo -> [Name] +#if MIN_VERSION_th_abstraction(0,3,0) +datatypeVars' d = tvName <$> datatypeVars d +#else +datatypeVars' d = name <$> datatypeVars d + where + name (VarT n) = n + name (SigT n _) = name n + name e = error $ "Unexpected datatype variable name of type " ++ show e +#endif + +-- | Run a 'Name' through the template haskell machinery, getting a +-- 'DatatypeInfo' if the 'Name' specified a datatype. The result is processed by +-- a given function or a default 'a' is returned in the style of 'maybe'. +tryReifyDatatype :: a -> (DatatypeInfo -> a) -> Name -> Tracked Q a +tryReifyDatatype a f name = lift (recover (pure a) $ f <$> reifyDatatype name) + +-- * Type tree folding / unfolding + +-- | Flag constructors with partially named fields as failing. +portsFromTypes + :: [Type] + -> Tracked Q (Naming [PortName]) +portsFromTypes xs = do + (mconcat <$> mapM f xs) + >>= \case + Complete names | length names > 0 && length names /= length xs -> + HasFail <$> failMsgWithContext "Partially named constructor arguments!\n" + x -> return x + where + f = fmap (fmap collapseNames) . gatherNames + +-- | Flag sum types as failing if they have any constructors with names. +handleNamesInSum + :: [ConstructorInfo] + -> Tracked Q (Naming [PortName]) +handleNamesInSum xs = + (fold <$> mapM portsFromTypes (constructorFields <$> xs)) >>= \case + Complete [] -> return $ Complete [] + x -> + mappend x . HasFail <$> failMsgWithContext "Annotated sum types not supported!\n" + +-- | Build a list of 'PortName's from a Template Haskell 'Con' and a free +-- variable mapping +constructorToPorts :: Con -> Map.Map Name Type -> Tracked Q (Naming [PortName]) +constructorToPorts c m = do + let xs = applySubstitution m (ctys c) + portsFromTypes xs + where + ctys (NormalC _ (fmap snd -> tys)) = tys + ctys (RecC _ (fmap (view _3) -> tys)) = tys + ctys (InfixC _ _ (snd -> ty)) = [ty] + ctys (ForallC _ _ c') = ctys c' + ctys (GadtC _ (fmap snd -> tys) _) = tys + ctys (RecGadtC _ (fmap (view _3) -> tys) _) = tys + +-- | Build a list of 'PortName's from a Template Haskell 'Name' +datatypeNameToPorts + :: Name + -> Tracked Q (Naming [PortName]) +datatypeNameToPorts name = do + constructors <- tryReifyDatatype [] datatypeCons name + + names <- case constructors of + [] -> return $ Complete [] + [x] -> portsFromTypes (constructorFields x) + xs -> handleNamesInSum xs + + case names of + BackTrack ns | Set.member name ns -> do + lift $ reportWarning $ "Make sure HDL port names are correct:\n" + ++ "Backtracked when constructing " ++ pprint name + ++ "\n(Type appears recursive)" + return $ case (Set.delete name ns) of + e | e == Set.empty -> Complete [] + xs -> BackTrack xs + _ -> return names + +-- | Recursively walking a 'Type' tree and building a list of 'PortName's. +typeTreeToPorts + :: TypeF (Type, Tracked Q (Naming [PortName])) + -- ^ Case under scrutiny, paramorphism style + -> Tracked Q (Naming [PortName]) +typeTreeToPorts (AppTF (AppT (ConT split) (LitT (StrTyLit name)), _) (_,c)) + -- Is there a ' ::: ' annotation? + | split == ''(:::) + -- We found our split. If: + -- - We only have no names from children: use split name as PortName + -- - We have children reporting names: use split name as name to PortProduct + = c >>= \case + Complete [] -> return $ Complete [PortName name] + Complete xs -> return $ Complete [PortProduct name xs] + x -> return x + +typeTreeToPorts (ConTF name) = do + -- Only attempt to resolve a subtree for names we haven't seen before + seen <- asks fst + if Set.member name seen + then return $ BackTrack $ Set.singleton name + else visit name name $ do + info <- lift $ reify name + case info of + -- Either `name` is an unannotated primitive + PrimTyConI _ _ _ -> return $ Complete [] + -- ... or a type synonym + TyConI (TySynD _ _ t) -> gatherNames t + -- ... or something "datatype" like + _ -> datatypeNameToPorts name + +typeTreeToPorts f@(AppTF (a,a') (b,b')) = do + -- Gather types applied to a head type + case unapp (AppT a b) of + -- Return the inner type for signals + (ConT x : _ : _ : []) | x == ''Clash.Signal.Signal -> b' + (ConT x : _ : _ : _ : []) | x == ''Clash.Signal.Delayed.DSignal -> b' + + -- Other handled type applications are + -- 1. Type synonyms + -- 2. Closed type families + -- 3. Open type and data families + -- 4. Regular data types + (ConT x : xs) -> do + info <- lift $ reify x + case info of + -- 1. Type synonym case is just inserting the relevant port tree + (TyConI (TySynD _ synvars def)) -> do + gatherNames $ applyContext xs (tvName <$> synvars) def + + -- 2. Match argument lengths, substitute types, and then insert the port + -- tree + FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bds _ _) eqs) _ + | length bds == length xs -> + case filter ((==) xs . applyFamilyBindings xs info . tySynArgs) eqs of +#if MIN_VERSION_template_haskell(2,15,0) + [TySynEqn _ _ r] -> +#else + [TySynEqn _ r] -> +#endif + gatherNames (applyFamilyBindings xs info r) + + -- We didn't find a (single) matching instance so give up. Is this + -- impossible? + _ -> return $ Complete [] + + -- 3. Match argument lengths then: + -- - Substitute port tree for type family + -- - Try to get a unique constructor for data families and build + -- port tree from the constructor + _ | familyArity info == Just (length xs) -> do + (lift $ reifyInstances x xs) >>= \case +#if MIN_VERSION_template_haskell(2,15,0) + [TySynInstD (TySynEqn _ _ r)] -> +#else + [TySynInstD _ (TySynEqn _ r)] -> +#endif + gatherNames (applyFamilyBindings xs info r) + + [NewtypeInstD _ _ _ _ c _] -> constructorToPorts c (familyTyMap xs info) + [DataInstD _ _ _ _ cs _] -> do + case cs of + [c] -> constructorToPorts c (familyTyMap xs info) + _ -> return $ Complete [] + y -> fail $ failMsg "Encountered unexpected type during family application!" + ++ pprint y + + -- 4. Check if head really is a datatype, apply free variables, + -- and attempt to get a unique constructor + _ -> do + dataTy <- tryReifyDatatype Nothing Just x + + let -- Apply tail types to head datatype free type variables + hasAllArgs = \vs -> length xs == length (datatypeVars vs) + constructors = applyDatatypeContext xs <$> mfilter hasAllArgs dataTy + + -- Attempt to get a unique constructor + getSingleConstructor cs = do [c] <- cs; return c + constructor = getSingleConstructor constructors + + -- If any steps failed, return the PortNames according to the head type. + maybe a' (visit x (ppr x) . portsFromTypes . constructorFields) constructor + + -- If head is a tuple or list then we take all the names + (ListT:_) -> fold <$> mapM snd f + (TupleT _:_) -> fold <$> mapM snd f + + -- We're not applying to a head 'ConT' so lets try best effort of getting names + -- from all applied types + _ -> do + lift $ reportWarning $ "Make sure HDL port names are correct:\n" + ++ "Type application with non ConT head:\n:(" + ++ pprint (AppT a b) + f' <- mapM snd f + return $ fold f' + where + tyMap ctx holes = Map.fromList $ zip holes ctx + familyTyMap ctx (familyBindings -> Just holes) = tyMap ctx (tvName <$> holes) + familyTyMap _ _ = error "familyTyMap called with non family argument!" + applyContext ctx holes = applySubstitution (tyMap ctx holes) + applyDatatypeContext ctx d = applyContext ctx (datatypeVars' d) <$> datatypeCons d + applyFamilyBindings ctx (familyBindings -> Just holes) t + = applyContext ctx (tvName <$> holes) t + applyFamilyBindings _ _ _ = error "familyTyMap called with non family argument!" + +#if MIN_VERSION_template_haskell(2,15,0) + tySynArgs (TySynEqn _ args _) = tail (unapp args) +#else + tySynArgs (TySynEqn args _) = args +#endif + + familyBindings (FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ xs _ _) _) _) = Just xs + familyBindings (FamilyI (OpenTypeFamilyD (TypeFamilyHead _ xs _ _)) _) = Just xs + familyBindings (FamilyI (DataFamilyD _ xs _) _) = Just xs + familyBindings _ = Nothing + familyArity = fmap length . familyBindings + +typeTreeToPorts f = do + -- Just collect names + f' <- mapM snd f + return $ fold f' + +-- | Gather naming tree attached to a 'Type' and its inner 'Type's +gatherNames + :: Type + -- ^ Type to investigate + -> Tracked Q (Naming [PortName]) +gatherNames = + para typeTreeToPorts + +-- | Build a possible failing 'PortName' tree and unwrap the 'Naming' result. +buildPorts + :: Type + -- ^ Type to investigate + -> Q [PortName] +buildPorts x = do + flip runReaderT (Set.empty, "") $ gatherNames x + >>= \case + Complete xs -> return xs + HasFail err -> fail err + BackTrack n -> fail $ failMsg "Encountered recursive type at entry! " ++ show n + +-- | Get the result 'PortName' from a function type +toReturnName :: Type -> Q PortName +toReturnName (ArrowTy _ b) = toReturnName b +toReturnName b = + buildPorts b + >>= \case + [] -> fail $ failMsg "No return name specified!" + [x] -> return x + xs -> return $ PortProduct "" xs + +-- | Get the argument 'PortName's from a function type +toArgNames :: Type -> Q [PortName] +toArgNames ty = traverse build (unarrow ty) + where + build x = buildPorts x >>= check x + check x [] = fail $ failMsg "Unnamed argument " ++ pprint x + check _ [a] = return a + check _ xs = return $ PortProduct "" xs + +data ClockType = None | SingleClockResetEnable | Other + deriving Eq + +-- | Strip constraints from a type. +-- +-- Fail if: +-- - There are free type variables. +-- - There are multiple hidden clocks +handleConstraints :: Type -> ClockType -> Q (Type, ClockType) +handleConstraints (ForallT [] [] x) clk = handleConstraints x clk +handleConstraints (ForallT xs@(_:_) _ _) _ = + fail $ failMsg "Free type variables!\n" + ++ pprint xs +handleConstraints (ForallT _ c x) clk = handleConstraints x hiddenClocks + where + hiddenClocks = foldl findHiddenClocks clk c + findHiddenClocks a (AppT (ConT b) _) + | b == ''Clash.Signal.HiddenClockResetEnable && a == None + = SingleClockResetEnable + | b == ''Clash.Signal.HiddenClockResetEnable && a /= None + = Other + | b == ''Clash.Signal.HiddenClock + || b == ''Clash.Signal.HiddenReset + || b == ''Clash.Signal.HiddenEnable + = Other + findHiddenClocks a _ = a +handleConstraints x clk = return (x, clk) + +clockToPorts :: ClockType -> Q [PortName] +clockToPorts None = return [] +clockToPorts (SingleClockResetEnable) = + return [PortProduct "" [ PortName "clk" , PortName "rst" , PortName "en" ]] +clockToPorts Other = + fail $ failMsg "TH generation for multiple hidden clocks and" + ++ " HiddenClock/HiddenReset/HiddenEnable currently unsupported!" + +-- * + +-- | Return a typed expression for a 'TopEntity' of a given @('Name', 'Type')@. +buildTopEntity :: Maybe String -> (Name, Type) -> TExpQ TopEntity +buildTopEntity topName (name, ty) = do + (ty', clock) <- handleConstraints ty None + + ins <- liftM2 (<>) (clockToPorts clock) (toArgNames ty') + out <- toReturnName ty' + + let outName = case topName of + Just name' -> name' -- user specified name + Nothing -> nameBase name -- auto-generated from Haskell name + + [|| Synthesize + { t_name = outName + , t_inputs = ins + , t_output = out + } ||] + +-- | Return a typed 'Maybe TopEntity' expression given a 'Name'. +-- This will return an 'TExp' of 'Nothing' if 'TopEntity' generation failed. +maybeBuildTopEntity :: Maybe String -> Name -> Q (TExp (Maybe TopEntity)) +maybeBuildTopEntity topName name = do + recover ([|| Nothing ||]) $ do + let expr = getNameBinding name >>= buildTopEntity topName + [|| Just ($$expr) ||] + +-- | Turn the 'Name' of a value to a @('Name', 'Type')@ +getNameBinding :: Name -> Q (Name, Type) +getNameBinding n = reify n >>= \case + VarI name ty _ -> return (name, ty) + _ -> fail "getNameBinding: Invalid Name, must be a top-level binding!" + +-- | Wrap a 'TopEntity' expression in an annotation pragma +makeTopEntityWithName' :: Name -> Maybe String -> DecQ +makeTopEntityWithName' n topName = do + (name,ty) <- getNameBinding n + topEntity <- buildTopEntity topName (name,ty) + let prag t = PragmaD (AnnP (valueAnnotation name) t) + return $ prag $ unType topEntity + +-- | Automatically create a @'TopEntity'@ for a given @'Name'@, using the given +-- @'String'@ to specify the name of the generated RTL entity. +-- +-- The function arguments and return values of the function specified by the +-- given @'Name'@ must be annotated with @'(:::)'@. This annotation provides the +-- given name of the port. +makeTopEntityWithName :: Name -> String -> DecsQ +makeTopEntityWithName nam top = pure <$> makeTopEntityWithName' nam (Just top) + +-- | Automatically create a @'TopEntity'@ for a given @'Name'@. The name of the +-- generated RTL entity will be the name of the function that has been +-- specified; e.g. @'makeTopEntity' 'foobar@ will generate a @foobar@ module. +-- +-- The function arguments and return values of the function specified by the +-- given @'Name'@ must be annotated with @'(:::)'@. This annotation provides the +-- given name of the port. +makeTopEntity :: Name -> DecsQ +makeTopEntity nam = pure <$> makeTopEntityWithName' nam Nothing diff --git a/src/Clash/Annotations/TopEntity.hs b/src/Clash/Annotations/TopEntity.hs --- a/src/Clash/Annotations/TopEntity.hs +++ b/src/Clash/Annotations/TopEntity.hs @@ -197,10 +197,6 @@ -} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} - {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Safe #-} @@ -253,7 +249,7 @@ -- g = ... -- @ | TestBench TH.Name - deriving (Data,Show,Generic) + deriving (Eq,Data,Show,Generic) instance Lift TopEntity where lift (Synthesize name inputs output) = @@ -355,7 +351,7 @@ -- 2. The prefix for any unnamed ports below the 'PortProduct' -- -- You can use an empty String ,\"\" , in case you want an auto-generated name. - deriving (Data,Show,Generic,Lift) + deriving (Eq,Data,Show,Generic,Lift) -- | Default 'Synthesize' annotation which has no specified names for the input -- and output ports. diff --git a/src/Clash/CPP.hs b/src/Clash/CPP.hs --- a/src/Clash/CPP.hs +++ b/src/Clash/CPP.hs @@ -4,16 +4,43 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE CPP#-} +{-# LANGUAGE CPP #-} + {-# OPTIONS_HADDOCK hide #-} #ifndef MAX_TUPLE_SIZE +#ifdef LARGE_TUPLES #define MAX_TUPLE_SIZE 62 +#else +#define MAX_TUPLE_SIZE 12 #endif +#endif module Clash.CPP ( maxTupleSize + + -- ** Cabal flags + , fSuperStrict + , fStrictMapSignal ) where maxTupleSize :: Num a => a maxTupleSize = MAX_TUPLE_SIZE + +-- | Whether clash-prelude was compiled with -fsuper-strict +fSuperStrict :: Bool +#ifdef CLASH_SUPER_STRICT +fSuperStrict = True +#else +fSuperStrict = False +#endif +{-# INLINE fSuperStrict #-} + +-- | Whether clash-prelude was compiled with -fstrict-mapSignal +fStrictMapSignal :: Bool +#ifdef CLASH_STRICT_MAPSIGNAL +fStrictMapSignal = True +#else +fStrictMapSignal = False +#endif +{-# INLINE fStrictMapSignal #-} diff --git a/src/Clash/Class/AutoReg.hs b/src/Clash/Class/AutoReg.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Class/AutoReg.hs @@ -0,0 +1,13 @@ +{-| + Copyright : (C) 2019, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} + +module Clash.Class.AutoReg + ( AutoReg (autoReg) + , deriveAutoReg + ) where + +import Clash.Class.AutoReg.Internal +import Clash.Class.AutoReg.Instances () diff --git a/src/Clash/Class/AutoReg/Instances.hs b/src/Clash/Class/AutoReg/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Class/AutoReg/Instances.hs @@ -0,0 +1,30 @@ +{-| + Copyright : (C) 2019, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Clash.Class.AutoReg.Instances where + +import Clash.Class.AutoReg.Internal +import Clash.CPP (maxTupleSize) + +#if MIN_VERSION_base(4,12,0) +import Data.Complex (Complex) +import Data.Ord (Down) +#endif + +import Data.Ratio (Ratio) + +#if MIN_VERSION_base(4,12,0) +deriveAutoReg ''Complex +deriveAutoReg ''Down +#endif + +deriveAutoReg ''Ratio + +deriveAutoRegTuples [2..maxTupleSize] diff --git a/src/Clash/Class/AutoReg/Internal.hs b/src/Clash/Class/AutoReg/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Class/AutoReg/Internal.hs @@ -0,0 +1,466 @@ +{-| + Copyright : (C) 2019, Google Inc. + License : BSD2 (see the file LICENSE) + Maintainer : Christiaan Baaij +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- needed for constraint on the Fixed instance +#if __GLASGOW_HASKELL__ < 806 +{-# OPTIONS_GHC -Wwarn=unused-pattern-binds #-} +#endif + +module Clash.Class.AutoReg.Internal + ( AutoReg (..) + , deriveAutoReg + , deriveAutoRegTuples + ) + where + +import Data.List (nub,zipWith4) +import Data.Maybe (fromMaybe,isJust) + +import GHC.Stack (HasCallStack) +import GHC.TypeNats (KnownNat,Nat,type (+)) +import Clash.Explicit.Signal +import Clash.Promoted.Nat +import Clash.Magic +import Clash.XException (NFDataX, deepErrorX) + +import Clash.Sized.BitVector +import Clash.Sized.Fixed +import Clash.Sized.Index +import Clash.Sized.RTree +import Clash.Sized.Signed +import Clash.Sized.Unsigned +import Clash.Sized.Vector (Vec, lazyV, smap) + +import Data.Int +import Data.Word +import Foreign.C.Types (CUShort) +import Numeric.Half (Half) + +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Ppr + +import Control.Lens.Internal.TH (bndrName, conAppsT) + +-- $setup +-- >>> import Data.Maybe +-- >>> import Clash.Class.BitPack (pack) +-- >>> :set -fplugin GHC.TypeLits.Normalise +-- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver + +-- | 'autoReg' is a "smart" version of 'register'. It does two things: +-- +-- 1. It splits product types over their fields. For example, given a 3-tuple, +-- the corresponding HDL will end up with three instances of a register (or +-- more if the three fields can be split up similarly). +-- +-- 2. Given a data type where a constructor indicates (parts) of the data will +-- (not) be updated a given cycle, it will split the data in two parts. The +-- first part will contain the "always interesting" parts (the constructor +-- bits). The second holds the "potentially uninteresting" data (the rest). +-- Both parts will be stored in separate registers. The register holding the +-- "potentially uninteresting" part will only be enabled if the constructor +-- bits indicate they're interesting. +-- +-- The most important example of this is "Maybe". Consider "Maybe Byte)"; +-- when viewed as bits, a 'Nothing' would look like: +-- +-- >>> pack @(Maybe (Signed 16)) Nothing +-- 0_...._...._...._.... +-- +-- and 'Just' +-- +-- >>> pack @(Maybe (Signed 16)) (Just 3) +-- 1_0000_0000_0000_0011 +-- +-- In the first case, Nothing, we don't particularly care about updating the +-- register holding the "Signed 16" field, as they'll be unknown anyway. We +-- can therefore deassert its enable line. +-- +-- Making Clash lay it out like this increases the chances of synthesis tools +-- clock gating the registers, saving energy. +-- +-- This version of 'autoReg' will split the given data type up recursively. For +-- example, given "a :: Maybe (Maybe Int, Maybe Int)", a total of five registers +-- will be rendered. Both the "interesting" and "uninteresting" enable lines of +-- the inner Maybe types will be controlled by the outer one, in addition to +-- the inner parts controlling their "uninteresting" parts as described in (2). +-- +-- The default implementation is just 'register'. If you don't need or want +-- the special features of "AutoReg", you can use that by writing an empty instance. +-- +-- > data MyDataType = ... +-- > instance AutoReg MyDataType +-- +-- If you have a product type you can use 'deriveAutoReg' to derive an instance. +-- +-- "Clash.Prelude" exports an implicit version of this: 'Clash.Prelude.autoReg' +class NFDataX a => AutoReg a where + autoReg + :: (HasCallStack, KnownDomain dom) + => Clock dom -> Reset dom -> Enable dom + -> a -- ^ Reset value + -> Signal dom a + -> Signal dom a + autoReg = register + +instance AutoReg () +instance AutoReg Bool + +instance AutoReg Double +instance AutoReg Float +instance AutoReg CUShort +instance AutoReg Half + +instance AutoReg Char + +instance AutoReg Integer +instance AutoReg Int +instance AutoReg Int8 +instance AutoReg Int16 +instance AutoReg Int32 +instance AutoReg Int64 +instance AutoReg Word +instance AutoReg Word8 +instance AutoReg Word16 +instance AutoReg Word32 +instance AutoReg Word64 + +instance AutoReg Bit +instance AutoReg (BitVector n) +instance AutoReg (Signed n) +instance AutoReg (Unsigned n) +instance AutoReg (Index n) +instance NFDataX (rep (int + frac)) => AutoReg (Fixed rep int frac) + +instance AutoReg a => AutoReg (Maybe a) where + autoReg clk rst en initVal input = + createMaybe <$> tagR <*> valR + where + tag = isJust <$> input + tagInit = isJust initVal + tagR = register clk rst en tagInit tag + + val = fromMaybe (deepErrorX "autoReg'.val") <$> input + valInit = fromMaybe (deepErrorX "autoReg'.valInit") initVal + + valR = autoReg clk rst (enable en tag) valInit val + + createMaybe t v = case t of + True -> Just v + False -> Nothing + +instance (KnownNat n, AutoReg a) => AutoReg (Vec n a) where + autoReg + :: forall dom. (HasCallStack, KnownDomain dom) + => Clock dom -> Reset dom -> Enable dom + -> Vec n a -- ^ Reset value + -> Signal dom (Vec n a) + -> Signal dom (Vec n a) + autoReg clk rst en initVal xs = + bundle $ smap go (lazyV initVal) <*> unbundle xs + where + go :: forall (i :: Nat). SNat i -> a -> Signal dom a -> Signal dom a + go SNat = suffixNameFromNatP @i . autoReg clk rst en + +instance (KnownNat d, AutoReg a) => AutoReg (RTree d a) where + autoReg clk rst en initVal xs = + bundle $ (autoReg clk rst en) <$> lazyT initVal <*> unbundle xs + + +-- | Decompose an applied type into its individual components. For example, this: +-- +-- @ +-- Either Int Char +-- @ +-- +-- would be unfolded to this: +-- +-- @ +-- ('ConT' ''Either, ['ConT' ''Int, 'ConT' ''Char]) +-- @ +-- +-- This function ignores explicit parentheses and visible kind applications. +-- +-- NOTE: Copied from "Control.Lens.Internal.TH". +-- TODO: Remove this function. Can be removed once we can upgrade to lens 4.18. +-- TODO: This is currently difficult due to issue with nix. +unfoldType :: Type -> (Type, [Type]) +unfoldType = go [] + where + go :: [Type] -> Type -> (Type, [Type]) + go acc (ForallT _ _ ty) = go acc ty + go acc (AppT ty1 ty2) = go (ty2:acc) ty1 + go acc (SigT ty _) = go acc ty +#if MIN_VERSION_template_haskell(2,11,0) + go acc (ParensT ty) = go acc ty +#endif +#if MIN_VERSION_template_haskell(2,15,0) + go acc (AppKindT ty _) = go acc ty +#endif + go acc ty = (ty, acc) + +-- | Automatically derives an 'AutoReg' instance for a product type +-- +-- Usage: +-- +-- > data Pair a b = MkPair { getA :: a, getB :: b } deriving (Generic, NFDataX) +-- > data Tup3 a b c = MkTup3 { getAB :: Pair a b, getC :: c } deriving (Generic, NFDataX) +-- > deriveAutoReg ''Pair +-- > deriveAutoReg ''Tup3 +-- +-- __NB__: Because of the way template haskell works the order here matters, +-- if you try to @deriveAutoReg ''Tup3@ before @Pair@ it will complain +-- about missing an @instance AutoReg (Pair a b)@. +deriveAutoReg :: Name -> DecsQ +deriveAutoReg tyNm = do + tyInfo <- reifyDatatype tyNm + case datatypeCons tyInfo of + [] -> fail "Can't deriveAutoReg for empty types" + [conInfo] -> deriveAutoRegProduct tyInfo conInfo + _ -> fail "Can't deriveAutoReg for sum types" + + + +{- +For a type like: + data Product a b .. = MkProduct { getA :: a, getB :: b, .. } +This generates the following instance: + +instance (AutoReg a, AutoReg b, ..) => AutoReg (Product a b ..) where + autoReg clk rst en initVal input = + MkProduct <$> sig0 <*> sig1 ... + where + field0 = (\(MkProduct x _ ...) -> x) <$> input + field1 = (\(MkProduct _ x ...) -> x) <$> input + ... + MkProduct initVal0 initVal1 ... = initVal + sig0 = suffixNameP @"getA" autoReg clk rst en initVal0 field0 + sig1 = suffixNameP @"getB" autoReg clk rst en initVal1 field1 + ... +-} +deriveAutoRegProduct :: DatatypeInfo -> ConstructorInfo -> DecsQ +deriveAutoRegProduct tyInfo conInfo = go (constructorName conInfo) fieldInfos + where + tyNm = datatypeName tyInfo + tyVarBndrs = datatypeVars tyInfo + +#if MIN_VERSION_th_abstraction(0,3,0) + toTyVar = VarT . bndrName +#else + toTyVar t = case t of + VarT _ -> t + SigT t' _ -> toTyVar t' + _ -> error "deriveAutoRegProduct.toTv" +#endif + + tyVars = map toTyVar tyVarBndrs + ty = conAppsT tyNm tyVars + + fieldInfos = + zip fieldNames (constructorFields conInfo) + where + fieldNames = + case constructorVariant conInfo of + RecordConstructor nms -> map Just nms + _ -> repeat Nothing + + go :: Name -> [(Maybe Name,Type)] -> Q [Dec] + go dcNm fields = do + args <- mapM newName ["clk", "rst", "en", "initVal", "input"] + let + [clkE, rstE, enE, initValE, inputE] = map varE args + argsP = map varP args + fieldNames = map fst fields + + field :: Name -> Int -> DecQ + field nm nr = + valD (varP nm) (normalB [| $fieldSel <$> $inputE |]) [] + where + fieldSel = do + xNm <- newName "x" + let fieldP = [ if nr == n then varP xNm else wildP + | (n,_) <- zip [0..] fields] + lamE [conP dcNm fieldP] (varE xNm) -- "\(Dc _ _ .. x _ ..) -> x" + + parts <- generateNames "field" fields + fieldDecls <- sequence $ zipWith field parts [0..] + sigs <- generateNames "sig" fields + initVals <- generateNames "initVal" fields + let initPat = conP dcNm (map varP initVals) + initDecl <- valD initPat (normalB initValE) [] + + let + genAutoRegDecl :: PatQ -> ExpQ -> ExpQ -> Maybe Name -> DecsQ + genAutoRegDecl s v i nameM = + [d| $s = $nameMe autoReg $clkE $rstE $enE $i $v |] + where + nameMe = case nameM of + Nothing -> [| id |] + Just nm -> let nmSym = litT $ strTyLit (nameBase nm) + in [| suffixNameP @($nmSym) |] + + partDecls <- concat <$> (sequence $ zipWith4 genAutoRegDecl + (varP <$> sigs) + (varE <$> parts) + (varE <$> initVals) + (fieldNames) + ) + let + decls :: [DecQ] + decls = map pure (initDecl : fieldDecls ++ partDecls) + tyConE = conE dcNm + body = + case map varE sigs of + (sig0:rest) -> foldl + (\acc sigN -> [| $acc <*> $sigN |]) + [| $tyConE <$> $sig0 |] + rest + [] -> [| $tyConE |] + + autoRegDec <- funD 'autoReg [clause argsP (normalB body) decls] + ctx <- calculateRequiredContext conInfo + return [InstanceD Nothing ctx (AppT (ConT ''AutoReg) ty) [autoRegDec]] + +-- Calculate the required constraint to call autoReg on all the fields of a +-- given constructor +calculateRequiredContext :: ConstructorInfo -> Q Cxt +calculateRequiredContext conInfo = do + let fieldTys = constructorFields conInfo + wantedInstances <- mapM (\ty -> constraintsWantedFor ''AutoReg [ty]) (nub fieldTys) + return $ nub (concat wantedInstances) + +constraintsWantedFor :: Name -> [Type] -> Q Cxt +constraintsWantedFor clsNm tys + | show clsNm == "GHC.TypeNats.KnownNat" = do + -- KnownNat is special, you can't just lookup instances with reifyInstances. + -- So we just pass KnownNat constraints. + -- This will most likely require UndecidableInstances. + return [conAppsT clsNm tys] + +constraintsWantedFor clsNm [ty] = case ty of + VarT _ -> return [AppT (ConT clsNm) ty] + ConT _ -> return [] + _ -> do + insts <- reifyInstances clsNm [ty] + case insts of + [InstanceD _ cxtInst (AppT autoRegCls instTy) _] + | autoRegCls == ConT clsNm -> do + let substs = findTyVarSubsts instTy ty + cxt2 = map (applyTyVarSubsts substs) cxtInst + okCxt = filter isOk cxt2 + recurseCxt = filter needRecurse cxt2 + recursed <- mapM recurse recurseCxt + return (okCxt ++ concat recursed) + [] -> fail $ "Missing instance " ++ show clsNm ++ " (" ++ pprint ty ++ ")" + (_:_:_) -> fail $ "There are multiple " ++ show clsNm ++ " instances for " + ++ pprint ty ++ ":\n" ++ pprint insts + _ -> fail $ "Got unexpected instance: " ++ pprint insts + where + isOk :: Type -> Bool + isOk (unfoldType -> (_cls,tys)) = + case tys of + [VarT _] -> True + [_] -> False + _ -> True -- see [NOTE: MultiParamTypeClasses] + needRecurse :: Type -> Bool + needRecurse (unfoldType -> (cls,tys)) = + case tys of + [VarT _] -> False + [ConT _] -> False -- we can just drop constraints like: "AutoReg Bool => ..." + [AppT _ _] -> True + [_] -> error ( "Error while deriveAutoReg: don't know how to handle: " + ++ pprint cls ++ " (" ++ pprint tys ++ ")" ) + _ -> False -- see [NOTE: MultiParamTypeClasses] + + recurse :: Type -> Q Cxt + recurse (unfoldType -> (ConT cls,tys)) = constraintsWantedFor cls tys + recurse t = + fail ("Expected a class applied to some arguments but got " ++ pprint t) + +constraintsWantedFor clsNm tys = + return [conAppsT clsNm tys] -- see [NOTE: MultiParamTypeClasses] + +-- [NOTE: MultiParamTypeClasses] +-- The constraint calculation code doesn't handle MultiParamTypeClasses +-- "properly", but it will try to pass them on, so the resulting instance should +-- still compile with UndecidableInstances enabled. + + +-- | Find tyVar substitutions between a general type and a second possibly less +-- general type. For example: +-- +-- @ +-- findTyVarSubsts "Either a b" "Either c [Bool]" +-- == "[(a,c), (b,[Bool])]" +-- @ +findTyVarSubsts :: Type -> Type -> [(Name,Type)] +findTyVarSubsts = go + where + go ty1 ty2 = case (ty1,ty2) of + (VarT nm1 , VarT nm2) | nm1 == nm2 -> [] + (VarT nm , t) -> [(nm,t)] + (ConT _ , ConT _) -> [] + (AppT x1 y1 , AppT x2 y2) -> go x1 x2 ++ go y1 y2 + (SigT t1 k1 , SigT t2 k2) -> go t1 t2 ++ go k1 k2 + (InfixT x1 _ y1 , InfixT x2 _ y2) -> go x1 x2 ++ go y1 y2 + (UInfixT x1 _ y1, UInfixT x2 _ y2) -> go x1 x2 ++ go y1 y2 + (ParensT x1 , ParensT x2) -> go x1 x2 + +#if __GLASGOW_HASKELL__ >= 808 + (AppKindT t1 k1 , AppKindT t2 k2) -> go t1 t2 ++ go k1 k2 + (ImplicitParamT _ x1, ImplicitParamT _ x2) -> go x1 x2 +#endif + + (PromotedT _ , PromotedT _ ) -> [] + (TupleT _ , TupleT _ ) -> [] + (UnboxedTupleT _ , UnboxedTupleT _ ) -> [] + (UnboxedSumT _ , UnboxedSumT _ ) -> [] + (ArrowT , ArrowT ) -> [] + (EqualityT , EqualityT ) -> [] + (ListT , ListT ) -> [] + (PromotedTupleT _ , PromotedTupleT _ ) -> [] + (PromotedNilT , PromotedNilT ) -> [] + (PromotedConsT , PromotedConsT ) -> [] + (StarT , StarT ) -> [] + (ConstraintT , ConstraintT ) -> [] + (LitT _ , LitT _ ) -> [] + (WildCardT , WildCardT ) -> [] + _ -> error $ unlines [ "findTyVarSubsts: Unexpected types" + , "ty1:", pprint ty1,"ty2:", pprint ty2] + +applyTyVarSubsts :: [(Name,Type)] -> Type -> Type +applyTyVarSubsts substs ty = go ty + where + go ty' = case ty' of + VarT n -> case lookup n substs of + Nothing -> ty' + Just m -> m + ConT _ -> ty' + AppT ty1 ty2 -> AppT (go ty1) (go ty2) + _ -> error $ "TODO applyTyVarSubsts: " ++ show ty' + + +-- | Generate a list of fresh Name's: +-- prefix0_.., prefix1_.., prefix2_.., .. +generateNames :: String -> [a] -> Q [Name] +generateNames prefix xs = + sequence (zipWith (\n _ -> newName $ prefix ++ show @Int n) [0..] xs) + +deriveAutoRegTuples :: [Int] -> DecsQ +deriveAutoRegTuples xs = concat <$> mapM deriveAutoRegTuple xs + +deriveAutoRegTuple :: Int -> DecsQ +deriveAutoRegTuple n + | n < 2 = fail $ "deriveAutoRegTuple doesn't work for " ++ show n ++ "-tuples" + | otherwise = deriveAutoReg tupN + where + tupN = mkName $ "(" ++ replicate (n-1) ',' ++ ")" diff --git a/src/Clash/Class/BitPack.hs b/src/Clash/Class/BitPack.hs --- a/src/Clash/Class/BitPack.hs +++ b/src/Clash/Class/BitPack.hs @@ -5,18 +5,11 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE Trustworthy #-} @@ -30,6 +23,7 @@ module Clash.Class.BitPack ( BitPack (..) , bitCoerce + , bitCoerceMap , boolToBV , boolToBit , bitToBool @@ -70,7 +64,7 @@ -} -- | Convert to and from a 'BitVector' -class BitPack a where +class KnownNat (BitSize a) => BitPack a where -- | Number of 'Clash.Sized.BitVector.Bit's needed to represents elements -- of type @a@ -- @@ -149,11 +143,27 @@ -- 59 -- >>> pack (59 :: Unsigned 6) -- 11_1011 -bitCoerce :: (BitPack a, BitPack b, BitSize a ~ BitSize b) - => a - -> b +bitCoerce + :: (BitPack a, BitPack b, BitSize a ~ BitSize b) + => a + -> b bitCoerce = unpack . pack +-- | Map a value by first coercing to another type through its bit representation. +-- +-- >>> pack (-5 :: Signed 32) +-- 1111_1111_1111_1111_1111_1111_1111_1011 +-- >>> bitCoerceMap @(Vec 4 (BitVector 8)) (replace 1 0) (-5 :: Signed 32) +-- -16711685 +-- >>> pack (-16711685 :: Signed 32) +-- 1111_1111_0000_0000_1111_1111_1111_1011 +bitCoerceMap + :: forall a b . (BitPack a, BitPack b, BitSize a ~ BitSize b) + => (a -> a) + -> b + -> b +bitCoerceMap f = bitCoerce . f . bitCoerce + instance BitPack Bool where type BitSize Bool = 1 pack = let go b = if b then 1 else 0 in packXWith go @@ -189,12 +199,10 @@ pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral -#if WORD_SIZE_IN_BITS >= 64 instance BitPack Int64 where type BitSize Int64 = 64 pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral -#endif instance BitPack Word where type BitSize Word = WORD_SIZE_IN_BITS @@ -216,12 +224,10 @@ pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral -#if WORD_SIZE_IN_BITS >= 64 instance BitPack Word64 where type BitSize Word64 = 64 pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral -#endif instance BitPack Float where type BitSize Float = 32 @@ -264,7 +270,7 @@ pack _ = minBound unpack _ = () -instance (KnownNat (BitSize a), KnownNat (BitSize b), BitPack a, BitPack b) => +instance (BitPack a, BitPack b) => BitPack (a,b) where type BitSize (a,b) = BitSize a + BitSize b pack = let go (a,b) = pack a ++# pack b in packXWith go @@ -371,23 +377,14 @@ -- Instances derived using Generic instance ( BitPack a - , KnownNat (BitSize a) , BitPack b - , KnownNat (BitSize b) ) => BitPack (Either a b) -instance ( BitPack a - , KnownNat (BitSize a) - ) => BitPack (Maybe a) +instance BitPack a => BitPack (Maybe a) #if MIN_VERSION_base(4,12,0) -instance ( BitPack a - , KnownNat (BitSize a) - ) => BitPack (Complex a) - -instance ( BitPack a - , KnownNat (BitSize a) - ) => BitPack (Down a) +instance BitPack a => BitPack (Complex a) +instance BitPack a => BitPack (Down a) #endif -- | Zero-extend a 'Bool'ean value to a 'BitVector' of the appropriate size. diff --git a/src/Clash/Class/BitPack/Internal.hs b/src/Clash/Class/BitPack/Internal.hs --- a/src/Clash/Class/BitPack/Internal.hs +++ b/src/Clash/Class/BitPack/Internal.hs @@ -3,7 +3,7 @@ License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Class.BitPack.Internal (deriveBitPackTuples) where diff --git a/src/Clash/Class/Exp.hs b/src/Clash/Class/Exp.hs --- a/src/Clash/Class/Exp.hs +++ b/src/Clash/Class/Exp.hs @@ -4,15 +4,8 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE NoStarIsType #-} -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} diff --git a/src/Clash/Class/HasDomain.hs b/src/Clash/Class/HasDomain.hs --- a/src/Clash/Class/HasDomain.hs +++ b/src/Clash/Class/HasDomain.hs @@ -1,6 +1,11 @@ module Clash.Class.HasDomain ( WithSpecificDomain , WithSingleDomain + + , HasDomain + , TryDomain + , TryDomainResult(..) + , DomEq ) where -- Compilation is split across modules to maximize GHC parallelism diff --git a/src/Clash/Class/HasDomain/CodeGen.hs b/src/Clash/Class/HasDomain/CodeGen.hs --- a/src/Clash/Class/HasDomain/CodeGen.hs +++ b/src/Clash/Class/HasDomain/CodeGen.hs @@ -4,8 +4,6 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE ViewPatterns #-} - module Clash.Class.HasDomain.CodeGen ( mkTryDomainTuples , mkHasDomainTuples diff --git a/src/Clash/Class/HasDomain/Common.hs b/src/Clash/Class/HasDomain/Common.hs --- a/src/Clash/Class/HasDomain/Common.hs +++ b/src/Clash/Class/HasDomain/Common.hs @@ -4,10 +4,8 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} module Clash.Class.HasDomain.Common ( Unlines diff --git a/src/Clash/Class/HasDomain/HasSingleDomain.hs b/src/Clash/Class/HasDomain/HasSingleDomain.hs --- a/src/Clash/Class/HasDomain/HasSingleDomain.hs +++ b/src/Clash/Class/HasDomain/HasSingleDomain.hs @@ -4,15 +4,14 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} + #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif diff --git a/src/Clash/Class/HasDomain/HasSpecificDomain.hs b/src/Clash/Class/HasDomain/HasSpecificDomain.hs --- a/src/Clash/Class/HasDomain/HasSpecificDomain.hs +++ b/src/Clash/Class/HasDomain/HasSpecificDomain.hs @@ -4,16 +4,15 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif diff --git a/src/Clash/Class/Num.hs b/src/Clash/Class/Num.hs --- a/src/Clash/Class/Num.hs +++ b/src/Clash/Class/Num.hs @@ -4,9 +4,8 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Safe #-} diff --git a/src/Clash/Class/Parity.hs b/src/Clash/Class/Parity.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Class/Parity.hs @@ -0,0 +1,114 @@ +{-| +Copyright : (C) 2019, QBayLogic +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-} +{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-} +{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +#include "MachDeps.h" + +module Clash.Class.Parity + ( Parity (..) ) +where + +import Prelude hiding (even, odd) + +import Data.Int +import Data.Word +import Foreign.C.Types (CUShort) +import GHC.TypeLits (KnownNat) + +import Clash.Class.BitPack (pack) +import Clash.Sized.Internal.BitVector (BitVector, high, low, lsb#) +import Clash.Promoted.Nat (SNat(..), snatToNum) + +{- $setup +>>> import Clash.Prelude +-} + +-- | Determine whether value is odd or even +class Parity a where + -- | Check if value is even + -- + -- >>> even (4 :: Unsigned 4) + -- True + even :: a -> Bool + even = not . odd + + -- | Check if value is odd + -- + -- >>> odd (4 :: Unsigned 4) + -- False + odd :: a -> Bool + odd = not . even + {-# MINIMAL even | odd #-} + +instance Parity Integer + where + even a = a `mod` 2 == 0 + odd a = a `mod` 2 == 1 + +instance KnownNat n => Parity (BitVector n) where + even a = + case snatToNum @Integer (SNat @n) of + 0 -> True + _ -> (==low) $ lsb# a + odd a = + case snatToNum @Integer (SNat @n) of + 0 -> False + _ -> (==high) $ lsb# a + +instance Parity Bool where + even = even . pack + odd = odd . pack + +instance Parity CUShort where + even = even . pack + odd = odd . pack + +instance Parity Word where + even = even . pack + odd = odd . pack + +instance Parity Word8 where + even = even . pack + odd = odd . pack + +instance Parity Word16 where + even = even . pack + odd = odd . pack + +instance Parity Word32 where + even = even . pack + odd = odd . pack + +instance Parity Word64 where + even = even . pack + odd = odd . pack + +instance Parity Int where + even = even . pack + odd = odd . pack + +instance Parity Int8 where + even = even . pack + odd = odd . pack + +instance Parity Int16 where + even = even . pack + odd = odd . pack + +instance Parity Int32 where + even = even . pack + odd = odd . pack + +instance Parity Int64 where + even = even . pack + odd = odd . pack diff --git a/src/Clash/Class/Resize.hs b/src/Clash/Class/Resize.hs --- a/src/Clash/Class/Resize.hs +++ b/src/Clash/Class/Resize.hs @@ -4,10 +4,6 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} - {-# LANGUAGE Safe #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} @@ -15,10 +11,11 @@ module Clash.Class.Resize where +import Data.Kind (Type) import GHC.TypeLits (Nat, KnownNat, type (+)) -- | Coerce a value to be represented by a different number of bits -class Resize (f :: Nat -> *) where +class Resize (f :: Nat -> Type) where -- | A sign-preserving resize operation -- -- * For signed datatypes: Increasing the size of the number replicates the diff --git a/src/Clash/Clocks.hs b/src/Clash/Clocks.hs --- a/src/Clash/Clocks.hs +++ b/src/Clash/Clocks.hs @@ -7,22 +7,25 @@ Generic clock related utilities. -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -module Clash.Clocks (Clocks, clocks) where +module Clash.Clocks (Clocks(..)) where +import Data.Kind (Constraint) + import Clash.Signal.Internal import Clash.Clocks.Deriving (deriveClocksInstances) class Clocks t where + type ClocksCxt t :: Constraint + clocks - :: Clock domIn + :: (KnownDomain domIn, ClocksCxt t) + => Clock domIn -> Reset domIn -> t diff --git a/src/Clash/Clocks/Deriving.hs b/src/Clash/Clocks/Deriving.hs --- a/src/Clash/Clocks/Deriving.hs +++ b/src/Clash/Clocks/Deriving.hs @@ -5,9 +5,9 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module Clash.Clocks.Deriving (deriveClocksInstances) where @@ -21,9 +21,18 @@ derive' :: Int -> Q Dec derive' n = do -- (Clock d0, Clock d1, ) - instType <- foldM (\a n' -> AppT a <$> clkType n') (TupleT $ n + 1) [1..n] - instType' <- (AppT (ConT $ mkName "Clocks") . AppT instType) <$> lockType + instType0 <- foldM (\a n' -> AppT a <$> clkType n') (TupleT $ n + 1) [1..n] + instType1 <- AppT instType0 <$> lockType + let instHead = AppT (ConT $ mkName "Clocks") instType1 + cxtRHS <- foldM (\a n' -> AppT a <$> knownDomainCxt n') (TupleT n) [1..n] +#if MIN_VERSION_template_haskell(2,15,0) + let cxtLHS = AppT (ConT $ mkName "ClocksCxt") instType1 + let cxtTy = TySynInstD (TySynEqn Nothing cxtLHS cxtRHS) +#else + let cxtTy = TySynInstD (mkName "ClocksCxt") (TySynEqn [instType1] cxtRHS) +#endif + -- Function definition of 'clocks' let clk = mkName "clk" let rst = mkName "rst" @@ -35,13 +44,17 @@ let funcBody = NormalB instTuple let instFunc = FunD (mkName "clocks") [Clause [VarP clk, VarP rst] funcBody []] - return $ InstanceD Nothing [] instType' [instFunc, noInline] + return $ InstanceD Nothing [] instHead [cxtTy, instFunc, noInline] where -- | Generate type @Clock dom@ with fresh @dom@ variable clkType n' = let c = varT $ mkName ("c" ++ show n') in [t| Clock $c |] + + knownDomainCxt n' = + let c = varT $ mkName ("c" ++ show n') in + [t| KnownDomain $c |] -- | Generate type @Signal dom 'Bool@ with fresh @dom@ variable lockType = diff --git a/src/Clash/Examples.hs b/src/Clash/Examples.hs --- a/src/Clash/Examples.hs +++ b/src/Clash/Examples.hs @@ -2,12 +2,17 @@ Copyright : © 2015-2016, Christiaan Baaij, 2017 , Google Inc. 2019 , Myrtle Software Ltd -Licence : Creative Commons 4.0 (CC BY 4.0) (http://creativecommons.org/licenses/by/4.0/) +Licence : Creative Commons 4.0 (CC BY 4.0) (https://creativecommons.org/licenses/by/4.0/) -} -{-# LANGUAGE NoImplicitPrelude, CPP, TemplateHaskell, DataKinds, BinaryLiterals, - FlexibleContexts, GADTs, TypeOperators, TypeApplications, - RecordWildCards, DeriveGeneric, DeriveAnyClass #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} @@ -157,10 +162,7 @@ s = register 1 (mux enable (rotateL <$> s <*> 1) s) crcT - :: ( Bits a - , KnownNat (BitSize a) - , BitPack a - ) + :: (Bits a, BitPack a) => a -> Bit -> a @@ -551,6 +553,7 @@ {- $uart @ {\-\# LANGUAGE RecordWildCards \#-\} + module UART (uart) where import Clash.Prelude diff --git a/src/Clash/Explicit/BlockRam.hs b/src/Clash/Explicit/BlockRam.hs --- a/src/Clash/Explicit/BlockRam.hs +++ b/src/Clash/Explicit/BlockRam.hs @@ -19,6 +19,7 @@ @ {\-\# LANGUAGE RecordWildCards, TupleSections, DeriveAnyClass \#-\} + module CPU where import Clash.Explicit.Prelude @@ -373,14 +374,7 @@ -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE Trustworthy #-} @@ -406,7 +400,7 @@ where import Data.Maybe (isJust) -import qualified Data.Vector as V +import qualified Data.Sequence as Seq import GHC.Stack (HasCallStack, withFrozenCallStack) import GHC.TypeLits (KnownNat, type (^), type (<=)) import Prelude hiding (length, replicate) @@ -424,7 +418,7 @@ import Clash.Sized.Vector (Vec, replicate, toList, iterateI) import qualified Clash.Sized.Vector as CV import Clash.XException - (maybeIsX, seqX, NFDataX, deepErrorX, defaultSeqX, errorX) + (maybeIsX, seqX, NFDataX, deepErrorX, defaultSeqX, fromJustX) {- $setup >>> import Clash.Explicit.Prelude as C @@ -692,10 +686,6 @@ -} -fromJustX :: HasCallStack => Maybe a -> a -fromJustX Nothing = errorX "fromJustX: Nothing" -fromJustX (Just x) = x - -- | Create a blockRAM with space for @n@ elements -- -- * __NB__: Read value is delayed by 1 cycle @@ -997,7 +987,7 @@ -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle blockRam# (Clock _) gen content rd wen = go - (V.fromList (toList content)) + (Seq.fromList (toList content)) (withFrozenCallStack (deepErrorX "blockRam: intial value undefined")) (fromEnable gen) rd @@ -1005,16 +995,16 @@ where go !ram o ret@(~(re :- res)) rt@(~(r :- rs)) et@(~(e :- en)) wt@(~(w :- wr)) dt@(~(d :- din)) = let ram' = d `defaultSeqX` upd ram e (fromEnum w) d - o' = if re then ram V.! r else o + o' = if re then ram `Seq.index` r else o in o `seqX` o :- (ret `seq` rt `seq` et `seq` wt `seq` dt `seq` go ram' o' res rs en wr din) upd ram we waddr d = case maybeIsX we of Nothing -> case maybeIsX waddr of - Nothing -> V.map (const (seq waddr d)) ram - Just wa -> ram V.// [(wa,d)] + Nothing -> fmap (const (seq waddr d)) ram + Just wa -> Seq.update wa d ram Just True -> case maybeIsX waddr of - Nothing -> V.map (const (seq waddr d)) ram - Just wa -> ram V.// [(wa,d)] + Nothing -> fmap (const (seq waddr d)) ram + Just wa -> Seq.update wa d ram _ -> ram {-# ANN blockRam# hasBlackBox #-} {-# NOINLINE blockRam# #-} diff --git a/src/Clash/Explicit/BlockRam/File.hs b/src/Clash/Explicit/BlockRam/File.hs --- a/src/Clash/Explicit/BlockRam/File.hs +++ b/src/Clash/Explicit/BlockRam/File.hs @@ -71,13 +71,7 @@ -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE Unsafe #-} @@ -99,8 +93,8 @@ where import Data.Char (digitToInt) -import Data.Maybe (fromJust, isJust, listToMaybe) -import qualified Data.Vector as V +import Data.Maybe (isJust, listToMaybe) +import qualified Data.Sequence as Seq import GHC.Stack (HasCallStack, withFrozenCallStack) import GHC.TypeLits (KnownNat) import Numeric (readInt) @@ -112,7 +106,7 @@ (Clock(..), Signal (..), Enable, KnownDomain, fromEnable, (.&&.)) import Clash.Signal.Bundle (unbundle) import Clash.Sized.Unsigned (Unsigned) -import Clash.XException (errorX, maybeIsX, seqX) +import Clash.XException (errorX, maybeIsX, seqX, fromJustX) -- | Create a blockRAM with space for 2^@n@ elements @@ -205,7 +199,7 @@ -- clock cycle blockRamFile = \clk gen sz file rd wrM -> let en = isJust <$> wrM - (wr,din) = unbundle (fromJust <$> wrM) + (wr,din) = unbundle (fromJustX <$> wrM) in withFrozenCallStack (blockRamFile# clk gen sz file (fromEnum <$> rd) en (fromEnum <$> wr) din) {-# INLINE blockRamFile #-} @@ -242,7 +236,7 @@ where -- clock enable go - :: V.Vector (BitVector m) + :: Seq.Seq (BitVector m) -> BitVector m -> Signal dom Bool -> Signal dom Int @@ -252,22 +246,22 @@ -> Signal dom (BitVector m) go !ram o (re :- res) (r :- rs) (e :- en) (w :- wr) (d :- din) = let ram' = upd ram e (fromEnum w) d - o' = if re then ram V.! r else o + o' = if re then ram `Seq.index` r else o in o `seqX` o :- go ram' o' res rs en wr din upd ram we waddr d = case maybeIsX we of Nothing -> case maybeIsX waddr of - Nothing -> V.map (const (seq waddr d)) ram - Just wa -> ram V.// [(wa,d)] + Nothing -> fmap (const (seq waddr d)) ram + Just wa -> Seq.update wa d ram Just True -> case maybeIsX waddr of - Nothing -> V.map (const (seq waddr d)) ram - Just wa -> ram V.// [(wa,d)] + Nothing -> fmap (const (seq waddr d)) ram + Just wa -> Seq.update wa d ram _ -> ram content = unsafePerformIO (initMem file) - ramI :: V.Vector (BitVector m) - ramI = V.fromList content + ramI :: Seq.Seq (BitVector m) + ramI = Seq.fromList content {-# NOINLINE blockRamFile# #-} -- | __NB:__ Not synthesizable diff --git a/src/Clash/Explicit/DDR.hs b/src/Clash/Explicit/DDR.hs --- a/src/Clash/Explicit/DDR.hs +++ b/src/Clash/Explicit/DDR.hs @@ -18,18 +18,9 @@ or "Clash.Xilinx.DDR". -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE NoStarIsType #-} -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module Clash.Explicit.DDR ( ddrIn diff --git a/src/Clash/Explicit/Prelude.hs b/src/Clash/Explicit/Prelude.hs --- a/src/Clash/Explicit/Prelude.hs +++ b/src/Clash/Explicit/Prelude.hs @@ -9,9 +9,7 @@ defined in "Clash.Prelude". -} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Unsafe #-} @@ -57,6 +55,8 @@ , windowD , isRising , isFalling + , riseEvery + , oscillate -- * Testbench functions , assert , stimuliGenerator @@ -108,6 +108,7 @@ , Lift (..) -- ** Type classes -- *** Clash + , module Clash.Class.AutoReg , module Clash.Class.BitPack , module Clash.Class.Exp , module Clash.Class.Num @@ -118,7 +119,6 @@ , module Data.Default.Class -- ** Exceptions , module Clash.XException - , undefined -- ** Named types , module Clash.NamedTypes -- ** Magic @@ -138,6 +138,7 @@ import Clash.HaskellPrelude import Clash.Annotations.TopEntity +import Clash.Class.AutoReg import Clash.Class.BitPack import Clash.Class.Exp import Clash.Class.Num diff --git a/src/Clash/Explicit/Prelude/Safe.hs b/src/Clash/Explicit/Prelude/Safe.hs --- a/src/Clash/Explicit/Prelude/Safe.hs +++ b/src/Clash/Explicit/Prelude/Safe.hs @@ -11,11 +11,8 @@ defined in "Clash.Prelude". -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Safe #-} @@ -93,7 +90,6 @@ , module Data.Bits -- ** Exceptions , module Clash.XException - , undefined -- ** Named types , module Clash.NamedTypes -- ** Haskell Prelude @@ -105,7 +101,6 @@ import Control.Applicative import Data.Bits import GHC.Generics (Generic, Generic1) -import GHC.Stack import GHC.TypeLits import GHC.TypeLits.Extra import Clash.HaskellPrelude @@ -253,5 +248,3 @@ else (s+1, i) -- hold current output {-# INLINEABLE oscillate #-} -undefined :: HasCallStack => a -undefined = errorX "undefined" diff --git a/src/Clash/Explicit/RAM.hs b/src/Clash/Explicit/RAM.hs --- a/src/Clash/Explicit/RAM.hs +++ b/src/Clash/Explicit/RAM.hs @@ -8,15 +8,9 @@ RAM primitives with a combinational read port. -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} @@ -35,17 +29,17 @@ ) where -import Data.Maybe (fromJust, isJust) +import Data.Maybe (isJust) import GHC.Stack (HasCallStack, withFrozenCallStack) import GHC.TypeLits (KnownNat) -import qualified Data.Vector as V +import qualified Data.Sequence as Seq import Clash.Explicit.Signal (unbundle, unsafeSynchronizer, KnownDomain, enable) import Clash.Promoted.Nat (SNat (..), snatToNum, pow2SNat) import Clash.Signal.Internal (Clock (..), Signal (..), Enable, fromEnable) import Clash.Sized.Unsigned (Unsigned) -import Clash.XException (errorX, maybeIsX) +import Clash.XException (errorX, maybeIsX, fromJustX) -- | Create a RAM with space for 2^@n@ elements -- @@ -109,7 +103,7 @@ -- ^ Value of the @RAM@ at address @r@ asyncRam = \wclk rclk gen sz rd wrM -> let en = isJust <$> wrM - (wr,din) = unbundle (fromJust <$> wrM) + (wr,din) = unbundle (fromJustX <$> wrM) in withFrozenCallStack (asyncRam# wclk rclk gen sz (fromEnum <$> rd) en (fromEnum <$> wr) din) {-# INLINE asyncRam #-} @@ -141,25 +135,25 @@ unsafeSynchronizer wclk rclk dout where rd' = unsafeSynchronizer rclk wclk rd - ramI = V.replicate + ramI = Seq.replicate (snatToNum sz) (withFrozenCallStack (errorX "asyncRam#: initial value undefined")) en' = fromEnable (enable en we) dout = go ramI rd' en' wr din - go :: V.Vector a -> Signal wdom Int -> Signal wdom Bool + go :: Seq.Seq a -> Signal wdom Int -> Signal wdom Bool -> Signal wdom Int -> Signal wdom a -> Signal wdom a go !ram (r :- rs) (e :- es) (w :- ws) (d :- ds) = let ram' = upd ram e (fromEnum w) d - o = ram V.! r + o = ram `Seq.index` r in o :- go ram' rs es ws ds upd ram we' waddr d = case maybeIsX we' of Nothing -> case maybeIsX waddr of - Nothing -> V.map (const (seq waddr d)) ram - Just wa -> ram V.// [(wa,d)] + Nothing -> fmap (const (seq waddr d)) ram + Just wa -> Seq.update wa d ram Just True -> case maybeIsX waddr of - Nothing -> V.map (const (seq waddr d)) ram - Just wa -> ram V.// [(wa,d)] + Nothing -> fmap (const (seq waddr d)) ram + Just wa -> Seq.update wa d ram _ -> ram {-# NOINLINE asyncRam# #-} diff --git a/src/Clash/Explicit/ROM.hs b/src/Clash/Explicit/ROM.hs --- a/src/Clash/Explicit/ROM.hs +++ b/src/Clash/Explicit/ROM.hs @@ -8,12 +8,8 @@ ROMs -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} @@ -108,16 +104,16 @@ -- ^ Read address @rd@ -> Signal dom a -- ^ The value of the ROM at address @rd@ from the previous clock cycle -rom# _ en content rd = +rom# _ en content = go (withFrozenCallStack (deepErrorX "rom: initial value undefined")) (fromEnable en) - ((arr !) <$> rd) where szI = length content arr = listArray (0,szI-1) (toList content) - go o (e :- es) as@(~(x :- xs)) = + go o (e :- es) rd@(~(r :- rs)) = + let o1 = if e then arr ! r else o -- See [Note: register strictness annotations] - o `seqX` o :- (as `seq` if e then go x es xs else go o es xs) + in o `seqX` o :- (rd `seq` go o1 es rs) {-# NOINLINE rom# #-} diff --git a/src/Clash/Explicit/ROM/File.hs b/src/Clash/Explicit/ROM/File.hs --- a/src/Clash/Explicit/ROM/File.hs +++ b/src/Clash/Explicit/ROM/File.hs @@ -69,12 +69,7 @@ @ -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Unsafe #-} diff --git a/src/Clash/Explicit/Signal.hs b/src/Clash/Explicit/Signal.hs --- a/src/Clash/Explicit/Signal.hs +++ b/src/Clash/Explicit/Signal.hs @@ -129,28 +129,26 @@ -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} {-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-} {-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_HADDOCK show-extensions #-} module Clash.Explicit.Signal ( -- * Synchronous signal Signal + , BiSignalIn + , BiSignalOut + , BiSignalDefault(..) -- * Domain , Domain , KnownDomain(..) @@ -189,7 +187,7 @@ , initBehavior , resetPolarity -- ** Enabling - , Enable(..) + , Enable , toEnable , fromEnable , enableGen @@ -202,7 +200,7 @@ , unsafeSynchronizer , veryUnsafeSynchronizer -- * Reset - , Reset(..) + , Reset , unsafeToReset , unsafeFromReset , unsafeToHighPolarity @@ -221,6 +219,7 @@ , register , regMaybe , regEn + , mux -- * Simulation and testbench functions , clockGen , resetGen @@ -231,6 +230,8 @@ , (.&&.), (.||.) -- * Product/Signal isomorphism , Bundle(..) + , EmptyTuple(..) + , TaggedEmptyTuple(..) -- * Simulation functions (not synthesizable) , simulate , simulateB @@ -242,6 +243,8 @@ -- * List \<-\> Signal conversion (not synthesizable) , sample , sampleN + , sampleWithReset + , sampleWithResetN , fromList , fromListWithReset -- ** lazy versions @@ -255,21 +258,29 @@ , (.==.), (./=.) -- ** 'Ord'-like , (.<.), (.<=.), (.>=.), (.>.) + -- * Bisignal functions + , veryUnsafeToBiSignalIn + , readFromBiSignal + , writeToBiSignal + , mergeBiSignalOuts ) where -import Data.Maybe (isJust, fromJust) +import Data.Maybe (isJust) import GHC.TypeLits (type (+), type (<=)) import Clash.Annotations.Primitive (hasBlackBox) import Clash.Class.Num (satSucc, SaturationMode(SatBound)) import Clash.Promoted.Nat (SNat(..), snatToNum) -import Clash.Signal.Bundle (Bundle (..)) +import Clash.Signal.Bundle + (Bundle (..), EmptyTuple(..), TaggedEmptyTuple(..), vecBundle#) +import Clash.Signal.BiSignal import Clash.Signal.Internal import Clash.Signal.Internal.Ambiguous (knownVDomain, clockPeriod, activeEdge, resetKind, initBehavior, resetPolarity) import Clash.Sized.Index (Index) -import Clash.XException (NFDataX, deepErrorX) +import qualified Clash.Sized.Vector +import Clash.XException (NFDataX, deepErrorX, fromJustX) {- $setup >>> :set -XDataKinds -XTypeApplications -XFlexibleInstances -XMultiParamTypeClasses -XTypeFamilies @@ -601,7 +612,7 @@ -> Signal dom (Maybe a) -> Signal dom a delayMaybe clk gen dflt i = - delayEn clk gen dflt (isJust <$> i) (fromJust <$> i) + delayEn clk gen dflt (isJust <$> i) (fromJustX <$> i) {-# INLINE delayMaybe #-} -- | Version of 'delay' that only updates when its third argument is asserted. @@ -686,7 +697,7 @@ -> Signal dom (Maybe a) -> Signal dom a regMaybe clk rst en initial iM = - register clk rst (enable en (fmap isJust iM)) initial (fmap fromJust iM) + register clk rst (enable en (fmap isJust iM)) initial (fmap fromJustX iM) {-# INLINE regMaybe #-} -- | Version of 'register' that only updates its content when its fourth @@ -898,3 +909,53 @@ (SAsynchronous, SSynchronous) -> delay clkB enableGen True $ delay clkB enableGen True rstA1 + +-- | Get a list of samples from a 'Signal', while asserting the reset line +-- for /n/ clock cycles. 'sampleWithReset' does not return the first /n/ cycles, +-- i.e., when the reset is asserted. +-- +-- __NB__: This function is not synthesizable +sampleWithReset + :: forall dom a m + . ( KnownDomain dom + , NFDataX a + , 1 <= m ) + => SNat m + -- ^ Number of cycles to assert the reset + -> (KnownDomain dom + => Clock dom + -> Reset dom + -> Enable dom + -> Signal dom a) + -- ^ 'Signal' to sample + -> [a] +sampleWithReset nReset f0 = + let f1 = f0 clockGen (resetGenN @dom nReset) enableGen in + drop (snatToNum nReset) (sample f1) +{-# NOINLINE sampleWithReset #-} + +-- | Get a fine list of /m/ samples from a 'Signal', while asserting the reset line +-- for /n/ clock cycles. 'sampleWithReset' does not return the first /n/ cycles, +-- i.e., while the reset is asserted. +-- +-- __NB__: This function is not synthesizable +sampleWithResetN + :: forall dom a m + . ( KnownDomain dom + , NFDataX a + , 1 <= m ) + => SNat m + -- ^ Number of cycles to assert the reset + -> Int + -- ^ Number of samples to produce + -> (KnownDomain dom + => Clock dom + -> Reset dom + -> Enable dom + -> Signal dom a) + -- ^ 'Signal' to sample + -> [a] +sampleWithResetN nReset nSamples f = + take nSamples (sampleWithReset nReset f) + +{-# RULES "sequenceAVecSignal" Clash.Sized.Vector.traverse# (\x -> x) = vecBundle# #-} diff --git a/src/Clash/Explicit/Signal/Delayed.hs b/src/Clash/Explicit/Signal/Delayed.hs --- a/src/Clash/Explicit/Signal/Delayed.hs +++ b/src/Clash/Explicit/Signal/Delayed.hs @@ -6,14 +6,16 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ < 806 +{-# LANGUAGE TypeInType #-} +#endif + {-# LANGUAGE Trustworthy #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} @@ -24,6 +26,9 @@ -- * Delay-annotated synchronous signals , delayed , delayedI + , delayN + , delayI + , delayedFold , feedback -- * Signal \<-\> DSignal conversion , fromSignal @@ -39,18 +44,21 @@ where import Data.Coerce (coerce) -import GHC.TypeLits (KnownNat, type (+)) +import Data.Kind (Type) +import Data.Proxy (Proxy (..)) +import Data.Singletons.Prelude (Apply, TyFun, type (@@)) +import GHC.TypeLits (KnownNat, Nat, type (+), type (^), type (*)) import Prelude hiding (head, length, repeat) import Clash.Sized.Vector - (Vec, head, length, repeat, shiftInAt0, singleton) + (Vec, dtfold, head, length, repeat, shiftInAt0, singleton) import Clash.Signal.Delayed.Internal (DSignal(..), dfromList, dfromList_lazy, fromSignal, toSignal, unsafeFromSignal, antiDelay, feedback) import Clash.Explicit.Signal - (KnownDomain, Clock, Reset, Signal, Enable, register, bundle, unbundle) - + (KnownDomain, Clock, Domain, Reset, Signal, Enable, register, delay, bundle, unbundle) +import Clash.Promoted.Nat (SNat (..), snatToInteger) import Clash.XException (NFDataX) {- $setup @@ -59,6 +67,9 @@ >>> import Clash.Explicit.Prelude >>> let delay3 clk rst en = delayed clk rst en (-1 :> -1 :> -1 :> Nil) >>> let delay2 clk rst en = (delayedI clk rst en :: Int -> DSignal System n Int -> DSignal System (n + 2) Int) +>>> let delayN2 = delayN d2 +>>> let delayI2 = delayI :: KnownDomain dom => Int -> Enable dom -> Clock dom -> DSignal dom n Int -> DSignal dom (n + 2) Int +>>> let countingSignals = Clash.Prelude.repeat (dfromList [0..]) :: Vec 4 (DSignal dom 0 Int) >>> :{ let mac :: Clock System -> Reset System @@ -81,7 +92,8 @@ -- -- @ -- delay3 --- :: Clock dom +-- :: KnownDomain dom +-- => Clock dom -- -> Reset dom -- -> Enable dom -- -> 'DSignal' dom n Int @@ -117,7 +129,8 @@ -- -- @ -- delay2 --- :: Clock dom +-- :: KnownDomain dom +-- => Clock dom -- -> Reset dom -- -> Enable dom -- -> Int @@ -152,3 +165,110 @@ -> DSignal dom n a -> DSignal dom (n + d) a delayedI clk rst en dflt = delayed clk rst en (repeat dflt) + +-- | Delay a 'DSignal' for @d@ cycles, the value at time 0..d-1 is /a/. +-- +-- @ +-- delayN2 +-- :: 'KnownDomain' dom +-- => Int +-- -> 'Enable' dom +-- -> 'Clock' dom +-- -> 'DSignal' dom n Int +-- -> 'DSignal' dom (n + 2) Int +-- delayN2 = 'delayN' d2 +-- @ +-- +-- >>> printX $ sampleN 6 (toSignal (delayN2 (-1) enableGen systemClockGen (dfromList [1..]))) +-- [-1,-1,1,2,3,4] +delayN + :: forall dom a d n + . ( KnownDomain dom + , NFDataX a ) + => SNat d + -> a + -- ^ Initial value + -> Enable dom + -> Clock dom + -> DSignal dom n a + -> DSignal dom (n+d) a +delayN d dflt ena clk = coerce . go (snatToInteger d) . coerce @_ @(Signal dom a) + where + go 0 = id + go i = delay clk ena dflt . go (i-1) + +-- | Delay a 'DSignal' for @d@ cycles, where @d@ is derived from the context. +-- The value at time 0..d-1 is a default value. +-- +-- @ +-- delayI2 +-- :: 'KnownDomain' dom +-- => Int +-- -> 'Enable' dom +-- -> 'Clock' dom +-- -> 'DSignal' dom n Int +-- -> 'DSignal' dom (n + 2) Int +-- delayI2 = 'delayI' +-- @ +-- +-- >>> sampleN 6 (toSignal (delayI2 (-1) enableGen systemClockGen (dfromList [1..]))) +-- [-1,-1,1,2,3,4] +-- +-- You can also use type application to do the same: +-- >>> sampleN 6 (toSignal (delayI @2 (-1) enableGen systemClockGen (dfromList [1..]))) +-- [-1,-1,1,2,3,4] +delayI + :: forall d n a dom + . ( NFDataX a + , KnownDomain dom + , KnownNat d ) + => a + -- ^ Initial value + -> Enable dom + -> Clock dom + -> DSignal dom n a + -> DSignal dom (n+d) a +delayI dflt = delayN (SNat :: SNat d) dflt + +data DelayedFold (dom :: Domain) (n :: Nat) (delay :: Nat) (a :: Type) (f :: TyFun Nat Type) :: Type +type instance Apply (DelayedFold dom n delay a) k = DSignal dom (n + (delay*k)) a + +-- | Tree fold over a 'Vec' of 'DSignal's with a combinatorial function, +-- and delaying @delay@ cycles after each application. +-- Values at times 0..(delay*k)-1 are set to a default. +-- +-- @ +-- countingSignals :: Vec 4 (DSignal dom 0 Int) +-- countingSignals = repeat (dfromList [0..]) +-- @ +-- +-- >>> printX $ sampleN 6 (toSignal (delayedFold d1 (-1) (+) enableGen systemClockGen countingSignals)) +-- [-1,-2,0,4,8,12] +-- +-- >>> printX $ sampleN 8 (toSignal (delayedFold d2 (-1) (*) enableGen systemClockGen countingSignals)) +-- [-1,-1,1,1,0,1,16,81] +delayedFold + :: forall dom n delay k a + . ( NFDataX a + , KnownDomain dom + , KnownNat delay + , KnownNat k ) + => SNat delay + -- ^ Delay applied after each step + -> a + -- ^ Initial value + -> (a -> a -> a) + -- ^ Fold operation to apply + -> Enable dom + -> Clock dom + -> Vec (2^k) (DSignal dom n a) + -- ^ Vector input of size 2^k + -> DSignal dom (n + (delay * k)) a + -- ^ Output Signal delayed by (delay * k) +delayedFold _ dflt op ena clk = dtfold (Proxy :: Proxy (DelayedFold dom n delay a)) id go + where + go :: SNat l + -> DelayedFold dom n delay a @@ l + -> DelayedFold dom n delay a @@ l + -> DelayedFold dom n delay a @@ (l+1) + go SNat x y = delayI dflt ena clk (op <$> x <*> y) diff --git a/src/Clash/Explicit/SimIO.hs b/src/Clash/Explicit/SimIO.hs new file mode 100644 --- /dev/null +++ b/src/Clash/Explicit/SimIO.hs @@ -0,0 +1,333 @@ +{-| + Copyright : (C) 2019, Google Inc + License : BSD2 (see the file LICENSE) + Maintainer : QBayLogic B.V. + + I\/O actions that are translatable to HDL +-} + +{-# LANGUAGE BangPatterns, MagicHash, TypeOperators, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE DataKinds, GADTs, TypeApplications #-} + +module Clash.Explicit.SimIO + ( -- * I\/O environment for simulation + mealyIO + , SimIO + -- * Display on stdout + , display + -- * End of simulation + , finish + -- * Mutable values + , Reg + , reg + , readReg + , writeReg + -- * File I\/O + , File + , openFile + , closeFile + -- ** Reading and writing characters + , getChar + , putChar + -- ** Reading strings + , getLine + -- ** Detecting the end of input + , isEOF + -- ** Buffering operations + , flush + -- ** Repositioning handles + , seek + , rewind + , tell + ) +where + +import Control.Monad (when) +import Data.Coerce +import Data.IORef +import GHC.TypeLits +import Prelude hiding (getChar, putChar, getLine) +import qualified System.IO as IO +import System.IO.Unsafe + +import Clash.Annotations.Primitive (hasBlackBox) +import Clash.Promoted.Nat +import Clash.Signal.Internal +import Clash.Sized.Unsigned +import Clash.Sized.Vector (Vec (..)) +import Clash.XException (seqX) + +-- | Simulation-level I\/O environment; synthesizable to HDL I\/O, which in +-- itself is unlikely to be synthesisable to a digital circuit. +-- +-- See 'mealyIO' as to its use. +newtype SimIO a = SimIO {unSimIO :: IO a} + +instance Functor SimIO where + fmap = fmapSimIO# + +fmapSimIO# :: (a -> b) -> SimIO a -> SimIO b +fmapSimIO# f (SimIO m) = SimIO (fmap f m) +{-# NOINLINE fmapSimIO# #-} + +instance Applicative SimIO where + pure = pureSimIO# + (<*>) = apSimIO# + +pureSimIO# :: a -> SimIO a +pureSimIO# a = SimIO (pure a) +{-# NOINLINE pureSimIO# #-} + +apSimIO# :: SimIO (a -> b) -> SimIO a -> SimIO b +apSimIO# (SimIO f) (SimIO m) = SimIO (f <*> m) +{-# NOINLINE apSimIO# #-} + +instance Monad SimIO where + return = pureSimIO# + (>>=) = bindSimIO# + +bindSimIO# :: SimIO a -> (a -> SimIO b) -> SimIO b +bindSimIO# (SimIO m) k = SimIO (m >>= (\x -> x `seqX` coerce k x)) +{-# NOINLINE bindSimIO# #-} + +-- | Display a string on /stdout/ +display + :: String + -- ^ String you want to display + -> SimIO () +display s = SimIO (putStrLn s) +{-# NOINLINE display #-} +{-# ANN display hasBlackBox #-} + +-- | Finish the simulation with an exit code +finish + :: Integer + -- ^ The exit code you want to return at the end of the simulation + -> SimIO a +finish i = return (error (show i)) +{-# NOINLINE finish #-} +{-# ANN finish hasBlackBox #-} + +-- | Mutable reference +newtype Reg a = Reg (IORef a) + +-- | Create a new mutable reference with the given starting value +reg + :: a + -- ^ The starting value + -> SimIO (Reg a) +reg a = SimIO (Reg <$> newIORef a) +{-# NOINLINE reg #-} +{-# ANN reg hasBlackBox #-} + +-- | Read value from a mutable reference +readReg :: Reg a -> SimIO a +readReg (Reg a) = SimIO (readIORef a) +{-# NOINLINE readReg #-} +{-# ANN readReg hasBlackBox #-} + +-- | Write new value to the mutable reference +writeReg + :: Reg a + -- ^ The mutable reference + -> a + -- ^ The new value + -> SimIO () +writeReg (Reg r) a = SimIO (writeIORef r a) +{-# NOINLINE writeReg #-} +{-# ANN writeReg hasBlackBox #-} + +-- | File handle +newtype File = File IO.Handle + +-- | Open a file +openFile + :: FilePath + -- ^ File to open + -> String + -- ^ File mode: + -- + -- * "r": Open for reading + -- * "w": Create for writing + -- * "a": Append + -- * "r+": Open for update (reading and writing) + -- * "w+": Create for update + -- * "a+": Append, open or create for update at end-of-file + -> SimIO File +openFile fp "r" = coerce (IO.openFile fp IO.ReadMode) +openFile fp "w" = coerce (IO.openFile fp IO.WriteMode) +openFile fp "a" = coerce (IO.openFile fp IO.AppendMode) +openFile fp "rb" = coerce (IO.openBinaryFile fp IO.ReadMode) +openFile fp "wb" = coerce (IO.openBinaryFile fp IO.WriteMode) +openFile fp "ab" = coerce (IO.openBinaryFile fp IO.AppendMode) +openFile fp "r+" = coerce (IO.openFile fp IO.ReadWriteMode) +openFile fp "w+" = coerce (IO.openFile fp IO.WriteMode) +openFile fp "a+" = coerce (IO.openFile fp IO.AppendMode) +openFile fp "r+b" = coerce (IO.openBinaryFile fp IO.ReadWriteMode) +openFile fp "w+b" = coerce (IO.openBinaryFile fp IO.WriteMode) +openFile fp "a+b" = coerce (IO.openBinaryFile fp IO.AppendMode) +openFile fp "rb+" = coerce (IO.openBinaryFile fp IO.ReadWriteMode) +openFile fp "wb+" = coerce (IO.openBinaryFile fp IO.WriteMode) +openFile fp "ab+" = coerce (IO.openBinaryFile fp IO.AppendMode) +openFile _ m = error ("openFile unknown mode: " ++ show m) +{-# NOINLINE openFile #-} +{-# ANN openFile hasBlackBox #-} + +-- | Close a file +closeFile + :: File + -> SimIO () +closeFile (File fp) = SimIO (IO.hClose fp) +{-# NOINLINE closeFile #-} +{-# ANN closeFile hasBlackBox #-} + +-- | Read one character from a file +getChar + :: File + -- ^ File to read from + -> SimIO Char +getChar (File fp) = SimIO (IO.hGetChar fp) +{-# NOINLINE getChar #-} +{-# ANN getChar hasBlackBox #-} + +-- | Insert a character into a buffer specified by the file +putChar + :: Char + -- ^ Character to insert + -> File + -- ^ Buffer to insert to + -> SimIO () +putChar c (File fp) = SimIO (IO.hPutChar fp c) +{-# NOINLINE putChar #-} +{-# ANN putChar hasBlackBox #-} + +-- | Read one line from a file +getLine + :: forall n + . KnownNat n + => File + -- ^ File to read from + -> Reg (Vec n (Unsigned 8)) + -- ^ Vector to store the content + -> SimIO Int +getLine (File fp) (Reg r) = SimIO $ do + s <- IO.hGetLine fp + let d = snatToNum (SNat @n) - length s + when (d < 0) (IO.hSeek fp IO.RelativeSeek (toInteger d)) + modifyIORef r (rep s) + return 0 + where + rep :: String -> Vec m (Unsigned 8) -> Vec m (Unsigned 8) + rep [] vs = vs + rep (x:xs) (Cons _ vs) = Cons (toEnum (fromEnum x)) (rep xs vs) + rep _ Nil = Nil +{-# NOINLINE getLine #-} +{-# ANN getLine hasBlackBox #-} + +-- | Determine whether we've reached the end of the file +isEOF + :: File + -- ^ File we want to inspect + -> SimIO Bool +isEOF (File fp) = SimIO (IO.hIsEOF fp) +{-# NOINLINE isEOF #-} +{-# ANN isEOF hasBlackBox #-} + +-- | Set the position of the next operation on the file +seek + :: File + -- ^ File to set the position for + -> Integer + -- ^ Position + -> Int + -- ^ Mode: + -- + -- * 0: From the beginning of the file + -- * 1: From the current position + -- * 2: From the end of the file + -> SimIO Int +seek (File fp) pos mode = SimIO (IO.hSeek fp (toEnum mode) pos >> return 0) +{-# NOINLINE seek #-} +{-# ANN seek hasBlackBox #-} + +-- | Set the position of the next operation to the beginning of the file +rewind + :: File + -> SimIO Int +rewind (File fp) = SimIO (IO.hSeek fp IO.AbsoluteSeek 0 >> return 0) +{-# NOINLINE rewind #-} +{-# ANN rewind hasBlackBox #-} + +-- | Returns the offset from the beginning of the file (in bytes). +tell + :: File + -- ^ File we want to inspect + -> SimIO Integer +tell (File fp) = SimIO (IO.hTell fp) +{-# NOINLINE tell #-} +{-# ANN tell hasBlackBox #-} + +-- | Write any buffered output to file +flush + :: File + -> SimIO () +flush (File fp) = SimIO (IO.hFlush fp) +{-# NOINLINE flush #-} +{-# ANN flush hasBlackBox #-} + +-- | Simulation-level I/O environment that can be synthesized to HDL-level I\/O. +-- Note that it is unlikely that the HDL-level I\/O can subsequently be +-- synthesized to a circuit. +-- +-- = Example +-- +-- @ +-- tbMachine :: (File,File) -> Int -> SimIO Int +-- tbMachine (fileIn,fileOut) regOut = do +-- eofFileOut <- 'isEOF' fileOut +-- eofFileIn <- 'isEOF' fileIn +-- when (eofFileIn || eofFileOut) $ do +-- 'display' "success" +-- 'finish' 0 +-- +-- goldenIn <- 'getChar' fileIn +-- goldenOut <- 'getChar' fileOut +-- res <- if regOut == fromEnum goldenOut then do +-- return (fromEnum goldenIn) +-- else do +-- 'display' "Output doesn't match golden output" +-- 'finish' 1 +-- display ("Output matches golden output") +-- return res +-- +-- tbInit :: (File,File) +-- tbInit = do +-- fileIn <- 'openFile' "./goldenInput00.txt" "r" +-- fileOut <- 'openFile' "./goldenOutput00.txt" "r" +-- return (fileIn,fileOut) +-- +-- topEntity :: Signal System Int +-- topEntity = regOut +-- where +-- clk = systemClockGen +-- rst = resetGen +-- ena = enableGen +-- +-- regOut = register clk rst ena (fromEnum 'a') regIn +-- regIn = 'mealyIO' clk tbMachine tbInit regOut +-- @ +mealyIO + :: KnownDomain dom + => Clock dom + -- ^ Clock at which rate the I\/O environment progresses + -> (s -> i -> SimIO o) + -- ^ Transition function inside an I\/O environment + -> SimIO s + -- ^ I/O action to create the initial state + -> Signal dom i + -> Signal dom o +mealyIO !_ f (SimIO i) inp = unsafePerformIO (i >>= go inp) + where + go q@(~(k :- ks)) s = + (:-) <$> unSimIO (f s k) <*> unsafeInterleaveIO ((q `seq` go ks s)) +{-# NOINLINE mealyIO #-} diff --git a/src/Clash/Explicit/Synchronizer.hs b/src/Clash/Explicit/Synchronizer.hs --- a/src/Clash/Explicit/Synchronizer.hs +++ b/src/Clash/Explicit/Synchronizer.hs @@ -8,13 +8,10 @@ Synchronizer circuits for safe clock domain crossings -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE Safe #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} diff --git a/src/Clash/Explicit/Testbench.hs b/src/Clash/Explicit/Testbench.hs --- a/src/Clash/Explicit/Testbench.hs +++ b/src/Clash/Explicit/Testbench.hs @@ -6,12 +6,7 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Unsafe #-} @@ -23,6 +18,7 @@ module Clash.Explicit.Testbench ( -- * Testbench functions for circuits assert + , assertBitVector , ignoreFor , stimuliGenerator @@ -51,9 +47,9 @@ import Clash.Explicit.Signal (Clock, Reset, System, Signal, clockPeriod, toEnable, fromList, register, unbundle, unsafeSynchronizer, veryUnsafeSynchronizer) -import Clash.Signal.Internal (Clock (..)) +import Clash.Signal.Internal (Clock (..), Reset (..)) import Clash.Signal - (mux, DomainResetKind, ResetKind(Asynchronous), KnownDomain, Reset(..), + (mux, DomainResetKind, ResetKind(Asynchronous), KnownDomain, Enable) import Clash.Sized.Index (Index) import Clash.Sized.Internal.BitVector diff --git a/src/Clash/HaskellPrelude.hs b/src/Clash/HaskellPrelude.hs --- a/src/Clash/HaskellPrelude.hs +++ b/src/Clash/HaskellPrelude.hs @@ -4,8 +4,8 @@ Maintainer : QBayLogic B.V "Clash.HaskellPrelude" re-exports most of the Haskell "Prelude" with the exception of -the following: (++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, -init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, +the following: (++), (!!), concat, drop, even, foldl, foldl1, foldr, foldr1, head, +init, iterate, last, length, map, odd, repeat, replicate, reverse, scanl, scanr, splitAt, tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3. -} @@ -18,6 +18,7 @@ where import Prelude hiding - ((++), (!!), concat, concatMap, drop, foldl, foldl1, foldr, foldr1, head, init, - iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, splitAt, - tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3, undefined, (^)) + ((++), (!!), concat, concatMap, drop, even, foldl, foldl1, foldr, foldr1, head, init, + iterate, last, length, map, odd, repeat, replicate, reverse, scanl, scanr, splitAt, + tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3, undefined, (^), + getChar, putChar, getLine) diff --git a/src/Clash/Hidden.hs b/src/Clash/Hidden.hs --- a/src/Clash/Hidden.hs +++ b/src/Clash/Hidden.hs @@ -6,15 +6,11 @@ Hidden arguments -} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-} diff --git a/src/Clash/Intel/ClockGen.hs b/src/Clash/Intel/ClockGen.hs --- a/src/Clash/Intel/ClockGen.hs +++ b/src/Clash/Intel/ClockGen.hs @@ -7,23 +7,22 @@ PLL and other clock-related components for Intel (Altera) FPGAs -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} module Clash.Intel.ClockGen ( altpll , alteraPll ) where -import Clash.Clocks (clocks, Clocks) +import Clash.Clocks (Clocks (..)) import Clash.Promoted.Symbol (SSymbol) import Clash.Signal.Internal - (Signal, Clock, Reset) + (Signal, Clock, Reset, KnownDomain (..)) -- | A clock source that corresponds to the Intel/Quartus \"ALTPLL\" component +-- (Arria GX, Arria II, Stratix IV, Stratix III, Stratix II, Stratix, +-- Cyclone 10 LP, Cyclone IV, Cyclone III, Cyclone II, Cyclone) -- with settings to provide a stable 'Clock' from a single free-running input -- -- Only works when configured with: @@ -41,11 +40,11 @@ -- @ altpll :: forall domOut domIn name - . SSymbol name - -- ^ Name of the component, must correspond to the name entered in the QSys - -- dialog. + . (KnownDomain domIn, KnownDomain domOut) + => SSymbol name + -- ^ Name of the component instance. -- - -- For example, when you entered \"altPLL50\", instantiate as follows: + -- Instantiate as follows: -- -- > SSymbol @"altPLL50" -> Clock domIn @@ -54,12 +53,12 @@ -- ^ Reset for the PLL -> (Clock domOut, Signal domOut Bool) -- ^ (Stable PLL clock, PLL lock) -altpll !_ = clocks +altpll !_ = knownDomain @domIn `seq` knownDomain @domOut `seq` clocks {-# NOINLINE altpll #-} -- | A clock source that corresponds to the Intel/Quartus \"Altera PLL\" --- component with settings to provide a stable 'Clock' from a single --- free-running input +-- component (Arria V, Stratix V, Cyclone V) with settings to provide a stable +-- 'Clock' from a single free-running input -- -- Only works when configured with: -- @@ -83,12 +82,11 @@ -- -- respectively. alteraPll - :: Clocks t + :: (Clocks t, KnownDomain domIn, ClocksCxt t) => SSymbol name - -- ^ Name of the component, must correspond to the name entered in the QSys - -- dialog. + -- ^ Name of the component instance. -- - -- For example, when you entered \"alteraPLL50\", instantiate as follows: + -- Instantiate as follows: -- -- > SSymbol @"alteraPLL50" -> Clock domIn diff --git a/src/Clash/Intel/DDR.hs b/src/Clash/Intel/DDR.hs --- a/src/Clash/Intel/DDR.hs +++ b/src/Clash/Intel/DDR.hs @@ -13,15 +13,9 @@ -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE NoStarIsType #-} -#endif +{-# LANGUAGE TypeFamilies #-} module Clash.Intel.DDR ( altddioIn diff --git a/src/Clash/Magic.hs b/src/Clash/Magic.hs --- a/src/Clash/Magic.hs +++ b/src/Clash/Magic.hs @@ -1,20 +1,28 @@ {-| Copyright : (C) 2019, Myrtle Software Ltd License : BSD2 (see the file LICENSE) - Maintainer : QBayLogic B.V. + Maintainer : QBayLogic B.V. Control module instance, and register, names in generated HDL code. -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} +module Clash.Magic + ( + -- ** Functions to control names of identifiers in HDL + prefixName + , suffixName + , suffixNameP + , suffixNameFromNat + , suffixNameFromNatP + , setName -module Clash.Magic where + -- ** Functions to control Clash's (de)duplication mechanisms + , deDup + , noDeDup + ) where import Clash.NamedTypes ((:::)) -import GHC.TypeLits (Symbol) +import GHC.TypeLits (Nat,Symbol) -- | Prefix instance and register names with the given 'Symbol' prefixName @@ -28,6 +36,58 @@ suffixName = id {-# NOINLINE suffixName #-} +-- | Suffix instance and register names with the given 'Nat' +suffixNameFromNat + :: forall (name :: Nat) a . a -> name ::: a +suffixNameFromNat = id +{-# NOINLINE suffixNameFromNat #-} + +-- | Suffix instance and register names with the given 'Symbol', but add it +-- in front of other suffixes. +-- +-- When you write +-- +-- @ +-- suffixName \@\"A\" (suffixName \@\"B\" f)) +-- @ +-- +-- you get register and instance names inside /f/ with the suffix: "_B_A" +-- +-- However, if you want them in the other order you can write: +-- +-- @ +-- suffixNameP \@\"A\" (suffixName \@\"B\" f)) +-- @ +-- +-- so that names inside /f/ will have the suffix "_A_B" +suffixNameP + :: forall (name :: Symbol) a . a -> name ::: a +suffixNameP = id +{-# NOINLINE suffixNameP #-} + +-- | Suffix instance and register names with the given 'Nat', but add it in +-- front of other suffixes. +-- +-- When you write +-- +-- @ +-- suffixNameNat \@1 (suffixName \@\"B\" f)) +-- @ +-- +-- you get register and instance names inside /f/ with the suffix: "_B_1" +-- +-- However, if you want them in the other order you can write: +-- +-- @ +-- suffixNameNatP \@1 (suffixName \@\"B\" f)) +-- @ +-- +-- so that names inside /f/ will have the suffix "_1_B" +suffixNameFromNatP + :: forall (name :: Nat) a . a -> name ::: a +suffixNameFromNatP = id +{-# NOINLINE suffixNameFromNatP #-} + -- | Name the instance or register with the given 'Symbol', instead of using -- an auto-generated name. Pre- and suffixes annotated with 'prefixName' and -- 'suffixName' will be added to both instances and registers named with @@ -36,3 +96,108 @@ :: forall (name :: Symbol) a . a -> name ::: a setName = id {-# NOINLINE setName #-} + +-- | Force deduplication, i.e. share a function or operator between multiple +-- branches. +-- +-- By default Clash converts +-- +-- @ +-- case x of +-- A -> 3 * y +-- B -> x * x +-- @ +-- +-- to +-- +-- @ +-- let f_arg0 = case x of {A -> 3; _ -> x} +-- f_arg1 = case x of {A -> y; _ -> x} +-- f_out = f_arg0 * f_arg1 +-- in case x of +-- A -> f_out +-- B -> f_out +-- @ +-- +-- However, it won't do this for: +-- +-- @ +-- case x of +-- A -> 3 + y +-- B -> x + x +-- @ +-- +-- Because according to the internal heuristics the multiplexer introduced for +-- the deduplication are more expensive than the addition. This might not be +-- the case for your particular platform. +-- +-- In these cases you can force Clash to deduplicate by: +-- +-- @ +-- case x of +-- A -> 'deDup' (3 + y) +-- B -> 'deDup' (x + x) +-- @ +deDup + :: forall a . a -> a +deDup = id +{-# NOINLINE deDup #-} + +-- | Do not deduplicate, i.e. /keep/, an applied function inside a +-- case-alternative; do not try to share the function between multiple +-- branches. +-- +-- By default Clash converts +-- +-- @ +-- case x of +-- A -> f 3 y +-- B -> f x x +-- C -> h x +-- @ +-- +-- to +-- +-- @ +-- let f_arg0 = case x of {A -> 3; _ -> x} +-- f_arg1 = case x of {A -> y; _ -> x} +-- f_out = f f_arg0 f_arg1 +-- in case x of +-- A -> f_out +-- B -> f_out +-- C -> h x +-- @ +-- +-- i.e. it deduplicates functions (and operators such as multiplication) between +-- case-alternatives to save on area. This comes at the cost of multiplexing the +-- arguments for the deduplicated function. +-- +-- There are two reasons you would want to stop Clash from doing this: +-- +-- 1. The deduplicated function is in the critical path, and the addition of the +-- multiplexers further increased the propagation delay. +-- +-- 2. Clash's heuristics were off, and the addition of the multiplexers actually +-- made the final circuit larger instead of smaller. +-- +-- In these cases you want to tell Clash not to deduplicate: +-- +-- @ +-- case x of +-- A -> 'noDeDup' f 3 y +-- B -> f x x +-- C -> h x +-- @ +-- +-- Where the application of /f/ in the /A/-alternative is now explicitly not +-- deduplicated, and given that the /f/ in the B-alternative is the only +-- remaining application of /f/ in the case-expression it is also not +-- deduplicated. +-- +-- Note that if the /C/-alternative also had an application of /f/, then the +-- applications of /f/ in the /B/- and /C/-alternatives would have been +-- deduplicated; i.e. the final circuit would have had two application of /f/. +noDeDup + :: forall a . a -> a +noDeDup = id +{-# NOINLINE noDeDup #-} diff --git a/src/Clash/NamedTypes.hs b/src/Clash/NamedTypes.hs --- a/src/Clash/NamedTypes.hs +++ b/src/Clash/NamedTypes.hs @@ -33,8 +33,7 @@ -} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE Safe #-} diff --git a/src/Clash/Prelude.hs b/src/Clash/Prelude.hs --- a/src/Clash/Prelude.hs +++ b/src/Clash/Prelude.hs @@ -32,11 +32,10 @@ Some circuit examples can be found in "Clash.Examples". -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Unsafe #-} @@ -133,9 +132,12 @@ , Lift (..) -- ** Type classes -- *** Clash + -- , module Clash.Class.AutoReg + , autoReg, deriveAutoReg , module Clash.Class.BitPack , module Clash.Class.Exp , module Clash.Class.Num + , module Clash.Class.Parity , module Clash.Class.Resize -- *** Other , module Control.Applicative @@ -143,7 +145,6 @@ , module Data.Default.Class -- ** Exceptions , module Clash.XException - , undefined -- ** Named types , module Clash.NamedTypes -- ** Hidden arguments @@ -159,15 +160,18 @@ import Control.Applicative import Data.Bits import Data.Default.Class +import GHC.Stack (HasCallStack) import GHC.TypeLits import GHC.TypeLits.Extra import Language.Haskell.TH.Syntax (Lift(..)) import Clash.HaskellPrelude import Clash.Annotations.TopEntity +import Clash.Class.AutoReg (AutoReg, deriveAutoReg) import Clash.Class.BitPack import Clash.Class.Exp import Clash.Class.Num +import Clash.Class.Parity import Clash.Class.Resize import qualified Clash.Explicit.Prelude as E import Clash.Hidden @@ -207,12 +211,13 @@ {- $hiding "Clash.Prelude" re-exports most of the Haskell "Prelude" with the exception of -the following: (++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, -init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, +the following: (++), (!!), concat, drop, even, foldl, foldl1, foldr, foldr1, head, +init, iterate, last, length, map, odd, repeat, replicate, reverse, scanl, scanr, splitAt, tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3. It instead exports the identically named functions defined in terms of -'Clash.Sized.Vector.Vec' at "Clash.Sized.Vector". +'Clash.Sized.Vector.Vec' at "Clash.Sized.Vector". For the 'odd' end 'even' +function a type class called Parity is available at 'Clash.Class.Parity'. -} @@ -259,3 +264,11 @@ -- ^ Window of at least size 1 windowD = hideClockResetEnable E.windowD {-# INLINE windowD #-} + +-- | Implicit version of 'Clash.Class.AutoReg.autoReg' +autoReg + :: (HasCallStack, HiddenClockResetEnable dom, AutoReg a) + => a + -> Signal dom a + -> Signal dom a +autoReg = hideClockResetEnable E.autoReg diff --git a/src/Clash/Prelude/BitIndex.hs b/src/Clash/Prelude/BitIndex.hs --- a/src/Clash/Prelude/BitIndex.hs +++ b/src/Clash/Prelude/BitIndex.hs @@ -4,11 +4,8 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} @@ -42,7 +39,7 @@ -- >>> (7 :: Unsigned 6) ! 6 -- *** Exception: (!): 6 is out of range [5..0] -- ... -(!) :: (BitPack a, KnownNat (BitSize a), Enum i) => a -> i -> Bit +(!) :: (BitPack a, Enum i) => a -> i -> Bit (!) v i = index# (pack v) (fromEnum i) {-# INLINE slice #-} @@ -96,8 +93,7 @@ -- >>> replaceBit 6 0 (-5 :: Signed 6) -- *** Exception: replaceBit: 6 is out of range [5..0] -- ... -replaceBit :: (BitPack a, KnownNat (BitSize a), Enum i) => i -> Bit -> a - -> a +replaceBit :: (BitPack a, Enum i) => i -> Bit -> a -> a replaceBit i b v = unpack (replaceBit# (pack v) (fromEnum i) b) {-# INLINE setSlice #-} @@ -134,7 +130,7 @@ -- 00_0100 -- >>> msb (4 :: Signed 6) -- 0 -msb :: (BitPack a, KnownNat (BitSize a)) => a -> Bit +msb :: BitPack a => a -> Bit msb v = msb# (pack v) {-# INLINE lsb #-} diff --git a/src/Clash/Prelude/BitReduction.hs b/src/Clash/Prelude/BitReduction.hs --- a/src/Clash/Prelude/BitReduction.hs +++ b/src/Clash/Prelude/BitReduction.hs @@ -5,7 +5,6 @@ -} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE Trustworthy #-} @@ -13,8 +12,6 @@ module Clash.Prelude.BitReduction where -import GHC.TypeLits (KnownNat) - import Clash.Class.BitPack (BitPack (..)) import Clash.Sized.Internal.BitVector (Bit, reduceAnd#, reduceOr#, reduceXor#) @@ -39,7 +36,7 @@ -- -- >>> reduceAnd (0 :: Unsigned 0) -- 1 -reduceAnd :: (BitPack a, KnownNat (BitSize a)) => a -> Bit +reduceAnd :: BitPack a => a -> Bit reduceAnd v = reduceAnd# (pack v) {-# INLINE reduceOr #-} @@ -58,7 +55,7 @@ -- -- >>> reduceOr (0 :: Unsigned 0) -- 0 -reduceOr :: (BitPack a, KnownNat (BitSize a)) => a -> Bit +reduceOr :: BitPack a => a -> Bit reduceOr v = reduceOr# (pack v) {-# INLINE reduceXor #-} @@ -81,5 +78,5 @@ -- -- >>> reduceXor (0 :: Unsigned 0) -- 0 -reduceXor :: (BitPack a, KnownNat (BitSize a)) => a -> Bit +reduceXor :: BitPack a => a -> Bit reduceXor v = reduceXor# (pack v) diff --git a/src/Clash/Prelude/BlockRam.hs b/src/Clash/Prelude/BlockRam.hs --- a/src/Clash/Prelude/BlockRam.hs +++ b/src/Clash/Prelude/BlockRam.hs @@ -19,6 +19,7 @@ @ {\-\# LANGUAGE RecordWildCards, TupleSections, DeriveAnyClass, TypeApplications \#-\} + module CPU where import Clash.Prelude @@ -372,11 +373,8 @@ -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE Safe #-} diff --git a/src/Clash/Prelude/BlockRam/File.hs b/src/Clash/Prelude/BlockRam/File.hs --- a/src/Clash/Prelude/BlockRam/File.hs +++ b/src/Clash/Prelude/BlockRam/File.hs @@ -65,14 +65,8 @@ -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE Unsafe #-} diff --git a/src/Clash/Prelude/DataFlow.hs b/src/Clash/Prelude/DataFlow.hs --- a/src/Clash/Prelude/DataFlow.hs +++ b/src/Clash/Prelude/DataFlow.hs @@ -8,13 +8,9 @@ Self-synchronizing circuits based on data-flow principles. -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Safe #-} diff --git a/src/Clash/Prelude/RAM.hs b/src/Clash/Prelude/RAM.hs --- a/src/Clash/Prelude/RAM.hs +++ b/src/Clash/Prelude/RAM.hs @@ -8,15 +8,9 @@ RAM primitives with a combinational read port. -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Safe #-} diff --git a/src/Clash/Prelude/ROM.hs b/src/Clash/Prelude/ROM.hs --- a/src/Clash/Prelude/ROM.hs +++ b/src/Clash/Prelude/ROM.hs @@ -8,11 +8,8 @@ ROMs -} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} @@ -91,7 +88,7 @@ -- ^ Read address @rd@ -> a -- ^ The value of the ROM at address @rd@ -asyncRom# content rd = arr ! rd +asyncRom# content = \rd -> arr ! rd where szI = length content arr = listArray (0,szI-1) (toList content) diff --git a/src/Clash/Prelude/ROM/File.hs b/src/Clash/Prelude/ROM/File.hs --- a/src/Clash/Prelude/ROM/File.hs +++ b/src/Clash/Prelude/ROM/File.hs @@ -63,12 +63,7 @@ @ -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Unsafe #-} diff --git a/src/Clash/Prelude/Safe.hs b/src/Clash/Prelude/Safe.hs --- a/src/Clash/Prelude/Safe.hs +++ b/src/Clash/Prelude/Safe.hs @@ -29,10 +29,8 @@ Some circuit examples can be found in "Clash.Examples". -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Safe #-} @@ -108,7 +106,6 @@ , module Data.Bits -- ** Exceptions , module Clash.XException - , E.undefined -- ** Named types , module Clash.NamedTypes -- ** Hidden arguments diff --git a/src/Clash/Prelude/Synchronizer.hs b/src/Clash/Prelude/Synchronizer.hs --- a/src/Clash/Prelude/Synchronizer.hs +++ b/src/Clash/Prelude/Synchronizer.hs @@ -6,9 +6,7 @@ Synchronizer circuits for safe clock domain crossings -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Clash.Prelude.Synchronizer ( -- * Bit-synchronizers diff --git a/src/Clash/Prelude/Testbench.hs b/src/Clash/Prelude/Testbench.hs --- a/src/Clash/Prelude/Testbench.hs +++ b/src/Clash/Prelude/Testbench.hs @@ -6,10 +6,8 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Unsafe #-} @@ -18,6 +16,7 @@ module Clash.Prelude.Testbench ( -- * Testbench functions for circuits assert + , assertBitVector , ignoreFor , outputVerifier' , outputVerifierBitVector' @@ -68,6 +67,22 @@ assert msg actual expected ret = hideReset (hideClock E.assert) msg actual expected ret {-# INLINE assert #-} + +-- | The same as 'assert', but can handle don't care bits in it's expected value. +assertBitVector + :: (KnownNat n, HiddenClock dom , HiddenReset dom ) + => String + -- ^ Additional message + -> Signal dom (BitVector n) + -- ^ Checked value + -> Signal dom (BitVector n) + -- ^ Expected value + -> Signal dom b + -- ^ Return value + -> Signal dom b +assertBitVector msg actual expected ret = + hideReset (hideClock E.assertBitVector) msg actual expected ret +{-# INLINE assertBitVector #-} -- | -- diff --git a/src/Clash/Promoted/Nat.hs b/src/Clash/Promoted/Nat.hs --- a/src/Clash/Promoted/Nat.hs +++ b/src/Clash/Promoted/Nat.hs @@ -6,19 +6,10 @@ -} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RankNTypes #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE NoStarIsType #-} -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE Trustworthy #-} @@ -77,6 +68,7 @@ where import Data.Kind (Type) +import GHC.Show (appPrec) import GHC.TypeLits (KnownNat, Nat, type (+), type (-), type (*), type (^), type (<=), natVal) import GHC.TypeLits.Extra (CLog, FLog, Div, Log, Mod, Min, Max) @@ -109,7 +101,11 @@ snatProxy _ = SNat instance Show (SNat n) where - show p@SNat = 'd' : show (snatToInteger p) + showsPrec d p@SNat | n <= 1024 = showChar 'd' . shows n + | otherwise = showParen (d > appPrec) $ + showString "SNat @" . shows n + where + n = snatToInteger p instance ShowX (SNat n) where showsPrecX = showsPrecXWith showsPrec diff --git a/src/Clash/Promoted/Nat/Literals.hs b/src/Clash/Promoted/Nat/Literals.hs --- a/src/Clash/Promoted/Nat/Literals.hs +++ b/src/Clash/Promoted/Nat/Literals.hs @@ -18,9 +18,8 @@ You can generate more 'SNat' literals using 'decLiteralsD' from "Clash.Promoted.Nat.TH" -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE Trustworthy #-} diff --git a/src/Clash/Promoted/Symbol.hs b/src/Clash/Promoted/Symbol.hs --- a/src/Clash/Promoted/Symbol.hs +++ b/src/Clash/Promoted/Symbol.hs @@ -4,9 +4,7 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Safe #-} @@ -18,6 +16,7 @@ where import Language.Haskell.TH.Syntax +import GHC.Show (appPrec) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -- | Singleton value for a type-level string @s@ @@ -32,7 +31,8 @@ instance Show (SSymbol s) where - show s@SSymbol = symbolVal s + showsPrec d s@SSymbol = showParen (d > appPrec) $ + showString "SSymbol @" . shows (ssymbolToString s) {-# INLINE ssymbolProxy #-} -- | Create a singleton symbol literal @'SSymbol' s@ from a proxy for diff --git a/src/Clash/Signal.hs b/src/Clash/Signal.hs --- a/src/Clash/Signal.hs +++ b/src/Clash/Signal.hs @@ -66,26 +66,20 @@ Check out 'IntelSystem' and 'XilinxSystem' too! -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} + +{-# LANGUAGE Trustworthy #-} + #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif -{-# LANGUAGE Trustworthy #-} - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_HADDOCK show-extensions #-} module Clash.Signal @@ -140,7 +134,7 @@ , unsafeSynchronizer #endif -- * Reset - , Reset(..) + , Reset , unsafeToReset , unsafeFromReset , unsafeToHighPolarity @@ -150,10 +144,10 @@ #ifdef CLASH_MULTIPLE_HIDDEN , convertReset #endif - , E.resetSynchronizer + , resetSynchronizer , holdReset -- ** Enabling - , Enable(..) + , Enable , toEnable , fromEnable , S.enableGen @@ -164,9 +158,11 @@ , HiddenClock , hideClock , exposeClock - , exposeSpecificClock , withClock +#ifdef CLASH_MULTIPLE_HIDDEN + , exposeSpecificClock , withSpecificClock +#endif , hasClock -- ** Hidden reset , HiddenReset @@ -217,6 +213,8 @@ , (.&&.), (.||.) -- * Product/Signal isomorphism , Bundle(..) + , EmptyTuple(..) + , TaggedEmptyTuple(..) -- * Simulation functions (not synthesizable) , simulate , simulateB @@ -251,33 +249,31 @@ , mergeBiSignalOuts ) where - -import GHC.TypeLits - (KnownNat, KnownSymbol, AppendSymbol, Symbol, type (<=)) -import Data.Bits (Bits) -- Haddock only +import GHC.TypeLits (type (<=)) import Data.Proxy (Proxy(..)) import Prelude import Test.QuickCheck (Property, property) + #ifdef CLASH_MULTIPLE_HIDDEN -import Clash.Class.HasDomain (WithSingleDomain, WithSpecificDomain) -#else -import Clash.Class.HasDomain (WithSpecificDomain) +import GHC.TypeLits (AppendSymbol) +import Clash.Class.HasDomain (WithSingleDomain) #endif + +import Clash.Class.HasDomain (WithSpecificDomain) import qualified Clash.Explicit.Signal as E import Clash.Explicit.Signal - (System, resetSynchronizer, systemClockGen, systemResetGen) + (resetSynchronizer, systemClockGen, systemResetGen) import qualified Clash.Explicit.Signal as S import Clash.Hidden import Clash.Promoted.Nat (SNat (..), snatToNum) -import Clash.Promoted.Symbol (SSymbol (..)) -import Clash.Signal.Bundle (Bundle (..)) +import Clash.Signal.Bundle + (Bundle (..), EmptyTuple(..), TaggedEmptyTuple(..)) import Clash.Signal.BiSignal --(BisignalIn, BisignalOut, ) import Clash.Signal.Internal hiding (sample, sample_lazy, sampleN, sampleN_lazy, simulate, simulate_lazy, testFor) import Clash.Signal.Internal.Ambiguous (knownVDomain, clockPeriod, activeEdge, resetKind, initBehavior, resetPolarity) -import qualified Clash.Signal.Internal as S import Clash.XException (NFDataX) {- $setup diff --git a/src/Clash/Signal/BiSignal.hs b/src/Clash/Signal/BiSignal.hs --- a/src/Clash/Signal/BiSignal.hs +++ b/src/Clash/Signal/BiSignal.hs @@ -83,19 +83,15 @@ @ -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif @@ -116,14 +112,15 @@ import Data.Kind (Type) import Data.List (intercalate) -import Data.Maybe (fromMaybe,fromJust,isJust) +import Data.Maybe (fromMaybe,isJust) +import Clash.Class.HasDomain import Clash.Class.BitPack (BitPack (..)) import Clash.Sized.BitVector (BitVector) import qualified Clash.Sized.Vector as V import Clash.Sized.Vector (Vec) import Clash.Signal.Internal (Signal(..), Domain, head#, tail#) -import Clash.XException (errorX) +import Clash.XException (errorX, fromJustX) import GHC.TypeLits (KnownNat, Nat) import GHC.Stack (HasCallStack) @@ -167,6 +164,9 @@ newtype BiSignalOut (ds :: BiSignalDefault) (dom :: Domain) (n :: Nat) = BiSignalOut [Signal dom (Maybe (BitVector n))] +type instance HasDomain dom1 (BiSignalOut ds dom2 n) = DomEq dom1 dom2 +type instance TryDomain t (BiSignalOut ds dom n) = 'Found dom + #if MIN_VERSION_base(4,11,0) instance Semigroup (BiSignalOut defaultState dom n) where (BiSignalOut b1) <> (BiSignalOut b2) = BiSignalOut (b1 ++ b2) @@ -207,7 +207,6 @@ -- | Read the value from an __inout__ port readFromBiSignal :: ( HasCallStack - , KnownNat (BitSize a) , BitPack a) => BiSignalIn ds d (BitSize a) -- ^ A 'BiSignalIn' with a number of bits needed to represent /a/ @@ -250,7 +249,7 @@ input (fmap pack <$> writes) (isJust <$> writes) - (pack . fromJust <$> writes) + (pack . fromJustX <$> writes) {-# INLINE writeToBiSignal #-} -- | Converts the 'out' part of a BiSignal to an 'in' part. In simulation it diff --git a/src/Clash/Signal/Bundle.hs b/src/Clash/Signal/Bundle.hs --- a/src/Clash/Signal/Bundle.hs +++ b/src/Clash/Signal/Bundle.hs @@ -1,34 +1,39 @@ {-| Copyright : (C) 2013-2016, University of Twente, 2017-2019, Myrtle Software Ltd, Google Inc. + 2019, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij The Product/Signal isomorphism -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} + #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif {-# LANGUAGE Trustworthy #-} +--{-# OPTIONS_GHC -ddump-splices #-} {-# OPTIONS_HADDOCK show-extensions #-} module Clash.Signal.Bundle ( Bundle (..) + -- ** Tools to emulate pre Clash 1.0 @Bundle ()@ instance + , EmptyTuple(..) + , TaggedEmptyTuple(..) + -- ** Internal + , vecBundle# ) where +import Data.Functor.Compose +import GHC.Generics import GHC.TypeLits (KnownNat) import Prelude hiding (head, map, tail) @@ -67,11 +72,25 @@ -- data D = A | B -- -- instance Bundle D where --- type 'Unbundled'' clk D = 'Signal'' clk D --- 'bundle' _ s = s --- 'unbundle' _ s = s +-- type 'Unbundled' clk D = 'Signal' clk D +-- 'bundle' s = s +-- 'unbundle' s = s -- @ -- +-- For custom product types you'll have to write the instance manually: +-- @ +-- data Pair a b = MkPair { getA :: a, getB :: b } +-- +-- instance Bundle (Pair a b) where +-- type Unbundled dom (Pair a b) = Pair (Signal dom a) (Signal dom b) +-- +-- -- bundle :: Pair (Signal dom a) (Signal dom b) -> Signal dom (Pair a b) +-- bundle (MkPair as bs) = MkPair <$> as <*> bs +-- +-- -- unbundle :: Signal dom (Pair a b) -> Pair (Signal dom a) (Signal dom b) +-- unbundle pairs = MkPair (getA <$> pairs) (getB <$> pairs) +-- @ + class Bundle a where type Unbundled (dom :: Domain) a = res | res -> dom a type Unbundled dom a = Signal dom a @@ -143,3 +162,49 @@ type Unbundled t (RTree d a) = RTree d (Signal t a) bundle = sequenceA unbundle = sequenceA . fmap lazyT + +instance Bundle ((f :*: g) a) where + type Unbundled t ((f :*: g) a) = (Compose (Signal t) f :*: Compose (Signal t) g) a + bundle (Compose l :*: Compose r) = (:*:) <$> l <*> r + unbundle s = Compose (getL <$> s) :*: Compose (getR <$> s) + where + getL (l :*: _) = l + getR (_ :*: r) = r + +-- | See "TaggedEmptyTuple" +data EmptyTuple = EmptyTuple + +-- | Helper type to emulate the "old" behavior of Bundle's unit instance. I.e., +-- the instance for @Bundle ()@ used to be defined as: +-- +-- class Bundle () where +-- bundle :: () -> Signal domain () +-- unbundle :: Signal domain () -> () +-- +-- In order to have sensible type inference, the "Bundle" class specifies that +-- the argument type of 'bundle' should uniquely identify the result type, and +-- vice versa for 'unbundle'. The type signatures in the snippet above don't +-- though, as @()@ doesn't uniquely map to a specific domain. In other words, +-- 'domain' should occur in both the argument and result of both functions. +-- +-- "TaggedEmptyTuple" tackles this by carrying the domain in its type. The +-- 'bundle' and 'unbundle' instance now looks like: +-- +-- class Bundle EmptyTuple where +-- bundle :: TaggedEmptyTuple domain -> Signal domain EmptyTuple +-- unbundle :: Signal domain EmptyTuple -> TaggedEmptyTuple domain +-- +-- @domain@ is now mentioned both the argument and result for both 'bundle' and +-- 'unbundle'. +data TaggedEmptyTuple (dom :: Domain) = TaggedEmptyTuple + +-- | See https://github.com/clash-lang/clash-compiler/pull/539/commits/94b0bff5770aa4961e04ddce2515130df3fc7863 +-- and documentation for "TaggedEmptyTuple". +instance Bundle EmptyTuple where + type Unbundled dom EmptyTuple = TaggedEmptyTuple dom + + bundle :: TaggedEmptyTuple dom -> Signal dom EmptyTuple + bundle TaggedEmptyTuple = pure EmptyTuple + + unbundle :: Signal dom EmptyTuple -> TaggedEmptyTuple dom + unbundle s = seq s TaggedEmptyTuple diff --git a/src/Clash/Signal/Bundle/Internal.hs b/src/Clash/Signal/Bundle/Internal.hs --- a/src/Clash/Signal/Bundle/Internal.hs +++ b/src/Clash/Signal/Bundle/Internal.hs @@ -1,14 +1,28 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Clash.Signal.Bundle.Internal where -import Clash.CPP (maxTupleSize) -import Clash.Signal.Internal (Signal) -import Control.Monad (replicateM) -import Data.List (foldl') +import Control.Monad (liftM) +import Clash.Annotations.Primitive (Primitive(InlinePrimitive)) +import Clash.CPP (maxTupleSize) +import Clash.Signal.Internal (Signal((:-))) +import Clash.XException (seqX) +import Data.List (foldl') +import qualified Language.Haskell.TH.Syntax as TH import Language.Haskell.TH +idPrimitive :: TH.Name -> DecQ +idPrimitive nm = + PragmaD . AnnP (ValueAnnotation nm) <$> TH.liftData ip + where + ipJson = "[{\"Primitive\": {\"name\": \"" ++ show nm ++ "\", \"primType\": \"Function\"}}]" + ip = InlinePrimitive [minBound..maxBound] ipJson + +-- | Monadic version of concatMap +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat (mapM f xs) + -- | Contruct all the tuple instances for Bundle. deriveBundleTuples :: Name @@ -24,69 +38,130 @@ let bundleTy = ConT bundleTyName signal = ConT ''Signal - allNames <- replicateM maxTupleSize (newName "a") - tempNames <- replicateM maxTupleSize (newName "b") - t <- newName "t" - x <- newName "x" - tup <- newName "tup" + aNamesAll = map (\i -> mkName ('a':show i)) [1..maxTupleSize::Int] + aPrimeNamesAll = map (\i -> mkName ('a':show i++"'")) [1..maxTupleSize::Int] + asNamesAll = map (\i -> mkName ("as" <> show i)) [1..maxTupleSize::Int] + tNm = mkName "t" + sTailNm = mkName "sTail" + sNm = mkName "s" - pure $ flip map [2..maxTupleSize] $ \tupleNum -> - let names = take tupleNum allNames - temps = take tupleNum tempNames - vars = fmap VarT names - tuple = foldl' AppT (TupleT tupleNum) + flip concatMapM [2..maxTupleSize] $ \tupleNum -> + let aNames = take tupleNum aNamesAll + aPrimeNames = take tupleNum aPrimeNamesAll + asNames = take tupleNum asNamesAll + vars = fmap VarT aNames + bundlePrimName = mkName ("bundle" ++ show tupleNum ++ "#") + unbundlePrimName = mkName ("unbundle" ++ show tupleNum ++ "#") + qualBundleNm = mkName ("Clash.Signal.Bundle.bundle" ++ show tupleNum ++ "#") + qualUnbundlePrimName = mkName ("Clash.Signal.Bundle.unbundle" ++ show tupleNum ++ "#") + + mkTupleT = foldl' AppT (TupleT tupleNum) + -- Instance declaration - instTy = AppT bundleTy $ tuple vars + instTy = AppT bundleTy $ mkTupleT vars -- Associated type Unbundled #if MIN_VERSION_template_haskell(2,15,0) unbundledTypeEq = TySynEqn Nothing ((ConT unbundledTyName `AppT` - VarT t ) `AppT` tuple vars ) - $ tuple $ map (AppT (signal `AppT` VarT t)) vars + VarT tNm ) `AppT` mkTupleT vars ) + $ mkTupleT $ map (AppT (signal `AppT` VarT tNm)) vars unbundledType = TySynInstD unbundledTypeEq #else unbundledTypeEq = TySynEqn - [ VarT t, tuple vars ] - $ tuple $ map (AppT (signal `AppT` VarT t)) vars + [ VarT tNm, mkTupleT vars ] + $ mkTupleT $ map (AppT (signal `AppT` VarT tNm)) vars unbundledType = TySynInstD unbundledTyName unbundledTypeEq #endif - bundleLambda = LamE (map VarP temps) (TupE $ map VarE temps) - applicatives = VarE '(<$>) : repeat (VarE '(<*>)) - bundle = + mkFunD nm alias = FunD nm [Clause [] (NormalB (VarE alias)) []] + bundleD = mkFunD bundleName bundlePrimName + unbundleD = mkFunD unbundleName unbundlePrimName + + sigType t = ConT ''Signal `AppT` VarT (mkName "dom") `AppT` t + + -- unbundle3# ~s@((a, b, c) :- abcs) = + -- let (as, bs, cs) = s `seq` unbundle3# abcs in + -- (a :- as, b :- bs, c :- cs) + unbundleNoInlineAnn = PragmaD (InlineP unbundlePrimName NoInline FunLike AllPhases) + + unbundleSig = SigD unbundlePrimName ( + mkFunTys + [mkTupleT (map sigType (map VarT aNames))] + (sigType (mkTupleT (map VarT aNames))) + ) + + seqE nm res = UInfixE (VarE nm) (VarE 'seq) res + seqXE nm res = UInfixE (VarE nm) (VarE 'seqX) res + + unbundleFBody = + LetE + [ ValD + (TupP (map VarP asNames)) + (NormalB ( + tNm `seqXE` (sNm `seqE` (VarE unbundlePrimName `AppE` VarE sTailNm)))) []] + (TupE + (zipWith + (\a as -> UInfixE (VarE a) (ConE '(:-)) (VarE as)) + aNames + asNames)) + + unbundleF = FunD - bundleName - [ Clause - [ TupP $ map VarP names ] - ( NormalB - $ foldl' - (\f (a, b) -> a `AppE` f `AppE` b) - bundleLambda - (zip applicatives $ map VarE names) - ) - [] - ] + unbundlePrimName + [Clause + [AsP sNm (TildeP (UInfixP + (AsP tNm (TildeP (TupP (map VarP aNames)))) + '(:-) + (VarP sTailNm)))] + (NormalB unbundleFBody) + [] ] - unbundleLambda n = - LamE - [ TupP [ if i == n then VarP x else WildP | i <- [0..tupleNum-1] ] ] - (VarE x) + -- bundle2# (a1, a2) = (\ a1' a2' -> (a1', a2')) <$> a1 <*> a2 + bundleNoInlineAnn = PragmaD (InlineP bundlePrimName NoInline FunLike AllPhases) - unbundle = + bundleSig = SigD bundlePrimName ( + mkFunTys + [sigType (mkTupleT (map VarT aNames))] + (mkTupleT (map sigType (map VarT aNames))) + ) + + bundleFmap = + UInfixE + (LamE (map VarP aPrimeNames) (TupE (map VarE aPrimeNames))) + (VarE '(<$>)) + (VarE (head aNames)) + + bundleFBody = + foldl' + (\e n -> UInfixE e (VarE '(<*>)) (VarE n)) + bundleFmap + (tail aNames) + + bundleF = FunD - unbundleName - [ Clause - [ VarP tup ] - ( NormalB . TupE $ - map - (\n -> VarE 'fmap `AppE` unbundleLambda n `AppE` VarE tup) - [0..tupleNum-1] - ) - [] - ] + bundlePrimName + [Clause + [TupP (map VarP aNames)] + (NormalB bundleFBody) + [] ] + in do + unbundlePrimAnn <- idPrimitive qualUnbundlePrimName + bundlePrimAnn <- idPrimitive qualBundleNm + pure [ -- Instance and its methods + InstanceD Nothing [] instTy [unbundledType, bundleD, unbundleD] - in InstanceD Nothing [] instTy [unbundledType, bundle, unbundle] + -- Bundle primitive + , bundleSig, bundleF, bundlePrimAnn, bundleNoInlineAnn + + -- Unbundle primitive + , unbundleSig, unbundleF, unbundlePrimAnn, unbundleNoInlineAnn + ] + +mkFunTys :: Foldable t => t Type -> Type -> Type +mkFunTys args res= foldl' go res args + where + go l r = AppT (AppT ArrowT l) r diff --git a/src/Clash/Signal/Delayed.hs b/src/Clash/Signal/Delayed.hs --- a/src/Clash/Signal/Delayed.hs +++ b/src/Clash/Signal/Delayed.hs @@ -6,25 +6,18 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE NoStarIsType #-} -#endif + #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Safe #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} module Clash.Signal.Delayed ( -- * Delay-annotated synchronous signals @@ -48,23 +41,19 @@ ) where -import Data.Coerce (coerce) -import Data.Kind (Type) -import Data.Proxy (Proxy(..)) import GHC.TypeLits - (KnownNat, type (^), type (+), type (*), Nat) -import Data.Singletons.Prelude (Apply, TyFun, type (@@)) + (KnownNat, type (^), type (+), type (*)) -import Clash.Signal.Internal (Domain) import Clash.Signal.Delayed.Internal (DSignal(..), dfromList, dfromList_lazy, fromSignal, toSignal, unsafeFromSignal, antiDelay, feedback) import qualified Clash.Explicit.Signal.Delayed as E -import Clash.Sized.Vector (Vec, dtfold) +import Clash.Sized.Vector (Vec) import Clash.Signal - (HiddenClockResetEnable , hideClockResetEnable, Signal, delay) + (HiddenClock, HiddenClockResetEnable, HiddenEnable, hideClock, + hideClockResetEnable, hideEnable) -import Clash.Promoted.Nat (SNat (..), snatToInteger) +import Clash.Promoted.Nat (SNat (..)) import Clash.XException (NFDataX) {- $setup @@ -135,29 +124,27 @@ -- | Delay a 'DSignal' for @d@ cycles, the value at time 0..d-1 is /a/. -- -- @ --- delay2 +-- delayN2 -- :: HiddenClockResetEnable dom -- => Int -- -> 'DSignal' dom n Int -- -> 'DSignal' dom (n + 2) Int --- delay2 = 'delayN' d2 +-- delayN2 = 'delayN' d2 -- @ -- -- >>> printX $ sampleN @System 6 (toSignal (delayN2 (-1) (dfromList [1..]))) -- [-1,-1,1,2,3,4] delayN :: forall dom a d n - . ( HiddenClockResetEnable dom + . ( HiddenClock dom + , HiddenEnable dom , NFDataX a ) => SNat d -> a -- ^ Initial value -> DSignal dom n a -> DSignal dom (n+d) a -delayN d dflt = coerce . go (snatToInteger d) . coerce @_ @(Signal dom a) - where - go 0 = id - go i = delay dflt . go (i-1) +delayN d dflt = hideClock (hideEnable (E.delayN d dflt)) -- | Delay a 'DSignal' for @d@ cycles, where @d@ is derived from the context. -- The value at time 0..d-1 is a default value. @@ -188,9 +175,6 @@ -> DSignal dom (n+d) a delayI dflt = delayN (SNat :: SNat d) dflt -data DelayedFold (dom :: Domain) (n :: Nat) (delay :: Nat) (a :: Type) (f :: TyFun Nat Type) :: Type -type instance Apply (DelayedFold dom n delay a) k = DSignal dom (n + (delay*k)) a - -- | Tree fold over a 'Vec' of 'DSignal's with a combinatorial function, -- and delaying @delay@ cycles after each application. -- Values at times 0..(delay*k)-1 are set to a default. @@ -207,7 +191,8 @@ -- [-1,-1,1,1,0,1,16,81] delayedFold :: forall dom n delay k a - . ( HiddenClockResetEnable dom + . ( HiddenClock dom + , HiddenEnable dom , NFDataX a , KnownNat delay , KnownNat k ) @@ -221,10 +206,4 @@ -- ^ Vector input of size 2^k -> DSignal dom (n + (delay * k)) a -- ^ Output Signal delayed by (delay * k) -delayedFold _ dflt op = dtfold (Proxy :: Proxy (DelayedFold dom n delay a)) id go - where - go :: SNat l - -> DelayedFold dom n delay a @@ l - -> DelayedFold dom n delay a @@ l - -> DelayedFold dom n delay a @@ (l+1) - go SNat x y = delayI dflt (op <$> x <*> y) +delayedFold d dflt f = hideClock (hideEnable (E.delayedFold d dflt f)) diff --git a/src/Clash/Signal/Delayed/Bundle.hs b/src/Clash/Signal/Delayed/Bundle.hs --- a/src/Clash/Signal/Delayed/Bundle.hs +++ b/src/Clash/Signal/Delayed/Bundle.hs @@ -5,25 +5,22 @@ License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} + #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif module Clash.Signal.Delayed.Bundle ( - Bundle, - Unbundled, - bundle, - unbundle, + Bundle(..) + -- ** Tools to emulate pre Clash 1.0 @Bundle ()@ instance + , B.EmptyTuple(..) + , TaggedEmptyTuple(..) ) where import Control.Applicative (liftA2) @@ -69,9 +66,9 @@ -- data D = A | B -- -- instance Bundle D where --- type 'Unbundled' dom delay D = 'DSignal' dom d D --- 'bundle' _ s = s --- 'unbundle' _ s = s +-- type 'Unbundled' dom delay D = 'DSignal' dom delay D +-- 'bundle' s = s +-- 'unbundle' s = s -- @ -- class Bundle a where @@ -222,3 +219,17 @@ type Unbundled t delay (RTree d a) = RTree d (DSignal t delay a) bundle = sequenceA unbundle = sequenceA . fmap lazyT + +-- | Same as "Clash.Signal.Bundle.TaggedEmptyTuple", but adapted for "DSignal". +data TaggedEmptyTuple (dom :: Domain) (d :: Nat) = TaggedEmptyTuple + +-- | See https://github.com/clash-lang/clash-compiler/pull/539/commits/94b0bff5770aa4961e04ddce2515130df3fc7863 +-- and documentation for "TaggedEmptyTuple". +instance Bundle B.EmptyTuple where + type Unbundled dom d B.EmptyTuple = TaggedEmptyTuple dom d + + bundle :: TaggedEmptyTuple dom d -> DSignal dom d B.EmptyTuple + bundle TaggedEmptyTuple = pure B.EmptyTuple + + unbundle :: DSignal dom d B.EmptyTuple -> TaggedEmptyTuple dom d + unbundle s = seq s TaggedEmptyTuple diff --git a/src/Clash/Signal/Delayed/Internal.hs b/src/Clash/Signal/Delayed/Internal.hs --- a/src/Clash/Signal/Delayed/Internal.hs +++ b/src/Clash/Signal/Delayed/Internal.hs @@ -5,17 +5,12 @@ License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif @@ -47,9 +42,7 @@ import Test.QuickCheck (Arbitrary, CoArbitrary) import Clash.Promoted.Nat (SNat) -import Clash.Signal.Internal (Domain) -import Clash.Explicit.Signal - (Signal, fromList, fromList_lazy) +import Clash.Signal.Internal (Signal, Domain, fromList, fromList_lazy) import Clash.XException (NFDataX) {- $setup diff --git a/src/Clash/Signal/Internal.hs b/src/Clash/Signal/Internal.hs --- a/src/Clash/Signal/Internal.hs +++ b/src/Clash/Signal/Internal.hs @@ -6,26 +6,16 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE NoStarIsType #-} -#endif +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + #if __GLASGOW_HASKELL__ < 806 {-# LANGUAGE TypeInType #-} #endif @@ -161,10 +151,11 @@ import Test.QuickCheck (Arbitrary (..), CoArbitrary(..), Property, property) +import Clash.CPP (fStrictMapSignal) import Clash.Promoted.Nat (SNat (..), snatToNum, snatToNatural) import Clash.Promoted.Symbol (SSymbol (..), ssymbolToString) import Clash.XException - (NFDataX, errorX, deepseqX, defaultSeqX, deepErrorX) + (NFDataX, errorX, deepseqX, defaultSeqX, deepErrorX, seqX) {- $setup >>> :set -XDataKinds @@ -371,17 +362,7 @@ -- Whether resets are active high or active low ^ -> SDomainConfiguration dom ('DomainConfiguration dom period edge reset init polarity) -instance Show (SDomainConfiguration dom conf) where - show (SDomainConfiguration dom period edge reset init_ polarity) = - unwords - [ "SDomainConfiguration" - , show dom - , show period - , show edge - , show reset - , show init_ - , show polarity - ] +deriving instance Show (SDomainConfiguration dom conf) type KnownConfiguration dom conf = (KnownDomain dom, KnownConf dom ~ conf) @@ -399,7 +380,7 @@ -- | Version of 'knownDomain' that takes a 'SSymbol'. For example: -- -- >>> knownDomainByName (SSymbol @"System") --- SDomainConfiguration System d10000 SRising SAsynchronous SDefined SActiveHigh +-- SDomainConfiguration (SSymbol @"System") (SNat @10000) SRising SAsynchronous SDefined SActiveHigh knownDomainByName :: forall dom . KnownDomain dom @@ -669,8 +650,12 @@ instance Functor (Signal dom) where fmap = mapSignal# -mapSignal# :: (a -> b) -> Signal dom a -> Signal dom b -mapSignal# f (a :- as) = f a :- mapSignal# f as +mapSignal# :: forall a b dom. (a -> b) -> Signal dom a -> Signal dom b +mapSignal# f = go + where + -- See -fstrict-mapSignal documentation in clash-prelude.cabal + theSeq = if fStrictMapSignal then seqX else flip const + go (a :- as) = f a :- (a `theSeq` go as) {-# NOINLINE mapSignal# #-} {-# ANN mapSignal# hasBlackBox #-} @@ -695,7 +680,7 @@ > appSignal (f :- fs) ~(a :- as) = f a :- appSignal fs as because some feedback loops, such as the loop described in 'system' in the -example at http://hackage.haskell.org/package/clash-prelude-0.10.10/docs/Clash-Prelude-BlockRam.html, +example at https://hackage.haskell.org/package/clash-prelude-1.0.0/docs/Clash-Prelude-BlockRam.html, will lead to "Exception <>". However, this "naive" lazy version is _too_ lazy and induces spaceleaks. @@ -784,7 +769,7 @@ data Clock (dom :: Domain) = Clock (SSymbol dom) instance Show (Clock dom) where - show (Clock dom) = "" + show (Clock dom) = "" -- | Extract dom symbol from Clock clockTag diff --git a/src/Clash/Signal/Internal/Ambiguous.hs b/src/Clash/Signal/Internal/Ambiguous.hs --- a/src/Clash/Signal/Internal/Ambiguous.hs +++ b/src/Clash/Signal/Internal/Ambiguous.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} module Clash.Signal.Internal.Ambiguous ( knownVDomain diff --git a/src/Clash/Signal/Trace.hs b/src/Clash/Signal/Trace.hs --- a/src/Clash/Signal/Trace.hs +++ b/src/Clash/Signal/Trace.hs @@ -44,17 +44,10 @@ writeFile "mainCounter.vcd" contents @ -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} @@ -147,7 +140,6 @@ mkTrace :: HasCallStack - => KnownNat (BitSize a) => BitPack a => NFDataX a => Signal dom a @@ -160,8 +152,7 @@ -- was previously registered. traceSignal# :: forall dom a - . ( KnownNat (BitSize a) - , BitPack a + . ( BitPack a , NFDataX a , Typeable a ) => IORef TraceMap @@ -195,8 +186,7 @@ -- an error. traceVecSignal# :: forall dom n a - . ( KnownNat (BitSize a) - , KnownNat n + . ( KnownNat n , BitPack a , NFDataX a , Typeable a ) @@ -226,7 +216,6 @@ traceSignal :: forall dom a . ( KnownDomain dom - , KnownNat (BitSize a) , BitPack a , NFDataX a , Typeable a ) @@ -250,8 +239,7 @@ -- multiple clocks. Use 'traceSignal' when working with circuits that have -- multiple clocks. traceSignal1 - :: ( KnownNat (BitSize a) - , BitPack a + :: ( BitPack a , NFDataX a , Typeable a ) => String @@ -273,7 +261,6 @@ traceVecSignal :: forall dom a n . ( KnownDomain dom - , KnownNat (BitSize a) , KnownNat n , BitPack a , NFDataX a @@ -299,8 +286,7 @@ -- multiple clocks. Use 'traceSignal' when working with circuits that have -- multiple clocks. traceVecSignal1 - :: ( KnownNat (BitSize a) - , KnownNat n + :: ( KnownNat n , BitPack a , NFDataX a , Typeable a ) @@ -421,7 +407,7 @@ format 1 label (0,1) = ['1', label, '\n'] format 1 label (1,_) = ['x', label, '\n'] format 1 label (mask,val) = - error $ "Can't format 1 bit wide value for " ++ show label ++ ": value " ++ show val ++ " and mask " ++ show mask + error $ "Can't format 1 bit wide value for " ++ show label ++ ": value " ++ show val ++ " and mask " ++ show mask format n label (mask,val) = "b" ++ map digit (reverse [0..n-1]) ++ " " ++ [label] where diff --git a/src/Clash/Sized/BitVector.hs b/src/Clash/Sized/BitVector.hs --- a/src/Clash/Sized/BitVector.hs +++ b/src/Clash/Sized/BitVector.hs @@ -4,8 +4,6 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE MagicHash #-} - {-# LANGUAGE Trustworthy #-} {-# OPTIONS_HADDOCK show-extensions #-} diff --git a/src/Clash/Sized/Fixed.hs b/src/Clash/Sized/Fixed.hs --- a/src/Clash/Sized/Fixed.hs +++ b/src/Clash/Sized/Fixed.hs @@ -10,35 +10,72 @@ * 'Fixed' has an instance for 'Fractional' meaning you use fractional literals @(3.75 :: 'SFixed' 4 18)@. * Both integer literals and fractional literals are clipped to 'minBound' and - 'maxBound'. + 'maxBound'. __NB__ Needs the `-XNegativeLiterals` language extension to work + for signed numbers. * There is no 'Floating' instance for 'Fixed', but you can use @$$('fLit' d)@ to create 'Fixed' point literal from 'Double' constant at compile-time. * Use <#constraintsynonyms Constraint synonyms> when writing type signatures for polymorphic functions that use 'Fixed' point numbers. +BEWARE: rounding by truncation can introduce errors larger than naively assumed; +e.g. for /Fixed 16 1/, rounding by truncation turns the real number 4.99 to 4.5, +not 5.0, i.e. an error or 0.49 instead of 0.01 + BEWARE: rounding by truncation introduces a sign bias! * Truncation for positive numbers effectively results in: round towards zero. * Truncation for negative numbers effectively results in: round towards -infinity. + +== Reasoning about precision +Givens the real numbers /A/ and /B/, and the corresponding fixed point numbers +/FA+-da/ and /FB+db/, where /da/ and /db/ denote the (potential) error introduced +by truncation w.r.t. the original /A/ and /B/, the arithmetic operators on fixed +point numbers have the following error propagation properties: + +* Addition: /da + db/ +* Subtraction: /da - db/ +* Multiplication: /FA*db + FB*da + da*db/ +* Division: /(FA+da)\/(FB+db) - FA\/FB/ + +=== Additional error from truncation + +Given: + +>>> 4.13 :: UFixed 16 3 +4.125 +>>> 20.9 :: UFixed 16 3 +20.875 + +The expected error that we would get from multiplication is: +/20.875*0.005 + 4.125*0.025 + 0.025*0.005 = 0.207625/ + +>>> 4.13 * 20.9 :: Double +86.317 +>>> (4.13 :: UFixed 16 3) `mul` (20.9 :: UFixed 16 3) :: UFixed 32 6 +86.109375 +>>> 86.109375 + 0.207625 :: Double +86.317 + +However the /0.109375/ is smaller than /2^-3/, so the regular multiplication +operator that uses truncation introduces an additional error of /0.109375/: + +>>> (4.13 :: UFixed 16 3) * (20.9 :: UFixed 16 3) :: UFixed 16 3 +86.0 + -} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} @@ -75,9 +112,9 @@ import Data.Data (Data) import Data.Default.Class (Default (..)) import Data.Either (isLeft) +import Data.Kind (Type) import Text.Read (Read(..)) import Data.List (find) -import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) import Data.Ratio ((%), denominator, numerator) import Data.Typeable (Typeable, TypeRep, typeRep) @@ -100,7 +137,7 @@ import Clash.Sized.Signed (Signed) import Clash.Sized.Unsigned (Unsigned) import Clash.XException - (ShowX (..), NFDataX (..), isX, errorX, showsPrecXWith) + (ShowX (..), NFDataX (..), isX, errorX, showsPrecXWith, fromJustX) {- $setup >>> :set -XDataKinds @@ -121,7 +158,7 @@ -- -- The 'Num' operators for this type saturate to 'maxBound' on overflow and -- 'minBound' on underflow, and use truncation as the rounding method. -newtype Fixed (rep :: Nat -> *) (int :: Nat) (frac :: Nat) = +newtype Fixed (rep :: Nat -> Type) (int :: Nat) (frac :: Nat) = Fixed { unFixed :: rep (int + frac) } deriving instance NFData (rep (int + frac)) => NFData (Fixed rep int frac) @@ -258,7 +295,7 @@ ) => Show (Fixed rep int frac) where show f@(Fixed fRep) = i ++ "." ++ (uncurry pad . second (show . numerator) . - fromJust . find ((==1) . denominator . snd) . + fromJustX . find ((==1) . denominator . snd) . iterate (succ *** (*10)) . (,) 0 $ (nom % denom)) where pad n str = replicate (n - length str) '0' ++ str @@ -279,6 +316,8 @@ instance NFDataX (rep (int + frac)) => NFDataX (Fixed rep int frac) where deepErrorX = Fixed . errorX rnfX f@(~(Fixed x)) = if isLeft (isX f) then () else rnfX x + hasUndefined f@(~(Fixed x)) = if isLeft (isX f) then True else hasUndefined x + ensureSpine ~(Fixed x) = Fixed x -- | None of the 'Read' class' methods are synthesizable. instance (size ~ (int + frac), KnownNat frac, Bounded (rep size), Integral (rep size)) @@ -435,11 +474,11 @@ (int + ((int + frac) + frac)) , BitPack (rep ((int + int) + (frac + frac))) , Bits (rep ((int + int) + (frac + frac))) - , KnownNat (BitSize (rep (int + frac))) , BitPack (rep (int + frac)) , Enum (rep (int + frac)) , Bits (rep (int + frac)) , Ord (rep (int + frac)) + , Integral (rep (int + frac)) , Resize rep , KnownNat int , KnownNat frac @@ -473,15 +512,20 @@ (+) = boundedAdd (*) = boundedMul (-) = boundedSub - negate (Fixed a) = Fixed (negate a) + negate = boundedSub (Fixed 0) abs (Fixed a) = Fixed (abs a) signum (Fixed a) | a == 0 = 0 | a < 0 = -1 | otherwise = 1 fromInteger i = let fSH = fromInteger (natVal (Proxy @frac)) - res = Fixed (fromInteger i `shiftL` fSH) - in res + res = i `shiftL` fSH + rMax = toInteger (maxBound :: rep (int + frac)) + rMin = toInteger (minBound :: rep (int + frac)) + sat | res > rMax = rMax + | res < rMin = rMin + | otherwise = res + in Fixed (fromInteger sat) instance (BitPack (rep (int + frac))) => BitPack (Fixed rep int frac) where type BitSize (Fixed rep int frac) = BitSize (rep (int + frac)) diff --git a/src/Clash/Sized/Index.hs b/src/Clash/Sized/Index.hs --- a/src/Clash/Sized/Index.hs +++ b/src/Clash/Sized/Index.hs @@ -4,10 +4,6 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeOperators #-} - {-# LANGUAGE Trustworthy #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver -fplugin GHC.TypeLits.KnownNat.Solver #-} @@ -16,7 +12,7 @@ {-# OPTIONS_HADDOCK show-extensions #-} module Clash.Sized.Index - (Index, bv2i) + (Index, bv2i, fromSNat) where import GHC.TypeLits (KnownNat, type (^)) diff --git a/src/Clash/Sized/Internal/BitVector.hs b/src/Clash/Sized/Internal/BitVector.hs --- a/src/Clash/Sized/Internal/BitVector.hs +++ b/src/Clash/Sized/Internal/BitVector.hs @@ -6,20 +6,11 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} @@ -135,6 +126,7 @@ import Data.Bits (Bits (..), FiniteBits (..)) import Data.Data (Data) import Data.Default.Class (Default (..)) +import Data.Either (isLeft) import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable, typeOf) import GHC.Generics (Generic) @@ -156,7 +148,7 @@ import Clash.Promoted.Nat (SNat (..), SNatLE (..), compareSNat, snatToInteger, snatToNum) import Clash.XException - (ShowX (..), NFDataX (..), errorX, showsPrecXWith, rwhnfX) + (ShowX (..), NFDataX (..), errorX, isX, showsPrecXWith, rwhnfX) import {-# SOURCE #-} qualified Clash.Sized.Vector as V import {-# SOURCE #-} qualified Clash.Sized.Internal.Index as I @@ -222,6 +214,7 @@ instance NFDataX Bit where deepErrorX = errorX rnfX = rwhnfX + hasUndefined bv = isLeft (isX bv) || unsafeMask# bv /= 0 instance Lift Bit where lift (Bit m i) = [| fromInteger## m i |] @@ -368,6 +361,7 @@ instance NFDataX (BitVector n) where deepErrorX = errorX rnfX = rwhnfX + hasUndefined bv = isLeft (isX bv) || unsafeMask bv /= 0 -- | Create a binary literal -- @@ -465,16 +459,16 @@ {-# NOINLINE enumFromThen# #-} {-# NOINLINE enumFromTo# #-} {-# NOINLINE enumFromThenTo# #-} -enumFrom# :: KnownNat n => BitVector n -> [BitVector n] -enumFromThen# :: KnownNat n => BitVector n -> BitVector n -> [BitVector n] +enumFrom# :: forall n. KnownNat n => BitVector n -> [BitVector n] +enumFromThen# :: forall n. KnownNat n => BitVector n -> BitVector n -> [BitVector n] enumFromTo# :: KnownNat n => BitVector n -> BitVector n -> [BitVector n] enumFromThenTo# :: KnownNat n => BitVector n -> BitVector n -> BitVector n -> [BitVector n] -enumFrom# (BV 0 x) = map (fromInteger_INLINE 0) [x ..] +enumFrom# (BV 0 x) = map (fromInteger_INLINE 0) [x .. unsafeToInteger (maxBound :: BitVector n)] enumFrom# bv = undefErrorU "enumFrom" bv -enumFromThen# (BV 0 x) (BV 0 y) = map (fromInteger_INLINE 0) [x, y ..] +enumFromThen# (BV 0 x) (BV 0 y) = map (fromInteger_INLINE 0) [x, y .. unsafeToInteger (maxBound :: BitVector n)] enumFromThen# bv1 bv2 = undefErrorP "enumFromThen" bv1 bv2 diff --git a/src/Clash/Sized/Internal/BitVector.hs-boot b/src/Clash/Sized/Internal/BitVector.hs-boot --- a/src/Clash/Sized/Internal/BitVector.hs-boot +++ b/src/Clash/Sized/Internal/BitVector.hs-boot @@ -4,16 +4,17 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RoleAnnotations #-} module Clash.Sized.Internal.BitVector where import GHC.TypeLits (KnownNat,Nat) import GHC.Stack (HasCallStack) +import Data.Kind (Type) type role BitVector phantom -data BitVector :: Nat -> * +data BitVector :: Nat -> Type data Bit undefError :: (HasCallStack, KnownNat n) => String -> [BitVector n] -> a diff --git a/src/Clash/Sized/Internal/Index.hs b/src/Clash/Sized/Internal/Index.hs --- a/src/Clash/Sized/Internal/Index.hs +++ b/src/Clash/Sized/Internal/Index.hs @@ -5,25 +5,13 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE NoStarIsType #-} -#endif +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} @@ -77,6 +65,8 @@ ) where +import Prelude hiding (even, odd) + import Control.DeepSeq (NFData (..)) import Data.Bits (Bits (..), FiniteBits (..)) import Data.Data (Data) @@ -88,7 +78,7 @@ import Numeric.Natural (Natural) import GHC.Generics (Generic) import GHC.Stack (HasCallStack) -import GHC.TypeLits (CmpNat, KnownNat, Nat, type (+), type (-), +import GHC.TypeLits (KnownNat, Nat, type (+), type (-), type (*), type (<=), natVal) import GHC.TypeLits.Extra (CLog) import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..), @@ -98,6 +88,7 @@ import Clash.Class.BitPack (BitPack (..), packXWith) import Clash.Class.Num (ExtendingNum (..), SaturatingNum (..), SaturationMode (..)) +import Clash.Class.Parity (Parity (..)) import Clash.Class.Resize (Resize (..)) import Clash.Prelude.BitIndex (replaceBit) import {-# SOURCE #-} Clash.Sized.Internal.BitVector (BitVector (BV), high, low, undefError) @@ -151,7 +142,7 @@ unpack = unpack# -- | Safely convert an `SNat` value to an `Index` -fromSNat :: (KnownNat m, CmpNat n m ~ 'LT) => SNat n -> Index m +fromSNat :: (KnownNat m, n <= m + 1) => SNat n -> Index m fromSNat = snatToNum {-# NOINLINE pack# #-} @@ -207,12 +198,12 @@ {-# NOINLINE enumFromThen# #-} {-# NOINLINE enumFromTo# #-} {-# NOINLINE enumFromThenTo# #-} -enumFrom# :: KnownNat n => Index n -> [Index n] -enumFromThen# :: KnownNat n => Index n -> Index n -> [Index n] +enumFrom# :: forall n. KnownNat n => Index n -> [Index n] +enumFromThen# :: forall n. KnownNat n => Index n -> Index n -> [Index n] enumFromTo# :: Index n -> Index n -> [Index n] enumFromThenTo# :: Index n -> Index n -> Index n -> [Index n] -enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..] -enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] +enumFrom# x = map fromInteger_INLINE [unsafeToInteger x .. unsafeToInteger (maxBound :: Index n)] +enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y .. unsafeToInteger (maxBound :: Index n)] enumFromTo# x y = map I [unsafeToInteger x .. unsafeToInteger y] enumFromThenTo# x1 x2 y = map I [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] @@ -280,7 +271,7 @@ instance (KnownNat n, 1 <= n) => SaturatingNum (Index n) where satAdd SatWrap !a !b = - case snatToNum @Int (SNat @n) of + case snatToNum @Integer (SNat @n) of 1 -> fromInteger# 0 _ -> leToPlusKN @1 @n $ case plus# a b of @@ -311,7 +302,7 @@ else a -# b satMul SatWrap !a !b = - case snatToNum @Int (SNat @n) of + case snatToNum @Integer (SNat @n) of 1 -> fromInteger# 0 _ -> leToPlusKN @1 @n $ case times# a b of @@ -351,6 +342,10 @@ {-# NOINLINE toInteger# #-} toInteger# :: Index n -> Integer toInteger# (I n) = n + +instance (KnownNat n, 1 <= n) => Parity (Index n) where + even = even . pack + odd = odd . pack instance (KnownNat n, 1 <= n) => Bits (Index n) where a .&. b = unpack# $ BV.and# (pack# a) (pack# b) diff --git a/src/Clash/Sized/Internal/Index.hs-boot b/src/Clash/Sized/Internal/Index.hs-boot --- a/src/Clash/Sized/Internal/Index.hs-boot +++ b/src/Clash/Sized/Internal/Index.hs-boot @@ -4,16 +4,17 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE RoleAnnotations #-} module Clash.Sized.Internal.Index where +import Data.Kind (Type) import GHC.TypeLits (KnownNat, Nat) type role Index phantom -data Index :: Nat -> * +data Index :: Nat -> Type instance KnownNat n => Num (Index n) toInteger# :: Index n -> Integer diff --git a/src/Clash/Sized/Internal/Signed.hs b/src/Clash/Sized/Internal/Signed.hs --- a/src/Clash/Sized/Internal/Signed.hs +++ b/src/Clash/Sized/Internal/Signed.hs @@ -5,19 +5,11 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} @@ -85,6 +77,8 @@ ) where +import Prelude hiding (odd, even) + import Control.DeepSeq (NFData (..)) import Control.Lens (Index, Ixed (..), IxValue) import Data.Bits (Bits (..), FiniteBits (..)) @@ -104,6 +98,7 @@ import Clash.Class.BitPack (BitPack (..), packXWith) import Clash.Class.Num (ExtendingNum (..), SaturatingNum (..), SaturationMode (..)) +import Clash.Class.Parity (Parity (..)) import Clash.Class.Resize (Resize (..)) import Clash.Prelude.BitIndex ((!), msb, replaceBit, split) import Clash.Prelude.BitReduction (reduceAnd, reduceOr) @@ -239,12 +234,12 @@ {-# NOINLINE enumFromThen# #-} {-# NOINLINE enumFromTo# #-} {-# NOINLINE enumFromThenTo# #-} -enumFrom# :: KnownNat n => Signed n -> [Signed n] -enumFromThen# :: KnownNat n => Signed n -> Signed n -> [Signed n] +enumFrom# :: forall n. KnownNat n => Signed n -> [Signed n] +enumFromThen# :: forall n. KnownNat n => Signed n -> Signed n -> [Signed n] enumFromTo# :: Signed n -> Signed n -> [Signed n] enumFromThenTo# :: Signed n -> Signed n -> Signed n -> [Signed n] -enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..] -enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] +enumFrom# x = map fromInteger_INLINE [unsafeToInteger x .. unsafeToInteger (maxBound :: Signed n)] +enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y .. unsafeToInteger (maxBound :: Signed n)] enumFromTo# x y = map S [unsafeToInteger x .. unsafeToInteger y] enumFromThenTo# x1 x2 y = map S [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] @@ -355,6 +350,10 @@ {-# NOINLINE toInteger# #-} toInteger# :: Signed n -> Integer toInteger# (S n) = n + +instance KnownNat n => Parity (Signed n) where + even = even . pack + odd = odd . pack instance KnownNat n => Bits (Signed n) where (.&.) = and# diff --git a/src/Clash/Sized/Internal/Unsigned.hs b/src/Clash/Sized/Internal/Unsigned.hs --- a/src/Clash/Sized/Internal/Unsigned.hs +++ b/src/Clash/Sized/Internal/Unsigned.hs @@ -5,18 +5,11 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} @@ -77,6 +70,8 @@ ) where +import Prelude hiding (even, odd) + import Control.DeepSeq (NFData (..)) import Control.Lens (Index, Ixed (..), IxValue) import Data.Bits (Bits (..), FiniteBits (..)) @@ -97,6 +92,7 @@ import Clash.Class.BitPack (BitPack (..), packXWith) import Clash.Class.Num (ExtendingNum (..), SaturatingNum (..), SaturationMode (..)) +import Clash.Class.Parity (Parity (..)) import Clash.Class.Resize (Resize (..)) import Clash.Prelude.BitIndex ((!), msb, replaceBit, split) import Clash.Prelude.BitReduction (reduceOr) @@ -225,12 +221,12 @@ {-# NOINLINE enumFromThen# #-} {-# NOINLINE enumFromTo# #-} {-# NOINLINE enumFromThenTo# #-} -enumFrom# :: KnownNat n => Unsigned n -> [Unsigned n] -enumFromThen# :: KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n] +enumFrom# :: forall n. KnownNat n => Unsigned n -> [Unsigned n] +enumFromThen# :: forall n. KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n] enumFromTo# :: Unsigned n -> Unsigned n -> [Unsigned n] enumFromThenTo# :: Unsigned n -> Unsigned n -> Unsigned n -> [Unsigned n] -enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..] -enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] +enumFrom# x = map fromInteger_INLINE [unsafeToInteger x .. unsafeToInteger (maxBound :: Unsigned n)] +enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y .. unsafeToInteger (maxBound :: Unsigned n)] enumFromTo# x y = map U [unsafeToInteger x .. unsafeToInteger y] enumFromThenTo# x1 x2 y = map U [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] @@ -332,6 +328,10 @@ {-# NOINLINE toInteger# #-} toInteger# :: Unsigned n -> Integer toInteger# (U i) = i + +instance KnownNat n => Parity (Unsigned n) where + even = even . pack + odd = odd . pack instance KnownNat n => Bits (Unsigned n) where (.&.) = and# diff --git a/src/Clash/Sized/RTree.hs b/src/Clash/Sized/RTree.hs --- a/src/Clash/Sized/RTree.hs +++ b/src/Clash/Sized/RTree.hs @@ -4,24 +4,13 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE NoStarIsType #-} -#endif {-# LANGUAGE Trustworthy #-} @@ -92,7 +81,8 @@ >>> :set -fplugin GHC.TypeLits.Normalise >>> :set -XUndecidableInstances >>> import Clash.Prelude ->>> data IIndex (f :: TyFun Nat *) :: * +>>> import Data.Kind +>>> data IIndex (f :: TyFun Nat Type) :: Type >>> type instance Apply IIndex l = Index ((2^l)+1) >>> :{ let populationCount' :: (KnownNat k, KnownNat (2^k)) => BitVector (2^k) -> Index ((2^k)+1) @@ -201,7 +191,7 @@ (fmap LR . f) (const (liftA2 BR)) -instance (KnownNat d, KnownNat (BitSize a), BitPack a) => +instance (KnownNat d, BitPack a) => BitPack (RTree d a) where type BitSize (RTree d a) = (2^d) * (BitSize a) pack = packXWith (pack . t2v) @@ -235,7 +225,15 @@ go (LR_ x) = rnfX x go (BR_ l r) = rnfX l `seq` rnfX r + hasUndefined t = if isLeft (isX t) then True else go t + where + go :: RTree d a -> Bool + go (LR_ x) = hasUndefined x + go (BR_ l r) = hasUndefined l || hasUndefined r + ensureSpine = fmap ensureSpine . lazyT + + -- | A /dependently/ typed fold over trees. -- -- As an example of when you might want to use 'dtfold' we will build a @@ -464,17 +462,18 @@ tzipWith f = tdfold (Proxy @(ZipWithTree b c)) lr br where lr :: a -> RTree 0 b -> RTree 0 c - lr a (LR b) = LR (f a b) - lr _ _ = error "impossible" + lr a t = LR (f a (textract t)) br :: SNat l -> (RTree l b -> RTree l c) -> (RTree l b -> RTree l c) -> RTree (l+1) b -> RTree (l+1) c - br _ fl fr (BR l r) = BR (fl l) (fr r) - br _ _ _ _ = error "impossible" + br _ fl fr t = BR (fl l) (fr r) + where + (l,r) = tsplit t + -- | 'tzip' takes two trees and returns a tree of corresponding pairs. tzip :: KnownNat d => RTree d a -> RTree d b -> RTree d (a,b) tzip = tzipWith (,) @@ -498,4 +497,4 @@ lazyT :: KnownNat d => RTree d a -> RTree d a -lazyT = tzipWith (flip const) (trepeat undefined) +lazyT = tzipWith (flip const) (trepeat ()) diff --git a/src/Clash/Sized/Vector.hs b/src/Clash/Sized/Vector.hs --- a/src/Clash/Sized/Vector.hs +++ b/src/Clash/Sized/Vector.hs @@ -5,26 +5,14 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE NoStarIsType #-} -#endif {-# LANGUAGE Trustworthy #-} @@ -111,6 +99,7 @@ import Data.Constraint.Nat (leZero) import Data.Data (Data (..), Constr, DataType, Fixity (..), Typeable, mkConstr, mkDataType) +import Data.Either (isLeft) import Data.Default.Class (Default (..)) import qualified Data.Foldable as F import Data.Kind (Type) @@ -133,6 +122,8 @@ import Test.QuickCheck (Arbitrary (..), CoArbitrary (..)) import Unsafe.Coerce (unsafeCoerce) +import Clash.Annotations.Primitive + (Primitive(InlinePrimitive), HDL(..)) import Clash.Promoted.Nat (SNat (..), SNatLE (..), UNat (..), compareSNat, leToPlus, pow2SNat, snatProxy, snatToInteger, subSNat, withSNat, toUNat) @@ -142,7 +133,7 @@ import Clash.Class.BitPack (packXWith, BitPack (..)) import Clash.XException - (ShowX (..), NFDataX (..), showsX, showsPrecXWith, seqX) + (ShowX (..), NFDataX (..), showsX, showsPrecXWith, seqX, isX) {- $setup >>> :set -XDataKinds @@ -153,6 +144,7 @@ >>> :set -XTypeApplications >>> :set -fplugin GHC.TypeLits.Normalise >>> import Clash.Prelude +>>> import Data.Kind >>> let compareSwapL a b = if a < b then (a,b) else (b,a) >>> :{ let sortV xs = map fst sorted :< (snd (last sorted)) @@ -178,13 +170,13 @@ sorted = zipWith (flip compareSwapL) rights lefts :} ->>> data Append (m :: Nat) (a :: *) (f :: TyFun Nat *) :: * +>>> data Append (m :: Nat) (a :: Type) (f :: TyFun Nat Type) :: Type >>> type instance Apply (Append m a) l = Vec (l + m) a >>> let append' xs ys = dfold (Proxy :: Proxy (Append m a)) (const (:>)) ys xs >>> let compareSwap a b = if a > b then (a,b) else (b,a) >>> let insert y xs = let (y',xs') = mapAccumL compareSwap y xs in xs' :< y' >>> let insertionSort = vfold (const insert) ->>> data IIndex (f :: TyFun Nat *) :: * +>>> data IIndex (f :: TyFun Nat Type) :: Type >>> :set -XUndecidableInstances >>> type instance Apply IIndex l = Index ((2^l)+1) >>> :{ @@ -246,6 +238,17 @@ toConstr (Cons _ _) = cCons dataTypeOf _ = tVec + gfoldl + :: (forall d b. Data d => c (d -> b) -> d -> c b) + -> (forall g. g -> c g) + -> Vec n a + -> c (Vec n a) + gfoldl f z xs = case compareSNat (SNat @n) (SNat @0) of + SNatLE -> case leZero @n of + Sub Dict -> z Nil + SNatGT -> let (y :> ys) = xs + in (z @(a -> Vec (n-1) a -> Vec n a) (:>) `f` y `f` ys) + tVec :: DataType tVec = mkDataType "Vec" [cNil, cCons] @@ -319,6 +322,10 @@ pure = repeat fs <*> xs = zipWith ($) fs xs +{-# RULES +"zipWith$map" forall f xs ys. zipWith (\g a -> g a) (map f xs) ys = zipWith f xs ys + #-} + instance (KnownNat n, 1 <= n) => F.Foldable (Vec n) where fold = leToPlus @1 @n $ fold mappend foldMap f = leToPlus @1 @n $ fold mappend . map f @@ -357,7 +364,15 @@ -- a recursive function. seqX (foldl (\() -> rnfX) () v) () + hasUndefined v = + if isLeft (isX v) then True else go v + where + go :: forall m b . (NFDataX b, KnownNat m) => Vec m b -> Bool + go Nil = False + go (x `Cons` xs) = hasUndefined x || hasUndefined xs + ensureSpine = map ensureSpine . lazyV + {-# INLINE singleton #-} -- | Create a vector of one element -- @@ -1000,6 +1015,7 @@ where (ys,zs) = P.splitAt (P.length xs `div` 2) xs {-# NOINLINE fold #-} +{-# ANN fold (InlinePrimitive [VHDL,Verilog,SystemVerilog] "[ { \"BlackBoxHaskell\" : { \"name\" : \"Clash.Sized.Vector.fold\", \"templateFunction\" : \"Clash.Primitives.Sized.Vector.foldBBF\"}} ]") #-} -- | 'scanl' is similar to 'foldl', but returns a vector of successive reduced -- values from the left: @@ -1856,9 +1872,9 @@ lazyV :: KnownNat n => Vec n a -> Vec n a -lazyV = lazyV' (repeat undefined) +lazyV = lazyV' (repeat ()) where - lazyV' :: Vec n a -> Vec n a -> Vec n a + lazyV' :: Vec n () -> Vec n a -> Vec n a lazyV' Nil _ = Nil lazyV' (_ `Cons` xs) ys = head ys `Cons` lazyV' xs (tail ys) {-# NOINLINE lazyV #-} @@ -2132,7 +2148,7 @@ Nil (reverse xs) {-# INLINE smap #-} -instance (KnownNat n, KnownNat (BitSize a), BitPack a) => BitPack (Vec n a) where +instance (KnownNat n, BitPack a) => BitPack (Vec n a) where type BitSize (Vec n a) = n * (BitSize a) pack = packXWith (concatBitVector# . map pack) unpack = map unpack . unconcatBitVector# diff --git a/src/Clash/Sized/Vector.hs-boot b/src/Clash/Sized/Vector.hs-boot --- a/src/Clash/Sized/Vector.hs-boot +++ b/src/Clash/Sized/Vector.hs-boot @@ -4,18 +4,19 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} module Clash.Sized.Vector where +import Data.Kind (Type) import GHC.TypeLits (KnownNat, Nat, type (<=)) import {-# SOURCE #-} Clash.Sized.Internal.BitVector (BitVector, Bit) type role Vec nominal representational -data Vec :: Nat -> * -> * +data Vec :: Nat -> Type -> Type instance (KnownNat n, 1 <= n) => Foldable (Vec n) diff --git a/src/Clash/Tutorial.hs b/src/Clash/Tutorial.hs --- a/src/Clash/Tutorial.hs +++ b/src/Clash/Tutorial.hs @@ -2,10 +2,11 @@ Copyright : © 2014-2016, Christiaan Baaij, 2017-2019, Myrtle Software Ltd 2017 , QBayLogic, Google Inc. -Licence : Creative Commons 4.0 (CC BY 4.0) (http://creativecommons.org/licenses/by/4.0/) +Licence : Creative Commons 4.0 (CC BY 4.0) (https://creativecommons.org/licenses/by/4.0/) -} -{-# LANGUAGE NoImplicitPrelude, MagicHash #-} +{-# LANGUAGE NoImplicitPrelude #-} + {-# OPTIONS_GHC -fno-warn-unused-imports #-} module Clash.Tutorial ( @@ -385,8 +386,8 @@ The 'register' function is our primary sequential building block to capture /state/. It is used internally by one of the "Clash.Prelude" function that we will use to describe our MAC circuit. Note that the following paragraphs will -only show one of many ways to specify a sequential circuit, at the section we -will show a couple more. +only show one of many ways to specify a sequential circuit, in the section +<#mac6 Alternative specifications> we will show a couple more. A principled way to describe a sequential circuit is to use one of the classic machine models, within the Clash prelude library offer standard function to @@ -466,6 +467,7 @@ topEntity :: 'Clock' 'System' -> 'Reset' 'System' + -> 'Enable' 'System' -> 'Signal' 'System' ('Signed' 9, 'Signed' 9) -> 'Signal' 'System' ('Signed' 9) topEntity = 'exposeClockResetEnable' mac @@ -512,7 +514,7 @@ to VHDL by executing the @:vhdl@ command in the interpreter. This will create a directory called 'vhdl', which contains a directory called @MAC@, which ultimately contains all the generated VHDL files. You can now load these files -into your favourite VHDL synthesis tool, marking @mac_topentity.vhdl@ as the file +into your favourite VHDL synthesis tool, marking @topentity.vhdl@ as the file containing the top level entity. -} @@ -583,13 +585,13 @@ You should now again run @:vhdl@ in the interpreter; this time the compiler will take a bit longer to generate all the circuits. Inside the @.\/vhdl\/MAC@ -directory you will now also find a /mac_testbench/ subdirectory containing all -the @vhdl@ files for the /test bench/. +directory you will now also find a /testbench/ subdirectory containing all the +@vhdl@ files for the /test bench/. After compilation is finished you load all the files in your favourite VHDL simulation tool. Once all files are loaded into the VHDL simulator, run the -simulation on the @mac_testbench_testbench@ entity. +simulation on the @testbench@ entity. On questasim / modelsim: doing a @run -all@ will finish once the output verifier will assert its output to @true@. The generated testbench, modulo the clock signal generator(s), is completely synthesizable. This means that if you want to @@ -613,7 +615,7 @@ structure. -} -{- $mac6 +{- $mac6 #mac6# * __'Num' instance for 'Signal'__: @'Signal' a@ is also also considered a 'Num'eric type as long as the value @@ -704,7 +706,7 @@ -> 'Enable' 'System' -> 'Signal' 'System' ('Signed' 16) -> 'Signal' 'System' ('Signed' 16) -topEntity = exposeClockResetEnableEnable (fir (0 ':>' 1 ':>' 2 ':>' 3 ':>' 'Nil')) +topEntity = exposeClockResetEnable (fir (0 ':>' 1 ':>' 2 ':>' 3 ':>' 'Nil')) @ Here we can see that, although the Clash compiler handles recursive function @@ -741,10 +743,10 @@ -> ('Signal' dom i -> 'Signal' dom o) @ -we see that the resulting function has an input of type @'Signal' i@, and an -output of @'Signal' o@. However, the type of @(a,b)@ in the definition of @g@ is: -@('Signal' Bool, 'Signal' Int)@. And the type of @(i1,b1)@ is of type -@('Signal' Int, 'Signal' Bool)@. +we see that the resulting function has an input of type @'Signal' dom i@, and +an output of @'Signal' dom o@. However, the type of @(a,b)@ in the definition +of @g@ is: @('Signal' dom Bool, 'Signal' dom Int)@. And the type of @(i1,b1)@ +is of type @('Signal' dom Int, 'Signal' dom Bool)@. Syntactically, @'Signal' dom (Bool,Int)@ and @('Signal' dom Bool, 'Signal' dom Int)@ are /unequal/. @@ -772,8 +774,9 @@ belonging to the 'Bundle' , which, together with 'bundle' and 'unbundle' defines the isomorphism between a product type of 'Signal's and a 'Signal' of a product type. That is, while -@(Signal a, Signal b)@ and @Signal (a,b)@ are not equal, they are /isomorphic/ -and can be converted from, or to, the other using 'bundle' and 'unbundle'. +@('Signal' dom a, 'Signal' dom b)@ and @'Signal' dom (a,b)@ are not equal, +they are /isomorphic/ and can be converted from, or to, the other using +'bundle' and 'unbundle'. Instances of this 'Bundle' type-class are defined as /isomorphisms/ for: @@ -797,7 +800,7 @@ @ instance 'Bundle' Bool where - type 'Unbundled' clk Bool = 'Signal' clk Bool + type 'Unbundled' dom Bool = 'Signal' dom Bool bundle s = s unbundle s = s @ @@ -890,14 +893,14 @@ 'createDomain' vSystem{vName=\"Dom50\", vPeriod=50000} topEntity - :: Clock \"DomInput\" - -> Signal \"DomInput\" Bool - -> Signal \"Dom50\" Bit - -> Signal \"Dom50\" (BitVector 8) + :: Clock DomInput + -> Signal DomInput Bool + -> Signal Dom50 Bit + -> Signal Dom50 (BitVector 8) topEntity clk rst = 'exposeClockResetEnable' ('mealy' blinkerT (1,False,0) . Clash.Prelude.isRising 1) pllOut rstSync 'enableGen' where - (pllOut,pllStable) = 'Clash.Intel.ClockGen.altpll' @"Dom50" (SSymbol @"altpll50") clk ('Clash.Signal.unsafeFromLowPolarity' rst) + (pllOut,pllStable) = 'Clash.Intel.ClockGen.altpll' \@Dom50 (SSymbol \@\"altpll50\") clk ('Clash.Signal.unsafeFromLowPolarity' rst) rstSync = 'Clash.Signal.resetSynchronizer' pllOut ('Clash.Signal.unsafeFromLowPolarity' pllStable) enableGen blinkerT (leds,mode,cntr) key1R = ((leds',mode',cntr'),leds) @@ -917,7 +920,7 @@ | otherwise = leds @ -The Clash compiler will normally generate the following @blinker_topEntity.vhdl@ file: +The Clash compiler will normally generate the following @topentity.vhdl@ file: @ -- Automatically generated VHDL-93 @@ -929,7 +932,7 @@ use work.all; use work.blinker_types.all; -entity blinker_topentity is +entity topentity is port(-- clock clk : in blinker_types.clk_dominput; rst : in boolean; @@ -937,7 +940,7 @@ leds : out std_logic_vector(7 downto 0)); end; -architecture structural of blinker_topentity is +architecture structural of topentity is ... end; @ @@ -1014,7 +1017,7 @@ Where redefined primitives in the current directory or include directories will overwrite those in the official install location. For now, files containing -primitive definitions must have an @.json@ file-extension. +primitive definitions must have a @.json@ file-extension. Clash differentiates between two types of primitives, /expression/ primitives and /declaration/ primitives, corresponding to whether the primitive is a VHDL @@ -1034,6 +1037,7 @@ { \"BlackBox\" : { "name" : "Clash.Sized.Internal.Signed.*#" , "kind" : \"Expression\" + , "type" : "(*#) :: KnownNat n => Signed n -> Signed n -> Signed n" , "template" : "resize(~ARG[1] * ~ARG[2], ~LIT[0])" } } @@ -1081,7 +1085,8 @@ blockRam# - :: ( HasCallStack + :: ( KnownDomain dom + , HasCallStack , NFDataX a ) => 'Clock' dom -- ^ 'Clock' to synchronize to -> 'Enable' dom -- ^ Global enable @@ -1127,55 +1132,56 @@ , "kind" : \"Declaration\" , "type" : "blockRam# - :: ( HasCallStack -- ARG[0] - , NFDataX a ) -- ARG[1] - => Clock dom -- clk, ARG[2] - -> Enable dom -- en, ARG[3] - -> Vec n a -- init, ARG[4] - -> Signal dom Int -- rd, ARG[5] - -> Signal dom Bool -- wren, ARG[6] - -> Signal dom Int -- wr, ARG[7] - -> Signal dom a -- din, ARG[8] + :: ( KnownDomain dom ARG[0] + , HasCallStack -- ARG[1] + , NFDataX a ) -- ARG[2] + => Clock dom -- clk, ARG[3] + -> Enable dom -- en, ARG[4] + -> Vec n a -- init, ARG[5] + -> Signal dom Int -- rd, ARG[6] + -> Signal dom Bool -- wren, ARG[7] + -> Signal dom Int -- wr, ARG[8] + -> Signal dom a -- din, ARG[9] -> Signal dom a" , "template" : "-- blockRam begin -~GENSYM[~RESULT_blockRam][0] : block - signal ~GENSYM[~RESULT_RAM][1] : ~TYP[4] := ~CONST[4]; - signal ~GENSYM[rd][3] : integer range 0 to ~LENGTH[~TYP[4]] - 1; - signal ~GENSYM[wr][4] : integer range 0 to ~LENGTH[~TYP[4]] - 1; +~GENSYM[~RESULT_blockRam][1] : block + signal ~GENSYM[~RESULT_RAM][2] : ~TYP[5] := ~CONST[5]; + signal ~GENSYM[rd][4] : integer range 0 to ~LENGTH[~TYP[5]] - 1; + signal ~GENSYM[wr][5] : integer range 0 to ~LENGTH[~TYP[5]] - 1; begin - ~SYM[3] <= to_integer(~ARG[5]) + ~SYM[4] <= to_integer(~ARG[6]) -- pragma translate_off - mod ~LENGTH[~TYP[4]] + mod ~LENGTH[~TYP[5]] -- pragma translate_on ; - ~SYM[4] <= to_integer(~ARG[7]) + ~SYM[5] <= to_integer(~ARG[8]) -- pragma translate_off - mod ~LENGTH[~TYP[4]] + mod ~LENGTH[~TYP[5]] -- pragma translate_on ; ~IF ~VIVADO ~THEN - ~SYM[5] : process(~ARG[2]) + ~SYM[6] : process(~ARG[3]) begin - if rising_edge(~ARG[2]) then - if ~ARG[6] ~IF ~ISACTIVEENABLE[3] ~THEN and ~ARG[3] ~ELSE ~FI then - ~SYM[1](~SYM[4]) <= ~TOBV[~ARG[8]][~TYP[8]]; + if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then + if ~ARG[7] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then + ~SYM[2](~SYM[5]) <= ~TOBV[~ARG[9]][~TYP[9]]; end if; - ~RESULT <= fromSLV(~SYM[1](~SYM[3])) + ~RESULT <= fromSLV(~SYM[2](~SYM[4])) -- pragma translate_off after 1 ps -- pragma translate_on ; end if; end process; ~ELSE - ~SYM[5] : process(~ARG[2]) + ~SYM[6] : process(~ARG[3]) begin - if rising_edge(~ARG[2]) then - if ~ARG[6] ~IF ~ISACTIVEENABLE[3] ~THEN and ~ARG[3] ~ELSE ~FI then - ~SYM[1](~SYM[4]) <= ~ARG[8]; + if ~IF~ACTIVEEDGE[Rising][0]~THENrising_edge~ELSEfalling_edge~FI(~ARG[3]) then + if ~ARG[7] ~IF ~ISACTIVEENABLE[4] ~THEN and ~ARG[4] ~ELSE ~FI then + ~SYM[2](~SYM[5]) <= ~ARG[9]; end if; - ~RESULT <= ~SYM[1](~SYM[3]) + ~RESULT <= ~SYM[2](~SYM[4]) -- pragma translate_off after 1 ps -- pragma translate_on @@ -1206,7 +1212,7 @@ * @~TYPO@: VHDL type of the result. * @~TYPM[N]@: VHDL type/name/ of the @(N+1)@'th argument; used in /type/ /qualification/. -* @~TYPM@: VHDL type/name/ of the result; used in /type qualification/. +* @~TYPMO@: VHDL type/name/ of the result; used in /type qualification/. * @~ERROR[N]@: Error value for the VHDL type of the @(N+1)@'th argument. * @~ERRORO@: Error value for the VHDL type of the result. * @~GENSYM[\][N]@: Create a unique name, trying to stay as close to @@ -1228,7 +1234,7 @@ * @~IF \ ~THEN \ ~ELSE \ ~FI@: renders the \ part when \ evaluates to /0/, and renders the \ in all other cases. Valid @\@s are @~LENGTH[\]@, @~SIZE[\]@, - @~DEPTH[\]@, @~VIVADO@, @~IW64@, @~ISLIT[N]@, @~ISVAR[N], @~ISACTIVEENABLE[N]@, + @~DEPTH[\]@, @~VIVADO@, @~IW64@, @~ISLIT[N]@, @~ISVAR[N]@, @~ISACTIVEENABLE[N]@, @~ISSYNC[N]@, and @~AND[\,\,..]@. * @~VIVADO@: /1/ when Clash compiler is invoked with the @-fclash-xilinx@ or @-fclash-vivado@ flag. To be used with in an @~IF .. ~THEN .. ~ElSE .. ~FI@ @@ -1238,14 +1244,14 @@ The @\@ hole indicates the type of the expression and must be either @~TYP[N]@, @~TYPO@, or @~TYPELEM[\]@. * @~FROMBV[\][\]@: create conversion code that so that the - expression in @\@, which has a bit vector (@std_logic_vector@) type, is - converted to type indicated by @\@. The @\@ hole indicates the - must be either @~TYP[N]@, @~TYPO@, or @~TYPELEM[\]@. + expression in @\@, which has a bit vector (@std_logic_vector@) type, + is converted to type indicated by @\@. The @\@ hole must be + either @~TYP[N]@, @~TYPO@, or @~TYPELEM[\]@. * @~INCLUDENAME[N]@: the generated name of the @N@'th included component. * @~FILEPATH[\]@: The argument mentioned in @\@ is a file which must be copied to the location of the generated HDL. * @~GENERATE@: Verilog: create a /generate/ statement, except when already in - as /generate/ context. + a /generate/ context. * @~ENDGENERATE@: Verilog: create an /endgenerate/ statement, except when already in a /generate/ context. * @~ISLIT[N]@: Is the @(N+1)@'th argument to the function a literal. @@ -1266,7 +1272,8 @@ /edge/. /edge/ must be one of 'Falling' or 'Rising'. Errors when called on an argument which is not a 'KnownDomain' or 'KnownConf'. * @~AND[\,\,..]@: Logically /and/ the conditions in the @\@'s -* @~VARS[N]@: VHDL: Return the variables at the @(N+1)@'th argument argument. +* @~VAR[\][N]@: Like @~ARG[N]@ but binds the argument to a variable named NAME. +* @~VARS[N]@: VHDL: Return the variables at the @(N+1)@'th argument. * @~NAME[N]@: Render the @(N+1)@'th string literal argument as an identifier instead of a string literal. Fails when the @(N+1)@'th argument is not a string literal. @@ -1296,6 +1303,7 @@ { \"BlackBox\" : { "name" : "Clash.Sized.Internal.Signed.*#" , "kind" : \"Expression\" + , "type" : "(*#) :: KnownNat n => Signed n -> Signed n -> Signed n" , "template" : "~ARG[1] * ~ARG[2]" } } @@ -1309,49 +1317,50 @@ , "kind" : \"Declaration\" , "type" : "blockRam# - :: ( HasCallStack -- ARG[0] - , NFDataX a ) -- ARG[1] - => Clock dom -- clk, ARG[2] - => Enable dom -- en, ARG[3] - -> Vec n a -- init, ARG[4] - -> Signal dom Int -- rd, ARG[5] - -> Signal dom Bool -- wren, ARG[6] - -> Signal dom Int -- wr, ARG[7] - -> Signal dom a -- din, ARG[8] + :: ( KnownDomain dom ARG[0] + , HasCallStack -- ARG[1] + , NFDataX a ) -- ARG[2] + => Clock dom -- clk, ARG[3] + => Enable dom -- en, ARG[4] + -> Vec n a -- init, ARG[5] + -> Signal dom Int -- rd, ARG[6] + -> Signal dom Bool -- wren, ARG[7] + -> Signal dom Int -- wr, ARG[8] + -> Signal dom a -- din, ARG[9] -> Signal dom a" , "outputReg" : true , "template" : "// blockRam begin -reg ~TYPO ~GENSYM[~RESULT_RAM][0] [0:~LENGTH[~TYP[4]]-1]; +reg ~TYPO ~GENSYM[~RESULT_RAM][1] [0:~LENGTH[~TYP[5]]-1]; -reg ~TYP[4] ~GENSYM[ram_init][2]; -integer ~GENSYM[i][3]; +reg ~TYP[5] ~GENSYM[ram_init][3]; +integer ~GENSYM[i][4]; initial begin - ~SYM[2] = ~CONST[4]; - for (~SYM[3]=0; ~SYM[3] < ~LENGTH[~TYP[4]]; ~SYM[3] = ~SYM[3] + 1) begin - ~SYM[0][~LENGTH[~TYP[4]]-1-~SYM[3]] = ~SYM[2][~SYM[3]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; + ~SYM[3] = ~CONST[5]; + for (~SYM[4]=0; ~SYM[4] < ~LENGTH[~TYP[5]]; ~SYM[4] = ~SYM[4] + 1) begin + ~SYM[1][~LENGTH[~TYP[5]]-1-~SYM[4]] = ~SYM[3][~SYM[4]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; end end -~IF ~ISACTIVEENABLE[3] ~THEN -always @(posedge ~ARG[2]) begin : ~GENSYM[~RESULT_blockRam][4]~IF ~VIVADO ~THEN - if (~ARG[3]) begin - if (~ARG[6]) begin - ~SYM[0][~ARG[7]] <= ~ARG[8]; +~IF ~ISACTIVEENABLE[4] ~THEN +always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~RESULT_blockRam][5]~IF ~VIVADO ~THEN + if (~ARG[4]) begin + if (~ARG[7]) begin + ~SYM[1][~ARG[8]] <= ~ARG[9]; end - ~RESULT <= ~SYM[0][~ARG[5]]; + ~RESULT <= ~SYM[1][~ARG[6]]; end~ELSE - if (~ARG[6] & ~ARG[3]) begin - ~SYM[0][~ARG[7]] <= ~ARG[8]; + if (~ARG[7] & ~ARG[4]) begin + ~SYM[1][~ARG[8]] <= ~ARG[9]; end - if (~ARG[3]) begin - ~RESULT <= ~SYM[0][~ARG[5]]; + if (~ARG[4]) begin + ~RESULT <= ~SYM[1][~ARG[6]]; end~FI end~ELSE -always @(posedge ~ARG[2]) begin : ~SYM[4] - if (~ARG[6]) begin - ~SYM[0][~ARG[7]] <= ~ARG[8]; +always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[5] + if (~ARG[7]) begin + ~SYM[1][~ARG[8]] <= ~ARG[9]; end - ~RESULT <= ~SYM[0][~ARG[5]]; + ~RESULT <= ~SYM[1][~ARG[6]]; end~FI // blockRam end" } @@ -1367,6 +1376,7 @@ { \"BlackBox\" : { "name" : "Clash.Sized.Internal.Signed.*#" , "kind" : \"Expression\" + , "type" : "(*#) :: KnownNat n => Signed n -> Signed n -> Signed n" , "template" : "~ARG[1] * ~ARG[2]" } } @@ -1380,44 +1390,45 @@ , "kind" : \"Declaration\" , "type" : "blockRam# - :: ( HasCallStack -- ARG[0] - , NFDataX a ) -- ARG[1] - => Clock dom -- clk, ARG[2] - -> Enable dom -- en, ARG[3] - -> Vec n a -- init, ARG[4] - -> Signal dom Int -- rd, ARG[5] - -> Signal dom Bool -- wren, ARG[6] - -> Signal dom Int -- wr, ARG[7] - -> Signal dom a -- din, ARG[8] + :: ( KnownDomain dom ARG[0] + , HasCallStack -- ARG[1] + , NFDataX a ) -- ARG[2] + => Clock dom -- clk, ARG[3] + -> Enable dom -- en, ARG[4] + -> Vec n a -- init, ARG[5] + -> Signal dom Int -- rd, ARG[6] + -> Signal dom Bool -- wren, ARG[7] + -> Signal dom Int -- wr, ARG[8] + -> Signal dom a -- din, ARG[9] -> Signal dom a" , "template" : "// blockRam begin -~SIGD[~GENSYM[RAM][0]][4]; -logic [~SIZE[~TYP[8]]-1:0] ~GENSYM[~RESULT_q][1]; +~SIGD[~GENSYM[RAM][1]][5]; +logic [~SIZE[~TYP[9]]-1:0] ~GENSYM[~RESULT_q][2]; initial begin - ~SYM[0] = ~CONST[4]; -end~IF ~ISACTIVEENABLE[3] ~THEN -always @(posedge ~ARG[2]) begin : ~GENSYM[~COMPNAME_blockRam][2]~IF ~VIVADO ~THEN - if (~ARG[3]) begin - if (~ARG[6]) begin - ~SYM[0][~ARG[7]] <= ~TOBV[~ARG[8]][~TYP[8]]; + ~SYM[1] = ~CONST[5]; +end~IF ~ISACTIVEENABLE[4] ~THEN +always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~GENSYM[~COMPNAME_blockRam][3]~IF ~VIVADO ~THEN + if (~ARG[4]) begin + if (~ARG[7]) begin + ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]]; end - ~SYM[1] <= ~SYM[0][~ARG[5]]; + ~SYM[2] <= ~SYM[1][~ARG[6]]; end~ELSE - if (~ARG[6] & ~ARG[3]) begin - ~SYM[0][~ARG[7]] <= ~TOBV[~ARG[8]][~TYP[8]]; + if (~ARG[7] & ~ARG[4]) begin + ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]]; end - if (~ARG[3]) begin - ~SYM[1] <= ~SYM[0][~ARG[5]]; + if (~ARG[4]) begin + ~SYM[2] <= ~SYM[1][~ARG[6]]; end~FI end~ELSE -always @(posedge ~ARG[2]) begin : ~SYM[2] - if (~ARG[6]) begin - ~SYM[0][~ARG[7]] <= ~TOBV[~ARG[8]][~TYP[8]]; +always @(~IF~ACTIVEEDGE[Rising][0]~THENposedge~ELSEnegedge~FI ~ARG[3]) begin : ~SYM[3] + if (~ARG[7]) begin + ~SYM[1][~ARG[8]] <= ~TOBV[~ARG[9]][~TYP[9]]; end - ~SYM[1] <= ~SYM[0][~ARG[5]]; + ~SYM[2] <= ~SYM[1][~ARG[6]]; end~FI -assign ~RESULT = ~FROMBV[~SYM[1]][~TYP[8]]; +assign ~RESULT = ~FROMBV[~SYM[2]][~TYP[9]]; // blockRam end" } } @@ -1529,10 +1540,10 @@ __asyncRam__ :: ( 'Enum' addr , 'HasCallStack' - , 'KnownDomain' wdom wconf - , 'KnownDomain' rdom rconf + , 'KnownDomain' wdom + , 'KnownDomain' rdom ) - => 'Clock' wdom -- ^ Clock to which to synchronize the write port of the RAM + => 'Clock' wdom -- ^ 'Clock' to which to synchronize the write port of the RAM -> 'Clock' rdom -- ^ 'Clock' to which the read address signal, @r@, is synchronized to -> 'Enable' wdom -- ^ Global enable -> 'SNat' n -- ^ Size @n@ of the RAM @@ -1628,8 +1639,8 @@ Gray-encoded pointers between the two clock domains: @ -ptrSync clk1 clk2 rst2 = - 'Clash.Explicit.Signal.register' clk2 rst2 0 . 'Clash.Explicit.Signal.register' clk2 rst2 0 . 'Clash.Explicit.Signal.unsafeSynchronizer' clk1 clk2 +ptrSync clk1 clk2 rst2 en2 = + 'Clash.Explicit.Signal.register' clk2 rst2 en2 0 . 'Clash.Explicit.Signal.register' clk2 rst2 en2 0 . 'Clash.Explicit.Signal.unsafeSynchronizer' clk1 clk2 @ It uses the 'unsafeSynchronizer' primitive, which is needed to go from one clock @@ -1639,12 +1650,12 @@ Clash compiler, so developers must ensure that it is only used as part of a proper synchronizer. -Finally we combine all the component in: +Finally we combine all the components in: @ asyncFIFOSynchronizer - :: ( 'KnownDomain' wdom wconf - , 'KnownDomain' rdom rconf + :: ( 'KnownDomain' wdom + , 'KnownDomain' rdom , 2 <= addrSize ) => SNat addrSize -- ^ Size of the internally used addresses, the FIFO contains @2^addrSize@ @@ -1666,8 +1677,8 @@ asyncFIFOSynchronizer addrSize\@SNat wclk rclk wrst rrst wen ren rinc wdataM = (rdata, rempty, wfull) where - s_rptr = 'dualFlipFlopSynchronizer' rclk wclk wrst wen 0 rptr - s_wptr = 'dualFlipFlopSynchronizer' wclk rclk rrst ren 0 wptr + s_rptr = ptrSync rclk wclk wrst wen rptr + s_wptr = ptrSync wclk rclk rrst ren wptr rdata = fifoMem @@ -1736,7 +1747,6 @@ bin' = bin + 'boolToBV' (inc && not flag) ptr' = (bin' \`shiftR\` 1) \`xor\` bin' addr = 'truncateB' bin - flag' = flagGen ptr' s_ptr -- FIFO empty: when next pntr == synchronized wptr or on reset @@ -1760,13 +1770,13 @@ wptrFullInit = (0, 0, False) -- Dual flip-flop synchronizer -ptrSync clk1 clk2 rst2 = - 'Clash.Explicit.Signal.register' clk2 rst2 0 . 'Clash.Explicit.Signal.register' clk2 rst2 0 . 'Clash.Explicit.Signal.unsafeSynchronizer' clk1 clk2 +ptrSync clk1 clk2 rst2 en2 = + 'Clash.Explicit.Signal.register' clk2 rst2 en2 0 . 'Clash.Explicit.Signal.register' clk2 rst2 en2 0 . 'Clash.Explicit.Signal.unsafeSynchronizer' clk1 clk2 -- Async FIFO synchronizer asyncFIFOSynchronizer - :: ( 'KnownDomain' wdom wconf - , 'KnownDomain' rdom rconf + :: ( 'KnownDomain' wdom + , 'KnownDomain' rdom , 2 <= addrSize ) => SNat addrSize -- ^ Size of the internally used addresses, the FIFO contains @2^addrSize@ @@ -1788,8 +1798,8 @@ asyncFIFOSynchronizer addrSize\@SNat wclk rclk wrst rrst wen ren rinc wdataM = (rdata, rempty, wfull) where - s_rptr = 'dualFlipFlopSynchronizer' rclk wclk wrst wen 0 rptr - s_wptr = 'dualFlipFlopSynchronizer' wclk rclk rrst ren 0 wptr + s_rptr = ptrSync rclk wclk wrst wen rptr + s_wptr = ptrSync wclk rclk rrst ren wptr rdata = fifoMem @@ -1843,6 +1853,8 @@ -> 'Clock' \"FFT\" -> 'Reset' \"ADC\" -> 'Reset' \"FFT\" + -> 'Enable' \"ADC\" + -> 'Enable' \"FFT\" -> 'Signal' \"FFT\" Bool -> 'Signal' \"ADC\" (Maybe (SFixed 8 8)) -> ( 'Signal' \"FFT\" (SFixed 8 8) @@ -1866,10 +1878,10 @@ * __Type error: Couldn't match expected type @'Signal' dom (a,b)@ with actual type__ __@('Signal' dom a, 'Signal' dom b)@__: - Signals of product types and product types (to which tuples belong) of - signals are __isomorphic__ due to synchronisity principle, but are not - (structurally) equal. Use the 'bundle' function to convert from a product type - to the signal type. So if your code which gives the error looks like: + Signals of product types and product types of signals are __isomorphic__ + due to synchronisity principle, but are not (structurally) equal. Tuples + are a product type. Use the 'bundle' function to convert from a product + type to the signal type. So if your code which gives the error looks like: @ ... = f a b (c,d) @@ -1889,10 +1901,11 @@ * __Type error: Couldn't match expected type @('Signal' dom a, 'Signal' dom b)@ with__ __ actual type @'Signal' dom (a,b)@__: - Product types (to which tuples belong) of signals and signals of product - types are __isomorphic__ due to synchronicity principle, but are not - (structurally) equal. Use the 'unbundle' function to convert from a signal - type to the product type. So if your code which gives the error looks like: + Product types of signals and signals of product types are __isomorphic__ + due to synchronicity principle, but are not (structurally) equal. Tuples + are a product type. Use the 'unbundle' function to convert from a signal + type to the product type. So if your code which gives the error looks + like: @ (c,d) = f a b @@ -1914,17 +1927,24 @@ A function could not be transformed into the expected normal form. This usually means one of the following: - * The @topEntity@ has residual polymorphism. * The @topEntity@ has higher-order arguments, or a higher-order result. * You are using types which cannot be represented in hardware. The solution for all the above listed reasons is quite simple: remove them. That is, make sure that the @topEntity@ is completely monomorphic and first-order. Also remove any variables and constants/literals that have a - non-representable type, see <#unsupported Unsupported Haskell features> to - find out which types are not representable. + non-representable type; see <#limitations Limitations of Clash> to find + out which types are not representable. -* __Clash.Normalize(94): Expr belonging to bndr: \ remains__ +* __Clash.Normalize(..): Clash can only normalize monomorphic functions, but this is polymorphic__: + + If this happens for a @topEntity@ or something with a @Synthesize@ annotation, + add a monomorphic type signature. + Non topEntites should be type-specialized by clash automatically, if not please report this as a bug. + But adding a monomorphic type signature should still help (when possible). + + +* __Clash.Normalize(..): Expr belonging to bndr: \ remains__ __recursive after normalization__: * If you actually wrote a recursive function, rewrite it to a non-recursive @@ -1944,7 +1964,7 @@ @ topEntity - :: 'SystemClockReset' + :: 'SystemClockResetEnable' => 'Signal' 'System' ('Signed' 8) -> 'Signal' 'System' ('Signed' 8) -> 'Signal' 'System' ('Signed' 8) @@ -1953,7 +1973,7 @@ acc = 'register' 3 (acc + x * y) @ -* __Clash.Normalize.Transformations(155): InlineNonRep: \ already__ +* __Clash.Normalize.Transformations(..): InlineNonRep: \ already__ __inlined 100 times in:\, \__: You left the @topEntity@ function polymorphic or higher-order: use @@ -2052,6 +2072,7 @@ n'th Fibbonaci number on the n'th clock cycle: @ + fibS :: SystemClockResetEnable => Signal System (Unsigned 64) fibS = r where r = 'register' 0 r + 'register' 0 ('register' 1 r) @ @@ -2072,11 +2093,11 @@ of bubble sort: @ - sortV xs = 'map' fst sorted :< (snd ('last' sorted)) + sortVL xs = 'map' fst sorted ':<' (snd ('last' sorted)) where - lefts = 'head' xs :> 'map' snd ('init' sorted) + lefts = 'head' xs :> map snd ('init' sorted) rights = 'tail' xs - sorted = 'zipWith' compareSwapL lefts rights + sorted = 'zipWith' compareSwapL ('lazyV' lefts) rights @ Where we can clearly see that 'lefts' and 'sorted' are defined in terms @@ -2305,7 +2326,7 @@ ==== FIR filter -FIR filter in Clash 1.0: +FIR filter in Clash 0.99: @ module FIR where @@ -2320,8 +2341,8 @@ dotp as bs = fold boundedPlus (zipWith boundedMult as bs) fir - :: (Default a, KnownNat n, SaturatingNum a, HiddenClockResetEnable dom) - => Vec (n + 1) a -> Signal dom a -> Signal dom a + :: (Default a, KnownNat n, SaturatingNum a, HiddenClockReset domain gated synchronous) + => Vec (n + 1) a -> Signal domain a -> Signal domain a fir coeffs x_t = y_t where y_t = dotp coeffs \<$\> bundle xs @@ -2333,7 +2354,7 @@ -> Signal System (Signed 16) -> Signal System (Signed 16) topEntity = exposeClockReset (fir (2:>3:>(-2):>8:>Nil)) -{-# NOINLINE topEntity #-} +{\-\# NOINLINE topEntity \#-\} testBench :: Signal System Bool testBench = done @@ -2345,7 +2366,7 @@ rst = systemResetGen @ -FIR filter in current version: +FIR filter in Clash 1.0: @ @@ -2366,7 +2387,7 @@ , KnownNat n , SaturatingNum a , NFDataX a ) - => Vec (n + 1) a -> Signal tag a -> Signal tag a + => Vec (n + 1) a -> Signal dom a -> Signal dom a fir coeffs x_t = y_t where y_t = dotp coeffs \<$\> bundle xs @@ -2379,7 +2400,7 @@ -> Signal System (Signed 16) -> Signal System (Signed 16) topEntity = exposeClockResetEnable (fir (2:>3:>(-2):>8:>Nil)) -{-# NOINLINE topEntity #-} +{\-\# NOINLINE topEntity \#-\} testBench :: Signal System Bool testBench = done @@ -2396,7 +2417,8 @@ Blinker circuit in Clash 0.99: @ -{-# LANGUAGE NoMonoLocalBinds #-} +{\-\# LANGUAGE NoMonoLocalBinds \#-\} + module Blinker where import Clash.Prelude @@ -2422,7 +2444,7 @@ topEntity clk rst = exposeClockReset (mealy blinkerT (1,False,0) . isRising 1) pllOut rstSync where - (pllOut,pllStable) = altpll \@Dom50 (SSymbol \@ \"altpll50\") clk rst + (pllOut,pllStable) = altpll \@Dom50 (SSymbol \@\"altpll50\") clk rst rstSync = resetSynchronizer pllOut (unsafeToAsyncReset pllStable) blinkerT (leds,mode,cntr) key1R = ((leds',mode',cntr'),leds) @@ -2455,7 +2477,7 @@ -- ^ After some period, rotate active led to the left | Complement -- ^ After some period, turn on all disable LEDs, and vice versa - deriving (Generic, 'Undefined') + deriving (Generic, 'NFDataX') -- Define a synthesis domain with a clock with a period of 20000 /ps/. 'createDomain' 'vSystem'{vName=\"Input\", vPeriod=20000} diff --git a/src/Clash/XException.hs b/src/Clash/XException.hs --- a/src/Clash/XException.hs +++ b/src/Clash/XException.hs @@ -15,18 +15,15 @@ "(X,4)" -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE Trustworthy #-} @@ -34,35 +31,50 @@ module Clash.XException ( -- * 'X': An exception for uninitialized values - XException(..), errorX, isX, hasX, maybeIsX, maybeHasX + XException(..), errorX, isX, hasX, maybeIsX, maybeHasX, fromJustX, undefined -- * Printing 'X' exceptions as \"X\" , ShowX (..), showsX, printX, showsPrecXWith -- * Strict evaluation - , seqX, forceX, deepseqX, rwhnfX, defaultSeqX + , seqX, forceX, deepseqX, rwhnfX, defaultSeqX, hwSeqX -- * Structured undefined / deep evaluation with undefined values - , NFDataX (rnfX, deepErrorX) + , NFDataX (rnfX, deepErrorX, hasUndefined, ensureSpine) ) where -import Control.Exception (Exception, catch, evaluate, throw) -import Control.DeepSeq (NFData, rnf) -import Data.Complex (Complex) -import Data.Either (isLeft) -import Data.Foldable (toList) -import Data.Int (Int8,Int16,Int32,Int64) -import Data.Ord (Down (Down)) -import Data.Ratio (Ratio, numerator, denominator) -import qualified Data.Semigroup as SG -import Data.Sequence (Seq(Empty, (:<|))) -import Data.Word (Word8,Word16,Word32,Word64) -import GHC.Exts (Char (C#), Double (D#), Float (F#), Int (I#), Word (W#)) -import GHC.Generics -import GHC.Natural (Natural) -import GHC.Show (appPrec) -import GHC.Stack (HasCallStack, callStack, prettyCallStack, withFrozenCallStack) -import Numeric.Half (Half) -import System.IO.Unsafe (unsafeDupablePerformIO) +import Prelude hiding (undefined) +import Clash.Annotations.Primitive (hasBlackBox) +import Clash.CPP (maxTupleSize, fSuperStrict) +import Clash.XException.TH +import Control.Exception (Exception, catch, evaluate, throw) +import Control.DeepSeq (NFData, rnf) +import Data.Complex (Complex) +import Data.Either (isLeft) +import Data.Foldable (toList) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Ord (Down (Down)) +import Data.Ratio (Ratio, numerator, denominator) +import qualified Data.Semigroup as SG +import Data.Sequence (Seq(Empty, (:<|))) +import Data.Word (Word8, Word16, Word32, Word64) +import Foreign.C.Types (CUShort) +import GHC.Exts + (Char (C#), Double (D#), Float (F#), Int (I#), Word (W#)) +import GHC.Generics +import GHC.Natural (Natural) +import GHC.Show (appPrec) +import GHC.Stack + (HasCallStack, callStack, prettyCallStack, withFrozenCallStack) +import Numeric.Half (Half) +import System.IO.Unsafe (unsafeDupablePerformIO) + +-- $setup +-- >>> import Clash.Class.BitPack (pack) +-- >>> import Clash.Sized.Vector (Vec) +-- >>> import Clash.Sized.RTree (RTree) +-- >>> :set -fplugin GHC.TypeLits.Normalise +-- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver + -- | An exception representing an \"uninitialized\" value. newtype XException = XException String @@ -75,11 +87,7 @@ -- '-fsuper-strict'. If enabled, 'defaultSeqX' will be 'deepseqX', otherwise -- 'seqX'. Flag defaults to /false/ and thus 'seqX'. defaultSeqX :: NFDataX a => a -> b -> b -#ifdef CLASH_SUPER_STRICT -defaultSeqX = deepseqX -#else -defaultSeqX = seqX -#endif +defaultSeqX = if fSuperStrict then deepseqX else seqX {-# INLINE defaultSeqX #-} -- | Like 'error', but throwing an 'XException' instead of an 'ErrorCall' @@ -103,6 +111,25 @@ {-# NOINLINE seqX #-} infixr 0 `seqX` +-- | Like 'seqX' in simulation, but will force its first argument to be rendered +-- in HDL. This is useful for components that need to be rendered in hardware, +-- but otherwise have no meaning in simulation. An example of such a component +-- would be an ILA: a component monitoring an internal signal of a design. The +-- output of such a component (typically a unit) can be passed as the first +-- argument to 'hwSeqX' to ensure the ILA ends up in the generated HDL. +-- +-- __NB__: the result of 'hwSeqX' must (indirectly) be used at the very top of +-- a design. If it's not, Clash will remove it like it does for any other unused +-- circuit parts. +-- +-- __NB__: Make sure the blackbox for the component with zero-width results +-- uses 'Clash.Netlist.BlackBox.Types.RenderVoid' +hwSeqX :: a -> b -> b +hwSeqX = seqX +{-# NOINLINE hwSeqX #-} +{-# ANN hwSeqX hasBlackBox #-} +infixr 0 `hwSeqX` + -- | Evaluate a value with given function, returning 'Nothing' if it throws -- 'XException'. -- @@ -118,7 +145,7 @@ -- > maybeX isX (3, _|_) = Just (3, _|_) -- > maybeX isX _|_ = _|_ -- -maybeX :: NFData a => (a -> Either String a) -> a -> Maybe a +maybeX :: (a -> Either String a) -> a -> Maybe a maybeX f a = either (const Nothing) Just (f a) -- | Fully evaluate a value, returning 'Nothing' if it throws 'XException'. @@ -139,10 +166,12 @@ -- > maybeIsX (3, XException msg) = Just (3, XException msg) -- > maybeIsX (3, _|_) = Just (3, _|_) -- > maybeIsX _|_ = _|_ -maybeIsX :: NFData a => a -> Maybe a +maybeIsX :: a -> Maybe a maybeIsX = maybeX isX -- | Fully evaluate a value, returning @'Left' msg@ if it throws 'XException'. +-- If you want to determine if a value contains undefined parts, use +-- 'hasUndefined' instead. -- -- > hasX 42 = Right 42 -- > hasX (XException msg) = Left msg @@ -263,42 +292,7 @@ genericShowsPrecX n = gshowsPrecX Pref n . from instance ShowX () -instance (ShowX a, ShowX b) => ShowX (a,b) -instance (ShowX a, ShowX b, ShowX c) => ShowX (a,b,c) -instance (ShowX a, ShowX b, ShowX c, ShowX d) => ShowX (a,b,c,d) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e) => ShowX (a,b,c,d,e) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f) => ShowX (a,b,c,d,e,f) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g) => ShowX (a,b,c,d,e,f,g) --- Show is defined up to 15-tuples, but GHC.Generics only has Generic instances --- up to 7-tuples, hence we need these orphan instances. -deriving instance Generic ((,,,,,,,) a b c d e f g h) -deriving instance Generic ((,,,,,,,,) a b c d e f g h i) -deriving instance Generic ((,,,,,,,,,) a b c d e f g h i j) -deriving instance Generic ((,,,,,,,,,,) a b c d e f g h i j k) -deriving instance Generic ((,,,,,,,,,,,) a b c d e f g h i j k l) -deriving instance Generic ((,,,,,,,,,,,,) a b c d e f g h i j k l m) -deriving instance Generic ((,,,,,,,,,,,,,) a b c d e f g h i j k l m n) -deriving instance Generic ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o) - -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h) => ShowX (a,b,c,d,e,f,g,h) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i) => ShowX (a,b,c,d,e,f,g,h,i) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j) - => ShowX (a,b,c,d,e,f,g,h,i,j) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k) - => ShowX (a,b,c,d,e,f,g,h,i,j,k) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l) - => ShowX (a,b,c,d,e,f,g,h,i,j,k,l) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l - ,ShowX m) - => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l - ,ShowX m, ShowX n) - => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l - ,ShowX m, ShowX n, ShowX o) - => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) - instance {-# OVERLAPPABLE #-} ShowX a => ShowX [a] where showsPrecX _ = showListX @@ -527,6 +521,34 @@ instance (NFDataX1 f, GNFDataX One g) => GNFDataX One (f :.: g) where grnfX args = liftRnfX (grnfX args) . unComp1 +class GEnsureSpine f where + gEnsureSpine :: f a -> f a + +instance GEnsureSpine U1 where + gEnsureSpine _u = U1 + +instance NFDataX a => GEnsureSpine (K1 i a) where + gEnsureSpine = K1 . ensureSpine . unK1 + {-# INLINEABLE gEnsureSpine #-} + +instance GEnsureSpine a => GEnsureSpine (M1 i c a) where + gEnsureSpine a = M1 (gEnsureSpine (unM1 a)) + {-# INLINEABLE gEnsureSpine #-} + +instance (GEnsureSpine a, GEnsureSpine b) => GEnsureSpine (a :*: b) where + gEnsureSpine ~(x :*: y) = gEnsureSpine x :*: gEnsureSpine y + {-# INLINEABLE gEnsureSpine #-} + +instance (GEnsureSpine a, GEnsureSpine b) => GEnsureSpine (a :+: b) where + gEnsureSpine lrx = + case lrx of + (L1 x) -> L1 (gEnsureSpine x) + (R1 x) -> R1 (gEnsureSpine x) + {-# INLINEABLE gEnsureSpine #-} + +instance GEnsureSpine V1 where + gEnsureSpine _ = error "Unreachable code?" + -- | A class of functors that can be fully evaluated, according to semantics -- of NFDataX. class NFDataX1 f where @@ -540,6 +562,47 @@ default liftRnfX :: (Generic1 f, GNFDataX One (Rep1 f)) => (a -> ()) -> f a -> () liftRnfX r = grnfX (RnfArgs1 r) . from1 + +class GHasUndefined f where + gHasUndefined :: f a -> Bool + +instance GHasUndefined U1 where + gHasUndefined u = if isLeft (isX u) then True else case u of U1 -> False + +instance NFDataX a => GHasUndefined (K1 i a) where + gHasUndefined = hasUndefined . unK1 + {-# INLINEABLE gHasUndefined #-} + +instance GHasUndefined a => GHasUndefined (M1 i c a) where + gHasUndefined a = + -- Check for X needed to handle edge-case "data Void" + if isLeft (isX a) then + True + else + gHasUndefined (unM1 a) + {-# INLINEABLE gHasUndefined #-} + +instance (GHasUndefined a, GHasUndefined b) => GHasUndefined (a :*: b) where + gHasUndefined xy@(~(x :*: y)) = + if isLeft (isX xy) then + True + else + gHasUndefined x || gHasUndefined y + {-# INLINEABLE gHasUndefined #-} + +instance (GHasUndefined a, GHasUndefined b) => GHasUndefined (a :+: b) where + gHasUndefined lrx = + if isLeft (isX lrx) then + True + else + case lrx of + L1 x -> gHasUndefined x + R1 x -> gHasUndefined x + {-# INLINEABLE gHasUndefined #-} + +instance GHasUndefined V1 where + gHasUndefined _ = error "Unreachable code?" + -- | Class that houses functions dealing with /undefined/ values in Clash. See -- 'deepErrorX' and 'rnfX'. class NFDataX a where @@ -550,6 +613,40 @@ default deepErrorX :: (HasCallStack, Generic a, GDeepErrorX (Rep a)) => String -> a deepErrorX = withFrozenCallStack $ to . gDeepErrorX + -- | Determines whether any of parts of a given construct contain undefined + -- parts. Note that a negative answer does not mean its bit representation + -- is fully defined. For example: + -- + -- >>> m = Nothing :: Maybe Bool + -- >>> hasUndefined m + -- False + -- >>> pack m + -- 0. + -- >>> hasUndefined (pack m) + -- True + -- + hasUndefined :: a -> Bool + + default hasUndefined :: (Generic a, GHasUndefined (Rep a)) => a -> Bool + hasUndefined = gHasUndefined . from + + -- | Create a value where at the very least the spine is defined. For example: + -- + -- >>> spined = ensureSpine (errorX "?" :: (Int, Int)) + -- >>> case spined of (_, _) -> 'a' + -- 'a' + -- >>> fmap (const 'b') (ensureSpine undefined :: Vec 3 Int) + -- <'b','b','b'> + -- >>> fmap (const 'c') (ensureSpine undefined :: RTree 2 Int) + -- <<'c','c'>,<'c','c'>> + -- + -- For users familiar with 'Clash.Sized.Vector.lazyV': this is the generalized + -- version of it. + ensureSpine :: a -> a + + default ensureSpine :: (Generic a, GEnsureSpine (Rep a)) => a -> a + ensureSpine = to . gEnsureSpine . from + -- | Evaluate a value to NF. As opposed to 'NFData's 'rnf', it does not bubble -- up 'XException's. rnfX :: a -> () @@ -558,52 +655,18 @@ rnfX = grnfX RnfArgs0 . from instance NFDataX () -instance (NFDataX a, NFDataX b) => NFDataX (a,b) -instance (NFDataX a, NFDataX b, NFDataX c) => NFDataX (a,b,c) -instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d) => NFDataX (a,b,c,d) -instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e) => NFDataX (a,b,c,d,e) -instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e ,NFDataX f) - => NFDataX (a,b,c,d,e,f) -instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e - ,NFDataX f, NFDataX g) - => NFDataX (a,b,c,d,e,f,g) -instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e - ,NFDataX f, NFDataX g, NFDataX h) - => NFDataX (a,b,c,d,e,f,g,h) -instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e - ,NFDataX f, NFDataX g, NFDataX h, NFDataX i) - => NFDataX (a,b,c,d,e,f,g,h,i) -instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e - ,NFDataX f, NFDataX g, NFDataX h, NFDataX i, NFDataX j) - => NFDataX (a,b,c,d,e,f,g,h,i,j) -instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e - ,NFDataX f, NFDataX g, NFDataX h, NFDataX i, NFDataX j - ,NFDataX k) - => NFDataX (a,b,c,d,e,f,g,h,i,j,k) -instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e - ,NFDataX f, NFDataX g, NFDataX h, NFDataX i, NFDataX j - ,NFDataX k, NFDataX l) - => NFDataX (a,b,c,d,e,f,g,h,i,j,k,l) -instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e - ,NFDataX f, NFDataX g, NFDataX h, NFDataX i, NFDataX j - ,NFDataX k, NFDataX l, NFDataX m) - => NFDataX (a,b,c,d,e,f,g,h,i,j,k,l,m) -instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e - ,NFDataX f, NFDataX g, NFDataX h, NFDataX i, NFDataX j - ,NFDataX k, NFDataX l, NFDataX m, NFDataX n) - => NFDataX (a,b,c,d,e,f,g,h,i,j,k,l,m,n) -instance (NFDataX a, NFDataX b, NFDataX c, NFDataX d, NFDataX e - ,NFDataX f, NFDataX g, NFDataX h, NFDataX i, NFDataX j - ,NFDataX k, NFDataX l, NFDataX m, NFDataX n, NFDataX o) - => NFDataX (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) instance NFDataX b => NFDataX (a -> b) where deepErrorX = pure . deepErrorX rnfX = rwhnfX + hasUndefined = error "hasUndefined on Undefined (a -> b): Not Yet Implemented" + ensureSpine = id instance NFDataX a => NFDataX (Down a) where deepErrorX = Down . deepErrorX rnfX d@(~(Down x)) = if isLeft (isX d) then () else rnfX x + hasUndefined d@(~(Down x))= if isLeft (isX d) then True else hasUndefined x + ensureSpine ~(Down x) = Down (ensureSpine x) instance NFDataX Bool instance NFDataX a => NFDataX [a] @@ -613,66 +676,104 @@ instance NFDataX Char where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Double where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Float where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Int where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Int8 where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Int16 where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Int32 where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Int64 where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Integer where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Natural where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Word where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Word8 where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Word16 where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Word32 where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX Word64 where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id +instance NFDataX CUShort where + deepErrorX = errorX + rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id + instance NFDataX Half where deepErrorX = errorX rnfX = rwhnfX + hasUndefined = isLeft . isX + ensureSpine = id instance NFDataX a => NFDataX (Seq a) where deepErrorX = errorX @@ -681,10 +782,19 @@ where go Empty = () go (x :<| xs) = rnfX x `seq` go xs + ensureSpine = id + hasUndefined s = + if isLeft (isX s) then True else go s + where + go Empty = False + go (x :<| xs) = hasUndefined x || hasUndefined xs + instance NFDataX a => NFDataX (Ratio a) where deepErrorX = errorX rnfX r = rnfX (numerator r) `seq` rnfX (denominator r) + hasUndefined r = isLeft (isX (numerator r)) || isLeft (isX (denominator r)) + ensureSpine = id instance NFDataX a => NFDataX (Complex a) where deepErrorX = errorX @@ -722,3 +832,15 @@ instance GDeepErrorX (f :+: g) where gDeepErrorX = errorX + +mkShowXTupleInstances [2..maxTupleSize] +mkNFDataXTupleInstances [2..maxTupleSize] + +undefined :: HasCallStack => a +undefined = errorX "undefined" + +-- | Same as "Data.Maybe.fromJust", but returns a bottom/undefined value that +-- other Clash constructs are aware of. +fromJustX :: HasCallStack => Maybe a -> a +fromJustX Nothing = errorX "isJustX: Nothing" +fromJustX (Just a) = a diff --git a/src/Clash/XException/TH.hs b/src/Clash/XException/TH.hs new file mode 100644 --- /dev/null +++ b/src/Clash/XException/TH.hs @@ -0,0 +1,155 @@ +{-| +Copyright : (C) 2019, Myrtle Software Ltd +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Clash.XException.TH + ( mkShowXTupleInstances + , mkNFDataXTupleInstances + ) where + +import Data.Either (isLeft) +import Data.List (intersperse) +import Language.Haskell.TH.Syntax + +-- Spliced in in XException, so these names should be in scope: +isXName, hasUndefinedName, deepErrorXName, rnfXName, ensureSpineName :: Name +isXName = mkName "isX" +hasUndefinedName = mkName "hasUndefined" +deepErrorXName = mkName "deepErrorX" +rnfXName = mkName "rnfX" +ensureSpineName = mkName "ensureSpine" + +showxName :: Name +showxName = mkName "ShowX" + +showXFnName :: Name +showXFnName = mkName "showX" + +showsPrecXName :: Name +showsPrecXName = mkName "showsPrecX" + +nfdataxName :: Name +nfdataxName = mkName "NFDataX" + +mkTup :: [Type] -> Type +mkTup names@(length -> n) = + foldl AppT (TupleT n) names + +-- | Creates an instance of the form: +-- +-- instance (ShowX a0, ShowX a1) => ShowX (a0, a1) +-- +-- With /n/ number of variables. +mkShowXTupleInstance :: Int -> Dec +mkShowXTupleInstance n = + InstanceD Nothing constraints instanceTyp [showsPrecXDecl, showXDecl] + where + constraints = fmap (AppT (ConT showxName)) vars + instanceTyp = ConT showxName `AppT` mkTup vars + names = fmap (mkName . ('a':) . show) [0..n-1] + vars = fmap VarT names + + x = mkName "x" + s = mkName "s" + + showsPrecXDecl = FunD showsPrecXName + [ Clause + [WildP, VarP x, VarP s] + (NormalB + (VarE 'mappend `AppE` (VarE showXFnName `AppE` VarE x) `AppE` VarE s)) + [] + ] + + showXDecl = FunD showXFnName + [ Clause + [TupP (fmap VarP names)] + (NormalB + (VarE 'mconcat `AppE` (ListE + ([LitE (StringL "(")] + <> intersperse (LitE (StringL ",")) (fmap toShowX names) + <> [LitE (StringL ")")])))) + [] + ] + where + toShowX a = VarE showXFnName `AppE` VarE a + +-- | Creates instances of ShowX for all tuple sizes listed. +-- See 'mkShowXTupleInstance' for more information. +mkShowXTupleInstances :: [Int] -> Q [Dec] +mkShowXTupleInstances tupSizes = + return (fmap mkShowXTupleInstance tupSizes) + +-- | Creates an instance of the form: +-- +-- instance (NFDataX a0, NFDataX a1) => NFDataX (a0, a1) +-- +-- With /n/ number of variables. +mkNFDataXTupleInstance :: Int -> Dec +mkNFDataXTupleInstance n = + InstanceD + Nothing + constraints + instanceTyp + [ ensureSpineDecl + , hasUndefinedDecl + , deepErrorXDecl + , rnfXDecl + ] + where + constraints = map (AppT (ConT nfdataxName)) vars + instanceTyp = ConT nfdataxName `AppT` mkTup vars + names = map (mkName . ('a':) . show) [0..n-1] + vars = map VarT names + + t = mkName "t" + s = mkName "s" + + rnfXDecl = FunD rnfXName [ + Clause + [AsP t (TildeP (TupP (map VarP names)))] + (NormalB ( + CondE + (VarE 'isLeft `AppE` (VarE isXName `AppE` VarE t)) + (TupE []) + (foldl + (\e1 e2 -> UInfixE e1 (VarE 'seq) (VarE rnfXName `AppE` e2)) + (VarE rnfXName `AppE` VarE (head names)) + (map VarE (tail names))) + )) + [] + ] + + hasUndefinedDecl = FunD hasUndefinedName [ + Clause + [AsP t (TildeP (TupP (map VarP names)))] + (NormalB ( + CondE + (VarE 'isLeft `AppE` (VarE isXName `AppE` VarE t)) + (ConE 'True) + (VarE 'or `AppE` ListE + (map ((VarE hasUndefinedName `AppE`) . VarE) names)) + )) + [] + ] + + ensureSpineDecl = FunD ensureSpineName [ + Clause + [TildeP (TupP (map VarP names))] + (NormalB (TupE (map (AppE (VarE ensureSpineName) . VarE) names))) + [] + ] + + deepErrorXDecl = FunD deepErrorXName [ + Clause + [VarP s] + (NormalB (TupE (replicate n (VarE deepErrorXName `AppE` VarE s)))) + [] + ] + +mkNFDataXTupleInstances :: [Int] -> Q [Dec] +mkNFDataXTupleInstances tupSizes = + pure (map mkNFDataXTupleInstance tupSizes) diff --git a/src/Clash/Xilinx/ClockGen.hs b/src/Clash/Xilinx/ClockGen.hs --- a/src/Clash/Xilinx/ClockGen.hs +++ b/src/Clash/Xilinx/ClockGen.hs @@ -6,11 +6,9 @@ PLL and other clock-related components for Xilinx FPGAs -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} + module Clash.Xilinx.ClockGen where import Clash.Annotations.Primitive (hasBlackBox) diff --git a/src/Clash/Xilinx/DDR.hs b/src/Clash/Xilinx/DDR.hs --- a/src/Clash/Xilinx/DDR.hs +++ b/src/Clash/Xilinx/DDR.hs @@ -14,15 +14,9 @@ -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE NoStarIsType #-} -#endif +{-# LANGUAGE TypeFamilies #-} module Clash.Xilinx.DDR ( iddr diff --git a/src/Language/Haskell/TH/Compat.hs b/src/Language/Haskell/TH/Compat.hs --- a/src/Language/Haskell/TH/Compat.hs +++ b/src/Language/Haskell/TH/Compat.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + module Language.Haskell.TH.Compat where import Language.Haskell.TH diff --git a/tests/Clash/Tests/AutoReg.hs b/tests/Clash/Tests/AutoReg.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/AutoReg.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Clash.Tests.AutoReg where + +import Test.Tasty +import Test.Tasty.QuickCheck +import qualified Data.List as L +import Clash.Prelude +import Clash.Class.AutoReg (AutoReg) + +test :: (Eq a, Show a, AutoReg a, Arbitrary a) => a -> [a] -> Property +test initVal xs = testFor (L.length xs) $ register initVal input .==. autoReg initVal input + where input = fromList @_ @System xs + +tests :: TestTree +tests = + testGroup + "AutoReg" + [ testGroup "autoReg === register" + [ testProperty "Int" $ test @Int + , testProperty "(Unsigned 4, Bool)" $ test @(Unsigned 4, Bool) + , testProperty "Maybe Bool" $ test @(Maybe Bool) + -- , testProperty "Either Bool (Unsigned 3)" $ test @(Either Bool (Unsigned 3)) + + , testProperty "Vec 4 Bool" $ test @(Vec 4 Bool) + , testProperty "Vec 4 (Maybe Bool)" $ test @(Vec 4 (Maybe Bool)) + + , testProperty "Maybe (Vec 4 Bool)" $ test @(Maybe (Vec 4 Bool)) + , testProperty "Maybe (Maybe (Vec 4 Bool))" $ test @(Maybe (Maybe (Vec 4 Bool))) + + , testProperty "RTree 2 Bool" $ test @(RTree 2 Bool) + , testProperty "Maybe (RTree 2 Bool)" $ test @(Maybe (RTree 2 Bool)) + , testProperty "Maybe (Maybe (RTree 2 Bool))" $ test @(Maybe (Maybe (RTree 2 Bool))) + + , testProperty "Maybe (Vec 4 (Maybe (Vec 3 Bool)))" $ test @(Maybe (Vec 4 (Maybe (Vec 3 Bool)))) + ] + ] diff --git a/tests/Clash/Tests/BitPack.hs b/tests/Clash/Tests/BitPack.hs --- a/tests/Clash/Tests/BitPack.hs +++ b/tests/Clash/Tests/BitPack.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-} diff --git a/tests/Clash/Tests/BitVector.hs b/tests/Clash/Tests/BitVector.hs --- a/tests/Clash/Tests/BitVector.hs +++ b/tests/Clash/Tests/BitVector.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} module Clash.Tests.BitVector where +import Data.Proxy +import GHC.TypeNats (KnownNat, SomeNat (..), natVal, someNatVal) import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.QuickCheck -import Clash.Prelude (BitVector, bitPattern) +import Clash.Prelude (bitPattern) +import Clash.Sized.Internal.BitVector (BitVector (..)) +import Clash.Tests.SizedNum + test1 :: BitVector 8 -> Int test1 = \case @@ -22,8 +25,8 @@ _ -> 5 -- To keep exhaustiveness checker happy tests :: TestTree -tests = - testGroup +tests = localOption (QuickCheckMaxRatio 2) $ testGroup "All" + [ testGroup "bitPattern" [ testCase "case0-0" $ test1 0b00000000 @?= 0 , testCase "case0-1" $ test1 0b00011001 @?= 0 @@ -35,4 +38,28 @@ , testCase "case3-1" $ test1 0b11111111 @?= 4 , testCase "case3-2" $ test1 0b11010110 @?= 4 ] + , testGroup "BitVector 1" $ + testProperty "fromInteger" + (fromIntegerProp (Proxy :: Proxy 1)) : + map lawsToTest (laws1 (Proxy :: Proxy (BitVector 1))) + , testGroup "BitVector 21" $ + testProperty "fromInteger" + (fromIntegerProp (Proxy :: Proxy 21)) : + map lawsToTest (laws (Proxy :: Proxy (BitVector 21))) + , testGroup "BitVector 83" $ + testProperty "fromInteger" + (fromIntegerProp (Proxy :: Proxy 83)) : + map lawsToTest (laws (Proxy :: Proxy (BitVector 83))) + , testGroup "Random BitVector" + [ testProperty "fromInteger" fromIntegerRandomProp ] + ] +fromIntegerProp :: forall m. KnownNat m => Proxy m -> Integer -> Property +fromIntegerProp p n = unsafeToInteger m === fromInteger (n `mod` (2 ^ toInteger (natVal p))) + where + m :: BitVector m + m = fromInteger n + +fromIntegerRandomProp :: Positive Integer -> Integer -> Property +fromIntegerRandomProp (Positive m) n = m > 1 ==> case someNatVal (fromInteger m) of + SomeNat p -> fromIntegerProp p n diff --git a/tests/Clash/Tests/DerivingDataRepr.hs b/tests/Clash/Tests/DerivingDataRepr.hs --- a/tests/Clash/Tests/DerivingDataRepr.hs +++ b/tests/Clash/Tests/DerivingDataRepr.hs @@ -1,10 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE BinaryLiterals #-} module Clash.Tests.DerivingDataRepr where diff --git a/tests/Clash/Tests/DerivingDataReprTypes.hs b/tests/Clash/Tests/DerivingDataReprTypes.hs --- a/tests/Clash/Tests/DerivingDataReprTypes.hs +++ b/tests/Clash/Tests/DerivingDataReprTypes.hs @@ -1,7 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} module Clash.Tests.DerivingDataReprTypes where diff --git a/tests/Clash/Tests/NFDataX.hs b/tests/Clash/Tests/NFDataX.hs --- a/tests/Clash/Tests/NFDataX.hs +++ b/tests/Clash/Tests/NFDataX.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MagicHash #-} module Clash.Tests.NFDataX where @@ -9,20 +7,30 @@ import Test.Tasty.HUnit import GHC.Generics (Generic) -import Clash.XException (NFDataX(rnfX), errorX) +import Clash.Class.BitPack (pack) +import Clash.Sized.Vector (Vec(..)) +import Clash.XException + (NFDataX(rnfX, hasUndefined, deepErrorX), errorX, ensureSpine) import Data.Ord (Down (Down)) -data Void deriving (Generic, NFDataX) -data Unit = Unit deriving (Generic, NFDataX) -data Wrapper = Wrapper Int deriving (Generic, NFDataX) -data Sum = SumTypeA | SumTypeB deriving (Generic, NFDataX) -data BigSum = BS1 | BS2 | BS3 | BS4 | BS5 deriving (Generic, NFDataX) -data Product = Product Int Int deriving (Generic, NFDataX) -data SP = S Int Int | P Int deriving (Generic, NFDataX) -data Rec0 = Rec0 { } deriving (Generic, NFDataX) -data Rec1 = Rec1 { a :: Int } deriving (Generic, NFDataX) -data Rec2 = Rec2 { b :: Int, c :: Int } deriving (Generic, NFDataX) +data Void deriving (Generic, NFDataX) +data Unit = Unit deriving (Generic, NFDataX) +data Wrapper = Wrapper Int deriving (Generic, NFDataX) +data Sum = SumTypeA | SumTypeB deriving (Generic, NFDataX) +data BigSum = BS1 | BS2 | BS3 | BS4 | BS5 deriving (Generic, NFDataX) +data Product = Product Int Int deriving (Generic, NFDataX) +data SP = S Int Int | P Int deriving (Generic, NFDataX) +data Rec0 = Rec0 { } deriving (Generic, NFDataX) +data Rec1 = Rec1 { a :: Int } deriving (Generic, NFDataX) +data Rec2 = Rec2 { b :: Int, c :: Int } deriving (Generic, NFDataX) +data ProductRec = ProductRec Rec1 (Unit, Sum) deriving (Generic, NFDataX) +sundef :: NFDataX a => a +sundef = ensureSpine undef + +dundef :: NFDataX a => a +dundef = deepErrorX "!" + undef :: a undef = errorX "!" {-# NOINLINE undef #-} @@ -32,7 +40,7 @@ testGroup "NFDataX" [ testGroup - "Generic" + "GenericRnf" [ testCase "Unit" $ rnfX (undef :: Unit) @?= () , testCase "Wrapper1" $ rnfX (undef :: Wrapper) @?= () , testCase "Wrapper2" $ rnfX (Wrapper undef) @?= () @@ -53,11 +61,40 @@ , testCase "Rec2_1" $ rnfX (undef :: Rec2) @?= () , testCase "Rec2_2" $ rnfX (Rec2 3 undef) @?= () , testCase "Rec2_3" $ rnfX (Rec2 undef 5) @?= () --- Test case broken on 8.2.2: --- , testCase "Void" $ rnfX (undef :: Void) @?= () + , testCase "Void" $ rnfX (undef :: Void) @?= () ] , testGroup - "Manual" + "Tuples" + [ -- Test Template Haskell generated hasUndefined instance for tuples + testCase "HU1" $ hasUndefined (undef :: (Int, Int)) @?= True + , testCase "HU3" $ hasUndefined ((undef, undef) :: (Int, Int)) @?= True + , testCase "HU2" $ hasUndefined ((undef, 1) :: (Int, Int)) @?= True + , testCase "HU4" $ hasUndefined ((1, undef) :: (Int, Int)) @?= True + , testCase "HU4" $ hasUndefined ((1, 2) :: (Int, Int)) @?= False + , testCase "HU5" $ hasUndefined ((undef, 1) :: (Rec2, Int)) @?= True + , testCase "HU6" $ hasUndefined ((Rec2 undef undef, 1) :: (Rec2, Int)) @?= True + , testCase "HU7" $ hasUndefined ((Rec2 1 undef, 1) :: (Rec2, Int)) @?= True + , testCase "HU8" $ hasUndefined ((Rec2 1 1, 1) :: (Rec2, Int)) @?= False + + -- Test Template Haskell generated rnfX instance for tuples + , testCase "RnfX1" $ rnfX (undef :: (Int, Int)) @?= () + , testCase "RnfX3" $ rnfX ((undef, undef) :: (Int, Int)) @?= () + , testCase "RnfX2" $ rnfX ((undef, 1) :: (Int, Int)) @?= () + , testCase "RnfX4" $ rnfX ((1, undef) :: (Int, Int)) @?= () + , testCase "RnfX4" $ rnfX ((1, 2) :: (Int, Int)) @?= () + , testCase "RnfX5" $ rnfX ((undef, 1) :: (Rec2, Int)) @?= () + , testCase "RnfX6" $ rnfX ((Rec2 undef undef, 1) :: (Rec2, Int)) @?= () + , testCase "RnfX7" $ rnfX ((Rec2 1 undef, 1) :: (Rec2, Int)) @?= () + , testCase "RnfX8" $ rnfX ((Rec2 1 1, 1) :: (Rec2, Int)) @?= () + + -- Test Template Haskell generated deepErrorX/ensureSpine instance for tuples + , testCase "DU" $ case dundef @(Unit, Unit) of (Unit, Unit) -> () @?= () + , testCase "ES1" $ case ensureSpine undef of () -> () @?= () + , testCase "ES1" $ case ensureSpine undef of ((), ()) -> () @?= () + , testCase "ES2" $ case ensureSpine @(Unit, Unit) undef of (Unit, Unit) -> () @?= () + ] + , testGroup + "ManualRnf" [ testCase "List1" $ rnfX (undef :: [Int]) @?= () , testCase "List2" $ rnfX ([undef] :: [Int]) @?= () , testCase "Maybe1" $ rnfX (undef :: Maybe Int) @?= () @@ -67,6 +104,72 @@ , testCase "Either3" $ rnfX (Right undef :: Either Int Int) @?= () , testCase "Down1" $ rnfX (Down undef :: Down Int) @?= () , testCase "Down2" $ rnfX (undef :: Down Int) @?= () + ] + , testGroup + "GenericHasUndefinedTrue" + [ testCase "Unit" $ hasUndefined (undef :: Unit) @?= True + , testCase "Wrapper1" $ hasUndefined (undef :: Wrapper) @?= True + , testCase "Wrapper2" $ hasUndefined (Wrapper undef) @?= True + , testCase "Sum" $ hasUndefined (undef :: Sum) @?= True + , testCase "BigSum" $ hasUndefined (undef :: BigSum) @?= True + , testCase "Product1" $ hasUndefined (undef :: Product) @?= True + , testCase "Product2" $ hasUndefined (Product undef undef :: Product) @?= True + , testCase "Product3" $ hasUndefined (Product 3 undef :: Product) @?= True + , testCase "Product4" $ hasUndefined (Product undef 5 :: Product) @?= True + , testCase "SP1" $ hasUndefined (undef :: SP) @?= True + , testCase "SP2" $ hasUndefined (S undef undef :: SP) @?= True + , testCase "SP3" $ hasUndefined (S 3 undef :: SP) @?= True + , testCase "SP3" $ hasUndefined (S undef 5 :: SP) @?= True + , testCase "SP4" $ hasUndefined (P undef :: SP) @?= True + , testCase "Rec0" $ hasUndefined (undef :: Rec0) @?= True + , testCase "Rec1_1" $ hasUndefined (undef :: Rec1) @?= True + , testCase "Rec1_2" $ hasUndefined (Rec1 undef) @?= True + , testCase "Rec2_1" $ hasUndefined (undef :: Rec2) @?= True + , testCase "Rec2_2" $ hasUndefined (Rec2 3 undef) @?= True + , testCase "Rec2_3" $ hasUndefined (Rec2 undef 5) @?= True + , testCase "Void" $ hasUndefined (undef :: Void) @?= True + ] + , testGroup + "GenericHasUndefinedFalse" + [ testCase "Unit" $ hasUndefined () @?= False + , testCase "Wrapper" $ hasUndefined (Wrapper 0:: Wrapper) @?= False + , testCase "SumA" $ hasUndefined (SumTypeA :: Sum) @?= False + , testCase "SumB" $ hasUndefined (SumTypeB :: Sum) @?= False + , testCase "BigSum1" $ hasUndefined (BS1 :: BigSum) @?= False + , testCase "BigSum2" $ hasUndefined (BS2 :: BigSum) @?= False + , testCase "BigSum3" $ hasUndefined (BS3 :: BigSum) @?= False + , testCase "BigSum4" $ hasUndefined (BS4 :: BigSum) @?= False + , testCase "BigSum5" $ hasUndefined (BS5 :: BigSum) @?= False + , testCase "Product" $ hasUndefined (Product 3 5 :: Product) @?= False + , testCase "SP1" $ hasUndefined (S 3 5 :: SP) @?= False + , testCase "SP2" $ hasUndefined (P 5 :: SP) @?= False + , testCase "Rec2_3" $ hasUndefined (Rec2 3 5) @?= False + ] + , testGroup + "ManualHasUndefined" + [ testCase "Vec1" $ hasUndefined (3 :> errorX "X" :: Vec 5 Int) @?= True + , testCase "Vec2" $ hasUndefined (errorX "X" :: Vec 5 Int) @?= True + , testCase "Maybe" $ hasUndefined (Nothing :: Maybe Bool) @?= False + , testCase "BitVector1" $ hasUndefined (pack (Nothing :: Maybe Bool)) @?= True + , testCase "BitVector2" $ hasUndefined (pack (Just True:: Maybe Bool)) @?= False + ] + , testGroup + "GenericDeepErrorX" + [ testCase "Unit" $ case dundef @Unit of Unit -> () @?= () + , testCase "Wrapper1" $ case dundef @Wrapper of Wrapper _ -> () @?= () + , testCase "Product1" $ case dundef @Product of Product _ _ -> () @?= () + , testCase "Rec1_1" $ case dundef @Rec1 of Rec1 {} -> () @?= () + , testCase "Rec2_1" $ case dundef @Rec2 of Rec2 {} -> () @?= () + , testCase "ProductRec" $ case dundef @ProductRec of ProductRec (Rec1 _) (Unit, _) -> () @?= () + ] + , testGroup + "GenericEnsureSpine" + [ testCase "Unit" $ case sundef @Unit of Unit -> () @?= () + , testCase "Wrapper1" $ case sundef @Wrapper of Wrapper _ -> () @?= () + , testCase "Product1" $ case sundef @Product of Product _ _ -> () @?= () + , testCase "Rec1_1" $ case sundef @Rec1 of Rec1 {} -> () @?= () + , testCase "Rec2_1" $ case sundef @Rec2 of Rec2 {} -> () @?= () + , testCase "ProductRec" $ case sundef @ProductRec of ProductRec (Rec1 _) (Unit, _) -> () @?= () ] ] diff --git a/tests/Clash/Tests/Signal.hs b/tests/Clash/Tests/Signal.hs --- a/tests/Clash/Tests/Signal.hs +++ b/tests/Clash/Tests/Signal.hs @@ -4,11 +4,10 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} diff --git a/tests/Clash/Tests/Signed.hs b/tests/Clash/Tests/Signed.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/Signed.hs @@ -0,0 +1,43 @@ +module Clash.Tests.Signed (tests) where + +import Data.Proxy +import GHC.TypeNats (KnownNat, SomeNat (..), natVal, someNatVal) +import Test.Tasty +import Test.Tasty.QuickCheck + +import Clash.Sized.Internal.Signed +import Clash.Tests.SizedNum + +tests :: TestTree +tests = localOption (QuickCheckMaxRatio 2) $ testGroup "All" + [ testGroup "Signed 1" $ + testProperty "fromInteger" + (fromIntegerProp (Proxy :: Proxy 1)) : + map lawsToTest (laws1 (Proxy :: Proxy (Signed 1))) + , testGroup "Signed 21" $ + testProperty "fromInteger" + (fromIntegerProp (Proxy :: Proxy 21)) : + map lawsToTest (laws (Proxy :: Proxy (Signed 21))) + , testGroup "Signed 83" $ + testProperty "fromInteger" + (fromIntegerProp (Proxy :: Proxy 83)) : + map lawsToTest (laws (Proxy :: Proxy (Signed 83))) + , testGroup "Random Signed" + [ testProperty "fromInteger" fromIntegerRandomProp ] + ] + + +fromIntegerProp :: forall m. KnownNat m => Proxy m -> Integer -> Property +fromIntegerProp p n = unsafeToInteger m === fromInteger i + where + m :: Signed m + m = fromInteger n + + mb = 2 ^ (toInteger (natVal p) - 1) + i = case divMod n mb of + (d,r) | even d -> r + | otherwise -> r - mb + +fromIntegerRandomProp :: Positive Integer -> Integer -> Property +fromIntegerRandomProp (Positive m) n = m > 1 ==> case someNatVal (fromInteger m) of + SomeNat p -> fromIntegerProp p n diff --git a/tests/Clash/Tests/SizedNum.hs b/tests/Clash/Tests/SizedNum.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/SizedNum.hs @@ -0,0 +1,24 @@ +module Clash.Tests.SizedNum where + +import Data.Bits +import Data.Proxy +import Test.QuickCheck.Classes.Base +import Test.Tasty +import Test.Tasty.QuickCheck + +laws1 :: (Eq a, Ord a, Show a, Num a, Arbitrary a, Integral a, FiniteBits a) => Proxy a -> [Laws] +laws1 p = + [ eqLaws p + , ordLaws p + , numLaws p + , showLaws p + , integralLaws p + , bitsLaws p + ] + +laws :: (Eq a, Ord a, Show a, Num a, Enum a, Bounded a, Arbitrary a, Integral a, FiniteBits a) => Proxy a -> [Laws] +laws p = boundedEnumLaws p : laws1 p + +lawsToTest :: Laws -> TestTree +lawsToTest (Laws name props) = + testGroup name $ map (uncurry testProperty) props diff --git a/tests/Clash/Tests/TopEntityGeneration.hs b/tests/Clash/Tests/TopEntityGeneration.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/TopEntityGeneration.hs @@ -0,0 +1,324 @@ +{-# OPTIONS_GHC -Wwarn #-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Clash.Tests.TopEntityGeneration where + +import Language.Haskell.TH.Syntax (unTypeQ) + +import Test.Tasty +import Test.Tasty.HUnit + +import Clash.Prelude hiding (undefined) +import Clash.Annotations.TH + +type Pair a = ("left" ::: a, "right" ::: a) + +data Unnamed = Unnamed Int +data Simple = Simple ("simple1" ::: Int) ("simple2" ::: Bool) +data Named + = Named + { name1 :: "named1" ::: BitVector 3 + , name2 :: "named2" ::: BitVector 5 + } +data Embedded + = Embedded + { name3 :: "embedded1" ::: Simple + , name4 :: "embedded2" ::: Bool + } +data OneSide + = OneSide + { name5 :: "embedded1" ::: Simple + , name6 :: Bool + } +newtype Single = Single ("s" ::: Int) + +data Gadt x where + Gadt :: ("gadt" ::: Int) -> Gadt Int + +type family CF x y z where + CF Int Int Int = ("cfiii" ::: Single) + CF Bool Int Int = ("cfbii" ::: Single) +type family OF x y z +type instance OF Int Int Int = ("ofiii" ::: Single) +type instance OF Bool Int Int = ("ofbii" ::: Single) + +data family X x y z +data instance X Int Int Int = X1 ("xiii" ::: Int) ("xiii2" ::: Bool) +newtype instance X Bool Int Int = X2 ("xbii" ::: Int) + +data Impossible = L ("left" ::: Int) | R ("right" ::: Bool) + +data FailureTy1 = TwoF1 ("one" ::: Int) Int +data SuccessTy = TwoS ("one" ::: Int) Single + +data Passthrough a b = Passthrough a b + +topEntity1 :: "in1" ::: Signal System Int + -> "in2" ::: Signal System Bool + -> "out" ::: Signal System Int +topEntity1 = undefined +makeTopEntity 'topEntity1 + +expectedTopEntity1 :: TopEntity +expectedTopEntity1 = + Synthesize "topEntity1" + [PortName "in1", PortName "in2"] + (PortName "out") + +topEntity2 :: "int" ::: Signal System Int + -> "tuple" ::: ( "tup1" ::: Signal System (BitVector 7) + , "tup2" ::: Signal System (BitVector 9)) + -> "simple" ::: Signal System Simple + -> "named" ::: Signal System Named + -> "embedded" ::: Signal System Embedded + -> "out" ::: Signal System Bool +topEntity2 = undefined +makeTopEntity 'topEntity2 + +expectedTopEntity2 :: TopEntity +expectedTopEntity2 = + Synthesize "topEntity2" + [ PortName "int" + , PortProduct "tuple" [PortName "tup1",PortName "tup2"] + , PortProduct "simple" [PortName "simple1",PortName "simple2"] + , PortProduct "named" [PortName "named1",PortName "named2"] + , PortProduct "embedded" + [ PortProduct "embedded1" + [ PortName "simple1" + , PortName "simple2"] + , PortName "embedded2"] + ] + (PortName "out") + +topEntity3 :: "clk" ::: Clock System + -> "rst" ::: Reset System + -> "en" ::: Enable System + -> "tup1" ::: Signal System (Int, Bool) + -> "tup2" ::: (Signal System Int, Signal System Bool) + -> "tup3" ::: Signal System ("int":::Int, "bool":::Bool) + -> "tup4" ::: ("int":::Signal System Int, "bool":::Signal System Bool) + -> "custom" ::: Signal System Named + -> "outTup" ::: Signal System ("outint":::Int, "outbool":::Bool) +topEntity3 = undefined +makeTopEntity 'topEntity3 + +expectedTopEntity3 :: TopEntity +expectedTopEntity3 = + Synthesize "topEntity3" + [ PortName "clk" + , PortName "rst" + , PortName "en" + , PortName "tup1" + , PortName "tup2" + , PortProduct "tup3" [PortName "int",PortName "bool"] + , PortProduct "tup4" [PortName "int",PortName "bool"] + , PortProduct "custom" [PortName "named1",PortName "named2"] + ] + (PortProduct "outTup" [PortName "outint",PortName "outbool"]) + +topEntity4 :: Signal System (Gadt Int) + -> Signal System Single + -> Signal System (CF Int Int Int) + -> Signal System (CF Bool Int Int) + -> Signal System (OF Int Int Int) + -> Signal System (OF Bool Int Int) + -> Signal System (X Int Int Int) + -> Signal System (X Bool Int Int) + -> Signal System Single +topEntity4 = undefined +makeTopEntity 'topEntity4 + +expectedTopEntity4 :: TopEntity +expectedTopEntity4 = + Synthesize "topEntity4" + [ PortName "gadt" + , PortName "s" + , PortProduct "cfiii" [PortName "s"] + , PortProduct "cfbii" [PortName "s"] + , PortProduct "ofiii" [PortName "s"] + , PortProduct "ofbii" [PortName "s"] + , PortProduct "" [PortName "xiii", PortName "xiii2"] + , PortName "xbii" + ] + (PortName "s") + +topEntity5 :: "in1" ::: Signal System SuccessTy + -> "ab" ::: Signal System (Passthrough (Passthrough Simple Simple) Simple) + -> "out" ::: Signal System Int +topEntity5 = undefined +makeTopEntity 'topEntity5 + +expectedTopEntity5 :: TopEntity +expectedTopEntity5 = + Synthesize "topEntity5" + [ PortProduct "in1" [PortName "one", PortName "s"] + , PortProduct "ab" [PortProduct "" [PortProduct "" [PortName "simple1",PortName "simple2"] + ,PortProduct "" [PortName "simple1",PortName "simple2"]] + ,PortProduct "" [PortName "simple1",PortName "simple2"]] + ] + (PortName "out") + +topEntity6 :: (HiddenClockResetEnable System) + => (1~1, Eq Int) + => (Ord Int) + => "in1" ::: Signal System SuccessTy + -> "out" ::: Signal System Int +topEntity6 = undefined +makeTopEntity 'topEntity6 + +expectedTopEntity6 :: TopEntity +expectedTopEntity6 = + Synthesize "topEntity6" + [ PortProduct "" [ PortName "clk", PortName "rst", PortName "en"] + , PortProduct "in1" [PortName "one", PortName "s"]] + (PortName "out") + + +topEntity7 :: (HiddenClockResetEnable System) + => "in1" ::: Signal System (Vec 3 Int) + -> "in2" ::: Signal System (Vec 3 Simple) + -> "passthrough" ::: Signal System (Passthrough Single Single) + -> "out" ::: Signal System Int +topEntity7 = undefined +makeTopEntity 'topEntity7 + +expectedTopEntity7 :: TopEntity +expectedTopEntity7 = + Synthesize "topEntity7" + [ PortProduct "" [PortName "clk", PortName "rst", PortName "en"] + , PortName "in1" + , PortName "in2" + , PortProduct "passthrough" [PortName "s", PortName "s"] + ] + (PortName "out") + +topEntity8 :: (HiddenClockResetEnable System) + => "pair" ::: Signal System (Pair Bool) + -> "pair" ::: Signal System (Pair Single) + -> "out" ::: Signal System Int +topEntity8 = undefined +makeTopEntity 'topEntity8 + +expectedTopEntity8 :: TopEntity +expectedTopEntity8 = + Synthesize "topEntity8" + [ PortProduct "" [PortName "clk", PortName "rst", PortName "en"] + , PortProduct "pair" [PortName "left", PortName "right"] + , PortProduct "pair" [PortProduct "left" [PortName "s"], PortProduct "right" [PortName "s"]] + ] + (PortName "out") + +topEntityFailure1 + :: "int" ::: Signal System Int + -> "tuple" ::: ("tup1" ::: Signal System (BitVector 7), "tup2" ::: Signal System (BitVector 9)) + -> "simple" ::: Signal System Simple + -> "named" ::: Signal System Named + -> Signal System OneSide + -> "out" ::: Signal System Bool +topEntityFailure1 = undefined + +topEntityFailure2 + :: "int" ::: Signal System Int + -> "tuple" ::: ("tup1" ::: Signal System (BitVector 7), "tup2" ::: Signal System (BitVector 9)) + -> "simple" ::: Signal System Simple + -> "named" ::: Signal System Named + -> Signal System Int + -> "out" ::: Signal System Bool +topEntityFailure2 = undefined + +topEntityFailure3 + :: "int" ::: Signal System Impossible + -> "out" ::: Signal System Bool +topEntityFailure3 = undefined + +topEntityFailure4 + :: "int" ::: Signal System FailureTy1 + -> "out" ::: Signal System Bool +topEntityFailure4 = undefined + +topEntityFailure5 + :: "int" ::: Signal System (Passthrough (Passthrough Simple Int) Simple) + -> "out" ::: Signal System Bool +topEntityFailure5 = undefined + +topEntityFailure6 + :: "int" ::: Signal System a + -> "out" ::: Signal System Bool +topEntityFailure6 = undefined + +#if MULTIPLE_HIDDEN +topEntityFailure7 + :: HiddenClockResetEnable System + => HiddenClockResetEnable XilinxSystem + => "int" ::: Signal System Int + -> "out" ::: Signal System Bool +topEntityFailure7 = undefined +#endif + +topEntityFailure8 + :: "int" ::: Signal System (Passthrough Int Simple ) + -> "out" ::: Signal System Bool +topEntityFailure8 = undefined + +-- This splice is needed to make sure TH.names are in the type environment +-- during reify for the expected failure cases. +$( return [] ) + +tests :: TestTree +tests = + testGroup "TopEntityGeneration" + [ testGroup "Expected successes" + [ testCase "topEntity1" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity1) + @?= Just expectedTopEntity1 + , testCase "topEntity2" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity2) + @?= Just expectedTopEntity2 + , testCase "topEntity3" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity3) + @?= Just expectedTopEntity3 + , testCase "topEntity4" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity4) + @?= Just expectedTopEntity4 + , testCase "topEntity5" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity5) + @?= Just expectedTopEntity5 + , testCase "topEntity6" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity6) + @?= Just expectedTopEntity6 + , testCase "topEntity7" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity7) + @?= Just expectedTopEntity7 + , testCase "topEntity8" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntity8) + @?= Just expectedTopEntity8 + ] + , testGroup "Expected failures" + [ testCase "topEntityFailure1" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure1) @?= failed + , testCase "topEntityFailure2" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure2) @?= failed + , testCase "topEntityFailure3" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure3) @?= failed + , testCase "topEntityFailure4" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure4) @?= failed + , testCase "topEntityFailure5" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure5) @?= failed + , testCase "topEntityFailure6" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure6) @?= failed +#if MULTIPLE_HIDDEN + , testCase "topEntityFailure7" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure7) @?= failed +#endif + , testCase "topEntityFailure8" $ + $(unTypeQ $ maybeBuildTopEntity Nothing 'topEntityFailure8) @?= failed + ] + ] + where + failed = Nothing :: Maybe TopEntity + diff --git a/tests/Clash/Tests/Unsigned.hs b/tests/Clash/Tests/Unsigned.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/Unsigned.hs @@ -0,0 +1,37 @@ +module Clash.Tests.Unsigned (tests) where + +import Data.Proxy +import GHC.TypeNats (KnownNat, SomeNat (..), natVal, someNatVal) +import Test.Tasty +import Test.Tasty.QuickCheck + +import Clash.Sized.Internal.Unsigned +import Clash.Tests.SizedNum + +tests :: TestTree +tests = localOption (QuickCheckMaxRatio 2) $ testGroup "All" + [ testGroup "Unsigned 1" $ + testProperty "fromInteger" + (fromIntegerProp (Proxy :: Proxy 1)) : + map lawsToTest (laws1 (Proxy :: Proxy (Unsigned 1))) + , testGroup "Unsigned 21" $ + testProperty "fromInteger" + (fromIntegerProp (Proxy :: Proxy 21)) : + map lawsToTest (laws (Proxy :: Proxy (Unsigned 21))) + , testGroup "Unsigned 83" $ + testProperty "fromInteger" + (fromIntegerProp (Proxy :: Proxy 83)) : + map lawsToTest (laws (Proxy :: Proxy (Unsigned 83))) + , testGroup "Random Unsigned" + [ testProperty "fromInteger" fromIntegerRandomProp ] + ] + +fromIntegerProp :: forall m. KnownNat m => Proxy m -> Integer -> Property +fromIntegerProp p n = unsafeToInteger m === fromInteger (n `mod` (2 ^ toInteger (natVal p))) + where + m :: Unsigned m + m = fromInteger n + +fromIntegerRandomProp :: Positive Integer -> Integer -> Property +fromIntegerRandomProp (Positive m) n = m > 1 ==> case someNatVal (fromInteger m) of + SomeNat p -> fromIntegerProp p n diff --git a/tests/doctests.hs b/tests/doctests.hs --- a/tests/doctests.hs +++ b/tests/doctests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + module Main where import Test.DocTest (doctest) @@ -10,8 +11,31 @@ docTestOpts :: [String] docTestOpts = -#if __GLASGOW_HASKELL__ >= 802 - ["-fdiagnostics-color=never"] -#else - [] +#if __GLASGOW_HASKELL__ >= 806 + "-XNoStarIsType" : #endif +#if __GLASGOW_HASKELL__ <= 804 + "-XTypeInType" : +#endif + -- TODO: Figure out a way to auto-sync this with clash-prelude.cabal + [ "-XBangPatterns" + , "-XBinaryLiterals" + , "-XDataKinds" + , "-XDefaultSignatures" + , "-XDeriveDataTypeable" + , "-XDeriveFoldable" + , "-XDeriveFunctor" + , "-XDeriveGeneric" + , "-XDeriveLift" + , "-XDeriveTraversable" + , "-XDerivingStrategies" + , "-XInstanceSigs" + , "-XKindSignatures" + , "-XMagicHash" + , "-XScopedTypeVariables" + , "-XStandaloneDeriving" + , "-XTupleSections" + , "-XTypeApplications" + , "-XTypeOperators" + , "-XViewPatterns" + ] diff --git a/tests/unittests.hs b/tests/unittests.hs --- a/tests/unittests.hs +++ b/tests/unittests.hs @@ -2,19 +2,27 @@ import Test.Tasty +import qualified Clash.Tests.AutoReg import qualified Clash.Tests.BitPack import qualified Clash.Tests.BitVector import qualified Clash.Tests.DerivingDataRepr import qualified Clash.Tests.Signal +import qualified Clash.Tests.Signed import qualified Clash.Tests.NFDataX +import qualified Clash.Tests.TopEntityGeneration +import qualified Clash.Tests.Unsigned tests :: TestTree tests = testGroup "Unittests" - [ Clash.Tests.BitPack.tests + [ Clash.Tests.AutoReg.tests + , Clash.Tests.BitPack.tests , Clash.Tests.BitVector.tests , Clash.Tests.DerivingDataRepr.tests , Clash.Tests.Signal.tests + , Clash.Tests.Signed.tests , Clash.Tests.NFDataX.tests + , Clash.Tests.TopEntityGeneration.tests + , Clash.Tests.Unsigned.tests ] main :: IO ()