clash-prelude 0.10.14 → 0.11
raw patch · 52 files changed
+3831/−1560 lines, 52 filesdep +clash-preludedep +constraintsdep +criteriondep −th-liftdep ~basedep ~deepseqdep ~ghc-typelits-extra
Dependencies added: clash-prelude, constraints, criterion, data-binary-ieee754, ghc-typelits-knownnat
Dependencies removed: th-lift
Dependency ranges changed: base, deepseq, ghc-typelits-extra, ghc-typelits-natnormalise
Files
- CHANGELOG.md +18/−8
- LICENSE +2/−1
- README.md +4/−5
- benchmarks/BenchBitVector.hs +125/−0
- benchmarks/BenchFixed.hs +55/−0
- benchmarks/BenchSigned.hs +94/−0
- benchmarks/benchmark-main.hs +51/−0
- clash-prelude.cabal +52/−22
- src/CLaSH/Annotations/TopEntity.hs +2/−2
- src/CLaSH/Class/BitPack.hs +95/−3
- src/CLaSH/Class/Resize.hs +9/−8
- src/CLaSH/Examples.hs +7/−7
- src/CLaSH/NamedTypes.hs +65/−0
- src/CLaSH/Prelude.hs +12/−15
- src/CLaSH/Prelude/BitIndex.hs +12/−12
- src/CLaSH/Prelude/BlockRam.hs +359/−84
- src/CLaSH/Prelude/BlockRam/File.hs +46/−39
- src/CLaSH/Prelude/DataFlow.hs +80/−98
- src/CLaSH/Prelude/Explicit.hs +14/−12
- src/CLaSH/Prelude/Explicit/Safe.hs +5/−2
- src/CLaSH/Prelude/Mealy.hs +4/−2
- src/CLaSH/Prelude/Moore.hs +29/−1
- src/CLaSH/Prelude/RAM.hs +45/−35
- src/CLaSH/Prelude/ROM.hs +16/−14
- src/CLaSH/Prelude/ROM/File.hs +17/−15
- src/CLaSH/Prelude/Safe.hs +15/−9
- src/CLaSH/Prelude/Synchronizer.hs +70/−48
- src/CLaSH/Prelude/Testbench.hs +30/−30
- src/CLaSH/Promoted/Nat.hs +346/−38
- src/CLaSH/Promoted/Nat/Literals.hs +4/−4
- src/CLaSH/Promoted/Nat/TH.hs +5/−5
- src/CLaSH/Promoted/Nat/Unsafe.hs +2/−2
- src/CLaSH/Promoted/Ord.hs +0/−29
- src/CLaSH/Promoted/Symbol.hs +10/−9
- src/CLaSH/Signal.hs +33/−56
- src/CLaSH/Signal/Bundle.hs +88/−81
- src/CLaSH/Signal/Delayed.hs +5/−7
- src/CLaSH/Signal/Delayed/Explicit.hs +22/−24
- src/CLaSH/Signal/Explicit.hs +14/−45
- src/CLaSH/Signal/Internal.hs +97/−138
- src/CLaSH/Sized/Fixed.hs +142/−74
- src/CLaSH/Sized/Index.hs +6/−6
- src/CLaSH/Sized/Internal/BitVector.hs +125/−87
- src/CLaSH/Sized/Internal/Index.hs +66/−14
- src/CLaSH/Sized/Internal/Index.hs-boot +2/−1
- src/CLaSH/Sized/Internal/Signed.hs +146/−103
- src/CLaSH/Sized/Internal/Unsigned.hs +80/−57
- src/CLaSH/Sized/RTree.hs +460/−20
- src/CLaSH/Sized/Vector.hs +296/−126
- src/CLaSH/Sized/Vector.hs-boot +4/−2
- src/CLaSH/Tutorial.hs +225/−160
- src/CLaSH/XException.hs +320/−0
CHANGELOG.md view
@@ -1,14 +1,24 @@ # Changelog for [`clash-prelude` package](http://hackage.haskell.org/package/clash-prelude) -## 0.10.14 *August 21st 2016*-* Build against ghc-typelits-extra-0.2--## 0.10.13 *August 18th 2016*+## 0.11 *January 16th 2017* * New features:- * Thanks to Joe Hermaszewski (@expipiplus1): Add an explicitly clocked `DSignal`- * Add a `Real` instance for `Fixed` [#158](https://github.com/clash-lang/clash-compiler/issues/158)-* Fixes bugs:- * {BitVector;Index;Signed;Unsigned} `enumFromTo` and friends overflowed on values outside `Int` range [#166](https://github.com/clash-lang/clash-compiler/issues/166)+ * `CLaSH.XException`: a module defining an exception representing uninitialised values. Additionally adds the `ShowX` class which has methods that print values as "X" where they would normally raise an `XException` exception.+ * Add `BNat` (and supporting functions) to `CLaSH.Promoted.Nat`: base-2 encoded natural numbers.+ * Add `divSNat` and `logBaseSNat` to `CLaSH.Promoted.Nat`: division and logarithm for singleton natural numbers.+ * Add `predUNat` and `subUNat` to `CLaSH.Promoted.Nat`: predecessor and subtraction for unary-encoded natural numbers.+ * Add `dtfold` to `CLaSH.Sized.Vector`: a dependently-typed tree-fold over `Vec`.+ * Add the perfect-depth binary trees module `CLaSH.Sized.RTree`+ * Synthesisable definitions of `countLeadingZeros` and `countTrailingZeros` for: `BitVector`, `Signed`, `Unsigned`, and `Fixed`+ * Add the `(:::)` type alias in `CLaSH.NamedTypes` which allows you to annotate types with documentation+* Changes:+ * `asyncRam`, `blockRam`, `blockRamFile` have a `Maybe (addr,a)` as write input instead of three separate `Bool`, `addr`, and `a` inputs.+ * `asyncFIFOSynchronizer` has a `Maybe a` as write-request instead of a separate `Bool` and `a` input+ * `bundle'` and `unbundle'` are removed; `bundle` now has type `Unbundled' clk a -> Signal' clk a`, `unbundle` now has type `Signal' clk a -> Unbundled' clk a`+ * `subSNat` now has the type `SNat (a+b) -> SNat b -> SNat a` (where it used to be `SNat a -> SNat b -> SNat (a-b)`)+ * Renamed `multUNat` to `mulUNat` to be in sync with `mulSNat` and `mulBNat`.+ * The function argument of `vfold` in `CLaSH.Sized.Vector` is now `(forall l . SNat l -> a -> Vec l b -> Vec (l + 1) b)` (where it used to be `(forall l . a -> Vec l b -> Vec (l + 1) b)`)+ * `Cons` constructor of `Vec` is no longer visible; `(:>)` and `(:<)` are now listed as constructors of `Vec`+ * Simulation speed improvements for numeric types ## 0.10.12 * Fixes bugs:
LICENSE view
@@ -1,4 +1,5 @@-Copyright (c) 2013-2016, University of Twente+Copyright (c) 2013-2016, University of Twente,+ 2017, QBayLogic All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,11 +1,11 @@ # CλaSH - A functional hardware description language -[](https://travis-ci.org/clash-lang/clash-prelude?branch=0.10)+[](https://travis-ci.org/clash-lang/clash-prelude) [](https://hackage.haskell.org/package/clash-prelude) [](http://packdeps.haskellers.com/feed?needle=exact%3Aclash-prelude) __WARNING__-Only works with GHC-7.10.* (http://www.haskell.org/ghc/download_ghc_7_10_3)!+Only works with GHC-8.0.* (http://www.haskell.org/ghc/download_ghc_8_0_2)! CλaSH (pronounced ‘clash’) is a functional hardware description language that borrows both its syntax and semantics from the functional programming language@@ -14,9 +14,8 @@ Features of CλaSH: - * Strongly typed (like VHDL), yet with a very high degree of type inference,- enabling both safe and fast prototying using consise descriptions (like- Verilog).+ * Strongly typed, yet with a very high degree of type inference, enabling both+ safe and fast prototyping using concise descriptions. * Interactive REPL: load your designs in an interpreter and easily test all your component without needing to setup a test bench.
+ benchmarks/BenchBitVector.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-}++{-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-}++#define WORD_SIZE_IN_BITS 64++module BenchBitVector where++import CLaSH.Sized.Internal.BitVector+import CLaSH.Class.Num+import GHC.TypeLits (type (*))+import Criterion (Benchmark, env, bench, nf)+import Language.Haskell.TH.Syntax (lift)++smallValue1 :: BitVector WORD_SIZE_IN_BITS+smallValue1 = $(lift (2^(16::Int)-10 :: BitVector WORD_SIZE_IN_BITS))+{-# INLINE smallValue1 #-}++smallValue2 :: BitVector WORD_SIZE_IN_BITS+smallValue2 = $(lift (2^(16::Int)-100 :: BitVector WORD_SIZE_IN_BITS))+{-# INLINE smallValue2 #-}++largeValue1 :: BitVector (3*WORD_SIZE_IN_BITS)+largeValue1 = 2^(2*WORD_SIZE_IN_BITS :: Int)-10 :: BitVector (3*WORD_SIZE_IN_BITS)+{-# INLINE largeValue1 #-}++largeValue2 :: BitVector (3*WORD_SIZE_IN_BITS)+largeValue2 = 2^(2*WORD_SIZE_IN_BITS :: Int)-100 :: BitVector (3*WORD_SIZE_IN_BITS)+{-# INLINE largeValue2 #-}++addBench :: Benchmark+addBench = env setup $ \m ->+ bench "+# WORD_SIZE_IN_BITS" $ nf (uncurry (+#)) m+ where+ setup = return (smallValue1,smallValue2)++negateBench :: Benchmark+negateBench = env setup $ \m ->+ bench "negate# WORD_SIZE_IN_BITS" $ nf negate# m+ where+ setup = return smallValue1++subBench :: Benchmark+subBench = env setup $ \m ->+ bench "-# WORD_SIZE_IN_BITS" $ nf (uncurry (-#)) m+ where+ setup = return (smallValue1,smallValue2)++multBench :: Benchmark+multBench = env setup $ \m ->+ bench "*# WORD_SIZE_IN_BITS" $ nf (uncurry (*#)) m+ where+ setup = return (smallValue1,smallValue2)++plusBench :: Benchmark+plusBench = env setup $ \m ->+ bench "plus# WORD_SIZE_IN_BITS" $ nf (uncurry (plus#)) m+ where+ setup = return (smallValue1,smallValue2)++minusBench :: Benchmark+minusBench = env setup $ \m ->+ bench "minus# WORD_SIZE_IN_BITS" $ nf (uncurry (minus#)) m+ where+ setup = return (smallValue1,smallValue2)++timesBench :: Benchmark+timesBench = env setup $ \m ->+ bench "times# WORD_SIZE_IN_BITS" $ nf (uncurry (times#)) m+ where+ setup = return (smallValue1,smallValue2)++boundedPlusBench :: Benchmark+boundedPlusBench = env setup $ \m ->+ bench "boundedPlus WORD_SIZE_IN_BITS" $ nf (uncurry (boundedPlus)) m+ where+ setup = return (smallValue1,smallValue2)++boundedMinBench :: Benchmark+boundedMinBench = env setup $ \m ->+ bench "boundedMin WORD_SIZE_IN_BITS" $ nf (uncurry (boundedMin)) m+ where+ setup = return (smallValue1,smallValue2)++boundedMultBench :: Benchmark+boundedMultBench = env setup $ \m ->+ bench "boundedMult WORD_SIZE_IN_BITS" $ nf (uncurry (boundedMult)) m+ where+ setup = return (smallValue1,smallValue2)++msbBench :: Benchmark+msbBench = env setup $ \m ->+ bench "msb# WORD_SIZE_IN_BITS" $ nf msb# m+ where+ setup = return smallValue1++msbBenchL :: Benchmark+msbBenchL = env setup $ \m ->+ bench "msb# (3*WORD_SIZE_IN_BITS)" $ nf msb# m+ where+ setup = return largeValue1++appendBench :: Benchmark+appendBench = env setup $ \m ->+ bench "++# WORD_SIZE_IN_BITS" $ nf (uncurry (++#)) m+ where+ setup = return (smallValue1,smallValue2)++appendBenchL :: Benchmark+appendBenchL = env setup $ \m ->+ bench "++# (3*WORD_SIZE_IN_BITS)" $ nf (uncurry (++#)) m+ where+ setup = return (largeValue1,largeValue2)++splitBench :: Benchmark+splitBench = env setup $ \m ->+ bench "split# WORD_SIZE_IN_BITS" $ nf (split# :: BitVector WORD_SIZE_IN_BITS -> (BitVector 18, BitVector 46)) m+ where+ setup = return smallValue1++splitBenchL :: Benchmark+splitBenchL = env setup $ \m ->+ bench "split# (3*WORD_SIZE_IN_BITS)" $ nf (split# :: BitVector (3*WORD_SIZE_IN_BITS) -> (BitVector 18, BitVector 174)) m+ where+ setup = return largeValue1
+ benchmarks/BenchFixed.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-}++{-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-}++#define WORD_SIZE_IN_BITS 64++module BenchFixed where++import CLaSH.Class.Num+import CLaSH.Sized.Fixed+import CLaSH.Sized.Unsigned+import Criterion (Benchmark, env, bench, nf)+import Language.Haskell.TH.Syntax (lift)++smallValueR_pos :: Rational+smallValueR_pos = $(lift (5126.889117 :: Rational))+{-# INLINE smallValueR_pos #-}++smallValueU1 :: UFixed 24 17+smallValueU1 = $(lift (5126.889117 :: UFixed 24 17))+{-# INLINE smallValueU1 #-}++smallValueU2 :: UFixed 24 17+smallValueU2 = $(lift (56.589117 :: UFixed 24 17))+{-# INLINE smallValueU2 #-}++fromRationalBench :: Benchmark+fromRationalBench = env setup $ \m ->+ bench "fromRational" $ nf (fromRational :: Rational -> UFixed 24 17) m+ where+ setup = return smallValueR_pos++addBench :: Benchmark+addBench = env setup $ \m ->+ bench "+" $ nf (uncurry (+)) m+ where+ setup = return (smallValueU1,smallValueU2)++subBench :: Benchmark+subBench = env setup $ \m ->+ bench "-" $ nf (uncurry (-)) m+ where+ setup = return (smallValueU1,smallValueU2)++multBench :: Benchmark+multBench = env setup $ \m ->+ bench "*" $ nf (uncurry (*)) m+ where+ setup = return (smallValueU1,smallValueU2)++multBench_wrap :: Benchmark+multBench_wrap = env setup $ \m ->+ bench "satMult SatWrap" $ nf (uncurry (satMult SatWrap)) m+ where+ setup = return (smallValueU1,smallValueU2)
+ benchmarks/BenchSigned.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-}++{-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-}++#define WORD_SIZE_IN_BITS 64++module BenchSigned where++import CLaSH.Sized.BitVector+import CLaSH.Sized.Internal.Signed+import Criterion (Benchmark, env, bench, nf)+import Language.Haskell.TH.Syntax (lift)++smallValueI_pos :: Integer+smallValueI_pos = $(lift (2^(16::Int)-10 :: Integer))+{-# INLINE smallValueI_pos #-}++smallValue_pos1 :: Signed WORD_SIZE_IN_BITS+smallValue_pos1 = $(lift (2^(16::Int)-100 :: Signed WORD_SIZE_IN_BITS))+{-# INLINE smallValue_pos1 #-}++smallValue_pos2 :: Signed WORD_SIZE_IN_BITS+smallValue_pos2 = $(lift (2^(16::Int)-100 :: Signed WORD_SIZE_IN_BITS))+{-# INLINE smallValue_pos2 #-}++smallValueBV :: BitVector WORD_SIZE_IN_BITS+smallValueBV = $(lift (2^(16::Int)-10 :: BitVector WORD_SIZE_IN_BITS))+{-# INLINE smallValueBV #-}++addBench :: Benchmark+addBench = env setup $ \m ->+ bench "+# WORD_SIZE_IN_BITS" $ nf (uncurry (+#)) m+ where+ setup = return (smallValue_pos1,smallValue_pos2)++negateBench :: Benchmark+negateBench = env setup $ \m ->+ bench "negate# WORD_SIZE_IN_BITS" $ nf negate# m+ where+ setup = return smallValue_pos1++absBench :: Benchmark+absBench = env setup $ \m ->+ bench "abs# WORD_SIZE_IN_BITS" $ nf abs# m+ where+ setup = return smallValue_pos1++subBench :: Benchmark+subBench = env setup $ \m ->+ bench "-# WORD_SIZE_IN_BITS" $ nf (uncurry (-#)) m+ where+ setup = return (smallValue_pos1,smallValue_pos2)++multBench :: Benchmark+multBench = env setup $ \m ->+ bench "*# WORD_SIZE_IN_BITS" $ nf (uncurry (*#)) m+ where+ setup = return (smallValue_pos1,smallValue_pos2)++plusBench :: Benchmark+plusBench = env setup $ \m ->+ bench "plus# WORD_SIZE_IN_BITS" $ nf (uncurry (plus#)) m+ where+ setup = return (smallValue_pos1,smallValue_pos2)++minusBench :: Benchmark+minusBench = env setup $ \m ->+ bench "minus# WORD_SIZE_IN_BITS" $ nf (uncurry (minus#)) m+ where+ setup = return (smallValue_pos1,smallValue_pos2)++timesBench :: Benchmark+timesBench = env setup $ \m ->+ bench "times# WORD_SIZE_IN_BITS" $ nf (uncurry (times#)) m+ where+ setup = return (smallValue_pos1,smallValue_pos2)++fromIntegerBench :: Benchmark+fromIntegerBench = env setup $ \m ->+ bench "fromInteger# WORD_SIZE_IN_BITS" $ nf (fromInteger# :: Integer -> Signed WORD_SIZE_IN_BITS) m+ where+ setup = return smallValueI_pos++packBench :: Benchmark+packBench = env setup $ \m ->+ bench "pack# WORD_SIZE_IN_BITS" $ nf pack# m+ where+ setup = return smallValue_pos1++unpackBench :: Benchmark+unpackBench = env setup $ \m ->+ bench "unpack# WORD_SIZE_IN_BITS" $ nf unpack# m+ where+ setup = return smallValueBV
+ benchmarks/benchmark-main.hs view
@@ -0,0 +1,51 @@+module Main where++import Criterion.Main++import qualified BenchBitVector as BV+import qualified BenchFixed as F+import qualified BenchSigned as S++main :: IO ()+main =+ defaultMain+ [+ bgroup "BitVector"+ [ BV.addBench+ , BV.negateBench+ , BV.subBench+ , BV.multBench+ , BV.plusBench+ , BV.minusBench+ , BV.timesBench+ , BV.boundedPlusBench+ , BV.boundedMinBench+ , BV.boundedMultBench+ , BV.msbBench+ , BV.msbBenchL+ , BV.appendBench+ , BV.appendBenchL+ , BV.splitBench+ , BV.splitBenchL+ ]+ , bgroup "Signed"+ [ S.fromIntegerBench+ , S.addBench+ , S.negateBench+ , S.absBench+ , S.subBench+ , S.multBench+ , S.plusBench+ , S.minusBench+ , S.timesBench+ , S.packBench+ , S.unpackBench+ ]+ , bgroup "Fixed"+ [ F.fromRationalBench+ , F.addBench+ , F.subBench+ , F.multBench+ , F.multBench_wrap+ ]+ ]
clash-prelude.cabal view
@@ -1,5 +1,5 @@ Name: clash-prelude-Version: 0.10.14+Version: 0.11 Synopsis: CAES Language for Synchronous Hardware - Prelude library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that@@ -9,9 +9,8 @@ . Features of CλaSH: .- * Strongly typed (like VHDL), yet with a very high degree of type inference,- enabling both safe and fast prototying using consise descriptions (like- Verilog).+ * Strongly typed, but with a very high degree of type inference, enabling both+ safe and fast prototyping using concise descriptions. . * Interactive REPL: load your designs in an interpreter and easily test all your component without needing to setup a test bench.@@ -45,7 +44,8 @@ License-file: LICENSE Author: Christiaan Baaij Maintainer: Christiaan Baaij <christiaan.baaij@gmail.com>-Copyright: Copyright © 2013-2016 University of Twente+Copyright: Copyright © 2013-2016, University of Twente,+ 2017, QBayLogic Category: Hardware Build-type: Simple @@ -67,6 +67,12 @@ default: True manual: True +flag benchmarks+ description:+ You can disable testing with benchmarks using `-f-benchmarks`.+ default: True+ manual: True+ flag doclinks description: Create hyperlinks to non-dependent packages using `-fdoclinks`.@@ -85,6 +91,8 @@ CLaSH.Class.Num CLaSH.Class.Resize + CLaSH.NamedTypes+ CLaSH.Prelude CLaSH.Prelude.BitIndex CLaSH.Prelude.BitReduction@@ -106,7 +114,6 @@ CLaSH.Promoted.Nat.Literals CLaSH.Promoted.Nat.TH CLaSH.Promoted.Nat.Unsafe- CLaSH.Promoted.Ord CLaSH.Promoted.Symbol CLaSH.Signal@@ -129,54 +136,56 @@ CLaSH.Sized.Internal.Signed CLaSH.Sized.Internal.Unsigned + CLaSH.XException+ CLaSH.Tutorial CLaSH.Examples - other-extensions: BangPatterns- DataKinds+ other-extensions: CPP+ BangPatterns ConstraintKinds+ DataKinds DefaultSignatures- DeriveTraversable DeriveDataTypeable+ DeriveTraversable+ DeriveLift FlexibleContexts+ FlexibleInstances GADTs GeneralizedNewtypeDeriving+ InstanceSigs KindSignatures MagicHash MultiParamTypeClasses+ PatternSynonyms Rank2Types ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections+ TypeApplications TypeFamilies TypeOperators UndecidableInstances+ ViewPatterns Build-depends: array >= 0.5.1.0 && < 0.6, base >= 4.8.0.0 && < 5,+ constraints >= 0.8 && < 1.0,+ data-binary-ieee754 >= 0.4.4 && < 0.6, data-default >= 0.5.3 && < 0.8, integer-gmp >= 0.5.1.0 && < 1.1, deepseq >= 1.4.1.0 && < 1.5, ghc-prim >= 0.3.1.0 && < 0.6,- ghc-typelits-extra >= 0.1 && < 0.3,- ghc-typelits-natnormalise >= 0.4.1 && < 0.6,- lens >= 4.9 && < 4.15,+ ghc-typelits-extra >= 0.2.1 && < 0.3,+ ghc-typelits-knownnat >= 0.2.2 && < 0.3,+ ghc-typelits-natnormalise >= 0.4.2 && < 0.6,+ lens >= 4.9 && < 4.16, QuickCheck >= 2.7 && < 2.10, reflection >= 2 && < 2.2, singletons >= 1.0 && < 3.0, template-haskell >= 2.9.0.0 && < 2.12 - if impl(ghc<7.11)- -- Newer GHCs have -XDeriveLift- Build-depends: th-lift >= 0.5.6- -- Newer GHCs have a -fno-cpr-anal dynflag which we can enable per module- -- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c- -- as to why we need this.- ghc-options: -fcpr-off- else- other-extensions: DeriveLift- if flag(doclinks) CPP-Options: -DDOCLINKS build-depends: transformers >= 0.4.2.0@@ -194,3 +203,24 @@ build-depends: base >= 4 && < 5, doctest >= 0.9.1 && < 0.12++benchmark benchmark-clash-prelude+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ main-is: benchmark-main.hs+ ghc-options: -O2 -Wall+ hs-source-dirs: benchmarks++ if !flag(benchmarks)+ buildable: False+ else+ build-depends:+ base >= 4 && < 5,+ clash-prelude,+ criterion >= 1.1.1.0 && < 1.2,+ deepseq >= 1.4.0.1 && < 1.5,+ template-haskell >= 2.9.0.0 && < 2.12++ Other-Modules: BenchBitVector+ BenchFixed+ BenchSigned
src/CLaSH/Annotations/TopEntity.hs view
@@ -215,7 +215,7 @@ -- * __SystemVerilog__: @logic [n-1:0]@ , t_clocks :: [ClockSource] -- ^ List of clock sources }- deriving (Data,Show)+ deriving (Data,Show,Read) -- | A clock source data ClockSource@@ -259,7 +259,7 @@ -- When 'c_sync' is set to 'True' those reset synchronisers are not generated -- and there is change for reset-induced metastability. }- deriving (Data,Show)+ deriving (Data,Show,Read) -- | Default 'TopEntity' which has no clocks, and no specified names for the -- input and output ports. Also has no clock sources:
src/CLaSH/Class/BitPack.hs view
@@ -4,8 +4,8 @@ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}@@ -14,8 +14,11 @@ {-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} +#include "MachDeps.h"+ module CLaSH.Class.BitPack ( BitPack (..) , bitCoerce@@ -23,12 +26,16 @@ ) where +import Data.Binary.IEEE754 (doubleToWord, floatToWord, wordToDouble,+ wordToFloat)+import Data.Int+import Data.Word import GHC.TypeLits (KnownNat, Nat, type (+)) import Prelude hiding (map) import CLaSH.Class.Resize (zeroExtend) import CLaSH.Sized.BitVector (BitVector, (++#), high, low)-import CLaSH.Sized.Internal.BitVector (split#)+import CLaSH.Sized.Internal.BitVector (unsafeToInteger, split#) {- $setup >>> :set -XDataKinds@@ -82,6 +89,91 @@ pack v = v unpack v = v +instance BitPack Int where+ type BitSize Int = WORD_SIZE_IN_BITS+ pack = fromIntegral+ unpack = fromIntegral++instance BitPack Int8 where+ type BitSize Int8 = 8+ pack = fromIntegral+ unpack = fromIntegral++instance BitPack Int16 where+ type BitSize Int16 = 16+ pack = fromIntegral+ unpack = fromIntegral++instance BitPack Int32 where+ type BitSize Int32 = 32+ pack = fromIntegral+ unpack = fromIntegral++#if WORD_SIZE_IN_BITS >= 64+instance BitPack Int64 where+ type BitSize Int64 = 64+ pack = fromIntegral+ unpack = fromIntegral+#endif++instance BitPack Word where+ type BitSize Word = WORD_SIZE_IN_BITS+ pack = fromIntegral+ unpack = fromIntegral++instance BitPack Word8 where+ type BitSize Word8 = 8+ pack = fromIntegral+ unpack = fromIntegral++instance BitPack Word16 where+ type BitSize Word16 = 16+ pack = fromIntegral+ unpack = fromIntegral++instance BitPack Word32 where+ type BitSize Word32 = 32+ pack = fromIntegral+ unpack = fromIntegral++#if WORD_SIZE_IN_BITS >= 64+instance BitPack Word64 where+ type BitSize Word64 = 64+ pack = fromIntegral+ unpack = fromIntegral+#endif++instance BitPack Float where+ type BitSize Float = 32+ pack = packFloat#+ unpack = unpackFloat#++packFloat# :: Float -> BitVector 32+packFloat# = fromIntegral . floatToWord+{-# NOINLINE packFloat# #-}++unpackFloat# :: BitVector 32 -> Float+unpackFloat# = wordToFloat . fromInteger . unsafeToInteger+{-# NOINLINE unpackFloat# #-}++instance BitPack Double where+ type BitSize Double = 64+ pack = packDouble#+ unpack = unpackDouble#++packDouble# :: Double -> BitVector 64+packDouble# = fromIntegral . doubleToWord+{-# NOINLINE packDouble# #-}++unpackDouble# :: BitVector 64 -> Double+unpackDouble# = wordToDouble . fromInteger . unsafeToInteger+{-# NOINLINE unpackDouble# #-}++instance BitPack () where+ type BitSize () = 0+ pack _ = minBound+ unpack _ = ()+ instance (KnownNat (BitSize b), BitPack a, BitPack b) => BitPack (a,b) where type BitSize (a,b) = BitSize a + BitSize b@@ -130,5 +222,5 @@ -- 00_0001 -- >>> boolToBV False :: BitVector 6 -- 00_0000-boolToBV :: (KnownNat n, KnownNat (n+1)) => Bool -> BitVector (n + 1)+boolToBV :: KnownNat n => Bool -> BitVector (n + 1) boolToBV = zeroExtend . pack
src/CLaSH/Class/Resize.hs view
@@ -4,18 +4,18 @@ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Class.Resize where -import GHC.TypeLits (KnownNat, Nat, type (+))+import GHC.TypeLits (Nat, KnownNat, type (+)) -- | Coerce a value to be represented by a different number of bits class Resize (f :: Nat -> *) where@@ -31,11 +31,12 @@ resize :: (KnownNat a, KnownNat b) => f a -> f b -- | Perform a 'zeroExtend' for unsigned datatypes, and 'signExtend' for a -- signed datatypes- extend :: (KnownNat a, KnownNat (b + a)) => f a -> f (b + a)+ extend :: (KnownNat a, KnownNat b) => f a -> f (b + a) extend = resize -- | Add extra zero bits in front of the MSB- zeroExtend :: (KnownNat a, KnownNat b, KnownNat (b + a)) => f a -> f (b + a)+ zeroExtend :: (KnownNat a, KnownNat b) => f a -> f (b + a) -- | Add extra sign bits in front of the MSB- signExtend :: (KnownNat a, KnownNat (b + a)) => f a -> f (b + a)+ signExtend :: (KnownNat a, KnownNat b) => f a -> f (b + a)+ signExtend = resize -- | Remove bits from the MSB truncateB :: KnownNat a => f (a + b) -> f a
src/CLaSH/Examples.hs view
@@ -96,7 +96,7 @@ let upCounter :: Signal Bool -> Signal (Unsigned 8) upCounter enable = s where- s = regEn 0 enable (s + 1)+ s = register 0 (mux enable (s + 1) s) :} >>> :{@@ -156,7 +156,7 @@ let oneHotCounter :: Signal Bool -> Signal (BitVector 8) oneHotCounter enable = s where- s = regEn 1 enable (rotateL s 1)+ s = register 1 (mux enable (rotateL <$> s <*> 1) s) :} >>> :{@@ -179,7 +179,7 @@ let crc :: Signal Bool -> Signal Bool -> Signal Bit -> Signal (BitVector 16) crc enable ld dIn = s where- s = regEn 0xFFFF enable (mux ld 0xFFFF (crcT <$> s <*> dIn))+ s = register 0xFFFF (mux enable (mux ld 0xFFFF (crcT <$> s <*> dIn)) s) :} >>> :{@@ -389,13 +389,13 @@ {- $counters = 8-bit Simple Up Counter -Using `regEn`:+Using `register`: @ upCounter :: Signal Bool -> Signal (Unsigned 8) upCounter enable = s where- s = `regEn` 0 enable (s + 1)+ s = `register` 0 (`mux` enable (s + 1) s) @ = 8-bit Up Counter With Load@@ -484,7 +484,7 @@ oneHotCounter :: Signal Bool -> Signal (BitVector 8) oneHotCounter enable = s where- s = 'regEn' 1 enable ('rotateL' s 1)+ s = 'register' 1 ('mux' enable ('rotateL' '<$>' s '<*>' 1) s) @ -} @@ -520,7 +520,7 @@ crc :: Signal Bool -> Signal Bool -> Signal Bit -> Signal (BitVector 16) crc enable ld dIn = s where- s = 'regEn' 0xFFFF enable ('mux' ld 0xFFFF (crcT '<$>' s '<*>' dIn))+ s = 'register' 0xFFFF ('mux' enable ('mux' ld 0xFFFF (crcT '<$>' s '<*>' dIn)) s) @ -}
+ src/CLaSH/NamedTypes.hs view
@@ -0,0 +1,65 @@+{- |+Copyright : (C) 2017, QBayLogic+License : BSD2 (see the file LICENSE)+Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>++Add inline documentation to types:++@+fifo+ :: SClock clk+ -> SNat addrSize+ -> "read request" ::: Signal' clk Bool+ -> "write request" ::: Signal' clk (Maybe (BitVector dataSize))+ -> ( "q" ::: Signal' clk (BitVector dataSize)+ , "full" ::: Signal' clk Bool+ , "empty" ::: Signal' clk Bool+ )+@++which can subsequently be inspected in the interactive environment:++>>> :t fifo systemClock+fifo systemClock+ :: SNat addrSize+ -> "read request" ::: Signal' SystemClock Bool+ -> "write request"+ ::: Signal' SystemClock (Maybe (BitVector dataSize))+ -> ("q" ::: Signal' SystemClock (BitVector dataSize),+ "full" ::: Signal' SystemClock Bool,+ "empty" ::: Signal' SystemClock Bool)++-}++{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}++{-# LANGUAGE Safe #-}++{-# OPTIONS_HADDOCK show-extensions #-}++module CLaSH.NamedTypes+ ((:::))+where++type (name :: k) ::: a = a+-- ^ Annotate a type with a name++{- $setup+>>> :set -XDataKinds -XTypeOperators -XNoImplicitPrelude+>>> import CLaSH.Prelude+>>> import CLaSH.Prelude.Explicit+>>> :{+let fifo+ :: SClock clk+ -> SNat addrSize+ -> "read request" ::: Signal' clk Bool+ -> "write request" ::: Signal' clk (Maybe (BitVector dataSize))+ -> ( "q" ::: Signal' clk (BitVector dataSize)+ , "full" ::: Signal' clk Bool+ , "empty" ::: Signal' clk Bool+ )+ fifo = CLaSH.Prelude.undefined+:}++-}
src/CLaSH/Prelude.hs view
@@ -102,13 +102,8 @@ , module CLaSH.Promoted.Nat , module CLaSH.Promoted.Nat.Literals , module CLaSH.Promoted.Nat.TH- -- ** Type-level functions- , module CLaSH.Promoted.Ord -- ** Template Haskell , Lift (..)-#if __GLASGOW_HASKELL__ < 711- , deriveLift-#endif -- ** Type classes -- *** CLaSH , module CLaSH.Class.BitPack@@ -118,6 +113,11 @@ , module Control.Applicative , module Data.Bits , module Data.Default+ -- ** Exceptions+ , module CLaSH.XException+ , undefined+ -- ** Named types+ , module CLaSH.NamedTypes -- ** Haskell Prelude -- $hiding , module Prelude@@ -128,26 +128,21 @@ import Data.Bits import Data.Default import GHC.TypeLits-#if MIN_VERSION_ghc_typelits_extra(0,2,0)-import GHC.TypeLits.Extra hiding (Max, Min)-#else import GHC.TypeLits.Extra-#endif import Language.Haskell.TH.Syntax (Lift(..))-#if __GLASGOW_HASKELL__ < 711-import Language.Haskell.TH.Lift (deriveLift)-#endif import Prelude hiding ((++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, splitAt, tail, take, unzip, unzip3,- zip, zip3, zipWith, zipWith3)+ zip, zip3, zipWith, zipWith3,+ undefined) import CLaSH.Annotations.TopEntity import CLaSH.Class.BitPack import CLaSH.Class.Num import CLaSH.Class.Resize+import CLaSH.NamedTypes import CLaSH.Prelude.BitIndex import CLaSH.Prelude.BitReduction import CLaSH.Prelude.BlockRam.File (blockRamFile, blockRamFilePow2)@@ -160,7 +155,6 @@ import CLaSH.Promoted.Nat import CLaSH.Promoted.Nat.TH import CLaSH.Promoted.Nat.Literals-import CLaSH.Promoted.Ord import CLaSH.Sized.BitVector import CLaSH.Sized.Fixed import CLaSH.Sized.Index@@ -171,6 +165,7 @@ import CLaSH.Signal import CLaSH.Signal.Delayed import CLaSH.Signal.Explicit (systemClock)+import CLaSH.XException {- $setup >>> :set -XDataKinds@@ -197,6 +192,7 @@ -- -- >>> simulateB 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>...+-- ... window :: (KnownNat n, Default a) => Signal a -- ^ Signal to create a window over -> Vec (n + 1) (Signal a) -- ^ Window of at least size 1@@ -210,7 +206,8 @@ -- -- >>> simulateB windowD3 [1::Int,2,3,4] :: [Vec 3 Int] -- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>...-windowD :: (KnownNat (n + 1), Default a)+-- ...+windowD :: (KnownNat n, Default a) => Signal a -- ^ Signal to create a window over -> Vec (n + 1) (Signal a) -- ^ Window of at least size 1 windowD = windowD' systemClock
src/CLaSH/Prelude/BitIndex.hs view
@@ -41,6 +41,7 @@ -- 0 -- >>> (7 :: Unsigned 6) ! 6 -- *** Exception: (!): 6 is out of range [5..0]+-- ... (!) :: (BitPack a, KnownNat (BitSize a), Enum i) => a -> i -> Bit (!) v i = index# (pack v) (fromEnum i) @@ -56,12 +57,11 @@ -- >>> slice d6 d4 (7 :: Unsigned 6) -- <BLANKLINE> -- <interactive>:...--- Couldn't match type ‘7 + i0’ with ‘6’--- The type variable ‘i0’ is ambiguous--- Expected type: (6 + 1) + i0--- Actual type: BitSize (Unsigned 6)--- In the expression: slice d6 d4 (7 :: Unsigned 6)--- In an equation for ‘it’: it = slice d6 d4 (7 :: Unsigned 6)+-- • 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@@ -95,6 +95,7 @@ -- 01_1011 -- >>> replaceBit 6 0 (-5 :: Signed 6) -- *** Exception: replaceBit: 6 is out of range [5..0]+-- ... replaceBit :: (BitPack a, KnownNat (BitSize a), Enum i) => i -> Bit -> a -> a replaceBit i b v = unpack (replaceBit# (pack v) (fromEnum i) b)@@ -113,12 +114,11 @@ -- >>> setSlice d6 d5 0 (-5 :: Signed 6) -- <BLANKLINE> -- <interactive>:...--- Couldn't match type ‘7 + i0’ with ‘6’--- The type variable ‘i0’ is ambiguous--- Expected type: (6 + 1) + i0--- Actual type: BitSize (Signed 6)--- In the expression: setSlice d6 d5 0 (- 5 :: Signed 6)--- In an equation for ‘it’: it = setSlice d6 d5 0 (- 5 :: Signed 6)+-- • 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# (pack v) m n w)
src/CLaSH/Prelude/BlockRam.hs view
@@ -16,11 +16,10 @@ codes: @-{\-\# LANGUAGE RecordWildCards \#-\}+{\-\# LANGUAGE RecordWildCards, TupleSections \#-\} module CPU where import CLaSH.Prelude-import qualified Data.List as L type InstrAddr = Unsigned 8 type MemAddr = Unsigned 5@@ -56,13 +55,12 @@ , aluCode :: Operator , ldReg :: Reg , rdAddr :: MemAddr- , wrAddr :: MemAddr- , wrEn :: Bool+ , wrAddrM :: Maybe MemAddr , jmpM :: Maybe Value } nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm- , ldReg = Zero, wrAddr = 0, rdAddr = 0, wrEn = False+ , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing , jmpM = Nothing } @@@ -73,9 +71,9 @@ cpu :: Vec 7 Value -- ^ Register bank -> (Value,Instruction) -- ^ (Memory output, Current instruction) -> ( Vec 7 Value- , (MemAddr,MemAddr,Bool,Value,InstrAddr)+ , (MemAddr, Maybe (MemAddr,Value), InstrAddr) )-cpu regbank (memOut,instr) = (regbank',(rdAddr,wrAddr,wrEn,aluOut,fromIntegral ipntr))+cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) '<$>' wrAddrM,fromIntegral ipntr)) where -- Current instruction pointer ipntr = regbank '!!' PC@@ -86,7 +84,7 @@ Branch cr a -> nullCode {inputX=cr,jmpM=Just a} Jump a -> nullCode {aluCode=Incr,jmpM=Just a} Load a r -> nullCode {ldReg=r,rdAddr=a}- Store r a -> nullCode {inputX=r,wrAddr=a,wrEn=True}+ Store r a -> nullCode {inputX=r,wrAddrM=Just a} Nop -> nullCode -- ALU@@ -116,18 +114,17 @@ We initially create a memory out of simple registers: @-dataMem :: Signal MemAddr -- ^ Read address- -> Signal MemAddr -- ^ Write address- -> Signal Bool -- ^ Write enable- -> Signal Value -- ^ data in- -> Signal Value -- ^ data out-dataMem wr rd en din = 'CLaSH.Prelude.Mealy.mealy' dataMemT ('replicate' d32 0) (bundle (wr,rd,en,din))+dataMem :: Signal MemAddr -- ^ Read address+ -> Signal (Maybe (MemAddr,Value)) -- ^ (write address, data in)+ -> Signal Value -- ^ data out+dataMem rd wrM = 'CLaSH.Prelude.Mealy.mealy' dataMemT ('replicate' d32 0) (bundle (rd,wrM)) where- dataMemT mem (wr,rd,en,din) = (mem',dout)+ dataMemT mem (rd,wrM) = (mem',dout) where dout = mem '!!' rd- mem' | en = 'replace' wr din mem- | otherwise = mem+ mem' = case wrM of+ Just (wr,din) -> 'replace' wr din mem+ _ -> mem @ And then connect everything:@@ -136,8 +133,8 @@ system :: KnownNat n => Vec n Instruction -> Signal Value system instrs = memOut where- memOut = dataMem wrAddr rdAddr wrEn aluOut- (rdAddr,wrAddr,wrEn,aluOut,ipntr) = 'CLaSH.Prelude.Mealy.mealyB' cpu ('replicate' d7 0) (memOut,instr)+ memOut = dataMem rdAddr dout+ (rdAddr,dout,ipntr) = 'CLaSH.Prelude.Mealy.mealyB' cpu ('replicate' d7 0) (memOut,instr) instr = 'CLaSH.Prelude.ROM.asyncRom' instrs '<$>' ipntr @ @@ -178,8 +175,9 @@ And test our system: @-__>>> sampleN 31 $ system prog__+>>> sampleN 31 $ system prog [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,2]+ @ to see that our system indeed calculates that the GCD of 6 and 4 is 2.@@ -197,8 +195,8 @@ system2 :: KnownNat n => Vec n Instruction -> Signal Value system2 instrs = memOut where- memOut = 'CLaSH.Prelude.RAM.asyncRam' d32 wrAddr rdAddr wrEn aluOut- (rdAddr,wrAddr,wrEn,aluOut,ipntr) = 'mealyB' cpu ('replicate' d7 0) (memOut,instr)+ memOut = 'CLaSH.Prelude.RAM.asyncRam' d32 rdAddr dout+ (rdAddr,dout,ipntr) = 'mealyB' cpu ('replicate' d7 0) (memOut,instr) instr = 'CLaSH.Prelude.ROM.asyncRom' instrs '<$>' ipntr @ @@ -208,8 +206,9 @@ output samples are also 'undefined'. @-__>>> L.drop 5 $ sampleN 31 $ system2 prog__-[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]+>>> printX $ sampleN 31 $ system2 prog+[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]+ @ === Improvement 2: using @blockRam@@@ -236,9 +235,9 @@ cpu2 :: (Vec 7 Value,Reg) -- ^ (Register bank, Load reg addr) -> (Value,Instruction) -- ^ (Memory output, Current instruction) -> ( (Vec 7 Value,Reg)- , (MemAddr,MemAddr,Bool,Value,InstrAddr)+ , (MemAddr, Maybe (MemAddr,Value), InstrAddr) )-cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,wrAddr,wrEn,aluOut,fromIntegral ipntr))+cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) '<$>' wrAddrM,fromIntegral ipntr)) where -- Current instruction pointer ipntr = regbank '!!' PC@@ -249,7 +248,7 @@ Branch cr a -> nullCode {inputX=cr,jmpM=Just a} Jump a -> nullCode {aluCode=Incr,jmpM=Just a} Load a r -> nullCode {ldReg=r,rdAddr=a}- Store r a -> nullCode {inputX=r,wrAddr=a,wrEn=True}+ Store r a -> nullCode {inputX=r,wrAddrM=Just a} Nop -> nullCode -- ALU@@ -277,8 +276,8 @@ system3 :: KnownNat n => Vec n Instruction -> Signal Value system3 instrs = memOut where- memOut = 'blockRam' (replicate d32 0) wrAddr rdAddr wrEn aluOut- (rdAddr,wrAddr,wrEn,aluOut,ipntr) = 'mealyB' cpu2 (('replicate' d7 0),Zero) (memOut,instr)+ memOut = 'blockRam' (replicate d32 0) rdAddr dout+ (rdAddr,dout,ipntr) = 'mealyB' cpu2 (('replicate' d7 0),Zero) (memOut,instr) instr = 'CLaSH.Prelude.ROM.asyncRom' instrs '<$>' ipntr @ @@ -327,21 +326,23 @@ also 'undefined'. @-__>>> L.tail $ sampleN 33 $ system3 prog2__-[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]+>>> printX $ sampleN 33 $ system3 prog2+[X,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]+ @ This concludes the short introduction to using 'blockRam'. -} -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Prelude.BlockRam@@ -359,18 +360,263 @@ ) where +import Control.Exception (catch, evaluate, throw) import Control.Monad (when) import Control.Monad.ST.Lazy (ST,runST)+import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST) import Data.Array.MArray.Safe (newListArray,readArray,writeArray) import Data.Array.ST.Safe (STArray)+import Data.Maybe (fromJust, isJust) import GHC.TypeLits (KnownNat, type (^))+import Prelude hiding (length) import CLaSH.Signal (Signal, mux) import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock)-import CLaSH.Signal.Bundle (bundle')+import CLaSH.Signal.Bundle (bundle, unbundle) import CLaSH.Sized.Unsigned (Unsigned)-import CLaSH.Sized.Vector (Vec, maxIndex, toList)+import CLaSH.Sized.Vector (Vec, length, toList)+import CLaSH.XException (XException, errorX) +{- $setup+>>> import CLaSH.Prelude as C+>>> import qualified Data.List as L+>>> :set -XDataKinds -XRecordWildCards -XTupleSections+>>> type InstrAddr = Unsigned 8+>>> type MemAddr = Unsigned 5+>>> type Value = Signed 8+>>> :{+data Reg+ = Zero+ | PC+ | RegA+ | RegB+ | RegC+ | RegD+ | RegE+ deriving (Eq,Show,Enum)+:}++>>> :{+data Operator = Add | Sub | Incr | Imm | CmpGt+ deriving (Eq,Show)+:}++>>> :{+data Instruction+ = Compute Operator Reg Reg Reg+ | Branch Reg Value+ | Jump Value+ | Load MemAddr Reg+ | Store Reg MemAddr+ | Nop+ deriving (Eq,Show)+:}++>>> :{+data MachCode+ = MachCode+ { inputX :: Reg+ , inputY :: Reg+ , result :: Reg+ , aluCode :: Operator+ , ldReg :: Reg+ , rdAddr :: MemAddr+ , wrAddrM :: Maybe MemAddr+ , jmpM :: Maybe Value+ }+:}++>>> :{+nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm+ , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing+ , jmpM = Nothing+ }+:}++>>> :{+alu Add x y = x + y+alu Sub x y = x - y+alu Incr x _ = x + 1+alu Imm x _ = x+alu CmpGt x y = if x > y then 1 else 0+:}++>>> :{+cpu :: Vec 7 Value -- ^ Register bank+ -> (Value,Instruction) -- ^ (Memory output, Current instruction)+ -> ( Vec 7 Value+ , (MemAddr,Maybe (MemAddr,Value),InstrAddr)+ )+cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr))+ where+ -- Current instruction pointer+ ipntr = regbank C.!! PC+ -- Decoder+ (MachCode {..}) = case instr of+ Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}+ Branch cr a -> nullCode {inputX=cr,jmpM=Just a}+ Jump a -> nullCode {aluCode=Incr,jmpM=Just a}+ Load a r -> nullCode {ldReg=r,rdAddr=a}+ Store r a -> nullCode {inputX=r,wrAddrM=Just a}+ Nop -> nullCode+ -- ALU+ regX = regbank C.!! inputX+ regY = regbank C.!! inputY+ aluOut = alu aluCode regX regY+ -- next instruction+ nextPC = case jmpM of+ Just a | aluOut /= 0 -> ipntr + a+ _ -> ipntr + 1+ -- update registers+ regbank' = replace Zero 0+ $ replace PC nextPC+ $ replace result aluOut+ $ replace ldReg memOut+ $ regbank+:}++>>> :{+dataMem :: Signal MemAddr+ -> Signal (Maybe (MemAddr,Value))+ -> Signal Value+dataMem rd wrM = mealy dataMemT (C.replicate d32 0) (bundle (rd,wrM))+ where+ dataMemT mem (rd,wrM) = (mem',dout)+ where+ dout = mem C.!! rd+ mem' = case wrM of+ Just (wr,din) -> replace wr din mem+ Nothing -> mem+:}++>>> :{+system :: KnownNat n => Vec n Instruction -> Signal Value+system instrs = memOut+ where+ memOut = dataMem rdAddr dout+ (rdAddr,dout,ipntr) = mealyB cpu (C.replicate d7 0) (memOut,instr)+ instr = asyncRom instrs <$> ipntr+:}++>>> :{+-- Compute GCD of 4 and 6+prog = -- 0 := 4+ Compute Incr Zero RegA RegA :>+ C.replicate d3 (Compute Incr RegA Zero RegA) C.+++ Store RegA 0 :>+ -- 1 := 6+ Compute Incr Zero RegA RegA :>+ C.replicate d5 (Compute Incr RegA Zero RegA) C.+++ Store RegA 1 :>+ -- A := 4+ Load 0 RegA :>+ -- B := 6+ Load 1 RegB :>+ -- start+ Compute CmpGt RegA RegB RegC :>+ Branch RegC 4 :>+ Compute CmpGt RegB RegA RegC :>+ Branch RegC 4 :>+ Jump 5 :>+ -- (a > b)+ Compute Sub RegA RegB RegA :>+ Jump (-6) :>+ -- (b > a)+ Compute Sub RegB RegA RegB :>+ Jump (-8) :>+ -- end+ Store RegA 2 :>+ Load 2 RegC :>+ Nil+:}++>>> :{+system2 :: KnownNat n => Vec n Instruction -> Signal Value+system2 instrs = memOut+ where+ memOut = asyncRam d32 rdAddr dout+ (rdAddr,dout,ipntr) = mealyB cpu (C.replicate d7 0) (memOut,instr)+ instr = asyncRom instrs <$> ipntr+:}++>>> :{+cpu2 :: (Vec 7 Value,Reg) -- ^ (Register bank, Load reg addr)+ -> (Value,Instruction) -- ^ (Memory output, Current instruction)+ -> ( (Vec 7 Value,Reg)+ , (MemAddr,Maybe (MemAddr,Value),InstrAddr)+ )+cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr))+ where+ -- Current instruction pointer+ ipntr = regbank C.!! PC+ -- Decoder+ (MachCode {..}) = case instr of+ Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op}+ Branch cr a -> nullCode {inputX=cr,jmpM=Just a}+ Jump a -> nullCode {aluCode=Incr,jmpM=Just a}+ Load a r -> nullCode {ldReg=r,rdAddr=a}+ Store r a -> nullCode {inputX=r,wrAddrM=Just a}+ Nop -> nullCode+ -- ALU+ regX = regbank C.!! inputX+ regY = regbank C.!! inputY+ aluOut = alu aluCode regX regY+ -- next instruction+ nextPC = case jmpM of+ Just a | aluOut /= 0 -> ipntr + a+ _ -> ipntr + 1+ -- update registers+ ldRegD' = ldReg -- Delay the ldReg by 1 cycle+ regbank' = replace Zero 0+ $ replace PC nextPC+ $ replace result aluOut+ $ replace ldRegD memOut+ $ regbank+:}++>>> :{+system3 :: KnownNat n => Vec n Instruction -> Signal Value+system3 instrs = memOut+ where+ memOut = blockRam (C.replicate d32 0) rdAddr dout+ (rdAddr,dout,ipntr) = mealyB cpu2 ((C.replicate d7 0),Zero) (memOut,instr)+ instr = asyncRom instrs <$> ipntr+:}++>>> :{+prog2 = -- 0 := 4+ Compute Incr Zero RegA RegA :>+ C.replicate d3 (Compute Incr RegA Zero RegA) C.+++ Store RegA 0 :>+ -- 1 := 6+ Compute Incr Zero RegA RegA :>+ C.replicate d5 (Compute Incr RegA Zero RegA) C.+++ Store RegA 1 :>+ -- A := 4+ Load 0 RegA :>+ -- B := 6+ Load 1 RegB :>+ Nop :> -- Extra NOP+ -- start+ Compute CmpGt RegA RegB RegC :>+ Branch RegC 4 :>+ Compute CmpGt RegB RegA RegC :>+ Branch RegC 4 :>+ Jump 5 :>+ -- (a > b)+ Compute Sub RegA RegB RegA :>+ Jump (-6) :>+ -- (b > a)+ Compute Sub RegB RegA RegB :>+ Jump (-8) :>+ -- end+ Store RegA 2 :>+ Load 2 RegC :>+ Nil+:}++-}+ {-# INLINE blockRam #-} -- | Create a blockRAM with space for @n@ elements. --@@ -378,8 +624,9 @@ -- * __NB__: Initial output value is 'undefined' -- -- @--- bram40 :: 'Signal' ('Unsigned' 6) -> Signal ('Unsigned' 6) -> 'Signal' Bool--- -> 'Signal' 'CLaSH.Sized.BitVector.Bit' -> Signal 'CLaSH.Sized.BitVector.Bit'+-- bram40 :: 'Signal' ('Unsigned' 6)+-- -> 'Signal' (Maybe ('Unsigned' 6, 'CLaSH.Sized.BitVector.Bit'))+-- -> 'Signal' 'CLaSH.Sized.BitVector.Bit' -- bram40 = 'blockRam' ('CLaSH.Sized.Vector.replicate' d40 1) -- @ --@@ -387,16 +634,15 @@ -- -- * 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 (blockRam inits) wr rd en dt@.+-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRam inits) rd wrM@. blockRam :: (KnownNat n, Enum addr) => Vec n a -- ^ Initial content of the BRAM, also -- determines the size, @n@, of the BRAM. -- -- __NB__: __MUST__ be a constant.- -> Signal addr -- ^ Write address @w@ -> Signal addr -- ^ Read address @r@- -> Signal Bool -- ^ Write enable- -> Signal a -- ^ Value to write (at address @w@)+ -> Signal (Maybe (addr, a))+ -- ^ (write address @w@, value to write) -> Signal a -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle@@ -409,8 +655,9 @@ -- * __NB__: Initial output value is 'undefined' -- -- @--- bram32 :: 'Signal' ('Unsigned' 5) -> Signal ('Unsigned' 5) -> 'Signal' Bool--- -> 'Signal' 'CLaSH.Sized.BitVector.Bit' -> 'Signal' 'CLaSH.Sized.BitVector.Bit'+-- bram32 :: 'Signal' ('Unsigned' 5)+-- -> 'Signal' (Maybe ('Unsigned' 5, 'CLaSH.Sized.BitVector.Bit'))+-- -> 'Signal' 'CLaSH.Sized.BitVector.Bit' -- bram32 = 'blockRamPow2' ('CLaSH.Sized.Vector.replicate' d32 1) -- @ --@@ -418,20 +665,19 @@ -- -- * 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 (blockRamPow2 inits) wr rd en dt@.-blockRamPow2 :: (KnownNat (2^n), KnownNat n)+-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRamPow2 inits) rd wrM@.+blockRamPow2 :: KnownNat n => Vec (2^n) a -- ^ Initial content of the BRAM, also -- determines the size, @2^n@, of the BRAM. -- -- __NB__: __MUST__ be a constant.- -> Signal (Unsigned n) -- ^ Write address @w@ -> Signal (Unsigned n) -- ^ Read address @r@- -> Signal Bool -- ^ Write enable- -> Signal a -- ^ Value to write (at address @w@)+ -> Signal (Maybe (Unsigned n, a))+ -- ^ (write address @w@, value to write) -> Signal a -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle-blockRamPow2 = blockRam+blockRamPow2 = blockRamPow2' systemClock {-# INLINE blockRam' #-} -- | Create a blockRAM with space for @n@ elements@@ -445,8 +691,9 @@ -- clkA100 :: SClock ClkA -- clkA100 = 'CLaSH.Signal.Explicit.sclock' ----- bram40 :: 'Signal'' ClkA ('Unsigned' 6) -> 'Signal'' ClkA ('Unsigned' 6)--- -> 'Signal'' ClkA Bool -> 'Signal'' ClkA 'CLaSH.Sized.BitVector.Bit' -> ClkA 'Signal'' 'CLaSH.Sized.BitVector.Bit'+-- bram40 :: 'Signal'' ClkA ('Unsigned' 6)+-- -> 'Signal'' ClkA (Maybe ('Unsigned' 6, 'CLaSH.Sized.BitVector.Bit'))+-- -> 'Signal'' ClkA 'CLaSH.Sized.BitVector.Bit' -- bram40 = 'blockRam'' clkA100 ('CLaSH.Sized.Vector.replicate' d40 1) -- @ --@@ -454,22 +701,25 @@ -- -- * 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 (blockRam' clk inits) wr rd en dt@.+-- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRam' clk inits) rd wrM@. blockRam' :: (KnownNat n, Enum addr) => SClock clk -- ^ 'Clock' to synchronize to -> Vec n a -- ^ Initial content of the BRAM, also -- determines the size, @n@, of the BRAM. -- -- __NB__: __MUST__ be a constant.- -> Signal' clk addr -- ^ Write address @w@ -> Signal' clk addr -- ^ Read address @r@- -> Signal' clk Bool -- ^ Write enable- -> Signal' clk a -- ^ Value to write (at address @w@)+ -> Signal' clk (Maybe (addr, a))+ -- ^ (write address @w@, value to write) -> Signal' clk a -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle-blockRam' clk content wr rd en din = blockRam# clk content (fromEnum <$> wr)- (fromEnum <$> rd) en din+blockRam' clk content rd wrM =+ blockRam# clk content+ (fromEnum <$> rd)+ (isJust <$> wrM)+ ((fromEnum . fst . fromJust) <$> wrM)+ ((snd . fromJust) <$> wrM) {-# INLINE blockRamPow2' #-} -- | Create a blockRAM with space for 2^@n@ elements@@ -483,8 +733,9 @@ -- clkA100 :: SClock ClkA -- clkA100 = 'CLaSH.Signal.Explicit.sclock' ----- bram32 :: 'Signal'' ClkA ('Unsigned' 5) -> Signal' ClkA ('Unsigned' 5)--- -> 'Signal'' ClkA Bool -> 'Signal'' ClkA 'CLaSH.Sized.BitVector.Bit' -> Signal' ClkA 'CLaSH.Sized.BitVector.Bit'+-- bram32 :: 'Signal'' ClkA ('Unsigned' 5)+-- -> 'Signal'' ClkA (Maybe ('Unsigned' 5, 'CLaSH.Sized.BitVector.Bit'))+-- -> 'Signal'' ClkA 'CLaSH.Sized.BitVector.Bit' -- bram32 = 'blockRamPow2'' clkA100 ('CLaSH.Sized.Vector.replicate' d32 1) -- @ --@@ -492,24 +743,22 @@ -- -- * 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 (blockRamPow2' clk inits) wr rd en dt@.-blockRamPow2' :: (KnownNat n, KnownNat (2^n))+-- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamPow2' clk inits) rd wrM@.+blockRamPow2' :: KnownNat n => SClock clk -- ^ 'Clock' to synchronize to -> Vec (2^n) a -- ^ Initial content of the BRAM, also -- determines the size, @2^n@, of -- the BRAM. -- -- __NB__: __MUST__ be a constant.- -> Signal' clk (Unsigned n) -- ^ Write address @w@ -> Signal' clk (Unsigned n) -- ^ Read address @r@- -> Signal' clk Bool -- ^ Write enable- -> Signal' clk a -- ^ Value to write (at address @w@)+ -> Signal' clk (Maybe (Unsigned n, a))+ -- ^ (Write address @w@, value to write) -> Signal' clk a -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle blockRamPow2' = blockRam' -{-# NOINLINE blockRam# #-} -- | blockRAM primitive blockRam# :: KnownNat n => SClock clk -- ^ 'Clock' to synchronize to@@ -517,40 +766,66 @@ -- determines the size, @n@, of the BRAM. -- -- __NB__: __MUST__ be a constant.- -> Signal' clk Int -- ^ Write address @w@ -> Signal' clk Int -- ^ Read address @r@ -> Signal' clk Bool -- ^ Write enable+ -> Signal' clk Int -- ^ Write address @w@ -> Signal' clk a -- ^ Value to write (at address @w@) -> Signal' clk a -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle-blockRam# clk content wr rd en din = register' clk undefined dout+blockRam# clk content rd en wr din =+ register' clk (errorX "blockRam#: intial value undefined") dout where- szI = maxIndex content+ szI = length content dout = runST $ do- arr <- newListArray (0,szI) (toList content)- traverse (ramT arr) (bundle' clk (wr,rd,en,din))+ arr <- newListArray (0,szI-1) (toList content)+ traverse (ramT arr) (bundle (rd,en,wr,din)) - ramT :: STArray s Int e -> (Int,Int,Bool,e) -> ST s e- ramT ram (w,r,e,d) = do- d' <- readArray ram r+ ramT :: STArray s Int e -> (Int,Bool,Int,e) -> ST s e+ ramT ram (r,e,w,d) = do+ -- reading from address using an 'X' exception results in an 'X' result+ r' <- unsafeIOToST $+ catch (evaluate r >>= (return . Right))+ (\(err :: XException) -> return (Left (throw err)))+ d' <- case r' of+ Right r2 -> readArray ram r2+ Left err -> return err+ -- writing to an address using an 'X' exception makes everything 'X' when e (writeArray ram w d) return d'+{-# NOINLINE blockRam# #-} -- | Create read-after-write blockRAM from a read-before-write one (synchronised to specified clock) ---readNew' :: Eq addr => SClock clk -> (Signal' clk addr -> Signal' clk addr -> Signal' clk Bool -> Signal' clk a -> Signal' clk a) -> Signal' clk addr -> Signal' clk addr -> Signal' clk Bool -> Signal' clk a -> Signal' clk a-readNew' clk ram wrAddr rdAddr wrEn wrData = mux wasSame wasWritten $ ram wrAddr rdAddr wrEn wrData- where sameAddr = (==) <$> wrAddr <*> rdAddr- wasSame = register' clk False ((&&) <$> wrEn <*> sameAddr)- wasWritten = register' clk undefined wrData+readNew' :: Eq addr+ => SClock clk+ -> (Signal' clk addr -> Signal' clk (Maybe (addr, a)) -> Signal' clk a)+ -- ^ The @ram@ component+ -> Signal' clk addr -- ^ Read address @r@+ -> Signal' clk (Maybe (addr, a)) -- ^ (Write address @w@, value to write)+ -> Signal' clk a+ -- ^ Value of the @ram@ at address @r@ from the previous clock+ -- cycle+readNew' clk ram rdAddr wrM = mux wasSame wasWritten $ ram rdAddr wrM+ where readNewT rd (Just (wr, wrdata)) = (wr == rd, wrdata)+ readNewT _ Nothing = (False , undefined) + (wasSame,wasWritten) = unbundle (register' clk (False,undefined)+ (readNewT <$> rdAddr <*> wrM))+ -- | Create read-after-write blockRAM from a read-before-write one (synchronised to system clock) -- -- >>> import CLaSH.Prelude -- >>> :t readNew (blockRam (0 :> 1 :> Nil)) -- readNew (blockRam (0 :> 1 :> Nil))--- :: (Enum addr, Eq addr, Num a) =>--- Signal addr -> Signal addr -> Signal Bool -> Signal a -> Signal a-readNew :: Eq addr => (Signal addr -> Signal addr -> Signal Bool -> Signal a -> Signal a) -> Signal addr -> Signal addr -> Signal Bool -> Signal a -> Signal a+-- :: ... =>+-- Signal addr -> Signal (Maybe (addr, a)) -> Signal a+readNew :: Eq addr+ => (Signal addr -> Signal (Maybe (addr, a)) -> Signal a)+ -- ^ The @ram@ component+ -> Signal addr -- ^ Read address @r@+ -> Signal (Maybe (addr, a)) -- ^ (Write address @w@, value to write)+ -> Signal a+ -- ^ Value of the @ram@ at address @r@ from the previous clock+ -- cycle readNew = readNew' systemClock
src/CLaSH/Prelude/BlockRam/File.hs view
@@ -33,7 +33,7 @@ @ topEntity :: Signal (Unsigned 3) -> Signal (Unsigned 9)-topEntity rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" 0 rd (signal False) 0+topEntity rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" rd (signal Nothing) @ In the example above, we basically treat the BlockRAM as an synchronous ROM.@@ -50,7 +50,7 @@ @ topEntity2 :: Signal (Unsigned 3) -> Signal (Unsigned 6,Signed 3)-topEntity2 rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" 0 rd (signal False) 0+topEntity2 rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" rd (signal Nothing) @ And then we would see:@@ -64,13 +64,14 @@ -} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Unsafe #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Prelude.BlockRam.File@@ -86,22 +87,24 @@ ) where +import Control.Exception (catch, evaluate, throw) import Control.Monad (when) import Control.Monad.ST.Lazy (ST,runST) import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST) import Data.Array.MArray (newListArray,readArray,writeArray) import Data.Array.ST (STArray) import Data.Char (digitToInt)-import Data.Maybe (listToMaybe)-import GHC.TypeLits (KnownNat, type (^))+import Data.Maybe (fromJust, isJust, listToMaybe)+import GHC.TypeLits (KnownNat) import Numeric (readInt) -import CLaSH.Promoted.Nat (SNat,snat,snatToInteger)+import CLaSH.Promoted.Nat (SNat (..), pow2SNat, snatToNum) import CLaSH.Sized.BitVector (BitVector) import CLaSH.Signal (Signal) import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock)-import CLaSH.Signal.Bundle (bundle')+import CLaSH.Signal.Bundle (bundle) import CLaSH.Sized.Unsigned (Unsigned)+import CLaSH.XException (XException, errorX) {-# INLINE blockRamFile #-} -- | Create a blockRAM with space for @n@ elements@@ -125,7 +128,7 @@ -- -- * 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 (blockRamFile size file) wr rd en dt@.+-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRamFile size file) rd wrM@. -- * See "CLaSH.Prelude.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@@ -134,10 +137,9 @@ => SNat n -- ^ Size of the blockRAM -> FilePath -- ^ File describing the initial content -- of the blockRAM- -> Signal addr -- ^ Write address @w@ -> Signal addr -- ^ Read address @r@- -> Signal Bool -- ^ Write enable- -> Signal (BitVector m) -- ^ Value to write (at address @w@)+ -> Signal (Maybe (addr, BitVector m))+ -- ^ (write address @w@, value to write) -> Signal (BitVector m) -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle@@ -165,22 +167,21 @@ -- -- * 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 (blockRamFilePow2 file) wr rd en dt@.+-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRamFilePow2 file) rd wrM@. -- * See "CLaSH.Prelude.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.-blockRamFilePow2 :: forall n m . (KnownNat m, KnownNat n, KnownNat (2^n))+blockRamFilePow2 :: (KnownNat m, KnownNat n) => FilePath -- ^ File describing the initial -- content of the blockRAM- -> Signal (Unsigned n) -- ^ Write address @w@- -> Signal (Unsigned n) -- ^ Read address @r@- -> Signal Bool -- ^ Write enable- -> Signal (BitVector m) -- ^ Value to write (at address @w@)+ -> Signal (Unsigned n) -- ^ Read address @r@+ -> Signal (Maybe (Unsigned n, BitVector m))+ -- ^ (write address @w@, value to write)@) -> Signal (BitVector m) -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle-blockRamFilePow2 = blockRamFile' systemClock (snat :: SNat (2^n))+blockRamFilePow2 = blockRamFilePow2' systemClock {-# INLINE blockRamFilePow2' #-} -- | Create a blockRAM with space for 2^@n@ elements@@ -204,23 +205,22 @@ -- -- * 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 (blockRamFilePow2' clk file) wr rd en dt@.+-- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamFilePow2' clk file) rd wrM@. -- * See "CLaSH.Prelude.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.-blockRamFilePow2' :: forall clk n m . (KnownNat m, KnownNat n, KnownNat (2^n))+blockRamFilePow2' :: forall clk n m . (KnownNat m, KnownNat n) => SClock clk -- ^ 'Clock' to synchronize to -> FilePath -- ^ File describing the initial -- content of the blockRAM- -> Signal' clk (Unsigned n) -- ^ Write address @w@ -> Signal' clk (Unsigned n) -- ^ Read address @r@- -> Signal' clk Bool -- ^ Write enable- -> Signal' clk (BitVector m) -- ^ Value to write (at address @w@)+ -> Signal' clk (Maybe (Unsigned n, BitVector m))+ -- ^ (write address @w@, value to write) -> Signal' clk (BitVector m) -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle-blockRamFilePow2' clk = blockRamFile' clk (snat :: SNat (2^n))+blockRamFilePow2' clk = blockRamFile' clk (pow2SNat (SNat @ n)) {-# INLINE blockRamFile' #-} -- | Create a blockRAM with space for @n@ elements@@ -244,7 +244,7 @@ -- -- * 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 (blockRamFile' clk size file) wr rd en dt@.+-- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamFile' clk size file) rd wrM@. -- * See "CLaSH.Prelude.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@@ -254,17 +254,18 @@ -> SNat n -- ^ Size of the blockRAM -> FilePath -- ^ File describing the initial -- content of the blockRAM- -> Signal' clk addr -- ^ Write address @w@ -> Signal' clk addr -- ^ Read address @r@- -> Signal' clk Bool -- ^ Write enable- -> Signal' clk (BitVector m) -- ^ Value to write (at address @w@)+ -> Signal' clk (Maybe (addr, BitVector m))+ -- ^ (write address @w@, value to write) -> Signal' clk (BitVector m) -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle-blockRamFile' clk sz file wr rd en din = blockRamFile# clk sz file- (fromEnum <$> wr)- (fromEnum <$> rd)- en din+blockRamFile' clk sz file rd wrM =+ blockRamFile# clk sz file+ (fromEnum <$> rd)+ (isJust <$> wrM)+ ((fromEnum . fst . fromJust) <$> wrM)+ ((snd . fromJust) <$> wrM) {-# NOINLINE blockRamFile# #-} -- | blockRamFile primitive@@ -273,24 +274,30 @@ -> SNat n -- ^ Size of the blockRAM -> FilePath -- ^ File describing the initial -- content of the blockRAM- -> Signal' clk Int -- ^ Write address @w@ -> Signal' clk Int -- ^ Read address @r@ -> Signal' clk Bool -- ^ Write enable+ -> Signal' clk Int -- ^ Write address @w@ -> Signal' clk (BitVector m) -- ^ Value to write (at address @w@) -> Signal' clk (BitVector m) -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle-blockRamFile# clk sz file wr rd en din = register' clk undefined dout+blockRamFile# clk sz file rd en wr din = register' clk (errorX "blockRamFile#: intial value undefined") dout where- szI = fromInteger $ snatToInteger sz+ szI = snatToNum sz dout = runST $ do mem <- unsafeIOToST (initMem file) arr <- newListArray (0,szI-1) mem- traverse (ramT arr) (bundle' clk (wr,rd,en,din))+ traverse (ramT arr) (bundle (rd,en,wr,din)) - ramT :: STArray s Int e -> (Int,Int,Bool,e) -> ST s e- ramT ram (w,r,e,d) = do- d' <- readArray ram r+ ramT :: STArray s Int e -> (Int,Bool,Int,e) -> ST s e+ ramT ram (r,e,w,d) = do+ -- reading from address using an 'X' exception results in an 'X' result+ r' <- unsafeIOToST (catch (evaluate r >>= (return . Right))+ (\(err :: XException) -> return (Left (throw err))))+ d' <- case r' of+ Right r2 -> readArray ram r2+ Left err -> return err+ -- writing to an address using an 'X' exception makes everything 'X' when e (writeArray ram w d) return d'
src/CLaSH/Prelude/DataFlow.hs view
@@ -7,17 +7,16 @@ -} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Prelude.DataFlow@@ -54,8 +53,9 @@ import CLaSH.Prelude.BitIndex (msb) import CLaSH.Prelude.Mealy (mealyB') import CLaSH.Promoted.Nat (SNat)-import CLaSH.Signal ((.&&.), not1, regEn, unbundle)+import CLaSH.Signal ((.&&.), unbundle) import CLaSH.Signal.Bundle (Bundle (..))+import CLaSH.Signal.Internal (regEn#) import CLaSH.Signal.Explicit (Clock (..), Signal', SystemClock, sclock) import CLaSH.Sized.BitVector (BitVector) import CLaSH.Sized.Vector@@ -147,49 +147,47 @@ -- | Create a 'DataFlow' circuit from a Mealy machine description as those of -- "CLaSH.Prelude.Mealy"-mealyDF :: (s -> i -> (s,o))+mealyDF :: (KnownSymbol nm, KnownNat rate)+ => (s -> i -> (s,o)) -> s- -> DataFlow Bool Bool i o+ -> DataFlow' ('Clk nm rate) Bool Bool i o mealyDF f iS = DF (\i iV oR -> let en = iV .&&. oR (s',o) = unbundle (f <$> s <*> i)- s = regEn iS en s'+ s = regEn# sclock iS en s' in (o,iV,oR)) -- | Create a 'DataFlow' circuit from a Moore machine description as those of -- "CLaSH.Prelude.Moore"-mooreDF :: (s -> i -> s)+mooreDF :: (KnownSymbol nm, KnownNat rate)+ => (s -> i -> s) -> (s -> o) -> s- -> DataFlow Bool Bool i o+ -> DataFlow' ('Clk nm rate) Bool Bool i o mooreDF ft fo iS = DF (\i iV oR -> let en = iV .&&. oR s' = ft <$> s <*> i- s = regEn iS en s'+ s = regEn# sclock iS en s' o = fo <$> s in (o,iV,oR)) -fifoDF_mealy :: forall addrSize a .- (KnownNat addrSize- ,KnownNat (addrSize + 1)- ,KnownNat (2 ^ addrSize))+fifoDF_mealy :: forall addrSize a . KnownNat addrSize => (Vec (2^addrSize) a, BitVector (addrSize + 1), BitVector (addrSize + 1)) -> (a, Bool, Bool) -> ((Vec (2^addrSize) a, BitVector (addrSize + 1), BitVector (addrSize + 1)) ,(a, Bool, Bool)) fifoDF_mealy (mem,rptr,wptr) (wdata,winc,rinc) =- ((mem',rptr',wptr'), (rdata,empty,full))- where- raddr = truncateB rptr :: BitVector addrSize- waddr = truncateB wptr :: BitVector addrSize+ let raddr = truncateB rptr :: BitVector addrSize+ waddr = truncateB wptr :: BitVector addrSize - mem' | winc && not full = replace waddr wdata mem- | otherwise = mem+ mem' | winc && not full = replace waddr wdata mem+ | otherwise = mem - rdata = mem !! raddr+ rdata = mem !! raddr - rptr' = rptr + boolToBV (rinc && not empty)- wptr' = wptr + boolToBV (winc && not full)- empty = rptr == wptr- full = msb rptr /= msb wptr && raddr == waddr+ rptr' = rptr + boolToBV (rinc && not empty)+ wptr' = wptr + boolToBV (winc && not full)+ empty = rptr == wptr+ full = msb rptr /= msb wptr && raddr == waddr+ in ((mem',rptr',wptr'), (rdata,empty,full)) -- | Create a FIFO buffer adhering to the 'DataFlow' protocol. Can be filled -- with initial content.@@ -200,11 +198,7 @@ -- fifo4 = 'fifoDF' d4 (2 :> 3 :> Nil) -- @ fifoDF :: forall addrSize m n a nm rate .- (KnownNat addrSize,- KnownNat n, KnownNat m,- KnownNat (2 ^ addrSize),- KnownNat (addrSize + 1),- (m + n) ~ (2 ^ addrSize),+ (KnownNat addrSize, KnownNat n, KnownNat m, (m + n) ~ (2 ^ addrSize), KnownSymbol nm, KnownNat rate) => SNat (m + n) -- ^ Depth of the FIFO buffer. Must be a power of two. -> Vec m a -- ^ Initial content. Can be smaller than the size of the@@ -217,7 +211,7 @@ initMem = iS ++ repeat undefined :: Vec (m + n) a initS = (initMem,initRdPtr,initWrPtr) (o,empty,full) = mealyB' clk fifoDF_mealy initS (i,iV,oR)- in (o,not1 empty, not1 full)+ in (o,not <$> empty, not <$> full) -- | Identity circuit --@@ -239,24 +233,22 @@ -- the second halve unchanged. -- -- <<doc/firstDF.svg>>-firstDF :: (KnownSymbol nm, KnownNat rate)- => DataFlow' ('Clk nm rate) aEn bEn a b- -> DataFlow' ('Clk nm rate) (aEn,cEn) (bEn,cEn) (a,c) (b,c)-firstDF (DF f) = DF (\ac acV bcR -> let clk = sclock- (a,c) = unbundle' clk ac- (aV,cV) = unbundle' clk acV- (bR,cR) = unbundle' clk bcR+firstDF :: DataFlow' clk aEn bEn a b+ -> DataFlow' clk (aEn,cEn) (bEn,cEn) (a,c) (b,c)+firstDF (DF f) = DF (\ac acV bcR -> let (a,c) = unbundle ac+ (aV,cV) = unbundle acV+ (bR,cR) = unbundle bcR (b,bV,aR) = f a aV bR- bc = bundle' clk (b,c)- bcV = bundle' clk (bV,cV)- acR = bundle' clk (aR,cR)+ bc = bundle (b,c)+ bcV = bundle (bV,cV)+ acR = bundle (aR,cR) in (bc,bcV,acR) ) -- | Swap the two communication channels. -- -- <<doc/swapDF.svg>>-swapDF :: DataFlow' ('Clk nm rate) (aEn,bEn) (bEn,aEn) (a,b) (b,a)+swapDF :: DataFlow' clk (aEn,bEn) (bEn,aEn) (a,b) (b,a) swapDF = DF (\ab abV baR -> (swap <$> ab, swap <$> abV, swap <$> baR)) where swap ~(a,b) = (b,a)@@ -265,37 +257,34 @@ -- the first halve unchanged. -- -- <<doc/secondDF.svg>>-secondDF :: (KnownSymbol nm, KnownNat rate)- => DataFlow' ('Clk nm rate) aEn bEn a b- -> DataFlow' ('Clk nm rate) (cEn,aEn) (cEn,bEn) (c,a) (c,b)+secondDF :: DataFlow' clk aEn bEn a b+ -> DataFlow' clk (cEn,aEn) (cEn,bEn) (c,a) (c,b) secondDF f = swapDF `seqDF` firstDF f `seqDF` swapDF -- | Compose two 'DataFlow' circuits in parallel. -- -- <<doc/parDF.svg>>-parDF :: (KnownSymbol nm, KnownNat rate)- => DataFlow' ('Clk nm rate) aEn bEn a b- -> DataFlow' ('Clk nm rate) cEn dEn c d- -> DataFlow' ('Clk nm rate) (aEn,cEn) (bEn,dEn) (a,c) (b,d)+parDF :: DataFlow' clk aEn bEn a b+ -> DataFlow' clk cEn dEn c d+ -> DataFlow' clk (aEn,cEn) (bEn,dEn) (a,c) (b,d) f `parDF` g = firstDF f `seqDF` secondDF g -- | Compose /n/ 'DataFlow' circuits in parallel.-parNDF :: (KnownSymbol nm, KnownNat rate, KnownNat n)- => Vec n (DataFlow' ('Clk nm rate) aEn bEn a b)- -> DataFlow' ('Clk nm rate)+parNDF :: KnownNat n+ => Vec n (DataFlow' clk aEn bEn a b)+ -> DataFlow' clk (Vec n aEn) (Vec n bEn) (Vec n a) (Vec n b) parNDF fs = DF (\as aVs bRs ->- let clk = sclock- as' = unbundle' clk as- aVs' = unbundle' clk aVs- bRs' = unbundle' clk bRs+ let as' = unbundle as+ aVs' = unbundle aVs+ bRs' = unbundle bRs (bs,bVs,aRs) = unzip3 (zipWith (\k (a,b,r) -> df k a b r) fs (zip3 (lazyV as') (lazyV aVs') bRs'))- in (bundle' clk bs,bundle' clk bVs, bundle' clk aRs)+ in (bundle bs,bundle bVs, bundle aRs) ) -- | Feed back the second halve of the communication channel. The feedback loop@@ -340,9 +329,8 @@ -- @ -- -- <<doc/loopDF_sync.svg>>-loopDF :: (KnownNat m, KnownNat n, KnownNat rate, KnownNat addrSize- ,KnownNat (2 ^ addrSize), KnownNat (addrSize + 1), KnownSymbol nm- ,(m+n) ~ (2^addrSize))+loopDF :: (KnownNat m, KnownNat n, KnownNat addrSize, KnownNat rate+ ,KnownSymbol nm,(m+n) ~ (2^addrSize)) => SNat (m + n) -- ^ Depth of the FIFO buffer. Must be a power of two -> Vec m d -- ^ Initial content of the FIFO buffer. Can be smaller than -- the size of the FIFO. Empty spaces are initialised with@@ -350,32 +338,29 @@ -> DataFlow' ('Clk nm rate) (Bool,Bool) (Bool,Bool) (a,d) (b,d) -> DataFlow' ('Clk nm rate) Bool Bool a b loopDF sz is (DF f) =- DF (\a aV bR -> let clk = sclock- (bd,bdV,adR) = f ad adV bdR- (b,d) = unbundle' clk bd- (bV,dV) = unbundle' clk bdV- (aR,dR) = unbundle' clk adR+ DF (\a aV bR -> let (bd,bdV,adR) = f ad adV bdR+ (b,d) = unbundle bd+ (bV,dV) = unbundle bdV+ (aR,dR) = unbundle adR (d_buf,dV_buf,dR_buf) = df (fifoDF sz is) d dV dR - ad = bundle' clk (a,d_buf)- adV = bundle' clk (aV,dV_buf)- bdR = bundle' clk (bR,dR_buf)+ ad = bundle (a,d_buf)+ adV = bundle (aV,dV_buf)+ bdR = bundle (bR,dR_buf) in (b,bV,aR) ) -- | Feed back the second halve of the communication channel. Unlike 'loopDF', -- the feedback loop is /not/ buffered.-loopDF_nobuf :: (KnownSymbol nm, KnownNat rate)- => DataFlow' ('Clk nm rate) (Bool,Bool) (Bool,Bool) (a,d) (b,d)- -> DataFlow' ('Clk nm rate) Bool Bool a b-loopDF_nobuf (DF f) = DF (\a aV bR -> let clk = sclock- (bd,bdV,adR) = f ad adV bdR- (b,d) = unbundle' clk bd- (bV,dV) = unbundle' clk bdV- (aR,dR) = unbundle' clk adR- ad = bundle' clk (a,d)- adV = bundle' clk (aV,dV)- bdR = bundle' clk (bR,dR)+loopDF_nobuf :: DataFlow' clk (Bool,Bool) (Bool,Bool) (a,d) (b,d)+ -> DataFlow' clk Bool Bool a b+loopDF_nobuf (DF f) = DF (\a aV bR -> let (bd,bdV,adR) = f ad adV bdR+ (b,d) = unbundle bd+ (bV,dV) = unbundle bdV+ (aR,dR) = unbundle adR+ ad = bundle (a,d)+ adV = bundle (aV,dV)+ bdR = bundle (bR,dR) in (b,bV,aR) ) @@ -445,8 +430,7 @@ -- @ -- -- Does the right thing.- lockStep :: (KnownNat rate,KnownSymbol nm)- => DataFlow' ('Clk nm rate) a Bool b b+ lockStep :: DataFlow' clk a Bool b b -- | Extend the synchronisation granularity from a single 'Bool'ean value. --@@ -512,8 +496,7 @@ -- @ -- -- Does the right thing.- stepLock :: (KnownNat rate,KnownSymbol nm)- => DataFlow' ('Clk nm rate) Bool a b b+ stepLock :: DataFlow' clk Bool a b b instance LockStep Bool c where lockStep = idDF@@ -521,37 +504,36 @@ instance (LockStep a x, LockStep b y) => LockStep (a,b) (x,y) where lockStep = (lockStep `parDF` lockStep) `seqDF`- (DF (\xy xyV rdy -> let clk = sclock- (xV,yV) = unbundle' clk xyV+ (DF (\xy xyV rdy -> let (xV,yV) = unbundle xyV val = xV .&&. yV xR = yV .&&. rdy yR = xV .&&. rdy- xyR = bundle' clk (xR,yR)+ xyR = bundle (xR,yR) in (xy,val,xyR))) - stepLock = (DF (\xy val xyR -> let clk = sclock- (xR,yR) = unbundle' clk xyR+ stepLock = (DF (\xy val xyR -> let (xR,yR) = unbundle xyR rdy = xR .&&. yR xV = val .&&. yR yV = val .&&. xR- xyV = bundle' clk (xV,yV)+ xyV = bundle (xV,yV) in (xy,xyV,rdy))) `seqDF` (stepLock `parDF` stepLock) -instance (LockStep en a, KnownNat m, m ~ (n + 1), KnownNat (n+1)) =>- LockStep (Vec m en) (Vec m a) where+instance (LockStep en a, KnownNat n) => LockStep (Vec n en) (Vec n a) where lockStep = parNDF (repeat lockStep) `seqDF` DF (\xs vals rdy ->- let val = and <$> vals- rdys = allReady <$> rdy <*> (repeat <$> vals)+ let val = (and . (True :>)) <$> vals+ rdys = allReady <$> rdy <*> (repeat . (:< True) <$> vals) in (xs,val,rdys) ) stepLock = DF (\xs val rdys ->- let rdy = and <$> rdys- vals = allReady <$> val <*> (repeat <$> rdys)+ let rdy = (and . (True :>)) <$> rdys+ vals = allReady <$> val <*> (repeat . (:< True) <$> rdys) in (xs,vals,rdy) ) `seqDF` parNDF (repeat stepLock) -allReady :: KnownNat (n+1) => Bool -> Vec (n+1) (Vec (n+1) Bool)- -> Vec (n+1) Bool+allReady :: KnownNat n+ => Bool+ -> Vec n (Vec (n+1) Bool)+ -> Vec n Bool allReady b vs = map (and . (b :>) . tail) (smap (flip rotateLeftS) vs)
src/CLaSH/Prelude/Explicit.hs view
@@ -12,13 +12,12 @@ using explicitly clocked signals. -} -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Unsafe #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Prelude.Explicit@@ -74,6 +73,7 @@ {- $setup >>> :set -XDataKinds+>>> import CLaSH.Prelude >>> type ClkA = Clk "A" 100 >>> let clkA = sclock :: SClock ClkA >>> let window4 = window' clkA :: Signal' ClkA Int -> Vec 4 (Signal' ClkA Int)@@ -93,8 +93,9 @@ -- window4 = 'window'' clkA -- @ ----- >>> simulateB' clkA clkA window4 [1::Int,2,3,4,5] :: [Vec 4 Int]+-- >>> simulateB 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>...+-- ... window' :: (KnownNat n, Default a) => SClock clk -- ^ Clock to which the incoming -- signal is synchronized@@ -102,7 +103,7 @@ -> Vec (n + 1) (Signal' clk a) -- ^ Window of at least size 1 window' clk x = res where- res = x `Cons` prev+ res = x :> prev prev = case natVal (asNatProxy prev) of 0 -> repeat def _ -> let next = x +>> prev@@ -121,14 +122,15 @@ -- windowD3 = 'windowD'' clkA -- @ ----- >>> simulateB' clkA clkA windowD3 [1::Int,2,3,4] :: [Vec 3 Int]+-- >>> simulateB windowD3 [1::Int,2,3,4] :: [Vec 3 Int] -- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>...-windowD' :: (KnownNat (n + 1), Default a)+-- ...+windowD' :: (KnownNat n, Default a) => SClock clk -- ^ Clock to which the incoming signal -- is synchronized -> Signal' clk a -- ^ Signal to create a window over -> Vec (n + 1) (Signal' clk a) -- ^ Window of at least size 1-windowD' clk x = prev- where- prev = registerB' clk (repeat def) next- next = x +>> prev+windowD' clk x =+ let prev = registerB' clk (repeat def) next+ next = x +>> prev+ in prev
src/CLaSH/Prelude/Explicit/Safe.hs view
@@ -60,10 +60,12 @@ import CLaSH.Prelude.ROM (rom', romPow2') import CLaSH.Prelude.Synchronizer (dualFlipFlopSynchronizer, asyncFIFOSynchronizer)+import CLaSH.Signal.Bundle (Bundle(..), Unbundled') import CLaSH.Signal.Explicit {- $setup >>> :set -XDataKinds+>>> import CLaSH.Prelude >>> type ClkA = Clk "A" 100 >>> let clkA = sclock :: SClock ClkA >>> let rP = registerB' clkA (8::Int,8::Int)@@ -83,10 +85,11 @@ -- rP = 'registerB'' clkA (8,8) -- @ ----- >>> simulateB' clkA clkA rP [(1,1),(2,2),(3,3)] :: [(Int,Int)]+-- >>> simulateB rP [(1,1),(2,2),(3,3)] :: [(Int,Int)] -- [(8,8),(1,1),(2,2),(3,3)...+-- ... registerB' :: Bundle a => SClock clk -> a -> Unbundled' clk a -> Unbundled' clk a-registerB' clk i = unbundle' clk Prelude.. register' clk i Prelude.. bundle' clk+registerB' clk i = unbundle Prelude.. register' clk i Prelude.. bundle {-# INLINABLE isRising' #-} -- | Give a pulse when the 'Signal'' goes from 'minBound' to 'maxBound'
src/CLaSH/Prelude/Mealy.hs view
@@ -67,6 +67,7 @@ -- -- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)] -- [0,1,5,14...+-- ... -- -- Synchronous sequential functions can be composed just like their -- combinational counterpart:@@ -158,6 +159,7 @@ -- -- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)] -- [0,1,5,14...+-- ... -- -- Synchronous sequential functions can be composed just like their -- combinational counterpart:@@ -178,7 +180,7 @@ -> (Signal' clk i -> Signal' clk o) -- ^ Synchronous sequential function with input and output matching that -- of the mealy machine-mealy' clk f iS = \i -> let (s',o) = unbundle' clk $ f <$> s <*> i+mealy' clk f iS = \i -> let (s',o) = unbundle $ f <$> s <*> i s = register' clk iS s' in o @@ -217,4 +219,4 @@ -> (Unbundled' clk i -> Unbundled' clk o) -- ^ Synchronous sequential function with input and output matching that -- of the mealy machine-mealyB' clk f iS i = unbundle' clk (mealy' clk f iS (bundle' clk i))+mealyB' clk f iS i = unbundle (mealy' clk f iS (bundle i))
src/CLaSH/Prelude/Moore.hs view
@@ -16,9 +16,13 @@ ( -- * Moore machine synchronised to the system clock moore , mooreB+ , medvedev+ , medvedevB -- * Moore machine synchronised to an arbitrary clock , moore' , mooreB'+ , medvedev'+ , medvedevB' ) where @@ -58,6 +62,7 @@ -- -- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)] -- [0,1,5,14...+-- ... -- -- Synchronous sequential functions can be composed just like their -- combinational counterpart:@@ -81,6 +86,12 @@ -- of the moore machine moore = moore' systemClock +{-# INLINE medvedev #-}+-- | Create a synchronous function from a combinational function describing+-- a moore machine without any output logic+medvedev :: (s -> i -> s) -> s -> Signal i -> Signal s+medvedev tr st = moore tr id st+ {-# INLINE mooreB #-} -- | A version of 'moore' that does automatic 'Bundle'ing --@@ -120,6 +131,11 @@ -- of the moore machine mooreB = mooreB' systemClock +{-# INLINE medvedevB #-}+-- | A version of 'medvedev' that does automatic 'Bundle'ing+medvedevB :: (Bundle i, Bundle s) => (s -> i -> s) -> s -> Unbundled i -> Unbundled s+medvedevB tr st = mooreB tr id st+ {-# INLINABLE moore' #-} -- | Create a synchronous function from a combinational function describing -- a moore machine@@ -141,6 +157,7 @@ -- -- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)] -- [0,1,5,14...+-- ... -- -- Synchronous sequential functions can be composed just like their -- combinational counterpart:@@ -167,6 +184,12 @@ s = register' clk iS s' in fo <$> s +{-# INLINE medvedev' #-}+-- | Create a synchronous function from a combinational function describing+-- a moore machine without any output logic+medvedev' :: SClock clk -> (s -> i -> s) -> s -> (Signal' clk i -> Signal' clk s)+medvedev' clk tr st = moore' clk tr id st+ {-# INLINE mooreB' #-} -- | A version of 'moore'' that does automatic 'Bundle'ing --@@ -205,4 +228,9 @@ -> (Unbundled' clk i -> Unbundled' clk o) -- ^ Synchronous sequential function with input and output matching that -- of the moore machine-mooreB' clk ft fo iS i = unbundle' clk (moore' clk ft fo iS (bundle' clk i))+mooreB' clk ft fo iS i = unbundle (moore' clk ft fo iS (bundle i))++{-# INLINE medvedevB' #-}+-- | A version of 'medvedev'' that does automatic 'Bundle'ing+medvedevB' :: (Bundle i, Bundle s) => SClock clk -> (s -> i -> s) -> s -> Unbundled' clk i -> Unbundled' clk s+medvedevB' clk tr st = mooreB' clk tr id st
src/CLaSH/Prelude/RAM.hs view
@@ -11,16 +11,15 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} -- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c -- as to why we need this.-#if __GLASGOW_HASKELL__ > 711 {-# OPTIONS_GHC -fno-cpr-anal #-}-#endif {-# OPTIONS_HADDOCK show-extensions #-} @@ -36,17 +35,21 @@ ) where +import Control.Exception (catch, evaluate, throw) import Control.Monad (when) import Control.Monad.ST.Lazy (ST,runST)-import Data.Array.MArray.Safe (newArray_,readArray,writeArray)+import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST)+import Data.Array.MArray.Safe (newListArray,readArray,writeArray) import Data.Array.ST.Safe (STArray)-import GHC.TypeLits (KnownNat, type (^))+import Data.Maybe (fromJust, isJust)+import GHC.TypeLits (KnownNat) -import CLaSH.Promoted.Nat (SNat,snat,snatToInteger)+import CLaSH.Promoted.Nat (SNat (..), snatToNum, pow2SNat) import CLaSH.Signal (Signal)-import CLaSH.Signal.Bundle (bundle')+import CLaSH.Signal.Bundle (bundle) import CLaSH.Signal.Explicit (Signal', SClock, systemClock, unsafeSynchronizer) import CLaSH.Sized.Unsigned (Unsigned)+import CLaSH.XException (XException, errorX) {-# INLINE asyncRam #-} -- | Create a RAM with space for @n@ elements.@@ -59,10 +62,9 @@ -- RAM. asyncRam :: Enum addr => SNat n -- ^ Size @n@ of the RAM- -> Signal addr -- ^ Write address @w@ -> Signal addr -- ^ Read address @r@- -> Signal Bool -- ^ Write enable- -> Signal a -- ^ Value to write (at address @w@)+ -> Signal (Maybe (addr, a))+ -- ^ (write address @w@, value to write) -> Signal a -- ^ Value of the @RAM@ at address @r@ asyncRam = asyncRam' systemClock systemClock @@ -75,13 +77,12 @@ -- -- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a -- RAM.-asyncRamPow2 :: forall n a . (KnownNat (2^n), KnownNat n)- => Signal (Unsigned n) -- ^ Write address @w@- -> Signal (Unsigned n) -- ^ Read address @r@- -> Signal Bool -- ^ Write enable- -> Signal a -- ^ Value to write (at address @w@)+asyncRamPow2 :: KnownNat n+ => Signal (Unsigned n) -- ^ Read address @r@+ -> Signal (Maybe (Unsigned n, a))+ -- ^ (write address @w@, value to write) -> Signal a -- ^ Value of the @RAM@ at address @r@-asyncRamPow2 = asyncRam' systemClock systemClock (snat :: SNat (2^n))+asyncRamPow2 = asyncRamPow2' systemClock systemClock {-# INLINE asyncRamPow2' #-} -- | Create a RAM with space for 2^@n@ elements@@ -93,19 +94,18 @@ -- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a -- RAM. asyncRamPow2' :: forall wclk rclk n a .- (KnownNat n, KnownNat (2^n))+ KnownNat n => SClock wclk -- ^ 'Clock' to which to synchronise -- the write port of the RAM -> SClock rclk -- ^ 'Clock' to which the read -- address signal, @r@, is -- synchronised- -> Signal' wclk (Unsigned n) -- ^ Write address @w@ -> Signal' rclk (Unsigned n) -- ^ Read address @r@- -> Signal' wclk Bool -- ^ Write enable- -> Signal' wclk a -- ^ Value to write (at address @w@)- -> Signal' rclk a+ -> Signal' wclk (Maybe (Unsigned n, a))+ -- ^ (write address @w@, value to write)+ -> Signal' rclk a -- ^ Value of the @RAM@ at address @r@-asyncRamPow2' wclk rclk = asyncRam' wclk rclk (snat :: SNat (2^n))+asyncRamPow2' wclk rclk = asyncRam' wclk rclk (pow2SNat (SNat @ n)) {-# INLINE asyncRam' #-} -- | Create a RAM with space for @n@ elements@@ -122,14 +122,18 @@ -> SClock rclk -- ^ 'Clock' to which the read address signal, -- @r@, is synchronised -> SNat n -- ^ Size @n@ of the RAM- -> Signal' wclk addr -- ^ Write address @w@ -> Signal' rclk addr -- ^ Read address @r@- -> Signal' wclk Bool -- ^ Write enable- -> Signal' wclk a -- ^ Value to write (at address @w@)+ -> Signal' wclk (Maybe (addr, a))+ -- ^ (write address @w@, value to write) -> Signal' rclk a -- ^ Value of the @RAM@ at address @r@-asyncRam' wclk rclk sz wr rd en din = asyncRam# wclk rclk sz (fromEnum <$> wr)- (fromEnum <$> rd) en din+asyncRam' wclk rclk sz rd wrM =+ asyncRam# wclk rclk sz+ (fromEnum <$> rd)+ (isJust <$> wrM)+ ((fromEnum . fst . fromJust) <$> wrM)+ ((snd . fromJust) <$> wrM) + {-# NOINLINE asyncRam# #-} -- | RAM primitive asyncRam# :: SClock wclk -- ^ 'Clock' to which to synchronise the write@@ -137,21 +141,27 @@ -> SClock rclk -- ^ 'Clock' to which the read address signal, -- @r@, is synchronised -> SNat n -- ^ Size @n@ of the RAM- -> Signal' wclk Int -- ^ Write address @w@ -> Signal' rclk Int -- ^ Read address @r@ -> Signal' wclk Bool -- ^ Write enable+ -> Signal' wclk Int -- ^ Write address @w@ -> Signal' wclk a -- ^ Value to write (at address @w@) -> Signal' rclk a -- ^ Value of the @RAM@ at address @r@-asyncRam# wclk rclk sz wr rd en din = unsafeSynchronizer wclk rclk dout+asyncRam# wclk rclk sz rd en wr din = unsafeSynchronizer wclk rclk dout where- szI = fromInteger $ snatToInteger sz+ szI = snatToNum sz rd' = unsafeSynchronizer rclk wclk rd dout = runST $ do- arr <- newArray_ (0,szI-1)- traverse (ramT arr) (bundle' wclk (wr,rd',en,din))+ arr <- newListArray (0,szI-1) (replicate szI (errorX "asyncRam#: initial value undefined"))+ traverse (ramT arr) (bundle (rd',en,wr,din)) - ramT :: STArray s Int e -> (Int,Int,Bool,e) -> ST s e- ramT ram (w,r,e,d) = do- d' <- readArray ram r+ ramT :: STArray s Int e -> (Int,Bool,Int,e) -> ST s e+ ramT ram (r,e,w,d) = do+ -- reading from address using an 'X' exception results in an 'X' result+ r' <- unsafeIOToST (catch (evaluate r >>= (return . Right))+ (\(err :: XException) -> return (Left (throw err))))+ d' <- case r' of+ Right r2 -> readArray ram r2+ Left err -> return err+ -- writing to an address using an 'X' exception makes everything 'X' when e (writeArray ram w d) return d'
src/CLaSH/Prelude/ROM.hs view
@@ -6,13 +6,13 @@ ROMs -} -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Prelude.ROM@@ -33,12 +33,14 @@ import Data.Array ((!),listArray) import GHC.TypeLits (KnownNat, type (^))+import Prelude hiding (length) import CLaSH.Signal (Signal) import CLaSH.Signal.Explicit (Signal', SClock, systemClock) import CLaSH.Sized.Unsigned (Unsigned) import CLaSH.Signal.Explicit (register')-import CLaSH.Sized.Vector (Vec, maxIndex, toList)+import CLaSH.Sized.Vector (Vec, length, toList)+import CLaSH.XException (errorX) {-# INLINE asyncRom #-} -- | An asynchronous/combinational ROM with space for @n@ elements@@ -62,7 +64,7 @@ -- -- * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams" -- for ideas on how to use ROMs and RAMs-asyncRomPow2 :: (KnownNat (2^n), KnownNat n)+asyncRomPow2 :: KnownNat n => Vec (2^n) a -- ^ ROM content -- -- __NB:__ must be a constant@@ -80,8 +82,8 @@ -> a -- ^ The value of the ROM at address @rd@ asyncRom# content rd = arr ! rd where- szI = maxIndex content- arr = listArray (0,szI) (toList content)+ szI = length content+ arr = listArray (0,szI-1) (toList content) {-# INLINE rom #-} -- | A ROM with a synchronous read port, with space for @n@ elements@@ -111,13 +113,13 @@ -- -- * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams" -- for ideas on how to use ROMs and RAMs-romPow2 :: (KnownNat (2^n), KnownNat n)+romPow2 :: KnownNat n => Vec (2^n) a -- ^ ROM content -- -- __NB:__ must be a constant -> Signal (Unsigned n) -- ^ Read address @rd@ -> Signal a -- ^ The value of the ROM at address @rd@-romPow2 = rom' systemClock+romPow2 = romPow2' systemClock {-# INLINE romPow2' #-} -- | A ROM with a synchronous read port, with space for 2^@n@ elements@@ -129,7 +131,7 @@ -- -- * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams" -- for ideas on how to use ROMs and RAMs-romPow2' :: (KnownNat (2^n), KnownNat n)+romPow2' :: KnownNat n => SClock clk -- ^ 'Clock' to synchronize to -> Vec (2^n) a -- ^ ROM content --@@ -168,7 +170,7 @@ -> Signal' clk Int -- ^ Read address @rd@ -> Signal' clk a -- ^ The value of the ROM at address @rd@ from the previous clock cycle-rom# clk content rd = register' clk undefined ((arr !) <$> rd)+rom# clk content rd = register' clk (errorX "rom#: initial value undefined") ((arr !) <$> rd) where- szI = maxIndex content- arr = listArray (0,szI) (toList content)+ szI = length content+ arr = listArray (0,szI-1) (toList content)
src/CLaSH/Prelude/ROM/File.hs view
@@ -65,6 +65,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Unsafe #-}@@ -88,15 +89,16 @@ where import Data.Array (listArray,(!))-import GHC.TypeLits (KnownNat, type (^))+import GHC.TypeLits (KnownNat) import System.IO.Unsafe (unsafePerformIO) import CLaSH.Prelude.BlockRam.File (initMem)-import CLaSH.Promoted.Nat (SNat,snat,snatToInteger)+import CLaSH.Promoted.Nat (SNat (..), pow2SNat, snatToNum) import CLaSH.Sized.BitVector (BitVector) import CLaSH.Signal (Signal) import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock) import CLaSH.Sized.Unsigned (Unsigned)+import CLaSH.XException (errorX) {-# INLINE asyncRomFile #-} -- | An asynchronous/combinational ROM with space for @n@ elements@@ -164,7 +166,7 @@ -- > where -- > mem = unsafePerformIO (initMem file) -- > content = listArray (0,szI-1) mem--- > szI = fromInteger (snatToInteger sz)+-- > szI = snatToNum sz -- -- We write: --@@ -172,7 +174,7 @@ -- > where -- > mem = unsafePerformIO (initMem file) -- > content = listArray (0,szI-1) mem--- > szI = fromInteger (snatToInteger sz)+-- > szI = snatToNum sz -- -- Where instead of returning the BitVector defined by @(content ! rd)@, we -- return the function (thunk) @(content !)@.@@ -213,11 +215,11 @@ -- myRomData :: Unsigned 9 -> BitVector 16 -- myRomData = asyncRomFilePow2 "memory.bin" -- @-asyncRomFilePow2 :: forall n m . (KnownNat m, KnownNat n, KnownNat (2^n))+asyncRomFilePow2 :: forall n m . (KnownNat m, KnownNat n) => FilePath -- ^ File describing the content of the ROM -> Unsigned n -- ^ Read address @rd@ -> BitVector m -- ^ The value of the ROM at address @rd@-asyncRomFilePow2 = asyncRomFile (snat :: SNat (2^n))+asyncRomFilePow2 = asyncRomFile (pow2SNat (SNat @ n)) {-# NOINLINE asyncRomFile# #-} -- | asyncROMFile primitive@@ -230,7 +232,7 @@ where -- Note [Eta-reduction and unsafePerformIO initMem] mem = unsafePerformIO (initMem file) content = listArray (0,szI-1) mem- szI = fromInteger (snatToInteger sz)+ szI = snatToNum sz {-# INLINE romFile #-} -- | A ROM with a synchronous read port, with space for @n@ elements@@ -256,10 +258,10 @@ -- 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.-romFile :: (KnownNat m, KnownNat k)+romFile :: (KnownNat m, KnownNat n) => SNat n -- ^ Size of the ROM -> FilePath -- ^ File describing the content of the ROM- -> Signal (Unsigned k) -- ^ Read address @rd@+ -> Signal (Unsigned n) -- ^ Read address @rd@ -> Signal (BitVector m) -- ^ The value of the ROM at address @rd@ from the previous clock cycle romFile = romFile' systemClock@@ -288,12 +290,12 @@ -- 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.-romFilePow2 :: forall n m . (KnownNat m, KnownNat n, KnownNat (2^n))+romFilePow2 :: forall n m . (KnownNat m, KnownNat n) => FilePath -- ^ File describing the content of the ROM -> Signal (Unsigned n) -- ^ Read address @rd@ -> Signal (BitVector m) -- ^ The value of the ROM at address @rd@ from the previous clock cycle-romFilePow2 = romFile' systemClock (snat :: SNat (2^n))+romFilePow2 = romFilePow2' systemClock {-# INLINE romFilePow2' #-} -- | A ROM with a synchronous read port, with space for 2^@n@ elements@@ -319,7 +321,7 @@ -- 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.-romFilePow2' :: forall clk n m . (KnownNat m, KnownNat n, KnownNat (2^n))+romFilePow2' :: forall clk n m . (KnownNat m, KnownNat n) => SClock clk -- ^ 'Clock' to synchronize to -> FilePath -- ^ File describing the content of -- the ROM@@ -327,7 +329,7 @@ -> Signal' clk (BitVector m) -- ^ The value of the ROM at address @rd@ from the previous clock -- cycle-romFilePow2' clk = romFile' clk (snat :: SNat (2^n))+romFilePow2' clk = romFile' clk (pow2SNat (SNat @ n)) {-# INLINE romFile' #-} -- | A ROM with a synchronous read port, with space for @n@ elements@@ -373,8 +375,8 @@ -> Signal' clk Int -- ^ Read address @rd@ -> Signal' clk (BitVector m) -- ^ The value of the ROM at address @rd@ from the previous clock cycle-romFile# clk sz file rd = register' clk undefined ((content !) <$> rd)+romFile# clk sz file rd = register' clk (errorX "romFile#: initial value undefined") ((content !) <$> rd) where mem = unsafePerformIO (initMem file) content = listArray (0,szI-1) mem- szI = fromInteger (snatToInteger sz)+ szI = snatToNum sz
src/CLaSH/Prelude/Safe.hs view
@@ -27,7 +27,6 @@ Some circuit examples can be found in "CLaSH.Examples". -} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-}@@ -90,8 +89,6 @@ , module CLaSH.Promoted.Nat , module CLaSH.Promoted.Nat.Literals , module CLaSH.Promoted.Nat.TH- -- ** Type-level functions- , module CLaSH.Promoted.Ord -- ** Type classes -- *** CLaSH , module CLaSH.Class.BitPack@@ -100,6 +97,11 @@ -- *** Other , module Control.Applicative , module Data.Bits+ -- ** Exceptions+ , module CLaSH.XException+ , undefined+ -- ** Named types+ , module CLaSH.NamedTypes -- ** Haskell Prelude -- $hiding , module Prelude@@ -108,23 +110,22 @@ import Control.Applicative import Data.Bits+import GHC.Stack import GHC.TypeLits-#if MIN_VERSION_ghc_typelits_extra(0,2,0)-import GHC.TypeLits.Extra hiding (Max, Min)-#else import GHC.TypeLits.Extra-#endif import Prelude hiding ((++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, splitAt, tail, take, unzip, unzip3,- zip, zip3, zipWith, zipWith3)+ zip, zip3, zipWith, zipWith3,+ undefined) import CLaSH.Annotations.TopEntity import CLaSH.Class.BitPack import CLaSH.Class.Num import CLaSH.Class.Resize+import CLaSH.NamedTypes import CLaSH.Prelude.BitIndex import CLaSH.Prelude.BitReduction import CLaSH.Prelude.BlockRam (blockRam, blockRamPow2, readNew, readNew')@@ -137,7 +138,6 @@ import CLaSH.Promoted.Nat import CLaSH.Promoted.Nat.TH import CLaSH.Promoted.Nat.Literals-import CLaSH.Promoted.Ord import CLaSH.Sized.BitVector import CLaSH.Sized.Fixed import CLaSH.Sized.Index@@ -148,6 +148,7 @@ import CLaSH.Signal import CLaSH.Signal.Delayed import CLaSH.Signal.Explicit (systemClock)+import CLaSH.XException {- $setup >>> let rP = registerB (8,8)@@ -171,8 +172,10 @@ -- -- >>> simulateB rP [(1,1),(2,2),(3,3)] :: [(Int,Int)] -- [(8,8),(1,1),(2,2),(3,3)...+-- ... registerB :: Bundle a => a -> Unbundled a -> Unbundled a registerB = registerB' systemClock+infixr 3 `registerB` {-# INLINE isRising #-} -- | Give a pulse when the 'Signal' goes from 'minBound' to 'maxBound'@@ -189,3 +192,6 @@ -> Signal a -> Signal Bool isFalling = isFalling' systemClock++undefined :: HasCallStack => a+undefined = errorX "undefined"
src/CLaSH/Prelude/Synchronizer.hs view
@@ -6,15 +6,21 @@ Synchronizer circuits for safe clock domain crossings -} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}+ {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Prelude.Synchronizer@@ -25,16 +31,25 @@ ) where +import Control.Applicative (liftA2) import Data.Bits (complement, shiftR, xor)-import GHC.TypeLits (type (+))+import Data.Constraint ((:-)(..), Dict (..))+#if MIN_VERSION_constraints(0,9,0)+import Data.Constraint.Nat (leTrans)+#else+import Unsafe.Coerce+#endif+import Data.Maybe (isJust)+import GHC.TypeLits (type (+), type (-), type (<=)) import CLaSH.Class.BitPack (boolToBV)+import CLaSH.Class.Resize (truncateB) import CLaSH.Prelude.BitIndex (slice) import CLaSH.Prelude.Mealy (mealyB') import CLaSH.Prelude.RAM (asyncRam')-import CLaSH.Promoted.Nat (SNat, powSNat, subSNat)-import CLaSH.Promoted.Nat.Literals (d0, d1, d2)-import CLaSH.Signal ((.&&.), not1)+import CLaSH.Promoted.Nat (SNat (..), pow2SNat)+import CLaSH.Promoted.Nat.Literals (d0)+import CLaSH.Signal (mux) import CLaSH.Signal.Explicit (Signal', SClock, register', unsafeSynchronizer) import CLaSH.Sized.BitVector (BitVector, (++#))@@ -77,78 +92,85 @@ -- * Asynchronous FIFO synchronizer -fifoMem :: _- => SClock wclk- -> SClock rclk- -> SNat addrSize- -> Signal' wclk (BitVector addrSize)- -> Signal' rclk (BitVector addrSize)- -> Signal' wclk Bool- -> Signal' wclk Bool- -> Signal' wclk a- -> Signal' rclk a-fifoMem wclk rclk addrSize waddr raddr winc wfull wdata =+fifoMem ::+ SClock wclk+ -> SClock rclk+ -> SNat addrSize+ -> Signal' wclk Bool+ -> Signal' rclk (BitVector addrSize)+ -> Signal' wclk (Maybe (BitVector addrSize, a))+ -> Signal' rclk a+fifoMem wclk rclk addrSize@SNat full raddr writeM = asyncRam' wclk rclk- (d2 `powSNat` addrSize)- waddr raddr- (winc .&&. not1 wfull)- wdata+ (pow2SNat addrSize)+ raddr+ (mux full (pure Nothing) writeM) -ptrCompareT :: _- => SNat addrSize+ptrCompareT :: SNat addrSize -> (BitVector (addrSize + 1) -> BitVector (addrSize + 1) -> Bool) -> (BitVector (addrSize + 1), BitVector (addrSize + 1), Bool) -> (BitVector (addrSize + 1), Bool) -> ((BitVector (addrSize + 1), BitVector (addrSize + 1), Bool) ,(Bool, BitVector addrSize, BitVector (addrSize + 1)))-ptrCompareT addrSize flagGen (bin,ptr,flag) (s_ptr,inc) = ((bin',ptr',flag')- ,(flag,addr,ptr))+ptrCompareT SNat flagGen (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 = slice (addrSize `subSNat` d1) d0 bin+ addr = truncateB bin flag' = flagGen ptr' s_ptr - -- FIFO full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1:0]}-isFull :: _+isFull :: forall addrSize .+ (2 <= addrSize) => SNat addrSize -> BitVector (addrSize + 1) -> BitVector (addrSize + 1) -> Bool-isFull addrSize ptr s_ptr =- ptr == (complement (slice addrSize (addrSize `subSNat` d1) s_ptr) ++#- slice (addrSize `subSNat` d2) d0 s_ptr)+isFull addrSize@SNat ptr s_ptr = case leTrans @1 @2 @addrSize of+ Sub Dict ->+ let a1 = SNat @(addrSize - 1)+ a2 = SNat @(addrSize - 2)+ in ptr == (complement (slice addrSize a1 s_ptr) ++# slice a2 d0 s_ptr) -- | Synchroniser implemented as a FIFO around an asynchronous 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>. -- -- __NB__: This synchroniser can be used for __word__-synchronization.-asyncFIFOSynchronizer :: _- => SNat addrSize -- ^ Size of the internally used- -- addresses, the FIFO contains- -- @2^addrSize@ elements.- -> SClock wclk -- ^ 'Clock' to which the write port- -- is synchronised- -> SClock rclk -- ^ 'Clock' to which the read port- -- is synchronised- -> Signal' wclk a -- ^ Element to insert- -> Signal' wclk Bool -- ^ Write request- -> Signal' rclk Bool -- ^ Read request- -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool)- -- ^ (Oldest element in the FIFO, @empty@ flag, @full@ flag)-asyncFIFOSynchronizer addrSize wclk rclk wdata winc rinc = (rdata,rempty,wfull)+asyncFIFOSynchronizer+ :: (2 <= addrSize)+ => SNat addrSize -- ^ Size of the internally used addresses, the+ -- FIFO contains @2^addrSize@ elements.+ -> SClock wclk -- ^ 'Clock' to which the write port is synchronised+ -> SClock rclk -- ^ 'Clock' to which the read port is synchronised+ -> Signal' rclk Bool -- ^ Read request+ -> Signal' wclk (Maybe a) -- ^ Element to insert+ -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool)+ -- ^ (Oldest element in the FIFO, @empty@ flag, @full@ flag)+asyncFIFOSynchronizer addrSize@SNat wclk rclk rinc wdataM = (rdata,rempty,wfull) where s_rptr = dualFlipFlopSynchronizer rclk wclk 0 rptr s_wptr = dualFlipFlopSynchronizer wclk rclk 0 wptr - rdata = fifoMem wclk rclk addrSize waddr raddr winc wfull wdata+ rdata = fifoMem wclk rclk addrSize wfull raddr+ (liftA2 (,) <$> (pure <$> waddr) <*> wdataM) (rempty,raddr,rptr) = mealyB' rclk (ptrCompareT addrSize (==)) (0,0,True) (s_wptr,rinc) (wfull,waddr,wptr) = mealyB' wclk (ptrCompareT addrSize (isFull addrSize))- (0,0,False) (s_rptr,winc)+ (0,0,False) (s_rptr,isJust <$> wdataM)++#if !MIN_VERSION_constraints(0,9,0)+axiom :: forall a b . Dict (a ~ b)+axiom = unsafeCoerce (Dict :: Dict (a ~ a))++axiomLe :: forall a b. Dict (a <= b)+axiomLe = axiom++leTrans :: forall a b c. (b <= c, a <= b) :- (a <= c)+leTrans = Sub (axiomLe @a @c)+#endif
src/CLaSH/Prelude/Testbench.hs view
@@ -24,25 +24,25 @@ import Debug.Trace (trace) import GHC.TypeLits (KnownNat)-import Prelude hiding ((!!))+import Prelude hiding ((!!), length) import CLaSH.Signal (Signal, fromList) import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock)-import CLaSH.Signal.Bundle (unbundle')+import CLaSH.Signal.Bundle (unbundle) import CLaSH.Sized.Index (Index)-import CLaSH.Sized.Vector (Vec, (!!), maxIndex)+import CLaSH.Sized.Vector (Vec, (!!), length) {- $setup >>> :set -XTemplateHaskell >>> :set -XDataKinds >>> import CLaSH.Prelude->>> let testInput = stimuliGenerator $(v [(1::Int),3..21])->>> let expectedOutput = outputVerifier $(v ([70,99,2,3,4,5,7,8,9,10]::[Int]))+>>> let testInput = stimuliGenerator $(listToVecTH [(1::Int),3..21])+>>> let expectedOutput = outputVerifier $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int])) >>> import CLaSH.Prelude.Explicit >>> type ClkA = Clk "A" 100 >>> let clkA = sclock :: SClock ClkA->>> let testInput' = stimuliGenerator' clkA $(v [(1::Int),3..21])->>> let expectedOutput' = outputVerifier' clkA $(v ([70,99,2,3,4,5,7,8,9,10]::[Int]))+>>> let testInput' = stimuliGenerator' clkA $(listToVecTH [(1::Int),3..21])+>>> let expectedOutput' = outputVerifier' clkA $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int])) -} {-# INLINE assert #-}@@ -70,7 +70,7 @@ -- -- @ -- testInput :: 'Signal' Int--- testInput = 'stimuliGenerator' $('CLaSH.Sized.Vector.v' [(1::Int),3..21])+-- testInput = 'stimuliGenerator' $('CLaSH.Sized.Vector.listToVecTH' [(1::Int),3..21]) -- @ -- -- >>> sampleN 13 testInput@@ -89,30 +89,30 @@ -- -- @ -- expectedOutput :: 'Signal' Int -> 'Signal' Bool--- expectedOutput = 'outputVerifier' $('CLaSH.Sized.Vector.v' ([70,99,2,3,4,5,7,8,9,10]::[Int]))+-- expectedOutput = 'outputVerifier' $('CLaSH.Sized.Vector.listToVecTH' ([70,99,2,3,4,5,7,8,9,10]::[Int])) -- @ -- -- >>> import qualified Data.List as List -- >>> sampleN 12 (expectedOutput (fromList ([0..10] List.++ [10,10,10])))--- [+-- <BLANKLINE> -- cycle(system1000): 0, outputVerifier -- expected value: 70, not equal to actual value: 0--- False,+-- [False -- cycle(system1000): 1, outputVerifier -- expected value: 99, not equal to actual value: 1--- False,False,False,False,False,+-- ,False,False,False,False,False -- cycle(system1000): 6, outputVerifier -- expected value: 7, not equal to actual value: 6--- False,+-- ,False -- cycle(system1000): 7, outputVerifier -- expected value: 8, not equal to actual value: 7--- False,+-- ,False -- cycle(system1000): 8, outputVerifier -- expected value: 9, not equal to actual value: 8--- False,+-- ,False -- cycle(system1000): 9, outputVerifier -- expected value: 10, not equal to actual value: 9--- False,True,True]+-- ,False,True,True] outputVerifier :: forall l a . (KnownNat l, Eq a, Show a) => Vec l a -- ^ Samples to compare with -> Signal a -- ^ Signal to verify@@ -162,7 +162,7 @@ -- clkA = 'CLaSH.Signal.Explicit.sclock' -- -- testInput' :: 'Signal'' clkA Int--- testInput' = 'stimuliGenerator'' clkA $('CLaSH.Sized.Vector.v' [(1::Int),3..21])+-- testInput' = 'stimuliGenerator'' clkA $('CLaSH.Sized.Vector.listToVecTH' [(1::Int),3..21]) -- @ -- -- >>> sampleN 13 testInput'@@ -173,13 +173,13 @@ -> Vec l a -- ^ Samples to generate -> Signal' clk a -- ^ Signal of given samples stimuliGenerator' clk samples =- let (r,o) = unbundle' clk (genT <$> register' clk 0 r)+ let (r,o) = unbundle (genT <$> register' clk 0 r) in o where genT :: Index l -> (Index l,a) genT s = (s',samples !! s) where- maxI = toEnum (maxIndex samples)+ maxI = toEnum (length samples - 1) s' = if s < maxI then s + 1@@ -199,30 +199,30 @@ -- clkA = 'CLaSH.Signal.Explicit.sclock' -- -- expectedOutput' :: 'Signal'' ClkA Int -> 'Signal'' ClkA Bool--- expectedOutput' = 'outputVerifier'' clkA $('CLaSH.Sized.Vector.v' ([70,99,2,3,4,5,7,8,9,10]::[Int]))+-- expectedOutput' = 'outputVerifier'' clkA $('CLaSH.Sized.Vector.listToVecTH' ([70,99,2,3,4,5,7,8,9,10]::[Int])) -- @ -- -- >>> import qualified Data.List as List -- >>> sampleN 12 (expectedOutput' (fromList ([0..10] List.++ [10,10,10])))--- [+-- <BLANKLINE> -- cycle(A100): 0, outputVerifier -- expected value: 70, not equal to actual value: 0--- False,+-- [False -- cycle(A100): 1, outputVerifier -- expected value: 99, not equal to actual value: 1--- False,False,False,False,False,+-- ,False,False,False,False,False -- cycle(A100): 6, outputVerifier -- expected value: 7, not equal to actual value: 6--- False,+-- ,False -- cycle(A100): 7, outputVerifier -- expected value: 8, not equal to actual value: 7--- False,+-- ,False -- cycle(A100): 8, outputVerifier -- expected value: 9, not equal to actual value: 8--- False,+-- ,False -- cycle(A100): 9, outputVerifier -- expected value: 10, not equal to actual value: 9--- False,True,True]+-- ,False,True,True] outputVerifier' :: forall l clk a . (KnownNat l, Eq a, Show a) => SClock clk -- ^ Clock to which the input signal is -- synchronized to@@ -230,14 +230,14 @@ -> Signal' clk a -- ^ Signal to verify -> Signal' clk Bool -- ^ Indicator that all samples are verified outputVerifier' clk samples i =- let (s,o) = unbundle' clk (genT <$> register' clk 0 s)- (e,f) = unbundle' clk o+ let (s,o) = unbundle (genT <$> register' clk 0 s)+ (e,f) = unbundle o in assert' clk "outputVerifier" i e (register' clk False f) where genT :: Index l -> (Index l,(a,Bool)) genT s = (s',(samples !! s,finished)) where- maxI = toEnum (maxIndex samples)+ maxI = toEnum (length samples - 1) s' = if s < maxI then s + 1
src/CLaSH/Promoted/Nat.hs view
@@ -4,55 +4,118 @@ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Promoted.Nat- ( SNat (..), snat, withSNat, snatToInteger, addSNat, subSNat, mulSNat, powSNat- , UNat (..), toUNat, addUNat, multUNat, powUNat+ ( -- * Singleton natural numbers+ -- ** Data type+ SNat (..)+ -- ** Construction+ , snatProxy+ , withSNat+ , snat+ -- ** Conversion+ , snatToInteger, snatToNum+ -- ** Arithmetic+ , addSNat, mulSNat, powSNat+ -- *** Partial+ , subSNat, divSNat, modSNat, flogBaseSNat, clogBaseSNat, logBaseSNat+ -- *** Specialised+ , pow2SNat+ -- * Unary/Peano-encoded natural numbers+ -- ** Data type+ , UNat (..)+ -- ** Construction+ , toUNat+ -- ** Conversion+ , fromUNat+ -- ** Arithmetic+ , addUNat, mulUNat, powUNat+ -- *** Partial+ , predUNat, subUNat+ -- * Base-2 encoded natural numbers+ -- ** Data type+ , BNat (..)+ -- ** Construction+ , toBNat+ -- ** Conversion+ , fromBNat+ -- ** Pretty printing base-2 encoded natural numbers+ , showBNat+ -- ** Arithmetic+ , succBNat, addBNat, mulBNat, powBNat+ -- *** Partial+ , predBNat, div2BNat, div2Sub1BNat, log2BNat+ -- ** Normalisation+ , stripZeros ) where -import Data.Proxy (Proxy (..))-import Data.Reflection (reifyNat)-import GHC.TypeLits (KnownNat, Nat, type (+), type (-), type (*), type (^),- natVal)-import Unsafe.Coerce (unsafeCoerce)+import GHC.TypeLits (KnownNat, Nat, type (+), type (-), type (*),+ type (^), type (<=), natVal)+import GHC.TypeLits.Extra (CLog, FLog, Div, Log, Mod)+import Language.Haskell.TH (appT, conT, litT, numTyLit, sigE)+import Language.Haskell.TH.Syntax (Lift (..))+import Unsafe.Coerce (unsafeCoerce)+import CLaSH.XException (ShowX (..), showsPrecXWith) +{- $setup+>>> :set -XBinaryLiterals+>>> import CLaSH.Promoted.Nat.Literals (d789)+-}+ -- | Singleton value for a type-level natural number 'n' -- -- * "CLaSH.Promoted.Nat.Literals" contains a list of predefined 'SNat' literals -- * "CLaSH.Promoted.Nat.TH" has functions to easily create large ranges of new -- 'SNat' literals-data SNat (n :: Nat) = KnownNat n => SNat (Proxy n)+data SNat (n :: Nat) where+ SNat :: KnownNat n => SNat n -instance Show (SNat n) where- show (SNat p) = 'd' : show (natVal p)+instance Lift (SNat n) where+ lift s = sigE [| SNat |]+ (appT (conT ''SNat) (litT $ numTyLit (snatToInteger s))) -{-# INLINE snat #-} -- | Create a singleton literal for a type-level natural number snat :: KnownNat n => SNat n-snat = SNat Proxy+snat = SNat+{-# DEPRECATED snat "Use 'SNat' instead of 'snat'" #-} +-- | Create an @`SNat` n@ from a proxy for /n/+snatProxy :: KnownNat n => proxy n -> SNat n+snatProxy _ = SNat++instance Show (SNat n) where+ show p@SNat = 'd' : show (natVal p)++instance ShowX (SNat n) where+ showsPrecX = showsPrecXWith showsPrec+ {-# INLINE withSNat #-} -- | Supply a function with a singleton natural 'n' according to the context withSNat :: KnownNat n => (SNat n -> a) -> a-withSNat f = f (SNat Proxy)+withSNat f = f SNat {-# INLINE snatToInteger #-} -- | Reify the type-level 'Nat' @n@ to it's term-level 'Integer' representation. snatToInteger :: SNat n -> Integer-snatToInteger (SNat p) = natVal p+snatToInteger p@SNat = natVal p +-- | Reify the type-level 'Nat' @n@ to it's term-level 'Num'ber.+snatToNum :: Num a => SNat n -> a+snatToNum p@SNat = fromInteger (natVal p)+{-# INLINE snatToNum #-}+ -- | Unary representation of a type-level natural -- -- __NB__: Not synthesisable@@ -60,55 +123,300 @@ UZero :: UNat 0 USucc :: UNat n -> UNat (n + 1) +instance KnownNat n => Show (UNat n) where+ show x = 'u':show (natVal x)++instance KnownNat n => ShowX (UNat n) where+ showsPrecX = showsPrecXWith showsPrec+ -- | Convert a singleton natural number to its unary representation -- -- __NB__: Not synthesisable toUNat :: SNat n -> UNat n-toUNat (SNat p) = fromI (natVal p)+toUNat p@SNat = fromI (natVal p) where fromI :: Integer -> UNat m fromI 0 = unsafeCoerce UZero fromI n = unsafeCoerce (USucc (fromI (n - 1))) --- | Add two unary singleton natural numbers+-- | Convert a unary-encoded natural number to its singleton representation -- -- __NB__: Not synthesisable+fromUNat :: UNat n -> SNat n+fromUNat UZero = SNat :: SNat 0+fromUNat (USucc x) = addSNat (fromUNat x) (SNat :: SNat 1)++-- | Add two unary-encoded natural numbers+--+-- __NB__: Not synthesisable addUNat :: UNat n -> UNat m -> UNat (n + m) addUNat UZero y = y addUNat x UZero = x addUNat (USucc x) y = USucc (addUNat x y) --- | Multiply two unary singleton natural numbers+-- | Multiply two unary-encoded natural numbers -- -- __NB__: Not synthesisable-multUNat :: UNat n -> UNat m -> UNat (n * m)-multUNat UZero _ = UZero-multUNat _ UZero = UZero-multUNat (USucc x) y = addUNat y (multUNat x y)+mulUNat :: UNat n -> UNat m -> UNat (n * m)+mulUNat UZero _ = UZero+mulUNat _ UZero = UZero+mulUNat (USucc x) y = addUNat y (mulUNat x y) --- | Power of two unary singleton natural numbers+-- | Power of two unary-encoded natural numbers -- -- __NB__: Not synthesisable powUNat :: UNat n -> UNat m -> UNat (n ^ m) powUNat _ UZero = USucc UZero-powUNat x (USucc y) = multUNat x (powUNat x y)+powUNat x (USucc y) = mulUNat x (powUNat x y) +-- | Predecessor of a unary-encoded natural number+--+-- __NB__: Not synthesisable+predUNat :: UNat (n+1) -> UNat n+predUNat (USucc x) = x++-- | Subtract two unary-encoded natural numbers+--+-- __NB__: Not synthesisable+subUNat :: UNat (m+n) -> UNat n -> UNat m+subUNat x UZero = x+subUNat (USucc x) (USucc y) = subUNat x y+subUNat UZero _ = error "impossible: 0 + (n + 1) ~ 0"+ -- | Add two singleton natural numbers addSNat :: SNat a -> SNat b -> SNat (a+b)-addSNat x y = reifyNat (snatToInteger x + snatToInteger y) (unsafeCoerce . SNat)-{-# NOINLINE addSNat #-}+addSNat SNat SNat = SNat+{-# INLINE addSNat #-} -- | Subtract two singleton natural numbers-subSNat :: SNat a -> SNat b -> SNat (a-b)-subSNat x y = reifyNat (snatToInteger x - snatToInteger y) (unsafeCoerce . SNat)-{-# NOINLINE subSNat #-}+subSNat :: SNat (a+b) -> SNat b -> SNat a+subSNat SNat SNat = SNat+{-# INLINE subSNat #-} -- | Multiply two singleton natural numbers mulSNat :: SNat a -> SNat b -> SNat (a*b)-mulSNat x y = reifyNat (snatToInteger x * snatToInteger y) (unsafeCoerce . SNat)-{-# NOINLINE mulSNat #-}+mulSNat SNat SNat = SNat+{-# INLINE mulSNat #-} -- | Power of two singleton natural numbers powSNat :: SNat a -> SNat b -> SNat (a^b)-powSNat x y = reifyNat (snatToInteger x ^ snatToInteger y) (unsafeCoerce . SNat)+powSNat SNat SNat = SNat {-# NOINLINE powSNat #-}++-- | Division of two singleton natural numbers+divSNat :: (1 <= b) => SNat a -> SNat b -> SNat (Div a b)+divSNat SNat SNat = SNat+{-# INLINE divSNat #-}++-- | Modulo of two singleton natural numbers+modSNat :: (1 <= b) => SNat a -> SNat b -> SNat (Mod a b)+modSNat SNat SNat = SNat+{-# INLINE modSNat #-}++-- | Floor of the logarithm of a natural number+flogBaseSNat :: (2 <= base, 1 <= x)+ => SNat base -- ^ Base+ -> SNat x+ -> SNat (FLog base x)+flogBaseSNat SNat SNat = SNat+{-# NOINLINE flogBaseSNat #-}++-- | Ceiling of the logarithm of a natural number+clogBaseSNat :: (2 <= base, 1 <= x)+ => SNat base -- ^ Base+ -> SNat x+ -> SNat (CLog base x)+clogBaseSNat SNat SNat = SNat+{-# NOINLINE clogBaseSNat #-}++-- | Exact integer logarithm of a natural number+--+-- __NB__: Only works when the argument is a power of the base+logBaseSNat :: (FLog base x ~ CLog base x)+ => SNat base -- ^ Base+ -> SNat x+ -> SNat (Log base x)+logBaseSNat SNat SNat = SNat+{-# NOINLINE logBaseSNat #-}++-- | Power of two of a singleton natural number+pow2SNat :: SNat a -> SNat (2^a)+pow2SNat SNat = SNat+{-# INLINE pow2SNat #-}++-- | Base-2 encoded natural number+--+-- * __NB__: The LSB is the left/outer-most constructor:+-- * __NB__: Not synthesisable+--+-- >>> B0 (B1 (B1 BT))+-- b6+--+-- == Constructors+--+-- * Starting/Terminating element:+--+-- @+-- __BT__ :: 'BNat' 0+-- @+--+-- * Append a zero (/0/):+--+-- @+-- __B0__ :: 'BNat' n -> 'BNat' (2 '*' n)+-- @+--+-- * Append a one (/1/):+--+-- @+-- __B1__ :: 'BNat' n -> 'BNat' ((2 '*' n) '+' 1)+-- @+data BNat :: Nat -> * where+ BT :: BNat 0+ B0 :: BNat n -> BNat (2*n)+ B1 :: BNat n -> BNat ((2*n) + 1)++instance KnownNat n => Show (BNat n) where+ show x = 'b':show (natVal x)++instance KnownNat n => ShowX (BNat n) where+ showsPrecX = showsPrecXWith showsPrec++-- | Show a base-2 encoded natural as a binary literal+--+-- __NB__: The LSB is shown as the right-most bit+--+-- >>> d789+-- d789+-- >>> toBNat d789+-- b789+-- >>> showBNat (toBNat d789)+-- "0b1100010101"+-- >>> 0b1100010101 :: Integer+-- 789+showBNat :: BNat n -> String+showBNat = go []+ where+ go :: String -> BNat m -> String+ go xs BT = "0b" ++ xs+ go xs (B0 x) = go ('0':xs) x+ go xs (B1 x) = go ('1':xs) x++-- | Convert a singleton natural number to its base-2 representation+--+-- __NB__: Not synthesisable+toBNat :: SNat n -> BNat n+toBNat s@SNat = toBNat' (natVal s)+ where+ toBNat' :: Integer -> BNat m+ toBNat' 0 = unsafeCoerce BT+ toBNat' n = case n `divMod` 2 of+ (n',1) -> unsafeCoerce (B1 (toBNat' n'))+ (n',_) -> unsafeCoerce (B0 (toBNat' n'))++-- | Convert a base-2 encoded natural number to its singleton representation+--+-- __NB__: Not synthesisable+fromBNat :: BNat n -> SNat n+fromBNat BT = SNat :: SNat 0+fromBNat (B0 x) = mulSNat (SNat :: SNat 2) (fromBNat x)+fromBNat (B1 x) = addSNat (mulSNat (SNat :: SNat 2) (fromBNat x))+ (SNat :: SNat 1)++-- | Add two base-2 encoded natural numbers+--+-- __NB__: Not synthesisable+addBNat :: BNat n -> BNat m -> BNat (n+m)+addBNat (B0 a) (B0 b) = B0 (addBNat a b)+addBNat (B0 a) (B1 b) = B1 (addBNat a b)+addBNat (B1 a) (B0 b) = B1 (addBNat a b)+addBNat (B1 a) (B1 b) = B0 (succBNat (addBNat a b))+addBNat BT b = b+addBNat a BT = a++-- | Multiply two base-2 encoded natural numbers+--+-- __NB__: Not synthesisable+mulBNat :: BNat n -> BNat m -> BNat (n*m)+mulBNat BT _ = BT+mulBNat _ BT = BT+mulBNat (B0 a) b = B0 (mulBNat a b)+mulBNat (B1 a) b = addBNat (B0 (mulBNat a b)) b++-- | Power of two base-2 encoded natural numbers+--+-- __NB__: Not synthesisable+powBNat :: BNat n -> BNat m -> BNat (n^m)+powBNat _ BT = B1 BT+powBNat a (B0 b) = let z = powBNat a b+ in mulBNat z z+powBNat a (B1 b) = let z = powBNat a b+ in mulBNat a (mulBNat z z)++-- | Successor of a base-2 encoded natural number+--+-- __NB__: Not synthesisable+succBNat :: BNat n -> BNat (n+1)+succBNat BT = B1 BT+succBNat (B0 a) = B1 a+succBNat (B1 a) = B0 (succBNat a)++-- | Predecessor of a base-2 encoded natural number+--+-- __NB__: Not synthesisable+predBNat :: BNat (n+1) -> (BNat n)+predBNat (B1 a) = case stripZeros a of+ BT -> BT+ a' -> B0 a'+predBNat (B0 x) = B1 (go x)+ where+ go :: BNat m -> BNat (m-1)+ go (B1 a) = case stripZeros a of+ BT -> BT+ a' -> B0 a'+ go (B0 a) = B1 (go a)+ go BT = error "impossible: 0 ~ 0 - 1"++-- | Divide a base-2 encoded natural number by 2+--+-- __NB__: Not synthesisable+div2BNat :: BNat (2*n) -> BNat n+div2BNat BT = BT+div2BNat (B0 x) = x+div2BNat (B1 _) = error "impossible: 2*n ~ 2*n+1"++-- | Subtract 1 and divide a base-2 encoded natural number by 2+--+-- __NB__: Not synthesisable+div2Sub1BNat :: BNat (2*n+1) -> BNat n+div2Sub1BNat (B1 x) = x+div2Sub1BNat _ = error "impossible: 2*n+1 ~ 2*n"++-- | Get the log2 of a base-2 encoded natural number+--+-- __NB__: Not synthesisable+log2BNat :: BNat (2^n) -> BNat n+log2BNat (B1 x) = case stripZeros x of+ BT -> BT+ _ -> error "impossible: 2^n ~ 2x+1"+log2BNat (B0 x) = succBNat (log2BNat x)++-- | Strip non-contributing zero's from a base-2 encoded natural number+--+-- >>> B1 (B0 (B0 (B0 BT)))+-- b1+-- >>> showBNat (B1 (B0 (B0 (B0 BT))))+-- "0b0001"+-- >>> showBNat (stripZeros (B1 (B0 (B0 (B0 BT)))))+-- "0b1"+-- >>> stripZeros (B1 (B0 (B0 (B0 BT))))+-- b1+--+-- __NB__: Not synthesisable+stripZeros :: BNat n -> BNat n+stripZeros BT = BT+stripZeros (B1 x) = B1 (stripZeros x)+stripZeros (B0 BT) = BT+stripZeros (B0 x) = case stripZeros x of+ BT -> BT+ k -> B0 k
src/CLaSH/Promoted/Nat/Literals.hs view
@@ -8,11 +8,11 @@ Defines: @-d0 = snat :: SNat 0-d1 = snat :: SNat 1-d2 = snat :: SNat 2+d0 = SNat :: SNat 0+d1 = SNat :: SNat 1+d2 = SNat :: SNat 2 ...-d1024 = snat :: SNat 1024+d1024 = SNat :: SNat 1024 @ You can generate more 'SNat' literals using 'decLiteralsD' from "CLaSH.Promoted.Nat.TH"
src/CLaSH/Promoted/Nat/TH.hs view
@@ -23,10 +23,10 @@ {- $setup >>> :set -XDataKinds->>> let d1111 = snat :: SNat 1111->>> let d1200 = snat :: SNat 1200->>> let d1201 = snat :: SNat 1201->>> let d1202 = snat :: SNat 1202+>>> let d1111 = SNat :: SNat 1111+>>> let d1200 = SNat :: SNat 1200+>>> let d1201 = SNat :: SNat 1201+>>> let d1202 = SNat :: SNat 1202 -} -- | Create an 'SNat' literal@@ -42,7 +42,7 @@ let suffix = if n < 0 then error ("Can't make negative SNat: " ++ show n) else show n valName = mkName $ 'd':suffix sig <- sigD valName (appT (conT ''SNat) (litT (numTyLit n)))- val <- valD (varP valName) (normalB [| snat |]) []+ val <- valD (varP valName) (normalB [| SNat |]) [] return [ sig, val ] -- | Create a range of 'SNat' literals
src/CLaSH/Promoted/Nat/Unsafe.hs view
@@ -13,9 +13,9 @@ import Data.Reflection (reifyNat) import Unsafe.Coerce (unsafeCoerce) -import CLaSH.Promoted.Nat (SNat (..))+import CLaSH.Promoted.Nat (SNat, snatProxy) -- | I hope you know what you're doing unsafeSNat :: Integer -> SNat k-unsafeSNat i = reifyNat i (unsafeCoerce . SNat)+unsafeSNat i = reifyNat i $ (\p -> unsafeCoerce (snatProxy p)) {-# NOINLINE unsafeSNat #-}
− src/CLaSH/Promoted/Ord.hs
@@ -1,29 +0,0 @@-{-|-Copyright : (C) 2013-2016, University of Twente-License : BSD2 (see the file LICENSE)-Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>--}--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--{-# LANGUAGE Safe #-}--{-# OPTIONS_HADDOCK show-extensions #-}--module CLaSH.Promoted.Ord where--import Data.Type.Bool-import GHC.TypeLits---- | Type-level 'min' function for natural numbers-type family Min (x :: Nat) (y :: Nat) :: Nat- where- Min x y = If (x <=? y) x y---- | Type-level 'max' function for natural numbers-type family Max (x :: Nat) (y :: Nat) :: Nat- where- Max x y = If (x <=? y) y x
src/CLaSH/Promoted/Symbol.hs view
@@ -13,25 +13,26 @@ {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Promoted.Symbol- (SSymbol (..), ssymbol, ssymbolToString)+ (SSymbol (..), ssymbolProxy, ssymbolToString) where -import Data.Proxy import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -- | Singleton value for a type-level string @s@-data SSymbol (s :: Symbol) = KnownSymbol s => SSymbol (Proxy s)+data SSymbol (s :: Symbol) where+ SSymbol :: KnownSymbol s => SSymbol s instance Show (SSymbol s) where- show (SSymbol s) = symbolVal s+ show s@SSymbol = symbolVal s -{-# INLINE ssymbol #-}--- | Create a singleton literal for a type-level natural number-ssymbol :: KnownSymbol s => SSymbol s-ssymbol = SSymbol Proxy+{-# INLINE ssymbolProxy #-}+-- | Create a singleton symbol literal @'SSymbol' s@ from a proxy for+-- /s/+ssymbolProxy :: KnownSymbol s => proxy s -> SSymbol s+ssymbolProxy _ = SSymbol {-# INLINE ssymbolToString #-} -- | Reify the type-level 'Symbol' @s@ to it's term-level 'String' -- representation. ssymbolToString :: SSymbol s -> String-ssymbolToString (SSymbol s) = symbolVal s+ssymbolToString s@SSymbol = symbolVal s
src/CLaSH/Signal.hs view
@@ -8,7 +8,7 @@ {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-deprecations #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Signal@@ -17,29 +17,28 @@ -- * Basic circuit functions , signal , register+ , registerMaybe , regEn , mux -- * Boolean connectives , (.&&.), (.||.), not1 -- * Product/Signal isomorphism- , Bundle+ , Bundle(..) , Unbundled- , bundle- , unbundle -- * Simulation functions (not synthesisable) , simulate , simulateB- -- * Strict versions- , simulate_strict- , simulateB_strict+ -- ** lazy versions+ , simulate_lazy+ , simulateB_lazy -- * List \<-\> Signal conversion (not synthesisable) , sample , sampleN , fromList- -- ** Strict versions- , sample_strict- , sampleN_strict- , fromList_strict+ -- ** lazy versions+ , sample_lazy+ , sampleN_lazy+ , fromList_lazy -- * QuickCheck combinators , testFor -- * Type classes@@ -71,6 +70,7 @@ import Control.DeepSeq (NFData) import Data.Bits (Bits) -- Haddock only+import Data.Maybe (isJust, fromJust) import CLaSH.Signal.Internal (Signal', register#, regEn#, (.==.), (./=.), compare1, (.<.), (.<=.), (.>=.), (.>.), fromEnum1,@@ -79,14 +79,13 @@ unsafeShiftL1, shiftR1, unsafeShiftR1, rotateL1, rotateR1, (.||.), (.&&.), not1, mux, sample, sampleN, fromList, simulate, signal, testFor,- sample_strict, sampleN_strict, simulate_strict,- fromList_strict)-import CLaSH.Signal.Explicit (SystemClock, systemClock, simulateB',- simulateB'_strict)+ sample_lazy, sampleN_lazy, simulate_lazy,+ fromList_lazy)+import CLaSH.Signal.Explicit (SystemClock, systemClock) import CLaSH.Signal.Bundle (Bundle (..), Unbundled') {- $setup->>> let oscillate = register False (not1 oscillate)+>>> let oscillate = register False (not <$> oscillate) >>> let count = regEn 0 oscillate (count + 1) -} @@ -105,14 +104,19 @@ -- [8,1,2] register :: a -> Signal a -> Signal a register = register# systemClock-infixr `register`+infixr 3 `register` +registerMaybe :: a -> Signal (Maybe a) -> Signal a+registerMaybe initial i = regEn# systemClock initial (fmap isJust i) (fmap fromJust i)+{-# INLINE registerMaybe #-}+infixr 3 `registerMaybe`+ {-# INLINE regEn #-} -- | Version of 'register' that only updates its content when its second argument -- is asserted. So given: -- -- @--- oscillate = 'register' False ('not1' oscillate)+-- oscillate = 'register' False ('not1' '<$>' oscillate) -- count = 'regEn' 0 oscillate (count + 1) -- @ --@@ -131,51 +135,24 @@ -- product type of 'Signal's. type Unbundled a = Unbundled' SystemClock a -{-# INLINE unbundle #-}--- | Example:------ @--- __unbundle__ :: 'Signal' (a,b) -> ('Signal' a, 'Signal' b)--- @------ However:------ @--- __unbundle__ :: 'Signal' 'CLaSH.Sized.BitVector.Bit' -> 'Signal' 'CLaSH.Sized.BitVector.Bit'--- @-unbundle :: Bundle a => Signal a -> Unbundled a-unbundle = unbundle' systemClock--{-# INLINE bundle #-}--- | Example:------ @--- __bundle__ :: ('Signal' a, 'Signal' b) -> 'Signal' (a,b)--- @+-- | Simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a list of+-- samples of type @a@ ----- However:+-- >>> simulateB (unbundle . register (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)]+-- [(8,8),(1,1),(2,2),(3,3)...+-- ... ----- @--- __bundle__ :: 'Signal' 'CLaSH.Sized.BitVector.Bit' -> 'Signal' 'CLaSH.Sized.BitVector.Bit'--- @-bundle :: Bundle a => Unbundled a -> Signal a-bundle = bundle' systemClock+-- __NB__: This function is not synthesisable+simulateB :: (Bundle a, Bundle b, NFData a, NFData b) => (Unbundled' clk1 a -> Unbundled' clk2 b) -> [a] -> [b]+simulateB f = simulate (bundle . f . unbundle) -- | Simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a list of -- samples of type @a@ -- -- >>> simulateB (unbundle . register (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)] -- [(8,8),(1,1),(2,2),(3,3)...+-- ... -- -- __NB__: This function is not synthesisable-simulateB :: (Bundle a, Bundle b) => (Unbundled a -> Unbundled b) -> [a] -> [b]-simulateB = simulateB' systemClock systemClock---- | Version of 'simulateB' that strictly evaluates the input elements and the--- output elements------ __N.B:__ Exceptions are lazily rethrown-simulateB_strict :: (Bundle a, Bundle b, NFData a, NFData b)- => (Unbundled a -> Unbundled b) -> [a] -> [b]-simulateB_strict = simulateB'_strict systemClock systemClock-{-# DEPRECATED simulateB_strict "'simulateB will be strict in CLaSH 1.0, and 'simulateB_strict' will be removed" #-}+simulateB_lazy :: (Bundle a, Bundle b) => (Unbundled' clk1 a -> Unbundled' clk2 b) -> [a] -> [b]+simulateB_lazy f = simulate_lazy (bundle . f . unbundle)
src/CLaSH/Signal/Bundle.hs view
@@ -6,11 +6,12 @@ The Product/Signal isomorphism -} -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE Trustworthy #-} @@ -25,31 +26,32 @@ import GHC.TypeLits (KnownNat) import Prelude hiding (head, map, tail) -import CLaSH.Signal.Internal (Clock, Signal' (..), SClock)+import CLaSH.Signal.Internal (Clock, Signal' (..)) import CLaSH.Sized.BitVector (BitVector) import CLaSH.Sized.Fixed (Fixed) import CLaSH.Sized.Index (Index) import CLaSH.Sized.Signed (Signed) import CLaSH.Sized.Unsigned (Unsigned) import CLaSH.Sized.Vector (Vec, traverse#, lazyV)+import CLaSH.Sized.RTree (RTree, lazyT) -- | Isomorphism between a 'CLaSH.Signal.Signal' of a product type (e.g. a tuple) and a -- product type of 'CLaSH.Signal.Signal''s. ----- Instances of 'Bundle' must satisfy the following laws:+-- Instances of 'bundle must satisfy the following laws: -- -- @--- 'bundle'' . 'unbundle'' = 'id'--- 'unbundle'' . 'bundle'' = 'id'+-- 'bundle' . 'unbundle' = 'id'+-- 'unbundle' . 'bundle' = 'id' -- @ ----- By default, 'bundle'' and 'unbundle'', are defined as the identity, that is,+-- By default, 'bundle' and 'unbundle', are defined as the identity, that is, -- writing: -- -- @ -- data D = A | B ----- instance 'Bundle' D+-- instance 'bundle D -- @ -- -- is the same as:@@ -57,47 +59,47 @@ -- @ -- data D = A | B ----- instance 'Bundle' D where+-- instance 'bundle D where -- type 'Unbundled'' clk D = 'Signal'' clk D--- 'bundle'' _ s = s--- 'unbundle'' _ s = s+-- 'bundle' _ s = s+-- 'unbundle' _ s = s -- @ -- class Bundle a where- type Unbundled' (clk :: Clock) a+ type Unbundled' (clk :: Clock) a = res | res -> clk type Unbundled' clk a = Signal' clk a -- | Example: -- -- @- -- __bundle'__ :: ('Signal'' clk a, 'Signal'' clk b) -> 'Signal'' clk (a,b)+ -- __bundle__ :: ('Signal'' clk a, 'Signal'' clk b) -> 'Signal'' clk (a,b) -- @ -- -- However: -- -- @- -- __bundle'__ :: 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -> 'Signal'' clk 'CLaSH.Sized.BitVector.Bit'+ -- __bundle__ :: 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -> 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -- @- bundle' :: SClock clk -> Unbundled' clk a -> Signal' clk a+ bundle :: Unbundled' clk a -> Signal' clk a - {-# INLINE bundle' #-}- default bundle' :: SClock clk -> Signal' clk a -> Signal' clk a- bundle' _ s = s+ {-# INLINE bundle #-}+ default bundle :: Signal' clk a -> Signal' clk a+ bundle s = s -- | Example: -- -- @- -- __unbundle'__ :: 'Signal'' clk (a,b) -> ('Signal'' clk a, 'Signal'' clk b)+ -- __unbundle__ :: 'Signal'' clk (a,b) -> ('Signal'' clk a, 'Signal'' clk b) -- @ -- -- However: -- -- @- -- __unbundle'__ :: 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -> 'Signal'' clk 'CLaSH.Sized.BitVector.Bit'+ -- __unbundle__ :: 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -> 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -- @- unbundle' :: SClock clk -> Signal' clk a -> Unbundled' clk a+ unbundle :: Signal' clk a -> Unbundled' clk a - {-# INLINE unbundle' #-}- default unbundle' :: SClock clk -> Signal' clk a -> Signal' clk a- unbundle' _ s = s+ {-# INLINE unbundle #-}+ default unbundle :: Signal' clk a -> Signal' clk a+ unbundle s = s instance Bundle Bool instance Bundle Integer@@ -116,93 +118,98 @@ instance Bundle (a,b) where type Unbundled' t (a,b) = (Signal' t a, Signal' t b)- bundle' _ = uncurry (liftA2 (,))- unbundle' _ tup = (fmap fst tup, fmap snd tup)+ bundle = uncurry (liftA2 (,))+ unbundle tup = (fmap fst tup, fmap snd tup) instance Bundle (a,b,c) where type Unbundled' t (a,b,c) = (Signal' t a, Signal' t b, Signal' t c)- bundle' _ (a,b,c) = (,,) <$> a <*> b <*> c- unbundle' _ tup = (fmap (\(x,_,_) -> x) tup- ,fmap (\(_,x,_) -> x) tup- ,fmap (\(_,_,x) -> x) tup- )+ bundle (a,b,c) = (,,) <$> a <*> b <*> c+ unbundle tup = (fmap (\(x,_,_) -> x) tup+ ,fmap (\(_,x,_) -> x) tup+ ,fmap (\(_,_,x) -> x) tup+ ) instance Bundle (a,b,c,d) where type Unbundled' t (a,b,c,d) = ( Signal' t a, Signal' t b, Signal' t c , Signal' t d )- bundle' _ (a,b,c,d) = (,,,) <$> a <*> b <*> c <*> d- unbundle' _ tup = (fmap (\(x,_,_,_) -> x) tup- ,fmap (\(_,x,_,_) -> x) tup- ,fmap (\(_,_,x,_) -> x) tup- ,fmap (\(_,_,_,x) -> x) tup- )+ bundle (a,b,c,d) = (,,,) <$> a <*> b <*> c <*> d+ unbundle tup = (fmap (\(x,_,_,_) -> x) tup+ ,fmap (\(_,x,_,_) -> x) tup+ ,fmap (\(_,_,x,_) -> x) tup+ ,fmap (\(_,_,_,x) -> x) tup+ ) instance Bundle (a,b,c,d,e) where type Unbundled' t (a,b,c,d,e) = ( Signal' t a, Signal' t b, Signal' t c , Signal' t d, Signal' t e )- bundle' _ (a,b,c,d,e) = (,,,,) <$> a <*> b <*> c <*> d <*> e- unbundle' _ tup = (fmap (\(x,_,_,_,_) -> x) tup- ,fmap (\(_,x,_,_,_) -> x) tup- ,fmap (\(_,_,x,_,_) -> x) tup- ,fmap (\(_,_,_,x,_) -> x) tup- ,fmap (\(_,_,_,_,x) -> x) tup- )+ bundle (a,b,c,d,e) = (,,,,) <$> a <*> b <*> c <*> d <*> e+ unbundle tup = (fmap (\(x,_,_,_,_) -> x) tup+ ,fmap (\(_,x,_,_,_) -> x) tup+ ,fmap (\(_,_,x,_,_) -> x) tup+ ,fmap (\(_,_,_,x,_) -> x) tup+ ,fmap (\(_,_,_,_,x) -> x) tup+ ) instance Bundle (a,b,c,d,e,f) where type Unbundled' t (a,b,c,d,e,f) = ( Signal' t a, Signal' t b, Signal' t c , Signal' t d, Signal' t e, Signal' t f )- bundle' _ (a,b,c,d,e,f) = (,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f- unbundle' _ tup = (fmap (\(x,_,_,_,_,_) -> x) tup- ,fmap (\(_,x,_,_,_,_) -> x) tup- ,fmap (\(_,_,x,_,_,_) -> x) tup- ,fmap (\(_,_,_,x,_,_) -> x) tup- ,fmap (\(_,_,_,_,x,_) -> x) tup- ,fmap (\(_,_,_,_,_,x) -> x) tup- )+ bundle (a,b,c,d,e,f) = (,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f+ unbundle tup = (fmap (\(x,_,_,_,_,_) -> x) tup+ ,fmap (\(_,x,_,_,_,_) -> x) tup+ ,fmap (\(_,_,x,_,_,_) -> x) tup+ ,fmap (\(_,_,_,x,_,_) -> x) tup+ ,fmap (\(_,_,_,_,x,_) -> x) tup+ ,fmap (\(_,_,_,_,_,x) -> x) tup+ ) instance Bundle (a,b,c,d,e,f,g) where type Unbundled' t (a,b,c,d,e,f,g) = ( Signal' t a, Signal' t b, Signal' t c , Signal' t d, Signal' t e, Signal' t f , Signal' t g )- bundle' _ (a,b,c,d,e,f,g) = (,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f- <*> g- unbundle' _ tup = (fmap (\(x,_,_,_,_,_,_) -> x) tup- ,fmap (\(_,x,_,_,_,_,_) -> x) tup- ,fmap (\(_,_,x,_,_,_,_) -> x) tup- ,fmap (\(_,_,_,x,_,_,_) -> x) tup- ,fmap (\(_,_,_,_,x,_,_) -> x) tup- ,fmap (\(_,_,_,_,_,x,_) -> x) tup- ,fmap (\(_,_,_,_,_,_,x) -> x) tup- )+ bundle (a,b,c,d,e,f,g) = (,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f+ <*> g+ unbundle tup = (fmap (\(x,_,_,_,_,_,_) -> x) tup+ ,fmap (\(_,x,_,_,_,_,_) -> x) tup+ ,fmap (\(_,_,x,_,_,_,_) -> x) tup+ ,fmap (\(_,_,_,x,_,_,_) -> x) tup+ ,fmap (\(_,_,_,_,x,_,_) -> x) tup+ ,fmap (\(_,_,_,_,_,x,_) -> x) tup+ ,fmap (\(_,_,_,_,_,_,x) -> x) tup+ ) instance Bundle (a,b,c,d,e,f,g,h) where type Unbundled' t (a,b,c,d,e,f,g,h) = ( Signal' t a, Signal' t b, Signal' t c , Signal' t d, Signal' t e, Signal' t f , Signal' t g, Signal' t h )- bundle' _ (a,b,c,d,e,f,g,h) = (,,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f- <*> g <*> h- unbundle' _ tup = (fmap (\(x,_,_,_,_,_,_,_) -> x) tup- ,fmap (\(_,x,_,_,_,_,_,_) -> x) tup- ,fmap (\(_,_,x,_,_,_,_,_) -> x) tup- ,fmap (\(_,_,_,x,_,_,_,_) -> x) tup- ,fmap (\(_,_,_,_,x,_,_,_) -> x) tup- ,fmap (\(_,_,_,_,_,x,_,_) -> x) tup- ,fmap (\(_,_,_,_,_,_,x,_) -> x) tup- ,fmap (\(_,_,_,_,_,_,_,x) -> x) tup- )+ bundle (a,b,c,d,e,f,g,h) = (,,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f+ <*> g <*> h+ unbundle tup = (fmap (\(x,_,_,_,_,_,_,_) -> x) tup+ ,fmap (\(_,x,_,_,_,_,_,_) -> x) tup+ ,fmap (\(_,_,x,_,_,_,_,_) -> x) tup+ ,fmap (\(_,_,_,x,_,_,_,_) -> x) tup+ ,fmap (\(_,_,_,_,x,_,_,_) -> x) tup+ ,fmap (\(_,_,_,_,_,x,_,_) -> x) tup+ ,fmap (\(_,_,_,_,_,_,x,_) -> x) tup+ ,fmap (\(_,_,_,_,_,_,_,x) -> x) tup+ ) instance KnownNat n => Bundle (Vec n a) where type Unbundled' t (Vec n a) = Vec n (Signal' t a) -- The 'Traversable' instance of 'Vec' is not synthesisable, so we must- -- define 'bundle'' as a primitive.- bundle' = vecBundle#- unbundle' _ = sequenceA . fmap lazyV+ -- define 'bundle' as a primitive.+ bundle = vecBundle#+ unbundle = sequenceA . fmap lazyV {-# NOINLINE vecBundle# #-}-vecBundle# :: SClock t -> Vec n (Signal' t a) -> Signal' t (Vec n a)-vecBundle# _ = traverse# id+vecBundle# :: Vec n (Signal' t a) -> Signal' t (Vec n a)+vecBundle# = traverse# id++instance KnownNat d => Bundle (RTree d a) where+ type Unbundled' t (RTree d a) = RTree d (Signal' t a)+ bundle = sequenceA+ unbundle = sequenceA . fmap lazyT
src/CLaSH/Signal/Delayed.hs view
@@ -6,9 +6,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-#if __GLASGOW_HASKELL__ > 710-{-# LANGUAGE DeriveLift #-}-#endif {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}@@ -29,6 +26,8 @@ , toSignal -- * List \<-\> DSignal conversion (not synthesisable) , dfromList+ -- ** lazy versions+ , dfromList_lazy -- * Experimental , unsafeFromSignal , antiDelay@@ -41,9 +40,9 @@ import CLaSH.Sized.Vector (Vec) import CLaSH.Signal.Explicit (SystemClock, systemClock)-import CLaSH.Signal.Delayed.Explicit (DSignal', dfromList, delay', delayI',- feedback, fromSignal, toSignal,- unsafeFromSignal, antiDelay)+import CLaSH.Signal.Delayed.Explicit (DSignal', dfromList, dfromList_lazy,+ delay', delayI', feedback, fromSignal,+ toSignal, unsafeFromSignal, antiDelay) {- $setup >>> :set -XDataKinds@@ -96,4 +95,3 @@ => DSignal n a -> DSignal (n + d) a delayI = delayI' systemClock-
src/CLaSH/Signal/Delayed/Explicit.hs view
@@ -6,9 +6,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-#if __GLASGOW_HASKELL__ > 710 {-# LANGUAGE DeriveLift #-}-#endif {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -35,28 +33,27 @@ , toSignal -- * List \<-\> DSignal conversion (not synthesisable) , dfromList+ -- ** lazy versions+ , dfromList_lazy -- * Experimental , unsafeFromSignal , antiDelay ) where -import Data.Bits (Bits, FiniteBits)+import Control.DeepSeq (NFData) import Data.Coerce (coerce) import Data.Default (Default(..))-import Control.Applicative (liftA2) import GHC.TypeLits (KnownNat, Nat, type (+)) import Language.Haskell.TH.Syntax (Lift) import Prelude hiding (head, length, repeat) import Test.QuickCheck (Arbitrary, CoArbitrary) -import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum) import CLaSH.Promoted.Nat (SNat) import CLaSH.Sized.Vector (Vec, head, length, repeat, shiftInAt0, singleton)-import CLaSH.Signal (fromList)-import CLaSH.Signal.Explicit (Signal', Clock, SClock, register',- bundle', unbundle')+import CLaSH.Signal (fromList, fromList_lazy, bundle, unbundle)+import CLaSH.Signal.Explicit (Signal', Clock, SClock, register') {- $setup >>> :set -XDataKinds@@ -85,19 +82,8 @@ DSignal' { -- | Strip a 'DSignal' from its delay information. toSignal :: Signal' clk a }- deriving (Show,Default,Functor,Applicative,Num,Bounded,Fractional,- Real,Integral,SaturatingNum,Eq,Ord,Enum,Bits,FiniteBits,Foldable,- Traversable,Arbitrary,CoArbitrary,Lift)--instance ExtendingNum a b- => ExtendingNum (DSignal' clk n a) (DSignal' clk n b) where- type AResult (DSignal' clk n a) (DSignal' clk n b) =- DSignal' clk n (AResult a b)- plus = liftA2 plus- minus = liftA2 minus- type MResult (DSignal' clk n a) (DSignal' clk n b) =- DSignal' clk n (MResult a b)- times = liftA2 times+ deriving (Show,Default,Functor,Applicative,Num,Fractional,+ Foldable,Traversable,Arbitrary,CoArbitrary,Lift) -- | Create a 'DSignal'' from a list --@@ -108,9 +94,21 @@ -- [1,2] -- -- __NB__: This function is not synthesisable-dfromList :: [a] -> DSignal' clk 0 a+dfromList :: NFData a => [a] -> DSignal' clk 0 a dfromList = coerce . fromList +-- | Create a 'DSignal' from a list+--+-- Every element in the list will correspond to a value of the signal for one+-- clock cycle.+--+-- >>> sampleN 2 (dfromList [1,2,3,4,5])+-- [1,2]+--+-- __NB__: This function is not synthesisable+dfromList_lazy :: [a] -> DSignal' clk 0 a+dfromList_lazy = coerce . fromList_lazy+ -- | Delay a 'DSignal'' for @d@ periods. -- -- @@@ -130,8 +128,8 @@ delaySignal :: Signal' clk a -> Signal' clk a delaySignal s = case length m of 0 -> s- _ -> let (r',o) = shiftInAt0 (unbundle' clk r) (singleton s)- r = register' clk m (bundle' clk r')+ _ -> let (r',o) = shiftInAt0 (unbundle r) (singleton s)+ r = register' clk m (bundle r') in head o -- | Delay a 'DSignal' clk' for @m@ periods, where @m@ is derived from the
src/CLaSH/Signal/Explicit.hs view
@@ -10,7 +10,6 @@ {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Signal.Explicit@@ -30,24 +29,18 @@ , unsafeSynchronizer -- * Basic circuit functions , register'+ , registerMaybe' , regEn'- -- * Product/Signal isomorphism- , Bundle (..)- -- * Simulation functions (not synthesisable)- , simulateB'- -- ** Strict version- , simulateB'_strict ) where -import Control.DeepSeq (NFData)+import Data.Maybe (isJust, fromJust) import GHC.TypeLits (KnownNat, KnownSymbol) -import CLaSH.Promoted.Nat (snat, snatToInteger)-import CLaSH.Promoted.Symbol (ssymbol)+import CLaSH.Promoted.Nat (SNat (..), snatToNum)+import CLaSH.Promoted.Symbol (SSymbol (..)) import CLaSH.Signal.Internal (Signal' (..), Clock (..), SClock (..), register#,- regEn#, simulate, simulate_strict)-import CLaSH.Signal.Bundle (Bundle (..), Unbundled')+ regEn#) {- $setup >>> :set -XDataKinds@@ -127,14 +120,14 @@ -- @ sclock :: (KnownSymbol name, KnownNat period) => SClock ('Clk name period)-sclock = SClock ssymbol snat+sclock = SClock SSymbol SNat {-# INLINE withSClock #-} -- | Supply a function with a singleton clock @clk@ according to the context withSClock :: (KnownSymbol name, KnownNat period) => (SClock ('Clk name period) -> a) -> a-withSClock f = f (SClock ssymbol snat)+withSClock f = f (SClock SSymbol SNat) -- | The standard system clock with a period of 1000 type SystemClock = 'Clk "system" 1000@@ -250,8 +243,8 @@ -> Signal' clk2 a unsafeSynchronizer (SClock _ period1) (SClock _ period2) s = s' where- t1 = fromInteger (snatToInteger period1)- t2 = fromInteger (snatToInteger period2)+ t1 = snatToNum period1+ t2 = snatToNum period2 s' | t1 < t2 = compress t2 t1 s | t1 > t2 = oversample t1 t2 s | otherwise = same s@@ -308,8 +301,12 @@ register' :: SClock clk -> a -> Signal' clk a -> Signal' clk a register' = register# +registerMaybe' :: SClock clk -> a -> Signal' clk (Maybe a) -> Signal' clk a+registerMaybe' clk initial i = regEn# clk initial (fmap isJust i) (fmap fromJust i)+{-# INLINE registerMaybe' #-}+ {-# INLINE regEn' #-}--- | Version of 'register'' that only updates its content when its second+-- | Version of 'register'' that only updates its content when its third -- argument is asserted. So given: -- -- @@@ -329,31 +326,3 @@ -- [0,0,1,1,2,2,3,3] regEn' :: SClock clk -> a -> Signal' clk Bool -> Signal' clk a -> Signal' clk a regEn' = regEn#---- * Simulation functions---- | Simulate a (@'Unbundled'' clk1 a -> 'Unbundled'' clk2 b@) function given a--- list of samples of type @a@------ >>> simulateB' clkA clkA (unbundle' clkA . register' clkA (8,8) . bundle' clkA) [(1,1), (2,2), (3,3)] :: [(Int,Int)]--- [(8,8),(1,1),(2,2),(3,3)...------ __NB__: This function is not synthesisable-simulateB' :: (Bundle a, Bundle b)- => SClock clk1 -- ^ 'Clock' of the incoming signal- -> SClock clk2 -- ^ 'Clock' of the outgoing signal- -> (Unbundled' clk1 a -> Unbundled' clk2 b) -- ^ Function to simulate- -> [a] -> [b]-simulateB' clk1 clk2 f = simulate (bundle' clk2 . f . unbundle' clk1)---- | Version of 'simulateB'' that strictly evaluates the input elements and the--- output elements------ __N.B:__ Exceptions are lazily rethrown-simulateB'_strict :: (Bundle a, Bundle b, NFData a, NFData b)- => SClock clk1 -- ^ 'Clock' of the incoming signal- -> SClock clk2 -- ^ 'Clock' of the outgoing signal- -> (Unbundled' clk1 a -> Unbundled' clk2 b) -- ^ Function to simulate- -> [a] -> [b]-simulateB'_strict clk1 clk2 f = simulate_strict (bundle' clk2 . f . unbundle' clk1)-{-# DEPRECATED simulateB'_strict "'simulateB'' will be strict in CLaSH 1.0, and 'simulateB'_strict' will be removed" #-}
src/CLaSH/Signal/Internal.hs view
@@ -19,9 +19,7 @@ -- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c -- as to why we need this.-#if __GLASGOW_HASKELL__ > 711 {-# OPTIONS_GHC -fno-cpr-anal #-}-#endif {-# OPTIONS_HADDOCK show-extensions #-} @@ -39,16 +37,16 @@ , (.&&.), (.||.), not1 -- * Simulation functions (not synthesisable) , simulate- -- ** strict versions- , simulate_strict+ -- ** lazy version+ , simulate_lazy -- * List \<-\> Signal conversion (not synthesisable) , sample , sampleN , fromList- -- ** strict versions- , sample_strict- , sampleN_strict- , fromList_strict+ -- ** lazy versions+ , sample_lazy+ , sampleN_lazy+ , fromList_lazy -- * QuickCheck combinators , testFor -- * Type classes@@ -90,9 +88,9 @@ where import Control.Applicative (liftA2, liftA3)-import Control.DeepSeq (NFData,force)-import Control.Exception (SomeException,catch,evaluate,throw)-import Data.Bits (Bits (..), FiniteBits (..))+import Control.DeepSeq (NFData, force)+import Control.Exception (catch, evaluate, throw)+import Data.Bits (Bits (..)) import Data.Default (Default (..)) import GHC.TypeLits (Nat, Symbol) import Language.Haskell.TH.Syntax (Lift (..))@@ -100,9 +98,9 @@ import Test.QuickCheck (Arbitrary (..), CoArbitrary(..), Property, property) -import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..)) import CLaSH.Promoted.Nat (SNat, snatToInteger) import CLaSH.Promoted.Symbol (SSymbol, ssymbolToString)+import CLaSH.XException (XException, errorX) {- $setup >>> :set -XDataKinds@@ -111,7 +109,7 @@ >>> import CLaSH.Promoted.Symbol >>> type SystemClock = Clk "System" 1000 >>> type Signal a = Signal' SystemClock a->>> let register = register# (SClock ssymbol snat :: SClock SystemClock)+>>> let register = register# (SClock SSymbol SNat :: SClock SystemClock) -} -- | A clock with a name ('Symbol') and period ('Nat')@@ -261,6 +259,7 @@ -- It is a version of 'not' that operates on 'CLaSH.Signal.Signal's of 'Bool' not1 :: Functor f => f Bool -> f Bool not1 = fmap not+{-# DEPRECATED not1 "'not1' will be removed in clash-prelude-1.0, use \"fmap not\" instead." #-} {-# NOINLINE register# #-} register# :: SClock clk -> a -> Signal' clk a -> Signal' clk a@@ -299,28 +298,6 @@ signal :: Applicative f => a -> f a signal = pure -instance Bounded a => Bounded (Signal' clk a) where- minBound = signal# minBound- maxBound = signal# maxBound--instance ExtendingNum a b => ExtendingNum (Signal' clk a) (Signal' clk b) where- type AResult (Signal' clk a) (Signal' clk b) = Signal' clk (AResult a b)- plus = liftA2 plus- minus = liftA2 minus- type MResult (Signal' clk a) (Signal' clk b) = Signal' clk (MResult a b)- times = liftA2 times--instance SaturatingNum a => SaturatingNum (Signal' clk a) where- satPlus s = liftA2 (satPlus s)- satMin s = liftA2 (satMin s)- satMult s = liftA2 (satMult s)---- | __WARNING__: ('==') and ('/=') are undefined, use ('.==.') and ('./=.')--- instead-instance Eq (Signal' clk a) where- (==) = error "(==)' undefined for 'Signal'', use '(.==.)' instead"- (/=) = error "(/=)' undefined for 'Signal'', use '(./=.)' instead"- infix 4 .==. -- | The above type is a generalisation for: --@@ -343,17 +320,6 @@ (./=.) :: (Eq a, Applicative f) => f a -> f a -> f Bool (./=.) = liftA2 (/=) --- | __WARNING__: 'compare', ('<'), ('>='), ('>'), and ('<=') are--- undefined, use 'compare1', ('.<.'), ('.>=.'), ('.>.'), and ('.<=.') instead-instance Ord a => Ord (Signal' clk a) where- compare = error "'compare' undefined for 'Signal'', use 'compare1' instead"- (<) = error "'(<)' undefined for 'Signal'', use '(.<.)' instead"- (>=) = error "'(>=)' undefined for 'Signal'', use '(.>=.)' instead"- (>) = error "'(>)' undefined for 'Signal'', use '(.>.)' instead"- (<=) = error "'(<=)' undefined for 'Signal'', use '(.<=.)' instead"- max = liftA2 max- min = liftA2 min- -- | The above type is a generalisation for: -- -- @@@ -363,6 +329,7 @@ -- It is a version of 'compare' that returns a 'CLaSH.Signal.Signal' of 'Ordering' compare1 :: (Ord a, Applicative f) => f a -> f a -> f Ordering compare1 = liftA2 compare+{-# DEPRECATED compare1 "'compare1' will be removed in clash-prelude-1.0, use \"liftA2 compare\" instead." #-} infix 4 .<. -- | The above type is a generalisation for:@@ -408,17 +375,6 @@ (.>=.) :: (Ord a, Applicative f) => f a -> f a -> f Bool (.>=.) = liftA2 (>=) --- | __WARNING__: 'fromEnum' is undefined, use 'fromEnum1' instead-instance Enum a => Enum (Signal' clk a) where- succ = fmap succ- pred = fmap pred- toEnum = signal# . toEnum- fromEnum = error "'fromEnum' undefined for 'Signal'', use 'fromEnum1'"- enumFrom = sequenceA . fmap enumFrom- enumFromThen = (sequenceA .) . liftA2 enumFromThen- enumFromTo = (sequenceA .) . liftA2 enumFromTo- enumFromThenTo = ((sequenceA .) .) . liftA3 enumFromThenTo- -- | The above type is a generalisation for: -- -- @@@ -428,10 +384,7 @@ -- It is a version of 'fromEnum' that returns a CLaSH.Signal.Signal' of 'Int' fromEnum1 :: (Enum a, Functor f) => f a -> f Int fromEnum1 = fmap fromEnum---- | __WARNING__: 'toRational' is undefined, use 'toRational1' instead-instance (Num a, Ord a) => Real (Signal' clk a) where- toRational = error "'toRational' undefined for 'Signal'', use 'toRational1'"+{-# DEPRECATED fromEnum1 "'fromEnum1' will be removed in clash-prelude-1.0, use \"fmap fromEnum\" instead." #-} -- | The above type is a generalisation for: --@@ -442,16 +395,7 @@ -- It is a version of 'toRational' that returns a 'CLaSH.Signal.Signal' of 'Rational' toRational1 :: (Real a, Functor f) => f a -> f Rational toRational1 = fmap toRational---- | __WARNING__: 'toInteger' is undefined, use 'toInteger1' instead-instance Integral a => Integral (Signal' clk a) where- quot = liftA2 quot- rem = liftA2 rem- div = liftA2 div- mod = liftA2 mod- quotRem a b = (quot a b, rem a b)- divMod a b = (div a b, mod a b)- toInteger = error "'toInteger' undefined for 'Signal'', use 'toInteger1'"+{-# DEPRECATED toRational1 "'toRational1' will be removed in clash-prelude-1.0, use \"fmap toRational\" instead." #-} -- | The above type is a generalisation for: --@@ -462,34 +406,7 @@ -- It is a version of 'toRational' that returns a 'CLaSH.Signal.Signal' of 'Integer' toInteger1 :: (Integral a, Functor f) => f a -> f Integer toInteger1 = fmap toInteger---- | __WARNING__: 'testBit' and 'popCount' are undefined, use 'testBit1' and--- 'popCount1' instead-instance Bits a => Bits (Signal' clk a) where- (.&.) = liftA2 (.&.)- (.|.) = liftA2 (.|.)- xor = liftA2 xor- complement = fmap complement- shift a i = fmap (`shift` i) a- rotate a i = fmap (`rotate` i) a- zeroBits = signal# zeroBits- bit = signal# . bit- setBit a i = fmap (`setBit` i) a- clearBit a i = fmap (`clearBit` i) a- testBit = error "'testBit' undefined for 'Signal'', use 'testbit1'"- bitSizeMaybe _ = bitSizeMaybe (undefined :: a)- bitSize _ = maybe 0 id (bitSizeMaybe (undefined :: a))- isSigned _ = isSigned (undefined :: a)- shiftL a i = fmap (`shiftL` i) a- unsafeShiftL a i = fmap (`unsafeShiftL` i) a- shiftR a i = fmap (`shiftR` i) a- unsafeShiftR a i = fmap (`unsafeShiftR` i) a- rotateL a i = fmap (`rotateL` i) a- rotateR a i = fmap (`rotateR` i) a- popCount = error "'popCount' undefined for 'Signal'', use 'popCount1'"--instance FiniteBits a => FiniteBits (Signal' clk a) where- finiteBitSize _ = finiteBitSize (undefined :: a)+{-# DEPRECATED toInteger1 "'toInteger1' will be removed in clash-prelude-1.0, use \"fmap toInteger\" instead." #-} -- | The above type is a generalisation for: --@@ -501,6 +418,7 @@ -- argument, and a result of 'CLaSH.Signal.Signal' of 'Bool' testBit1 :: (Bits a, Applicative f) => f a -> f Int -> f Bool testBit1 = liftA2 testBit+{-# DEPRECATED testBit1 "'testBit1' will be removed in clash-prelude-1.0, use \"liftA2 testBit\" instead." #-} -- | The above type is a generalisation for: --@@ -511,6 +429,7 @@ -- It is a version of 'popCount' that returns a 'CLaSH.Signal.Signal' of 'Int' popCount1 :: (Bits a, Functor f) => f a -> f Int popCount1 = fmap popCount+{-# DEPRECATED popCount1 "'popCount1' will be removed in clash-prelude-1.0, use \"fmap popCount\" instead." #-} -- | The above type is a generalisation for: --@@ -521,6 +440,7 @@ -- It is a version of 'shift' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument shift1 :: (Bits a, Applicative f) => f a -> f Int -> f a shift1 = liftA2 shift+{-# DEPRECATED shift1 "'shift1' will be removed in clash-prelude-1.0, use \"liftA2 shift\" instead." #-} -- | The above type is a generalisation for: --@@ -531,6 +451,7 @@ -- It is a version of 'rotate' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument rotate1 :: (Bits a, Applicative f) => f a -> f Int -> f a rotate1 = liftA2 rotate+{-# DEPRECATED rotate1 "'rotate1' will be removed in clash-prelude-1.0, use \"liftA2 rotate\" instead." #-} -- | The above type is a generalisation for: --@@ -541,6 +462,7 @@ -- It is a version of 'setBit' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument setBit1 :: (Bits a, Applicative f) => f a -> f Int -> f a setBit1 = liftA2 setBit+{-# DEPRECATED setBit1 "'setBit1' will be removed in clash-prelude-1.0, use \"liftA2 setBit\" instead." #-} -- | The above type is a generalisation for: --@@ -551,6 +473,7 @@ -- It is a version of 'clearBit' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument clearBit1 :: (Bits a, Applicative f) => f a -> f Int -> f a clearBit1 = liftA2 clearBit+{-# DEPRECATED clearBit1 "'clearBit1' will be removed in clash-prelude-1.0, use \"liftA2 clearBit\" instead." #-} -- | The above type is a generalisation for: --@@ -561,6 +484,7 @@ -- It is a version of 'shiftL' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument shiftL1 :: (Bits a, Applicative f) => f a -> f Int -> f a shiftL1 = liftA2 shiftL+{-# DEPRECATED shiftL1 "'shiftL1' will be removed in clash-prelude-1.0, use \"liftA2 shiftL\" instead." #-} -- | The above type is a generalisation for: --@@ -571,6 +495,7 @@ -- It is a version of 'unsafeShiftL' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument unsafeShiftL1 :: (Bits a, Applicative f) => f a -> f Int -> f a unsafeShiftL1 = liftA2 unsafeShiftL+{-# DEPRECATED unsafeShiftL1 "'unsafeShiftL1' will be removed in clash-prelude-1.0, use \"liftA2 unsafeShiftL\" instead." #-} -- | The above type is a generalisation for: --@@ -581,6 +506,7 @@ -- It is a version of 'shiftR' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument shiftR1 :: (Bits a, Applicative f) => f a -> f Int -> f a shiftR1 = liftA2 shiftR+{-# DEPRECATED shiftR1 "'shiftR1' will be removed in clash-prelude-1.0, use \"liftA2 shiftR\" instead." #-} -- | The above type is a generalisation for: --@@ -591,6 +517,7 @@ -- It is a version of 'unsafeShiftR' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument unsafeShiftR1 :: (Bits a, Applicative f) => f a -> f Int -> f a unsafeShiftR1 = liftA2 unsafeShiftR+{-# DEPRECATED unsafeShiftR1 "'unsafeShiftR1' will be removed in clash-prelude-1.0, use \"liftA2 unsafeShiftR\" instead." #-} -- | The above type is a generalisation for: --@@ -601,6 +528,7 @@ -- It is a version of 'rotateL' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument rotateL1 :: (Bits a, Applicative f) => f a -> f Int -> f a rotateL1 = liftA2 rotateL+{-# DEPRECATED rotateL1 "'rotateL1' will be removed in clash-prelude-1.0, use \"liftA2 rotateL\" instead." #-} -- | The above type is a generalisation for: --@@ -611,6 +539,7 @@ -- It is a version of 'rotateR' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument rotateR1 :: (Bits a, Applicative f) => f a -> f Int -> f a rotateR1 = liftA2 rotateR+{-# DEPRECATED rotateR1 "'rotateR1' will be removed in clash-prelude-1.0, use \"liftA2 rotateR\" instead." #-} instance Fractional a => Fractional (Signal' clk a) where (/) = liftA2 (/)@@ -623,7 +552,7 @@ instance CoArbitrary a => CoArbitrary (Signal' clk a) where coarbitrary xs gen = do n <- arbitrary- coarbitrary (take (abs n) (sample xs)) gen+ coarbitrary (take (abs n) (sample_lazy xs)) gen -- | The above type is a generalisation for: --@@ -637,6 +566,16 @@ -- * List \<-\> Signal conversion (not synthesisable) +-- | A 'force' that lazily returns exceptions+forceNoException :: NFData a => a -> IO a+forceNoException x = catch (evaluate (force x)) (\(e :: XException) -> return (throw e))++headStrictCons :: NFData a => a -> [a] -> [a]+headStrictCons x xs = unsafeDupablePerformIO ((:) <$> forceNoException x <*> pure xs)++headStrictSignal :: NFData a => a -> Signal' clk a -> Signal' clk a+headStrictSignal x xs = unsafeDupablePerformIO ((:-) <$> forceNoException x <*> pure xs)+ -- | The above type is a generalisation for: -- -- @@@ -651,8 +590,8 @@ -- > sample s == [s0, s1, s2, s3, ... -- -- __NB__: This function is not synthesisable-sample :: Foldable f => f a -> [a]-sample = foldr (:) []+sample :: (Foldable f, NFData a) => f a -> [a]+sample = foldr headStrictCons [] -- | The above type is a generalisation for: --@@ -668,7 +607,7 @@ -- > sampleN 3 s == [s0, s1, s2] -- -- __NB__: This function is not synthesisable-sampleN :: Foldable f => Int -> f a -> [a]+sampleN :: (Foldable f, NFData a) => Int -> f a -> [a] sampleN n = take n . sample -- | Create a 'CLaSH.Signal.Signal' from a list@@ -680,8 +619,8 @@ -- [1,2] -- -- __NB__: This function is not synthesisable-fromList :: [a] -> Signal' clk a-fromList = Prelude.foldr (:-) (error "finite list")+fromList :: NFData a => [a] -> Signal' clk a+fromList = Prelude.foldr headStrictSignal (errorX "finite list") -- * Simulation functions (not synthesisable) @@ -690,47 +629,67 @@ -- -- >>> simulate (register 8) [1, 2, 3] -- [8,1,2,3...+-- ... -- -- __NB__: This function is not synthesisable-simulate :: (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b]+simulate :: (NFData a, NFData b) => (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b] simulate f = sample . f . fromList --- | A 'force' that lazily returns exceptions-forceNoException :: NFData a => a -> IO a-forceNoException x = catch (evaluate (force x)) (\(e :: SomeException) -> return (throw e))--headStrictCons :: NFData a => a -> [a] -> [a]-headStrictCons x xs = unsafeDupablePerformIO ((:) <$> forceNoException x <*> pure xs)--headStrictSignal :: NFData a => a -> Signal' clk a -> Signal' clk a-headStrictSignal x xs = unsafeDupablePerformIO ((:-) <$> forceNoException x <*> pure xs)---- | Version of 'sample' that strictly evaluates the samples+-- | The above type is a generalisation for: ----- __N.B:__ Exceptions are lazily rethrown-sample_strict :: (Foldable f, NFData a) => f a -> [a]-sample_strict = foldr headStrictCons []-{-# DEPRECATED sample_strict "'sample' will be strict in CLaSH 1.0, and 'sample_strict' will be removed" #-}+-- @+-- __sample__ :: 'CLaSH.Signal.Signal' a -> [a]+-- @+--+-- Get an infinite list of samples from a 'CLaSH.Signal.Signal'+--+-- The elements in the list correspond to the values of the 'CLaSH.Signal.Signal'+-- at consecutive clock cycles+--+-- > sample s == [s0, s1, s2, s3, ...+--+-- __NB__: This function is not synthesisable+sample_lazy :: Foldable f => f a -> [a]+sample_lazy = foldr (:) [] --- | Version of 'sampleN' that strictly evaluates the samples+-- | The above type is a generalisation for: ----- __N.B:__ Exceptions are lazily rethrown-sampleN_strict :: (Foldable f, NFData a) => Int -> f a -> [a]-sampleN_strict n = take n . sample_strict-{-# DEPRECATED sampleN_strict "'sampleN' will be strict in CLaSH 1.0, and 'sampleN_strict' will be removed" #-}+-- @+-- __sampleN__ :: Int -> 'CLaSH.Signal.Signal' a -> [a]+-- @+--+-- Get a list of @n@ samples from a 'CLaSH.Signal.Signal'+--+-- The elements in the list correspond to the values of the 'CLaSH.Signal.Signal'+-- at consecutive clock cycles+--+-- > sampleN 3 s == [s0, s1, s2]+--+-- __NB__: This function is not synthesisable+sampleN_lazy :: Foldable f => Int -> f a -> [a]+sampleN_lazy n = take n . sample_lazy --- | Version of 'fromList' that strictly evaluates the elements of the list+-- | Create a 'CLaSH.Signal.Signal' from a list ----- __N.B:__ Exceptions are lazily rethrown-fromList_strict :: NFData a => [a] -> Signal' clk a-fromList_strict = foldr headStrictSignal (error "finite list")-{-# DEPRECATED fromList_strict "'fromList' will be strict in CLaSH 1.0, and 'fromList_strict' will be removed" #-}+-- Every element in the list will correspond to a value of the signal for one+-- clock cycle.+--+-- >>> sampleN 2 (fromList [1,2,3,4,5])+-- [1,2]+--+-- __NB__: This function is not synthesisable+fromList_lazy :: [a] -> Signal' clk a+fromList_lazy = Prelude.foldr (:-) (error "finite list") --- | Version of 'simulate' that strictly evaluates the input elements and the--- output elements+-- * Simulation functions (not synthesisable)++-- | Simulate a (@'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' b@) function+-- given a list of samples of type @a@ ----- __N.B:__ Exceptions are lazily rethrown-simulate_strict :: (NFData a, NFData b)- => (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b]-simulate_strict f = sample_strict . f . fromList_strict-{-# DEPRECATED simulate_strict "'simulate' will be strict in CLaSH 1.0, and 'simulate_strict' will be removed" #-}+-- >>> simulate (register 8) [1, 2, 3]+-- [8,1,2,3...+-- ...+--+-- __NB__: This function is not synthesisable+simulate_lazy :: (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b]+simulate_lazy f = sample_lazy . f . fromList_lazy
src/CLaSH/Sized/Fixed.hs view
@@ -32,12 +32,14 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Sized.Fixed@@ -79,6 +81,7 @@ import Data.Ratio ((%), denominator, numerator) import Data.Typeable (Typeable, TypeRep, typeRep) import GHC.TypeLits (KnownNat, Nat, type (+), natVal)+import GHC.TypeLits.Extra (Max) import Language.Haskell.TH (Q, TExp, TypeQ, appT, conT, litT, mkName, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..))@@ -90,9 +93,12 @@ boundedMult) import CLaSH.Class.Resize (Resize (..)) import CLaSH.Promoted.Nat (SNat)-import CLaSH.Promoted.Ord (Max)+import CLaSH.Prelude.BitIndex (msb, split)+import CLaSH.Prelude.BitReduction (reduceAnd, reduceOr)+import CLaSH.Sized.BitVector (BitVector, (++#)) import CLaSH.Sized.Signed (Signed) import CLaSH.Sized.Unsigned (Unsigned)+import CLaSH.XException (ShowX (..), showsPrecXWith) {- $setup >>> :set -XDataKinds@@ -258,6 +264,10 @@ else fRepI .&. ((2 ^ nF) - 1) denom = 2 ^ nF +instance ( size ~ (int + frac), KnownNat frac, Integral (rep size)+ ) => ShowX (Fixed rep int frac) where+ showsPrecX = showsPrecXWith showsPrec+ -- | None of the 'Read' class' methods are synthesisable. instance (size ~ (int + frac), KnownNat frac, Bounded (rep size), Integral (rep size)) => Read (Fixed rep int frac) where@@ -346,26 +356,30 @@ -- | Constraint for the 'ExtendingNum' instance of 'Fixed' type ENumFixedC rep int1 frac1 int2 frac2- = ( ResizeFC rep int1 frac1 (1 + Max int1 int2) (Max frac1 frac2)- , ResizeFC rep int2 frac2 (1 + Max int1 int2) (Max frac1 frac2)- , Bounded (rep ((1 + Max int1 int2) + Max frac1 frac2))+ = ( Bounded (rep ((1 + Max int1 int2) + Max frac1 frac2)) , Num (rep ((1 + Max int1 int2) + Max frac1 frac2))+ , Bits (rep ((1 + Max int1 int2) + Max frac1 frac2)) , ExtendingNum (rep (int1 + frac1)) (rep (int2 + frac2)) , MResult (rep (int1 + frac1)) (rep (int2 + frac2)) ~ rep ((int1 + int2) + (frac1 + frac2))+ , KnownNat int1+ , KnownNat int2+ , KnownNat frac1+ , KnownNat frac2+ , Resize rep ) -- | Constraint for the 'ExtendingNum' instance of 'SFixed' type ENumSFixedC int1 frac1 int2 frac2- = ( KnownNat frac1- , KnownNat frac2+ = ( KnownNat (int2 + frac2)+ , KnownNat (1 + Max int1 int2 + Max frac1 frac2) , KnownNat (Max frac1 frac2)+ , KnownNat (1 + Max int1 int2) , KnownNat (int1 + frac1)- , KnownNat (int2 + frac2)- , KnownNat ((int1 + int2) + (frac1 + frac2))- , KnownNat (1 + Max (int1 + frac1) (int2 + frac2))- , KnownNat ((1 + Max int1 int2) + Max frac1 frac2)- , ((int1 + frac1) + (int2 + frac2)) ~ ((int1 + int2) + (frac1 + frac2))+ , KnownNat frac2+ , KnownNat int2+ , KnownNat frac1+ , KnownNat int1 ) -- | Constraint for the 'ExtendingNum' instance of 'UFixed'@@ -383,13 +397,17 @@ ExtendingNum (Fixed rep int1 frac1) (Fixed rep int2 frac2) where type AResult (Fixed rep int1 frac1) (Fixed rep int2 frac2) = Fixed rep (1 + Max int1 int2) (Max frac1 frac2)- plus f1 f2 =- let (Fixed f1R) = resizeF f1 :: Fixed rep (1 + Max int1 int2) (Max frac1 frac2)- (Fixed f2R) = resizeF f2 :: Fixed rep (1 + Max int1 int2) (Max frac1 frac2)+ plus (Fixed f1) (Fixed f2) =+ let sh1 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac1)) :: Int+ f1R = shiftL (resize f1) sh1 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))+ sh2 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac2)) :: Int+ f2R = shiftL (resize f2) sh2 :: rep ((1 + Max int1 int2) + (Max frac1 frac2)) in Fixed (f1R + f2R)- minus f1 f2 =- let (Fixed f1R) = resizeF f1 :: Fixed rep (1 + Max int1 int2) (Max frac1 frac2)- (Fixed f2R) = resizeF f2 :: Fixed rep (1 + Max int1 int2) (Max frac1 frac2)+ minus (Fixed f1) (Fixed f2) =+ let sh1 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac1)) :: Int+ f1R = shiftL (resize f1) sh1 :: rep ((1 + Max int1 int2) + (Max frac1 frac2))+ sh2 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac2)) :: Int+ f2R = shiftL (resize f2) sh2 :: rep ((1 + Max int1 int2) + (Max frac1 frac2)) in Fixed (f1R - f2R) type MResult (Fixed rep int1 frac1) (Fixed rep int2 frac2) = Fixed rep (int1 + int2) (frac1 + frac2)@@ -399,20 +417,31 @@ type NumFixedC rep int frac = ( SaturatingNum (rep (int + frac)) , ExtendingNum (rep (int + frac)) (rep (int + frac))- , ResizeFC rep (int + int) (frac + frac) int frac , MResult (rep (int + frac)) (rep (int + frac)) ~ rep ((int + int) + (frac + frac))+ , BitSize (rep ((int + int) + (frac + frac))) ~+ (int + ((int + frac) + frac))+ , BitPack (rep ((int + int) + (frac + frac)))+ , Bits (rep ((int + int) + (frac + frac)))+ , KnownNat (BitSize (rep (int + frac)))+ , BitPack (rep (int + frac))+ , Enum (rep (int + frac))+ , Bits (rep (int + frac))+ , Resize rep+ , KnownNat int+ , KnownNat frac ) -- | Constraint for the 'Num' instance of 'SFixed' type NumSFixedC int frac =- ( KnownNat frac+ ( KnownNat ((int + int) + (frac + frac)) , KnownNat (frac + frac)+ , KnownNat (int + int) , KnownNat (int + frac)- , KnownNat (1 + (int + frac))- , KnownNat ((int + frac) + (int + frac))- , ((int + int) + (frac + frac)) ~ ((int + frac) + (int + frac))+ , KnownNat frac+ , KnownNat int )+ -- | Constraint for the 'Num' instance of 'UFixed' type NumUFixedC int frac = NumSFixedC int frac@@ -434,7 +463,7 @@ negate (Fixed a) = Fixed (negate a) abs (Fixed a) = Fixed (abs a) signum (Fixed a) = Fixed (signum a)- fromInteger i = let fSH = fromInteger (natVal (Proxy :: Proxy frac))+ fromInteger i = let fSH = fromInteger (natVal (Proxy @frac)) res = Fixed (fromInteger i `shiftL` fSH) in res @@ -464,18 +493,21 @@ , Num (rep (int1 + frac1)) , Bits (rep (int1 + frac1)) , Bits (rep (int2 + frac2))+ , Bounded (rep (int2 + frac2))+ , KnownNat int1 , KnownNat frac1+ , KnownNat int2 , KnownNat frac2- , KnownNat (int1 + frac1)- , KnownNat (int2 + frac2) ) -- | Constraint for the 'resizeF' function, specialized for 'SFixed' type ResizeSFC int1 frac1 int2 frac2- = ( KnownNat frac1+ = ( KnownNat int1+ , KnownNat frac1+ , KnownNat int2 , KnownNat frac2- , KnownNat (int1 + frac1) , KnownNat (int2 + frac2)+ , KnownNat (int1 + frac1) ) -- | Constraint for the 'resizeF' function, specialized for 'UFixed'@@ -507,24 +539,18 @@ -- -- * @'ResizeUFC' rep int1 frac1 int2 frac2@ for: -- @'UFixed' int1 frac1 -> 'UFixed' int2 frac2@-resizeF ::(ResizeFC rep int1 frac1 int2 frac2, Bounded (rep (int2 + frac2)))+resizeF :: forall rep int1 frac1 int2 frac2 . ResizeFC rep int1 frac1 int2 frac2 => Fixed rep int1 frac1 -> Fixed rep int2 frac2-resizeF = resizeF' False minBound maxBound--resizeF' :: forall rep int1 frac1 int2 frac2 . ResizeFC rep int1 frac1 int2 frac2- => Bool -- ^ Wrap- -> rep (int2 + frac2) -- ^ minBound- -> rep (int2 + frac2) -- ^ maxBound- -> Fixed rep int1 frac1- -> Fixed rep int2 frac2-resizeF' doWrap fMin fMax (Fixed fRep) = Fixed sat+resizeF (Fixed fRep) = Fixed sat where- argSZ = natVal (Proxy :: Proxy (int1 + frac1))- resSZ = natVal (Proxy :: Proxy (int2 + frac2))+ fMin = minBound :: rep (int2 + frac2)+ fMax = maxBound :: rep (int2 + frac2)+ argSZ = natVal (Proxy @(int1 + frac1))+ resSZ = natVal (Proxy @(int2 + frac2)) - argFracSZ = fromInteger (natVal (Proxy :: Proxy frac1))- resFracSZ = fromInteger (natVal (Proxy :: Proxy frac2))+ argFracSZ = fromInteger (natVal (Proxy @frac1))+ resFracSZ = fromInteger (natVal (Proxy @frac2)) -- All size and frac comparisons and related if-then-else statements should -- be optimized away by the compiler@@ -540,7 +566,7 @@ (resFracSZ - argFracSZ) shiftedL_masked = shiftedL .&. mask shiftedL_resized = resize shiftedL- in if doWrap then shiftedL_resized else if fRep >= 0+ in if fRep >= 0 then if shiftedL_masked == 0 then shiftedL_resized else fMax@@ -551,7 +577,7 @@ (argFracSZ - resFracSZ) shiftedR_masked = shiftedR .&. mask shiftedR_resized = resize shiftedR- in if doWrap then shiftedR_resized else if fRep >= 0+ in if fRep >= 0 then if shiftedR_masked == 0 then shiftedR_resized else fMax@@ -608,7 +634,7 @@ then rMin else truncated truncated = truncate shifted :: Integer- shifted = a * (2 ^ (natVal (Proxy :: Proxy frac)))+ shifted = a * (2 ^ (natVal (Proxy @frac))) -- | Convert, at run-time, a 'Double' to a 'Fixed'-point. --@@ -660,7 +686,7 @@ -- We then compile this to an executable: -- -- @--- $ clash --make createRomFile.hs+-- \$ clash --make createRomFile.hs -- @ -- -- We can then use this utility to convert our @Data.txt@ file which contains@@ -668,7 +694,7 @@ -- binary data: -- -- @--- $ ./createRomFile \"Data.txt\" \"Data.bin\"+-- \$ ./createRomFile \"Data.txt\" \"Data.bin\" -- @ -- -- Which results in a @Data.bin@ file containing:@@ -773,41 +799,82 @@ then rMin else truncated truncated = truncate shifted :: Integer- shifted = a * (2 ^ (natVal (Proxy :: Proxy frac)))+ shifted = a * (2 ^ (natVal (Proxy @frac))) instance NumFixedC rep int frac => SaturatingNum (Fixed rep int frac) where satPlus w (Fixed a) (Fixed b) = Fixed (satPlus w a b) satMin w (Fixed a) (Fixed b) = Fixed (satMin w a b)- satMult w (Fixed a) (Fixed b) = case w of- SatWrap -> resizeF' True 0 0 res- SatBound -> resizeF' False minBound maxBound res- SatZero -> resizeF' False 0 0 res- SatSymmetric -> resizeF' False fMinSym maxBound res- where- res = Fixed (a `times` b) :: Fixed rep (int + int) (frac + frac)- fMinSym = if isSigned a- then 0- else minBound + 1 + satMult SatWrap (Fixed a) (Fixed b) =+ let res = a `times` b+ sh = fromInteger (natVal (Proxy @frac))+ res' = shiftR res sh+ in Fixed (resize res')++ satMult SatBound (Fixed a) (Fixed b) =+ let res = a `times` b+ sh = fromInteger (natVal (Proxy @frac))+ (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac))+ in case isSigned a of+ True -> let overflow = complement (reduceOr (msb rR ++# pack rL)) .|.+ reduceAnd (msb rR ++# pack rL)+ in case overflow of+ 1 -> unpack (resize (shiftR rR sh))+ _ -> case msb rL of+ 0 -> maxBound+ _ -> minBound+ False -> case rL of+ 0 -> unpack (resize (shiftR rR sh))+ _ -> maxBound++ satMult SatZero (Fixed a) (Fixed b) =+ let res = a `times` b+ sh = fromInteger (natVal (Proxy @frac))+ (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac))+ in case isSigned a of+ True -> let overflow = complement (reduceOr (msb rR ++# pack rL)) .|.+ reduceAnd (msb rR ++# pack rL)+ in case overflow of+ 1 -> unpack (resize (shiftR rR sh))+ _ -> 0+ False -> case rL of+ 0 -> unpack (resize (shiftR rR sh))+ _ -> 0++ satMult SatSymmetric (Fixed a) (Fixed b) =+ let res = a `times` b+ sh = fromInteger (natVal (Proxy @frac))+ (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac))+ in case isSigned a of+ True -> let overflow = complement (reduceOr (msb rR ++# pack rL)) .|.+ reduceAnd (msb rR ++# pack rL)+ in case overflow of+ 1 -> unpack (resize (shiftR rR sh))+ _ -> case msb rL of+ 0 -> maxBound+ _ -> succ minBound+ False -> case rL of+ 0 -> unpack (resize (shiftR rR sh))+ _ -> maxBound+ -- | Constraint for the 'divide' function type DivideC rep int1 frac1 int2 frac2 = ( Resize rep , Integral (rep (((int1 + frac2) + 1) + (int2 + frac1))) , Bits (rep (((int1 + frac2) + 1) + (int2 + frac1)))+ , KnownNat int1+ , KnownNat frac1 , KnownNat int2 , KnownNat frac2- , KnownNat (int1 + frac1)- , KnownNat (int2 + frac2)- , KnownNat ((int1 + frac2 + 1) + (int2 + frac1)) ) -- | Constraint for the 'divide' function, specialized for 'SFixed' type DivideSC int1 frac1 int2 frac2- = ( KnownNat int2+ = ( KnownNat (((int1 + frac2) + 1) + (int2 + frac1)) , KnownNat frac2- , KnownNat (int1 + frac1)- , KnownNat (int2 + frac2)- , KnownNat ((int1 + frac2 + 1) + (int2 + frac1))+ , KnownNat int2+ , KnownNat frac1+ , KnownNat int1 ) -- | Constraint for the 'divide' function, specialized for 'UFixed'@@ -831,26 +898,27 @@ => Fixed rep int1 frac1 -> Fixed rep int2 frac2 -> Fixed rep (int1 + frac2 + 1) (int2 + frac1)-divide (Fixed fr1) fx2@(Fixed fr2) = Fixed res- where- int2 = fromInteger (natVal (asIntProxy fx2))- frac2 = fromInteger (natVal fx2)- fr1' = resize fr1- fr2' = resize fr2- fr1SH = shiftL fr1' ((int2 + frac2))- res = fr1SH `quot` fr2'+divide (Fixed fr1) fx2@(Fixed fr2) =+ let int2 = fromInteger (natVal (asIntProxy fx2))+ frac2 = fromInteger (natVal fx2)+ fr1' = resize fr1+ fr2' = resize fr2+ fr1SH = shiftL fr1' ((int2 + frac2))+ res = fr1SH `quot` fr2'+ in Fixed res -- | Constraint for the 'Fractional' instance of 'Fixed' type FracFixedC rep int frac = ( NumFixedC rep int frac , DivideC rep int frac int frac , Integral (rep (int + frac))+ , KnownNat int+ , KnownNat frac ) -- | Constraint for the 'Fractional' instance of 'SFixed' type FracSFixedC int frac = ( NumSFixedC int frac- , KnownNat int , KnownNat ((int + frac + 1) + (int + frac)) ) @@ -868,7 +936,7 @@ -- * @'FracFixedC' frac rep size@ for: @'Fixed' frac rep size@ -- * @'FracSFixedC' int frac@ for: @'SFixed' int frac@ -- * @'FracUFixedC' int frac@ for: @'UFixed' int frac@-instance (FracFixedC rep int frac) => Fractional (Fixed rep int frac) where+instance FracFixedC rep int frac => Fractional (Fixed rep int frac) where f1 / f2 = resizeF (divide f1 f2) recip fx = resizeF (divide (1 :: Fixed rep int frac) fx) fromRational r = res
src/CLaSH/Sized/Index.hs view
@@ -4,14 +4,13 @@ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_HADDOCK show-extensions #-} @@ -22,6 +21,7 @@ import GHC.TypeLits (KnownNat, type (^)) import GHC.TypeLits.Extra (CLog) -- documentation only +import CLaSH.Promoted.Nat (SNat (..), pow2SNat) import CLaSH.Sized.BitVector (BitVector) import CLaSH.Sized.Internal.Index @@ -42,5 +42,5 @@ -- -- 'bv2i' on the other hand will /never/ fail at run-time, because the -- 'BitVector' argument determines the size.-bv2i :: KnownNat (2^n) => BitVector n -> Index (2^n)+bv2i :: KnownNat n => BitVector n -> Index (2^n) bv2i = unpack#
src/CLaSH/Sized/Internal/BitVector.hs view
@@ -4,20 +4,22 @@ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Sized.Internal.BitVector@@ -88,6 +90,9 @@ , rotateL# , rotateR# , popCountBV+ -- ** FiniteBits+ , countLeadingZerosBV+ , countTrailingZerosBV -- ** Resize , resize# -- ** QuickCheck@@ -106,6 +111,7 @@ import GHC.Integer (smallInteger) import GHC.Prim (dataToTag#) import GHC.TypeLits (KnownNat, Nat, type (+), type (-), natVal)+import GHC.TypeLits.Extra (Max) import Language.Haskell.TH (Q, TExp, TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) import Numeric (readInt)@@ -116,8 +122,8 @@ import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..), SaturationMode (..)) import CLaSH.Class.Resize (Resize (..))-import CLaSH.Promoted.Nat (SNat, snatToInteger)-import CLaSH.Promoted.Ord (Max)+import CLaSH.Promoted.Nat (SNat, snatToInteger, snatToNum)+import CLaSH.XException (ShowX (..), showsPrecXWith) import {-# SOURCE #-} qualified CLaSH.Sized.Vector as V import {-# SOURCE #-} qualified CLaSH.Sized.Internal.Index as I@@ -137,7 +143,7 @@ -- | The constructor, 'BV', and the field, 'unsafeToInteger', are not -- synthesisable. BV { unsafeToInteger :: Integer}- deriving Data+ deriving (Data) -- | 'Bit': a 'BitVector' of length 1 type Bit = BitVector 1@@ -163,6 +169,9 @@ (rest,_) -> rest {-# NOINLINE show #-} +instance KnownNat n => ShowX (BitVector n) where+ showsPrecX = showsPrecXWith showsPrec+ -- | Create a binary literal -- -- >>> $$(bLit "1001") :: BitVector 4@@ -236,12 +245,12 @@ {-# NOINLINE enumFromThen# #-} {-# NOINLINE enumFromTo# #-} {-# NOINLINE enumFromThenTo# #-}-enumFrom# :: BitVector n -> [BitVector n]-enumFromThen# :: BitVector n -> BitVector n -> [BitVector n]+enumFrom# :: KnownNat n => BitVector n -> [BitVector n]+enumFromThen# :: KnownNat n => BitVector n -> BitVector n -> [BitVector n] enumFromTo# :: BitVector n -> BitVector n -> [BitVector n] enumFromThenTo# :: BitVector n -> BitVector n -> BitVector n -> [BitVector n]-enumFrom# x = map BV [unsafeToInteger x ..]-enumFromThen# x y = map BV [unsafeToInteger x, unsafeToInteger y ..]+enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..]+enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] enumFromTo# x y = map BV [unsafeToInteger x .. unsafeToInteger y] enumFromThenTo# x1 x2 y = map BV [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] @@ -254,8 +263,9 @@ minBound# = BV 0 {-# NOINLINE maxBound# #-}-maxBound# :: KnownNat n => BitVector n-maxBound# = let res = BV ((2 ^ natVal res) - 1) in res+maxBound# :: forall n . KnownNat n => BitVector n+maxBound# = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))+ in BV (m-1) instance KnownNat n => Num (BitVector n) where (+) = (+#)@@ -266,21 +276,26 @@ signum bv = resize# (reduceOr# bv) fromInteger = fromInteger# -(+#),(-#),(*#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n+(+#),(-#),(*#) :: forall n . KnownNat n => BitVector n -> BitVector n -> BitVector n {-# NOINLINE (+#) #-}-(+#) (BV i) (BV j) = fromInteger_INLINE (i + j)+(+#) (BV i) (BV j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))+ z = i + j+ in if z >= m then BV (z - m) else BV z {-# NOINLINE (-#) #-}-(-#) (BV i) (BV j) = fromInteger_INLINE (i - j)+(-#) (BV i) (BV j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))+ z = i - j+ in if z < 0 then BV (m + z) else BV z {-# NOINLINE (*#) #-} (*#) (BV i) (BV j) = fromInteger_INLINE (i * j) {-# NOINLINE negate# #-}-negate# :: KnownNat n => BitVector n -> BitVector n-negate# bv@(BV i) = sz `seq` BV (sz - i)+negate# :: forall n . KnownNat n => BitVector n -> BitVector n+negate# (BV 0) = BV 0+negate# (BV i) = BV (sz - i) where- sz = 2 ^ natVal bv+ sz = 1 `shiftL` fromInteger (natVal (Proxy @n)) {-# NOINLINE fromInteger# #-} fromInteger# :: KnownNat n => Integer -> BitVector n@@ -288,29 +303,33 @@ {-# INLINE fromInteger_INLINE #-} fromInteger_INLINE :: forall n . KnownNat n => Integer -> BitVector n-fromInteger_INLINE i = sz `seq` BV (i `mod` (shiftL 1 sz))+fromInteger_INLINE i = sz `seq` BV (i `mod` sz) where- sz = fromInteger (natVal (Proxy :: Proxy n))+ sz = 1 `shiftL` fromInteger (natVal (Proxy @n)) -instance (KnownNat (Max m n + 1), KnownNat (m + n)) =>- ExtendingNum (BitVector m) (BitVector n) where+instance (KnownNat m, KnownNat n) => ExtendingNum (BitVector m) (BitVector n) where type AResult (BitVector m) (BitVector n) = BitVector (Max m n + 1) plus = plus# minus = minus# type MResult (BitVector m) (BitVector n) = BitVector (m + n) times = times# -plus#, minus# :: KnownNat (Max m n + 1) => BitVector m -> BitVector n- -> BitVector (Max m n + 1) {-# NOINLINE plus# #-}-plus# (BV a) (BV b) = fromInteger_INLINE (a + b)+plus# :: BitVector m -> BitVector n -> BitVector (Max m n + 1)+plus# (BV a) (BV b) = BV (a + b) {-# NOINLINE minus# #-}-minus# (BV a) (BV b) = fromInteger_INLINE (a - b)+minus# :: forall m n . (KnownNat m, KnownNat n) => BitVector m -> BitVector n+ -> BitVector (Max m n + 1)+minus# (BV a) (BV b) =+ let sz = fromInteger (natVal (Proxy @(Max m n + 1)))+ mask = 1 `shiftL` sz+ z = a - b+ in if z < 0 then BV (mask + z) else BV z {-# NOINLINE times# #-}-times# :: KnownNat (m + n) => BitVector m -> BitVector n -> BitVector (m + n)-times# (BV a) (BV b) = fromInteger_INLINE (a * b)+times# :: BitVector m -> BitVector n -> BitVector (m + n)+times# (BV a) (BV b) = BV (a * b) instance KnownNat n => Real (BitVector n) where toRational = toRational . toInteger#@@ -334,7 +353,7 @@ toInteger# :: BitVector n -> Integer toInteger# (BV i) = i -instance (KnownNat n, KnownNat (n+1), KnownNat (n+2)) => Bits (BitVector n) where+instance KnownNat n => Bits (BitVector n) where (.&.) = and# (.|.) = or# xor = xor#@@ -352,13 +371,23 @@ shiftR v i = shiftR# v i rotateL v i = rotateL# v i rotateR v i = rotateR# v i- popCount bv = fromEnum (popCountBV (bv ++# (0 :: Bit)))+ popCount bv = fromInteger (I.toInteger# (popCountBV (bv ++# (0 :: Bit)))) -instance (KnownNat n, KnownNat (n+1), KnownNat (n+2)) => FiniteBits (BitVector n) where- finiteBitSize = size#+instance KnownNat n => FiniteBits (BitVector n) where+ finiteBitSize = size#+ countLeadingZeros = fromInteger . I.toInteger# . countLeadingZerosBV+ countTrailingZeros = fromInteger . I.toInteger# . countTrailingZerosBV +countLeadingZerosBV :: KnownNat n => BitVector n -> I.Index (n+1)+countLeadingZerosBV = V.foldr (\l r -> if eq# l low then 1 + r else 0) 0 . V.bv2v+{-# INLINE countLeadingZerosBV #-}++countTrailingZerosBV :: KnownNat n => BitVector n -> I.Index (n+1)+countTrailingZerosBV = V.foldl (\l r -> if eq# r low then 1 + l else 0) 0 . V.bv2v+{-# INLINE countTrailingZerosBV #-}+ {-# NOINLINE reduceAnd# #-}-reduceAnd# :: (KnownNat n) => BitVector n -> BitVector 1+reduceAnd# :: KnownNat n => BitVector n -> BitVector 1 reduceAnd# bv@(BV i) = BV (smallInteger (dataToTag# check)) where check = i == maxI@@ -408,10 +437,10 @@ {-# NOINLINE msb# #-} -- | MSB-msb# :: KnownNat n => BitVector n -> Bit-msb# bv@(BV v) = BV (smallInteger (dataToTag# (testBit v i)))- where- i = fromInteger (natVal bv - 1)+msb# :: forall n . KnownNat n => BitVector n -> Bit+msb# (BV v)+ = let i = fromInteger (natVal (Proxy @n) - 1)+ in BV (smallInteger (dataToTag# (testBit v i))) {-# NOINLINE lsb# #-} -- | LSB@@ -423,7 +452,7 @@ slice# (BV i) m n = BV (shiftR (i .&. mask) n') where m' = snatToInteger m- n' = fromInteger (snatToInteger n)+ n' = snatToNum n mask = 2 ^ (m' + 1) - 1 @@ -474,13 +503,16 @@ mask = complement ((2 ^ (m' + 1) - 1) `xor` (2 ^ n' - 1)) {-# NOINLINE split# #-}-split# :: KnownNat n => BitVector (m + n) -> (BitVector m, BitVector n)-split# (BV i) = (l,r)+split# :: forall n m . KnownNat n+ => BitVector (m + n) -> (BitVector m, BitVector n)+split# (BV i) = (BV l, BV r) where- n = fromInteger (natVal r)- mask = (2 ^ n) - 1- r = BV (i .&. mask)- l = BV (i `shiftR` n)+ n = fromInteger (natVal (Proxy @n))+ mask = 1 `shiftL` n+ -- The code below is faster than:+ -- > (l,r) = i `divMod` mask+ r = i `mod` mask+ l = i `shiftR` n and#, or#, xor# :: BitVector n -> BitVector n -> BitVector n {-# NOINLINE and# #-}@@ -496,8 +528,9 @@ complement# :: KnownNat n => BitVector n -> BitVector n complement# (BV v1) = fromInteger_INLINE (complement v1) -shiftL#, shiftR#, rotateL#, rotateR# :: KnownNat n => BitVector n -> Int- -> BitVector n+shiftL#, rotateL#, rotateR# :: KnownNat n+ => BitVector n -> Int -> BitVector n+ {-# NOINLINE shiftL# #-} shiftL# (BV v) i | i < 0 = error@@ -505,10 +538,11 @@ | otherwise = fromInteger_INLINE (shiftL v i) {-# NOINLINE shiftR# #-}+shiftR# :: BitVector n -> Int -> BitVector n shiftR# (BV v) i | i < 0 = error $ "'shiftR undefined for negative number: " ++ show i- | otherwise = fromInteger_INLINE (shiftR v i)+ | otherwise = BV (shiftR v i) {-# NOINLINE rotateL# #-} rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers"@@ -532,23 +566,21 @@ b'' = sz - b' sz = fromInteger (natVal bv) -popCountBV :: (KnownNat (n+1), KnownNat (n + 2))- => BitVector (n+1)- -> I.Index (n+2)-popCountBV bv = sum (V.map fromIntegral v)- where- v = V.bv2v bv+popCountBV :: forall n . KnownNat n => BitVector (n+1) -> I.Index (n+2)+popCountBV bv =+ let v = V.bv2v bv+ in sum (V.map fromIntegral v) {-# INLINE popCountBV #-} instance Resize BitVector where resize = resize#- zeroExtend = resize#- signExtend = resize#+ zeroExtend = extend truncateB = resize# {-# NOINLINE resize# #-}-resize# :: KnownNat m => BitVector n -> BitVector m-resize# (BV n) = fromInteger_INLINE n+resize# :: forall n m . KnownNat m => BitVector n -> BitVector m+resize# (BV i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @m))+ in if i >= m then fromInteger_INLINE i else BV i instance KnownNat n => Lift (BitVector n) where lift bv@(BV i) = sigE [| fromInteger# i |] (decBitVector (natVal bv))@@ -557,33 +589,39 @@ decBitVector :: Integer -> TypeQ decBitVector n = appT (conT ''BitVector) (litT $ numTyLit n) -instance (KnownNat n, KnownNat (n + 1), KnownNat (n + n)) =>- SaturatingNum (BitVector n) where+instance KnownNat n => SaturatingNum (BitVector n) where satPlus SatWrap a b = a +# b- satPlus w a b = case msb# r of- 0 -> resize# r- _ -> case w of- SatZero -> minBound#- _ -> maxBound#- where- r = plus# a b+ satPlus SatZero a b =+ let r = plus# a b+ in case msb# r of+ 0 -> resize# r+ _ -> minBound#+ satPlus _ a b =+ let r = plus# a b+ in case msb# r of+ 0 -> resize# r+ _ -> maxBound# satMin SatWrap a b = a -# b- satMin _ a b = case msb# r of- 0 -> resize# r- _ -> minBound#- where- r = minus# a b+ satMin _ a b =+ let r = minus# a b+ in case msb# r of+ 0 -> resize# r+ _ -> minBound# satMult SatWrap a b = a *# b- satMult w a b = case rL of- 0 -> rR- _ -> case w of- SatZero -> minBound#- _ -> maxBound#- where- r = times# a b- (rL,rR) = split# r+ satMult SatZero a b =+ let r = times# a b+ (rL,rR) = split# r+ in case rL of+ 0 -> rR+ _ -> minBound#+ satMult _ a b =+ let r = times# a b+ (rL,rR) = split# r+ in case rL of+ 0 -> rR+ _ -> maxBound# instance KnownNat n => Arbitrary (BitVector n) where arbitrary = arbitraryBoundedIntegral
src/CLaSH/Sized/Internal/Index.hs view
@@ -11,17 +11,21 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Sized.Internal.Index ( -- * Datatypes Index (..)+ -- * Construction+ , fromSNat -- * Type classes -- ** BitConvert , pack#@@ -66,17 +70,20 @@ import Text.Read (Read (..), ReadPrec) import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..))-import GHC.TypeLits (KnownNat, Nat, type (+), type (-), type (*),- natVal)+import GHC.TypeLits (CmpNat, KnownNat, Nat, type (+), type (-),+ type (*), type (<=), type (^), natVal) import GHC.TypeLits.Extra (CLog) import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..), arbitraryBoundedIntegral, coarbitraryIntegral, shrinkIntegral) -import CLaSH.Class.BitPack (BitPack (..))-import CLaSH.Class.Num (ExtendingNum (..))-import CLaSH.Class.Resize (Resize (..))+import CLaSH.Class.BitPack (BitPack (..))+import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..),+ SaturationMode (..))+import CLaSH.Class.Resize (Resize (..)) import {-# SOURCE #-} CLaSH.Sized.Internal.BitVector (BitVector (BV))+import CLaSH.Promoted.Nat (SNat, snatToNum)+import CLaSH.XException (ShowX (..), showsPrecXWith) -- | Arbitrary-bounded unsigned integer represented by @ceil(log_2(n))@ bits. --@@ -92,12 +99,15 @@ -- 3 -- >>> 2 + 6 :: Index 8 -- *** Exception: CLaSH.Sized.Index: result 8 is out of bounds: [0..7]+-- ... -- >>> 1 - 3 :: Index 8 -- *** Exception: CLaSH.Sized.Index: result -2 is out of bounds: [0..7]+-- ... -- >>> 2 * 3 :: Index 8 -- 6 -- >>> 2 * 4 :: Index 8 -- *** Exception: CLaSH.Sized.Index: result 8 is out of bounds: [0..7]+-- ... newtype Index (n :: Nat) = -- | The constructor, 'I', and the field, 'unsafeToInteger', are not -- synthesisable.@@ -115,6 +125,10 @@ pack = pack# unpack = unpack# +-- | Safely convert an `SNat` value to an `Index`+fromSNat :: (KnownNat m, CmpNat n m ~ 'LT) => SNat n -> Index m+fromSNat = snatToNum+ {-# NOINLINE pack# #-} pack# :: Index n -> BitVector (CLog 2 n) pack# (I i) = BV i@@ -167,12 +181,12 @@ {-# NOINLINE enumFromThen# #-} {-# NOINLINE enumFromTo# #-} {-# NOINLINE enumFromThenTo# #-}-enumFrom# :: Index n -> [Index n]-enumFromThen# :: Index n -> Index n -> [Index n]+enumFrom# :: KnownNat n => Index n -> [Index n]+enumFromThen# :: KnownNat n => Index n -> Index n -> [Index n] enumFromTo# :: Index n -> Index n -> [Index n] enumFromThenTo# :: Index n -> Index n -> Index n -> [Index n]-enumFrom# x = map I [unsafeToInteger x ..]-enumFromThen# x y = map I [unsafeToInteger x, unsafeToInteger y ..]+enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..]+enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] enumFromTo# x y = map I [unsafeToInteger x .. unsafeToInteger y] enumFromThenTo# x1 x2 y = map I [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] @@ -209,10 +223,9 @@ fromInteger# = fromInteger_INLINE {-# INLINE fromInteger_INLINE #-} fromInteger_INLINE :: forall n . KnownNat n => Integer -> Index n-fromInteger_INLINE i = bound `seq` if i' == i then I i else err+fromInteger_INLINE i = bound `seq` if i > (-1) && i < bound then I i else err where- bound = natVal (Proxy :: Proxy n)- i' = i `mod` bound+ bound = natVal (Proxy @n) err = error ("CLaSH.Sized.Index: result " ++ show i ++ " is out of bounds: [0.." ++ show (bound - 1) ++ "]") @@ -239,6 +252,43 @@ times# :: Index m -> Index n -> Index (((m - 1) * (n - 1)) + 1) times# (I a) (I b) = I (a * b) +instance (KnownNat n, 1 <= (n*2), (n*2) <= (n^2)) => SaturatingNum (Index n) where+ satPlus SatWrap a b = case plus# a b of+ z | let m = fromInteger# (natVal (Proxy @ n))+ , z >= m -> resize# (z - m)+ z -> resize# z+ satPlus SatZero a b = case plus# a b of+ z | let m = fromInteger# (natVal (Proxy @ n))+ , z >= m -> fromInteger# 0+ z -> resize# z+ satPlus _ a b = case plus# a b of+ z | let m = fromInteger# (natVal (Proxy @ n))+ , z >= m -> maxBound#+ z -> resize# z++ satMin SatWrap a b =+ if lt# a b+ then maxBound -# (b -# a) +# 1+ else a -# b++ satMin _ a b =+ if lt# a b+ then fromInteger# 0+ else a -# b++ satMult SatWrap a b = case times# a b of+ z | let m = fromInteger# (natVal (Proxy @ n))+ , z >= m -> resize# (z - m)+ z -> resize# z+ satMult SatZero a b = case times# a b of+ z | let m = fromInteger# (natVal (Proxy @ n))+ , z >= m -> fromInteger# 0+ z -> resize# z+ satMult _ a b = case times# a b of+ z | let m = fromInteger# (natVal (Proxy @ n))+ , z >= m -> maxBound#+ z -> resize# z+ instance KnownNat n => Real (Index n) where toRational = toRational . toInteger# @@ -263,8 +313,7 @@ instance Resize Index where resize = resize#- zeroExtend = resize#- signExtend = resize#+ zeroExtend = extend truncateB = resize# resize# :: KnownNat m => Index n -> Index m@@ -281,6 +330,9 @@ instance Show (Index n) where show (I i) = show i {-# NOINLINE show #-}++instance ShowX (Index n) where+ showsPrecX = showsPrecXWith showsPrec -- | None of the 'Read' class' methods are synthesisable. instance KnownNat n => Read (Index n) where
src/CLaSH/Sized/Internal/Index.hs-boot view
@@ -6,6 +6,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE RoleAnnotations #-} module CLaSH.Sized.Internal.Index where @@ -15,4 +16,4 @@ data Index :: Nat -> * instance KnownNat n => Num (Index n)-instance KnownNat n => Enum (Index n)+toInteger# :: Index n -> Integer
src/CLaSH/Sized/Internal/Signed.hs view
@@ -4,21 +4,24 @@ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} {-# OPTIONS_HADDOCK show-extensions #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} module CLaSH.Sized.Internal.Signed ( -- * Datatypes@@ -88,6 +91,7 @@ import Data.Proxy (Proxy (..)) import Text.Read (Read (..), ReadPrec) import GHC.TypeLits (KnownNat, Nat, type (+), natVal)+import GHC.TypeLits.Extra (Max) import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..),@@ -100,9 +104,9 @@ import CLaSH.Class.Resize (Resize (..)) import CLaSH.Prelude.BitIndex ((!), msb, replaceBit, split) import CLaSH.Prelude.BitReduction (reduceAnd, reduceOr)-import CLaSH.Promoted.Ord (Max) import CLaSH.Sized.Internal.BitVector (BitVector (BV), Bit, (++#), high, low) import qualified CLaSH.Sized.Internal.BitVector as BV+import CLaSH.XException (ShowX (..), showsPrecXWith) -- | Arbitrary-width signed integer represented by @n@ bits, including the sign -- bit.@@ -143,7 +147,7 @@ -- | The constructor, 'S', and the field, 'unsafeToInteger', are not -- synthesisable. S { unsafeToInteger :: Integer}- deriving Data+ deriving (Data) {-# NOINLINE size# #-} size# :: KnownNat n => Signed n -> Int@@ -159,6 +163,9 @@ show (S i) = show i {-# NOINLINE show #-} +instance ShowX (Signed n) where+ showsPrecX = showsPrecXWith showsPrec+ -- | None of the 'Read' class' methods are synthesisable. instance KnownNat n => Read (Signed n) where readPrec = fromIntegral <$> (readPrec :: ReadPrec Int)@@ -169,14 +176,15 @@ unpack = unpack# {-# NOINLINE pack# #-}-pack# :: KnownNat n => Signed n -> BitVector n-pack# s@(S i) = BV (i `mod` maxI)- where- maxI = 2 ^ natVal s+pack# :: forall n . KnownNat n => Signed n -> BitVector n+pack# (S i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))+ in if i < 0 then BV (m + i) else BV i {-# NOINLINE unpack# #-}-unpack# :: KnownNat n => BitVector n -> Signed n-unpack# (BV i) = fromInteger_INLINE i+unpack# :: forall n . KnownNat n => BitVector n -> Signed n+unpack# (BV i) =+ let m = 1 `shiftL` fromInteger (natVal (Proxy @n) - 1)+ in if i >= m then S (i-2*m) else S i instance Eq (Signed n) where (==) = eq#@@ -222,12 +230,12 @@ {-# NOINLINE enumFromThen# #-} {-# NOINLINE enumFromTo# #-} {-# NOINLINE enumFromThenTo# #-}-enumFrom# :: Signed n -> [Signed n]-enumFromThen# :: Signed n -> Signed n -> [Signed n]+enumFrom# :: KnownNat n => Signed n -> [Signed n]+enumFromThen# :: KnownNat n => Signed n -> Signed n -> [Signed n] enumFromTo# :: Signed n -> Signed n -> [Signed n] enumFromThenTo# :: Signed n -> Signed n -> Signed n -> [Signed n]-enumFrom# x = map S [unsafeToInteger x ..]-enumFromThen# x y = map S [unsafeToInteger x, unsafeToInteger y ..]+enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..]+enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] enumFromTo# x y = map S [unsafeToInteger x .. unsafeToInteger y] enumFromThenTo# x1 x2 y = map S [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] @@ -253,22 +261,32 @@ if s > 0 then 1 else 0 fromInteger = fromInteger# -(+#), (-#), (*#) :: KnownNat n => Signed n -> Signed n -> Signed n+(+#), (-#), (*#) :: forall n . KnownNat n => Signed n -> Signed n -> Signed n {-# NOINLINE (+#) #-}-(S a) +# (S b) = fromInteger_INLINE (a + b)+(S a) +# (S b) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1)+ z = a + b+ in if z >= m then S (z - 2*m) else+ if z < negate m then S (z + 2*m) else S z {-# NOINLINE (-#) #-}-(S a) -# (S b) = fromInteger_INLINE (a - b)+(S a) -# (S b) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1)+ z = a - b+ in if z < negate m then S (z + 2*m) else+ if z >= m then S (z - 2*m) else S z {-# NOINLINE (*#) #-} (S a) *# (S b) = fromInteger_INLINE (a * b) -negate#,abs# :: KnownNat n => Signed n -> Signed n+negate#,abs# :: forall n . KnownNat n => Signed n -> Signed n {-# NOINLINE negate# #-}-negate# (S n) = fromInteger_INLINE (negate n)+negate# (S n) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1)+ z = negate n+ in if z == m then S n else S z {-# NOINLINE abs# #-}-abs# (S n) = fromInteger_INLINE (abs n)+abs# (S n) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1)+ z = abs n+ in if z == m then S n else S z {-# NOINLINE fromInteger# #-} fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat)@@ -276,33 +294,30 @@ {-# INLINE fromInteger_INLINE #-} fromInteger_INLINE :: forall n . KnownNat n => Integer -> Signed n-fromInteger_INLINE i = sz `seq` if sz == 0 then S 0 else S res+fromInteger_INLINE i = mask `seq` S res where- sz = natVal (Proxy :: Proxy n)- mask = shiftL 1 (fromInteger sz - 1)+ mask = 1 `shiftL` fromInteger (natVal (Proxy @n) -1) res = case divMod i mask of (s,i') | even s -> i' | otherwise -> i' - mask -instance (KnownNat (1 + Max m n), KnownNat (m + n)) =>- ExtendingNum (Signed m) (Signed n) where- type AResult (Signed m) (Signed n) = Signed (1 + Max m n)+instance ExtendingNum (Signed m) (Signed n) where+ type AResult (Signed m) (Signed n) = Signed (Max m n + 1) plus = plus# minus = minus# type MResult (Signed m) (Signed n) = Signed (m + n) times = times# -plus#, minus# :: KnownNat (1 + Max m n) => Signed m -> Signed n- -> Signed (1 + Max m n)+plus#, minus# :: Signed m -> Signed n -> Signed (Max m n + 1) {-# NOINLINE plus# #-}-plus# (S a) (S b) = fromInteger_INLINE (a + b)+plus# (S a) (S b) = S (a + b) {-# NOINLINE minus# #-}-minus# (S a) (S b) = fromInteger_INLINE (a - b)+minus# (S a) (S b) = S (a - b) {-# NOINLINE times# #-}-times# :: KnownNat (m + n) => Signed m -> Signed n -> Signed (m + n)-times# (S a) (S b) = fromInteger_INLINE (a * b)+times# :: Signed m -> Signed n -> Signed (m + n)+times# (S a) (S b) = S (a * b) instance KnownNat n => Real (Signed n) where toRational = toRational . toInteger#@@ -332,7 +347,7 @@ toInteger# :: Signed n -> Integer toInteger# (S n) = n -instance (KnownNat n, KnownNat (n + 1), KnownNat (n + 2)) => Bits (Signed n) where+instance KnownNat n => Bits (Signed n) where (.&.) = and# (.|.) = or# xor = xor#@@ -395,32 +410,31 @@ b'' = sz - b' sz = fromInteger (natVal s) -instance (KnownNat n, KnownNat (n + 1), KnownNat (n + 2)) => FiniteBits (Signed n) where- finiteBitSize = size#+instance KnownNat n => FiniteBits (Signed n) where+ finiteBitSize = size#+ countLeadingZeros s = countLeadingZeros (pack# s)+ countTrailingZeros s = countTrailingZeros (pack# s) instance Resize Signed where resize = resize#- extend = resize# zeroExtend s = unpack# (0 ++# pack s)- signExtend = resize# truncateB = truncateB# {-# NOINLINE resize# #-}-resize# :: (KnownNat n, KnownNat m) => Signed n -> Signed m-resize# s@(S i) | n <= m = extended+resize# :: forall m n . (KnownNat n, KnownNat m) => Signed n -> Signed m+resize# s@(S i) | n' <= m' = extended | otherwise = truncated where- n = fromInteger (natVal s)- m = fromInteger (natVal extended)-- extended = fromInteger_INLINE i+ n = fromInteger (natVal s)+ n' = shiftL 1 n+ m' = shiftL mask 1+ extended = S i - mask = (2 ^ (m - 1)) - 1- sign = 2 ^ (m - 1)- i' = i .&. mask- truncated = if testBit i (n - 1)- then fromInteger_INLINE (i' .|. sign)- else fromInteger_INLINE i'+ mask = 1 `shiftL` fromInteger (natVal (Proxy @m) -1)+ i' = i `mod` mask+ truncated = if testBit i (n-1)+ then S (i' - mask)+ else S i' {-# NOINLINE truncateB# #-} truncateB# :: KnownNat m => Signed (m + n) -> Signed m@@ -436,55 +450,84 @@ decSigned :: Integer -> TypeQ decSigned n = appT (conT ''Signed) (litT $ numTyLit n) -instance (KnownNat n, KnownNat (1 + n), KnownNat (n + n)) =>- SaturatingNum (Signed n) where- satPlus SatWrap a b = a +# b- satPlus w a b = case msb r `xor` msb r' of- 0 -> unpack# r'- _ -> case msb a .&. msb b of- 1 -> case w of- SatBound -> minBound#- SatSymmetric -> minBoundSym#- _ -> fromInteger# 0- _ -> case w of- SatZero -> fromInteger# 0- _ -> maxBound#- where- r = plus# a b- (_,r') = split r+instance KnownNat n => SaturatingNum (Signed n) where+ satPlus SatWrap a b = a +# b+ satPlus SatBound a b =+ let r = plus# a b+ (_,r') = split r+ in case msb r `xor` msb r' of+ 0 -> unpack# r'+ _ -> case msb a .&. msb b of+ 0 -> maxBound#+ _ -> minBound#+ satPlus SatZero a b =+ let r = plus# a b+ (_,r') = split r+ in case msb r `xor` msb r' of+ 0 -> unpack# r'+ _ -> fromInteger# 0+ satPlus SatSymmetric a b =+ let r = plus# a b+ (_,r') = split r+ in case msb r `xor` msb r' of+ 0 -> unpack# r'+ _ -> case msb a .&. msb b of+ 0 -> maxBound#+ _ -> minBoundSym# satMin SatWrap a b = a -# b- satMin w a b = case msb r `xor` msb r' of- 0 -> unpack# r'- _ -> case msb a ++# msb b of- 2 -> case w of- SatBound -> minBound#- SatSymmetric -> minBoundSym#- _ -> fromInteger# 0- _ -> case w of- SatZero -> fromInteger# 0- _ -> maxBound#- where- r = minus# a b- (_,r') = split r-+ satMin SatBound a b =+ let r = minus# a b+ (_,r') = split r+ in case msb r `xor` msb r' of+ 0 -> unpack# r'+ _ -> case msb a ++# msb b of+ 2 -> minBound#+ _ -> maxBound#+ satMin SatZero a b =+ let r = minus# a b+ (_,r') = split r+ in case msb r `xor` msb r' of+ 0 -> unpack# r'+ _ -> fromInteger# 0+ satMin SatSymmetric a b =+ let r = minus# a b+ (_,r') = split r+ in case msb r `xor` msb r' of+ 0 -> unpack# r'+ _ -> case msb a ++# msb b of+ 2 -> minBoundSym#+ _ -> maxBound# satMult SatWrap a b = a *# b- satMult w a b = case overflow of- 1 -> unpack# rR- _ -> case msb rL of- 0 -> case w of- SatZero -> fromInteger# 0- _ -> maxBound#- _ -> case w of- SatBound -> minBound#- SatSymmetric -> minBoundSym#- _ -> fromInteger# 0- where- overflow = complement (reduceOr (msb rR ++# pack rL)) .|.- reduceAnd (msb rR ++# pack rL)- r = times# a b- (rL,rR) = split r+ satMult SatBound a b =+ let r = times# a b+ (rL,rR) = split r+ overflow = complement (reduceOr (msb rR ++# pack rL)) .|.+ reduceAnd (msb rR ++# pack rL)+ in case overflow of+ 1 -> unpack# rR+ _ -> case msb rL of+ 0 -> maxBound#+ _ -> minBound#+ satMult SatZero a b =+ let r = times# a b+ (rL,rR) = split r+ overflow = complement (reduceOr (msb rR ++# pack rL)) .|.+ reduceAnd (msb rR ++# pack rL)+ in case overflow of+ 1 -> unpack# rR+ _ -> fromInteger# 0+ satMult SatSymmetric a b =+ let r = times# a b+ (rL,rR) = split r+ overflow = complement (reduceOr (msb rR ++# pack rL)) .|.+ reduceAnd (msb rR ++# pack rL)+ in case overflow of+ 1 -> unpack# rR+ _ -> case msb rL of+ 0 -> maxBound#+ _ -> minBoundSym# minBoundSym# :: KnownNat n => Signed n minBoundSym# = minBound# +# fromInteger# 1
src/CLaSH/Sized/Internal/Unsigned.hs view
@@ -6,17 +6,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Sized.Internal.Unsigned@@ -81,6 +82,7 @@ import Data.Proxy (Proxy (..)) import Text.Read (Read (..), ReadPrec) import GHC.TypeLits (KnownNat, Nat, type (+), natVal)+import GHC.TypeLits.Extra (Max) import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..),@@ -93,9 +95,9 @@ import CLaSH.Class.Resize (Resize (..)) import CLaSH.Prelude.BitIndex ((!), msb, replaceBit, split) import CLaSH.Prelude.BitReduction (reduceOr)-import CLaSH.Promoted.Ord (Max) import CLaSH.Sized.Internal.BitVector (BitVector (BV), Bit, high, low) import qualified CLaSH.Sized.Internal.BitVector as BV+import CLaSH.XException (ShowX (..), showsPrecXWith) -- | Arbitrary-width unsigned integer represented by @n@ bits --@@ -148,6 +150,9 @@ show (U i) = show i {-# NOINLINE show #-} +instance ShowX (Unsigned n) where+ showsPrecX = showsPrecXWith showsPrec+ -- | None of the 'Read' class' methods are synthesisable. instance KnownNat n => Read (Unsigned n) where readPrec = fromIntegral <$> (readPrec :: ReadPrec Word)@@ -209,12 +214,12 @@ {-# NOINLINE enumFromThen# #-} {-# NOINLINE enumFromTo# #-} {-# NOINLINE enumFromThenTo# #-}-enumFrom# :: Unsigned n -> [Unsigned n]-enumFromThen# :: Unsigned n -> Unsigned n -> [Unsigned n]+enumFrom# :: KnownNat n => Unsigned n -> [Unsigned n]+enumFromThen# :: KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n] enumFromTo# :: Unsigned n -> Unsigned n -> [Unsigned n] enumFromThenTo# :: Unsigned n -> Unsigned n -> Unsigned n -> [Unsigned n]-enumFrom# x = map U [unsafeToInteger x ..]-enumFromThen# x y = map U [unsafeToInteger x, unsafeToInteger y ..]+enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..]+enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] enumFromTo# x y = map U [unsafeToInteger x .. unsafeToInteger y] enumFromThenTo# x1 x2 y = map U [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] @@ -227,8 +232,9 @@ minBound# = U 0 {-# NOINLINE maxBound# #-}-maxBound# :: KnownNat n => Unsigned n-maxBound# = let res = U ((2 ^ natVal res) - 1) in res+maxBound# :: forall n .KnownNat n => Unsigned n+maxBound# = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))+ in U (m - 1) instance KnownNat n => Num (Unsigned n) where (+) = (+#)@@ -239,21 +245,26 @@ signum bv = resize# (unpack# (reduceOr bv)) fromInteger = fromInteger# -(+#),(-#),(*#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n+(+#),(-#),(*#) :: forall n . KnownNat n => Unsigned n -> Unsigned n -> Unsigned n {-# NOINLINE (+#) #-}-(+#) (U i) (U j) = fromInteger_INLINE (i + j)+(+#) (U i) (U j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))+ z = i + j+ in if z >= m then U (z - m) else U z {-# NOINLINE (-#) #-}-(-#) (U i) (U j) = fromInteger_INLINE (i - j)+(-#) (U i) (U j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n))+ z = i - j+ in if z < 0 then U (m + z) else U z {-# NOINLINE (*#) #-} (*#) (U i) (U j) = fromInteger_INLINE (i * j) {-# NOINLINE negate# #-}-negate# :: KnownNat n => Unsigned n -> Unsigned n-negate# u@(U i) = sz `seq` U (sz - i)+negate# :: forall n . KnownNat n => Unsigned n -> Unsigned n+negate# (U 0) = U 0+negate# (U i) = sz `seq` U (sz - i) where- sz = 2 ^ natVal u+ sz = 1 `shiftL` fromInteger (natVal (Proxy @n)) {-# NOINLINE fromInteger# #-} fromInteger# :: KnownNat n => Integer -> Unsigned n@@ -261,29 +272,33 @@ {-# INLINE fromInteger_INLINE #-} fromInteger_INLINE :: forall n . KnownNat n => Integer -> Unsigned n-fromInteger_INLINE i = sz `seq` U (i `mod` (shiftL 1 sz))+fromInteger_INLINE i = U (i `mod` sz) where- sz = fromInteger (natVal (Proxy :: Proxy n))+ sz = 1 `shiftL` fromInteger (natVal (Proxy @n)) -instance (KnownNat (1 + Max m n), KnownNat (m + n)) =>- ExtendingNum (Unsigned m) (Unsigned n) where- type AResult (Unsigned m) (Unsigned n) = Unsigned (1 + Max m n)+instance (KnownNat m, KnownNat n) => ExtendingNum (Unsigned m) (Unsigned n) where+ type AResult (Unsigned m) (Unsigned n) = Unsigned (Max m n + 1) plus = plus# minus = minus# type MResult (Unsigned m) (Unsigned n) = Unsigned (m + n) times = times# -plus#, minus# :: KnownNat (1 + Max m n) => Unsigned m -> Unsigned n- -> Unsigned (1 + Max m n) {-# NOINLINE plus# #-}-plus# (U a) (U b) = fromInteger_INLINE (a + b)+plus# :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1)+plus# (U a) (U b) = U (a + b) {-# NOINLINE minus# #-}-minus# (U a) (U b) = fromInteger_INLINE (a - b)+minus# :: forall m n . (KnownNat m, KnownNat n) => Unsigned m -> Unsigned n+ -> Unsigned (Max m n + 1)+minus# (U a) (U b) =+ let sz = fromInteger (natVal (Proxy @(Max m n + 1)))+ mask = 1 `shiftL` sz+ z = a - b+ in if z < 0 then U (mask + z) else U z {-# NOINLINE times# #-}-times# :: KnownNat (m + n) => Unsigned m -> Unsigned n -> Unsigned (m + n)-times# (U a) (U b) = fromInteger_INLINE (a * b)+times# :: Unsigned m -> Unsigned n -> Unsigned (m + n)+times# (U a) (U b) = U (a * b) instance KnownNat n => Real (Unsigned n) where toRational = toRational . toInteger#@@ -307,7 +322,7 @@ toInteger# :: Unsigned n -> Integer toInteger# (U i) = i -instance (KnownNat n, KnownNat (n + 1), KnownNat (n + 2)) => Bits (Unsigned n) where+instance KnownNat n => Bits (Unsigned n) where (.&.) = and# (.|.) = or# xor = xor#@@ -343,8 +358,7 @@ complement# :: KnownNat n => Unsigned n -> Unsigned n complement# (U i) = fromInteger_INLINE (complement i) -shiftL#, shiftR#, rotateL#, rotateR# :: KnownNat n => Unsigned n -> Int- -> Unsigned n+shiftL#, rotateL#, rotateR# :: KnownNat n => Unsigned n -> Int -> Unsigned n {-# NOINLINE shiftL# #-} shiftL# (U v) i | i < 0 = error@@ -352,10 +366,11 @@ | otherwise = fromInteger_INLINE (shiftL v i) {-# NOINLINE shiftR# #-}+shiftR# :: Unsigned n -> Int -> Unsigned n shiftR# (U v) i | i < 0 = error $ "'shiftR undefined for negative number: " ++ show i- | otherwise = fromInteger_INLINE (shiftR v i)+ | otherwise = U (shiftR v i) {-# NOINLINE rotateL# #-} rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers"@@ -379,18 +394,20 @@ b'' = sz - b' sz = fromInteger (natVal bv) -instance (KnownNat n, KnownNat (n + 1), KnownNat (n + 2)) => FiniteBits (Unsigned n) where- finiteBitSize = size#+instance KnownNat n => FiniteBits (Unsigned n) where+ finiteBitSize = size#+ countLeadingZeros u = countLeadingZeros (pack# u)+ countTrailingZeros u = countTrailingZeros (pack# u) instance Resize Unsigned where resize = resize#- zeroExtend = resize#- signExtend = resize#+ zeroExtend = extend truncateB = resize# {-# NOINLINE resize# #-}-resize# :: KnownNat m => Unsigned n -> Unsigned m-resize# (U i) = fromInteger_INLINE i+resize# :: forall n m . KnownNat m => Unsigned n -> Unsigned m+resize# (U i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @m))+ in if i >= m then fromInteger_INLINE i else U i instance Default (Unsigned n) where def = minBound#@@ -402,33 +419,39 @@ decUnsigned :: Integer -> TypeQ decUnsigned n = appT (conT ''Unsigned) (litT $ numTyLit n) -instance (KnownNat n, KnownNat (1 + n), KnownNat (n + n)) =>- SaturatingNum (Unsigned n) where+instance KnownNat n => SaturatingNum (Unsigned n) where satPlus SatWrap a b = a +# b- satPlus w a b = case msb r of- 0 -> resize# r- _ -> case w of- SatZero -> minBound#- _ -> maxBound#- where- r = plus# a b+ satPlus SatZero a b =+ let r = plus# a b+ in case msb r of+ 0 -> resize# r+ _ -> minBound#+ satPlus _ a b =+ let r = plus# a b+ in case msb r of+ 0 -> resize# r+ _ -> maxBound# satMin SatWrap a b = a -# b- satMin _ a b = case msb r of- 0 -> resize# r- _ -> minBound#- where- r = minus# a b+ satMin _ a b =+ let r = minus# a b+ in case msb r of+ 0 -> resize# r+ _ -> minBound# satMult SatWrap a b = a *# b- satMult w a b = case rL of- 0 -> unpack# rR- _ -> case w of- SatZero -> minBound#- _ -> maxBound#- where- r = times# a b- (rL,rR) = split r+ satMult SatZero a b =+ let r = times# a b+ (rL,rR) = split r+ in case rL of+ 0 -> unpack# rR+ _ -> minBound#+ satMult _ a b =+ let r = times# a b+ (rL,rR) = split r+ in case rL of+ 0 -> unpack# rR+ _ -> maxBound# instance KnownNat n => Arbitrary (Unsigned n) where arbitrary = arbitraryBoundedIntegral
src/CLaSH/Sized/RTree.hs view
@@ -4,35 +4,475 @@ Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com> -} -{-# LANGUAGE DataKinds, TypeOperators, GADTs, ScopedTypeVariables,- KindSignatures, RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-} -module CLaSH.Sized.RTree where+module CLaSH.Sized.RTree+ ( -- * 'RTree' data type+ RTree (LR, BR)+ -- * Construction+ , treplicate+ , trepeat+ -- * Accessors+ -- ** Indexing+ , indexTree+ , tindices+ -- * Modifying trees+ , replaceTree+ -- * Element-wise operations+ -- ** Mapping+ , tmap+ , tzipWith+ -- ** Zipping+ , tzip+ -- ** Unzipping+ , tunzip+ -- * Folding+ , tfold+ -- ** Specialised folds+ , tdfold+ -- * Conversions+ , v2t+ , t2v+ -- * Misc+ , lazyT+ )+where -import Data.Singletons.Prelude (TyFun,type ($))+import Control.Applicative (liftA2)+import qualified Control.Lens as Lens+import Data.Default (Default (..))+import Data.Foldable (toList)+import Data.Singletons.Prelude (Apply, TyFun, type (@@)) import Data.Proxy (Proxy (..))-import GHC.TypeLits (KnownNat, Nat, type (+))+import GHC.TypeLits (KnownNat, Nat, type (+), type (^), type (*))+import Language.Haskell.TH.Syntax (Lift(..))+import qualified Prelude as P+import Prelude hiding ((++), (!!))+import Test.QuickCheck (Arbitrary (..), CoArbitrary (..)) -import CLaSH.Promoted.Nat (SNat, snat, subSNat)+import CLaSH.Class.BitPack (BitPack (..))+import CLaSH.Promoted.Nat (SNat (..), UNat (..), pow2SNat, snatToNum,+ subSNat, toUNat) import CLaSH.Promoted.Nat.Literals (d1)+import CLaSH.Sized.Index (Index)+import CLaSH.Sized.Vector (Vec (..), (!!), (++), dtfold, replace)+import CLaSH.XException (ShowX (..), showsX, showsPrecXWith) +{- $setup+>>> :set -XDataKinds+>>> :set -XTypeFamilies+>>> :set -XTypeOperators+>>> :set -XTemplateHaskell+>>> :set -XFlexibleContexts+>>> :set -XTypeApplications+>>> :set -fplugin GHC.TypeLits.Normalise+>>> :set -XUndecidableInstances+>>> import CLaSH.Prelude+>>> data IIndex (f :: TyFun Nat *) :: *+>>> type instance Apply IIndex l = Index ((2^l)+1)+>>> :{+let populationCount' :: (KnownNat k, KnownNat (2^k)) => BitVector (2^k) -> Index ((2^k)+1)+ populationCount' bv = tdfold (Proxy @IIndex)+ fromIntegral+ (\_ x y -> plus x y)+ (v2t (bv2v bv))+:}+-}++-- | Perfect depth binary tree.+--+-- * Only has elements at the leaf of the tree+-- * A tree of depth /d/ has /2^d/ elements. data RTree :: Nat -> * -> * where- LR :: a -> RTree 0 a- BR :: RTree n a -> RTree n a -> RTree (n+1) a+ LR_ :: a -> RTree 0 a+ BR_ :: RTree d a -> RTree d a -> RTree (d+1) a -tfold :: forall p k a . KnownNat k- => Proxy (p :: TyFun Nat * -> *)- -> (a -> (p $ 0))- -> (forall l . SNat l -> (p $ l) -> (p $ l) -> (p $ (l+1)))- -> RTree k a- -> (p $ k)-tfold _ f g = go snat+textract :: RTree 0 a -> a+textract (LR_ x) = x+{-# NOINLINE textract #-}++tsplit :: RTree (d+1) a -> (RTree d a,RTree d a)+tsplit (BR_ l r) = (l,r)+{-# NOINLINE tsplit #-}++-- | Leaf of a perfect depth tree+--+-- >>> LR 1+-- 1+-- >>> let x = LR 1+-- >>> :t x+-- x :: Num a => RTree 0 a+--+-- Can be used as a pattern:+--+-- >>> let f (LR a) (LR b) = a + b+-- >>> :t f+-- f :: Num a => RTree 0 a -> RTree 0 a -> a+-- >>> f (LR 1) (LR 2)+-- 3+pattern LR :: a -> RTree 0 a+pattern LR x <- (textract -> x) where- go :: SNat m -> RTree m a -> (p $ m)- go _ (LR a) = f a- go sn (BR l r) = let sn' = sn `subSNat` d1- in g sn' (go sn' l) (go sn' r)+ LR x = LR_ x++-- | Branch of a perfect depth tree+--+-- >>> BR (LR 1) (LR 2)+-- <1,2>+-- >>> let x = BR (LR 1) (LR 2)+-- >>> :t x+-- x :: Num a => RTree 1 a+--+-- Case be used a pattern:+--+-- >>> let f (BR (LR a) (LR b)) = LR (a + b)+-- >>> :t f+-- f :: Num a => RTree 1 a -> RTree 0 a+-- >>> f (BR (LR 1) (LR 2))+-- 3+pattern BR :: RTree d a -> RTree d a -> RTree (d+1) a+pattern BR l r <- ((\t -> (tsplit t)) -> (l,r))+ where+ BR l r = BR_ l r++instance (KnownNat d, Eq a) => Eq (RTree d a) where+ (==) t1 t2 = (==) (t2v t1) (t2v t2)++instance (KnownNat d, Ord a) => Ord (RTree d a) where+ compare t1 t2 = compare (t2v t1) (t2v t2)++instance Show a => Show (RTree n a) where+ showsPrec _ (LR_ a) = shows a+ showsPrec _ (BR_ l r) = \s -> '<':shows l (',':shows r ('>':s))++instance ShowX a => ShowX (RTree n a) where+ showsPrecX = showsPrecXWith go+ where+ go :: Int -> RTree d a -> ShowS+ go _ (LR_ a) = showsX a+ go _ (BR_ l r) = \s -> '<':showsX l (',':showsX r ('>':s))++instance KnownNat d => Functor (RTree d) where+ fmap = tmap++instance KnownNat d => Applicative (RTree d) where+ pure = trepeat+ (<*>) = tzipWith ($)++instance KnownNat d => Foldable (RTree d) where+ foldMap f = tfold f mappend++data TraversableTree (g :: * -> *) (a :: *) (f :: TyFun Nat *) :: *+type instance Apply (TraversableTree f a) d = f (RTree d a)++instance KnownNat d => Traversable (RTree d) where+ traverse :: forall f a b . Applicative f => (a -> f b) -> RTree d a -> f (RTree d b)+ traverse f = tdfold (Proxy @(TraversableTree f b))+ (fmap LR . f)+ (const (liftA2 BR))++instance (KnownNat d, KnownNat (BitSize a), BitPack a) =>+ BitPack (RTree d a) where+ type BitSize (RTree d a) = (2^d) * (BitSize a)+ pack = pack . t2v+ unpack = v2t . unpack++type instance Lens.Index (RTree d a) = Int+type instance Lens.IxValue (RTree d a) = a+instance KnownNat d => Lens.Ixed (RTree d a) where+ ix i f t = replaceTree i <$> f (indexTree t i) <*> pure t++instance (KnownNat d, Default a) => Default (RTree d a) where+ def = trepeat def++instance Lift a => Lift (RTree d a) where+ lift (LR_ a) = [| LR_ a |]+ lift (BR_ t1 t2) = [| BR_ $(lift t1) $(lift t2) |]++instance (KnownNat d, Arbitrary a) => Arbitrary (RTree d a) where+ arbitrary = sequenceA (trepeat arbitrary)+ shrink = sequenceA . fmap shrink++instance (KnownNat d, CoArbitrary a) => CoArbitrary (RTree d a) where+ coarbitrary = coarbitrary . toList++-- | A /dependently/ typed fold over trees.+--+-- As an example of when you might want to use 'dtfold' we will build a+-- population counter: a circuit that counts the number of bits set to '1' in+-- a 'BitVector'. Given a vector of /n/ bits, we only need we need a data type+-- that can represent the number /n/: 'Index' @(n+1)@. 'Index' @k@ has a range+-- of @[0 .. k-1]@ (using @ceil(log2(k))@ bits), hence we need 'Index' @n+1@.+-- As an initial attempt we will use 'tfold', because it gives a nice (@log2(n)@)+-- tree-structure of adders:+--+-- @+-- populationCount :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1))+-- => BitVector (2^d) -> Index (2^d+1)+-- populationCount = tfold fromIntegral (+) . v2t . bv2v+-- @+--+-- The \"problem\" with this description is that all adders have the same+-- bit-width, i.e. all adders are of the type:+--+-- @+-- (+) :: 'Index' (2^d+1) -> 'Index' (2^d+1) -> 'Index' (2^d+1).+-- @+--+-- This is a \"problem\" because we could have a more efficient structure:+-- one where each layer of adders is /precisely/ wide enough to count the number+-- of bits at that layer. That is, at height /d/ we want the adder to be of+-- type:+--+-- @+-- 'Index' ((2^d)+1) -> 'Index' ((2^d)+1) -> 'Index' ((2^(d+1))+1)+-- @+--+-- We have such an adder in the form of the 'CLaSH.Class.Num.plus' function, as+-- defined in the instance 'CLaSH.Class.Num.ExtendingNum' instance of 'Index'.+-- However, we cannot simply use 'fold' to create a tree-structure of+-- 'CLaSH.Class.Num.plus'es:+--+-- >>> :{+-- let populationCount' :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1))+-- => BitVector (2^d) -> Index (2^d+1)+-- populationCount' = tfold fromIntegral plus . v2t . bv2v+-- :}+-- <BLANKLINE>+-- <interactive>:...+-- • Couldn't match type ‘(((2 ^ d) + 1) + ((2 ^ d) + 1)) - 1’+-- with ‘(2 ^ d) + 1’+-- Expected type: Index ((2 ^ d) + 1)+-- -> Index ((2 ^ d) + 1) -> Index ((2 ^ d) + 1)+-- Actual type: Index ((2 ^ d) + 1)+-- -> Index ((2 ^ d) + 1)+-- -> AResult (Index ((2 ^ d) + 1)) (Index ((2 ^ d) + 1))+-- • In the second argument of ‘tfold’, namely ‘plus’+-- In the first argument of ‘(.)’, namely ‘tfold fromIntegral plus’+-- In the expression: tfold fromIntegral plus . v2t . bv2v+-- • Relevant bindings include+-- populationCount' :: BitVector (2 ^ d) -> Index ((2 ^ d) + 1)+-- (bound at ...)+--+-- because 'tfold' expects a function of type \"@b -> b -> b@\", i.e. a function+-- where the arguments and result all have exactly the same type.+--+-- In order to accommodate the type of our 'CLaSH.Class.Num.plus', where the+-- result is larger than the arguments, we must use a dependently typed fold in+-- the the form of 'dtfold':+--+-- @+-- {\-\# LANGUAGE UndecidableInstances \#-\}+-- import Data.Singletons.Prelude+-- import Data.Proxy+--+-- data IIndex (f :: 'TyFun' Nat *) :: *+-- type instance 'Apply' IIndex l = 'Index' ((2^l)+1)+--+-- populationCount' :: (KnownNat k, KnownNat (2^k))+-- => BitVector (2^k) -> Index ((2^k)+1)+-- populationCount' bv = 'tdfold' (Proxy @IIndex)+-- fromIntegral+-- (\\_ x y -> 'CLaSH.Class.Num.plus' x y)+-- ('v2t' ('CLaSH.Sized.Vector.bv2v' bv))+-- @+--+-- And we can test that it works:+--+-- >>> :t populationCount' (7 :: BitVector 16)+-- populationCount' (7 :: BitVector 16) :: Index 17+-- >>> populationCount' (7 :: BitVector 16)+-- 3+tdfold :: forall p k a . KnownNat k+ => Proxy (p :: TyFun Nat * -> *) -- ^ The /motive/+ -> (a -> (p @@ 0)) -- ^ Function to apply to the elements on the leafs+ -> (forall l . SNat l -> (p @@ l) -> (p @@ l) -> (p @@ (l+1)))+ -- ^ Function to fold the branches with.+ --+ -- __NB:__ @SNat l@ is the depth of the two sub-branches.+ -> RTree k a -- ^ Tree to fold over.+ -> (p @@ k)+tdfold _ f g = go SNat+ where+ go :: SNat m -> RTree m a -> (p @@ m)+ go _ (LR_ a) = f a+ go sn (BR_ l r) = let sn' = sn `subSNat` d1+ in g sn' (go sn' l) (go sn' r)+{-# NOINLINE tdfold #-}++data TfoldTree (a :: *) (f :: TyFun Nat *) :: *+type instance Apply (TfoldTree a) d = a++-- | Reduce a tree to a single element+tfold :: forall d a b .+ KnownNat d+ => (a -> b) -- ^ Function to apply to the leaves+ -> (b -> b -> b) -- ^ Function to combine the results of the reduction+ -- of two branches+ -> RTree d a -- ^ Tree to fold reduce+ -> b+tfold f g = tdfold (Proxy @(TfoldTree b)) f (const g)++-- | \"'treplicate' @d a@\" returns a tree of depth /d/, and has /2^d/ copies+-- of /a/.+--+-- >>> treplicate (SNat :: SNat 3) 6+-- <<<6,6>,<6,6>>,<<6,6>,<6,6>>>+-- >>> treplicate d3 6+-- <<<6,6>,<6,6>>,<<6,6>,<6,6>>>+treplicate :: forall d a . SNat d -> a -> RTree d a+treplicate sn a = go (toUNat sn)+ where+ go :: UNat n -> RTree n a+ go UZero = LR a+ go (USucc un) = BR (go un) (go un)+{-# NOINLINE treplicate #-}++-- | \"'trepeat' @a@\" creates a tree with as many copies of /a/ as demanded by+-- the context.+--+-- >>> trepeat 6 :: RTree 2 Int+-- <<6,6>,<6,6>>+trepeat :: KnownNat d => a -> RTree d a+trepeat = treplicate SNat++data MapTree (a :: *) (f :: TyFun Nat *) :: *+type instance Apply (MapTree a) d = RTree d a++-- | \"'tmap' @f t@\" is the tree obtained by apply /f/ to each element of /t/,+-- i.e.,+--+-- > tmap f (BR (LR a) (LR b)) == BR (LR (f a)) (LR (f b))+tmap :: forall d a b . KnownNat d => (a -> b) -> RTree d a -> RTree d b+tmap f = tdfold (Proxy @(MapTree b)) (LR . f) (\_ l r -> BR l r)++-- | Generate a tree of indices, where the depth of the tree is determined by+-- the context.+--+-- >>> tindices :: RTree 3 (Index 8)+-- <<<0,1>,<2,3>>,<<4,5>,<6,7>>>+tindices :: forall d . KnownNat d => RTree d (Index (2^d))+tindices =+ tdfold (Proxy @(MapTree (Index (2^d)))) LR+ (\s@SNat l r -> BR l (tmap (+(snatToNum (pow2SNat s))) r))+ (treplicate SNat 0)++data V2TTree (a :: *) (f :: TyFun Nat *) :: *+type instance Apply (V2TTree a) d = RTree d a++-- | Convert a vector with /2^d/ elements to a tree of depth /d/.+--+-- >>> (1:>2:>3:>4:>Nil)+-- <1,2,3,4>+-- >>> v2t (1:>2:>3:>4:>Nil)+-- <<1,2>,<3,4>>+v2t :: forall d a . KnownNat d => Vec (2^d) a -> RTree d a+v2t = dtfold (Proxy @(V2TTree a)) LR (const BR)++data T2VTree (a :: *) (f :: TyFun Nat *) :: *+type instance Apply (T2VTree a) d = Vec (2^d) a++-- | Convert a tree of depth /d/ to a vector of /2^d/ elements+--+-- >>> (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4)))+-- <<1,2>,<3,4>>+-- >>> t2v (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4)))+-- <1,2,3,4>+t2v :: forall d a . KnownNat d => RTree d a -> Vec (2^d) a+t2v = tdfold (Proxy @(T2VTree a)) (:> Nil) (\_ l r -> l ++ r)++-- | \"'indexTree' @t n@\" returns the /n/'th element of /t/.+--+-- The bottom-left leaf had index /0/, and the bottom-right leaf has index+-- /2^d-1/, where /d/ is the depth of the tree+--+-- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 0+-- 1+-- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 2+-- 3+-- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 14+-- *** Exception: CLaSH.Sized.Vector.(!!): index 14 is larger than maximum index 3+-- ...+indexTree :: (KnownNat d, Enum i) => RTree d a -> i -> a+indexTree t i = (t2v t) !! i++-- | \"'replaceTree' @n a t@\" returns the tree /t/ where the /n/'th element is+-- replaced by /a/.+--+-- The bottom-left leaf had index /0/, and the bottom-right leaf has index+-- /2^d-1/, where /d/ is the depth of the tree+--+-- >>> replaceTree 0 5 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4)))+-- <<5,2>,<3,4>>+-- >>> replaceTree 2 7 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4)))+-- <<1,2>,<7,4>>+-- >>> replaceTree 9 6 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4)))+-- <<1,2>,<3,*** Exception: CLaSH.Sized.Vector.replace: index 9 is larger than maximum index 3+-- ...+replaceTree :: (KnownNat d, Enum i) => i -> a -> RTree d a -> RTree d a+replaceTree i a = v2t . replace i a . t2v++data ZipWithTree (b :: *) (c :: *) (f :: TyFun Nat *) :: *+type instance Apply (ZipWithTree b c) d = RTree d b -> RTree d c++-- | 'tzipWith' generalises 'tzip' by zipping with the function given as the+-- first argument, instead of a tupling function. For example, "tzipWith (+)"+-- applied to two trees produces the tree of corresponding sums.+--+-- > tzipWith f (BR (LR a1) (LR b1)) (BR (LR a2) (LR b2)) == BR (LR (f a1 a2)) (LR (f b1 b2))+tzipWith :: forall a b c d . KnownNat d => (a -> b -> c) -> RTree d a -> RTree d b -> RTree d c+tzipWith f = tdfold (Proxy @(ZipWithTree b c)) lr br+ where+ lr :: a -> RTree 0 b -> RTree 0 c+ lr a (LR b) = LR (f a b)+ lr _ _ = error "impossible"++ br :: SNat l+ -> (RTree l b -> RTree l c)+ -> (RTree l b -> RTree l c)+ -> RTree (l+1) b+ -> RTree (l+1) c+ br _ fl fr (BR l r) = BR (fl l) (fr r)+ br _ _ _ _ = error "impossible"++-- | 'tzip' takes two trees and returns a tree of corresponding pairs.+tzip :: KnownNat d => RTree d a -> RTree d b -> RTree d (a,b)+tzip = tzipWith (,)++data UnzipTree (a :: *) (b :: *) (f :: TyFun Nat *) :: *+type instance Apply (UnzipTree a b) d = (RTree d a, RTree d b)++-- | 'tunzip' transforms a tree of pairs into a tree of first components and a+-- tree of second components.+tunzip :: forall d a b . KnownNat d => RTree d (a,b) -> (RTree d a,RTree d b)+tunzip = tdfold (Proxy @(UnzipTree a b)) lr br+ where+ lr (a,b) = (LR a,LR b)++ br _ (l1,r1) (l2,r2) = (BR l1 l2, BR r1 r2)++-- | Given a function 'f' that is strict in its /n/th 'RTree' argument, make it+-- lazy by applying 'lazyT' to this argument:+--+-- > f x0 x1 .. (lazyT xn) .. xn_plus_k+lazyT :: KnownNat d+ => RTree d a+ -> RTree d a+lazyT = tzipWith (flip const) (trepeat undefined)
src/CLaSH/Sized/Vector.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-}@@ -15,6 +14,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -22,13 +22,14 @@ {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-redundant-constraints #-}+ {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Sized.Vector ( -- * 'Vec'tor data type- Vec(..)+ Vec(Nil,(:>),(:<)) -- * Accessors -- ** Length information , length, maxIndex, lengthS@@ -49,9 +50,8 @@ , replicate, replicateI, repeat , iterate, iterateI, generate, generateI -- *** Initialisation from a list- , v+ , listToVecTH, v -- ** Concatenation- , pattern (:>), pattern (:<) , (++), (+>>), (<<+), concat , shiftInAt0, shiftInAtN , shiftOutFrom0, shiftOutFromN , merge@@ -75,7 +75,7 @@ , foldr, foldl, foldr1, foldl1, fold , ifoldr, ifoldl -- ** Specialised folds- , dfold, vfold+ , dfold, dtfold, vfold -- * Prefix sums (scans) , scanl, scanr, postscanl, postscanr , mapAccumL, mapAccumR@@ -98,13 +98,13 @@ where import Control.DeepSeq (NFData (..))-import qualified Control.Lens as Lens+import qualified Control.Lens as Lens hiding (pattern (:>), pattern (:<)) import Data.Default (Default (..)) import qualified Data.Foldable as F import Data.Proxy (Proxy (..))-import Data.Singletons.Prelude (TyFun,Apply,type ($))-import GHC.TypeLits (CmpNat, KnownNat, Nat, type (+), type (*),- type (-), natVal)+import Data.Singletons.Prelude (TyFun,Apply,type (@@))+import GHC.TypeLits (CmpNat, KnownNat, Nat, type (+), type (-), type (*),+ type (^), natVal) import GHC.Base (Int(I#),Int#,isTrue#) import GHC.Prim ((==#),(<#),(-#)) import Language.Haskell.TH (ExpQ)@@ -119,14 +119,14 @@ import Test.QuickCheck (Arbitrary (..), CoArbitrary (..)) import Unsafe.Coerce (unsafeCoerce) -import CLaSH.Promoted.Nat (SNat (..), UNat (..), snat, snatToInteger,- subSNat, withSNat, toUNat)+import CLaSH.Promoted.Nat (SNat (..), UNat (..), pow2SNat, snatProxy,+ snatToInteger, subSNat, withSNat, toUNat) import CLaSH.Promoted.Nat.Literals (d1)-import CLaSH.Promoted.Nat.Unsafe (unsafeSNat) import CLaSH.Sized.Internal.BitVector (Bit, BitVector, (++#), split#) import CLaSH.Sized.Index (Index) import CLaSH.Class.BitPack (BitPack (..))+import CLaSH.XException (ShowX (..), showsX, showsPrecXWith) {- $setup >>> :set -XDataKinds@@ -134,6 +134,7 @@ >>> :set -XTypeOperators >>> :set -XTemplateHaskell >>> :set -XFlexibleContexts+>>> :set -XTypeApplications >>> :set -fplugin GHC.TypeLits.Normalise >>> import CLaSH.Prelude >>> let compareSwapL a b = if a < b then (a,b) else (b,a)@@ -161,13 +162,23 @@ sorted = zipWith (flip compareSwapL) rights lefts :} ->>> import Data.Singletons.Prelude >>> data Append (m :: Nat) (a :: *) (f :: TyFun Nat *) :: * >>> type instance Apply (Append m a) l = Vec (l + m) a >>> let append' xs ys = dfold (Proxy :: Proxy (Append m a)) (const (:>)) ys xs >>> let compareSwap a b = if a > b then (a,b) else (b,a) >>> let insert y xs = let (y',xs') = mapAccumL compareSwap y xs in xs' :< y'->>> let insertionSort = vfold insert+>>> let insertionSort = vfold (const insert)+>>> data IIndex (f :: TyFun Nat *) :: *+>>> :set -XUndecidableInstances+>>> type instance Apply IIndex l = Index ((2^l)+1)+>>> :{+let populationCount' :: (KnownNat k, KnownNat (2^k)) => BitVector (2^k) -> Index ((2^k)+1)+ populationCount' bv = dtfold (Proxy @IIndex)+ fromIntegral+ (\_ x y -> plus x y)+ (bv2v bv)+:}+ -} infixr 5 `Cons`@@ -175,11 +186,10 @@ -- -- * Lists with their length encoded in their type -- * 'Vec'tor elements have an __ASCENDING__ subscript starting from 0 and--- ending at 'maxIndex' (== 'length' - 1).+-- ending at @'length' - 1@. data Vec :: Nat -> * -> * where Nil :: Vec 0 a Cons :: a -> Vec n a -> Vec (n + 1) a-{-# WARNING Cons "Use ':>' instead of 'Cons'" #-} instance NFData a => NFData (Vec n a) where rnf Nil = ()@@ -216,13 +226,23 @@ infixr 5 :> instance Show a => Show (Vec n a) where- show vs = "<" P.++ punc vs P.++ ">"+ showsPrec _ vs = \s -> '<':punc vs ('>':s) where- punc :: Vec m a -> String- punc Nil = ""- punc (x `Cons` Nil) = show x- punc (x `Cons` xs) = show x P.++ "," P.++ punc xs+ punc :: Vec m a -> ShowS+ punc Nil = id+ punc (x `Cons` Nil) = shows x+ punc (x `Cons` xs) = \s -> shows x (',':punc xs s) +instance ShowX a => ShowX (Vec n a) where+ showsPrecX = showsPrecXWith go+ where+ go _ vs = \s -> '<': punc vs ('>':s)+ where+ punc :: Vec m a -> ShowS+ punc Nil = id+ punc (x `Cons` Nil) = showsX x+ punc (x `Cons` xs) = \s -> showsX x (',':punc xs s)+ instance (KnownNat n, Eq a) => Eq (Vec n a) where (==) v1 v2 | length v1 == 0 = True@@ -268,7 +288,7 @@ traverse = traverse# {-# NOINLINE traverse# #-}-traverse# :: Applicative f => (a -> f b) -> Vec n a -> f (Vec n b)+traverse# :: forall a f b n . Applicative f => (a -> f b) -> Vec n a -> f (Vec n b) traverse# _ Nil = pure Nil traverse# f (x `Cons` xs) = Cons <$> f x <*> traverse# f xs @@ -291,11 +311,12 @@ -- >>> head Nil -- <BLANKLINE> -- <interactive>:...--- Couldn't match type ‘...’ with ‘0’--- Expected type: Vec ... a--- Actual type: Vec 0 a--- In the first argument of ‘head’, namely ‘Nil’--- In the expression: head Nil+-- • Couldn't match type ‘1’ with ‘0’+-- Expected type: Vec (0 + 1) a+-- Actual type: Vec 0 a+-- • In the first argument of ‘head’, namely ‘Nil’+-- In the expression: head Nil+-- In an equation for ‘it’: it = head Nil head :: Vec (n + 1) a -> a head (x `Cons` _) = x @@ -307,11 +328,12 @@ -- >>> tail Nil -- <BLANKLINE> -- <interactive>:...--- Couldn't match type ‘...’ with ‘0’--- Expected type: Vec ... a--- Actual type: Vec 0 a--- In the first argument of ‘tail’, namely ‘Nil’--- In the expression: tail Nil+-- • Couldn't match type ‘1’ with ‘0’+-- Expected type: Vec (0 + 1) a+-- Actual type: Vec 0 a+-- • In the first argument of ‘tail’, namely ‘Nil’+-- In the expression: tail Nil+-- In an equation for ‘it’: it = tail Nil tail :: Vec (n + 1) a -> Vec n a tail (_ `Cons` xs) = xs @@ -323,11 +345,12 @@ -- >>> last Nil -- <BLANKLINE> -- <interactive>:...--- Couldn't match type ‘...’ with ‘0’--- Expected type: Vec ... a--- Actual type: Vec 0 a--- In the first argument of ‘last’, namely ‘Nil’--- In the expression: last Nil+-- • Couldn't match type ‘1’ with ‘0’+-- Expected type: Vec (0 + 1) a+-- Actual type: Vec 0 a+-- • In the first argument of ‘last’, namely ‘Nil’+-- In the expression: last Nil+-- In an equation for ‘it’: it = last Nil last :: Vec (n + 1) a -> a last (x `Cons` Nil) = x last (_ `Cons` y `Cons` ys) = last (y `Cons` ys)@@ -340,11 +363,12 @@ -- >>> init Nil -- <BLANKLINE> -- <interactive>:...--- Couldn't match type ‘...’ with ‘0’--- Expected type: Vec ... a--- Actual type: Vec 0 a--- In the first argument of ‘init’, namely ‘Nil’--- In the expression: init Nil+-- • Couldn't match type ‘1’ with ‘0’+-- Expected type: Vec (0 + 1) a+-- Actual type: Vec 0 a+-- • In the first argument of ‘init’, namely ‘Nil’+-- In the expression: init Nil+-- In an equation for ‘it’: it = init Nil init :: Vec (n + 1) a -> Vec n a init (_ `Cons` Nil) = Nil init (x `Cons` y `Cons` ys) = x `Cons` init (y `Cons` ys)@@ -466,12 +490,12 @@ -- -- >>> shiftOutFromN d2 ((1 :> 2 :> 3 :> 4 :> 5 :> Nil) :: Vec 5 Integer) -- (<0,0,1,2,3>,<4,5>)-shiftOutFromN :: (Default a, KnownNat (m + n))+shiftOutFromN :: (Default a, KnownNat n) => SNat m -- ^ @m@, the number of elements to shift out -> Vec (m + n) a -- ^ The old vector -> (Vec (m + n) a, Vec m a) -- ^ (The new vector, shifted out elements)-shiftOutFromN m xs = shiftInAt0 xs (replicate m def)+shiftOutFromN m@SNat xs = shiftInAt0 xs (replicate m def) {-# INLINE shiftOutFromN #-} infixr 5 ++@@ -486,7 +510,7 @@ -- | Split a vector into two vectors at the given point. ----- >>> splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil)+-- >>> splitAt (SNat :: SNat 3) (1:>2:>3:>7:>8:>Nil) -- (<1,2,3>,<7,8>) -- >>> splitAt d3 (1:>2:>3:>7:>8:>Nil) -- (<1,2,3>,<7,8>)@@ -576,6 +600,7 @@ -- imap (+) (2 :> 2 :> 2 :> 2 :> Nil) :: Vec 4 (Index 4) -- >>> imap (+) (2 :> 2 :> 2 :> 2 :> Nil) -- <2,3,*** Exception: CLaSH.Sized.Index: result 4 is out of bounds: [0..3]+-- ... -- >>> imap (\i a -> fromIntegral i + a) (2 :> 2 :> 2 :> 2 :> Nil) :: Vec 4 (Unsigned 8) -- <2,3,4,5> --@@ -594,6 +619,7 @@ -- -- >>> izipWith (\i a b -> i + a + b) (2 :> 2 :> Nil) (3 :> 3:> Nil) -- <*** Exception: CLaSH.Sized.Index: result 3 is out of bounds: [0..1]+-- ... -- >>> izipWith (\i a b -> fromIntegral i + a + b) (2 :> 2 :> Nil) (3 :> 3 :> Nil) :: Vec 2 (Unsigned 8) -- <5,6> --@@ -992,7 +1018,7 @@ sub Nil _ = error (P.concat [ "CLaSH.Sized.Vector.(!!): index " , show i , " is larger than maximum index "- , show (maxIndex xs)+ , show ((length xs)-1) ]) sub (y `Cons` (!ys)) n = if isTrue# (n ==# 0#) then y@@ -1002,28 +1028,27 @@ -- | \"@xs@ '!!' @n@\" returns the /n/'th element of /xs/. -- -- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and--- ending at 'maxIndex'.+-- ending at @'length' - 1@. -- -- >>> (1:>2:>3:>4:>5:>Nil) !! 4 -- 5--- >>> (1:>2:>3:>4:>5:>Nil) !! maxIndex (1:>2:>3:>4:>5:>Nil)+-- >>> (1:>2:>3:>4:>5:>Nil) !! (length (1:>2:>3:>4:>5:>Nil) - 1) -- 5 -- >>> (1:>2:>3:>4:>5:>Nil) !! 1 -- 2 -- >>> (1:>2:>3:>4:>5:>Nil) !! 14 -- *** Exception: CLaSH.Sized.Vector.(!!): index 14 is larger than maximum index 4+-- ... (!!) :: (KnownNat n, Enum i) => Vec n a -> i -> a xs !! i = index_int xs (fromEnum i) {-# INLINE (!!) #-} -- | The index (subscript) of the last element in a 'Vec'tor as an 'Int' -- value.------ >>> maxIndex (6 :> 7 :> 8 :> Nil)--- 2 maxIndex :: KnownNat n => Vec n a -> Int maxIndex = subtract 1 . length {-# NOINLINE maxIndex #-}+{-# DEPRECATED maxIndex "'maxIndex' will be removed in clash-prelude-1.0, use 'length xs - 1' instead." #-} -- | The length of a 'Vec'tor as an 'Int' value. --@@ -1042,7 +1067,7 @@ sub Nil _ _ = error (P.concat [ "CLaSH.Sized.Vector.replace: index " , show i , " is larger than maximum index "- , show (maxIndex xs)+ , show (length xs - 1) ]) sub (y `Cons` (!ys)) n b = if isTrue# (n ==# 0#) then b `Cons` ys@@ -1053,7 +1078,7 @@ -- replaced by /a/. -- -- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and--- ending at 'maxIndex'.+-- ending at @'length' - 1@. -- -- >>> replace 3 7 (1:>2:>3:>4:>5:>Nil) -- <1,2,3,7,5>@@ -1061,13 +1086,14 @@ -- <7,2,3,4,5> -- >>> replace 9 7 (1:>2:>3:>4:>5:>Nil) -- <1,2,3,4,*** Exception: CLaSH.Sized.Vector.replace: index 9 is larger than maximum index 4+-- ... replace :: (KnownNat n, Enum i) => i -> a -> Vec n a -> Vec n a replace i y xs = replace_int xs (fromEnum i) y {-# INLINE replace #-} -- | \"'take' @n xs@\" returns the /n/-length prefix of /xs/. ----- >>> take (snat :: SNat 3) (1:>2:>3:>4:>5:>Nil)+-- >>> take (SNat :: SNat 3) (1:>2:>3:>4:>5:>Nil) -- <1,2,3> -- >>> take d3 (1:>2:>3:>4:>5:>Nil) -- <1,2,3>@@ -1076,13 +1102,13 @@ -- >>> take d4 (1:>2:>Nil) -- <BLANKLINE> -- <interactive>:...--- Couldn't match type ‘4 + n0’ with ‘2’--- The type variable ‘n0’ is ambiguous--- Expected type: Vec (4 + n0) a--- Actual type: Vec (1 + 1) a--- In the second argument of ‘take’, namely ‘(1 :> 2 :> Nil)’--- In the expression: take d4 (1 :> 2 :> Nil)--- In an equation for ‘it’: it = take d4 (1 :> 2 :> Nil)+-- • Couldn't match type ‘4 + n0’ with ‘2’+-- Expected type: Vec (4 + n0) a+-- Actual type: Vec (1 + 1) a+-- The type variable ‘n0’ is ambiguous+-- • In the second argument of ‘take’, namely ‘(1 :> 2 :> Nil)’+-- In the expression: take d4 (1 :> 2 :> Nil)+-- In an equation for ‘it’: it = take d4 (1 :> 2 :> Nil) take :: SNat m -> Vec (m + n) a -> Vec m a take n = fst . splitAt n {-# INLINE take #-}@@ -1097,7 +1123,7 @@ -- | \"'drop' @n xs@\" returns the suffix of /xs/ after the first /n/ elements. ----- >>> drop (snat :: SNat 3) (1:>2:>3:>4:>5:>Nil)+-- >>> drop (SNat :: SNat 3) (1:>2:>3:>4:>5:>Nil) -- <4,5> -- >>> drop d3 (1:>2:>3:>4:>5:>Nil) -- <4,5>@@ -1106,10 +1132,10 @@ -- >>> drop d4 (1:>2:>Nil) -- <BLANKLINE> -- <interactive>:...--- Couldn't match expected type ‘2’ with actual type ‘4 + n0’--- The type variable ‘n0’ is ambiguous--- In the first argument of ‘print’, namely ‘it’--- In a stmt of an interactive GHCi command: print it+-- • Couldn't match expected type ‘2’ with actual type ‘4 + n0’+-- The type variable ‘n0’ is ambiguous+-- • In the first argument of ‘print’, namely ‘it’+-- In a stmt of an interactive GHCi command: print it drop :: SNat m -> Vec (m + n) a -> Vec n a drop n = snd . splitAt n {-# INLINE drop #-}@@ -1125,9 +1151,9 @@ -- | \"'at' @n xs@\" returns /n/'th element of /xs/ -- -- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and--- ending at 'maxIndex'.+-- ending at @'length' - 1@. ----- >>> at (snat :: SNat 1) (1:>2:>3:>4:>5:>Nil)+-- >>> at (SNat :: SNat 1) (1:>2:>3:>4:>5:>Nil) -- 2 -- >>> at d1 (1:>2:>3:>4:>5:>Nil) -- 2@@ -1138,7 +1164,7 @@ -- | \"'select' @f s n xs@\" selects /n/ elements with step-size /s/ and -- offset @f@ from /xs/. ----- >>> select (snat :: SNat 1) (snat :: SNat 2) (snat :: SNat 3) (1:>2:>3:>4:>5:>6:>7:>8:>Nil)+-- >>> select (SNat :: SNat 1) (SNat :: SNat 2) (SNat :: SNat 3) (1:>2:>3:>4:>5:>6:>7:>8:>Nil) -- <2,4,6> -- >>> select d1 d2 d3 (1:>2:>3:>4:>5:>6:>7:>8:>Nil) -- <2,4,6>@@ -1171,7 +1197,7 @@ -- | \"'replicate' @n a@\" returns a vector that has /n/ copies of /a/. ----- >>> replicate (snat :: SNat 3) 6+-- >>> replicate (SNat :: SNat 3) 6 -- <6,6,6> -- >>> replicate d3 6 -- <6,6,6>@@ -1187,6 +1213,11 @@ -- demanded by the context. -- -- >>> replicateI 6 :: Vec 5 Int+-- <BLANKLINE>+-- <interactive>:...+-- In the use of ‘replicateI’+-- (imported from CLaSH.Prelude, but defined in CLaSH.Sized.Vector):+-- Deprecated: "Use 'repeat' instead of 'replicateI'" -- <6,6,6,6,6> replicateI :: KnownNat n => a -> Vec n a replicateI = withSNat replicate@@ -1205,7 +1236,7 @@ -- | \"'iterate' @n f x@\" returns a vector starting with /x/ followed by -- /n/ repeated applications of /f/ to /x/. ----- > iterate (snat :: SNat 4) f x == (x :> f x :> f (f x) :> f (f (f x)) :> Nil)+-- > iterate (SNat :: SNat 4) f x == (x :> f x :> f (f x) :> f (f (f x)) :> Nil) -- > iterate d4 f x == (x :> f x :> f (f x) :> f (f (f x)) :> Nil) -- -- >>> iterate d4 (+1) 1@@ -1215,7 +1246,7 @@ -- -- <<doc/iterate.svg>> iterate :: SNat n -> (a -> a) -> a -> Vec n a-iterate (SNat _) = iterateI+iterate SNat = iterateI {-# INLINE iterate #-} -- | \"'iterate' @f x@\" returns a vector starting with @x@ followed by @n@@@ -1239,7 +1270,7 @@ -- | \"'generate' @n f x@\" returns a vector with @n@ repeated applications of -- @f@ to @x@. ----- > generate (snat :: SNat 4) f x == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil)+-- > generate (SNat :: SNat 4) f x == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil) -- > generate d4 f x == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil) -- -- >>> generate d4 (+1) 1@@ -1249,7 +1280,7 @@ -- -- <<doc/generate.svg>> generate :: SNat n -> (a -> a) -> a -> Vec n a-generate (SNat _) f a = iterateI f (f a)+generate SNat f a = iterateI f (f a) {-# INLINE generate #-} -- | \"'generateI' @f x@\" returns a vector with @n@ repeated applications of@@ -1291,7 +1322,7 @@ -- stencil1d d2 sum xs :: Num b => Vec 5 b -- >>> stencil1d d2 sum xs -- <3,5,7,9,11>-stencil1d :: KnownNat (n + 1)+stencil1d :: KnownNat n => SNat (stX + 1) -- ^ Windows length /stX/, at least size 1 -> (Vec (stX + 1) a -> b) -- ^ The stencil (function) -> Vec ((stX + n) + 1) a@@ -1310,10 +1341,10 @@ -- >>> :t xss -- xss :: Num a => Vec 4 (Vec 4 a) -- >>> :t stencil2d d2 d2 (sum . map sum) xss--- stencil2d d2 d2 (sum . map sum) xss :: Num a => Vec 3 (Vec 3 a)+-- stencil2d d2 d2 (sum . map sum) xss :: Num b => Vec 3 (Vec 3 b) -- >>> stencil2d d2 d2 (sum . map sum) xss -- <<14,18,22>,<30,34,38>,<46,50,54>>-stencil2d :: (KnownNat (n + 1), KnownNat (m+1))+stencil2d :: (KnownNat n, KnownNat m) => SNat (stY + 1) -- ^ Window hight /stY/, at least size 1 -> SNat (stX + 1) -- ^ Window width /stX/, at least size 1 -> (Vec (stY + 1) (Vec (stX + 1) a) -> b) -- ^ The stencil (function)@@ -1332,7 +1363,7 @@ -- windows1d d2 xs :: Num a => Vec 5 (Vec 2 a) -- >>> windows1d d2 xs -- <<1,2>,<2,3>,<3,4>,<4,5>,<5,6>>-windows1d :: KnownNat (n + 1)+windows1d :: KnownNat n => SNat (stX + 1) -- ^ Length of the window, at least size 1 -> Vec ((stX + n) + 1) a -> Vec (n + 1) (Vec (stX + 1) a)@@ -1354,13 +1385,12 @@ -- windows2d d2 d2 xss :: Num a => Vec 3 (Vec 3 (Vec 2 (Vec 2 a))) -- >>> windows2d d2 d2 xss -- <<<<1,2>,<5,6>>,<<2,3>,<6,7>>,<<3,4>,<7,8>>>,<<<5,6>,<9,10>>,<<6,7>,<10,11>>,<<7,8>,<11,12>>>,<<<9,10>,<13,14>>,<<10,11>,<14,15>>,<<11,12>,<15,16>>>>-windows2d :: (KnownNat (n+1),KnownNat (m+1))+windows2d :: (KnownNat n,KnownNat m) => SNat (stY + 1) -- ^ Window hight /stY/, at least size 1 -> SNat (stX + 1) -- ^ Window width /stX/, at least size 1 -> Vec ((stY + m) + 1) (Vec (stX + n + 1) a) -> Vec (m + 1) (Vec (n + 1) (Vec (stY + 1) (Vec (stX + 1) a)))-windows2d stY stX xss = map (transpose . (map (windows1d stX)))- (windows1d stY xss)+windows2d stY stX xss = map (transpose . (map (windows1d stX))) (windows1d stY xss) {-# INLINE windows2d #-} -- | Forward permutation specified by an index mapping, /ix/. The result vector@@ -1547,15 +1577,19 @@ -- | Create a vector literal from a list literal. ----- > $(v [1::Signed 8,2,3,4,5]) == (8:>2:>3:>4:>5:>Nil) :: Vec 5 (Signed 8)+-- > $(listToVecTH [1::Signed 8,2,3,4,5]) == (8:>2:>3:>4:>5:>Nil) :: Vec 5 (Signed 8) -- -- >>> [1 :: Signed 8,2,3,4,5] -- [1,2,3,4,5]--- >>> $(v [1::Signed 8,2,3,4,5])+-- >>> $(listToVecTH [1::Signed 8,2,3,4,5]) -- <1,2,3,4,5>+listToVecTH :: Lift a => [a] -> ExpQ+listToVecTH [] = [| Nil |]+listToVecTH (x:xs) = [| x :> $(listToVecTH xs) |]+ v :: Lift a => [a] -> ExpQ-v [] = [| Nil |]-v (x:xs) = [| x :> $(v xs) |]+v = listToVecTH+{-# DEPRECATED v "'v' will be removed in clash-prelude-1.0, use 'listToVecTH'" #-} -- | 'Vec'tor as a 'Proxy' for 'Nat' asNatProxy :: Vec n a -> Proxy n@@ -1563,7 +1597,7 @@ -- | Length of a 'Vec'tor as an 'SNat' value lengthS :: KnownNat n => Vec n a -> SNat n-lengthS _ = snat+lengthS _ = SNat {-# INLINE lengthS #-} -- | What you should use when your vector functions are too strict in their@@ -1626,33 +1660,36 @@ -- | A /dependently/ typed fold. ----- Using lists, we can define @append@ ('Prelude.++') using 'Prelude.foldr':+-- Using lists, we can define /append/ (a.k.a. @Data.List.@'Data.List.++') in+-- terms of @Data.List.@'Data.List.foldr': ----- >>> import qualified Prelude--- >>> let append xs ys = Prelude.foldr (:) ys xs+-- >>> import qualified Data.List+-- >>> let append xs ys = Data.List.foldr (:) ys xs -- >>> append [1,2] [3,4] -- [1,2,3,4] ----- However, when we try to do the same for 'Vec':+-- However, when we try to do the same for 'Vec', by defining /append'/ in terms+-- of @CLaSH.Sized.Vector.@'foldr': -- -- @ -- append' xs ys = 'foldr' (:>) ys xs -- @ ----- We get a type error+-- we get a type error: -- -- >>> let append' xs ys = foldr (:>) ys xs -- <BLANKLINE> -- <interactive>:...--- Occurs check: cannot construct the infinite type: ... ~ ... + 1--- Expected type: a -> Vec ... a -> Vec ... a--- Actual type: a -> Vec ... a -> Vec (... + 1) a--- Relevant bindings include--- ys :: Vec ... a (bound at ...)--- append' :: Vec n a -> Vec ... a -> Vec ... a--- (bound at ...)--- In the first argument of ‘foldr’, namely ‘(:>)’--- In the expression: foldr (:>) ys xs+-- • Occurs check: cannot construct the infinite type: t ~ t + 1+-- Expected type: a -> Vec t a -> Vec t a+-- Actual type: a -> Vec t a -> Vec (t + 1) a+-- • In the first argument of ‘foldr’, namely ‘(:>)’+-- In the expression: foldr (:>) ys xs+-- In an equation for ‘append'’: append' xs ys = foldr (:>) ys xs+-- • Relevant bindings include+-- ys :: Vec t a (bound at ...)+-- append' :: Vec n a -> Vec t a -> Vec t a+-- (bound at ...) -- -- The reason is that the type of 'foldr' is: --@@ -1667,8 +1704,8 @@ -- We thus need a @fold@ function that can handle the growing vector type: -- 'dfold'. Compared to 'foldr', 'dfold' takes an extra parameter, called the -- /motive/, that allows the folded function to have an argument and result type--- that /depends/ on the current index into the vector. Using 'dfold', we can--- now correctly define ('++'):+-- that /depends/ on the current length of the vector. Using 'dfold', we can+-- now correctly define /append'/: -- -- @ -- import Data.Singletons.Prelude@@ -1680,7 +1717,7 @@ -- append' xs ys = 'dfold' (Proxy :: Proxy (Append m a)) (const (':>')) ys xs -- @ ----- We now see that @append'@ has the appropriate type:+-- We now see that /append'/ has the appropriate type: -- -- >>> :t append' -- append' :: KnownNat k => Vec k a -> Vec m a -> Vec (k + m) a@@ -1689,25 +1726,159 @@ -- -- >>> append' (1 :> 2 :> Nil) (3 :> 4 :> Nil) -- <1,2,3,4>+--+-- __NB__: \"@'dfold' m f z xs@\" creates a linear structure, which has a depth,+-- or delay, of O(@'length' xs@). Look at 'dtfold' for a /dependently/ typed+-- fold that produces a structure with a depth of O(log_2(@'length' xs@)). dfold :: forall p k a . KnownNat k => Proxy (p :: TyFun Nat * -> *) -- ^ The /motive/- -> (forall l . SNat l -> a -> (p $ l) -> (p $ (l + 1))) -- ^ Function to fold- -> (p $ 0) -- ^ Initial element+ -> (forall l . SNat l -> a -> (p @@ l) -> (p @@ (l + 1)))+ -- ^ Function to fold.+ --+ -- __NB__: The @SNat l@ is __not__ the index (see (`!!`)) to the+ -- element /a/. @SNat l@ is the number of elements that occur to the+ -- right of /a/.+ -> (p @@ 0) -- ^ Initial element -> Vec k a -- ^ Vector to fold over- -> (p $ k)-dfold _ f z xs = go (natVal (asNatProxy xs) - 1) xs+ -> (p @@ k)+dfold _ f z xs = go (snatProxy (asNatProxy xs)) xs where- go :: Integer -> Vec n a -> (p $ n)+ go :: SNat n -> Vec n a -> (p @@ n) go _ Nil = z- go i (y `Cons` (ys :: Vec z a)) = f (unsafeSNat i :: SNat z) y (go (i-1) ys)+ go s (y `Cons` (ys :: Vec z a)) =+ let s' = s `subSNat` d1+ in f s' y (go s' ys) {-# NOINLINE dfold #-} +-- | A combination of 'dfold' and 'fold': a /dependently/ typed fold that+-- reduces a vector in a tree-like structure.+--+-- As an example of when you might want to use 'dtfold' we will build a+-- population counter: a circuit that counts the number of bits set to '1' in+-- a 'BitVector'. Given a vector of /n/ bits, we only need we need a data type+-- that can represent the number /n/: 'Index' @(n+1)@. 'Index' @k@ has a range+-- of @[0 .. k-1]@ (using @ceil(log2(k))@ bits), hence we need 'Index' @n+1@.+-- As an initial attempt we will use 'sum', because it gives a nice (@log2(n)@)+-- tree-structure of adders:+--+-- @+-- populationCount :: (KnownNat (n+1), KnownNat (n+2))+-- => 'BitVector' (n+1) -> 'Index' (n+2)+-- populationCount = sum . map fromIntegral . 'bv2v'+-- @+--+-- The \"problem\" with this description is that all adders have the same+-- bit-width, i.e. all adders are of the type:+--+-- @+-- (+) :: 'Index' (n+2) -> 'Index' (n+2) -> 'Index' (n+2).+-- @+--+-- This is a \"problem\" because we could have a more efficient structure:+-- one where each layer of adders is /precisely/ wide enough to count the number+-- of bits at that layer. That is, at height /d/ we want the adder to be of+-- type:+--+-- @+-- 'Index' ((2^d)+1) -> 'Index' ((2^d)+1) -> 'Index' ((2^(d+1))+1)+-- @+--+-- We have such an adder in the form of the 'CLaSH.Class.Num.plus' function, as+-- defined in the instance 'CLaSH.Class.Num.ExtendingNum' instance of 'Index'.+-- However, we cannot simply use 'fold' to create a tree-structure of+-- 'CLaSH.Class.Num.plus'es:+--+-- >>> :{+-- let populationCount' :: (KnownNat (n+1), KnownNat (n+2))+-- => BitVector (n+1) -> Index (n+2)+-- populationCount' = fold plus . map fromIntegral . bv2v+-- :}+-- <BLANKLINE>+-- <interactive>:...+-- • Couldn't match type ‘((n + 2) + (n + 2)) - 1’ with ‘n + 2’+-- Expected type: Index (n + 2) -> Index (n + 2) -> Index (n + 2)+-- Actual type: Index (n + 2)+-- -> Index (n + 2) -> AResult (Index (n + 2)) (Index (n + 2))+-- • In the first argument of ‘fold’, namely ‘plus’+-- In the first argument of ‘(.)’, namely ‘fold plus’+-- In the expression: fold plus . map fromIntegral . bv2v+-- • Relevant bindings include+-- populationCount' :: BitVector (n + 1) -> Index (n + 2)+-- (bound at ...)+--+-- because 'fold' expects a function of type \"@a -> a -> a@\", i.e. a function+-- where the arguments and result all have exactly the same type.+--+-- In order to accommodate the type of our 'CLaSH.Class.Num.plus', where the+-- result is larger than the arguments, we must use a dependently typed fold in+-- the the form of 'dtfold':+--+-- @+-- {\-\# LANGUAGE UndecidableInstances \#-\}+-- import Data.Singletons.Prelude+-- import Data.Proxy+--+-- data IIndex (f :: 'TyFun' Nat *) :: *+-- type instance 'Apply' IIndex l = 'Index' ((2^l)+1)+--+-- populationCount' :: (KnownNat k, KnownNat (2^k))+-- => BitVector (2^k) -> Index ((2^k)+1)+-- populationCount' bv = 'dtfold' (Proxy @IIndex)+-- fromIntegral+-- (\\_ x y -> 'CLaSH.Class.Num.plus' x y)+-- ('bv2v' bv)+-- @+--+-- And we can test that it works:+--+-- >>> :t populationCount' (7 :: BitVector 16)+-- populationCount' (7 :: BitVector 16) :: Index 17+-- >>> populationCount' (7 :: BitVector 16)+-- 3+--+-- Some final remarks:+--+-- * By using 'dtfold' instead of 'fold', we had to restrict our 'BitVector'+-- argument to have bit-width that is a power of 2.+-- * Even though our original /populationCount/ function specified a structure+-- where all adders had the same width. Most VHDL/(System)Verilog synthesis+-- tools will create a more efficient circuit, i.e. one where the adders+-- have an increasing bit-width for every layer, from the+-- VHDL/(System)Verilog produced by the CLaSH compiler.+--+-- __NB__: The depth, or delay, of the structure produced by+-- \"@'dtfold' m f g xs@\" is O(log_2(@'length' xs@)).+dtfold :: forall p k a . KnownNat k+ => Proxy (p :: TyFun Nat * -> *) -- ^ The /motive/+ -> (a -> (p @@ 0)) -- ^ Function to apply to every element+ -> (forall l . SNat l -> (p @@ l) -> (p @@ l) -> (p @@ (l + 1)))+ -- ^ Function to combine results.+ --+ -- __NB__: The @SNat l@ indicates the depth/height of the node in the+ -- tree that is created by applying this function. The leafs of the tree+ -- have depth\/height /0/, and the root of the tree has height /k/.+ -> Vec (2^k) a+ -- ^ Vector to fold over.+ --+ -- __NB__: Must have a length that is a power of 2.+ -> (p @@ k)+dtfold _ f g = go (SNat :: SNat k)+ where+ go :: forall n . SNat n -> Vec (2^n) a -> (p @@ n)+ go _ (x `Cons` Nil) = f x+ go sn xs =+ let sn' :: SNat (n - 1)+ sn' = sn `subSNat` d1+ (xsL,xsR) = splitAt (pow2SNat sn') xs+ in g sn' (go sn' xsL) (go sn' xsR)+{-# NOINLINE dtfold #-}+ -- | To be used as the motive /p/ for 'dfold', when the /f/ in \"'dfold' @p f@\" -- is a variation on (':>'), e.g.: -- -- @--- map' :: KnownNat k => (a -> b) -> Vec n a -> Vec n b--- map' f = 'dfold' (Proxy :: Proxy ('VCons' a)) (\_ x xs -> f x :> xs)+-- map' :: forall n a b . KnownNat n => (a -> b) -> Vec n a -> Vec n b+-- map' f = 'dfold' (Proxy @('VCons' b)) (\_ x xs -> f x :> xs) -- @ data VCons (a :: *) (f :: TyFun Nat *) :: * type instance Apply (VCons a) l = Vec l a@@ -1720,7 +1891,7 @@ -- @ -- compareSwap a b = if a > b then (a,b) else (b,a) -- insert y xs = let (y',xs') = 'mapAccumL' compareSwap y xs in xs' ':<' y'--- insertionSort = 'vfold' insert+-- insertionSort = 'vfold' (const insert) -- @ -- -- Builds a triangular structure of compare and swaps to sort a row.@@ -1731,11 +1902,11 @@ -- The circuit layout of @insertionSort@, build using 'vfold', is: -- -- <<doc/csSort.svg>>-vfold :: KnownNat k- => (forall l . a -> Vec l b -> Vec (l + 1) b)+vfold :: forall k a b . KnownNat k+ => (forall l . SNat l -> a -> Vec l b -> Vec (l + 1) b) -> Vec k a -> Vec k b-vfold f xs = dfold (Proxy :: Proxy (VCons a)) (const f) Nil xs+vfold f xs = dfold (Proxy @(VCons b)) f Nil xs {-# INLINE vfold #-} -- | Apply a function to every element of a vector and the element's position@@ -1747,12 +1918,11 @@ -- <<1,2,3>,<1,2,3>,<1,2,3>> -- >>> rotateMatrix xss -- <<1,2,3>,<3,1,2>,<2,3,1>>-smap :: KnownNat k => (forall l . SNat (k-1-l) -> a -> b) -> Vec k a -> Vec k b-smap f xs = dfold (Proxy :: Proxy (VCons a))- (\sn x xs' -> f (xsL `subSNat` d1 `subSNat` sn) x :> xs')- Nil xs- where- xsL = lengthS xs+smap :: forall k a b . KnownNat k => (forall l . SNat l -> a -> b) -> Vec k a -> Vec k b+smap f xs = reverse+ $ dfold (Proxy @(VCons b))+ (\sn x xs' -> f sn x :> xs')+ Nil (reverse xs) {-# INLINE smap #-} instance (KnownNat n, KnownNat (BitSize a), BitPack a) => BitPack (Vec n a) where@@ -1807,7 +1977,7 @@ instance Lift a => Lift (Vec n a) where lift Nil = [| Nil |]- lift (x `Cons` xs) = [| x :> $(lift xs) |]+ lift (x `Cons` xs) = [| x `Cons` $(lift xs) |] instance (KnownNat n, Arbitrary a) => Arbitrary (Vec n a) where arbitrary = traverse# id $ repeat arbitrary@@ -1816,7 +1986,7 @@ instance CoArbitrary a => CoArbitrary (Vec n a) where coarbitrary = coarbitrary . toList -type instance Lens.Index (Vec n a) = Int+type instance Lens.Index (Vec n a) = Index n type instance Lens.IxValue (Vec n a) = a instance KnownNat n => Lens.Ixed (Vec n a) where- ix i f xs = replace_int xs i <$> f (index_int xs i)+ ix i f xs = replace_int xs (fromEnum i) <$> f (index_int xs (fromEnum i))
src/CLaSH/Sized/Vector.hs-boot view
@@ -19,5 +19,7 @@ instance (KnownNat m, (~) m ((+) n 1)) => Foldable (Vec m) -bv2v :: KnownNat n => BitVector n -> Vec n Bit-map :: (a -> b) -> Vec n a -> Vec n b+bv2v :: KnownNat n => BitVector n -> Vec n Bit+map :: (a -> b) -> Vec n a -> Vec n b+foldr :: (a -> b -> b) -> b -> Vec n a -> b+foldl :: (b -> a -> b) -> b -> Vec n a -> b
src/CLaSH/Tutorial.hs view
@@ -1,5 +1,5 @@ {-|-Copyright : © Christiaan Baaij, 2014-2016+Copyright : © 2014-2016, Christiaan Baaij, 2017, QBayLogic Licence : Creative Commons 4.0 (CC BY 4.0) (http://creativecommons.org/licenses/by/4.0/) -} @@ -77,6 +77,7 @@ import Data.Char import Data.Int import GHC.Prim+import GHC.TypeLits import GHC.Word import Data.Default @@ -112,8 +113,8 @@ >>> let mac = mealy macT 0 >>> let topEntity = mac :: Signal (Signed 9, Signed 9) -> Signal (Signed 9)->>> let testInput = stimuliGenerator $(v [(1,1) :: (Signed 9,Signed 9),(2,2),(3,3),(4,4)])->>> let expectedOutput = outputVerifier $(v [0 :: Signed 9,1,5,14])+>>> let testInput = stimuliGenerator $(listToVecTH [(1,1) :: (Signed 9,Signed 9),(2,2),(3,3),(4,4)])+>>> let expectedOutput = outputVerifier $(listToVecTH [0 :: Signed 9,1,5,14]) >>> :{ let fibR :: Unsigned 64 -> Unsigned 64 fibR 0 = 0@@ -139,9 +140,8 @@ Features of CλaSH: - * Strongly typed (like VHDL), yet with a very high degree of type inference,- enabling both safe and fast prototying using concise descriptions (like- Verilog).+ * Strongly typed, but with a very high degree of type inference, enabling+ both safe and fast prototyping using concise descriptions. * Interactive REPL: load your designs in an interpreter and easily test all your component without needing to setup a test bench. * Compile your designs for fast simulation.@@ -188,37 +188,40 @@ {- $installation The CλaSH compiler and Prelude library for circuit design only work with the-<http://haskell.org/ghc GHC> Haskell compiler version 7.10 (higher or lower-versions of GHC are not supported).+<http://haskell.org/ghc GHC> Haskell compiler version 8.0 (lower versions of+GHC are not supported). - (1) Install __GHC 7.10__+ (1) Install __GHC 8.0__ - * Download and install <https://www.haskell.org/ghc/download_ghc_7_10_3 GHC for your platform>.+ * Download and install <https://www.haskell.org/ghc/download_ghc_8_0_2 GHC for your platform>. Unix user can use @./configure prefix=\<LOCATION\>@ to set the installation location. * Make sure that the @bin@ directory of __GHC__ is in your @PATH@. - Next follows a list of alternative installation instructions, in case you cannot find what you are looking for on <https://www.haskell.org/ghc/download_ghc_7_10_3>+ In case you cannot find what you are looking for on <https://www.haskell.org/ghc/download_ghc_8_0_2>,+ you can, /alternatively/, use the following instructions: * Ubuntu: * Run: @sudo add-apt-repository -y ppa:hvr/ghc@ * Run: @sudo apt-get update@- * Run: @sudo apt-get install cabal-install-1.24 ghc-7.10.3 libtinfo-dev@- * Update your @PATH@ with: @\/opt\/ghc\/7.10.3\/bin@, @\/opt\/cabal\/1.24/bin@, and @\$HOME\/.cabal\/bin@+ * Run: @sudo apt-get install cabal-install-1.24 ghc-8.0.2 libtinfo-dev@+ * Update your @PATH@ with: @\/opt\/ghc\/8.0.2\/bin@, @\/opt\/cabal\/1.24/bin@, and @\$HOME\/.cabal\/bin@ * Run: @cabal update@ * Skip step 2. * OS X: - * Follow the instructions on: <https://ghcformacosx.github.io/ Haskell for Mac OS X>+ * Follow the instructions on: <https://www.haskell.org/platform/mac.html Haskell Platform Mac OS X>+ to install the /minimal/ Haskell platform * Run: @cabal update@ * Skip step 2. * Windows: - * Follow the instructions on: <https://github.com/fpco/minghc#using-the-legacy-installer MinGHC>+ * Follow the instructions on: <https://www.haskell.org/platform/windows.html Haskell Platform Windows>+ to install the /minimal/ Haskell platform * Run: @cabal update@ * Skip step 2. @@ -253,7 +256,7 @@ (4) Verify that everything is working by: - * Downloading the <https://raw.github.com/clash-lang/clash-compiler/master/examples/FIR.hs Fir.hs> example+ * Downloading the <https://raw.githubusercontent.com/clash-lang/clash-compiler/049e6e2eacb9b3b5ae8664b9b79979c321b322d9/examples/FIR.hs Fir.hs> example * Run: @clash --interactive FIR.hs@ * Execute, in the interpreter, the @:vhdl@ command * Execute, in the interpreter, the @:verilog@ command@@ -447,8 +450,8 @@ argument is the initial state, in this case 0. We can see it is functioning correctly in our interpreter: ->>> import qualified Data.List->>> Data.List.take 4 $ simulate mac [(1::Int,1),(2,2),(3,3),(4,4)] :: [Int]+>>> import qualified Data.List as L+>>> L.take 4 $ simulate mac [(1,1),(2,2),(3,3),(4,4)] [0,1,5,14] Where we simulate our sequential circuit over a list of input samples and take@@ -552,10 +555,10 @@ @ testInput :: 'Signal' ('Signed' 9,'Signed' 9)-testInput = 'stimuliGenerator' $('v' [(1,1) :: ('Signed' 9,'Signed' 9),(2,2),(3,3),(4,4)])+testInput = 'stimuliGenerator' $('listToVecTH' [(1,1) :: ('Signed' 9,'Signed' 9),(2,2),(3,3),(4,4)]) expectedOutput :: 'Signal' ('Signed' 9) -> 'Signal' Bool-expectedOutput = 'outputVerifier' $('v' [0 :: 'Signed' 9,1,5,14])+expectedOutput = 'outputVerifier' $('listToVecTH' [0 :: 'Signed' 9,1,5,14]) @ This will create a stimulus generator that creates the same inputs as we used@@ -564,16 +567,16 @@ simulate the behaviour of the /testbench/: >>> sampleN 7 $ expectedOutput (topEntity testInput)-[False,False,False,False,+[False,False,False,False cycle(system1000): 4, outputVerifier expected value: 14, not equal to actual value: 30-True,+,True cycle(system1000): 5, outputVerifier expected value: 14, not equal to actual value: 46-True,+,True cycle(system1000): 6, outputVerifier expected value: 14, not equal to actual value: 62-True]+,True] We can see that for the first 4 samples, everything is working as expected, after which warnings are being reported. The reason is that 'stimuliGenerator'@@ -773,8 +776,8 @@ @ instance 'Bundle' (a,b) where type 'Unbundled'' clk (a,b) = ('Signal'' clk a, 'Signal'' clk b)- bundle' _ (a,b) = (,) '<$>' a '<*>' b- unbundle' _ tup = (fst '<$>' tup, snd '<*>' tup)+ bundle (a,b) = (,) '<$>' a '<*>' b+ unbundle tup = (fst '<$>' tup, snd '<*>' tup) @ but,@@ -782,8 +785,8 @@ @ instance 'Bundle' Bool where type 'Unbundled'' clk Bool = 'Signal'' clk Bool- bundle' _ s = s- unbundle' _ s = s+ bundle s = s+ unbundle s = s @ What you need take away from the above is that a product type (e.g. a tuple) of@@ -1004,9 +1007,9 @@ "CLaSH.Sized.Internal.Signed" module specifies multiplication as follows: @-{\-\# NOINLINE (*#) \#-\} (*#) :: 'GHC.TypeLits.KnownNat' n => 'Signed' n -> 'Signed' n -> 'Signed' n (S a) *# (S b) = fromInteger_INLINE (a * b)+{\-\# NOINLINE (*#) \#-\} @ For which the VHDL /expression/ primitive is:@@ -1046,73 +1049,94 @@ We will use 'blockRam#' as an example, for which the Haskell/CλaSH code is: @-{\-\# NOINLINE blockRam# \#-\} -- | blockRAM primitive-blockRam# :: 'GHC.TypeLits.KnownNat' n- => 'SClock' clk -- ^ \'Clock\' to synchronize to+blockRam# :: 'KnownNat' n+ => 'SClock' clk -- ^ 'Clock' to synchronize to -> 'Vec' n a -- ^ Initial content of the BRAM, also- -- determines the size, \@n\@, of the BRAM.+ -- determines the size, @n@, of the BRAM. --- -- \_\_NB\_\_: \_\_MUST\_\_ be a constant.- -> 'Signal'' clk 'Int' -- ^ Write address \@w\@- -> 'Signal'' clk 'Int' -- ^ Read address \@r\@+ -- __NB__: __MUST__ be a constant.+ -> 'Signal'' clk Int -- ^ Read address @r@ -> 'Signal'' clk Bool -- ^ Write enable- -> 'Signal'' clk a -- ^ Value to write (at address \@w\@)+ -> 'Signal'' clk Int -- ^ Write address @w@+ -> 'Signal'' clk a -- ^ Value to write (at address @w@) -> 'Signal'' clk a- -- ^ Value of the \@blockRAM\@ at address \@r\@ from the previous clock+ -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle-blockRam# clk binit wr rd en din = 'register'' clk undefined dout+blockRam# clk content rd en wr din =+ 'register'' clk ('errorX' "blockRam#: intial value undefined") dout where- szI = fromInteger $ 'maxIndex' content+ szI = 'length' content dout = runST $ do- arr <- newListArray (0,szI) ('toList' content)- traverse (ramT arr) ('bundle'' clk (wr,rd,en,din))+ arr <- newListArray (0,szI-1) ('toList' content)+ traverse (ramT arr) ('bundle' (rd,en,wr,din)) - ramT :: STArray s Int e -> (Int,Int,Bool,e) -> ST s e- ramT ram (w,r,e,d) = do- d' <- readArray ram r+ ramT :: STArray s Int e -> (Int,Bool,Int,e) -> ST s e+ ramT ram (r,e,w,d) = do+ -- reading from address using an 'X' exception results in an 'X' result+ r' <- unsafeIOToST $+ catch (evaluate r >>= (return . Right))+ (\(err :: XException) -> return (Left (throw err)))+ d' <- case r' of+ Right r2 -> readArray ram r2+ Left err -> return err+ -- writing to an address using an 'X' exception makes everything 'X' when e (writeArray ram w d) return d'+{\-\# NOINLINE blockRam# \#-\} @ And for which the /declaration/ primitive is: @ { \"BlackBox\" :- { "name" : "CLaSH.Prelude.BlockRam.blockRam#"+ { "name" : "CLaSH.Prelude.BlockRam.blockRam#"+ , "type" :+"blockRam# :: KnownNat n -- ARG[0]+ => SClock clk -- clk, ARG[1]+ -> Vec n a -- init, ARG[2]+ -> Signal' clk Int -- rd, ARG[3]+ -> Signal' clk Bool -- wren, ARG[4]+ -> Signal' clk Int -- wr, ARG[5]+ -> Signal' clk a -- din, ARG[6]+ -> Signal' clk a" , "templateD" :-"blockRam_~COMPNAME_~SYM[0] : block- signal RAM : ~TYP[2] := ~LIT[2];- signal dout : ~TYP[6];- signal wr : integer range 0 to ~LIT[0] - 1;- signal rd : integer range 0 to ~LIT[0] - 1;+"-- blockRam begin+~GENSYM[~COMPNAME_blockRam][0] : block+ signal ~GENSYM[RAM][1] : ~TYP[2] := ~LIT[2];~IF ~VIVADO ~THEN+ signal ~GENSYM[dout][2] : std_logic_vector(~SIZE[~TYP[6]]-1 downto 0);~ELSE+ signal ~SYM[2] : ~TYP[6];~FI+ signal ~GENSYM[rd][3] : integer range 0 to ~LIT[0] - 1;+ signal ~GENSYM[wr][4] : integer range 0 to ~LIT[0] - 1; begin- wr <= ~ARG[3]+ ~SYM[3] <= to_integer(~ARG[3]) -- pragma translate_off- mod ~LIT[0]+ mod ~LIT[0] -- pragma translate_on- ;+ ; - rd <= ~ARG[4]+ ~SYM[4] <= to_integer(~ARG[5]) -- pragma translate_off- mod ~LIT[0]+ mod ~LIT[0] -- pragma translate_on- ;+ ; - blockRam_~SYM[1] : process(~CLK[1])+ ~GENSYM[blockRam_sync][5] : process(~CLK[1]) begin if rising_edge(~CLK[1]) then- if ~ARG[5] then- RAM(wr) <= ~ARG[6];+ if ~ARG[4] then~IF ~VIVADO ~THEN+ ~SYM[1](~SYM[4]) <= ~TOBV[~ARG[6]][~TYP[6]];~ELSE+ ~SYM[1](~SYM[4]) <= ~ARG[6];~FI end if;- dout <= RAM(rd);+ ~SYM[2] <= ~SYM[1](~SYM[3]); end if;- end process;-- ~RESULT <= dout;-end block;"+ end process;~IF ~VIVADO ~THEN+ ~RESULT <= ~FROMBV[~SYM[2]][~TYPO];~ELSE+ ~RESULT <= ~SYM[2];~FI+end block;+-- blockRam end" }- }+} @ Again, the @name@ of the primitive is the fully qualified name of the function@@ -1139,9 +1163,10 @@ * @~TYPM@: VHDL type/name/ of the result; used in /type qualification/. * @~ERROR[N]@: Error value for the VHDL type of the @(N+1)@'th argument. * @~ERRORO@: Error value for the VHDL type of the result.-* @~SYM[N]@: Randomly generated, but unique, symbol. Multiple occurrences of- @~SYM[N]@ in the same primitive definition all refer to the same random, but- unique, symbol.+* @~GENSYM[\<NAME\>][N]@: Create a unique name, trying to stay as close to+ the given @\<NAME\>@ as possible. This unique symbol can be referred to in+ other places using @~SYM[N]@.+* @~SYM[N]@: a reference to the unique symbol created by @~GENSYM[\<NAME\>][N]@. * @~SIGD[\<HOLE\>][N]@: Create a signal declaration, using @\<HOLE\>@ as the name of the signal, and the type of the @(N+1)@'th argument. * @~SIGDO[\<HOLE\>]@: Create a signal declaration, using @\<HOLE\>@ as the name@@ -1150,9 +1175,25 @@ The content of @\<HOLE\>@ must either be: @TYPM[N]@, @TYPO@, or @TYPELEM[\<HOLE\>]@. * @~COMPNAME@: The name of the component in which the primitive is instantiated. * @~LENGTH[\<HOLE\>]@: The vector length of the type represented by @\<HOLE\>@.+* @~DEPTH[\<HOLE\>]@: The tree depth of the type represented by @\<HOLE\>@. The content of @\<HOLE\>@ must either be: @TYPM[N]@, @TYPO@, or @TYPELEM[\<HOLE\>]@. * @~SIZE[\<HOLE\>]@: The number of bits needed to encode the type represented by @\<HOLE\>@. The content of @\<HOLE\>@ must either be: @TYPM[N]@, @TYPO@, or @TYPELEM[\<HOLE\>]@.+* @~IF \<CONDITION\> ~THEN \<THEN\> ~ELSE \<ELSE\> ~FI@: renders the \<ELSE\>+ part when \<CONDITION\> evaluates to /0/, and renders the \<THEN\> in all+ other cases. Valid @\<CONDITION\>@s are @~LENGTH[\<HOLE\>]@, @~SIZE[\<HOLE\>]@,+ @~DEPTH[\<HOLE\>]@, and @~VIVADO@.+* @~VIVADO@: /1/ when CλaSH compiler is invoked with the @-clash-xilinx@ or+ @-clash-vivado@ flag. To be used with in an @~IF .. ~THEN .. ~ElSE .. ~FI@+ statement.+* @~FROMBV[\<HOLE\>][\<TYPE\>]@: create conversion code that so that the+ expression in @\<HOLE\>@ is converted to a bit vector (@std_logic_vector@).+ The @\<TYPE\>@ hole indicates the type of the expression and must be either+ @~TYP[N]@, @~TYPO@, or @~TYPELEM[\<HOLE\>]@.+* @~TOBV[\<HOLE\>][\<TYPE\>]@: create conversion code that so that the+ expression in @\<HOLE\>@, which has a bit vector (@std_logic_vector@) type, is+ converted to type indicated by @\<TYPE\>@. The @\<TYPE\>@ hole indicates the+ must be either @~TYP[N]@, @~TYPO@, or @~TYPELEM[\<HOLE\>]@. Some final remarks to end this section: VHDL primitives are there to instruct the CλaSH compiler to use the given VHDL template, instead of trying to do normal@@ -1183,33 +1224,43 @@ @ { \"BlackBox\" :- { "name" : "CLaSH.Prelude.BlockRam.blockRam#"+ { "name" : "CLaSH.Prelude.BlockRam.blockRam#"+ , "type" :+"blockRam# :: KnownNat n -- ARG[0]+ => SClock clk -- clk, ARG[1]+ -> Vec n a -- init, ARG[2]+ -> Signal' clk Int -- rd, ARG[3]+ -> Signal' clk Bool -- wren, ARG[4]+ -> Signal' clk Int -- wr, ARG[5]+ -> Signal' clk a -- din, ARG[6]+ -> Signal' clk a" , "templateD" : "// blockRam begin-reg ~TYPO RAM_~SYM[0] [0:~LIT[0]-1];-reg ~TYPO dout_~SYM[1];+reg ~TYPO ~GENSYM[RAM][0] [0:~LIT[0]-1];+reg ~TYPO ~GENSYM[dout][1]; -reg ~TYP[2] ram_init_~SYM[2];-integer ~SYM[3];+reg ~TYP[2] ~GENSYM[ram_init][2];+integer ~GENSYM[i][3]; initial begin- ram_init_~SYM[2] = ~ARG[2];+ ~SYM[2] = ~ARG[2]; for (~SYM[3]=0; ~SYM[3] < ~LIT[0]; ~SYM[3] = ~SYM[3] + 1) begin- RAM_~SYM[0][~LIT[0]-1-~SYM[3]] = ram_init_~SYM[2][~SYM[3]*~SIZE[~TYPO]+:~SIZE[~TYPO]];+ ~SYM[0][~LIT[0]-1-~SYM[3]] = ~SYM[2][~SYM[3]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; end end -always @(posedge ~CLK[1]) begin : blockRam_~COMPNAME_~SYM[4]- if (~ARG[5]) begin- RAM_~SYM[0][~ARG[3]] <= ~ARG[6];+always @(posedge ~CLK[1]) begin : ~GENSYM[~COMPNAME_blockRam][4]+ if (~ARG[4]) begin+ ~SYM[0][~ARG[5]] <= ~ARG[6]; end- dout_~SYM[1] <= RAM_~SYM[0][~ARG[4]];+ ~SYM[1] <= ~SYM[0][~ARG[3]]; end -assign ~RESULT = dout_~SYM[1];+assign ~RESULT = ~SYM[1]; // blockRam end" }- }+} @+ -} {- $svprimitives@@ -1227,24 +1278,31 @@ @ { \"BlackBox\" :- { "name" : "CLaSH.Prelude.BlockRam.blockRam#"+ { "name" : "CLaSH.Prelude.BlockRam.blockRam#"+ , "type" :+"blockRam# :: KnownNat n -- ARG[0]+ => SClock clk -- clk, ARG[1]+ -> Vec n a -- init, ARG[2]+ -> Signal' clk Int -- rd, ARG[3]+ -> Signal' clk Bool -- wren, ARG[4]+ -> Signal' clk Int -- wr, ARG[5]+ -> Signal' clk a -- din, ARG[6]+ -> Signal' clk a" , "templateD" :-"// blockRam-~SIGD[RAM_~SYM[0]][2];-~SIGD[dout_~SYM[1]][6];-+"// blockRam begin+~SIGD[~GENSYM[RAM][0]][2];+logic [~SIZE[~TYP[6]]-1:0] ~GENSYM[dout][1]; initial begin- ~SYM[0] = ~LIT[3];+ ~SYM[0] = ~LIT[2]; end--always @(posedge ~CLK[1]) begin : blockRam_~COMPNAME_~SYM[3]- if (~ARG[5]) begin- RAM_~SYM[0][~ARG[3]] <= ~ARG[6];+always @(posedge ~CLK[1]) begin : ~GENSYM[~COMPNAME_blockRam][2]+ if (~ARG[4]) begin+ ~SYM[0][~ARG[5]] <= ~TOBV[~ARG[6]][~TYP[6]]; end- dout_~SYM[1] <= RAM_~SYM[0][~ARG[4]];+ ~SYM[1] <= ~SYM[0][~ARG[3]]; end--assign ~RESULT = dout_~SYM[1];"+assign ~RESULT = ~FROMBV[~SYM[1]][~TYP[6]];+// blockRam end" } } @@@ -1297,6 +1355,7 @@ import CLaSH.Prelude import CLaSH.Prelude.Explicit+import Data.Maybe (isJust) @ Then we'll start with the /heart/ of the FIFO synchroniser, an asynchronous RAM@@ -1306,14 +1365,14 @@ synchronous logic. As a consequence, we see in the type signature of 'asyncRam'': @-__asyncRam'__ :: _ => SClock wclk -- ^ Clock to which to synchronise the write port of the RAM- -> SClock rclk -- ^ Clock to which the read address signal __r__ is synchronised- -> SNat n -- ^ Size __n__ of the RAM- -> Signal' wclk addr -- ^ Write address __w__- -> Signal' rclk addr -- ^ Read address __r__- -> Signal' wclk Bool -- ^ Write enable- -> Signal' wclk a -- ^ Value to write (at address __w__)- -> Signal' rclk a -- ^ Value of the RAM at address __r__+__asyncRam'__+ :: _+ => SClock wclk -- ^ Clock to which to synchronise the write port of the RAM+ -> SClock rclk -- ^ Clock to which the read address signal __r__ is synchronised+ -> SNat n -- ^ Size __n__ of the RAM+ -> Signal' rclk addr -- ^ Read address __r__+ -> Signal' wclk (Maybe (addr,a)) -- ^ (write address @w@, value to write)+ -> Signal' rclk a -- ^ Value of the RAM at address __r__ @ that the signal containing the read address __r__ is synchronised to a different@@ -1322,12 +1381,13 @@ We continue by instantiating the 'asyncRam'': @-fifoMem wclk rclk addrSize waddr raddr winc wfull wdata =+fifoMem wclk rclk addrSize wfull raddr wdataM = 'asyncRam'' wclk rclk- (d2 ``powSNat`` addrSize)- waddr raddr- (winc '.&&.' 'not1' wfull)- wdata+ ('pow2SNat' addrSize)+ raddr+ ('mux' (not \<$\> wfull)+ wdataM+ (pure Nothing)) @ We see that we give it @2^addrSize@ elements, where @addrSize@ is the bit-size@@ -1337,24 +1397,17 @@ The next part of the design calculates the read and write address for the asynchronous RAM, and creates the flags indicating whether the FIFO is full-or empty. We start with a function that converts 'Bool'eans to @n + 1@ bit-bitvectors:--@-boolToBV :: (KnownNat n, KnownNat (n+1)) => Bool -> BitVector (n + 1)-boolToBV = 'zeroExtend' . 'pack'-@--followed by the actual address and flag generator in 'mealy' machine style:+or empty. The address and flag generator is given in 'mealy' machine style: @-ptrCompareT addrSize flagGen (bin,ptr,flag) (s_ptr,inc) = ((bin',ptr',flag')- ,(flag,addr,ptr))+ptrCompareT addrSize flagGen (bin,ptr,flag) (s_ptr,inc) =+ ((bin',ptr',flag')+ ,(flag,addr,ptr)) where -- GRAYSTYLE2 pointer- bin' = bin + boolToBV (inc && not flag)+ bin' = bin + 'boolToBV' (inc && not flag) ptr' = (bin' \`shiftR\` 1) \`xor\` bin'- addr = 'slice' (addrSize ``subSNat`` d1) d0 bin+ addr = 'slice' (addrSize ``subSNat`` d1) d0 bin flag' = flagGen ptr' s_ptr @@@ -1375,8 +1428,10 @@ rptrEmptyInit = (0,0,True) -- FIFO full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1:0]}-isFull addrSize ptr s_ptr = ptr == ('complement' ('slice' addrSize (addrSize ``subSNat`` d1) s_ptr) '++#'- 'slice' (addrSize ``subSNat`` d2) d0 s_ptr)+isFull addrSize ptr s_ptr =+ ptr == 'complement' ('slice' addrSize (addrSize ``subSNat`` d1) s_ptr) '++#'+ 'slice' (addrSize ``subSNat`` d2) d0 s_ptr+ wptrFullInit = (0,0,False) @ @@ -1399,28 +1454,32 @@ Finally we combine all the component in: @-fifo :: _- => SNat addrSize -> SClock wclk -> SClock rclk- -> Signal' wclk a -> Signal' wclk Bool- -> Signal' rclk Bool- -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool)-fifo addrSize wclk rclk wdata winc rinc = (rdata,rempty,wfull)+fifo+ :: _+ => SNat (addrSize + 2)+ -> SClock wclk+ -> SClock rclk+ -> Signal' rclk Bool+ -> Signal' wclk (Maybe a)+ -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool)+fifo addrSize wclk rclk rinc wdataM = (rdata,rempty,wfull) where s_rptr = ptrSync rclk wclk rptr s_wptr = ptrSync wclk rclk wptr - rdata = fifoMem wclk rclk addrSize waddr raddr winc wfull wdata+ rdata = fifoMem wclk rclk addrSize wfull raddr+ (liftA2 (,) \<$\> (Just \<$\> waddr) \<*\> wdataM) (rempty,raddr,rptr) = 'mealyB'' rclk (ptrCompareT addrSize isEmpty) rptrEmptyInit (s_wptr,rinc) (wfull,waddr,wptr) = 'mealyB'' wclk (ptrCompareT addrSize (isFull addrSize))- wptrFullInit (s_rptr,winc)+ wptrFullInit (s_rptr,isJust \<$\> wdataM) @ where we first specify the synchronisation of the read and the write pointers,-instantiate the asynchronous RAM, and instantiate the read address/pointer/flag-generator and write address/pointer/flag generator.+instantiate the asynchronous RAM, and instantiate the read address \/ pointer \/+flag generator and write address \/ pointer \/ flag generator. Ultimately, the whole file containing our FIFO design will look like this: @@ -1431,22 +1490,22 @@ import CLaSH.Prelude import CLaSH.Prelude.Explicit+import Data.Maybe (isJust) -fifoMem wclk rclk addrSize waddr raddr winc wfull wdata =+fifoMem wclk rclk addrSize wfull raddr wdataM = 'asyncRam'' wclk rclk- (d2 ``powSNat`` addrSize)- waddr raddr- (winc '.&&.' 'not1' wfull)- wdata--boolToBV :: (KnownNat n, KnownNat (n+1)) => Bool -> BitVector (n + 1)-boolToBV = 'zeroExtend' . 'pack'+ ('pow2SNat' addrSize)+ raddr+ ('mux' (not \<$\> wfull)+ wdataM+ (pure Nothing)) -ptrCompareT addrSize flagGen (bin,ptr,flag) (s_ptr,inc) = ((bin',ptr',flag')- ,(flag,addr,ptr))+ptrCompareT addrSize flagGen (bin,ptr,flag) (s_ptr,inc) =+ ((bin',ptr',flag')+ ,(flag,addr,ptr)) where -- GRAYSTYLE2 pointer- bin' = bin + boolToBV (inc && not flag)+ bin' = bin + 'boolToBV' (inc && not flag) ptr' = (bin' \`shiftR\` 1) \`xor\` bin' addr = 'slice' (addrSize ``subSNat`` d1) d0 bin @@ -1457,8 +1516,10 @@ rptrEmptyInit = (0,0,True) -- FIFO full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1:0]}-isFull addrSize ptr s_ptr = ptr == ('complement' ('slice' addrSize (addrSize ``subSNat`` d1) s_ptr) '++#'- 'slice' (addrSize ``subSNat`` d2) d0 s_ptr)+isFull addrSize ptr s_ptr =+ ptr == 'complement' ('slice' addrSize (addrSize ``subSNat`` d1) s_ptr) '++#'+ 'slice' (addrSize ``subSNat`` d2) d0 s_ptr+ wptrFullInit = (0,0,False) -- Dual flip-flip synchroniser@@ -1467,23 +1528,27 @@ . 'unsafeSynchronizer' clk1 clk2 -- Async FIFO synchroniser-fifo :: _- => SNat addrSize -> SClock wclk -> SClock rclk- -> Signal' wclk a -> Signal' wclk Bool- -> Signal' rclk Bool- -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool)-fifo addrSize wclk rclk wdata winc rinc = (rdata,rempty,wfull)+fifo+ :: _+ => SNat (addrSize + 2)+ -> SClock wclk+ -> SClock rclk+ -> Signal' rclk Bool+ -> Signal' wclk (Maybe a)+ -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool)+fifo addrSize wclk rclk rinc wdataM = (rdata,rempty,wfull) where s_rptr = ptrSync rclk wclk rptr s_wptr = ptrSync wclk rclk wptr - rdata = fifoMem wclk rclk addrSize waddr raddr winc wfull wdata+ rdata = fifoMem wclk rclk addrSize wfull raddr+ (liftA2 (,) \<$\> (Just \<$\> waddr) \<*\> wdataM) (rempty,raddr,rptr) = 'mealyB'' rclk (ptrCompareT addrSize isEmpty) rptrEmptyInit (s_wptr,rinc) (wfull,waddr,wptr) = 'mealyB'' wclk (ptrCompareT addrSize (isFull addrSize))- wptrFullInit (s_rptr,winc)+ wptrFullInit (s_rptr,isJust \<$\> wdataM) @ == Instantiating a FIFO synchroniser@@ -1521,10 +1586,10 @@ domain and to the FFT clock domain: @-adcToFFT :: Signal' ClkADC (SFixed 8 8)- -> Signal' ClkADC Bool- -> Signal' ClkFFT Bool- -> (Signal' ClkFFT (SFixed 8 8), Signal' ClkFFT Bool, Signal' ClkADC Bool)+adcToFFT+ :: Signal' ClkFFT Bool+ -> Signal' ClkADC (Maybe (SFixed 8 8))+ -> (Signal' ClkFFT (SFixed 8 8), Signal' ClkFFT Bool, Signal' ClkADC Bool) adcToFFT = fifo d8 clkADC clkFFT @ @@ -1654,7 +1719,7 @@ @topEntity@ has no arguments, you're out of luck for now. If it has multiple arguments, consider bundling them in a tuple. -* __\<*** Exception: \<\<loop\>\>__+* __\<*** Exception: \<\<loop\>\>__ or "blinking cursor" You are using value-recursion, but one of the 'Vec'tor functions that you are using is too /strict/ in one of the recursive arguments. For example:@@ -1818,7 +1883,7 @@ for which the compiler has hard-coded knowledge. For \"easy\" 'Vec'tor literals you should use Template Haskell splices and- the 'v' /meta/-function that as we have seen earlier in this tutorial.+ the 'listToVecTH' /meta/-function that as we have seen earlier in this tutorial. * __GADT pattern matching__
+ src/CLaSH/XException.hs view
@@ -0,0 +1,320 @@+{-|+Copyright : (C) 2016, University of Twente+License : BSD2 (see the file LICENSE)+Maintainer : Christiaan Baaij <christiaan.baaij@gmail.com>++'X': An exception for uninitialized values++>>> show (errorX "undefined" :: Integer, 4 :: Int)+"(*** Exception: X: undefined+CallStack (from HasCallStack):+...+>>> showX (errorX "undefined" :: Integer, 4 :: Int)+"(X,4)"+-}++{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}++{-# LANGUAGE Trustworthy #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module CLaSH.XException+ ( -- * 'X': An exception for uninitialized values+ XException, errorX+ -- * Printing 'X' exceptions as \"X\"+ , ShowX (..), showsX, printX, showsPrecXWith)+where++import Control.Exception (Exception, catch, evaluate, throw)+import Data.Complex (Complex)+import Data.Int (Int8,Int16,Int32,Int64)+import Data.Ratio (Ratio)+import Data.Word (Word8,Word16,Word32,Word64)+import GHC.Exts (Char (C#), Double (D#), Float (F#), Int (I#), Word (W#))+import GHC.Generics+import GHC.Show (appPrec)+import GHC.Stack (HasCallStack, callStack, prettyCallStack)+import System.IO.Unsafe (unsafeDupablePerformIO)++-- | An exception representing an \"uninitialised\" value.+newtype XException = XException String++instance Show XException where+ show (XException s) = s++instance Exception XException++-- | Like 'error', but throwing an 'XException' instead of an 'ErrorCall'+--+-- The 'ShowX' methods print these error-values as \"X\"; instead of error'ing+-- out with an exception.+errorX :: HasCallStack => String -> a+errorX msg = throw (XException ("X: " ++ msg ++ "\n" ++ prettyCallStack callStack))++showXWith :: (a -> ShowS) -> a -> ShowS+showXWith f x =+ \s -> unsafeDupablePerformIO (catch (f <$> evaluate x <*> pure s)+ (\(XException _) -> return ('X': s)))++-- | Use when you want to create a 'ShowX' instance where:+--+-- - There is no 'Generic' instance for your data type+-- - The 'Generic' derived ShowX method would traverse into the (hidden)+-- implementation details of your data type, and you just want to show the+-- entire value as \"X\".+--+-- Can be used like:+--+-- > data T = ...+-- >+-- > instance Show T where ...+-- >+-- > instance ShowX T where+-- > showsPrecX = showsPrecXWith showsPrec+showsPrecXWith :: (Int -> a -> ShowS) -> Int -> a -> ShowS+showsPrecXWith f n = showXWith (f n)++-- | Like 'shows', but values that normally throw an 'X' exception are+-- converted to \"X\", instead of error'ing out with an exception.+showsX :: ShowX a => a -> ShowS+showsX = showsPrecX 0++-- | Like 'print', but values that normally throw an 'X' exception are+-- converted to \"X\", instead of error'ing out with an exception+printX :: ShowX a => a -> IO ()+printX x = putStrLn $ showX x++-- | Like the 'Show' class, but values that normally throw an 'X' exception are+-- converted to \"X\", instead of error'ing out with an exception.+--+-- >>> show (errorX "undefined" :: Integer, 4 :: Int)+-- "(*** Exception: X: undefined+-- CallStack (from HasCallStack):+-- ...+-- >>> showX (errorX "undefined" :: Integer, 4 :: Int)+-- "(X,4)"+--+-- Can be derived using 'GHC.Generics':+--+-- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+-- >+-- > import CLaSH.Prelude+-- > import GHC.Generics+-- >+-- > data T = MkTA Int | MkTB Bool+-- > deriving (Show,Generic,ShowX)+class ShowX a where+ -- | Like 'showsPrec', but values that normally throw an 'X' exception are+ -- converted to \"X\", instead of error'ing out with an exception.+ showsPrecX :: Int -> a -> ShowS++ -- | Like 'show', but values that normally throw an 'X' exception are+ -- converted to \"X\", instead of error'ing out with an exception.+ showX :: a -> String+ showX x = showsX x ""++ -- | Like 'showList', but values that normally throw an 'X' exception are+ -- converted to \"X\", instead of error'ing out with an exception.+ showListX :: [a] -> ShowS+ showListX ls s = showListX__ showsX ls s++ default showsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS+ showsPrecX = genericShowsPrecX++showListX__ :: (a -> ShowS) -> [a] -> ShowS+showListX__ showx = showXWith go+ where+ go [] s = "[]" ++ s+ go (x:xs) s = '[' : showx x (showl xs)+ where+ showl [] = ']':s+ showl (y:ys) = ',' : showx y (showl ys)++data ShowType = Rec -- Record+ | Tup -- Tuple+ | Pref -- Prefix+ | Inf String -- Infix++genericShowsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS+genericShowsPrecX n = gshowsPrecX Pref n . from++instance ShowX ()+instance (ShowX a, ShowX b) => ShowX (a,b)+instance (ShowX a, ShowX b, ShowX c) => ShowX (a,b,c)+instance (ShowX a, ShowX b, ShowX c, ShowX d) => ShowX (a,b,c,d)+instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e) => ShowX (a,b,c,d,e)+instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f) => ShowX (a,b,c,d,e,f)+instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g) => ShowX (a,b,c,d,e,f,g)++-- Show is defined up to 15-tuples, but GHC.Generics only has Generic instances+-- up to 7-tuples, hence we need these orphan instances.+deriving instance Generic ((,,,,,,,) a b c d e f g h)+deriving instance Generic ((,,,,,,,,) a b c d e f g h i)+deriving instance Generic ((,,,,,,,,,) a b c d e f g h i j)+deriving instance Generic ((,,,,,,,,,,) a b c d e f g h i j k)+deriving instance Generic ((,,,,,,,,,,,) a b c d e f g h i j k l)+deriving instance Generic ((,,,,,,,,,,,,) a b c d e f g h i j k l m)+deriving instance Generic ((,,,,,,,,,,,,,) a b c d e f g h i j k l m n)+deriving instance Generic ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o)++instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h) => ShowX (a,b,c,d,e,f,g,h)+instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i) => ShowX (a,b,c,d,e,f,g,h,i)+instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j)+ => ShowX (a,b,c,d,e,f,g,h,i,j)+instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k)+ => ShowX (a,b,c,d,e,f,g,h,i,j,k)+instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l)+ => ShowX (a,b,c,d,e,f,g,h,i,j,k,l)+instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l+ ,ShowX m)+ => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m)+instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l+ ,ShowX m, ShowX n)+ => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m,n)+instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l+ ,ShowX m, ShowX n, ShowX o)+ => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o)++instance {-# OVERLAPPABLE #-} ShowX a => ShowX [a] where+ showsPrecX _ = showListX++instance ShowX Bool++instance ShowX Double where+ showsPrecX = showsPrecXWith showsPrec++instance (ShowX a, ShowX b) => ShowX (Either a b)++instance ShowX Float where+ showsPrecX = showsPrecXWith showsPrec++instance ShowX Int where+ showsPrecX = showsPrecXWith showsPrec++instance ShowX Int8 where+ showsPrecX = showsPrecXWith showsPrec++instance ShowX Int16 where+ showsPrecX = showsPrecXWith showsPrec++instance ShowX Int32 where+ showsPrecX = showsPrecXWith showsPrec++instance ShowX Int64 where+ showsPrecX = showsPrecXWith showsPrec++instance ShowX Integer where+ showsPrecX = showsPrecXWith showsPrec++instance ShowX Word where+ showsPrecX = showsPrecXWith showsPrec++instance ShowX Word8 where+ showsPrecX = showsPrecXWith showsPrec++instance ShowX Word16 where+ showsPrecX = showsPrecXWith showsPrec++instance ShowX Word32 where+ showsPrecX = showsPrecXWith showsPrec++instance ShowX Word64 where+ showsPrecX = showsPrecXWith showsPrec++instance ShowX a => ShowX (Maybe a)++instance ShowX a => ShowX (Ratio a) where+ showsPrecX = showsPrecXWith showsPrecX++instance ShowX a => ShowX (Complex a)++instance {-# OVERLAPPING #-} ShowX String where+ showsPrecX = showsPrecXWith showsPrec++class GShowX f where+ gshowsPrecX :: ShowType -> Int -> f a -> ShowS+ isNullary :: f a -> Bool+ isNullary = error "generic showX (isNullary): unnecessary case"++instance GShowX U1 where+ gshowsPrecX _ _ U1 = id+ isNullary _ = True++instance (ShowX c) => GShowX (K1 i c) where+ gshowsPrecX _ n (K1 a) = showsPrecX n a+ isNullary _ = False++instance (GShowX a, Constructor c) => GShowX (M1 C c a) where+ gshowsPrecX _ n c@(M1 x) =+ case fixity of+ Prefix ->+ showParen (n > appPrec && not (isNullary x))+ ( (if conIsTuple c then id else showString (conName c))+ . (if isNullary x || conIsTuple c then id else showString " ")+ . showBraces t (gshowsPrecX t appPrec x))+ Infix _ m -> showParen (n > m) (showBraces t (gshowsPrecX t m x))+ where fixity = conFixity c+ t = if conIsRecord c then Rec else+ case conIsTuple c of+ True -> Tup+ False -> case fixity of+ Prefix -> Pref+ Infix _ _ -> Inf (show (conName c))+ showBraces :: ShowType -> ShowS -> ShowS+ showBraces Rec p = showChar '{' . p . showChar '}'+ showBraces Tup p = showChar '(' . p . showChar ')'+ showBraces Pref p = p+ showBraces (Inf _) p = p++ conIsTuple :: C1 c f p -> Bool+ conIsTuple y = tupleName (conName y) where+ tupleName ('(':',':_) = True+ tupleName _ = False++instance (Selector s, GShowX a) => GShowX (M1 S s a) where+ gshowsPrecX t n s@(M1 x) | selName s == "" = gshowsPrecX t n x+ | otherwise = showString (selName s)+ . showString " = "+ . gshowsPrecX t 0 x+ isNullary (M1 x) = isNullary x++instance (GShowX a) => GShowX (M1 D d a) where+ gshowsPrecX t = showsPrecXWith go+ where go n (M1 x) = gshowsPrecX t n x++instance (GShowX a, GShowX b) => GShowX (a :+: b) where+ gshowsPrecX t n (L1 x) = gshowsPrecX t n x+ gshowsPrecX t n (R1 x) = gshowsPrecX t n x++instance (GShowX a, GShowX b) => GShowX (a :*: b) where+ gshowsPrecX t@Rec n (a :*: b) =+ gshowsPrecX t n a . showString ", " . gshowsPrecX t n b+ gshowsPrecX t@(Inf s) n (a :*: b) =+ gshowsPrecX t n a . showString s . gshowsPrecX t n b+ gshowsPrecX t@Tup n (a :*: b) =+ gshowsPrecX t n a . showChar ',' . gshowsPrecX t n b+ gshowsPrecX t@Pref n (a :*: b) =+ gshowsPrecX t (n+1) a . showChar ' ' . gshowsPrecX t (n+1) b++ -- If we have a product then it is not a nullary constructor+ isNullary _ = False++-- Unboxed types+instance GShowX UChar where+ gshowsPrecX _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#'+instance GShowX UDouble where+ gshowsPrecX _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##"+instance GShowX UFloat where+ gshowsPrecX _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#'+instance GShowX UInt where+ gshowsPrecX _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#'+instance GShowX UWord where+ gshowsPrecX _ _ (UWord w) = showsPrec 0 (W# w) . showString "##"