clash-prelude 1.4.7 → 1.6.0

raw patch · 112 files changed

+7536/−2072 lines, 112 filesdep +directorydep +doctest-paralleldep +filepathdep −bifunctorsdep −doctestdep −text-showdep ~bytestringsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, doctest-parallel, filepath

Dependencies removed: bifunctors, doctest, text-show

Dependency ranges changed: bytestring

API changes (from Hackage documentation)

Files

• CHANGELOG.md +73/−0
• Setup.hs +0/−25
• benchmarks/BenchBitVector.hs +1/−3
• benchmarks/BenchRAM.hs +73/−20
• benchmarks/BenchSigned.hs +0/−2
• benchmarks/BenchUnsigned.hs +0/−2
• benchmarks/BenchVector.hs +0/−2
• clash-prelude.cabal +38/−28
• src/Clash/Annotations/BitRepresentation.hs +0/−2
• src/Clash/Annotations/BitRepresentation/Deriving.hs +5/−2
• src/Clash/Annotations/BitRepresentation/Internal.hs +1/−14
• src/Clash/Annotations/BitRepresentation/Util.hs +0/−2
• src/Clash/Annotations/Primitive.hs +18/−18
• src/Clash/Annotations/SynthesisAttributes.hs +26/−4
• src/Clash/Annotations/TH.hs +1/−7
• src/Clash/Annotations/TopEntity.hs +3/−3
• src/Clash/Class/AutoReg/Instances.hs +0/−7
• src/Clash/Class/AutoReg/Internal.hs +9/−11
• src/Clash/Class/BitPack.hs +22/−398
• src/Clash/Class/BitPack/BitIndex.hs +160/−0
• src/Clash/Class/BitPack/BitReduction.hs +83/−0
• src/Clash/Class/BitPack/Internal.hs +449/−87
• src/Clash/Class/BitPack/Internal/TH.hs +102/−0
• src/Clash/Class/Counter.hs +62/−0
• src/Clash/Class/Counter/Internal.hs +144/−0
• src/Clash/Class/Counter/TH.hs +81/−0
• src/Clash/Class/HasDomain/HasSingleDomain.hs +0/−4
• src/Clash/Class/HasDomain/HasSpecificDomain.hs +0/−4
• src/Clash/Class/Num.hs +1/−0
• src/Clash/Class/Parity.hs +1/−0
• src/Clash/Examples.hs +2/−4
• src/Clash/Explicit/BlockRam.hs +416/−25
• src/Clash/Explicit/BlockRam/Blob.hs +385/−0
• src/Clash/Explicit/BlockRam/File.hs +196/−47
• src/Clash/Explicit/BlockRam/Internal.hs +193/−0
• src/Clash/Explicit/Mealy.hs +0/−2
• src/Clash/Explicit/Moore.hs +0/−2
• src/Clash/Explicit/Prelude.hs +25/−11
• src/Clash/Explicit/Prelude/Safe.hs +23/−8
• src/Clash/Explicit/RAM.hs +39/−11
• src/Clash/Explicit/ROM.hs +23/−3
• src/Clash/Explicit/ROM/Blob.hs +153/−0
• src/Clash/Explicit/ROM/File.hs +32/−9
• src/Clash/Explicit/Reset.hs +8/−13
• src/Clash/Explicit/Signal.hs +102/−8
• src/Clash/Explicit/Signal/Delayed.hs +3/−7
• src/Clash/Explicit/SimIO.hs +7/−1
• src/Clash/Explicit/Synchronizer.hs +77/−33
• src/Clash/Explicit/Testbench.hs +119/−66
• src/Clash/Explicit/Verification.hs +15/−1
• src/Clash/HaskellPrelude.hs +46/−2
• src/Clash/Intel/ClockGen.hs +5/−1
• src/Clash/Num/Erroring.hs +155/−0
• src/Clash/Num/Overflowing.hs +189/−0
• src/Clash/Num/Saturating.hs +154/−0
• src/Clash/Num/Wrapping.hs +151/−0
• src/Clash/Num/Zeroing.hs +153/−0
• src/Clash/Prelude.hs +25/−10
• src/Clash/Prelude/BitIndex.hs +12/−142
• src/Clash/Prelude/BitReduction.hs +7/−76
• src/Clash/Prelude/BlockRam.hs +70/−6
• src/Clash/Prelude/BlockRam/Blob.hs +107/−0
• src/Clash/Prelude/BlockRam/File.hs +12/−4
• src/Clash/Prelude/DataFlow.hs +7/−6
• src/Clash/Prelude/Mealy.hs +0/−3
• src/Clash/Prelude/RAM.hs +5/−1
• src/Clash/Prelude/ROM.hs +35/−6
• src/Clash/Prelude/ROM/Blob.hs +175/−0
• src/Clash/Prelude/ROM/File.hs +13/−3
• src/Clash/Prelude/Safe.hs +22/−6
• src/Clash/Prelude/Synchronizer.hs +2/−1
• src/Clash/Prelude/Testbench.hs +26/−9
• src/Clash/Promoted/Nat.hs +8/−1
• src/Clash/Promoted/Nat/TH.hs +2/−0
• src/Clash/Promoted/Nat/Unsafe.hs +4/−1
• src/Clash/Promoted/Symbol.hs +8/−2
• src/Clash/Signal.hs +314/−9
• src/Clash/Signal/BiSignal.hs +9/−7
• src/Clash/Signal/Bundle.hs +4/−7
• src/Clash/Signal/Delayed.hs +3/−5
• src/Clash/Signal/Delayed/Bundle.hs +0/−5
• src/Clash/Signal/Delayed/Internal.hs +57/−9
• src/Clash/Signal/Internal.hs +4/−9
• src/Clash/Signal/Trace.hs +7/−1
• src/Clash/Sized/Fixed.hs +45/−28
• src/Clash/Sized/Internal/BitVector.hs +187/−72
• src/Clash/Sized/Internal/Index.hs +74/−13
• src/Clash/Sized/Internal/Mod.hs +1/−20
• src/Clash/Sized/Internal/Signed.hs +113/−26
• src/Clash/Sized/Internal/Unsigned.hs +111/−25
• src/Clash/Sized/RTree.hs +9/−3
• src/Clash/Sized/Vector.hs +223/−173
• src/Clash/Tutorial.hs +171/−184
• src/Clash/Verification.hs +1/−0
• src/Clash/Verification/Internal.hs +10/−4
• src/Clash/Verification/PrettyPrinters.hs +0/−244
• src/Clash/XException.hs +39/−18
• src/Clash/XException/Internal.hs +11/−8
• tests/Clash/Tests/AsyncFIFOSynchronizer.hs +996/−0
• tests/Clash/Tests/BitVector.hs +17/−1
• tests/Clash/Tests/BlockRam.hs +19/−1
• tests/Clash/Tests/BlockRam/Blob.hs +36/−0
• tests/Clash/Tests/Counter.hs +110/−0
• tests/Clash/Tests/Fixed.hs +25/−4
• tests/Clash/Tests/Laws/SaturatingNum.hs +20/−3
• tests/Clash/Tests/NumNewtypes.hs +286/−0
• tests/Clash/Tests/Ram.hs +20/−2
• tests/Clash/Tests/Vector.hs +20/−2
• tests/Hedgehog/Extra.hs +17/−1
• tests/Test/Tasty/HUnit/Extra.hs +1/−1
• tests/doctests.hs +3/−10
• tests/unittests.hs +9/−1

@@ -1,4 +1,77 @@ # Changelog for the Clash project+## 1.6.0 *Feb 10th 2022*+Added:+  * `Clash.Class.Counter`: a class that defines a odometer-style supercounter. [#1763](https://github.com/clash-lang/clash-compiler/pull/1763)+  * `isLike` function for BitPack types. [#1774](https://github.com/clash-lang/clash-compiler/pull/1774)+  * 'seqErrorX' for catching both `XException` and `ErrorCall`. [#1774](https://github.com/clash-lang/clash-compiler/pull/1774)+  * `Clash.Explicit.BlockRam.File.memFile`, a function for creating the contents of the data files this blockRAM uses. Can also be imported from `Clash.Prelude.BlockRam.File`, `Clash.Prelude.ROM.File` and `Clash.Explicit.ROM.File`. [#1840](https://github.com/clash-lang/clash-compiler/pull/1840)+  * Support for Yosys compatible SVA to `Clash.Verification`. This enables formal verification using SymbiYosis for Verilog and SystemVerilog. [#1798](https://github.com/clash-lang/clash-compiler/pull/1798)+  * `Clash.Explicit.Signal.Delayed.forward`, a function that can be used to retime a `DSignal` into the future without applying any logic. [#1882](https://github.com/clash-lang/clash-compiler/pull/1882)+  * `Clash.Signal.andEnable` is the `HiddenEnable` version of `Clash.Explicit.Signal.andEnable` (formerly known as `enable`) [#1849](https://github.com/clash-lang/clash-compiler/pull/1849)+  * `runUntil`, a function to sample a signal until it returns a value that satisfies the user-given test. It is a convenience function that, among others, allow easy running of a `testBench` style function in Haskell simulation, logging assertion failures to stderr. [#1940](https://github.com/clash-lang/clash-compiler/pull/1940)+  * Support for true dual ported block ram through `Clash.Prelude.BlockRam.trueDualPortBlockRam` and `Clash.Explicit.BlockRam.trueDualPortBlockRam`. [#1726](https://github.com/clash-lang/clash-compiler/pull/1726) [#1975](https://github.com/clash-lang/clash-compiler/pull/1975)+  * `clash-{prelude,lib}-hedgehog` packages which provide generators for types in `clash-prelude` and `clash-lib`. The former is published on Hackage. [#1976](https://github.com/clash-lang/clash-compiler/pull/1976)+  * Clash now contains black boxes which are verilator compatible. When running with `--verilog` or `--systemverilog` a C++ shim is automatically produced which can be used to quickly generate a verilated executable. Users who wish to interact with verilator simulations are recommended to use [clashilator](https://github.com/gergoerdi/clashilator). [#2019](https://github.com/clash-lang/clash-compiler/pull/2019)+  * Support for YAML blackboxes. Clash will now pickup on files with a `.primitives.yaml` extension. While we recommend upgrading your primitive files to the new format, old style primitives are still supported. We've included a tool to automatically upgrade your JSON files, see [#2037](https://github.com/clash-lang/clash-compiler/pull/2037)+  * `MemBlob`: a datastructure for efficient constants, typically used for initializing memories. [#2041](https://github.com/clash-lang/clash-compiler/pull/2041)++Fixed:++  * BlockRam simulation is now less strict. [#1458](https://github.com/clash-lang/clash-compiler/issues/1458)+  * Don't overflow VHDL's integer type when addressing RAM/ROM in simulation.Addresses are masked to 32 bits to be sure to keep it within the simulator's range. [#1875](https://github.com/clash-lang/clash-compiler/pull/1875)+  * `show` on `BitVector 0` no longer results in an empty string. [#1785](https://github.com/clash-lang/clash-compiler/pull/1785)+  * Clash now preserves transfinite floating numbers (NaN, Infinity) when packing/unpacking [#1803](https://github.com/clash-lang/clash-compiler/issues/1803)+  * `SynthesisAnnotation`s can now be defined in type synoynms without being excluded from the generated HDL [#1771](https://github.com/clash-lang/clash-compiler/issues/1771)+  * Manifest files now correctly list bidirectional ports as "inout" rather than "in" [#1843](https://github.com/clash-lang/clash-compiler/issues/1843)+  * `div`/`rem`/`mod` now avoid division by zero during VHDL simulation. Due to the use of concurrent statements, even unreachable code would previously result in simulation error [#1873](https://github.com/clash-lang/clash-compiler/pull/1873)+  * Don't overflow the range of VHDL's natural type in shift/rotate, leading to simulation issues. Shift now saturates to a 31-bit shift amount. For rotate, in simulation only, the rotate amount is modulo the word width of the rotated value [#1874](https://github.com/clash-lang/clash-compiler/pull/1874)+  * `shiftL` for Clash datatypes does not cause a crash anymore when running Clash code with a really large shift amount [#1874](https://github.com/clash-lang/clash-compiler/pull/1874)+  * VHDL generated for `Signed.fromInteger` now truncates, like the Clash simulation, when the result is smaller than the argument [#1874](https://github.com/clash-lang/clash-compiler/pull/1874)+  * Clash now preserves boolean combinatorial logic better when generating HDL [#1881](https://github.com/clash-lang/clash-compiler/issues/1881)+  * `valid` field of `TemplateFunction` is now checked for includes [#1945](https://github.com/clash-lang/clash-compiler/issues/1945)+  * Clash now generates clock generators that ensure that the amount of time between simulation start and the first active edge of the clock is equal to (/or longer than/) the period of the clock. The first active edges of the clocks do still occur simultaneously. [#2001](https://github.com/clash-lang/clash-compiler/issues/2001)+  * Expected values in assert become undefined when using `-fclash-compile-ultra` [#2040](https://github.com/clash-lang/clash-compiler/issues/2040)+  * `toEnum`/`fromEnum` on sized types is now less eager to report warnings about integer functions being used [#2046](https://github.com/clash-lang/clash-compiler/issues/2046)++Changed:++  * `Clash.Verification.PrettyPrinters` has been moved from clash-prelude to to `Clash.Verification.Pretty` in `clash-lib`. [#1798](https://github.com/clash-lang/clash-compiler/pull/1798)+  * RAM/ROM functions: They now throw `XExeception` for out-of-bounds address inputs, so this condition no longer aborts simulation. [#1875](https://github.com/clash-lang/clash-compiler/pull/1875)+  * `Vec`'s show instance now generates valid Haskell. [#1776](https://github.com/clash-lang/clash-compiler/issues/1776)+  * `ShowX` and its functions now produce valid Haskell [#1782](https://github.com/clash-lang/clash-compiler/issues/1782)+  * `bLit` now infers the size of the generated BitVector from the string given to it. This means you don't have to give it an explicit type signature anymore. This does slightly modify the syntax needed to invoke `bLit`. E.g., `$$(bLit "00..1") :: BitVector 5` should be rewritten as `$(bLit "00..1")`. If you relied on the size inference, wrap the new invocation in `resize`. For example: `resize $(bLit "00..1")`. [#1784](https://github.com/clash-lang/clash-compiler/pull/1784)+  * `NumericUnderscores` is now enabled by default in `clash`, `clashi`, and starter projects using Clash >=1.6. [#1785](https://github.com/clash-lang/clash-compiler/pull/1785)+  * `Show` instance of `BitVector` now includes a `0b` prefix, making it a copyable expression for fully defined vectors. [#1785](https://github.com/clash-lang/clash-compiler/pull/1785)+  * `blockRam` uses `STArray` as the underlying representation to improve simulation performance [#1878](https://github.com/clash-lang/clash-compiler/pull/1878)+  * `asyncRom` now throws `XException` for out-of-bounds addressing, no longer aborting simulation [#1878](https://github.com/clash-lang/clash-compiler/pull/1878)+  * Clash now renders ADTs with all zero-width fields as enumerations in VHDL [#1879](https://github.com/clash-lang/clash-compiler/pull/1879)+  * A warning about possible hard-to-debug issues has been added to the `Clash.Signal` documentation on hidden clocks, resets, and enables, in the form of the section named "Monomorphism restriction leads to surprising behavior" [#1960](https://github.com/clash-lang/clash-compiler/pull/1960)+  * `Clash.Explicit.Testbench.outputVerifier` and `outputVerifierBitVector` now emit a warning if they are used improperly. This situation only arises when they are used in synthesized code rather than a test bench context. When the clock domains `circuitDom` and `testDom` are two different domains, the clock crossing inside `outputVerifier` is only suitable inside a test bench, not inside a synthesized circuit. Clash now emits a warning for this case. [#1931](https://github.com/clash-lang/clash-compiler/pull/1931)+  * `resetSynchronizer` now no longer takes an `Enable` argument. The argument was already marked for removal and was ignored. [#1964](https://github.com/clash-lang/clash-compiler/pull/1964)+  * Clash can now compile multiple entities concurrently, providing speedups to designs with multiple entities to build [#2034](https://github.com/clash-lang/clash-compiler/pull/2034)+  * All `asyncRam` variants and `asyncFIFOSynchronizer` now require that the data has an `NFDataX` instance. [#2055](https://github.com/clash-lang/clash-compiler/pull/2055)+  * Clash now respects the `-Werror` option from GHC [#2066](https://github.com/clash-lang/clash-compiler/pull/2066)+  * `asyncFIFOSynchronizer` now uses the synchronous dual-ported RAM `trueDualPortBlockRam`, where it previously used a dual-ported RAM with an asynchronous read port `asyncRam`. With this change it's nearly guaranteed that `asyncFIFOSynchronizer` actually synthesizes to a circuit that uses the dual-ported RAMs found on most FPGAs. [#2083](https://github.com/clash-lang/clash-compiler/pull/2083)++Deprecated:+  * The function `Clash.Explicit.Signal.enable` is renamed to `andEnable` and the existing name deprecated [#1849](https://github.com/clash-lang/clash-compiler/pull/1849)+  * '-fclash-float-support': it is now on by default and can't be turned off. [#2048](https://github.com/clash-lang/clash-compiler/pull/2048)++Removed:++  * GHC 8.4 is no longer supported. Users should upgrade to at least GHC 8.6. [#1762](https://github.com/clash-lang/clash-compiler/pull/1762)++Internal changes:+  * `clash-lib` now uses `Data.Monoid.Ap` instead of `Data.Semigroup.Monad.Mon`. This means users defining primitives with `TemplateFunction` will need to replace `Mon`/`getMon` with `Ap`/`getAp`. [#1835](https://github.com/clash-lang/clash-compiler/pull/1835)+  * Clash now supports more expressive debug options at the command line [#1800](https://github.com/clash-lang/clash-compiler/issues/1800).+  * Added `zeroWidthSpec` transformation [#1891](https://github.com/clash-lang/clash-compiler/pull/1891)+  * Added `collapseRHSNoops` inlining stage and `WorkIdentity` constructor [#1896](https://github.com/clash-lang/clash-compiler/pull/1896)+  * Added `HasType` and `InferType` classes for getting / inferring core types from data representing some typed "thing" [#1915](https://github.com/clash-lang/clash-compiler/pull/1915)+  * Added `HasFreeVars` class for getting free variables from data "containing" variables [#1917](https://github.com/clash-lang/clash-compiler/pull/1917)+  * Added the primitive equality type (`~#`) to `Clash.Core.TysPrim`. In order to make this change, `undefinedTy` and `unsafeCoerceTy` were moved from `Clash.Core.Type` to `Clash.Core.Util`. [#1955](https://github.com/clash-lang/clash-compiler/pull/1955)+  * Clash now keeps information about which let bindings are recursive from GHC core. This can be used to avoid performing free variable calculations, or sorting bindings in normalization. [#1980](https://github.com/clash-lang/clash-compiler/pull/1980) [#2000](https://github.com/clash-lang/clash-compiler/pull/2000)+  *  Manifest files now use SHA256 for a cache invalidation digest [#1985](https://github.com/clash-lang/clash-compiler/pull/1985)+ ## 1.4.7 *Jan 30th 2022* Fixed:   * Clash now shows days in time strings for compile runs which take longer than a day [#1989](https://github.com/clash-lang/clash-compiler/compare/issue-1989).

@@ -1,25 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wall #-}-module Main (main) where-#ifndef MIN_VERSION_cabal_doctest-#define MIN_VERSION_cabal_doctest(x,y,z) 0-#endif-#if MIN_VERSION_cabal_doctest(1,0,0)-import Distribution.Extra.Doctest ( defaultMainWithDoctests )-main :: IO ()-main = defaultMainWithDoctests "doctests"-#else-#ifdef MIN_VERSION_Cabal--- If the macro is defined, we have new cabal-install,--- but for some reason we don't have cabal-doctest in package-db------ Probably we are running cabal sdist, when otherwise using v2-build--- workflow-#warning You are configuring this package without cabal-doctest installed. \-         The doctests test-suite will not work as a result. \-         To fix this, install cabal-doctest before configuring.-#endif-import Distribution.Simple-main :: IO ()-main = defaultMain-#endif

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-}-#if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE NoStarIsType #-}-#endif  {-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-} @@ -12,7 +10,7 @@ import Data.Bits import Clash.Sized.BitVector import Clash.Class.Num-import Clash.Prelude.BitIndex+import Clash.Class.BitPack.BitIndex import GHC.TypeLits                   (type (*)) import Criterion                      (Benchmark, env, bench, nf, bgroup) import Language.Haskell.TH.Syntax     (lift)

@@ -1,15 +1,20 @@-{-# LANGUAGE MagicHash, TypeApplications #-}+{-# LANGUAGE MagicHash, TypeApplications, DataKinds #-} module BenchRAM (ramBench) where -import Criterion (Benchmark, env, bench, nf, bgroup)+import Criterion (Benchmark, env, bench, nf, bgroup, envWithCleanup)+import System.Directory+import System.IO  import Clash.Explicit.BlockRam+import Clash.Explicit.BlockRam.File import Clash.Explicit.RAM import Clash.Explicit.ROM import Clash.Explicit.Signal import Clash.Prelude.ROM+import Clash.Promoted.Nat import Clash.Promoted.Nat.Literals import qualified Clash.Sized.Vector as V+import Clash.Sized.Internal.BitVector (undefined#)  ramBench :: Benchmark ramBench = bgroup "RAMs"@@ -17,19 +22,21 @@   , asyncRomBench   , blockRamBench   , blockRamROBench+  , blockRamFileBench+  , blockRamFileROBench   , romBench   ]  asyncRamBench :: Benchmark asyncRamBench = env setup $ \m ->   bench "asyncRam#" $-  nf (take 98 . drop 2 . simulate_lazy+  nf (take 298 . drop 2 . simulate_lazy         (\rw -> let (r,w) = unbundle rw                 in  asyncRam# @System                       clockGen                       clockGen                       enableGen-                      d1024+                      (SNat @4096)                       r                       (pure True)                       w@@ -49,36 +56,82 @@ blockRamBench :: Benchmark blockRamBench = env setup $ \m ->   bench "blockRam# (100% writes)" $-  nf (take 98 . drop 2 . simulate_lazy-        (\w -> blockRam# @System-                    clockGen-                    enableGen-                    ramInit-                    w+  nf (take 8298 . drop 2 . simulate_lazy+        (\w -> ram w                     (pure True)                     w                     w-                   )) m+                   )) (cycle m)   where-    ramInit = V.replicate d1024 (1 :: Int)+    ramInit = V.replicate (SNat @4096) (1 :: Int)     setup   = pure ([557,558..857])+    ram     = blockRam# @System+                    clockGen+                    enableGen+                    ramInit  blockRamROBench :: Benchmark blockRamROBench = env setup $ \m ->   bench "blockRam# (0% writes)" $-  nf (take 98 . drop 2 . simulate_lazy-        (\w -> blockRam# @System-                    clockGen-                    enableGen-                    ramInit-                    w+  nf (take 8298 . drop 2 . simulate_lazy+        (\w -> ram w                     (pure False)                     w                     w-                   )) m+                   )) (cycle m)   where-    ramInit = V.replicate d1024 (1 :: Int)+    ramInit = V.replicate (SNat @4096) (1 :: Int)     setup   = pure ([557,558..857])+    ram     = blockRam# @System+                    clockGen+                    enableGen+                    ramInit++blockRamFileBench :: Benchmark+blockRamFileBench = envWithCleanup setup cleanup $ \(~(m,_,ram)) ->+  bench "blockRamFile# (100% writes)" $+  nf (take 8298 . drop 2 . simulate_lazy+        (\w -> ram  w+                    (pure True)+                    w+                    (pure undefined#)+                   )) (cycle m)+  where+    setup = do+      (fp,h) <- openTempFile "." "mem.bin"+      hPutStr h (unlines (replicate 4096 (replicate 63 '0' ++ ['1'])))+      hClose h+      let ram = blockRamFile# @64 @System+              clockGen+              enableGen+              (SNat @4096)+              fp+      fp `seq` ram `seq` return ([557,558..857],fp,ram)++    cleanup (_,f,_) = removeFile f++blockRamFileROBench :: Benchmark+blockRamFileROBench = envWithCleanup setup cleanup $ \(~(m,_,ram)) ->+  bench "blockRamFile# (0% writes)" $+  nf (take 8298 . drop 2 . simulate_lazy+        (\w -> ram w+                   (pure False)+                   w+                   (pure undefined#)+                   )) (cycle m)+  where+    setup = do+      (fp,h) <- openTempFile "." "mem.bin"+      hPutStr h (unlines (replicate 4096 (replicate 63 '0' ++ ['1'])))+      hClose h+      let ram = blockRamFile# @64 @System+                    clockGen+                    enableGen+                    (SNat @4096)+                    fp+      fp `seq` ram `seq` return ([557,558..857], fp, ram)++    cleanup (_,f,_) = removeFile f  romBench :: Benchmark romBench = env setup $ \m ->

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-}-#if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE NoStarIsType #-}-#endif  {-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-} 

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-}-#if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE NoStarIsType #-}-#endif  {-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-} 

@@ -1,7 +1,5 @@ {-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-}-#if __GLASGOW_HASKELL__ >= 806 {-# LANGUAGE NoStarIsType #-}-#endif  {-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-} 

@@ -1,6 +1,6 @@ Cabal-version:        2.2 Name:                 clash-prelude-Version:              1.4.7+Version:              1.6.0 Synopsis:             Clash: a functional hardware description language - Prelude library Description:   Clash is a functional hardware description language that borrows both its@@ -51,9 +51,9 @@ Copyright:            Copyright © 2013-2016, University of Twente,                                   2016-2017, Myrtle Software Ltd,                                   2017-2019, QBayLogic B.V., Google Inc.,-                                  2020-2022, QBayLogic B.V.+                                  2021-2022, QBayLogic B.V. Category:             Hardware-Build-type:           Custom+Build-type:           Simple  Extra-source-files:   README.md                       CHANGELOG.md@@ -69,8 +69,8 @@ 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`.+    up to and including 62 elements - the GHC imposed maximum. Note that this+    greatly increases compile times for `clash-prelude`.   default: False   manual: True @@ -96,7 +96,7 @@     experimental feature, possibly triggering confusing error messages. By     default, it is enabled on development versions of Clash and disabled on     releases.-  default: False+  default: True   manual: True  flag doctests@@ -133,6 +133,7 @@                       InstanceSigs                       KindSignatures                       MagicHash+                      NoStarIsType                       ScopedTypeVariables                       StandaloneDeriving                       TupleSections@@ -140,15 +141,6 @@                       TypeOperators                       ViewPatterns -  if impl(ghc >= 8.6)-      default-extensions: NoStarIsType--custom-setup-  setup-depends:-    base          >= 4.9 && <5,-    Cabal         >= 1.10,-    cabal-doctest >= 1.0.1 && <1.1- Library   import:             common-options   HS-Source-Dirs:     src@@ -183,7 +175,15 @@                       Clash.Annotations.TH                        Clash.Class.AutoReg+                      Clash.Class.AutoReg.Internal                       Clash.Class.BitPack+                      Clash.Class.BitPack.BitIndex+                      Clash.Class.BitPack.BitReduction+                      Clash.Class.BitPack.Internal+                      Clash.Class.BitPack.Internal.TH+                      Clash.Class.Counter+                      Clash.Class.Counter.Internal+                      Clash.Class.Counter.TH                       Clash.Class.Exp                       Clash.Class.HasDomain                       Clash.Class.HasDomain.HasSingleDomain@@ -198,12 +198,15 @@                       Clash.Clocks.Deriving                        Clash.Explicit.BlockRam+                      Clash.Explicit.BlockRam.Blob                       Clash.Explicit.BlockRam.File+                      Clash.Explicit.BlockRam.Internal                       Clash.Explicit.DDR                       Clash.Explicit.Mealy                       Clash.Explicit.Moore                       Clash.Explicit.RAM                       Clash.Explicit.ROM+                      Clash.Explicit.ROM.Blob                       Clash.Explicit.ROM.File                       Clash.Explicit.Prelude                       Clash.Explicit.Prelude.Safe@@ -224,18 +227,26 @@                        Clash.Magic +                      Clash.Num.Erroring+                      Clash.Num.Overflowing+                      Clash.Num.Saturating+                      Clash.Num.Wrapping+                      Clash.Num.Zeroing+                       Clash.NamedTypes                        Clash.Prelude                       Clash.Prelude.BitIndex                       Clash.Prelude.BitReduction                       Clash.Prelude.BlockRam+                      Clash.Prelude.BlockRam.Blob                       Clash.Prelude.BlockRam.File                       Clash.Prelude.DataFlow                       Clash.Prelude.Mealy                       Clash.Prelude.Moore                       Clash.Prelude.RAM                       Clash.Prelude.ROM+                      Clash.Prelude.ROM.Blob                       Clash.Prelude.ROM.File                       Clash.Prelude.Safe                       Clash.Prelude.Testbench@@ -272,7 +283,6 @@                        Clash.Verification                       Clash.Verification.DSL-                      Clash.Verification.PrettyPrinters                       Clash.Verification.Internal                        Clash.XException@@ -284,13 +294,11 @@                        Clash.Tutorial                       Clash.Examples+                      Clash.Examples.Internal    other-modules:                       Clash.Class.AutoReg.Instances-                      Clash.Class.AutoReg.Internal-                      Clash.Class.BitPack.Internal                       Clash.CPP-                      Clash.Examples.Internal                       Clash.Signal.Bundle.Internal                       Language.Haskell.TH.Compat                       Paths_clash_prelude@@ -311,7 +319,6 @@   Build-depends:      array                     >= 0.5.1.0 && < 0.6,                       arrows                    >= 0.4     && < 0.5,                       base                      >= 4.11    && < 5,-                      bifunctors                >= 5.4.0   && < 6.0,                       binary                    >= 0.8.5   && < 0.11,                       bytestring                >= 0.10.8  && < 0.12,                       constraints               >= 0.9     && < 1.0,@@ -337,7 +344,6 @@                       th-lift                   >= 0.7.0    && < 0.9,                       th-orphans                >= 0.13.1   && < 1.0,                       text                      >= 0.11.3.1 && < 2.1,-                      text-show                 >= 3.7     && < 3.10,                       time                      >= 1.8     && < 1.14,                       transformers              >= 0.5.2.0 && < 0.7,                       type-errors               >= 0.2.0.0 && < 0.3,@@ -358,18 +364,14 @@   ghc-options:      -Wall -Wcompat -threaded   hs-source-dirs:   tests -  x-doctest-options: -fobject-code-   if !flag(doctests)     buildable: False   else     build-depends:       base,-      doctest >= 0.9.1 && < 0.19,-      clash-prelude-  if impl(ghc >= 8.6)-    build-depends:-      doctest >= 0.16.1+      clash-prelude,+      doctest-parallel >= 0.2 && < 0.3,+      filepath  test-suite unittests   import:           common-options@@ -389,6 +391,7 @@       ghc-typelits-extra,        base,+      bytestring,       deepseq,       hedgehog      >= 1.0.3    && < 1.1,       hint          >= 0.7      && < 0.10,@@ -401,15 +404,19 @@       template-haskell    Other-Modules:+                 Clash.Tests.AsyncFIFOSynchronizer                  Clash.Tests.AutoReg                  Clash.Tests.BitPack                  Clash.Tests.BitVector                  Clash.Tests.BlockRam+                 Clash.Tests.BlockRam.Blob+                 Clash.Tests.Counter                  Clash.Tests.DerivingDataRepr                  Clash.Tests.DerivingDataReprTypes                  Clash.Tests.Fixed                  Clash.Tests.FixedExhaustive                  Clash.Tests.NFDataX+                 Clash.Tests.NumNewtypes                  Clash.Tests.Ram                  Clash.Tests.Reset                  Clash.Tests.Resize@@ -435,6 +442,8 @@   ghc-options:      -O2 -Wall   hs-source-dirs:   benchmarks +  ghc-options:      -with-rtsopts=-T+   if !flag(benchmarks)     buildable: False   else@@ -442,6 +451,7 @@       base,       clash-prelude,       criterion         >= 1.3.0.0 && < 1.6,+      directory,       deepseq,       template-haskell 

@@ -9,8 +9,6 @@ -}  {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}  {-# OPTIONS_GHC -Wno-orphans #-} 

@@ -1,7 +1,8 @@ {-|-Copyright  :  (C) 2018, Google Inc.+Copyright  :  (C) 2018, Google Inc.,+                  2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  This module contains: @@ -58,6 +59,7 @@ import qualified Clash.Annotations.BitRepresentation.Util   as Util +import           Clash.Annotations.Primitive (hasBlackBox) import           Clash.Class.BitPack   (BitPack, BitSize, pack, packXWith, unpack) import           Clash.Class.Resize         (resize)@@ -851,6 +853,7 @@ dontApplyInHDL :: (a -> b) -> a -> b dontApplyInHDL f a = f a {-# NOINLINE dontApplyInHDL #-}+{-# ANN dontApplyInHDL hasBlackBox #-}  buildUnpackField   :: Name

@@ -8,7 +8,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}  module Clash.Annotations.BitRepresentation.Internal   ( buildCustomReprs@@ -27,7 +26,6 @@ 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)@@ -36,8 +34,6 @@ 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.@@ -48,16 +44,7 @@   -- ^ Qualified name of type   | LitTy' Integer   -- ^ 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'))+  deriving (Generic, NFData, Eq, Typeable, Hashable, Ord, Show)  -- | Internal version of DataRepr data DataRepr' = DataRepr'

@@ -4,8 +4,6 @@ Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE TemplateHaskell #-}- module Clash.Annotations.BitRepresentation.Util   ( bitOrigins   , bitOrigins'

@@ -1,7 +1,8 @@ {-|-Copyright  :  (C) 2017-2019, Myrtle Software, QBayLogic+Copyright  :  (C) 2017-2019, Myrtle Software+                  2022,      QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  Instruct the Clash compiler to look for primitive HDL templates provided inline or in a specified directory. For distribution of new packages with primitive@@ -234,7 +235,7 @@ -- Add more files to the @data-files@ stanza in your @.cabal@ files and more -- @ANN@ pragma's if you want to add more primitive templates for other HDLs ----- === Example of 'InlinePrimitive'+-- === Example of 'InlineYamlPrimitive' -- -- The following example shows off an inline HDL primitive template. It uses the -- [interpolate](https://hackage.haskell.org/package/interpolate) package for@@ -249,20 +250,17 @@ -- import           Data.String.Interpolate      (i) -- import           Data.String.Interpolate.Util (unindent) ----- {\-\# ANN example (InlinePrimitive [VHDL] $ unindent [i|---   [ { \"BlackBox\" :---       { "name" : "InlinePrimitive.example"---       , "kind": \"Declaration\"---       , "template" :---   "-- begin InlinePrimitive example:---   ~GENSYM[example][0] : block---   ~RESULT <= 1 + ~ARG[0];---   end block;---   -- end InlinePrimitive example"---       }---     }---   ]---   |]) \#-\}+-- {\-\# ANN example (InlineYamlPrimitive [VHDL] $ unindent [i|+--  BlackBox:+--    kind: Declaration+--    name: InlinePrimitive.example+--    template: |-+--      -- begin InlinePrimitive example:+--      ~GENSYM[example][0] : block+--      ~RESULT <= 1 + ~ARG[0];+--      end block;+--      end InlinePrimitive example+-- |]) \#-\} -- {\-\# NOINLINE example \#-\} -- example :: Signal System (BitVector 2) -> Signal System (BitVector 2) -- example = fmap succ@@ -271,7 +269,9 @@   = 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'+  -- ^ Description of a primitive for a given 'HDL's as an inline JSON 'String'+  | InlineYamlPrimitive [HDL] String+  -- ^ Description of a primitive for a given 'HDL's as an inline YAML 'String'   deriving (Show, Read, Data, Generic, NFData, Hashable, Eq)  -- | Primitive guard to mark a value as either not translatable or as having a

@@ -1,14 +1,14 @@ {-|-  Copyright   :  (C) 2018, Google Inc.+  Copyright   :  (C) 2018, Google Inc.,+                     2021, QBayLogic B.V.   License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>    API for synthesis attributes (sometimes refered to as "synthesis directives",   "pragmas", or "logic synthesis directives"). This is an experimental feature,   please report any unexpected or broken behavior to Clash's GitHub page   (<https://github.com/clash-lang/clash-compiler/issues>). -}-{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE PolyKinds #-}  {-# LANGUAGE Safe #-}@@ -68,7 +68,29 @@ -- For VHDL, see: --     <https://www.intel.com/content/www/us/en/programmable/quartushelp/current/index.htm#hdl/vhdl/vhdl_file_dir.htm> ----- Warning: This is an experimental feature, please report any unexpected or broken+-- = Warnings+--+-- When using annotations, it is important that annotated arguments are not+-- eta-reduced, as this may result in the annotation being stripped by GHC. For+-- example+--+-- @+-- f :: Signal System Bool \`Annotate\` 'StringAttr \"chip_pin\" \"C4\"+--   -> Signal System Bool+-- f x = id x -- Using a lambda, i.e. f = \x -> id x also works+-- @+--+-- will reliably show the annotation in the generated HDL, but+--+-- @+-- g :: Signal System Bool \`Annotate\` 'StringAttr \"chip_pin\" \"C4\"+--   -> Signal System Bool+-- g = id+-- @+--+-- will not work.+--+-- This is an experimental feature, please report any unexpected or broken -- behavior to Clash's GitHub page (<https://github.com/clash-lang/clash-compiler/issues>). data Attr   = BoolAttr Symbol Bool

@@ -71,9 +71,6 @@ 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           Data.Maybe                     ( catMaybes ) import           Language.Haskell.TH @@ -114,11 +111,8 @@   _ <> HasFail e               = HasFail e   HasFail e <> _               = HasFail e -instance (Semigroup a, Monoid a) => Monoid (Naming a) where+instance 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

@@ -1,8 +1,9 @@ {-| Copyright  :  (C) 2015-2016, University of Twente,-                  2017     , Google Inc.+                  2017     , Google Inc.,+                  2021     , QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  'TopEntity' annotations allow us to control hierarchy and naming aspects of the Clash compiler. We have the 'Synthesize' and 'TestBench' annotation.@@ -103,7 +104,6 @@     'Clash.Prelude.resetSynchronizer'       clk50       ('Clash.Signal.unsafeFromLowPolarity' pllStable)-      enableGen  blinkerT   :: (BitVector 8, Bool, Index 16650001)

@@ -3,7 +3,6 @@   License     :  BSD2 (see the file LICENSE)   Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com> -}-{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-}  {-# OPTIONS_GHC -Wno-orphans #-}@@ -14,18 +13,12 @@ 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  -- | __N.B.__: The documentation only shows instances up to /3/-tuples. By

@@ -1,7 +1,9 @@ {-|-  Copyright   :  (C) 2019, Google Inc.+  Copyright   :  (C) 2019     , Google Inc.,+                     2021     , QBayLogic B.V.+                     2021     , Myrtle.ai   License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+  Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}@@ -9,9 +11,6 @@ {-# 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 (..)@@ -55,7 +54,7 @@  -- $setup -- >>> import Data.Maybe--- >>> import Clash.Class.BitPack (pack)+-- >>> import Clash.Prelude -- >>> :set -fplugin GHC.TypeLits.Normalise -- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver @@ -77,12 +76,12 @@ --   when viewed as bits, a 'Nothing' would look like: -- --     >>> pack @(Maybe (Signed 16)) Nothing---     0_...._...._...._....+--     0b0_...._...._...._.... -- --   and 'Just' -- --     >>> pack @(Maybe (Signed 16)) (Just 3)---     1_0000_0000_0000_0011+--     0b1_0000_0000_0000_0011 -- --   In the first case, Nothing, we don't particularly care about updating the --   register holding the @Signed 16@ field, as they'll be unknown anyway. We@@ -159,7 +158,7 @@      val = fromMaybe (deepErrorX "autoReg'.val") <$> input      valInit = fromMaybe (deepErrorX "autoReg'.valInit") initVal -     valR = autoReg clk rst (enable en tag) valInit val+     valR = autoReg clk rst (andEnable en tag) valInit val       createMaybe t v = case t of        True -> Just v@@ -210,9 +209,7 @@     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@@ -461,6 +458,7 @@                   Just m  -> m       ConT _ -> ty'       AppT ty1 ty2 -> AppT (go ty1) (go ty2)+      LitT _ -> ty'       _ -> error $ "TODO applyTyVarSubsts: " ++ show ty'  

@@ -1,27 +1,16 @@+ {-|-Copyright  :  (C) 2013-2016, University of Twente,+Copyright  :  (C) 2013-2016, University of Twente                   2016-2017, Myrtle Software Ltd+                       2021, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -}--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}-{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}-{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}-{-# OPTIONS_HADDOCK show-extensions #-}--#include "MachDeps.h"+{-# LANGUAGE Safe #-}  module Clash.Class.BitPack   ( BitPack (..)+  , isLike   , bitCoerce   , bitCoerceMap   , boolToBV@@ -29,387 +18,22 @@   , bitToBool   , packXWith -  -- * Internals-  , GBitPack(..)+  -- * Bit Indexing+  , (!)+  , slice+  , split+  , replaceBit+  , setSlice+  , msb+  , lsb++  -- * Bit Reduction+  , reduceAnd+  , reduceOr+  , reduceXor   ) where -import Control.Exception              (catch, evaluate)-import Data.Binary.IEEE754            (doubleToWord, floatToWord, wordToDouble,-                                       wordToFloat)--#if MIN_VERSION_base(4,12,0)-import Data.Complex                   (Complex)-import Data.Ord                       (Down)-#endif--import Data.Int-import Data.Word-import Foreign.C.Types                (CUShort)-import GHC.TypeLits                   (KnownNat, Nat, type (+), type (-))-import Numeric.Half                   (Half (..))-import GHC.Generics-import GHC.TypeLits.Extra             (CLog, Max)-import Prelude                        hiding (map)-import System.IO.Unsafe               (unsafeDupablePerformIO)--import Clash.Promoted.Nat             (SNat(..), snatToNum)-import Clash.Class.BitPack.Internal   (deriveBitPackTuples)-import Clash.Class.Resize             (zeroExtend, resize)-import Clash.Sized.BitVector          (Bit, BitVector, (++#))-import Clash.Sized.Internal.BitVector-  (pack#, split#, checkUnpackUndef, undefined#, unpack#, unsafeToNatural)-import Clash.XException--{- $setup->>> :set -XDataKinds->>> import Clash.Prelude--}---- | Convert to and from a 'BitVector'-class KnownNat (BitSize a) => BitPack a where-  -- | Number of 'Clash.Sized.BitVector.Bit's needed to represents elements-  -- of type @a@-  ---  -- Can be derived using `GHC.Generics`:-  ---  -- > import Clash.Prelude-  -- > import GHC.Generics-  -- >-  -- > data MyProductType = MyProductType { a :: Int, b :: Bool }-  -- >   deriving (Generic, BitPack)-  type BitSize a :: Nat-  type BitSize a = (CLog 2 (GConstructorCount (Rep a))) + (GFieldSize (Rep a))-  -- | Convert element of type @a@ to a 'BitVector'-  ---  -- >>> pack (-5 :: Signed 6)-  -- 11_1011-  pack   :: a -> BitVector (BitSize a)-  default pack-    :: ( Generic a-       , GBitPack (Rep a)-       , KnownNat (BitSize a)-       , KnownNat constrSize-       , KnownNat fieldSize-       , constrSize ~ CLog 2 (GConstructorCount (Rep a))-       , fieldSize ~ GFieldSize (Rep a)-       , (constrSize + fieldSize) ~ BitSize a-       )-    => a -> BitVector (BitSize a)-  pack = packXWith go-   where-    go a = resize (pack sc) ++# packedFields-     where-      (sc, packedFields) = gPackFields 0 (from a)--  -- | Convert a 'BitVector' to an element of type @a@-  ---  -- >>> pack (-5 :: Signed 6)-  -- 11_1011-  -- >>> let x = pack (-5 :: Signed 6)-  -- >>> unpack x :: Unsigned 6-  -- 59-  -- >>> pack (59 :: Unsigned 6)-  -- 11_1011-  unpack :: BitVector (BitSize a) -> a-  default unpack-    :: ( Generic a-       , GBitPack (Rep a)-       , KnownNat constrSize-       , KnownNat fieldSize-       , constrSize ~ CLog 2 (GConstructorCount (Rep a))-       , fieldSize ~ GFieldSize (Rep a)-       , (constrSize + fieldSize) ~ BitSize a-       )-    => BitVector (BitSize a) -> a-  unpack b =-    to (gUnpack sc 0 bFields)-   where-    (checkUnpackUndef unpack . resize -> sc, bFields) = split# b--packXWith-  :: KnownNat n-  => (a -> BitVector n)-  -> a-  -> BitVector n-packXWith f x =-  unsafeDupablePerformIO (catch (f <$> evaluate x)-                                (\(XException _) -> return undefined#))-{-# NOINLINE packXWith #-}--{-# INLINE[1] bitCoerce #-}--- | Coerce a value from one type to another through its bit representation.------ >>> pack (-5 :: Signed 6)--- 11_1011--- >>> bitCoerce (-5 :: Signed 6) :: Unsigned 6--- 59--- >>> pack (59 :: Unsigned 6)--- 11_1011-bitCoerce-  :: (BitPack a, BitPack b, BitSize a ~ BitSize b)-  => a-  -> b-bitCoerce = unpack . pack---- | 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-  unpack = checkUnpackUndef $ \bv -> if bv == 1 then True else False--instance KnownNat n => BitPack (BitVector n) where-  type BitSize (BitVector n) = n-  pack     = packXWith id-  unpack v = v--instance BitPack Bit where-  type BitSize Bit = 1-  pack   = packXWith pack#-  unpack = unpack#--instance BitPack Int where-  type BitSize Int = WORD_SIZE_IN_BITS-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Int8 where-  type BitSize Int8 = 8-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Int16 where-  type BitSize Int16 = 16-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Int32 where-  type BitSize Int32 = 32-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Int64 where-  type BitSize Int64 = 64-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Word where-  type BitSize Word = WORD_SIZE_IN_BITS-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Word8 where-  type BitSize Word8 = 8-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Word16 where-  type BitSize Word16 = 16-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Word32 where-  type BitSize Word32 = 32-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Word64 where-  type BitSize Word64 = 64-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Float where-  type BitSize Float = 32-  pack   = packXWith packFloat#-  unpack = checkUnpackUndef unpackFloat#--packFloat# :: Float -> BitVector 32-packFloat# = fromIntegral . floatToWord-{-# NOINLINE packFloat# #-}--unpackFloat# :: BitVector 32 -> Float-unpackFloat# (unsafeToNatural -> w) = wordToFloat (fromIntegral w)-{-# NOINLINE unpackFloat# #-}--instance BitPack Double where-  type BitSize Double = 64-  pack   = packXWith packDouble#-  unpack = checkUnpackUndef unpackDouble#--packDouble# :: Double -> BitVector 64-packDouble# = fromIntegral . doubleToWord-{-# NOINLINE packDouble# #-}--unpackDouble# :: BitVector 64 -> Double-unpackDouble# (unsafeToNatural -> w) = wordToDouble (fromIntegral w)-{-# NOINLINE unpackDouble# #-}--instance BitPack CUShort where-  type BitSize CUShort = 16-  pack   = packXWith fromIntegral-  unpack = checkUnpackUndef fromIntegral--instance BitPack Half where-  type BitSize Half = 16-  pack (Half x) = pack x-  unpack        = checkUnpackUndef $ \x -> Half (unpack x)--instance BitPack () where-  type BitSize () = 0-  pack   _ = minBound-  unpack _ = ()---- | __N.B.__: The documentation only shows instances up to /3/-tuples. By--- default, instances up to and including /12/-tuples will exist. If the flag--- @large-tuples@ is set instances up to the GHC imposed limit will exist. The--- GHC imposed limit is either 62 or 64 depending on the GHC version.-instance (BitPack a, BitPack b) =>-    BitPack (a,b) where-  type BitSize (a,b) = BitSize a + BitSize b-  pack = let go (a,b) = pack a ++# pack b in packXWith go-  unpack ab  = let (a,b) = split# ab in (unpack a, unpack b)--class GBitPack f where-  -- | Size of fields. If multiple constructors exist, this is the maximum of-  -- the sum of each of the constructors fields.-  type GFieldSize f :: Nat--  -- | Number of constructors this type has. Indirectly indicates how many bits-  -- are needed to represent the constructor.-  type GConstructorCount f :: Nat--  -- | Pack fields of a type. Caller should pack and prepend the constructor bits.-  gPackFields-    :: Int-    -- ^ Current constructor-    -> f a-    -- ^ Data to pack-    -> (Int, BitVector (GFieldSize f))-    -- ^ (Constructor number, Packed fields)--  -- | Unpack whole type.-  gUnpack-    :: Int-    -- ^ Construct with constructor /n/-    -> Int-    -- ^ Current constructor-    -> BitVector (GFieldSize f)-    -- ^ BitVector containing fields-    -> f a-    -- ^ Unpacked result--instance GBitPack a => GBitPack (M1 m d a) where-  type GFieldSize (M1 m d a) = GFieldSize a-  type GConstructorCount (M1 m d a) = GConstructorCount a--  gPackFields cc (M1 m1) = gPackFields cc m1-  gUnpack c cc b = M1 (gUnpack c cc b)--instance ( KnownNat (GFieldSize g)-         , KnownNat (GFieldSize f)-         , KnownNat (GConstructorCount f)-         , GBitPack f-         , GBitPack g-         ) => GBitPack (f :+: g) where-  type GFieldSize (f :+: g) = Max (GFieldSize f) (GFieldSize g)-  type GConstructorCount (f :+: g) = GConstructorCount f + GConstructorCount g--  gPackFields cc (L1 l) =-    let (sc, packed) = gPackFields cc l in-    let padding = undefined# :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize f) in-    (sc, packed ++# padding)-  gPackFields cc (R1 r) =-    let cLeft = snatToNum (SNat @(GConstructorCount f)) in-    let (sc, packed) = gPackFields (cc + cLeft) r in-    let padding = undefined# :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize g) in-    (sc, packed ++# padding)--  gUnpack c cc b =-    let cLeft = snatToNum (SNat @(GConstructorCount f)) in-    if c < cc + cLeft then-      L1 (gUnpack c cc f)-    else-      R1 (gUnpack c (cc + cLeft) g)--   where-    -- It's a thing of beauty, if I may say so myself!-    (f, _ :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize f)) = split# b-    (g, _ :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize g)) = split# b---instance (KnownNat (GFieldSize g), KnownNat (GFieldSize f), GBitPack f, GBitPack g) => GBitPack (f :*: g) where-  type GFieldSize (f :*: g) = GFieldSize f + GFieldSize g-  type GConstructorCount (f :*: g) = 1--  gPackFields cc fg =-    (cc, packXWith go fg)-   where-    go (l0 :*: r0) =-      let (_, l1) = gPackFields cc l0 in-      let (_, r1) = gPackFields cc r0 in-      l1 ++# r1--  gUnpack c cc b =-    gUnpack c cc front :*: gUnpack c cc back-   where-    (front, back) = split# b--instance BitPack c => GBitPack (K1 i c) where-  type GFieldSize (K1 i c) = BitSize c-  type GConstructorCount (K1 i c)  = 1--  gPackFields cc (K1 i) = (cc, pack i)-  gUnpack _c _cc b      = K1 (unpack b)--instance GBitPack U1 where-  type GFieldSize U1 = 0-  type GConstructorCount U1 = 1--  gPackFields cc U1 = (cc, 0)-  gUnpack _c _cc _b = U1---- Instances derived using Generic-instance ( BitPack a-         , BitPack b-         ) => BitPack (Either a b)--instance BitPack a => BitPack (Maybe a)--#if MIN_VERSION_base(4,12,0)-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.------ >>> boolToBV True :: BitVector 6--- 00_0001--- >>> boolToBV False :: BitVector 6--- 00_0000-boolToBV :: KnownNat n => Bool -> BitVector (n + 1)-boolToBV = zeroExtend . pack---- | Convert a Bool to a Bit-boolToBit :: Bool -> Bit-boolToBit = bitCoerce---- | Convert a Bool to a Bit-bitToBool :: Bit -> Bool-bitToBool = bitCoerce---- Derive the BitPack instance for tuples of size 3 to 62-deriveBitPackTuples ''BitPack ''BitSize 'pack 'unpack+import Clash.Class.BitPack.Internal+import Clash.Class.BitPack.BitIndex+import Clash.Class.BitPack.BitReduction

@@ -0,0 +1,160 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente+                       2021, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Class.BitPack.BitIndex where++import GHC.TypeLits                   (KnownNat, type (+), type (-))++import Clash.Class.BitPack.Internal   (BitPack (..))+import Clash.Promoted.Nat             (SNat (..))+import Clash.Sized.Internal.BitVector+  (BitVector, Bit, index#, lsb#, msb#, replaceBit#, setSlice#, slice#, split#)++{- $setup+>>> :set -XDataKinds+>>> import Clash.Prelude+-}++{-# INLINE (!) #-}+-- | Get the bit at the specified bit index.+--+-- __NB:__ Bit indices are __DESCENDING__.+--+-- >>> pack (7 :: Unsigned 6)+-- 0b00_0111+-- >>> (7 :: Unsigned 6) ! 1+-- 1+-- >>> (7 :: Unsigned 6) ! 5+-- 0+-- >>> (7 :: Unsigned 6) ! 6+-- *** Exception: (!): 6 is out of range [5..0]+-- ...+(!) :: (BitPack a, Enum i) => a -> i -> Bit+(!) v i = index# (pack v) (fromEnum i)++{-# INLINE slice #-}+-- | Get a slice between bit index @m@ and and bit index @n@.+--+-- __NB:__ Bit indices are __DESCENDING__.+--+-- >>> pack (7 :: Unsigned 6)+-- 0b00_0111+-- >>> slice d4 d2 (7 :: Unsigned 6)+-- 0b001+-- >>> slice d6 d4 (7 :: Unsigned 6)+-- <BLANKLINE>+-- <interactive>:...+--     • Couldn't match type ‘7 + i0’ with ‘6’+--         arising from a use of ‘slice’+--       The type variable ‘i0’ is ambiguous+--     • In the expression: slice d6 d4 (7 :: Unsigned 6)+--       In an equation for ‘it’: it = slice d6 d4 (7 :: Unsigned 6)+slice+  :: (BitPack a, BitSize a ~ ((m + 1) + i))+  => SNat m+  -> SNat n+  -> a+  -> BitVector (m + 1 - n)+slice m n v = slice# (pack v) m n++{-# INLINE split #-}+-- | Split a value of a bit size @m + n@ into a tuple of values with size @m@+-- and size @n@.+--+-- >>> pack (7 :: Unsigned 6)+-- 0b00_0111+-- >>> split (7 :: Unsigned 6) :: (BitVector 2, BitVector 4)+-- (0b00,0b0111)+split+  :: (BitPack a, BitSize a ~ (m + n), KnownNat n)+  => a+  -> (BitVector m, BitVector n)+split v = split# (pack v)++{-# INLINE replaceBit #-}+-- | Set the bit at the specified index+--+-- __NB:__ Bit indices are __DESCENDING__.+--+-- >>> pack (-5 :: Signed 6)+-- 0b11_1011+-- >>> replaceBit 4 0 (-5 :: Signed 6)+-- -21+-- >>> pack (-21 :: Signed 6)+-- 0b10_1011+-- >>> replaceBit 5 0 (-5 :: Signed 6)+-- 27+-- >>> pack (27 :: Signed 6)+-- 0b01_1011+-- >>> replaceBit 6 0 (-5 :: Signed 6)+-- *** Exception: replaceBit: 6 is out of range [5..0]+-- ...+replaceBit :: (BitPack a, Enum i) => i -> Bit -> a -> a+replaceBit i b v = unpack (replaceBit# (pack v) (fromEnum i) b)++{-# INLINE setSlice #-}+-- | Set the bits between bit index @m@ and bit index @n@.+--+-- __NB:__ Bit indices are __DESCENDING__.+--+-- >>> pack (-5 :: Signed 6)+-- 0b11_1011+-- >>> setSlice d4 d3 0 (-5 :: Signed 6)+-- -29+-- >>> pack (-29 :: Signed 6)+-- 0b10_0011+-- >>> setSlice d6 d5 0 (-5 :: Signed 6)+-- <BLANKLINE>+-- <interactive>:...+--     • Couldn't match type ‘7 + i0’ with ‘6’+--         arising from a use of ‘setSlice’+--       The type variable ‘i0’ is ambiguous+--     • In the expression: setSlice d6 d5 0 (- 5 :: Signed 6)+--       In an equation for ‘it’: it = setSlice d6 d5 0 (- 5 :: Signed 6)+setSlice+  :: (BitPack a, BitSize a ~ ((m + 1) + i))+  => SNat m+  -> SNat n+  -> BitVector (m + 1 - n)+  -> a+  -> a+setSlice m n w v = unpack (setSlice# SNat (pack v) m n w)++{-# INLINE msb #-}+-- | Get the most significant bit.+--+-- >>> pack (-4 :: Signed 6)+-- 0b11_1100+-- >>> msb (-4 :: Signed 6)+-- 1+-- >>> pack (4 :: Signed 6)+-- 0b00_0100+-- >>> msb (4 :: Signed 6)+-- 0+msb :: BitPack a => a -> Bit+msb v = msb# (pack v)++{-# INLINE lsb #-}+-- | Get the least significant bit.+--+-- >>> pack (-9 :: Signed 6)+-- 0b11_0111+-- >>> lsb (-9 :: Signed 6)+-- 1+-- >>> pack (-8 :: Signed 6)+-- 0b11_1000+-- >>> lsb (-8 :: Signed 6)+-- 0+lsb :: BitPack a => a -> Bit+lsb v = lsb# (pack v)

@@ -0,0 +1,83 @@+{-|+Copyright  :  (C) 2013-2016, University of Twente,+                  2021,      QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleContexts #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Class.BitPack.BitReduction where++import Clash.Class.BitPack.Internal   (BitPack (..))+import Clash.Sized.Internal.BitVector (Bit, reduceAnd#, reduceOr#, reduceXor#)++{- $setup+>>> :set -XDataKinds+>>> import Clash.Prelude+-}++{-# INLINE reduceAnd #-}+-- | Are all bits set to '1'?+--+-- >>> pack (-2 :: Signed 6)+-- 0b11_1110+-- >>> reduceAnd (-2 :: Signed 6)+-- 0+-- >>> pack (-1 :: Signed 6)+-- 0b11_1111+-- >>> reduceAnd (-1 :: Signed 6)+-- 1+--+-- Zero width types will evaluate to '1':+--+-- >>> reduceAnd (0 :: Unsigned 0)+-- 1+reduceAnd :: BitPack a => a -> Bit+reduceAnd v = reduceAnd# (pack v)++{-# INLINE reduceOr #-}+-- | Is there at least one bit set to '1'?+--+-- >>> pack (5 :: Signed 6)+-- 0b00_0101+-- >>> reduceOr (5 :: Signed 6)+-- 1+-- >>> pack (0 :: Signed 6)+-- 0b00_0000+-- >>> reduceOr (0 :: Signed 6)+-- 0+--+-- Zero width types will evaluate to '0':+--+-- >>> reduceOr (0 :: Unsigned 0)+-- 0+reduceOr :: BitPack a => a -> Bit+reduceOr v = reduceOr# (pack v)++{-# INLINE reduceXor #-}+-- | Is the number of bits set to '1' uneven?+--+-- >>> pack (5 :: Signed 6)+-- 0b00_0101+-- >>> reduceXor (5 :: Signed 6)+-- 0+-- >>> pack (28 :: Signed 6)+-- 0b01_1100+-- >>> reduceXor (28 :: Signed 6)+-- 1+-- >>> pack (-5 :: Signed 6)+-- 0b11_1011+-- >>> reduceXor (-5 :: Signed 6)+-- 1+--+-- Zero width types will evaluate to '0':+--+-- >>> reduceXor (0 :: Unsigned 0)+-- 0+reduceXor :: BitPack a => a -> Bit+reduceXor v = reduceXor# (pack v)

@@ -1,102 +1,464 @@ {-|-Copyright  :  (C) 2019, QBayLogic B.V.+Copyright  :  (C) 2013-2016, University of Twente,+                  2016-2017, Myrtle Software Ltd,+                  2021,      QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -}+ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -module Clash.Class.BitPack.Internal (deriveBitPackTuples) where+{-# LANGUAGE Trustworthy #-} -import           Clash.CPP             (maxTupleSize)-import           Language.Haskell.TH.Compat (mkTySynInstD,mkTupE)-import           Control.Monad         (replicateM)-import           Data.List             (foldl')-import           GHC.TypeLits          (KnownNat)-import           Language.Haskell.TH+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_HADDOCK show-extensions #-} --- | Contruct all the tuple (starting at size 3) instances for BitPack.-deriveBitPackTuples-  :: Name-  -- ^ BitPack-  -> Name-  -- ^ BitSize-  -> Name-  -- ^ pack-  -> Name-  -- ^ unpack-  -> DecsQ-deriveBitPackTuples bitPackName bitSizeName packName unpackName = do-  let bitPack  = ConT bitPackName-      bitSize  = ConT bitSizeName-      knownNat = ConT ''KnownNat-      plus     = ConT $ mkName "+"+#include "MachDeps.h" -  allNames <- replicateM maxTupleSize (newName "a")-  retupName <- newName "retup"-  x <- newName "x"-  y <- newName "y"-  tup <- newName "tup"+module Clash.Class.BitPack.Internal where -  pure $ flip map [3..maxTupleSize] $ \tupleNum ->-    let names  = take tupleNum allNames-        (v:vs) = fmap VarT names-        tuple xs = foldl' AppT (TupleT $ length xs) xs+import Prelude                        hiding (map) -        -- Instance declaration-        context =-          [ bitPack `AppT` v-          , knownNat `AppT` (bitSize `AppT` v)-          , bitPack `AppT` tuple vs-          , knownNat `AppT` (bitSize `AppT` tuple vs)-          ]-        instTy = AppT bitPack $ tuple (v:vs)+import Control.Exception              (catch, evaluate)+import Data.Binary.IEEE754            (doubleToWord, floatToWord, wordToDouble,+                                       wordToFloat) -        -- Associated type BitSize-        bitSizeType =-          mkTySynInstD bitSizeName [tuple (v:vs)]-            $ plus `AppT` (bitSize `AppT` v) `AppT`-              (bitSize `AppT` foldl AppT (TupleT $ tupleNum - 1) vs)+import Data.Complex                   (Complex)+import Data.Int+import Data.Ord                       (Down)+import Data.Word+import Foreign.C.Types                (CUShort)+import GHC.Generics+import GHC.TypeLits                   (KnownNat, Nat, type (+), type (-))+import GHC.TypeLits.Extra             (CLog, Max)+import Numeric.Half                   (Half (..))+import System.IO.Unsafe               (unsafeDupablePerformIO) -        pack =-          FunD-            packName-            [ Clause-                [VarP tup]-                (NormalB (AppE (VarE packName) (AppE (VarE retupName) (VarE tup))))-                [FunD-                    retupName-                    [ Clause-                        [ TupP $ map VarP names ]-                        ( let (e:es) = map VarE names-                          in NormalB (mkTupE [e,mkTupE es])-                        )-                        []-                    ]-                ]-            ]+import Clash.Annotations.Primitive    (hasBlackBox)+import Clash.Class.BitPack.Internal.TH (deriveBitPackTuples)+import Clash.Class.Resize             (zeroExtend, resize)+import Clash.Promoted.Nat             (SNat(..), snatToNum)+import Clash.Sized.BitVector          (Bit, BitVector, (++#))+import Clash.Sized.Internal.BitVector+  (pack#, split#, checkUnpackUndef, undefined#, unpack#, unsafeToNatural, isLike#)+import Clash.XException -        unpack =-          FunD-            unpackName-            [ Clause-                [ VarP x ]-                ( NormalB $-                    let (p:ps) = map VarP names-                    in-                    LetE-                      [ ValD-                          ( TupP [ p, VarP y ] )-                          ( NormalB $ VarE unpackName `AppE` VarE x )-                          []-                      , ValD-                          ( TupP ps )-                          ( NormalB $ VarE unpackName `AppE` VarE y )-                          []-                      ]-                      ( mkTupE $ map VarE names )-                )-                []-            ]+{- $setup+>>> :m -Prelude+>>> :set -XDataKinds+>>> import Clash.Prelude+-} -    in InstanceD Nothing context instTy [bitSizeType, pack, unpack]+-- | Convert data to/from a 'BitVector'. This allows functions to be defined+-- on the underlying representation of data, while exposing a nicer API using+-- 'pack' / 'unpack' at the boundaries. For example:+--+-- @+--     f :: forall a b. (BitPack a, BitPack b) => a -> b+--     f = unpack . go . pack+--      where+--       go :: BitVector (BitSize a) -> BitVector (BitSize b)+--       go = _ -- A function on the underlying bit vector+-- @+--+-- A type should only implement this class if it has a statically known size,+-- as otherwise it is not possible to determine how many bits are needed to+-- represent values. This means that types such as @[a]@ cannot have @BitPack@+-- instances, as even if @a@ has a statically known size, the length of the+-- list cannot be known in advance.+--+-- Clash provides some generic functions on packable types in the prelude, such+-- as indexing into packable stuctures (see "Clash.Class.BitPack.BitIndex") and+-- bitwise reduction of packable data (see "Clash.Class.BitPack.BitReduction").+--+class KnownNat (BitSize a) => BitPack a where+  -- | Number of 'Clash.Sized.BitVector.Bit's needed to represents elements+  -- of type @a@+  --+  -- Can be derived using `GHC.Generics`:+  --+  -- > import Clash.Prelude+  -- > import GHC.Generics+  -- >+  -- > data MyProductType = MyProductType { a :: Int, b :: Bool }+  -- >   deriving (Generic, BitPack)+  type BitSize a :: Nat+  type BitSize a = (CLog 2 (GConstructorCount (Rep a))) + (GFieldSize (Rep a))+  -- | Convert element of type @a@ to a 'BitVector'+  --+  -- >>> pack (-5 :: Signed 6)+  -- 0b11_1011+  pack   :: a -> BitVector (BitSize a)+  default pack+    :: ( Generic a+       , GBitPack (Rep a)+       , KnownNat (BitSize a)+       , KnownNat constrSize+       , KnownNat fieldSize+       , constrSize ~ CLog 2 (GConstructorCount (Rep a))+       , fieldSize ~ GFieldSize (Rep a)+       , (constrSize + fieldSize) ~ BitSize a+       )+    => a -> BitVector (BitSize a)+  pack = packXWith go+   where+    go a = resize (pack sc) ++# packedFields+     where+      (sc, packedFields) = gPackFields 0 (from a)++  -- | Convert a 'BitVector' to an element of type @a@+  --+  -- >>> pack (-5 :: Signed 6)+  -- 0b11_1011+  -- >>> let x = pack (-5 :: Signed 6)+  -- >>> unpack x :: Unsigned 6+  -- 59+  -- >>> pack (59 :: Unsigned 6)+  -- 0b11_1011+  unpack :: BitVector (BitSize a) -> a+  default unpack+    :: ( Generic a+       , GBitPack (Rep a)+       , KnownNat constrSize+       , KnownNat fieldSize+       , constrSize ~ CLog 2 (GConstructorCount (Rep a))+       , fieldSize ~ GFieldSize (Rep a)+       , (constrSize + fieldSize) ~ BitSize a+       )+    => BitVector (BitSize a) -> a+  unpack b =+    to (gUnpack sc 0 bFields)+   where+    (checkUnpackUndef unpack . resize -> sc, bFields) = split# b++packXWith+  :: KnownNat n+  => (a -> BitVector n)+  -> a+  -> BitVector n+packXWith f x =+  unsafeDupablePerformIO (catch (f <$> evaluate x)+                                (\(XException _) -> return undefined#))+{-# NOINLINE packXWith #-}++-- | Pack both arguments to a 'BitVector' and use+-- 'Clash.Sized.Internal.BitVector.isLike#' to compare them. This is a more+-- lentiant comparison than '(==)', behaving more like (but not necessarily+-- exactly the same as) @std_match@ in VHDL or @casez@ in Verilog.+--+-- Unlike '(==)', isLike is not symmetric. The reason for this is that a+-- defined bit is said to be like an undefined bit, but not vice-versa:+--+-- >>> isLike (12 :: Signed 8) undefined+-- True+-- >>> isLike undefined (12 :: Signed 8)+-- False+--+-- However, it is still trivially reflexive and transitive:+--+-- >>> :set -XTemplateHaskell+-- >>> let x1 = $(bLit "0010")+-- >>> let x2 = $(bLit "0.10")+-- >>> let x3 = $(bLit "0.1.")+-- >>> isLike x1 x1+-- True+-- >>> isLike x1 x2+-- True+-- >>> isLike x2 x3+-- True+-- >>> isLike x1 x3+-- True+--+-- __N.B.__: Not synthesizable+--+isLike+  :: (BitPack a)+  => a+  -> a+  -> Bool+isLike x y =+  isLike# (pack x) (pack y)++{-# INLINE[1] bitCoerce #-}+-- | Coerce a value from one type to another through its bit representation.+--+-- >>> pack (-5 :: Signed 6)+-- 0b11_1011+-- >>> bitCoerce (-5 :: Signed 6) :: Unsigned 6+-- 59+-- >>> pack (59 :: Unsigned 6)+-- 0b11_1011+bitCoerce+  :: (BitPack a, BitPack b, BitSize a ~ BitSize b)+  => a+  -> b+bitCoerce = unpack . pack++-- | Map a value by first coercing to another type through its bit representation.+--+-- >>> pack (-5 :: Signed 32)+-- 0b1111_1111_1111_1111_1111_1111_1111_1011+-- >>> bitCoerceMap @(Vec 4 (BitVector 8)) (replace 1 0) (-5 :: Signed 32)+-- -16711685+-- >>> pack (-16711685 :: Signed 32)+-- 0b1111_1111_0000_0000_1111_1111_1111_1011+bitCoerceMap+  :: forall a b . (BitPack a, BitPack b, BitSize a ~ BitSize b)+  => (a -> a)+  -> b+  -> b+bitCoerceMap f = bitCoerce . f . bitCoerce++instance BitPack Bool where+  type BitSize Bool = 1+  pack   = let go b = if b then 1 else 0 in packXWith go+  unpack = checkUnpackUndef $ \bv -> if bv == 1 then True else False++instance KnownNat n => BitPack (BitVector n) where+  type BitSize (BitVector n) = n+  pack     = packXWith id+  unpack v = v++instance BitPack Bit where+  type BitSize Bit = 1+  pack   = packXWith pack#+  unpack = unpack#++instance BitPack Int where+  type BitSize Int = WORD_SIZE_IN_BITS+  pack   = packXWith fromIntegral+  unpack = checkUnpackUndef fromIntegral++instance BitPack Int8 where+  type BitSize Int8 = 8+  pack   = packXWith fromIntegral+  unpack = checkUnpackUndef fromIntegral++instance BitPack Int16 where+  type BitSize Int16 = 16+  pack   = packXWith fromIntegral+  unpack = checkUnpackUndef fromIntegral++instance BitPack Int32 where+  type BitSize Int32 = 32+  pack   = packXWith fromIntegral+  unpack = checkUnpackUndef fromIntegral++instance BitPack Int64 where+  type BitSize Int64 = 64+  pack   = packXWith fromIntegral+  unpack = checkUnpackUndef fromIntegral++instance BitPack Word where+  type BitSize Word = WORD_SIZE_IN_BITS+  pack   = packXWith fromIntegral+  unpack = checkUnpackUndef fromIntegral++instance BitPack Word8 where+  type BitSize Word8 = 8+  pack   = packXWith fromIntegral+  unpack = checkUnpackUndef fromIntegral++instance BitPack Word16 where+  type BitSize Word16 = 16+  pack   = packXWith fromIntegral+  unpack = checkUnpackUndef fromIntegral++instance BitPack Word32 where+  type BitSize Word32 = 32+  pack   = packXWith fromIntegral+  unpack = checkUnpackUndef fromIntegral++instance BitPack Word64 where+  type BitSize Word64 = 64+  pack   = packXWith fromIntegral+  unpack = checkUnpackUndef fromIntegral++instance BitPack Float where+  type BitSize Float = 32+  pack   = packXWith packFloat#+  unpack = checkUnpackUndef unpackFloat#++packFloat# :: Float -> BitVector 32+packFloat# = fromIntegral . floatToWord+{-# NOINLINE packFloat# #-}+{-# ANN packFloat# hasBlackBox #-}++unpackFloat# :: BitVector 32 -> Float+unpackFloat# (unsafeToNatural -> w) = wordToFloat (fromIntegral w)+{-# NOINLINE unpackFloat# #-}+{-# ANN unpackFloat# hasBlackBox #-}++instance BitPack Double where+  type BitSize Double = 64+  pack   = packXWith packDouble#+  unpack = checkUnpackUndef unpackDouble#++packDouble# :: Double -> BitVector 64+packDouble# = fromIntegral . doubleToWord+{-# NOINLINE packDouble# #-}+{-# ANN packDouble# hasBlackBox #-}++unpackDouble# :: BitVector 64 -> Double+unpackDouble# (unsafeToNatural -> w) = wordToDouble (fromIntegral w)+{-# NOINLINE unpackDouble# #-}+{-# ANN unpackDouble# hasBlackBox #-}++instance BitPack CUShort where+  type BitSize CUShort = 16+  pack   = packXWith fromIntegral+  unpack = checkUnpackUndef fromIntegral++instance BitPack Half where+  type BitSize Half = 16+  pack (Half x) = pack x+  unpack        = checkUnpackUndef $ \x -> Half (unpack x)++instance BitPack () where+  type BitSize () = 0+  pack   _ = minBound+  unpack _ = ()++-- | __N.B.__: The documentation only shows instances up to /3/-tuples. By+-- default, instances up to and including /12/-tuples will exist. If the flag+-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The+-- GHC imposed limit is either 62 or 64 depending on the GHC version.+instance (BitPack a, BitPack b) => BitPack (a,b) where+  type BitSize (a,b) = BitSize a + BitSize b+  pack = let go (a,b) = pack a ++# pack b in packXWith go+  unpack ab  = let (a,b) = split# ab in (unpack a, unpack b)++class GBitPack f where+  -- | Size of fields. If multiple constructors exist, this is the maximum of+  -- the sum of each of the constructors fields.+  type GFieldSize f :: Nat++  -- | Number of constructors this type has. Indirectly indicates how many bits+  -- are needed to represent the constructor.+  type GConstructorCount f :: Nat++  -- | Pack fields of a type. Caller should pack and prepend the constructor bits.+  gPackFields+    :: Int+    -- ^ Current constructor+    -> f a+    -- ^ Data to pack+    -> (Int, BitVector (GFieldSize f))+    -- ^ (Constructor number, Packed fields)++  -- | Unpack whole type.+  gUnpack+    :: Int+    -- ^ Construct with constructor /n/+    -> Int+    -- ^ Current constructor+    -> BitVector (GFieldSize f)+    -- ^ BitVector containing fields+    -> f a+    -- ^ Unpacked result++instance GBitPack a => GBitPack (M1 m d a) where+  type GFieldSize (M1 m d a) = GFieldSize a+  type GConstructorCount (M1 m d a) = GConstructorCount a++  gPackFields cc (M1 m1) = gPackFields cc m1+  gUnpack c cc b = M1 (gUnpack c cc b)++instance ( KnownNat (GFieldSize g)+         , KnownNat (GFieldSize f)+         , KnownNat (GConstructorCount f)+         , GBitPack f+         , GBitPack g+         ) => GBitPack (f :+: g) where+  type GFieldSize (f :+: g) = Max (GFieldSize f) (GFieldSize g)+  type GConstructorCount (f :+: g) = GConstructorCount f + GConstructorCount g++  gPackFields cc (L1 l) =+    let (sc, packed) = gPackFields cc l in+    let padding = undefined# :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize f) in+    (sc, packed ++# padding)+  gPackFields cc (R1 r) =+    let cLeft = snatToNum (SNat @(GConstructorCount f)) in+    let (sc, packed) = gPackFields (cc + cLeft) r in+    let padding = undefined# :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize g) in+    (sc, packed ++# padding)++  gUnpack c cc b =+    let cLeft = snatToNum (SNat @(GConstructorCount f)) in+    if c < cc + cLeft then+      L1 (gUnpack c cc f)+    else+      R1 (gUnpack c (cc + cLeft) g)++   where+    -- It's a thing of beauty, if I may say so myself!+    (f, _ :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize f)) = split# b+    (g, _ :: BitVector (Max (GFieldSize f) (GFieldSize g) - GFieldSize g)) = split# b+++instance (KnownNat (GFieldSize g), KnownNat (GFieldSize f), GBitPack f, GBitPack g) => GBitPack (f :*: g) where+  type GFieldSize (f :*: g) = GFieldSize f + GFieldSize g+  type GConstructorCount (f :*: g) = 1++  gPackFields cc fg =+    (cc, packXWith go fg)+   where+    go (l0 :*: r0) =+      let (_, l1) = gPackFields cc l0 in+      let (_, r1) = gPackFields cc r0 in+      l1 ++# r1++  gUnpack c cc b =+    gUnpack c cc front :*: gUnpack c cc back+   where+    (front, back) = split# b++instance BitPack c => GBitPack (K1 i c) where+  type GFieldSize (K1 i c) = BitSize c+  type GConstructorCount (K1 i c)  = 1++  gPackFields cc (K1 i) = (cc, pack i)+  gUnpack _c _cc b      = K1 (unpack b)++instance GBitPack U1 where+  type GFieldSize U1 = 0+  type GConstructorCount U1 = 1++  gPackFields cc U1 = (cc, 0)+  gUnpack _c _cc _b = U1++-- Instances derived using Generic+instance ( BitPack a+         , BitPack b+         ) => BitPack (Either a b)++instance BitPack a => BitPack (Maybe a)++instance BitPack a => BitPack (Complex a)+instance BitPack a => BitPack (Down a)++-- | Zero-extend a 'Bool'ean value to a 'BitVector' of the appropriate size.+--+-- >>> boolToBV True :: BitVector 6+-- 0b00_0001+-- >>> boolToBV False :: BitVector 6+-- 0b00_0000+boolToBV :: KnownNat n => Bool -> BitVector (n + 1)+boolToBV = zeroExtend . pack++-- | Convert a Bool to a Bit+boolToBit :: Bool -> Bit+boolToBit = bitCoerce++-- | Convert a Bool to a Bit+bitToBool :: Bit -> Bool+bitToBool = bitCoerce++-- Derive the BitPack instance for tuples of size 3 to maxTupleSize+deriveBitPackTuples ''BitPack ''BitSize 'pack 'unpack

@@ -0,0 +1,102 @@+{-|+Copyright  :  (C) 2019, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Clash.Class.BitPack.Internal.TH where++import           Clash.CPP             (maxTupleSize)+import           Language.Haskell.TH.Compat (mkTySynInstD,mkTupE)+import           Control.Monad         (replicateM)+import           Data.List             (foldl')+import           GHC.TypeLits          (KnownNat)+import           Language.Haskell.TH++-- | Contruct all the tuple (starting at size 3) instances for BitPack.+deriveBitPackTuples+  :: Name+  -- ^ BitPack+  -> Name+  -- ^ BitSize+  -> Name+  -- ^ pack+  -> Name+  -- ^ unpack+  -> DecsQ+deriveBitPackTuples bitPackName bitSizeName packName unpackName = do+  let bitPack  = ConT bitPackName+      bitSize  = ConT bitSizeName+      knownNat = ConT ''KnownNat+      plus     = ConT $ mkName "+"++  allNames <- replicateM maxTupleSize (newName "a")+  retupName <- newName "retup"+  x <- newName "x"+  y <- newName "y"+  tup <- newName "tup"++  pure $ flip map [3..maxTupleSize] $ \tupleNum ->+    let names  = take tupleNum allNames+        (v:vs) = fmap VarT names+        tuple xs = foldl' AppT (TupleT $ length xs) xs++        -- Instance declaration+        context =+          [ bitPack `AppT` v+          , knownNat `AppT` (bitSize `AppT` v)+          , bitPack `AppT` tuple vs+          , knownNat `AppT` (bitSize `AppT` tuple vs)+          ]+        instTy = AppT bitPack $ tuple (v:vs)++        -- Associated type BitSize+        bitSizeType =+          mkTySynInstD bitSizeName [tuple (v:vs)]+            $ plus `AppT` (bitSize `AppT` v) `AppT`+              (bitSize `AppT` foldl AppT (TupleT $ tupleNum - 1) vs)++        pack =+          FunD+            packName+            [ Clause+                [VarP tup]+                (NormalB (AppE (VarE packName) (AppE (VarE retupName) (VarE tup))))+                [FunD+                    retupName+                    [ Clause+                        [ TupP $ map VarP names ]+                        ( let (e:es) = map VarE names+                          in NormalB (mkTupE [e,mkTupE es])+                        )+                        []+                    ]+                ]+            ]++        unpack =+          FunD+            unpackName+            [ Clause+                [ VarP x ]+                ( NormalB $+                    let (p:ps) = map VarP names+                    in+                    LetE+                      [ ValD+                          ( TupP [ p, VarP y ] )+                          ( NormalB $ VarE unpackName `AppE` VarE x )+                          []+                      , ValD+                          ( TupP ps )+                          ( NormalB $ VarE unpackName `AppE` VarE y )+                          []+                      ]+                      ( mkTupE $ map VarE names )+                )+                []+            ]++    in InstanceD Nothing context instTy [bitSizeType, pack, unpack]

@@ -0,0 +1,62 @@+{-|+  Copyright   :  (C) 2021     , QBayLogic B.V.+  License     :  BSD2 (see the file LICENSE)+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>++  Utilities for wrapping counters consisting of multiple individual counters+-}++module Clash.Class.Counter+  ( Counter+  , countSucc+  , countPred+  ) where++import Clash.Class.Counter.Internal++-- $setup+-- >>> import Clash.Class.Counter+-- >>> import Clash.Sized.BitVector (BitVector)+-- >>> import Clash.Sized.Index (Index)+-- >>> import Clash.Sized.Signed (Signed)+-- >>> import Clash.Sized.Unsigned (Unsigned)++-- | Successor of a counter.+--+-- Examples:+--+-- >>> type T = (Unsigned 2, Unsigned 2)+-- >>> countSucc @T (1, 1)+-- (1,2)+-- >>> countSucc @T (1, 2)+-- (1,3)+-- >>> countSucc @T (1, 3)+-- (2,0)+-- >>> countSucc @T (3, 3)+-- (0,0)+-- >>> countSucc @(Index 9, Index 2) (0, 1)+-- (1,0)+-- >>> countSucc @(Either (Index 9) (Index 9)) (Left 8)+-- Right 0+countSucc :: Counter a => a -> a+countSucc = snd . countSuccOverflow++-- | Predecessor of a counter+--+-- Examples:+--+-- >>> type T = (Unsigned 2, Unsigned 2)+-- >>> countPred @T (1, 2)+-- (1,1)+-- >>> countPred @T (1, 3)+-- (1,2)+-- >>> countPred @T (2, 0)+-- (1,3)+-- >>> countPred @T (0, 0)+-- (3,3)+-- >>> countPred @(Index 9, Index 2) (1, 0)+-- (0,1)+-- >>> countPred @(Either (Index 9) (Index 9)) (Right 0)+-- Left 8+countPred :: Counter a => a -> a+countPred = snd . countPredOverflow

@@ -0,0 +1,144 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}++module Clash.Class.Counter.Internal where++import Clash.CPP (maxTupleSize)++import Clash.Class.Counter.TH (genTupleInstances)+import Clash.Sized.BitVector (BitVector)+import Clash.Sized.Index (Index)+import Clash.Sized.Signed (Signed)+import Clash.Sized.Unsigned (Unsigned)++import Data.Bifunctor (bimap)+import GHC.TypeLits (KnownNat, type (<=))++-- $setup+-- >>> import Clash.Class.Counter+-- >>> import Clash.Sized.BitVector (BitVector)+-- >>> import Clash.Sized.Index (Index)+-- >>> import Clash.Sized.Signed (Signed)+-- >>> import Clash.Sized.Unsigned (Unsigned)++-- | 'Clash.Class.Counter.Counter' is a class that composes multiple counters+-- into a single one. It is similar to odometers found in olds cars,+-- once all counters reach their maximum they reset to zero - i.e. odometer+-- rollover. See 'Clash.Class.Counter.countSucc' and 'Clash.Class.Counter.countPred'+-- for API usage examples.+--+-- Example use case: when driving a monitor through VGA you would like to keep+-- track at least two counters: one counting a horizontal position, and one+-- vertical. Perhaps a fancy VGA driver would also like to keep track of the+-- number of drawn frames. To do so, the three counters are setup with different+-- types. On each /round/ of the horizontal counter the vertical counter should+-- be increased. On each /round/ of the vertical counter the frame counter should+-- be increased. With this class you could simply use the type:+--+-- @+-- (FrameCount, VerticalCount, HorizontalCount)+-- @+--+-- and have 'Clash.Class.Counter.countSucc' work as described.+--+-- __N.B.__: This class exposes four functions 'countMin', 'countMax',+-- 'countSuccOverflow', and 'countPredOverflow'. These functions are considered+-- an internal API. Users are encouraged to use 'Clash.Class.Counter.countSucc'+-- and 'Clash.Class.Counter.countPred'.+--+class Counter a where+  -- | Value counter wraps around to on a 'countSuccOverflow' overflow+  countMin :: a+  default countMin :: Bounded a => a+  countMin = minBound++  -- | Value counter wraps around to on a 'countPredOverflow' overflow+  countMax :: a+  default countMax :: Bounded a => a+  countMax = maxBound++  -- | Gets the successor of @a@. If it overflows, the left part of the tuple+  -- will be set to True.+  countSuccOverflow :: a -> (Bool, a)+  default countSuccOverflow :: (Eq a, Enum a, Bounded a) => a -> (Bool, a)+  countSuccOverflow a+    | a == maxBound = (True, countMin)+    | otherwise = (False, succ a)++  -- | Gets the predecessor of @a@. If it overflows, the left part of the tuple+  -- will be set to True.+  countPredOverflow :: a -> (Bool, a)+  default countPredOverflow :: (Eq a, Enum a, Bounded a) => a -> (Bool, a)+  countPredOverflow a+    | a == minBound = (True, countMax)+    | otherwise = (False, pred a)++instance (1 <= n, KnownNat n) => Counter (Index n)+instance KnownNat n => Counter (Unsigned n)+instance KnownNat n => Counter (Signed n)+instance KnownNat n => Counter (BitVector n)++-- | Counter instance that flip-flops between 'Left' and 'Right'. Examples:+--+-- >>> type T = Either (Index 2) (Unsigned 2)+-- >>> countSucc @T (Left 0)+-- Left 1+-- >>> countSucc @T (Left 1)+-- Right 0+-- >>> countSucc @T (Right 0)+-- Right 1+instance (Counter a, Counter b) => Counter (Either a b) where+  countMin = Left countMin+  countMax = Right countMax++  countSuccOverflow e =+    case bimap countSuccOverflow countSuccOverflow e of+      Left (overflow, a)  -> (False, if overflow then Right countMin else Left a)+      Right (overflow, b) -> (overflow, if overflow then Left countMin else Right b)++  countPredOverflow e =+    case bimap countPredOverflow countPredOverflow e of+      Left (overflow, a)  -> (overflow, if overflow then Right countMax else Left a)+      Right (overflow, b) -> (False, if overflow then Left countMax else Right b)++-- | Counters on tuples increment from right-to-left. This makes sense from the+-- perspective of LSB/MSB; MSB is on the left-hand-side and LSB is on the+-- right-hand-side in other Clash types.+--+-- >>> type T = (Unsigned 2, Index 2, Index 2)+-- >>> countSucc @T (0, 0, 0)+-- (0,0,1)+-- >>> countSucc @T (0, 0, 1)+-- (0,1,0)+-- >>> countSucc @T (0, 1, 0)+-- (0,1,1)+-- >>> countSucc @T (0, 1, 1)+-- (1,0,0)+--+-- __N.B.__: The documentation only shows the instances up to /3/-tuples. By+-- default, instances up to and including /12/-tuples will exist. If the flag+-- @large-tuples@ is set instances up to the GHC imposed limit will exist. The+-- GHC imposed limit is either 62 or 64 depending on the GHC version.+instance (Counter a0, Counter a1) => Counter (a0, a1) where+  -- a0/a1 instead of a/b to be consistent with TH generated instances+  countMin = (countMin, countMin)+  countMax = (countMax, countMax)++  countSuccOverflow (a0, b0) =+    if overflowB+    then (overflowA, (a1, b1))+    else (overflowB, (a0, b1))+   where+    (overflowB, b1) = countSuccOverflow b0+    (overflowA, a1) = countSuccOverflow a0++  countPredOverflow (a0, b0) =+    if overflowB+    then (overflowA, (a1, b1))+    else (overflowB, (a0, b1))+   where+    (overflowB, b1) = countPredOverflow b0+    (overflowA, a1) = countPredOverflow a0++genTupleInstances maxTupleSize

@@ -0,0 +1,81 @@+{-# LANGUAGE CPP #-}++module Clash.Class.Counter.TH where++import Language.Haskell.TH++counterName, countMinName, countMaxName, countSuccName, countPredName :: Name+counterName = mkName "Counter"+countMinName = mkName "countMin"+countMaxName = mkName "countMax"+countSuccName = mkName "countSuccOverflow"+countPredName = mkName "countPredOverflow"++mkTupTy :: [Type] -> Type+mkTupTy names@(length -> n) = foldl AppT (TupleT n) names++mkTup :: [Exp] -> Exp+#if MIN_VERSION_template_haskell(2,16,0)+mkTup = TupE . map Just+#else+mkTup = TupE+#endif++genTupleInstances :: Int -> Q [Dec]+genTupleInstances maxTupleSize = mapM genTupleInstance [3..maxTupleSize]++genTupleInstance :: Int -> Q Dec+genTupleInstance tupSize = do+  typeVars <- mapM (\n -> VarT <$> newName ("a" <> show n)) [0..tupSize-1]++  succOverflowBody <- genCountOverflow countSuccName tupSize+  predOverflowBody <- genCountOverflow countPredName tupSize++  let+    minBody = genCount countMinName tupSize+    maxBody = genCount countMaxName tupSize+    ctx = map (ConT counterName `AppT`) typeVars+    typ = ConT counterName `AppT` mkTupTy typeVars+    decls =+      [ FunD countMinName [minBody]+      , FunD countMaxName [maxBody]+      , FunD (mkName "countSuccOverflow") [succOverflowBody]+      , FunD (mkName "countPredOverflow") [predOverflowBody]+      ]++  pure (InstanceD Nothing ctx typ decls)++genCount :: Name -> Int -> Clause+genCount nm n = Clause [] (NormalB (mkTup (replicate n (VarE nm)))) []++genCountOverflow :: Name -> Int -> Q Clause+genCountOverflow nm tupSize = do+  varNms <- mapM (\n -> newName ("a" <> show n)) [0..tupSize-1]+  let vars = map VarE varNms++  overflowLastNm <- newName "overflowLast"+  lastNm <- newName "last"++  overflowInitNm <- newName "overflowInit"+  initNms <- mapM (\n -> newName ("a" <> show n)) [0..tupSize-2]++  let+    body =+      CondE+        (VarE overflowLastNm)+        (mkTup [VarE overflowInitNm, mkTup (map VarE (initNms <> [lastNm]))])+        (mkTup [VarE overflowLastNm, mkTup (init vars <> [VarE lastNm])])++    decs =+      [ ValD+          (TupP [VarP overflowLastNm, VarP lastNm])+          (NormalB (VarE nm `AppE` last vars))+          []++      , ValD+          (TupP [VarP overflowInitNm, TupP (map VarP initNms)])+          (NormalB (VarE nm `AppE` mkTup (init vars)))+          []+      ]++  pure (Clause [TupP (map VarP varNms)] (NormalB body) decs)

@@ -14,10 +14,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ < 806-{-# LANGUAGE TypeInType #-}-#endif- {-# OPTIONS_GHC -Wno-missing-methods #-} {-# OPTIONS_HADDOCK not-home #-} 

@@ -15,10 +15,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ < 806-{-# LANGUAGE TypeInType #-}-#endif- {-# OPTIONS_GHC -Wno-missing-methods #-} {-# OPTIONS_HADDOCK not-home #-} 

@@ -52,6 +52,7 @@   | SatSymmetric -- ^ Become 'maxBound' on overflow, and (@'minBound' + 1@) on                  -- underflow for signed numbers, and 'minBound' for unsigned                  -- numbers.+  | SatError -- ^ Become an XException on overflow and underflow   deriving (Show, Eq, Enum, Bounded)  -- | 'Num' operators in which overflow and underflow behavior can be specified

@@ -30,6 +30,7 @@ import Clash.Promoted.Nat             (SNat(..), snatToNum)  {- $setup+>>> :m -Prelude >>> import Clash.Prelude >>> import Clash.Class.Parity -}

@@ -31,8 +31,6 @@  {- $setup >>> :set -XDataKinds->>> :m -Clash.Explicit.Prelude->>> :m -Clash.Signal.Internal >>> import Clash.Prelude >>> import Test.QuickCheck ((===)) >>> import Clash.Examples.Internal@@ -79,9 +77,9 @@ Examples:  >>> decoderCase True 3-0000_0000_0000_1000+0b0000_0000_0000_1000 >>> decoderShift True 7-0000_0000_1000_0000+0b0000_0000_1000_0000  The following property holds: 

@@ -239,7 +239,7 @@  @ >>> printX $ sampleN 32 $ system2 prog systemClockGen resetGen enableGen-[X,X,X,X,X,X,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]+[undefined,undefined,undefined,undefined,undefined,undefined,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]  @ @@ -369,7 +369,7 @@  @ >>> printX $ sampleN 34 $ system3 prog2 systemClockGen resetGen enableGen-[X,0,0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]+[undefined,0,0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2]  @ @@ -377,14 +377,18 @@  -} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE NoImplicitPrelude#-}+{-# LANGUAGE NoImplicitPrelude #-}  {-# LANGUAGE Trustworthy #-}  {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} +-- See [Note: eta port names for trueDualPortBlockRam]+{-# OPTIONS_GHC -fno-do-lambda-eta-expansion #-}+ -- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c -- as to why we need this. {-# OPTIONS_GHC -fno-cpr-anal #-}@@ -396,19 +400,36 @@   , blockRamU   , blockRam1   , ResetStrategy(..)-    -- * Read/Write conflict resolution+    -- ** Read/write conflict resolution   , readNew+    -- * True dual-port block RAM+    -- $tdpbram+  , trueDualPortBlockRam+  , RamOp(..)     -- * Internal   , blockRam#+  , trueDualPortBlockRam#   ) where  import           Clash.HaskellPrelude -import           Data.Maybe             (isJust)+import           Control.Exception      (catch, throw)+import           Control.Monad          (forM_)+import           Control.Monad.ST       (ST, runST)+import           Control.Monad.ST.Unsafe (unsafeInterleaveST, unsafeIOToST, unsafeSTToIO)+import           Data.Array.MArray      (newListArray)+import qualified Data.List              as L+import           Data.Maybe             (isJust, fromMaybe)+import           GHC.Arr+  (STArray, unsafeReadSTArray, unsafeWriteSTArray) import qualified Data.Sequence          as Seq+import           Data.Sequence          (Seq)+import           Data.Tuple             (swap)+import           GHC.Generics           (Generic) import           GHC.Stack              (HasCallStack, withFrozenCallStack) import           GHC.TypeLits           (KnownNat, type (^), type (<=))+import           Unsafe.Coerce          (unsafeCoerce)  import           Clash.Annotations.Primitive   (hasBlackBox)@@ -416,18 +437,33 @@ import           Clash.Explicit.Signal  (KnownDomain, Enable, register, fromEnable) import           Clash.Signal.Internal   (Clock(..), Reset, Signal (..), invertReset, (.&&.), mux)-import           Clash.Promoted.Nat     (SNat(..))-import           Clash.Signal.Bundle    (unbundle)+import           Clash.Promoted.Nat     (SNat(..), snatToNum, natToNum)+import           Clash.Signal.Bundle    (unbundle, bundle)+import           Clash.Signal.Internal.Ambiguous (clockPeriod) import           Clash.Sized.Unsigned   (Unsigned) import           Clash.Sized.Index      (Index)-import           Clash.Sized.Vector     (Vec, replicate, toList, iterateI)+import           Clash.Sized.Vector     (Vec, replicate, iterateI) import qualified Clash.Sized.Vector     as CV import           Clash.XException-  (maybeIsX, seqX, NFDataX, deepErrorX, defaultSeqX, fromJustX, undefined)+  (maybeIsX, NFDataX(deepErrorX), defaultSeqX, fromJustX, undefined,+   XException (..), seqX, isX, errorX) +{- $tdpbram+A true dual-port block RAM has two fully independent, fully functional access+ports: port A and port B. Either port can do both RAM reads and writes. These+two ports can even be on distinct clock domains, but the memory itself is shared+between the ports. This also makes a true dual-port block RAM suitable as a+component in a domain crossing circuit (but it needs additional logic for it to+be safe, see e.g. 'Clash.Explicit.Synchronizer.asyncFIFOSynchronizer').++A version with implicit clocks can be found in "Clash.Prelude.BlockRam".+-}++-- start benchmark only+-- import GHC.Arr (listArray, unsafeThawSTArray)+-- end benchmark only+ {- $setup->>> :m -Clash.Prelude->>> :m -Clash.Prelude.Safe >>> import Clash.Explicit.Prelude as C >>> import qualified Data.List as L >>> :set -XDataKinds -XRecordWildCards -XTupleSections -XDeriveAnyClass -XDeriveGeneric@@ -697,7 +733,7 @@ -- -- * __NB__: Read value is delayed by 1 cycle -- * __NB__: Initial output value is /undefined/, reading it will throw an--- 'Clash.XException.XException'+-- 'XException' -- -- @ -- bram40@@ -714,6 +750,10 @@ -- * See "Clash.Explicit.BlockRam#usingrams" for more information on how to use a -- Block RAM. -- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @'readNew' clk rst ('blockRam' clk inits) rd wrM@.+-- * A large 'Vec' for the initial content might be too inefficient, depending+-- on how it is constructed. See 'Clash.Explicit.BlockRam.File.blockRamFile' and+-- 'Clash.Explicit.BlockRam.Blob.blockRamBlob' for different approaches that+-- scale well. blockRam   :: ( KnownDomain dom      , HasCallStack@@ -744,7 +784,7 @@ -- -- * __NB__: Read value is delayed by 1 cycle -- * __NB__: Initial output value is /undefined/, reading it will throw an--- 'Clash.XException.XException'+-- 'XException' -- -- @ -- bram32@@ -761,6 +801,10 @@ -- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a -- Block RAM. -- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @'readNew' clk rst ('blockRamPow2' clk inits) rd wrM@.+-- * A large 'Vec' for the initial content might be too inefficient, depending+-- on how it is constructed. See 'Clash.Explicit.BlockRam.File.blockRamFilePow2'+-- and 'Clash.Explicit.BlockRam.Blob.blockRamBlobPow2' for different approaches+-- that scale well. blockRamPow2   :: ( KnownDomain dom      , HasCallStack@@ -970,7 +1014,8 @@  -- | blockRAM primitive blockRam#-  :: ( KnownDomain dom+  :: forall dom a n+   . ( KnownDomain dom      , HasCallStack      , NFDataX a )   => Clock dom@@ -992,33 +1037,74 @@   -- ^ Value to write (at address @w@)   -> Signal dom a   -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle-blockRam# (Clock _) gen content rd wen =+blockRam# (Clock _) gen content = \rd wen waS wd -> runST $ do+  ramStart <- newListArray (0,szI-1) contentL+  -- start benchmark only+  -- ramStart <- unsafeThawSTArray ramArr+  -- end benchmark only   go-    (Seq.fromList (toList content))+    ramStart     (withFrozenCallStack (deepErrorX "blockRam: intial value undefined"))     (fromEnable gen)     rd     (fromEnable gen .&&. wen)+    waS+    wd  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 `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)+  contentL = unsafeCoerce content :: [a]+  szI = L.length contentL+  -- start benchmark only+  -- ramArr = listArray (0,szI-1) contentL+  -- end benchmark only +  go :: STArray s Int a -> a -> Signal dom Bool -> Signal dom Int+     -> Signal dom Bool -> Signal dom Int -> Signal dom a+     -> ST s (Signal dom a)+  go !ram o ret@(~(re :- res)) rt@(~(r :- rs)) et@(~(e :- en)) wt@(~(w :- wr)) dt@(~(d :- din)) = do+    o `seqX` (o :-) <$> (ret `seq` rt `seq` et `seq` wt `seq` dt `seq`+      unsafeInterleaveST+        (do o' <- unsafeIOToST+                    (catch (if re then unsafeSTToIO (ram `safeAt` r) else pure o)+                    (\err@XException {} -> pure (throw err)))+            d `defaultSeqX` upd ram e (fromEnum w) d+            go ram o' res rs en wr din))++  upd :: STArray s Int a -> Bool -> Int -> a -> ST s ()   upd ram we waddr d = case maybeIsX we of     Nothing -> case maybeIsX waddr of       Nothing -> -- Put the XException from `waddr` as the value in all                  -- locations of `ram`.-                 seq waddr d <$ ram+                 forM_ [0..(szI-1)] (\i -> unsafeWriteSTArray ram i (seq waddr d))       Just wa -> -- Put the XException from `we` as the value at address                  -- `waddr`.-                 Seq.update wa (seq we d) ram+                 safeUpdate wa (seq we d) ram     Just True -> case maybeIsX waddr of       Nothing -> -- Put the XException from `waddr` as the value in all                  -- locations of `ram`.-                 seq waddr d <$ ram-      Just wa -> Seq.update wa d ram-    _ -> ram+                 forM_ [0..(szI-1)] (\i -> unsafeWriteSTArray ram i (seq waddr d))+      Just wa -> safeUpdate wa d ram+    _ -> return ()++  safeAt :: HasCallStack => STArray s Int a -> Int -> ST s a+  safeAt s i =+    if (0 <= i) && (i < szI) then+      unsafeReadSTArray s i+    else pure $+      withFrozenCallStack+        (deepErrorX ("blockRam: read address " <> show i <>+                     " not in range [0.." <> show szI <> ")"))+  {-# INLINE safeAt #-}++  safeUpdate :: HasCallStack => Int -> a -> STArray s Int a -> ST s ()+  safeUpdate i a s =+    if (0 <= i) && (i < szI) then+      unsafeWriteSTArray s i a+    else+      let d = withFrozenCallStack+                (deepErrorX ("blockRam: write address " <> show i <>+                             " not in range [0.." <> show szI <> ")"))+       in forM_ [0..(szI-1)] (\j -> unsafeWriteSTArray s j d)+  {-# INLINE safeUpdate #-} {-# ANN blockRam# hasBlackBox #-} {-# NOINLINE blockRam# #-} @@ -1045,3 +1131,308 @@         (wasSame,wasWritten) =           unbundle (register clk rst en (False, undefined)                              (readNewT <$> rdAddr <*> wrM))++-- | Port operation+data RamOp n a+  = RamRead (Index n)+  -- ^ Read from address+  | RamWrite (Index n) a+  -- ^ Write data to address+  | RamNoOp+  -- ^ No operation+  deriving (Generic, NFDataX, Show)++ramOpAddr :: RamOp n a -> Index n+ramOpAddr (RamRead addr)    = addr+ramOpAddr (RamWrite addr _) = addr+ramOpAddr RamNoOp           = errorX "Address for No operation undefined"++isRamWrite :: RamOp n a -> Bool+isRamWrite (RamWrite {}) = True+isRamWrite _             = False++ramOpWriteVal :: RamOp n a -> Maybe a+ramOpWriteVal (RamWrite _ val) = Just val+ramOpWriteVal _                = Nothing++isOp :: RamOp n a -> Bool+isOp RamNoOp = False+isOp _       = True++-- | Produces vendor-agnostic HDL that will be inferred as a true dual-port+-- block RAM+--+-- Any value that is being written on a particular port is also the+-- value that will be read on that port, i.e. the same-port read/write behavior+-- is: WriteFirst. For mixed-port read/write, when port A writes to the address+-- port B reads from, the output of port B is undefined, and vice versa.+trueDualPortBlockRam ::+  forall nAddrs domA domB a .+  ( HasCallStack+  , KnownNat nAddrs+  , KnownDomain domA+  , KnownDomain domB+  , NFDataX a+  )+  => Clock domA+  -- ^ Clock for port A+  -> Clock domB+  -- ^ Clock for port B+  -> Signal domA (RamOp nAddrs a)+  -- ^ RAM operation for port A+  -> Signal domB (RamOp nAddrs a)+  -- ^ RAM operation for port B+  -> (Signal domA a, Signal domB a)+  -- ^ Outputs data on /next/ cycle. When writing, the data written+  -- will be echoed. When reading, the read data is returned.++{-# INLINE trueDualPortBlockRam #-}+trueDualPortBlockRam = \clkA clkB opA opB ->+  trueDualPortBlockRamWrapper+    clkA (isOp <$> opA) (isRamWrite <$> opA) (ramOpAddr <$> opA) (fromJustX . ramOpWriteVal <$> opA)+    clkB (isOp <$> opB) (isRamWrite <$> opB) (ramOpAddr <$> opB) (fromJustX . ramOpWriteVal <$> opB)++toMaybeX :: a -> MaybeX a+toMaybeX a =+  case isX a of+    Left _ -> IsX+    Right _ -> IsDefined a++data MaybeX a = IsX | IsDefined !a++data Conflict = Conflict+  { cfWrite :: !(MaybeX Bool)+  , cfAddress :: !(MaybeX Int) }++instance Semigroup Conflict where+  (<>) = mergeConflicts++-- | "Stronger" conflict wins:+--+--   * Writes over read+--   * Undefineds over anything+--+mergeConflicts :: Conflict -> Conflict -> Conflict+mergeConflicts conflict1 conflict2 = Conflict+  { cfWrite = mergeWrite (cfWrite conflict1) (cfWrite conflict2)+  , cfAddress = mergeAddress (cfAddress conflict1) (cfAddress conflict2) }+ where+  mergeX _ IsX _ = IsX+  mergeX _ _ IsX = IsX+  mergeX f (IsDefined a) (IsDefined b) = IsDefined (f a b)++  mergeWrite a b = mergeX (||) a b+  mergeAddress a b = mergeX const a b++-- [Note: eta port names for trueDualPortBlockRam]+--+-- By naming all the arguments and setting the -fno-do-lambda-eta-expansion GHC+-- option for this module, the generated HDL also contains names based on the+-- argument names used here. This greatly improves readability of the HDL.++-- [Note: true dual-port blockRAM separate architecture]+--+-- A multi-clock true dual-port block RAM is only inferred from the generated HDL+-- when it lives in its own Verilog module / VHDL architecture. Add any other+-- logic to the module / architecture, and synthesis will no longer infer a+-- multi-clock true dual-port block RAM. This wrapper pushes the primitive out+-- into its own module / architecture.+trueDualPortBlockRamWrapper clkA enA weA addrA datA clkB enB weB addrB datB =+  trueDualPortBlockRam# clkA enA weA addrA datA clkB enB weB addrB datB+{-# NOINLINE trueDualPortBlockRamWrapper #-}++-- | Primitive of 'trueDualPortBlockRam'.+trueDualPortBlockRam#, trueDualPortBlockRamWrapper ::+  forall nAddrs domA domB a .+  ( HasCallStack+  , KnownNat nAddrs+  , KnownDomain domA+  , KnownDomain domB+  , NFDataX a+  )+  => Clock domA+  -- ^ Clock for port A+  -> Signal domA Bool+  -- ^ Enable for port A+  -> Signal domA Bool+  -- ^ Write enable for port A+  -> Signal domA (Index nAddrs)+  -- ^ Address to read from or write to on port A+  -> Signal domA a+  -- ^ Data in for port A; ignored when /write enable/ is @False@++  -> Clock domB+  -- ^ Clock for port B+  -> Signal domB Bool+  -- ^ Enable for port B+  -> Signal domB Bool+  -- ^ Write enable for port B+  -> Signal domB (Index nAddrs)+  -- ^ Address to read from or write to on port B+  -> Signal domB a+  -- ^ Data in for port B; ignored when /write enable/ is @False@++  -> (Signal domA a, Signal domB a)+  -- ^ Outputs data on /next/ cycle. If write enable is @True@, the data written+  -- will be echoed. If write enable is @False@, the read data is returned. If+  -- port enable is @False@, it is /undefined/.+trueDualPortBlockRam# clkA enA weA addrA datA clkB enB weB addrB datB+  | snatToNum @Int (clockPeriod @domA) < snatToNum @Int (clockPeriod @domB)+  = swap (trueDualPortBlockRamModel clkB enB weB addrB datB clkA enA weA addrA datA)+  | otherwise+  =       trueDualPortBlockRamModel clkA enA weA addrA datA clkB enB weB addrB datB+{-# NOINLINE trueDualPortBlockRam# #-}+{-# ANN trueDualPortBlockRam# hasBlackBox #-}+++-- | Haskell model for the primitive 'trueDualPortBlockRam#'.+--+-- Warning: this model only works if @domFast@'s clock is faster (or equal to)+-- @domSlow@'s clock.+trueDualPortBlockRamModel ::+  forall nAddrs domFast domSlow a .+  ( HasCallStack+  , KnownNat nAddrs+  , KnownDomain domSlow+  , KnownDomain domFast+  , NFDataX a+  ) =>++  Clock domSlow ->+  Signal domSlow Bool ->+  Signal domSlow Bool ->+  Signal domSlow (Index nAddrs) ->+  Signal domSlow a ->++  Clock domFast ->+  Signal domFast Bool ->+  Signal domFast Bool ->+  Signal domFast (Index nAddrs) ->+  Signal domFast a ->++  (Signal domSlow a, Signal domFast a)+trueDualPortBlockRamModel !_clkA enA weA addrA datA !_clkB enB weB addrB datB =+  ( deepErrorX "trueDualPortBlockRam: Port A: First value undefined" :- outA+  , deepErrorX "trueDualPortBlockRam: Port B: First value undefined" :- outB )+ where+  (outA, outB) =+    go+      Nothing+      (Seq.fromFunction (natToNum @nAddrs) initElement)+      tA -- ensure 'go' hits fast clock first+      (bundle (enA, weA, fromIntegral <$> addrA, datA))+      (bundle (enB, weB, fromIntegral <$> addrB, datB))++  tA = snatToNum @Int (clockPeriod @domSlow)+  tB = snatToNum @Int (clockPeriod @domFast)++  initElement :: Int -> a+  initElement n =+    deepErrorX ("Unknown initial element; position " <> show n)++  unknownEnableAndAddr :: String -> String -> Int -> a+  unknownEnableAndAddr enaMsg addrMsg n =+    deepErrorX ("Write enable and data unknown; position " <> show n <>+                "\nWrite enable error message: " <> enaMsg <>+                "\nAddress error message: " <> addrMsg)++  unknownAddr :: String -> Int -> a+  unknownAddr msg n =+    deepErrorX ("Write enabled, but address unknown; position " <> show n <>+                "\nAddress error message: " <> msg)++  getConflict :: Bool -> Int -> Bool -> Int -> Maybe Conflict+  getConflict enableA addrA_ enableB addrB_ =+    -- If port A or port B is writing on (potentially!) the same address,+    -- there's a conflict+    if sameAddr then maybeConflict else Nothing+   where+    conflict = Conflict+      { cfWrite = toMaybeX enableA+      , cfAddress = toMaybeX addrA_ }++    maybeConflict =+      case (isX enableA, isX enableB) of+        (Left _, _)     -> Just conflict+        (Right True, _) -> Just conflict+        (_, Left _)     -> Just conflict+        (_, Right True) -> Just conflict+        _               -> Nothing++    sameAddr =+      case (isX addrA_, isX addrB_) of+        (Left _, _) -> True+        (_, Left _) -> True+        _           -> addrA_ == addrB_++  writeRam :: Bool -> Int -> a -> Seq a -> (Maybe a, Seq a)+  writeRam enable addr dat mem+    | Left enaMsg <- enableUndefined+    , Left addrMsg <- addrUndefined+    = let msg = "Unknown enable and address" <>+                "\nWrite enable error message: " <> enaMsg <>+                "\nAddress error message: " <> addrMsg+       in ( Just (deepErrorX msg)+          , Seq.fromFunction (natToNum @nAddrs)+                             (unknownEnableAndAddr enaMsg addrMsg) )+    | Left enaMsg <- enableUndefined+    = let msg = "Write enable unknown; position" <> show addr <>+                "\nWrite enable error message: " <> enaMsg+       in writeRam True addr (deepErrorX msg) mem+    | enable+    , Left addrMsg <- addrUndefined+    = ( Just (deepErrorX "Unknown address")+      , Seq.fromFunction (natToNum @nAddrs) (unknownAddr addrMsg) )+    | enable+    = (Just dat, Seq.update addr dat mem)+    | otherwise+    = (Nothing, mem)+   where+    enableUndefined = isX enable+    addrUndefined = isX addr++  go ::+    Maybe Conflict ->+    Seq a ->+    Int ->+    Signal domSlow (Bool, Bool, Int, a) ->+    Signal domFast (Bool, Bool, Int, a) ->+    (Signal domSlow a, Signal domFast a)+  go conflict0 ram0 relativeTime as0 bs0 =+    if relativeTime <= 0 then goSlow else goFast+   where+    (enA_, weA_, addrA_, datA_) :- as1 = as0+    (enB_, weB_, addrB_, datB_) :- bs1 = bs0++    -- 1 iteration here, as this is the slow clock.+    goSlow = out1 `seqX` (out1 :- as2, bs2)+     where+      (wrote, !ram1) = writeRam weA_ addrA_ datA_ ram0+      out0 = fromMaybe (ram1 `Seq.index` addrA_) wrote+      (as2, bs2) = go Nothing ram1 (relativeTime + tA) as1 bs0+      out1 =+        case conflict0 of+          Just Conflict{cfWrite=IsDefined True} ->+            deepErrorX "trueDualPortBlockRam: conflicting read/write queries"+          Just Conflict{cfWrite=IsX} ->+            deepErrorX "trueDualPortBlockRam: conflicting read/write queries"+          _ -> out0++    -- 1 or more iterations here, as this is the fast clock. First iteration+    -- happens here.+    goFast = out1 `seqX` (as2, out1 :- bs2)+     where+      conflict1 | enA_ && enB_ = getConflict weB_ addrB_ weA_ addrA_+                | otherwise    = Nothing+      (wrote, !ram1) = writeRam weB_ addrB_ datB_ ram0+      out0 = fromMaybe (ram1 `Seq.index` addrB_) wrote+      conflict2 = conflict0 <> conflict1+      (as2, bs2) = go conflict2 ram1 (relativeTime - tB) as0 bs1+      out1 =+        case conflict1 of+          Just Conflict{cfWrite=IsDefined False} ->+            deepErrorX "trueDualPortBlockRam: conflicting read/write queries"+          Just Conflict{cfWrite=IsX} ->+            deepErrorX "trueDualPortBlockRam: conflicting read/write queries"+          _ ->+            out0

@@ -0,0 +1,385 @@+{-|+Copyright  :  (C) 2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++= Efficient bundling of initial RAM content with the compiled code++Leveraging Template Haskell, the initial content for the blockRAM components in+this module is stored alongside the compiled Haskell code. It covers use cases+where passing the initial content as a 'Clash.Sized.Vector.Vec' turns out to be+problematically slow.++The data is stored efficiently, with very little overhead (worst-case 7%, often+no overhead at all).++Unlike "Clash.Explicit.BlockRam.File", "Clash.Explicit.BlockRam.Blob"+generates practically the same HDL as "Clash.Explicit.BlockRam" and is+compatible with all tools consuming the generated HDL.+-}++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Explicit.BlockRam.Blob+  ( -- * BlockRAMs initialized with a 'MemBlob'+    blockRamBlob+  , blockRamBlobPow2+    -- * Creating and inspecting 'MemBlob'+  , MemBlob+  , createMemBlob+  , memBlobTH+  , unpackMemBlob+    -- * Internal+  , blockRamBlob#+  ) where++import Control.Exception (catch, throw)+import Control.Monad (forM_)+import Control.Monad.ST (ST, runST)+import Control.Monad.ST.Unsafe (unsafeInterleaveST, unsafeIOToST, unsafeSTToIO)+import Data.Array.MArray (newListArray)+import qualified Data.ByteString.Lazy as L+import Data.Maybe (isJust)+import GHC.Arr (STArray, unsafeReadSTArray, unsafeWriteSTArray)+import GHC.Stack (withFrozenCallStack)+import GHC.TypeLits (KnownNat, type (^))+import Language.Haskell.TH+  (DecsQ, ExpQ, integerL, litE, litT, mkName, normalB, numTyLit, sigD,+   stringPrimL, valD, varP)++import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Class.BitPack.Internal (BitPack, BitSize)+import Clash.Explicit.BlockRam.Internal+  (MemBlob(..), packBVs, unpackMemBlob, unpackMemBlob0)+import Clash.Explicit.Signal (KnownDomain, Enable, fromEnable)+import Clash.Promoted.Nat (natToInteger, natToNum)+import Clash.Signal.Bundle (unbundle)+import Clash.Signal.Internal (Clock, Signal(..), (.&&.))+import Clash.Sized.Internal.BitVector (Bit(..), BitVector(..))+import Clash.Sized.Internal.Unsigned (Unsigned)+import Clash.XException+  (maybeIsX, deepErrorX, defaultSeqX, fromJustX, XException (..), seqX)++-- $setup+-- >>> :set -XTemplateHaskell+-- >>> :set -fplugin GHC.TypeLits.Normalise+-- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver+-- >>> :m -Prelude+-- >>> import Clash.Explicit.Prelude++-- | Create a blockRAM with space for @n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException'+--+--+-- Additional helpful information:+--+-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a+-- Block RAM.+-- * Use the adapter 'Clash.Explicit.BlockRam.readNew' for obtaining+-- write-before-read semantics like this: @'Clash.Explicit.BlockRam.readNew'+-- clk rst en ('blockRamBlob' clk en content) rd wrM@.+blockRamBlob+  :: forall dom addr m n+   . ( KnownDomain dom+     , Enum addr+     )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> MemBlob n m+  -- ^ Initial content of the RAM, also determines the size, @n@, of the RAM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom (Maybe (addr, BitVector m))+  -- ^ (write address @w@, value to write)+  -> Signal dom (BitVector m)+  -- ^ Value of the blockRAM at address @r@ from the previous clock cycle+blockRamBlob = \clk gen content rd wrM ->+  let en       = isJust <$> wrM+      (wr,din) = unbundle (fromJustX <$> wrM)+  in blockRamBlob# clk gen content (fromEnum <$> rd) en (fromEnum <$> wr) din+{-# INLINE blockRamBlob #-}++-- | Create a blockRAM with space for 2^@n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'XException'+--+-- Additional helpful information:+--+-- * See "Clash.Prelude.BlockRam#usingrams" for more information on how to use a+-- Block RAM.+-- * Use the adapter 'Clash.Explicit.BlockRam.readNew' for obtaining+-- write-before-read semantics like this: @'Clash.Explicit.BlockRam.readNew'+-- clk rst en ('blockRamBlobPow2' clk en content) rd wrM@.+blockRamBlobPow2+  :: forall dom m n+   . ( KnownDomain dom+     , KnownNat n+     )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> MemBlob (2^n) m+  -- ^ Initial content of the RAM, also determines the size, 2^@n@, of the RAM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom (Unsigned n)+  -- ^ Read address @r@+  -> Signal dom (Maybe (Unsigned n, BitVector m))+  -- ^ (write address @w@, value to write)+  -> Signal dom (BitVector m)+  -- ^ Value of the blockRAM at address @r@ from the previous clock cycle+blockRamBlobPow2 = blockRamBlob+{-# INLINE blockRamBlobPow2 #-}++-- | BlockRAM primitive+blockRamBlob#+  :: forall dom m n+   . KnownDomain dom+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> MemBlob n m+  -- ^ Initial content of the RAM, also determines the size, @n@, of the RAM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom Int+  -- ^ Read address @r@+  -> Signal dom Bool+  -- ^ Write enable+  -> Signal dom Int+  -- ^ Write address @w@+  -> Signal dom (BitVector m)+  -- ^ Value to write (at address @w@)+  -> Signal dom (BitVector m)+  -- ^ Value of the blockRAM at address @r@ from the previous clock cycle+blockRamBlob# !_ gen content@MemBlob{} = \rd wen waS wd -> runST $ do+  bvList <- unsafeIOToST (unpackMemBlob0 content)+  ramStart <- newListArray (0,szI-1) bvList+  go+    ramStart+    (withFrozenCallStack (deepErrorX "blockRamBlob: intial value undefined"))+    (fromEnable gen)+    rd+    (fromEnable gen .&&. wen)+    waS+    wd+ where+  szI = natToNum @n @Int++  go :: STArray s Int (BitVector m) -> BitVector m -> Signal dom Bool+     -> Signal dom Int -> Signal dom Bool -> Signal dom Int+     -> Signal dom (BitVector m) -> ST s (Signal dom (BitVector m))+  go !ram o ret@(~(re :- res)) rt@(~(r :- rs)) et@(~(e :- en)) wt@(~(w :- wr))+     dt@(~(d :- din)) = do+    o `seqX` (o :-) <$> (ret `seq` rt `seq` et `seq` wt `seq` dt `seq`+      unsafeInterleaveST+        (do o' <- unsafeIOToST+                    (catch (if re then unsafeSTToIO (ram `safeAt` r) else pure o)+                    (\err@XException {} -> pure (throw err)))+            d `defaultSeqX` upd ram e w d+            go ram o' res rs en wr din))++  upd :: STArray s Int (BitVector m) -> Bool -> Int -> BitVector m -> ST s ()+  upd ram we waddr d = case maybeIsX we of+    Nothing -> case maybeIsX waddr of+      Nothing -> -- Put the XException from `waddr` as the value in all+                 -- locations of `ram`.+                 forM_ [0..(szI-1)] (\i -> unsafeWriteSTArray ram i (seq waddr d))+      Just wa -> -- Put the XException from `we` as the value at address+                 -- `waddr`.+                 safeUpdate wa (seq we d) ram+    Just True -> case maybeIsX waddr of+      Nothing -> -- Put the XException from `waddr` as the value in all+                 -- locations of `ram`.+                 forM_ [0..(szI-1)] (\i -> unsafeWriteSTArray ram i (seq waddr d))+      Just wa -> safeUpdate wa d ram+    _ -> return ()++  safeAt :: STArray s Int (BitVector m) -> Int -> ST s (BitVector m)+  safeAt s i =+    if (0 <= i) && (i < szI) then+      unsafeReadSTArray s i+    else pure $+      withFrozenCallStack+        (deepErrorX ("blockRamBlob: read address " <> show i <>+                     " not in range [0.." <> show szI <> ")"))+  {-# INLINE safeAt #-}++  safeUpdate :: Int -> BitVector m -> STArray s Int (BitVector m) -> ST s ()+  safeUpdate i a s =+    if (0 <= i) && (i < szI) then+      unsafeWriteSTArray s i a+    else+      let d = withFrozenCallStack+                (deepErrorX ("blockRam: write address " <> show i <>+                             " not in range [0.." <> show szI <> ")"))+       in forM_ [0..(szI-1)] (\j -> unsafeWriteSTArray s j d)+  {-# INLINE safeUpdate #-}+{-# ANN blockRamBlob# hasBlackBox #-}+{-# NOINLINE blockRamBlob# #-}++-- | Create a 'MemBlob' binding from a list of values+--+-- Since this uses Template Haskell, nothing in the arguments given to+-- 'createMemBlob' can refer to something defined in the same module.+--+-- === __Example__+--+-- @+-- 'createMemBlob' "content" 'Nothing' [15 :: Unsigned 8 .. 17]+--+-- ram clk en = 'blockRamBlob' clk en content+-- @+--+-- The 'Data.Maybe.Maybe' datatype has don't care bits, where the actual value+-- does not matter. But the bits need a defined value in the memory. Either 0 or+-- 1 can be used, and both are valid representations of the data.+--+-- >>> import qualified Prelude as P+-- >>> let es = [ Nothing, Just (7 :: Unsigned 8), Just 8 ]+-- >>> :{+-- createMemBlob "content0" (Just 0) es+-- createMemBlob "content1" (Just 1) es+-- x = 1+-- :}+--+-- >>> let pr = mapM_ (putStrLn . show)+-- >>> pr $ P.map pack es+-- 0b0_...._....+-- 0b1_0000_0111+-- 0b1_0000_1000+-- >>> pr $ unpackMemBlob content0+-- 0b0_0000_0000+-- 0b1_0000_0111+-- 0b1_0000_1000+-- >>> pr $ unpackMemBlob content1+-- 0b0_1111_1111+-- 0b1_0000_0111+-- 0b1_0000_1000+-- >>> :{+-- createMemBlob "contentN" Nothing es+-- x = 1+-- :}+-- <BLANKLINE>+-- <interactive>:...: error:+--     packBVs: cannot convert don't care values. Please specify a mapping to a definite value.+--+-- Note how we hinted to @clashi@ that our multi-line command was a list of+-- declarations by including a dummy declaration @x = 1@. Without this trick,+-- @clashi@ would expect an expression and the Template Haskell would not work.+createMemBlob+  :: forall a f+   . ( Foldable f+     , BitPack a+     )+  => String+  -- ^ Name of the binding to generate+  -> Maybe Bit+  -- ^ Value to map don't care bits to. 'Nothing' means throwing an error on+  -- don't care bits.+  -> f a+  -- ^ The content for the 'MemBlob'+  -> DecsQ+createMemBlob name care es =+  case packed of+    Left err -> fail err+    Right _ -> sequence+      [ sigD name0 [t| MemBlob $(n) $(m) |]+      , valD (varP name0) (normalB [| MemBlob { memBlobRunsLen = $(runsLen)+                                              , memBlobRuns = $(runs)+                                              , memBlobEndsLen = $(endsLen)+                                              , memBlobEnds = $(ends)+                                              } |]) []+      ]+ where+  name0 = mkName name+  n = litT . numTyLit . toInteger $ len+  m = litT . numTyLit $ natToInteger @(BitSize a)+  runsLen = litE . integerL . toInteger $ L.length runsB+  runs = litE . stringPrimL $ L.unpack runsB+  endsLen = litE . integerL . toInteger $ L.length endsB+  ends = litE . stringPrimL $ L.unpack endsB+  Right (len, runsB, endsB) = packed+  packed = packBVs care es++-- | Create a 'MemBlob' from a list of values+--+-- Since this uses Template Haskell, nothing in the arguments given to+-- 'memBlobTH' can refer to something defined in the same module.+--+-- === __Example__+--+-- @+-- ram clk en = 'blockRamBlob' clk en $(memBlobTH Nothing [15 :: Unsigned 8 .. 17])+-- @+--+-- The 'Data.Maybe.Maybe' datatype has don't care bits, where the actual value+-- does not matter. But the bits need a defined value in the memory. Either 0 or+-- 1 can be used, and both are valid representations of the data.+--+-- >>> import qualified Prelude as P+-- >>> let es = [ Nothing, Just (7 :: Unsigned 8), Just 8 ]+-- >>> content0 = $(memBlobTH (Just 0) es)+-- >>> content1 = $(memBlobTH (Just 1) es)+-- >>> let pr = mapM_ (putStrLn . show)+-- >>> pr $ P.map pack es+-- 0b0_...._....+-- 0b1_0000_0111+-- 0b1_0000_1000+-- >>> pr $ unpackMemBlob content0+-- 0b0_0000_0000+-- 0b1_0000_0111+-- 0b1_0000_1000+-- >>> pr $ unpackMemBlob content1+-- 0b0_1111_1111+-- 0b1_0000_0111+-- 0b1_0000_1000+-- >>> $(memBlobTH Nothing es)+-- <BLANKLINE>+-- <interactive>:...: error:+--     • packBVs: cannot convert don't care values. Please specify a mapping to a definite value.+--     • In the untyped splice: $(memBlobTH Nothing es)+memBlobTH+  :: forall a f+   . ( Foldable f+     , BitPack a+     )+  => Maybe Bit+  -- ^ Value to map don't care bits to. 'Nothing' means throwing an error on+  -- don't care bits.+  -> f a+  -- ^ The content for the 'MemBlob'+  -> ExpQ+memBlobTH care es =+  case packed of+    Left err -> fail err+    Right _ -> [| MemBlob { memBlobRunsLen = $(runsLen)+                          , memBlobRuns = $(runs)+                          , memBlobEndsLen = $(endsLen)+                          , memBlobEnds = $(ends)+                          }+                    :: MemBlob $(n) $(m) |]+ where+  n = litT . numTyLit . toInteger $ len+  m = litT . numTyLit $ natToInteger @(BitSize a)+  runsLen = litE . integerL . toInteger $ L.length runsB+  runs = litE . stringPrimL $ L.unpack runsB+  endsLen = litE . integerL . toInteger $ L.length endsB+  ends = litE . stringPrimL $ L.unpack endsB+  Right (len, runsB, endsB) = packed+  packed = packBVs care es

@@ -1,6 +1,6 @@ {-| Copyright  :  (C) 2015-2016, University of Twente,-                  2017     , Google Inc.+                  2017     , Google Inc.,                   2019     , Myrtle Software Ltd,                   2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)@@ -32,6 +32,12 @@ 000001101 @ +Such a file can be produced with 'memFile':++@+writeFile "memory.bin" (memFile Nothing [7 :: Unsigned 9 .. 13])+@+ We can instantiate a BlockRAM using the content of the above file like so:  @@@ -88,34 +94,55 @@   ( -- * BlockRAM synchronized to an arbitrary clock     blockRamFile   , blockRamFilePow2+    -- * Producing files+  , memFile     -- * Internal   , blockRamFile#   , initMem   ) where +import Control.Exception     (catch, throw)+import Control.Monad         (forM_)+import Control.Monad.ST      (ST, runST)+import Control.Monad.ST.Unsafe (unsafeInterleaveST, unsafeIOToST, unsafeSTToIO)+import Data.Array.MArray     (newArray_)+import Data.Bits             ((.&.), (.|.), shiftL, xor) import Data.Char             (digitToInt) import Data.Maybe            (isJust, listToMaybe)-import qualified Data.Sequence as Seq+import GHC.Arr               (STArray, unsafeReadSTArray, unsafeWriteSTArray) import GHC.Stack             (HasCallStack, withFrozenCallStack) import GHC.TypeLits          (KnownNat) import Numeric               (readInt)-import System.IO.Unsafe      (unsafePerformIO)+import System.IO -import Clash.Promoted.Nat    (SNat (..), pow2SNat)-import Clash.Sized.BitVector (BitVector)+import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Class.BitPack   (BitPack, BitSize, pack)+import Clash.Promoted.Nat    (SNat (..), pow2SNat, natToNum, snatToNum)+import Clash.Sized.Internal.BitVector (Bit(..), BitVector(..), undefined#) import Clash.Signal.Internal   (Clock(..), Signal (..), Enable, KnownDomain, fromEnable, (.&&.)) import Clash.Signal.Bundle   (unbundle) import Clash.Sized.Unsigned  (Unsigned)-import Clash.XException      (errorX, maybeIsX, seqX, fromJustX)+import Clash.XException      (errorX, maybeIsX, seqX, fromJustX, XException (..)) +-- start benchmark only+-- import GHC.Arr (unsafeFreezeSTArray, unsafeThawSTArray)+-- end benchmark only +-- $setup+-- >>> :m -Prelude+-- >>> :set -fplugin GHC.TypeLits.Normalise+-- >>> :set -fplugin GHC.TypeLits.KnownNat.Solver+-- >>> import Clash.Prelude+-- >>> import Clash.Prelude.BlockRam.File++ -- | Create a blockRAM with space for 2^@n@ elements -- -- * __NB__: Read value is delayed by 1 cycle -- * __NB__: Initial output value is /undefined/, reading it will throw an--- 'Clash.XException.XException'+-- 'XException' -- * __NB__: This function might not work for specific combinations of -- code-generation backends and hardware targets. Please check the support table -- below:@@ -136,8 +163,9 @@ -- * Use the adapter 'Clash.Explicit.BlockRam.readNew' for obtaining write-before-read semantics like this: @'Clash.Explicit.BlockRam.readNew' clk rst en (blockRamFilePow2' clk en file) rd wrM@. -- * See "Clash.Explicit.BlockRam.File#usingramfiles" for more information on how -- to instantiate a Block RAM with the contents of a data file.--- * See "Clash.Explicit.Fixed#creatingdatafiles" for ideas on how to create your--- own data files.+-- * See 'memFile' for creating a data file with Clash.+-- * See "Clash.Explicit.Fixed#creatingdatafiles" for more ideas on how to+-- create your own data files. blockRamFilePow2   :: forall dom n m    . (KnownDomain dom, KnownNat m, KnownNat n, HasCallStack)@@ -161,7 +189,7 @@ -- -- * __NB__: Read value is delayed by 1 cycle -- * __NB__: Initial output value is /undefined/, reading it will throw an--- 'Clash.XException.XException'+-- 'XException' -- * __NB__: This function might not work for specific combinations of -- code-generation backends and hardware targets. Please check the support table -- below:@@ -182,8 +210,9 @@ -- * Use the adapter 'Clash.Explicit.BlockRam.readNew' for obtaining write-before-read semantics like this: @'Clash.Explicit.BlockRam.readNew' clk rst en ('blockRamFile' clk en size file) rd wrM@. -- * See "Clash.Explicit.BlockRam.File#usingramfiles" for more information on how -- to instantiate a Block RAM with the contents of a data file.--- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your--- own data files.+-- * See 'memFile' for creating a data file with Clash.+-- * See "Clash.Sized.Fixed#creatingdatafiles" for more ideas on how to create+-- your own data files. blockRamFile   :: (KnownDomain dom, KnownNat m, Enum addr, HasCallStack)   => Clock dom@@ -208,6 +237,80 @@       (blockRamFile# clk gen sz file (fromEnum <$> rd) en (fromEnum <$> wr) din) {-# INLINE blockRamFile #-} +-- | Convert data to the String contents of a memory file.+--+-- * __NB:__ Not synthesizable+-- * The following document the several ways to instantiate components with+-- files:+--+--     * "Clash.Prelude.BlockRam.File#usingramfiles"+--     * "Clash.Prelude.ROM.File#usingromfiles"+--     * "Clash.Explicit.BlockRam.File#usingramfiles"+--     * "Clash.Explicit.ROM.File#usingromfiles"+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" for more ideas on how to create+-- your own data files.+--+-- = Example+--+-- The @Maybe@ datatype has don't care bits, where the actual value does not+-- matter. But the bits need a defined value in the memory. Either 0 or 1 can be+-- used, and both are valid representations of the data.+--+-- >>> let es = [ Nothing, Just (7 :: Unsigned 8), Just 8]+-- >>> mapM_ (putStrLn . show . pack) es+-- 0b0_...._....+-- 0b1_0000_0111+-- 0b1_0000_1000+-- >>> putStr (memFile (Just 0) es)+-- 000000000+-- 100000111+-- 100001000+-- >>> putStr (memFile (Just 1) es)+-- 011111111+-- 100000111+-- 100001000+--+memFile+  :: forall a f+   . ( BitPack a+     , Foldable f+     , HasCallStack)+  => Maybe Bit+  -- ^ Value to map don't care bits to. Nothing means throwing an error on+  -- don't care bits.+  -> f a+  -- ^ Values to convert.+  -> String+  -- ^ Contents of the memory file.+memFile care = foldr (\e -> showsBV $ pack e) ""+ where+  showsBV :: BitVector (BitSize a) -> String -> String+  showsBV (BV mask val) s =+    if n == 0 then+      '0' : '\n' : s+    else+      case care of+        Just (Bit 0 0) -> go n (val .&. (mask `xor` fullMask)) ('\n' : s)+        Just (Bit 0 1)  -> go n (val .|. mask) ('\n' : s)+        _ -> if mask /= 0 then+               err+             else+               go n val ('\n' : s)+   where+    n = natToNum @(BitSize a) @Int+    fullMask = (1 `shiftL` n) - 1+    err = withFrozenCallStack $ error $+            "memFile: cannot convert don't-care values. "+            ++ "Please specify mapping to definite value."+    go 0  _ s0 = s0+    go n0 v s0 =+      let (!v0, !vBit) = quotRem v 2+      in if vBit == 0 then+           go (n0 - 1) v0 $ '0' : s0+         else+           go (n0 - 1) v0 $ '1' : s0+ -- | blockRamFile primitive blockRamFile#   :: forall m dom n@@ -230,49 +333,95 @@   -- ^ Value to write (at address @w@)   -> Signal dom (BitVector m)   -- ^ Value of the @blockRAM@ at address @r@ from the previous clock cycle-blockRamFile# (Clock _) ena !_sz file rd wen =+blockRamFile# (Clock _) ena sz file = \rd wen waS wd -> runST $ do+  ramStart <- newArray_ (0,szI)+  unsafeIOToST (withFile file ReadMode (\h ->+    forM_ [0..(szI-1)] (\i -> do+      l <- hGetLine h+      let bv = parseBV l+      bv `seq` unsafeSTToIO (unsafeWriteSTArray ramStart i bv)+      )))+  -- start benchmark only+  -- ramStart <- unsafeThawSTArray ramArr+  -- end benchmark only   go-    ramI-    (withFrozenCallStack (errorX "blockRamFile#: intial value undefined"))+    ramStart+    (withFrozenCallStack (errorX "blockRamFile: intial value undefined"))     (fromEnable ena)     rd     (fromEnable ena .&&. wen)-  where-    -- clock enable-    go-      :: Seq.Seq (BitVector m)-      -> BitVector m-      -> Signal dom Bool-      -> Signal dom Int-      -> Signal dom Bool-      -> Signal dom Int-      -> Signal dom (BitVector m)-      -> 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 `Seq.index` r else o-      in  o `seqX` o :- go ram' o' res rs en wr din+    waS+    wd+ where+  szI = snatToNum sz :: Int+  -- start benchmark only+  -- ramArr = runST $ do+  --             ram <- newArray_ (0,szI-1) -- 0 -- (error "QQ")+  --             unsafeIOToST (withFile file ReadMode (\h ->+  --               forM_ [0..(szI-1)] (\i -> do+  --                 l <- hGetLine h+  --                 let bv = parseBV l+  --                 bv `seq` unsafeSTToIO (unsafeWriteSTArray ram i bv))+  --               ))+  --             unsafeFreezeSTArray ram+  -- end benchmark only -    upd ram we waddr d = case maybeIsX we of-      Nothing -> case maybeIsX waddr of-        Nothing -> -- Put the XException from `waddr` as the value in all-                   -- locations of `ram`.-                   seq waddr d <$ ram-        Just wa -> -- Put the XException from `we` as the value at address-                   -- `waddr`.-                   Seq.update wa (seq we d) ram-      Just True -> case maybeIsX waddr of-        Nothing -> -- Put the XException from `waddr` as the value in all-                   -- locations of `ram`.-                   seq waddr d <$ ram-        Just wa -> Seq.update wa d ram-      _ -> ram+  go :: STArray s Int (BitVector m) -> (BitVector m) -> Signal dom Bool -> Signal dom Int+    -> Signal dom Bool -> Signal dom Int -> Signal dom (BitVector m)+    -> ST s (Signal dom (BitVector m))+  go !ram o ret@(~(re :- res)) rt@(~(r :- rs)) et@(~(e :- en)) wt@(~(w :- wr)) dt@(~(d :- din)) = do+    o `seqX` (o :-) <$> (ret `seq` rt `seq` et `seq` wt `seq` dt `seq`+      unsafeInterleaveST+        (do o' <- unsafeIOToST+                    (catch (if re then unsafeSTToIO (ram `safeAt` r) else pure o)+                    (\err@XException {} -> pure (throw err)))+            d `seqX` upd ram e (fromEnum w) d+            go ram o' res rs en wr din)) -    content = unsafePerformIO (initMem file)+  upd :: STArray s Int (BitVector m) -> Bool -> Int -> (BitVector m) -> ST s ()+  upd ram we waddr d = case maybeIsX we of+    Nothing -> case maybeIsX waddr of+      Nothing -> -- Put the XException from `waddr` as the value in all+                 -- locations of `ram`.+                 forM_ [0..(szI-1)] (\i -> unsafeWriteSTArray ram i (seq waddr d))+      Just wa -> -- Put the XException from `we` as the value at address+                 -- `waddr`.+                 safeUpdate wa (seq we d) ram+    Just True -> case maybeIsX waddr of+      Nothing -> -- Put the XException from `waddr` as the value in all+                 -- locations of `ram`.+                 forM_ [0..(szI-1)] (\i -> unsafeWriteSTArray ram i (seq waddr d))+      Just wa -> safeUpdate wa d ram+    _ -> return () -    ramI :: Seq.Seq (BitVector m)-    ramI = Seq.fromList content+  safeAt :: HasCallStack => STArray s Int (BitVector m) -> Int -> ST s (BitVector m)+  safeAt s i =+    if (0 <= i) && (i < szI) then+      unsafeReadSTArray s i+    else pure $+      withFrozenCallStack+        (errorX ("blockRamFile: read address " <> show i <>+                " not in range [0.." <> show szI <> ")"))+  {-# INLINE safeAt #-}++  safeUpdate :: HasCallStack => Int -> a -> STArray s Int a -> ST s ()+  safeUpdate i a s =+    if (0 <= i) && (i < szI) then+      unsafeWriteSTArray s i a+    else+      let d = withFrozenCallStack+                (errorX ("blockRamFile: write address " <> show i <>+                        " not in range [0.." <> show szI <> ")"))+      in forM_ [0..(szI-1)] (\j -> unsafeWriteSTArray s j d)+  {-# INLINE safeUpdate #-}++  parseBV :: String -> BitVector m+  parseBV s = case parseBV' s of+                Just i  -> fromInteger i+                Nothing -> undefined#+  parseBV' = fmap fst . listToMaybe . readInt 2 (`elem` "01") digitToInt {-# NOINLINE blockRamFile# #-}+{-# ANN blockRamFile# hasBlackBox #-}  -- | __NB:__ Not synthesizable initMem :: KnownNat n => FilePath -> IO [BitVector n]

@@ -0,0 +1,193 @@+{-|+Copyright  :  (C) 2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++module Clash.Explicit.BlockRam.Internal where++import Data.Bits ((.&.), (.|.), shiftL, xor)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Builder (Builder, toLazyByteString, word8, word64BE)+import qualified Data.ByteString.Unsafe as B+import Data.Foldable (foldl')+import Data.Word (Word64)+import GHC.Exts (Addr#)+import GHC.TypeLits (KnownNat, Nat)+import Numeric.Natural (Natural)+import System.IO.Unsafe (unsafePerformIO)++import Clash.Class.BitPack.Internal (BitPack, BitSize, pack)+import Clash.Promoted.Nat (natToNum)+import Clash.Sized.Internal.BitVector (Bit(..), BitVector(..))++-- | Efficient storage of memory content+--+-- It holds @n@ words of @'BitVector' m@.+data MemBlob (n :: Nat) (m :: Nat) where+  MemBlob+    :: ( KnownNat n+       , KnownNat m+       )+    => { memBlobRunsLen :: !Int+       , memBlobRuns :: Addr#+       , memBlobEndsLen :: !Int+       , memBlobEnds :: Addr#+       }+    -> MemBlob n m++instance Show (MemBlob n m) where+  showsPrec _ x@MemBlob{} =+    ("$(memBlobTH @(BitVector " ++) . shows (natToNum @m @Int) .+      (") Nothing " ++) . shows (unpackMemBlob x) . (')':)++-- | Convert a 'MemBlob' back to a list+--+-- __NB__: Not synthesizable+unpackMemBlob+  :: forall n m+   . MemBlob n m+  -> [BitVector m]+unpackMemBlob = unsafePerformIO . unpackMemBlob0++unpackMemBlob0+  :: forall n m+   . MemBlob n m+  -> IO [BitVector m]+unpackMemBlob0 MemBlob{..} = do+  runsB <- B.unsafePackAddressLen memBlobRunsLen memBlobRuns+  endsB <- B.unsafePackAddressLen memBlobEndsLen memBlobEnds+  return $ map (BV 0) $+    unpackNats (natToNum @n) (natToNum @m) runsB endsB++packBVs+  :: forall a f+   . ( Foldable f+     , BitPack a+     )+  => Maybe Bit+  -> f a+  -> Either String (Int, L.ByteString, L.ByteString)+packBVs care es =+  case lenOrErr of+    Nothing  -> Left err+    Just len -> let (runs, ends) = packAsNats mI (knownBVVal . pack) es+                in Right (len, runs, ends)+ where+  lenOrErr = case care of+               Just (Bit 0 _) -> Just $ length es+               _              -> foldl' lenOrErr0 (Just 0) es+  lenOrErr0 (Just len) (pack -> BV 0 _) = Just $ len + 1+  lenOrErr0 _          _                = Nothing++  knownBVVal bv@(BV _ val) = case care of+    Just (Bit 0 bm) -> maskBVVal bm bv+    _               -> val++  maskBVVal _ (BV 0    val) = val+  maskBVVal 0 (BV mask val) = val .&. (mask `xor` fullMask)+  maskBVVal _ (BV mask val) = val .|. mask++  mI = natToNum @(BitSize a) @Int+  fullMask = (1 `shiftL` mI) - 1+  err = "packBVs: cannot convert don't care values. " +++        "Please specify a mapping to a definite value."++packAsNats+  :: forall a f+   . Foldable f+  => Int+  -> (a -> Natural)+  -> f a+  -> (L.ByteString, L.ByteString)+packAsNats width trans es = (toLazyByteString runs0, toLazyByteString ends)+ where+  (runL, endL) = width `divMod` 8+  ends | endC0 > 0 = word64BE endA0 <> ends0+       | otherwise = ends0+  (runs0, ends0, endC0, endA0) = foldr pack0 (mempty, mempty, 0, 0) es++  pack0 :: a -> (Builder, Builder, Int, Word64) ->+           (Builder, Builder, Int, Word64)+  pack0 val (runs1, ends1, endC1, endA1) =+    let (ends2, endC2, endA2) = packEnd val2 ends1 endC1 endA1+        (val2, runs2) = packRun runL (trans val) runs1+    in (runs2, ends2, endC2, endA2)++  packRun :: Int -> Natural -> Builder -> (Natural, Builder)+  packRun 0    val1 runs1 = (val1, runs1)+  packRun runC val1 runs1 = let (val2, runB) = val1 `divMod` 256+                                runs2 = word8 (fromIntegral runB) <> runs1+                            in packRun (runC - 1) val2 runs2++  packEnd :: Natural -> Builder -> Int -> Word64 -> (Builder, Int, Word64)+  packEnd val2 ends1 endC1 endA1+    | endL == 0   = (ends1, endC1, endA1)+    | endC2 <= 64 = let endA2 = endA1 * (2 ^ endL) + valEnd+                    in (ends1, endC2, endA2)+    | otherwise   = let ends2 = word64BE endA1 <> ends1+                    in (ends2, endL, valEnd)+   where+    endC2 = endC1 + endL+    valEnd = fromIntegral val2++unpackNats+  :: Int+  -> Int+  -> B.ByteString+  -> B.ByteString+  -> [Natural]+unpackNats 0 _ _ _ = []+unpackNats len width runBs endBs+  | width < 8 = ends+  | otherwise = go (head ends) runL runBs (tail ends)+ where+  (runL, endL) = width `divMod` 8+  ends = if endL == 0 then+           repeat 0+         else+           unpackEnds endL len $ unpackW64s endBs++  go val 0    runBs0 ~(end0:ends0) = val : go end0 runL runBs0 ends0+  go _   _    runBs0 _             | B.null runBs0 = []+  go val runC runBs0 ends0+    = let Just (runB, runBs1) = B.uncons runBs0+          val0 = val * 256 + fromIntegral runB+      in go val0 (runC - 1) runBs1 ends0++unpackW64s+  :: B.ByteString+  -> [Word64]+unpackW64s = go 8 0+ where+  go :: Int -> Word64 -> B.ByteString -> [Word64]+  go 8 _   endBs | B.null endBs = []+  go 0 val endBs = val : go 8 0 endBs+  go n val endBs = let Just (endB, endBs0) = B.uncons endBs+                       val0 = val * 256 + fromIntegral endB+                   in go (n - 1) val0 endBs0++unpackEnds+  :: Int+  -> Int+  -> [Word64]+  -> [Natural]+unpackEnds _    _   []     = []+unpackEnds endL len (w:ws) = go endCInit w ws+ where+  endPerWord = 64 `div` endL+  leader = len `mod` endPerWord+  endCInit | leader == 0 = endPerWord+           | otherwise   = leader++  go 0 _    []       = []+  go 0 _    (w0:ws0) = go endPerWord w0 ws0+  go n endA ws0      = let (endA0, valEnd) = endA `divMod` (2 ^ endL)+                       in fromIntegral valEnd : go (n - 1) endA0 ws0

@@ -27,8 +27,6 @@  {- $setup >>> :set -XDataKinds -XTypeApplications->>> :m -Clash.Prelude->>> :m -Clash.Prelude.Safe >>> import Clash.Explicit.Prelude >>> import qualified Data.List as L >>> :{

@@ -29,8 +29,6 @@  {- $setup >>> :set -XDataKinds -XTypeApplications->>> :m -Clash.Prelude->>> :m -Clash.Prelude.Safe >>> import Clash.Explicit.Prelude >>> let macT s (x,y) = x * y + s >>> let mac clk rst en = moore clk rst en macT id 0

@@ -1,9 +1,10 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2017     , Google Inc.-                  2019     , Myrtle Software Ltd+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  This module defines the explicitly clocked counterparts of the functions defined in "Clash.Prelude".@@ -31,7 +32,12 @@   , asyncRomPow2   , rom   , romPow2-    -- ** ROMs initialized with a data file+    -- ** ROMs defined by a 'MemBlob'+  , asyncRomBlob+  , asyncRomBlobPow2+  , romBlob+  , romBlobPow2+    -- ** ROMs defined by a data file   , asyncRomFile   , asyncRomFilePow2   , romFile@@ -45,11 +51,22 @@   , blockRamU   , blockRam1   , ResetStrategy(..)+    -- ** BlockRAM primitives initialized with a 'MemBlob'+  , blockRamBlob+  , blockRamBlobPow2+    -- *** Creating and inspecting 'MemBlob'+  , MemBlob+  , createMemBlob+  , memBlobTH+  , unpackMemBlob     -- ** BlockRAM primitives initialized with a data file   , blockRamFile   , blockRamFilePow2   -- ** BlockRAM read/write conflict resolution   , readNew+    -- ** True dual-port block RAM+  , trueDualPortBlockRam+  , RamOp(..)     -- * Utility functions   , window   , windowD@@ -78,8 +95,6 @@     -- ** Datatypes     -- *** Bit vectors   , module Clash.Sized.BitVector-  , module Clash.Prelude.BitIndex-  , module Clash.Prelude.BitReduction     -- *** Arbitrary-width numbers   , module Clash.Sized.Signed   , module Clash.Sized.Unsigned@@ -138,26 +153,26 @@  import Clash.Annotations.TopEntity import Clash.Class.AutoReg-import Clash.Class.BitPack hiding (GBitPack(..))+import Clash.Class.BitPack import Clash.Class.Exp import Clash.Class.Num import Clash.Class.Resize import Clash.Magic import Clash.NamedTypes import Clash.Explicit.BlockRam+import Clash.Explicit.BlockRam.Blob import Clash.Explicit.BlockRam.File import Clash.Explicit.Mealy import Clash.Explicit.Moore import Clash.Explicit.RAM import Clash.Explicit.ROM+import Clash.Explicit.ROM.Blob import Clash.Explicit.ROM.File import Clash.Explicit.Prelude.Safe import Clash.Explicit.Reset import Clash.Explicit.Signal import Clash.Explicit.Signal.Delayed import Clash.Explicit.Testbench-import Clash.Prelude.BitIndex-import Clash.Prelude.BitReduction import Clash.Prelude.ROM.File       (asyncRomFile, asyncRomFilePow2) import Clash.Promoted.Nat import Clash.Promoted.Nat.TH@@ -175,7 +190,6 @@  {- $setup >>> :set -XDataKinds -XTypeApplications->>> :m -Clash.Prelude >>> import Clash.Explicit.Prelude >>> let window4 = window @3 >>> let windowD3 = windowD @2@@ -203,7 +217,7 @@ -- @ -- -- >>> simulateB (window4 systemClockGen systemResetGen enableGen) [1::Int,2,3,4,5] :: [Vec 4 Int]--- [<1,0,0,0>,<2,1,0,0>,<3,2,1,0>,<4,3,2,1>,<5,4,3,2>...+-- [1 :> 0 :> 0 :> 0 :> Nil,2 :> 1 :> 0 :> 0 :> Nil,3 :> 2 :> 1 :> 0 :> Nil,4 :> 3 :> 2 :> 1 :> Nil,5 :> 4 :> 3 :> 2 :> Nil,... -- ... window   :: ( KnownNat n@@ -242,7 +256,7 @@ -- @ -- -- >>> simulateB (windowD3 systemClockGen resetGen enableGen) [1::Int,1,2,3,4] :: [Vec 3 Int]--- [<0,0,0>,<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>...+-- [0 :> 0 :> 0 :> Nil,0 :> 0 :> 0 :> Nil,1 :> 0 :> 0 :> Nil,2 :> 1 :> 0 :> Nil,3 :> 2 :> 1 :> Nil,4 :> 3 :> 2 :> Nil,... -- ... windowD   :: ( KnownNat n

@@ -1,9 +1,10 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2017     , Google Inc.-                  2019     , Myrtle Software Ltd+                  2019     , Myrtle Software Ltd,+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  __This is the <https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/exts/safe_haskell.html Safe> API only of "Clash.Explicit.Prelude"__ @@ -33,14 +34,30 @@   , asyncRomPow2   , rom   , romPow2+    -- ** ROMs defined by a 'MemBlob'+  , asyncRomBlob+  , asyncRomBlobPow2+  , romBlob+  , romBlobPow2     -- * RAM primitives with a combinational read port   , asyncRam   , asyncRamPow2     -- * BlockRAM primitives   , blockRam   , blockRamPow2+    -- ** BlockRAM primitives initialized with a 'MemBlob'+  , blockRamBlob+  , blockRamBlobPow2+    -- *** Creating and inspecting 'MemBlob'+  , MemBlob+  , createMemBlob+  , memBlobTH+  , unpackMemBlob     -- ** BlockRAM read/write conflict resolution   , readNew+    -- ** True dual-port block RAM+  , trueDualPortBlockRam+  , RamOp(..)     -- * Utility functions   , isRising   , isFalling@@ -53,8 +70,6 @@     -- ** Datatypes     -- *** Bit vectors   , module Clash.Sized.BitVector-  , module Clash.Prelude.BitIndex-  , module Clash.Prelude.BitReduction     -- *** Arbitrary-width numbers   , module Clash.Sized.Signed   , module Clash.Sized.Unsigned@@ -111,16 +126,17 @@ import Clash.NamedTypes  import Clash.Explicit.BlockRam+import Clash.Explicit.BlockRam.Blob import Clash.Explicit.Mealy import Clash.Explicit.Moore import Clash.Explicit.RAM import Clash.Explicit.ROM+import Clash.Explicit.ROM.Blob import Clash.Explicit.Signal import Clash.Explicit.Signal.Delayed import Clash.Explicit.Synchronizer   (dualFlipFlopSynchronizer, asyncFIFOSynchronizer)-import Clash.Prelude.BitIndex-import Clash.Prelude.BitReduction+import Clash.Prelude.ROM.Blob (asyncRomBlob, asyncRomBlobPow2) import Clash.Prelude.ROM             (asyncRom, asyncRomPow2) import Clash.Promoted.Nat import Clash.Promoted.Nat.TH@@ -137,8 +153,7 @@  {- $setup >>> :set -XDataKinds->>> :m -Clash.Prelude->>> :m -Clash.Prelude.Safe+>>> :m -Prelude >>> import Clash.Explicit.Prelude.Safe >>> let rP clk rst en = registerB clk rst en (8::Int,8::Int) -}

@@ -2,7 +2,7 @@ Copyright  :  (C) 2015-2016, University of Twente,                   2017     , Google Inc.                   2019     , Myrtle Software Ltd,-                  2022     , QBayLogic B.V.+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE) Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> @@ -35,12 +35,14 @@ import GHC.TypeLits          (KnownNat) import qualified Data.Sequence as Seq -import Clash.Explicit.Signal (unbundle, KnownDomain, enable)+import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Explicit.Signal (unbundle, KnownDomain, andEnable) import Clash.Promoted.Nat    (SNat (..), snatToNum, pow2SNat) import Clash.Signal.Internal (Clock (..), Signal (..), Enable, fromEnable) import Clash.Signal.Internal.Ambiguous (clockPeriod) import Clash.Sized.Unsigned  (Unsigned)-import Clash.XException      (errorX, maybeIsX, fromJustX, seqX)+import Clash.XException+  (defaultSeqX, errorX, fromJustX, maybeIsX, NFDataX)  -- | Create a RAM with space for 2^@n@ elements --@@ -57,6 +59,7 @@      , HasCallStack      , KnownDomain wdom      , KnownDomain rdom+     , NFDataX a      )   => Clock wdom   -- ^ 'Clock' to which to synchronize the write port of the RAM@@ -89,6 +92,7 @@      , HasCallStack      , KnownDomain wdom      , KnownDomain rdom+     , NFDataX a      )   => Clock wdom    -- ^ 'Clock' to which to synchronize the write port of the RAM@@ -116,7 +120,9 @@   :: forall wdom rdom n a    . ( HasCallStack      , KnownDomain wdom-     , KnownDomain rdom )+     , KnownDomain rdom+     , NFDataX a+     )   => Clock wdom   -- ^ 'Clock' to which to synchronize the write port of the RAM   -> Clock rdom@@ -140,7 +146,7 @@     ramI = Seq.replicate               szI               (withFrozenCallStack (errorX "asyncRam#: initial value undefined"))-    en0 = fromEnable (enable en we)+    en0 = fromEnable (andEnable en we)     dout = if rPeriod == wPeriod            then goSingle ramI rd en0 wr din            else go 0 ramI rd en0 wr din@@ -152,8 +158,8 @@        -> Signal wdom Int -> Signal wdom a -> Signal rdom a     goSingle !ram (r :- rs) ~(e :- es) wt@(~(w :- ws)) dt@(~(d :- ds)) =       let ram0 = upd ram e w d-          o    = ram `Seq.index` r-      in  o :- (wt `seq` dt `seq` goSingle ram0 rs es ws ds)+          o    = ram `safeAt` r+      in  o :- (o `defaultSeqX` wt `seq` dt `seq` goSingle ram0 rs es ws ds)      -- Given     --   tR = absolute time of next active edge of read clock@@ -170,8 +176,8 @@       | relTime < 0 = let ram0 = upd ram e w d                       in wt `seq` dt `seq`                          go (relTime + wPeriod) ram0 rt es ws ds-      | otherwise   = let o = ram `Seq.index` r-                      in o :- go (relTime - rPeriod) ram rs et wt dt+      | otherwise   = let o = ram `safeAt` r+                      in o :- (o `defaultSeqX` go (relTime - rPeriod) ram rs et wt dt)      upd ram we0 waddr d = case maybeIsX we0 of       Nothing -> case maybeIsX waddr of@@ -180,11 +186,33 @@                    seq waddr d <$ ram         Just wa -> -- Put the XException from `we` as the value at address                    -- `waddr`.-                   Seq.update wa (seq we0 d) ram+                   safeUpdate wa (seq we0 d) ram       Just True -> case maybeIsX waddr of         Nothing -> -- Put the XException from `waddr` as the value in all                    -- locations of `ram`.                    seq waddr d <$ ram-        Just wa -> d `seqX` Seq.update wa d ram+        Just wa -> d `defaultSeqX` safeUpdate wa d ram       _ -> ram++    safeAt :: HasCallStack => Seq.Seq a -> Int -> a+    safeAt s i =+      if (0 <= i) && (i < szI) then+        Seq.index s i+      else+        withFrozenCallStack+          (errorX ("asyncRam: read address " ++ show i +++                   " not in range [0.." ++ show szI ++ ")"))+    {-# INLINE safeAt #-}++    safeUpdate :: HasCallStack => Int -> a -> Seq.Seq a ->  Seq.Seq a+    safeUpdate i a s =+      if (0 <= i) && (i < szI) then+        Seq.update i a s+      else+        let d = withFrozenCallStack+                  (errorX ("asyncRam: write address " ++ show i +++                           " not in range [0.." ++ show szI ++ ")"))+        in d <$ s+    {-# INLINE safeUpdate #-} {-# NOINLINE asyncRam# #-}+{-# ANN asyncRam# hasBlackBox #-}

@@ -2,7 +2,7 @@ Copyright  :  (C) 2015-2016, University of Twente,                   2017     , Google Inc.                   2019     , Myrtle Software Ltd,-                  2022     , QBayLogic B.V.+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE) Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> @@ -27,11 +27,13 @@   ) where -import Data.Array             ((!),listArray)+import Data.Array             (listArray)+import Data.Array.Base        (unsafeAt) import GHC.Stack              (withFrozenCallStack) import GHC.TypeLits           (KnownNat, type (^)) import Prelude hiding         (length) +import Clash.Annotations.Primitive (hasBlackBox) import Clash.Signal.Internal   (Clock (..), KnownDomain, Signal (..), Enable, fromEnable) import Clash.Sized.Unsigned   (Unsigned)@@ -48,6 +50,10 @@ -- -- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Explicit.BlockRam#usingrams" -- for ideas on how to use ROMs and RAMs+-- * A large 'Vec' for the content might be too inefficient, depending on how it+-- is constructed. See 'Clash.Explicit.ROM.File.romFilePow2' and+-- 'Clash.Explicit.ROM.Blob.romBlobPow2' for different approaches that scale+-- well. romPow2   :: (KnownDomain dom, KnownNat n, NFDataX a)   => Clock dom@@ -75,6 +81,9 @@ -- -- * See "Clash.Sized.Fixed#creatingdatafiles" and "Clash.Explicit.BlockRam#usingrams" -- for ideas on how to use ROMs and RAMs+-- * A large 'Vec' for the content might be too inefficient, depending on how it+-- is constructed. See 'Clash.Explicit.ROM.File.romFile' and+-- 'Clash.Explicit.ROM.Blob.romBlob' for different approaches that scale well. rom   :: (KnownDomain dom, KnownNat n, NFDataX a, Enum addr)   => Clock dom@@ -117,7 +126,18 @@   arr = listArray (0,szI-1) (toList content)    go o (e :- es) rd@(~(r :- rs)) =-    let o1 = if e then arr ! r else o+    let o1 = if e then safeAt r else o     -- See [Note: register strictness annotations]     in  o `seqX` o :- (rd `seq` go o1 es rs)++  safeAt :: Int -> a+  safeAt i =+    if (0 <= i) && (i < szI) then+      unsafeAt arr i+    else+      withFrozenCallStack+        (deepErrorX ("rom: address " ++ show i +++                     " not in range [0.." ++ show szI ++ ")"))+  {-# INLINE safeAt #-} {-# NOINLINE rom# #-}+{-# ANN rom# hasBlackBox #-}

@@ -0,0 +1,153 @@+{-|+Copyright  :  (C) 2021-2022, QBayLogic B.V.+License    :  BSD2 (see the file LICENSE)+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>++= Efficient bundling of ROM content with the compiled code++Leveraging Template Haskell, the content for the ROM components in this module+is stored alongside the compiled Haskell code. It covers use cases where passing+the initial content as a 'Clash.Sized.Vector.Vec' turns out to be+problematically slow.++The data is stored efficiently, with very little overhead (worst-case 7%, often+no overhead at all).++Unlike "Clash.Explicit.ROM.File", "Clash.Explicit.ROM.Blob" generates+practically the same HDL as "Clash.Explicit.ROM" and is compatible with all+tools consuming the generated HDL.+-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module Clash.Explicit.ROM.Blob+  ( -- * ROMs defined by a 'MemBlob'+    romBlob+  , romBlobPow2+    -- * Creating and inspecting 'MemBlob'+  , MemBlob+  , createMemBlob+  , memBlobTH+  , unpackMemBlob+    -- * Internal+  , romBlob#+  ) where++import Data.Array (listArray)+import Data.Array.Base (unsafeAt)+import GHC.Stack (withFrozenCallStack)+import GHC.TypeLits (KnownNat, type (^))++import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Explicit.BlockRam.Blob (createMemBlob, memBlobTH)+import Clash.Explicit.BlockRam.Internal (MemBlob(..), unpackMemBlob)+import Clash.Promoted.Nat (natToNum)+import Clash.Signal.Internal+  (Clock (..), KnownDomain, Signal (..), Enable, fromEnable)+import Clash.Sized.Internal.BitVector (BitVector)+import Clash.Sized.Internal.Unsigned (Unsigned)+import Clash.XException (deepErrorX, seqX)++-- | A ROM with a synchronous read port, with space for @n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException'+--+-- Additional helpful information:+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" and+-- "Clash.Explicit.BlockRam#usingrams" for ideas on how to use ROMs and RAMs+romBlob+  :: forall dom addr m n+   . ( KnownDomain dom+     , Enum addr+     )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> MemBlob n m+  -- ^ ROM content, also determines the size, @n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom addr+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ The value of the ROM at address @r@ from the previous clock cycle+romBlob = \clk en content rd -> romBlob# clk en content (fromEnum <$> rd)+{-# INLINE romBlob #-}++-- | A ROM with a synchronous read port, with space for 2^@n@ elements+--+-- * __NB__: Read value is delayed by 1 cycle+-- * __NB__: Initial output value is /undefined/, reading it will throw an+-- 'Clash.XException.XException'+--+-- Additional helpful information:+--+-- * See "Clash.Sized.Fixed#creatingdatafiles" and+-- "Clash.Explicit.BlockRam#usingrams" for ideas on how to use ROMs and RAMs+romBlobPow2+  :: forall dom m n+   . ( KnownDomain dom+     , KnownNat n+     )+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> MemBlob (2^n) m+  -- ^ ROM content, also determines the size, 2^@n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom (Unsigned n)+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ The value of the ROM at address @r@ from the previous clock cycle+romBlobPow2 = romBlob+{-# INLINE romBlobPow2 #-}++-- | ROM primitive+romBlob#+  :: forall dom m n+   . KnownDomain dom+  => Clock dom+  -- ^ 'Clock' to synchronize to+  -> Enable dom+  -- ^ 'Enable' line+  -> MemBlob n m+  -- ^ ROM content, also determines the size, @n@, of the ROM+  --+  -- __NB__: __MUST__ be a constant+  -> Signal dom Int+  -- ^ Read address @r@+  -> Signal dom (BitVector m)+  -- ^ The value of the ROM at address @r@ from the previous clock cycle+romBlob# !_ en content@MemBlob{} =+  go+    (withFrozenCallStack (deepErrorX "romBlob: initial value undefined"))+    (fromEnable en)+ where+  szI = natToNum @n @Int+  arr = listArray (0,szI-1) $ unpackMemBlob content++  go o (e :- es) rd@(~(r :- rs)) =+    let o1 = if e then safeAt r else o+    -- See [Note: register strictness annotations]+    in  o `seqX` o :- (rd `seq` go o1 es rs)++  safeAt :: Int -> BitVector m+  safeAt i =+    if (0 <= i) && (i < szI) then+      unsafeAt arr i+    else+      withFrozenCallStack+        (deepErrorX ("romBlob: address " ++ show i +++                     " not in range [0.." ++ show szI ++ ")"))+  {-# INLINE safeAt #-}+{-# NOINLINE romBlob# #-}+{-# ANN romBlob# hasBlackBox #-}

@@ -1,8 +1,8 @@ {-| Copyright  :  (C) 2015-2016, University of Twente,-                  2017     , Google Inc.+                  2017     , Google Inc.,                   2019     , Myrtle Software Ltd.,-                  2022     , QBayLogic B.V.+                  2021-2022, QBayLogic B.V. License    :  BSD2 (see the file LICENSE) Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> @@ -31,6 +31,12 @@ 000001101 @ +Such a file can be produced with 'memFile':++@+writeFile "memory.bin" (memFile Nothing [7 :: Unsigned 9 .. 13])+@+ We can instantiate a synchronous ROM using the content of the above file like so: @@ -80,16 +86,20 @@   ( -- * Synchronous ROM synchronized to an arbitrary clock     romFile   , romFilePow2+    -- * Producing files+  , memFile     -- * Internal   , romFile#   ) where -import Data.Array                   (listArray,(!))+import Data.Array                   (listArray)+import Data.Array.Base              (unsafeAt) import GHC.TypeLits                 (KnownNat) import System.IO.Unsafe             (unsafePerformIO)----import Clash.Explicit.BlockRam.File (initMem)++import Clash.Annotations.Primitive (hasBlackBox)+import Clash.Explicit.BlockRam.File (initMem, memFile) import Clash.Promoted.Nat           (SNat (..), pow2SNat, snatToNum) import Clash.Sized.BitVector        (BitVector) import Clash.Explicit.Signal        (Clock, Enable, Signal, KnownDomain, delay)@@ -119,8 +129,9 @@ -- -- * See "Clash.Explicit.ROM.File#usingromfiles" for more information on how -- to instantiate a ROM with the contents of a data file.--- * See "Clash.Sized.Fixed#creatingdatafiles" for ideas on how to create your--- own data files.+-- * See 'memFile' for creating a data file with Clash.+-- * See "Clash.Sized.Fixed#creatingdatafiles" for more ideas on how to create+-- your own data files. romFilePow2   :: forall dom  n m    . (KnownNat m, KnownNat n, KnownDomain dom)@@ -181,7 +192,8 @@  -- | romFile primitive romFile#-  :: (KnownNat m, KnownDomain dom)+  :: forall m dom n+   . (KnownNat m, KnownDomain dom)   => Clock dom   -- ^ 'Clock' to synchronize to   -> Enable dom@@ -195,9 +207,20 @@   -> Signal dom (BitVector m)   -- ^ The value of the ROM at address @rd@ from the previous clock cycle romFile# clk en sz file rd =-  delay clk en (deepErrorX "First value of romFile is undefined") ((content !) <$> rd)+  delay clk en (deepErrorX "First value of romFile is undefined")+        (safeAt <$> rd)  where   mem     = unsafePerformIO (initMem file)   content = listArray (0,szI-1) mem   szI     = snatToNum sz++  safeAt :: Int -> BitVector m+  safeAt i =+    if (0 <= i) && (i < szI) then+      unsafeAt content i+    else+      deepErrorX ("romFile: address " ++ show i +++                  " not in range [0.." ++ show szI ++ ")")+  {-# INLINE safeAt #-} {-# NOINLINE romFile# #-}+{-# ANN romFile# hasBlackBox #-}

@@ -1,5 +1,5 @@ {-|-Copyright  :  (C) 2020, QBayLogic B.V.+Copyright  :  (C) 2020-2021, QBayLogic B.V. License    :  BSD2 (see the file LICENSE) Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> @@ -52,8 +52,6 @@ import           GHC.TypeLits (type (+), KnownNat)  {- $setup->>> :m -Clash.Prelude->>> :m -Clash.Prelude.Safe >>> import Clash.Explicit.Prelude -} @@ -92,13 +90,12 @@ -- topEntity --   :: Clock  System --   -> Reset  System---   -> Enable System --   -> Signal System Bit --   -> Signal System (BitVector 8)--- topEntity clk asyncRst ena key1 =---   withClockResetEnable clk rst ena leds+-- topEntity clk asyncRst key1 =+--   withClockResetEnable clk rst enableGen leds --  where---   rst   = 'resetSynchronizer' clk asyncRst ena+--   rst   = 'resetSynchronizer' clk asyncRst --   key1R = isRising 1 key1 --   leds  = mealy blinkerT (1, False, 0) key1R -- @@@ -115,9 +112,9 @@ --   -> Reset  System --   -> Signal System Bit --   -> Signal System (BitVector 8)--- topEntity clk rst ena key1 =+-- topEntity clk rst key1 = --     let  (pllOut,pllStable) = altpll (SSymbol @"altpll50") clk rst---          rstSync            = 'resetSynchronizer' pllOut (unsafeToHighPolarity pllStable) ena+--          rstSync            = 'resetSynchronizer' pllOut (unsafeToHighPolarity pllStable) --     in   exposeClockResetEnable leds pllOut rstSync enableGen --   where --     key1R  = isRising 1 key1@@ -163,10 +160,8 @@    . KnownDomain dom   => Clock dom   -> Reset dom-  -> Enable dom-  -- ^ Warning: this argument will be removed in future versions of Clash.   -> Reset dom-resetSynchronizer clk rst _ = rstOut+resetSynchronizer clk rst = rstOut  where   isActiveHigh = case resetPolarity @dom of { SActiveHigh -> True; _ -> False }   rstOut =@@ -290,4 +285,4 @@   rstA2 =     case (sameDomain @domA @domB) of       Just Refl -> rstA0-      Nothing   -> resetSynchronizer clkB rstA1 enableGen+      Nothing   -> resetSynchronizer clkB rstA1

@@ -209,7 +209,8 @@   , unsafeFromHighPolarity   , unsafeFromLowPolarity     -- * Basic circuit functions-  , enable+  , andEnable+  , enable -- DEPRECATED   , dflipflop   , delay   , delayMaybe@@ -235,6 +236,7 @@   , simulateB   , simulateWithReset   , simulateWithResetN+  , runUntil     -- ** lazy versions   , simulate_lazy   , simulateB_lazy@@ -278,15 +280,13 @@ import           Clash.Signal.Internal.Ambiguous   (knownVDomain, clockPeriod, activeEdge, resetKind, initBehavior, resetPolarity) import qualified Clash.Sized.Vector-import           Clash.XException               (NFDataX, deepErrorX, fromJustX)+import           Clash.XException+  (NFDataX, deepErrorX, fromJustX, seqX, ShowX(..))  {- $setup >>> :set -XDataKinds -XTypeApplications -XFlexibleInstances -XMultiParamTypeClasses -XTypeFamilies >>> :set -fno-warn-deprecations->>> :m -Clash.Prelude->>> :m -Clash.Prelude.Safe->>> :m -Clash.Explicit.Prelude.Safe->>> :m -Clash.Signal+>>> :m -Prelude >>> import Clash.Explicit.Prelude >>> import Clash.Promoted.Nat (SNat(..)) >>> import qualified Data.List as L@@ -499,14 +499,24 @@  -- | Merge enable signal with signal of bools by applying the boolean AND -- operation.-enable+andEnable   :: Enable dom   -> Signal dom Bool   -> Enable dom-enable e0 e1 =+andEnable e0 e1 =   toEnable (fromEnable e0 .&&. e1) {-# INLINE enable #-} +-- | Merge enable signal with signal of bools by applying the boolean AND+-- operation.+enable+  :: Enable dom+  -> Signal dom Bool+  -> Enable dom+enable = andEnable+{-# DEPRECATED enable+  "Use 'andEnable' instead. This function will be removed in Clash 1.8." #-}+ -- | Special version of 'delay' that doesn't take enable signals of any kind. -- Initial value will be undefined. dflipflop@@ -847,5 +857,89 @@   -> [a] sampleWithResetN nReset nSamples f =   take nSamples (sampleWithReset nReset f)++-- | Simulate a component until it matches a condition+--+-- It prints a message of the form+--+-- @+-- Signal sampled for N cycles until value X+-- @+--+-- __NB__: This function is not synthesizable+--+-- === __Example with test bench__+--+-- A common usage is with a test bench using+-- 'Clash.Explicit.Testbench.outputVerifier'.+--+-- __NB__: Since this uses 'Clash.Explicit.Testbench.assert', when using+-- @clashi@, read the note at "Clash.Explicit.Testbench#assert-clashi".+--+-- @+-- import Clash.Prelude+-- import Clash.Explicit.Testbench+--+-- topEntity+--   :: 'Signal' 'System' Int+--   -> 'Signal' 'System' Int+-- topEntity = id+--+-- testBench+--   :: 'Signal' 'System' Bool+-- testBench = done+--  where+--   testInput = 'Clash.Explicit.Testbench.stimuliGenerator' clk rst $('Clash.Sized.Vector.listToVecTH' [1 :: Int .. 10])+--   expectedOutput =+--     'Clash.Explicit.Testbench.outputVerifier'' clk rst $('Clash.Sized.Vector.listToVecTH' $ [1 :: Int .. 9] '<>' [42])+--   done = expectedOutput $ topEntity testInput+--   clk = 'Clash.Explicit.Testbench.tbSystemClockGen' (not \<$\> done)+--   rst = 'systemResetGen'+-- @+--+-- @+-- > runUntil id testBench+--+--+-- cycle(\<Clock: System\>): 10, outputVerifier+-- expected value: 42, not equal to actual value: 10+-- Signal sampled for 11 cycles until value True+-- @+--+-- When you need to verify multiple test benches, the following invocations come+-- in handy:+--+-- @+-- > 'mapM_' (runUntil id) [ testBenchA, testBenchB ]+-- @+--+-- or when the test benches are in different clock domains:+--+-- @+-- testBenchA :: Signal DomA Bool+-- testBenchB :: Signal DomB Bool+-- @+--+-- @+-- > 'sequence_' [ runUntil id testBenchA, runUntil id testBenchB ]+-- @+runUntil+  :: forall dom a+   . (KnownDomain dom, NFDataX a, ShowX a)+  => (a -> Bool)+  -- ^ Condition checking function, should return @True@ to finish run+  -> Signal dom a+  -- ^ 'Signal' we want to sample for the condition+  -> IO ()+runUntil check s =+  -- Ensure invocations of 'trace' are printed before the result message+  value `seqX`+  putStrLn msg+ where+  msg =   ("Signal sampled for " ++) . shows nSamples+        . (" cycles until value " ++) $ showX value+  (before, after) = break check $ sample s+  nSamples = length before+  value = head after  {-# RULES "sequenceAVecSignal" Clash.Sized.Vector.traverse# (\x -> x) = vecBundle# #-}

@@ -2,6 +2,7 @@ Copyright  :  (C) 2013-2016, University of Twente,                   2017     , Google Inc.                   2019     , Myrtle Software Ltd+                  2021     , LUMI GUIDE FIETSDETECTIE B.V. License    :  BSD2 (see the file LICENSE) Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com> -}@@ -13,10 +14,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ < 806-{-# LANGUAGE TypeInType #-}-#endif- {-# LANGUAGE Trustworthy #-}  {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}@@ -41,6 +38,7 @@     -- * Experimental   , unsafeFromSignal   , antiDelay+  , forward   ) where @@ -55,7 +53,7 @@ import Clash.Sized.Vector import Clash.Signal.Delayed.Internal   (DSignal(..), dfromList, dfromList_lazy, fromSignal, toSignal,-   unsafeFromSignal, antiDelay, feedback)+   unsafeFromSignal, antiDelay, feedback, forward)  import Clash.Explicit.Signal   (KnownDomain, Clock, Domain, Reset, Signal, Enable, register, delay, bundle, unbundle)@@ -65,8 +63,6 @@ {- $setup >>> :set -XDataKinds >>> :set -XTypeOperators->>> :m -Clash.Prelude->>> :m -Clash.Prelude.Safe >>> 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)

@@ -1,5 +1,6 @@ {-|-  Copyright   :  (C) 2019, Google Inc+  Copyright   :  (C) 2019, Google Inc.,+                     2022, QBayLogic B.V.   License     :  BSD2 (see the file LICENSE)   Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com> @@ -69,6 +70,7 @@ #else newtype SimIO a = SimIO {unSimIO :: IO a} #endif+{-# ANN unSimIO hasBlackBox #-}  instance Functor SimIO where   fmap = fmapSimIO#@@ -76,6 +78,7 @@ fmapSimIO# :: (a -> b) -> SimIO a -> SimIO b fmapSimIO# f (SimIO m) = SimIO (fmap f m) {-# NOINLINE fmapSimIO# #-}+{-# ANN fmapSimIO# hasBlackBox #-}  instance Applicative SimIO where   pure  = pureSimIO#@@ -84,10 +87,12 @@ pureSimIO# :: a -> SimIO a pureSimIO# a = SimIO (pure a) {-# NOINLINE pureSimIO# #-}+{-# ANN pureSimIO# hasBlackBox #-}  apSimIO# :: SimIO (a -> b) -> SimIO a -> SimIO b apSimIO# (SimIO f) (SimIO m) = SimIO (f <*> m) {-# NOINLINE apSimIO# #-}+{-# ANN apSimIO# hasBlackBox #-}  instance Monad SimIO where   return = pureSimIO#@@ -100,6 +105,7 @@ bindSimIO# (SimIO m) k = SimIO (m >>= (\x -> x `seqX` coerce k x)) #endif {-# NOINLINE bindSimIO# #-}+{-# ANN bindSimIO# hasBlackBox #-}  -- | Display a string on /stdout/ display

@@ -1,9 +1,10 @@ {-| Copyright   :  (C) 2015-2016, University of Twente,                    2016-2019, Myrtle Software Ltd,-                   2017     , Google Inc.+                   2017     , Google Inc.,+                   2021-2022, QBayLogic B.V. License     :  BSD2 (see the file LICENSE)-Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>  Synchronizer circuits for safe clock domain crossings -}@@ -15,6 +16,7 @@  {-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise       #-} {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver    #-}  {-# OPTIONS_HADDOCK show-extensions #-} @@ -26,25 +28,24 @@   ) where -import Control.Applicative         (liftA2) import Data.Bits                   (complement, shiftR, xor) import Data.Constraint             ((:-)(..), Dict (..)) import Data.Constraint.Nat         (leTrans) import Data.Maybe                  (isJust)-import GHC.TypeLits                (type (+), type (-), type (<=))+import GHC.TypeLits                (type (+), type (-), type (<=), type (^), KnownNat) -import Clash.Class.BitPack         (boolToBV)+import Clash.Class.BitPack         (boolToBV, unpack) import Clash.Class.Resize          (truncateB)-import Clash.Prelude.BitIndex      (slice)+import Clash.Class.BitPack.BitIndex (slice) import Clash.Explicit.Mealy        (mealyB)-import Clash.Explicit.RAM          (asyncRam)+import Clash.Explicit.BlockRam     (RamOp (..), trueDualPortBlockRam) import Clash.Explicit.Signal-  (Clock, Reset, Signal, Enable, register, unsafeSynchronizer)-import Clash.Promoted.Nat          (SNat (..), pow2SNat)+  (Clock, Reset, Signal, Enable, register, unsafeSynchronizer, fromEnable, (.&&.))+import Clash.Promoted.Nat          (SNat (..)) import Clash.Promoted.Nat.Literals (d0) import Clash.Signal                (mux, KnownDomain) import Clash.Sized.BitVector       (BitVector, (++#))-import Clash.XException            (NFDataX)+import Clash.XException            (NFDataX, fromJustX)  -- * Dual flip-flop synchronizer @@ -96,27 +97,63 @@ -- * Asynchronous FIFO synchronizer  fifoMem-  :: ( KnownDomain wdom-     , KnownDomain rdom )+  :: forall wdom rdom a addrSize+   . ( KnownDomain wdom+     , KnownDomain rdom+     , NFDataX a+     , KnownNat addrSize+     , 1 <= addrSize )   => Clock wdom   -> Clock rdom   -> Enable wdom-  -> SNat addrSize+  -> Enable rdom   -> Signal wdom Bool   -> Signal rdom (BitVector addrSize)-  -> Signal wdom (Maybe (BitVector addrSize, a))+  -> Signal wdom (BitVector addrSize)+  -> Signal wdom (Maybe a)   -> Signal rdom a-fifoMem wclk rclk en addrSize@SNat full raddr writeM =-  asyncRam-    wclk rclk en-    (pow2SNat addrSize)-    raddr-    (mux full (pure Nothing) writeM)+fifoMem wclk rclk wen ren full raddr waddr wdataM =+  fst $ trueDualPortBlockRam+    rclk wclk portA portB+ where+   portA :: Signal rdom (RamOp (2 ^ addrSize) a)+   portA = mux (fromEnable ren)+               (RamRead . unpack <$> raddr)+               (pure RamNoOp)+   portB :: Signal wdom (RamOp (2 ^ addrSize) a)+   portB = mux (fromEnable wen .&&. fmap not full .&&. fmap isJust wdataM)+               (RamWrite <$> fmap unpack waddr <*> fmap fromJustX wdataM)+               (pure RamNoOp) -ptrCompareT-  :: SNat addrSize-  -> (BitVector (addrSize + 1) -> BitVector (addrSize + 1) -> Bool)+readPtrCompareT+  :: KnownNat addrSize+  => ( BitVector (addrSize + 1)+     , BitVector (addrSize + 1)+     , Bool )   -> ( BitVector (addrSize + 1)+     , Bool )+  -> ( ( BitVector (addrSize + 1)+       , BitVector (addrSize + 1)+       , Bool )+     , ( Bool+       , BitVector addrSize+       , BitVector (addrSize + 1)+       )+     )+readPtrCompareT (bin, ptr, flag) (s_ptr, inc) =+  ((bin', ptr', flag'), (flag, addr, ptr))+ where+  -- GRAYSTYLE2 pointer+  bin' = bin + boolToBV (inc && not flag)+  ptr' = (bin' `shiftR` 1) `xor` bin'+  addr = truncateB bin'++  flag' = ptr' == s_ptr++writePtrCompareT+  :: (2 <= addrSize)+  => SNat addrSize+  -> ( BitVector (addrSize + 1)      , BitVector (addrSize + 1)      , Bool )   -> ( BitVector (addrSize + 1)@@ -129,7 +166,7 @@        , BitVector (addrSize + 1)        )      )-ptrCompareT SNat flagGen (bin, ptr, flag) (s_ptr, inc) =+writePtrCompareT addrSize@SNat (bin, ptr, flag) (s_ptr, inc) =   ((bin', ptr', flag'), (flag, addr, ptr))  where   -- GRAYSTYLE2 pointer@@ -137,9 +174,9 @@   ptr' = (bin' `shiftR` 1) `xor` bin'   addr = truncateB bin -  flag' = flagGen ptr' s_ptr+  flag' = isFull addrSize ptr' s_ptr --- FIFO full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1:0]}+-- FIFO full: when next pntr == synchronized {~wptr[addrSize:addrSize-1],wptr[addrSize-2:0]} isFull   :: forall addrSize    . (2 <= addrSize)@@ -154,15 +191,22 @@           a2 = SNat @(addrSize - 2)       in  ptr == (complement (slice addrSize a1 s_ptr) ++# slice a2 d0 s_ptr) --- | Synchronizer implemented as a FIFO around an asynchronous RAM. Based on the+-- | Synchronizer implemented as a FIFO around a synchronous RAM. Based on the -- design described in "Clash.Tutorial#multiclock", which is itself based on the -- design described in <http://www.sunburst-design.com/papers/CummingsSNUG2002SJ_FIFO1.pdf>.+-- However, this FIFO uses a synchronous dual-ported RAM which, unlike those+-- designs using RAM with an asynchronous read port, is nearly guaranteed to+-- actually synthesize into one of the dual-ported RAMs found on most FPGAs. -- -- __NB__: This synchronizer can be used for __word__-synchronization.+-- __NB__: This synchronizer will only work safely when you set up the proper+-- bus skew and maximum delay constraints inside your synthesis tool for the+-- clock domain crossings of the gray pointers. asyncFIFOSynchronizer   :: ( KnownDomain wdom      , KnownDomain rdom-     , 2 <= addrSize )+     , 2 <= addrSize+     , NFDataX a )   => SNat addrSize   -- ^ Size of the internally used addresses, the  FIFO contains @2^addrSize@   -- elements.@@ -188,20 +232,20 @@    rdata =     fifoMem-      wclk rclk wen-      addrSize wfull raddr-      (liftA2 (,) <$> (pure <$> waddr) <*> wdataM)+      wclk rclk wen ren+      wfull raddr+      waddr wdataM    (rempty, raddr, rptr) =     mealyB       rclk rrst ren-      (ptrCompareT addrSize (==))+      readPtrCompareT       (0, 0, True)       (s_wptr, rinc)    (wfull, waddr, wptr) =     mealyB       wclk wrst wen-      (ptrCompareT addrSize (isFull addrSize))+      (writePtrCompareT addrSize)       (0, 0, False)       (s_rptr, isJust <$> wdataM)

@@ -1,9 +1,10 @@ {-| Copyright  :  (C) 2013-2016, University of Twente,                   2017     , Google Inc.-                  2019     , Myrtle Software Ltd+                  2019     , Myrtle Software Ltd,+                  2021     , QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -}  {-# LANGUAGE TypeFamilies #-}@@ -31,27 +32,31 @@   , outputVerifierBitVector   , outputVerifierBitVector'   , biTbClockGen+  , unsafeSimSynchronizer+  , outputVerifierWith   ) where  import Control.Exception     (catch, evaluate) import Debug.Trace           (trace)-import GHC.TypeLits          (KnownNat, type (+))+import Data.Type.Equality    ((:~:)(..))+import Data.Proxy            (Proxy(..))+import GHC.TypeLits          (KnownNat, type (+), sameSymbol, type (<=)) import Prelude               hiding ((!!), length) import System.IO.Unsafe      (unsafeDupablePerformIO)  import Clash.Annotations.Primitive (hasBlackBox) import Clash.Class.Num       (satSucc, SaturationMode(SatBound))-import Clash.Promoted.Nat    (SNat(..), snatToNum)+import Clash.Promoted.Nat    (SNat(..)) import Clash.Promoted.Symbol (SSymbol (..)) import Clash.Explicit.Signal-  (Clock, Reset, System, Signal, clockPeriod, toEnable, fromList, register,-  unbundle, unsafeSynchronizer, veryUnsafeSynchronizer)+  (Clock, Reset, System, Signal, toEnable, fromList, register,+  unbundle, unsafeSynchronizer) import Clash.Signal.Internal (Clock (..), Reset (..)) import Clash.Signal          (mux, KnownDomain, Enable) import Clash.Sized.Index     (Index) import Clash.Sized.Internal.BitVector-  (BitVector, isLike)+  (BitVector, isLike#) import Clash.Sized.Vector    (Vec, (!!), length) import Clash.XException      (ShowX (..), XException) @@ -61,9 +66,6 @@  {- $setup >>> :set -XTemplateHaskell -XDataKinds -XTypeFamilies->>> :m -Clash.Prelude->>> :m -Clash.Prelude.Safe->>> :m -Clash.Prelude.Testbench >>> import Clash.Explicit.Prelude >>> let testInput clk rst = stimuliGenerator clk rst $(listToVecTH [(1::Int),3..21]) >>> let expectedOutput clk rst = outputVerifier' clk rst $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int]))@@ -74,7 +76,13 @@ -- function simply returns the third 'Signal' unaltered as its result. This -- function is used by 'outputVerifier'. --+-- === Usage in @clashi@ #assert-clashi# --+-- __NB__: When simulating a component that uses 'assert' in @clashi@, usually,+-- the warnings are only logged the first time the component is simulated.+-- Issuing @:reload@ in @clashi@ will discard the cached result of the+-- computation, and warnings will once again be emitted.+-- -- __NB__: This function /can/ be used in synthesizable designs. assert   :: (KnownDomain dom, Eq a, ShowX a)@@ -109,7 +117,7 @@ {-# NOINLINE assert #-} {-# ANN assert hasBlackBox #-} --- | The same as 'assert', but can handle don't care bits in it's expected value.+-- | The same as 'assert', but can handle don't care bits in its expected value. assertBitVector   :: (KnownDomain dom, KnownNat n)   => Clock dom@@ -138,7 +146,7 @@                             ]) r)   <$> checked <*> expected <*> fromList [(0::Integer)..] <*> returned   where-    eqX a b = unsafeDupablePerformIO (catch (evaluate (a `isLike` b))+    eqX a b = unsafeDupablePerformIO (catch (evaluate (a `isLike#` b))                                             (\(_ :: XException) -> return False)) {-# NOINLINE assertBitVector #-} {-# ANN assertBitVector hasBlackBox #-}@@ -185,18 +193,20 @@                 else s {-# INLINABLE stimuliGenerator #-} --- | Same as 'outputVerifier' but used in cases where the testbench domain and+-- | Same as 'outputVerifier' but used in cases where the test bench domain and -- the domain of the circuit under test are the same. outputVerifier'   :: forall l a dom    . ( KnownNat l      , KnownDomain dom      , Eq a-     , ShowX a )+     , ShowX a+     , 1 <= l+     )   => Clock dom-  -- ^ Clock to which the testbench is synchronized to+  -- ^ Clock to which the test bench is synchronized   -> Reset dom-  -- ^ Reset line of testbench+  -- ^ Reset line of test bench   -> Vec l a   -- ^ Samples to compare with   -> Signal dom a@@ -205,13 +215,18 @@   -- ^ Indicator that all samples are verified outputVerifier' =   outputVerifier @l @a @dom @dom-{-# INLINABLE outputVerifier' #-}+{-# INLINE outputVerifier' #-}  -- | Compare a signal (coming from a circuit) to a vector of samples. If a -- sample from the signal is not equal to the corresponding sample in the -- vector, print to stderr and continue testing. This function is--- synthesizable in the sense that HDL simulators will run it.+-- synthesizable in the sense that HDL simulators will run it. If @testDom@ and+-- @circuitDom@ refer to the same domain, it can also be synthesized into+-- hardware. --+-- __NB__: This function uses 'assert'. When simulating this function in+-- @clashi@, read the [note](#assert-clashi).+-- -- Example: -- -- @@@ -246,7 +261,7 @@ -- expected value: 10, not equal to actual value: 9 -- ,False,True] ----- If your working with 'BitVector's containing don't care bits you should+-- If you're working with 'BitVector's containing don't care bits you should -- use 'outputVerifierBitVector'. outputVerifier   :: forall l a testDom circuitDom@@ -254,51 +269,35 @@      , KnownDomain testDom      , KnownDomain circuitDom      , Eq a-     , ShowX a )+     , ShowX a+     , 1 <= l+     )   => Clock testDom-  -- ^ Clock to which the testbench is synchronized to (but not necessarily+  -- ^ Clock to which the test bench is synchronized (but not necessarily   -- the circuit under test)   -> Reset testDom-  -- ^ Reset line of testbench+  -- ^ Reset line of test bench   -> Vec l a   -- ^ Samples to compare with   -> Signal circuitDom a   -- ^ Signal to verify   -> Signal testDom Bool   -- ^ True if all samples are verified-outputVerifier clk rst samples i0 =-    let t1    = snatToNum (clockPeriod @circuitDom)-        t2    = snatToNum (clockPeriod @testDom)-        i1    = veryUnsafeSynchronizer t1 t2 i0-        en    = toEnable (pure True)-        (s,o) = unbundle (genT <$> register clk rst en 0 s)-        (e,f) = unbundle o-        f'    = register clk rst en False f-        -- Only assert while not finished-    in  mux f' f' $ assert clk rst "outputVerifier" i1 e f'-  where-    genT :: Index l -> (Index l,(a,Bool))-    genT s = (s',(samples !! s,finished))-      where-        maxI = toEnum (length samples - 1)--        s' = if s < maxI-                then s + 1-                else s--        finished = s == maxI-{-# INLINABLE outputVerifier #-}+outputVerifier =+  outputVerifierWith (\clk rst -> assert clk rst "outputVerifier")+{-# INLINE outputVerifier #-} --- | Same as 'outputVerifier'', but can handle don't care bits in it's expected+-- | Same as 'outputVerifier'', but can handle don't care bits in its expected -- values. outputVerifierBitVector'   :: forall l n dom    . ( KnownNat l      , KnownNat n      , KnownDomain dom+     , 1 <= l      )   => Clock dom-  -- ^ Clock to which the input signal is synchronized to+  -- ^ Clock to which the input signal is synchronized   -> Reset dom   -> Vec l (BitVector n)   -- ^ Samples to compare with@@ -308,9 +307,9 @@   -- ^ Indicator that all samples are verified outputVerifierBitVector' =   outputVerifierBitVector @l @n @dom @dom-{-# INLINABLE outputVerifierBitVector' #-}+{-# INLINE outputVerifierBitVector' #-} --- | Same as 'outputVerifier', but can handle don't care bits in it's+-- | Same as 'outputVerifier', but can handle don't care bits in its -- expected values. outputVerifierBitVector   :: forall l n testDom circuitDom@@ -318,38 +317,72 @@      , KnownNat n      , KnownDomain testDom      , KnownDomain circuitDom+     , 1 <= l      )   => Clock testDom-  -- ^ Clock to which the input signal is synchronized to+  -- ^ Clock to which the test bench is synchronized (but not necessarily+  -- the circuit under test)   -> Reset testDom+  -- ^ Reset line of test bench   -> Vec l (BitVector n)   -- ^ Samples to compare with   -> Signal circuitDom (BitVector n)   -- ^ Signal to verify   -> Signal testDom Bool   -- ^ Indicator that all samples are verified-outputVerifierBitVector clk rst samples i0 =-    let t1    = snatToNum (clockPeriod @circuitDom)-        t2    = snatToNum (clockPeriod @testDom)-        i1    = veryUnsafeSynchronizer t1 t2 i0+outputVerifierBitVector =+  outputVerifierWith+    (\clk rst -> assertBitVector clk rst "outputVerifierBitVector")+{-# INLINE outputVerifierBitVector #-}++outputVerifierWith+  :: forall l a testDom circuitDom+   . ( KnownNat l+     , KnownDomain testDom+     , KnownDomain circuitDom+     , Eq a+     , ShowX a+     , 1 <= l+     )+  => (    Clock testDom+       -> Reset testDom+       -> Signal testDom a+       -> Signal testDom a+       -> Signal testDom Bool+       -> Signal testDom Bool+      )+  -- ^ The @assert@ function to use+  -> Clock testDom+  -- ^ Clock to which the test bench is synchronized (but not necessarily+  -- the circuit under test)+  -> Reset testDom+  -- ^ Reset line of test bench+  -> Vec l a+  -- ^ Samples to compare with+  -> Signal circuitDom a+  -- ^ Signal to verify+  -> Signal testDom Bool+  -- ^ True if all samples are verified+outputVerifierWith assertF clk rst samples i0 =+    let i1    = sync i0         en    = toEnable (pure True)         (s,o) = unbundle (genT <$> register clk rst en 0 s)         (e,f) = unbundle o         f'    = register clk rst en False f         -- Only assert while not finished-    in  mux f' f' $ assertBitVector clk rst "outputVerifierBitVector'" i1 e f'+    in  mux f' f' $ assertF clk rst i1 e f'   where-    genT :: Index l -> (Index l,(BitVector n,Bool))+    genT :: Index l -> (Index l,(a,Bool))     genT s = (s',(samples !! s,finished))       where-        maxI = toEnum (length samples - 1)--        s' = if s < maxI-                then s + 1-                else s--        finished = s == maxI-{-# INLINABLE outputVerifierBitVector #-}+        s' = satSucc SatBound s+        finished = s == maxBound+    sync :: Signal circuitDom a+         -> Signal testDom a+    sync = case sameSymbol (Proxy @circuitDom) (Proxy @testDom) of+             Just Refl -> id+             Nothing   -> unsafeSimSynchronizer (Clock SSymbol) clk+{-# INLINABLE outputVerifierWith #-}  -- | Ignore signal for a number of cycles, while outputting a static value. ignoreFor@@ -374,9 +407,8 @@   counter = register clk rst en 0 (satSucc SatBound <$> counter)  -- | Same as 'tbClockGen', but returns two clocks on potentially different--- domains. To be used in situations where the circuit under test runs--- in a different domain than the circuit testing it. Most commonly used--- to test synchronous circuits (with an asynchronous test circuit).+-- domains. To be used in situations where the test circuit potentially operates+-- on a different clock than the device under test. biTbClockGen   :: forall testDom circuitDom    . ( KnownDomain testDom@@ -475,3 +507,24 @@   :: Signal System Bool   -> Clock System tbSystemClockGen = tbClockGen++-- | Cross clock domains in a way that is unsuitable for hardware but good+-- enough for simulation.+--+-- It's equal to 'unsafeSynchronizer' but will warn when used outside of a test+-- bench. 'outputVerifier' uses this function when it needs to cross between+-- clock domains, which will render it unsuitable for synthesis, but good enough+-- for simulating the generated HDL.+unsafeSimSynchronizer+  :: forall dom1 dom2 a+   . ( KnownDomain dom1+     , KnownDomain dom2 )+  => Clock dom1+  -- ^ 'Clock' of the incoming signal+  -> Clock dom2+  -- ^ 'Clock' of the outgoing signal+  -> Signal dom1 a+  -> Signal dom2 a+unsafeSimSynchronizer = unsafeSynchronizer+{-# NOINLINE unsafeSimSynchronizer #-}+{-# ANN unsafeSimSynchronizer hasBlackBox #-}

@@ -36,10 +36,12 @@   , timpliesOverlapping   , always   , never+  , eventually    -- * Asserts   , assert   , cover+  , assume    -- * Assertion checking   , check@@ -209,11 +211,16 @@ always = Assertion IsTemporal . CvAlways . assertion . toAssertionValue {-# INLINE always #-} --- | Specify assertion should _never_ hold+-- | Specify assertion should _never_ hold (not supported by SVA) never :: AssertionValue dom a => a -> Assertion dom never = Assertion IsTemporal . CvNever . assertion . toAssertionValue {-# INLINE never #-} +-- | Specify assertion should _eventually_ hold+eventually :: AssertionValue dom a => a -> Assertion dom+eventually = Assertion IsTemporal . CvEventually . assertion . toAssertionValue+{-# INLINE eventually #-}+ -- | Check whether given assertion always holds. Results can be collected with -- 'check'. assert :: AssertionValue dom a => a -> Property dom@@ -225,6 +232,13 @@ cover :: AssertionValue dom a => a -> Property dom cover = Property . CvCover . assertion . toAssertionValue {-# INLINE cover #-}++-- | Inform the prover that this property is true. This is the same as 'assert'+-- for simulations.+assume :: AssertionValue dom a => a -> Property dom+assume = Property . CvAssume . assertion . toAssertionValue+{-# INLINE assume #-}+  -- | Print property as PSL/SVA in HDL. Clash simulation support not yet -- implemented.

@@ -1,5 +1,6 @@ {-|   Copyright   :  (C) 2019, QBayLogic B.V.+                 (C) 2021, QBayLogic B.V.   License     :  BSD2 (see the file LICENSE)   Maintainer  :  QBayLogic B.V <devops@qbaylogic.com> @@ -16,11 +17,54 @@ {-# OPTIONS_HADDOCK show-extensions, not-home #-}  module Clash.HaskellPrelude-  (module Prelude)+  (module Prelude, (&&), (||), not) where  import Prelude hiding   ((++), (!!), concat, concatMap, drop, even, foldl, foldl1, foldr, foldr1, head, init,    iterate, last, length, map, odd, repeat, replicate, reverse, scanl, scanr, splitAt,    tail, take, unzip, unzip3, zip, zip3, zipWith, zipWith3, undefined, (^),-   getChar, putChar, getLine)+   getChar, putChar, getLine, (&&), (||), not)++import qualified Prelude+import GHC.Magic (noinline)++{-+Note [use of noinline]+~~~~~~~~~~~~~~~~~~~~~~+The magic noinline function is used here to prevent GHC inlining these+functions in the simplifier. They are removed (by GHC) post-simplifier, so+they have no negative impact on Clash's normalization.++Why prevent this inlining? When GHC sees a function like++    topEntity :: Bool -> Bool -> Bool+    topEntity a b = a && b++it inlines the definition of && to become++    topEntity a b =+      case a of+        True -> case b of+                  True -> True+                  False -> False+        False -> False++which Clash will render as multiplexer(s) instead of using the and operator+available in the targeted HDL backend. While this has no impact on the quality+of the final result (EDA tools will optimize this with ease in P&R), it makes+the generated HDL (and RTL view of circuits) more obfuscated to read.+-}++infixr 3 &&++(&&) :: Bool -> Bool -> Bool+(&&) = noinline (Prelude.&&)++infixr 2 ||++(||) :: Bool -> Bool -> Bool+(||) = noinline (Prelude.||)++not :: Bool -> Bool+not = noinline Prelude.not

@@ -1,8 +1,9 @@ {-| Copyright  :  (C) 2017-2018, Google Inc                   2019     , Myrtle Software+                  2022     , QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com>  PLL and other clock-related components for Intel (Altera) FPGAs -}@@ -14,6 +15,7 @@   , alteraPll   ) where +import Clash.Annotations.Primitive (hasBlackBox) import Clash.Clocks           (Clocks (..)) import Clash.Promoted.Symbol  (SSymbol) import Clash.Signal.Internal@@ -57,6 +59,7 @@   -- ^ (Stable PLL clock, PLL lock) altpll !_ = knownDomain @domIn `seq` knownDomain @domOut `seq` clocks {-# NOINLINE altpll #-}+{-# ANN altpll hasBlackBox #-}  -- | A clock source that corresponds to the Intel/Quartus \"Altera PLL\" -- component (Arria V, Stratix V, Cyclone V) with settings to provide a stable@@ -100,3 +103,4 @@   -> t alteraPll !_ = clocks {-# NOINLINE alteraPll #-}+{-# ANN alteraPll hasBlackBox #-}

@@ -0,0 +1,155 @@+{-+Copyright   : (C) 2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Clash.Num.Erroring+  ( Erroring(fromErroring)+  , toErroring+  ) where++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Bits (Bits, FiniteBits)+import Data.Coerce (coerce)+import Data.Functor.Compose (Compose(..))+import Data.Hashable (Hashable)+import GHC.TypeLits (KnownNat, type (+))++import Clash.Class.BitPack (BitPack)+import Clash.Class.Num (SaturationMode(SatError), SaturatingNum(..))+import Clash.Class.Parity (Parity)+import Clash.Class.Resize (Resize(..))+import Clash.XException (NFDataX, ShowX, errorX)++-- | An erroring number type is one where all operations return a+-- 'Clash.XException.XExecption' if they would go out of bounds for the+-- underlying type.+--+-- Numbers can be converted to error by default using 'toErroring'.+--+newtype Erroring a =+  Erroring { fromErroring :: a }+  deriving newtype+    ( Binary+    , Bits+    , BitPack+    , Bounded+    , Eq+    , FiniteBits+    , Hashable+    , NFData+    , NFDataX+    , Ord+    , Parity+    , Show+    , ShowX+    )++{-# INLINE toErroring #-}+toErroring :: (SaturatingNum a) => a -> Erroring a+toErroring = Erroring++instance (Resize f) => Resize (Compose Erroring f) where+  {-# INLINE resize #-}+  resize+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Erroring f a+    -> Compose Erroring f b+  resize = coerce (resize @f @a @b)++  {-# INLINE zeroExtend #-}+  zeroExtend+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Erroring f a+    -> Compose Erroring f (b + a)+  zeroExtend = coerce (zeroExtend @f @a @b)++  {-# INLINE truncateB #-}+  truncateB+    :: forall a b+     . (KnownNat a)+    => Compose Erroring f (a + b)+    -> Compose Erroring f a+  truncateB = coerce (truncateB @f @a @b)++instance (Bounded a, Ord a, SaturatingNum a) => Num (Erroring a) where+  {-# INLINE (+) #-}+  (+) = coerce (satAdd @a SatError)++  {-# INLINE (-) #-}+  (-) = coerce (satSub @a SatError)++  {-# INLINE (*) #-}+  (*) = coerce (satMul @a SatError)++  negate x+    | 0 == x = x+    | 0 <= minBound @a = errorX "Erroring.negate: result exceeds minBound"+    | x == minBound = errorX "Erroring.negate: result exceeds maxBound"+    | otherwise = coerce (negate @a) x++  abs x+    | x == minBound && x < 0 = errorX "Erroring.abs: result exceeds maxBound"+    | otherwise = coerce (abs @a) x++  {-# INLINE signum #-}+  signum = coerce (signum @a)++  {-# INLINE fromInteger #-}+  -- TODO This does what the underlying representation does if the Integer+  -- is not in range (typically wrapping). It would be better if this also+  -- threw an XException, but in a way which remained synthesizable.+  fromInteger = coerce (fromInteger @a)++instance (Enum a, SaturatingNum a) => Enum (Erroring a) where+  {-# INLINE succ #-}+  succ = coerce (satSucc @a SatError)++  {-# INLINE pred #-}+  pred = coerce (satPred @a SatError)++  {-# INLINE toEnum #-}+  toEnum = coerce (toEnum @a)++  {-# INLINE fromEnum #-}+  fromEnum = coerce (fromEnum @a)++instance (Real a, SaturatingNum a) => Real (Erroring a) where+  {-# INLINE toRational #-}+  toRational = coerce (toRational @a)++instance (Integral a, SaturatingNum a) => Integral (Erroring a) where+  quotRem x y+    | x == minBound && y < 0 && y == -1 =+        (errorX "Erroring.quotRem: result exceeds maxBound", 0)+    | otherwise = coerce (quotRem @a) x y++  divMod x y+    | x == minBound && y < 0 && y == -1 =+        (errorX "Erroring.divMod: result exceeds maxBound", 0)+    | otherwise = coerce (divMod @a) x y++  {-# INLINE toInteger #-}+  toInteger = coerce (toInteger @a)++instance (Fractional a, Ord a, SaturatingNum a) => Fractional (Erroring a) where+  {-# INLINE recip #-}+  recip = coerce (recip @a)++  {-# INLINE fromRational #-}+  -- TODO This does what the underlying representation does if the Rational+  -- is not in range (typically wrapping). It would be better if this also+  -- threw an XException, but in a way which remained synthesizable.+  fromRational = coerce (fromRational @a)++instance (RealFrac a, SaturatingNum a) => RealFrac (Erroring a) where+  {-# INLINE properFraction #-}+  properFraction :: forall b. (Integral b) => Erroring a -> (b, Erroring a)+  properFraction = coerce (properFraction @a @b)

@@ -0,0 +1,189 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Clash.Num.Overflowing+  ( Overflowing(fromOverflowing, hasOverflowed)+  , toOverflowing+  , clearOverflow+  ) where++import Prelude hiding (even, odd)++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Function (on)+import Data.Hashable (Hashable)+import GHC.Generics (Generic)+import GHC.TypeLits (KnownNat, type (+))++import Clash.Class.BitPack (BitPack(..))+import Clash.Class.Num (SaturationMode(SatWrap, SatZero), SaturatingNum(..))+import Clash.Class.Parity (Parity(..))+import Clash.XException (NFDataX, ShowX)++-- | An overflowing number behaves similarly to a 'Clash.Num.Wrapping.Wrapping'+-- number, but also includes an overflow status flag which can be used to more+-- easily check if an overflow has occurred.+--+-- Numbers can be converted to be 'Overflowing' using 'toOverflowing'.+--+data Overflowing a = Overflowing+  { fromOverflowing :: a+  , hasOverflowed :: Bool+  }+  deriving stock (Generic, Show)+  deriving anyclass (Binary, Hashable, NFData, NFDataX, ShowX)++{-# INLINE toOverflowing #-}+toOverflowing :: a -> Overflowing a+toOverflowing x = Overflowing x False++{-# INLINE clearOverflow #-}+-- | Reset the overflow status flag to False.+clearOverflow :: Overflowing a -> Overflowing a+clearOverflow x = x { hasOverflowed = False }++instance (Eq a) => Eq (Overflowing a) where+  {-# INLINE (==) #-}+  (==) = (==) `on` fromOverflowing++instance (Ord a) => Ord (Overflowing a) where+  {-# INLINE compare #-}+  compare = compare `on` fromOverflowing++instance (BitPack a, KnownNat (BitSize a + 1)) => BitPack (Overflowing a) where+  type BitSize (Overflowing a) = BitSize a + 1+  -- Default instance, no explicit implementations.++instance (Parity a) => Parity (Overflowing a) where+  {-# INLINE even #-}+  even = even . fromOverflowing++  {-# INLINE odd #-}+  odd = odd . fromOverflowing++instance (Bounded a, Ord a, SaturatingNum a) => Num (Overflowing a) where+  Overflowing x a + Overflowing y b+    | y > 0+    , x > satSub SatWrap maxBound y+    = withOverflow True++    | y < 0+    , x < satSub SatWrap minBound y+    = withOverflow True++    | otherwise+    = withOverflow (a || b)+   where+    withOverflow = Overflowing (satAdd SatWrap x y)++  Overflowing x a - Overflowing y b+    | y < 0+    , x > satAdd SatWrap maxBound y+    = withOverflow True++    | y > 0+    , x < satAdd SatWrap minBound y+    = withOverflow True++    | otherwise+    = withOverflow (a || b)+   where+    withOverflow = Overflowing (satSub SatWrap x y)++  Overflowing x a * Overflowing y b+    | x /= 0+    , y /= 0+    , satMul SatZero x y == 0+    = withOverflow True++    | otherwise+    = withOverflow (a || b)+   where+    withOverflow = Overflowing (satMul SatWrap x y)++  negate n@(Overflowing x a)+    | 0 == x = n+    | 0 <= minBound @a = withOverflow True+    | x == minBound = withOverflow True+    | otherwise = withOverflow a+   where+    withOverflow = Overflowing (negate x)++  abs (Overflowing x a)+    | x == minBound && x < 0 = Overflowing x True+    | otherwise = Overflowing (abs x) a++  signum (Overflowing x a) =+    Overflowing (signum x) a++  -- TODO This does what the underlying representation does if the Integer+  -- is not in range (typically wrapping). It would be better if this also+  -- definitely wrapped, but in a way which remained synthesizable.+  fromInteger i =+    Overflowing (fromInteger i) False++instance (Bounded a) => Bounded (Overflowing a) where+  minBound = Overflowing minBound False+  maxBound = Overflowing maxBound False++instance (Enum a, Eq a, SaturatingNum a) => Enum (Overflowing a) where+  succ (Overflowing x a)+    | x == maxBound = withOverflow True+    | otherwise = withOverflow a+   where+    withOverflow = Overflowing (satSucc SatWrap x)++  pred (Overflowing x a)+    | x == minBound = withOverflow True+    | otherwise = withOverflow a+   where+    withOverflow = Overflowing (satPred SatWrap x)++  toEnum i = Overflowing (toEnum i) False+  fromEnum = fromEnum . fromOverflowing++instance (Real a, SaturatingNum a) => Real (Overflowing a) where+  toRational = toRational . fromOverflowing++instance (Integral a, SaturatingNum a) => Integral (Overflowing a) where+  quotRem (Overflowing x a) (Overflowing y b)+    | x == minBound && y < 0 && y == -1 =+        withOverflow True++    | otherwise =+        withOverflow (a || b)+   where+    withOverflow o =+      let (q, r) = quotRem x y+       in (Overflowing q o, Overflowing r False)++  divMod (Overflowing x a) (Overflowing y b)+    | x == minBound && y < 0 && y == -1 =+        withOverflow True++    | otherwise =+        withOverflow (a || b)+   where+    withOverflow o =+      let (d, m) = divMod x y+       in (Overflowing d o, Overflowing m False)++  toInteger = toInteger . fromOverflowing++instance (Fractional a, Ord a, SaturatingNum a) => Fractional (Overflowing a) where+  recip x =+    x { fromOverflowing = recip (fromOverflowing x) }++  -- TODO This does what the underlying representation does if the Rational+  -- is not in range (typically wrapping). It would be better if this also+  -- definitely wrapped, but in a way which remained synthesizable.+  fromRational i =+    Overflowing (fromRational i) False++instance (RealFrac a, SaturatingNum a) => RealFrac (Overflowing a) where+  properFraction (Overflowing x _) =+    let (n, f) = properFraction x+     in (n, Overflowing f False)

@@ -0,0 +1,154 @@+{-+Copyright   : (C) 2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Clash.Num.Saturating+  ( Saturating(fromSaturating)+  , toSaturating+  ) where++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Bits (Bits, FiniteBits)+import Data.Coerce (coerce)+import Data.Functor.Compose (Compose(..))+import Data.Hashable (Hashable)+import GHC.TypeLits (KnownNat, type (+))++import Clash.Class.BitPack (BitPack)+import Clash.Class.Num (SaturationMode(SatBound), SaturatingNum(..))+import Clash.Class.Parity (Parity)+import Clash.Class.Resize (Resize(..))+import Clash.XException (NFDataX, ShowX)++-- | A saturating number type is one where all operations saturate at the+-- bounds of the underlying type, i.e. operations which overflow return+-- 'maxBound' and operations that underflow return 'minBound'.+--+-- Numbers can be converted to saturate by default using 'toSaturating'.+--+newtype Saturating a =+  Saturating { fromSaturating :: a }+  deriving newtype+    ( Binary+    , Bits+    , BitPack+    , Bounded+    , Eq+    , FiniteBits+    , Hashable+    , NFData+    , NFDataX+    , Ord+    , Parity+    , Show+    , ShowX+    )++{-# INLINE toSaturating #-}+toSaturating :: (SaturatingNum a) => a -> Saturating a+toSaturating = Saturating++instance (Resize f) => Resize (Compose Saturating f) where+  {-# INLINE resize #-}+  resize+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Saturating f a+    -> Compose Saturating f b+  resize = coerce (resize @f @a @b)++  {-# INLINE zeroExtend #-}+  zeroExtend+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Saturating f a+    -> Compose Saturating f (b + a)+  zeroExtend = coerce (zeroExtend @f @a @b)++  {-# INLINE truncateB #-}+  truncateB+    :: forall a b+     . (KnownNat a)+    => Compose Saturating f (a + b)+    -> Compose Saturating f a+  truncateB = coerce (truncateB @f @a @b)++instance (Ord a, SaturatingNum a) => Num (Saturating a) where+  {-# INLINE (+) #-}+  (+) = coerce (satAdd @a SatBound)++  {-# INLINE (-) #-}+  (-) = coerce (satSub @a SatBound)++  {-# INLINE (*) #-}+  (*) = coerce (satMul @a SatBound)++  negate x+    | 0 <= minBound @a = 0+    | x == minBound = maxBound+    | otherwise = coerce (negate @a) x++  abs x+    | x == minBound && x < 0 = maxBound+    | otherwise = coerce (abs @a) x++  {-# INLINE signum #-}+  signum = coerce (signum @a)++  {-# INLINE fromInteger #-}+  -- TODO This does what the underlying representation does if the Integer+  -- is not in range (typically wrapping). It would be better if this also+  -- saturated, but in a way which remained synthesizable.+  fromInteger = coerce (fromInteger @a)++instance (Enum a, SaturatingNum a) => Enum (Saturating a) where+  {-# INLINE succ #-}+  -- Deliberately breaks the Enum law that succ maxBound ~> error+  succ = coerce (satSucc @a SatBound)++  {-# INLINE pred #-}+  -- Deliberately breaks the Enum law that pred minBound ~> error+  pred = coerce (satPred @a SatBound)++  {-# INLINE toEnum #-}+  toEnum = coerce (toEnum @a)++  {-# INLINE fromEnum #-}+  fromEnum = coerce (fromEnum @a)++instance (Real a, SaturatingNum a) => Real (Saturating a) where+  {-# INLINE toRational #-}+  toRational = coerce (toRational @a)++instance (Integral a, SaturatingNum a) => Integral (Saturating a) where+  quotRem x y+    | x == minBound && y < 0 && y == -1 = (maxBound, 0)+    | otherwise = coerce (quotRem @a) x y++  divMod x y+    | x == minBound && y < 0 && y == -1 = (maxBound, 0)+    | otherwise = coerce (divMod @a) x y++  {-# INLINE toInteger #-}+  toInteger = coerce (toInteger @a)++instance (Fractional a, Ord a, SaturatingNum a) => Fractional (Saturating a) where+  {-# INLINE recip #-}+  recip = coerce (recip @a)++  {-# INLINE fromRational #-}+  -- TODO This does what the underlying representation does if the Rational+  -- is not in range (typically wrapping). It would be better if this also+  -- saturated, but in a way which remained synthesizable.+  fromRational = coerce (fromRational @a)++instance (Ord a, RealFrac a, SaturatingNum a) => RealFrac (Saturating a) where+  {-# INLINE properFraction #-}+  properFraction :: forall b. (Integral b) => Saturating a -> (b, Saturating a)+  properFraction = coerce (properFraction @a @b)

@@ -0,0 +1,151 @@+{-+Copyright   : (C) 2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Clash.Num.Wrapping+  ( Wrapping(fromWrapping)+  , toWrapping+  ) where++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Bits (Bits, FiniteBits)+import Data.Coerce (coerce)+import Data.Functor.Compose (Compose(..))+import Data.Hashable (Hashable)+import GHC.TypeLits (KnownNat, type (+))++import Clash.Class.BitPack (BitPack)+import Clash.Class.Num (SaturationMode(SatWrap), SaturatingNum(..))+import Clash.Class.Parity (Parity)+import Clash.Class.Resize (Resize(..))+import Clash.XException (NFDataX, ShowX)++-- | A wrapping number type is one where all operations wrap between minBound+-- and maxBound (and vice-versa) if the result goes out of bounds for the+-- underlying type.+--+-- Numbers can be converted to wrap by default using 'toWrapping'.+--+newtype Wrapping a =+  Wrapping { fromWrapping :: a }+  deriving newtype+    ( Binary+    , Bits+    , BitPack+    , Bounded+    , Eq+    , FiniteBits+    , Hashable+    , NFData+    , NFDataX+    , Ord+    , Parity+    , Show+    , ShowX+    )++{-# INLINE toWrapping #-}+toWrapping :: (SaturatingNum a) => a -> Wrapping a+toWrapping = Wrapping++instance (Resize f) => Resize (Compose Wrapping f) where+  {-# INLINE resize #-}+  resize+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Wrapping f a+    -> Compose Wrapping f b+  resize = coerce (resize @f @a @b)++  {-# INLINE zeroExtend #-}+  zeroExtend+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Wrapping f a+    -> Compose Wrapping f (b + a)+  zeroExtend = coerce (zeroExtend @f @a @b)++  {-# INLINE truncateB #-}+  truncateB+    :: forall a b+     . (KnownNat a)+    => Compose Wrapping f (a + b)+    -> Compose Wrapping f a+  truncateB = coerce (truncateB @f @a @b)++instance (SaturatingNum a) => Num (Wrapping a) where+  {-# INLINE (+) #-}+  (+) = coerce (satAdd @a SatWrap)++  {-# INLINE (-) #-}+  (-) = coerce (satSub @a SatWrap)++  {-# INLINE (*) #-}+  (*) = coerce (satMul @a SatWrap)++  -- Assume the default behaviour is to wrap anyway.++  {-# INLINE negate #-}+  negate = coerce (negate @a)++  {-# INLINE abs #-}+  abs = coerce (abs @a)++  {-# INLINE signum #-}+  signum = coerce (signum @a)++  {-# INLINE fromInteger #-}+  -- TODO This does what the underlying representation does if the Integer+  -- is not in range (typically wrapping). It would be better if this also+  -- definitely wrapped, but in a way which remained synthesizable.+  fromInteger = coerce (fromInteger @a)++instance (Enum a, SaturatingNum a) => Enum (Wrapping a) where+  {-# INLINE succ #-}+  -- Deliberately breaks the Enum law that succ maxBound ~> error+  succ = coerce (satSucc @a SatWrap)++  {-# INLINE pred #-}+  -- Deliberately breaks the Enum law that pred minBound ~> error+  pred = coerce (satPred @a SatWrap)++  {-# INLINE toEnum #-}+  toEnum = coerce (toEnum @a)++  {-# INLINE fromEnum #-}+  fromEnum = coerce (fromEnum @a)++instance (Real a, SaturatingNum a) => Real (Wrapping a) where+  {-# INLINE toRational #-}+  toRational = coerce (toRational @a)++instance (Integral a, SaturatingNum a) => Integral (Wrapping a) where+  {-# INLINE quotRem #-}+  quotRem = coerce (quotRem @a)++  {-# INLINE divMod #-}+  divMod = coerce (divMod @a)++  {-# INLINE toInteger #-}+  toInteger = coerce (toInteger @a)++instance (Fractional a, SaturatingNum a) => Fractional (Wrapping a) where+  {-# INLINE recip #-}+  recip = coerce (recip @a)++  {-# INLINE fromRational #-}+  -- TODO This does what the underlying representation does if the Rational+  -- is not in range (typically wrapping). It would be better if this also+  -- definitely wrapped, but in a way which remained synthesizable.+  fromRational = coerce (fromRational @a)++instance (RealFrac a, SaturatingNum a) => RealFrac (Wrapping a) where+  {-# INLINE properFraction #-}+  properFraction :: forall b. (Integral b) => Wrapping a -> (b, Wrapping a)+  properFraction = coerce (properFraction @a @b)

@@ -0,0 +1,153 @@+{-+Copyright   : (C) 2021, QBayLogic B.V.+License     : BSD2 (see the file LICENSE)+Maintainer  : QBayLogic B.V. <devops@qbaylogic.com>+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Clash.Num.Zeroing+  ( Zeroing(fromZeroing)+  , toZeroing+  ) where++import Control.DeepSeq (NFData)+import Data.Binary (Binary)+import Data.Bits (Bits, FiniteBits)+import Data.Coerce (coerce)+import Data.Functor.Compose (Compose(..))+import Data.Hashable (Hashable)+import GHC.TypeLits (KnownNat, type (+))++import Clash.Class.BitPack (BitPack)+import Clash.Class.Num (SaturationMode(SatZero), SaturatingNum(..))+import Clash.Class.Parity (Parity)+import Clash.Class.Resize (Resize(..))+import Clash.XException (NFDataX, ShowX)++-- | A zeroing number type is one where all operations return zero if they go+-- out of bounds for the underlying type.+--+-- Numbers can be converted to zero by default using `toZeroing`.+--+newtype Zeroing a =+  Zeroing { fromZeroing :: a }+  deriving newtype+    ( Binary+    , Bits+    , BitPack+    , Bounded+    , Eq+    , FiniteBits+    , Hashable+    , NFData+    , NFDataX+    , Ord+    , Parity+    , Show+    , ShowX+    )++{-# INLINE toZeroing #-}+toZeroing :: (SaturatingNum a) => a -> Zeroing a+toZeroing = Zeroing++instance (Resize f) => Resize (Compose Zeroing f) where+  {-# INLINE resize #-}+  resize+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Zeroing f a+    -> Compose Zeroing f b+  resize = coerce (resize @f @a @b)++  {-# INLINE zeroExtend #-}+  zeroExtend+    :: forall a b+     . (KnownNat a, KnownNat b)+    => Compose Zeroing f a+    -> Compose Zeroing f (b + a)+  zeroExtend = coerce (zeroExtend @f @a @b)++  {-# INLINE truncateB #-}+  truncateB+    :: forall a b+     . (KnownNat a)+    => Compose Zeroing f (a + b)+    -> Compose Zeroing f a+  truncateB = coerce (truncateB @f @a @b)++instance (Bounded a, Ord a, SaturatingNum a) => Num (Zeroing a) where+  {-# INLINE (+) #-}+  (+) = coerce (satAdd @a SatZero)++  {-# INLINE (-) #-}+  (-) = coerce (satSub @a SatZero)++  {-# INLINE (*) #-}+  (*) = coerce (satMul @a SatZero)++  negate x+    | 0 <= minBound @a = 0+    | x == minBound = 0+    | otherwise = coerce (negate @a) x++  abs x+    | x == minBound && x < 0 = 0+    | otherwise = coerce (abs @a) x++  {-# INLINE signum #-}+  signum = coerce (signum @a)++  {-# INLINE fromInteger #-}+  -- TODO This does what the underlying representation does if the Integer+  -- is not in range (typically wrapping). It would be better if this also+  -- returned zero, but in a way which remained synthesizable.+  fromInteger = coerce (fromInteger @a)++instance (Enum a, SaturatingNum a) => Enum (Zeroing a) where+  {-# INLINE succ #-}+  -- Deliberately breaks the Enum law that succ maxBound ~> error+  succ = coerce (satSucc @a SatZero)++  {-# INLINE pred #-}+  -- Deliberately breaks the Enum law that pred minBound ~> error+  pred = coerce (satPred @a SatZero)++  {-# INLINE toEnum #-}+  toEnum = coerce (toEnum @a)++  {-# INLINE fromEnum #-}+  fromEnum = coerce (fromEnum @a)++instance (Real a, SaturatingNum a) => Real (Zeroing a) where+  {-# INLINE toRational #-}+  toRational = coerce (toRational @a)++instance (Integral a, SaturatingNum a) => Integral (Zeroing a) where+  quotRem x y+    | x == minBound && y < 0 && y == -1 = (0, 0)+    | otherwise = coerce (quotRem @a) x y++  divMod x y+    | x == minBound && y < 0 && y == -1 = (0, 0)+    | otherwise = coerce (divMod @a) x y++  {-# INLINE toInteger #-}+  toInteger = coerce (toInteger @a)++instance (Fractional a, Ord a, SaturatingNum a) => Fractional (Zeroing a) where+  {-# INLINE recip #-}+  recip = coerce (recip @a)++  {-# INLINE fromRational #-}+  -- TODO This does what the underlying representation does if the Rational+  -- is not in range (typically wrapping). It would be better if this also+  -- returned zero, but in a way which remained synthesizable.+  fromRational = coerce (fromRational @a)++instance (RealFrac a, SaturatingNum a) => RealFrac (Zeroing a) where+  {-# INLINE properFraction #-}+  properFraction :: forall b. (Integral b) => Zeroing a -> (b, Zeroing a)+  properFraction = coerce (properFraction @a @b)

@@ -1,9 +1,10 @@ {-|   Copyright   :  (C) 2013-2016, University of Twente,                      2017-2019, Myrtle Software Ltd-                     2017     , Google Inc.+                     2017     , Google Inc.,+                     2021-2022, QBayLogic B.V.   License     :  BSD2 (see the file LICENSE)-  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>+  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>    Clash is a functional hardware description language that borrows both its   syntax and semantics from the functional programming language Haskell. The@@ -59,7 +60,12 @@   , asyncRomPow2   , rom   , romPow2-    -- ** ROMs initialized with a data file+    -- ** ROMs defined by a 'MemBlob'+  , asyncRomBlob+  , asyncRomBlobPow2+  , romBlob+  , romBlobPow2+    -- ** ROMs defined by a data file   , asyncRomFile   , asyncRomFilePow2   , romFile@@ -73,11 +79,22 @@   , blockRamU   , blockRam1   , E.ResetStrategy(..)+    -- ** BlockRAM primitives initialized with a 'MemBlob'+  , blockRamBlob+  , blockRamBlobPow2+    -- *** Creating and inspecting 'MemBlob'+  , MemBlob+  , createMemBlob+  , memBlobTH+  , unpackMemBlob     -- ** BlockRAM primitives initialized with a data file   , blockRamFile   , blockRamFilePow2     -- ** BlockRAM read/write conflict resolution   , readNew+    -- ** True dual-port block RAM+  , trueDualPortBlockRam+  , RamOp(..)     -- * Utility functions   , window   , windowD@@ -101,8 +118,6 @@     -- ** Datatypes     -- *** Bit vectors   , module Clash.Sized.BitVector-  , module Clash.Prelude.BitIndex-  , module Clash.Prelude.BitReduction     -- *** Arbitrary-width numbers   , module Clash.Sized.Signed   , module Clash.Sized.Unsigned@@ -167,7 +182,7 @@  import           Clash.Annotations.TopEntity import           Clash.Class.AutoReg         (AutoReg, deriveAutoReg)-import           Clash.Class.BitPack hiding  (GBitPack(..))+import           Clash.Class.BitPack import           Clash.Class.Exp import           Clash.Class.Num import           Clash.Class.Parity@@ -176,10 +191,10 @@ import           Clash.Hidden import           Clash.Magic import           Clash.NamedTypes-import           Clash.Prelude.BitIndex-import           Clash.Prelude.BitReduction import           Clash.Prelude.BlockRam+import           Clash.Prelude.BlockRam.Blob import           Clash.Prelude.BlockRam.File+import           Clash.Prelude.ROM.Blob import           Clash.Prelude.ROM.File import           Clash.Prelude.Safe #ifdef CLASH_MULTIPLE_HIDDEN@@ -224,7 +239,7 @@ -- > window4 = window -- -- >>> simulateB @System window4 [1::Int,2,3,4,5] :: [Vec 4 Int]--- [<1,0,0,0>,<2,1,0,0>,<3,2,1,0>,<4,3,2,1>,<5,4,3,2>...+-- [1 :> 0 :> 0 :> 0 :> Nil,2 :> 1 :> 0 :> 0 :> Nil,3 :> 2 :> 1 :> 0 :> Nil,4 :> 3 :> 2 :> 1 :> Nil,5 :> 4 :> 3 :> 2 :> Nil,... -- ... window   :: ( HiddenClockResetEnable dom@@ -247,7 +262,7 @@ -- > windowD3 = windowD -- -- >>> simulateB @System windowD3 [1::Int,2,3,4] :: [Vec 3 Int]--- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>...+-- [0 :> 0 :> 0 :> Nil,1 :> 0 :> 0 :> Nil,2 :> 1 :> 0 :> Nil,3 :> 2 :> 1 :> Nil,4 :> 3 :> 2 :> Nil,... -- ... windowD   :: ( HiddenClockResetEnable dom

@@ -1,148 +1,18 @@ {-| Copyright  :  (C) 2013-2016, University of Twente+                  2021,      QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module Clash.Prelude.BitIndex where--import GHC.TypeLits                   (KnownNat, type (+), type (-))--import Clash.Class.BitPack            (BitPack (..))-import Clash.Promoted.Nat             (SNat (..))-import Clash.Sized.Internal.BitVector (BitVector, Bit, index#, lsb#, msb#,-                                       replaceBit#, setSlice#, slice#, split#)--{- $setup->>> :set -XDataKinds->>> import Clash.Prelude+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# INLINE (!) #-}--- | Get the bit at the specified bit index.------ __NB:__ Bit indices are __DESCENDING__.------ >>> pack (7 :: Unsigned 6)--- 00_0111--- >>> (7 :: Unsigned 6) ! 1--- 1--- >>> (7 :: Unsigned 6) ! 5--- 0--- >>> (7 :: Unsigned 6) ! 6--- *** Exception: (!): 6 is out of range [5..0]--- ...-(!) :: (BitPack a, Enum i) => a -> i -> Bit-(!) v i = index# (pack v) (fromEnum i)--{-# INLINE slice #-}--- | Get a slice between bit index @m@ and and bit index @n@.------ __NB:__ Bit indices are __DESCENDING__.------ >>> pack (7 :: Unsigned 6)--- 00_0111--- >>> slice d4 d2 (7 :: Unsigned 6)--- 001--- >>> slice d6 d4 (7 :: Unsigned 6)--- <BLANKLINE>--- <interactive>:...---     • Couldn't match type ‘7 + i0’ with ‘6’---         arising from a use of ‘slice’---       The type variable ‘i0’ is ambiguous---     • In the expression: slice d6 d4 (7 :: Unsigned 6)---       In an equation for ‘it’: it = slice d6 d4 (7 :: Unsigned 6)-slice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => SNat m -> SNat n -> a-      -> BitVector (m + 1 - n)-slice m n v = slice# (pack v) m n--{-# INLINE split #-}--- | Split a value of a bit size @m + n@ into a tuple of values with size @m@--- and size @n@.------ >>> pack (7 :: Unsigned 6)--- 00_0111--- >>> split (7 :: Unsigned 6) :: (BitVector 2, BitVector 4)--- (00,0111)-split :: (BitPack a, BitSize a ~ (m + n), KnownNat n) => a-      -> (BitVector m, BitVector n)-split v = split# (pack v)--{-# INLINE replaceBit #-}--- | Set the bit at the specified index------ __NB:__ Bit indices are __DESCENDING__.------ >>> pack (-5 :: Signed 6)--- 11_1011--- >>> replaceBit 4 0 (-5 :: Signed 6)--- -21--- >>> pack (-21 :: Signed 6)--- 10_1011--- >>> replaceBit 5 0 (-5 :: Signed 6)--- 27--- >>> pack (27 :: Signed 6)--- 01_1011--- >>> replaceBit 6 0 (-5 :: Signed 6)--- *** Exception: replaceBit: 6 is out of range [5..0]--- ...-replaceBit :: (BitPack a, Enum i) => i -> Bit -> a -> a-replaceBit i b v = unpack (replaceBit# (pack v) (fromEnum i) b)--{-# INLINE setSlice #-}--- | Set the bits between bit index @m@ and bit index @n@.------ __NB:__ Bit indices are __DESCENDING__.------ >>> pack (-5 :: Signed 6)--- 11_1011--- >>> setSlice d4 d3 0 (-5 :: Signed 6)--- -29--- >>> pack (-29 :: Signed 6)--- 10_0011--- >>> setSlice d6 d5 0 (-5 :: Signed 6)--- <BLANKLINE>--- <interactive>:...---     • Couldn't match type ‘7 + i0’ with ‘6’---         arising from a use of ‘setSlice’---       The type variable ‘i0’ is ambiguous---     • In the expression: setSlice d6 d5 0 (- 5 :: Signed 6)---       In an equation for ‘it’: it = setSlice d6 d5 0 (- 5 :: Signed 6)-setSlice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => SNat m -> SNat n-         -> BitVector (m + 1 - n) -> a -> a-setSlice m n w v = unpack (setSlice# SNat (pack v) m n w)--{-# INLINE msb #-}--- | Get the most significant bit.------ >>> pack (-4 :: Signed 6)--- 11_1100--- >>> msb (-4 :: Signed 6)--- 1--- >>> pack (4 :: Signed 6)--- 00_0100--- >>> msb (4 :: Signed 6)--- 0-msb :: BitPack a => a -> Bit-msb v = msb# (pack v)+module Clash.Prelude.BitIndex {-# DEPRECATED "Use Clash.Class.BitPack instead. This module will be removed in Clash 1.8." #-}+  ( (!)+  , slice+  , split+  , replaceBit+  , setSlice+  , msb+  , lsb+  ) where -{-# INLINE lsb #-}--- | Get the least significant bit.------ >>> pack (-9 :: Signed 6)--- 11_0111--- >>> lsb (-9 :: Signed 6)--- 1--- >>> pack (-8 :: Signed 6)--- 11_1000--- >>> lsb (-8 :: Signed 6)--- 0-lsb :: BitPack a => a -> Bit-lsb v = lsb# (pack v)+import Clash.Class.BitPack.BitIndex

@@ -1,82 +1,13 @@ {-| Copyright  :  (C) 2013-2016, University of Twente+                  2021,      QBayLogic B.V. License    :  BSD2 (see the file LICENSE)-Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE FlexibleContexts #-}--{-# LANGUAGE Trustworthy #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module Clash.Prelude.BitReduction where--import Clash.Class.BitPack            (BitPack (..))-import Clash.Sized.Internal.BitVector (Bit, reduceAnd#, reduceOr#, reduceXor#)--{- $setup->>> :set -XDataKinds->>> import Clash.Prelude+Maintainer :  QBayLogic B.V. <devops@qbaylogic.com> -} -{-# INLINE reduceAnd #-}--- | Are all bits set to '1'?------ >>> pack (-2 :: Signed 6)--- 11_1110--- >>> reduceAnd (-2 :: Signed 6)--- 0--- >>> pack (-1 :: Signed 6)--- 11_1111--- >>> reduceAnd (-1 :: Signed 6)--- 1------ Zero width types will evaluate to '1':------ >>> reduceAnd (0 :: Unsigned 0)--- 1-reduceAnd :: BitPack a => a -> Bit-reduceAnd v = reduceAnd# (pack v)--{-# INLINE reduceOr #-}--- | Is there at least one bit set to '1'?------ >>> pack (5 :: Signed 6)--- 00_0101--- >>> reduceOr (5 :: Signed 6)--- 1--- >>> pack (0 :: Signed 6)--- 00_0000--- >>> reduceOr (0 :: Signed 6)--- 0------ Zero width types will evaluate to '0':------ >>> reduceOr (0 :: Unsigned 0)--- 0-reduceOr :: BitPack a => a -> Bit-reduceOr v = reduceOr# (pack v)+module Clash.Prelude.BitReduction {-# DEPRECATED "Use Clash.Class.BitPack instead. This module will be removed in Clash 1.8." #-}+  ( reduceAnd+  , reduceOr+  , reduceXor ) where -{-# INLINE reduceXor #-}--- | Is the number of bits set to '1' uneven?------ >>> pack (5 :: Signed 6)--- 00_0101--- >>> reduceXor (5 :: Signed 6)--- 0--- >>> pack (28 :: Signed 6)--- 01_1100--- >>> reduceXor (28 :: Signed 6)--- 1--- >>> pack (-5 :: Signed 6)--- 11_1011--- >>> reduceXor (-5 :: Signed 6)--- 1------ Zero width types will evaluate to '0':------ >>> reduceXor (0 :: Unsigned 0)--- 0-reduceXor :: BitPack a => a -> Bit-reduceXor v = reduceXor# (pack v)+import Clash.Class.BitPack.BitReduction