clash-prelude 1.2.4 → 1.2.5
raw patch · 16 files changed
+385/−87 lines, 16 filesdep +hedgehogdep +tasty-hedgehogdep ~bytestringdep ~ghc-typelits-extradep ~ghc-typelits-natnormalisePVP ok
version bump matches the API change (PVP)
Dependencies added: hedgehog, tasty-hedgehog
Dependency ranges changed: bytestring, ghc-typelits-extra, ghc-typelits-natnormalise, tasty, text-show, th-abstraction, time
API changes (from Hackage documentation)
+ Clash.Class.Num: instance GHC.Enum.Bounded Clash.Class.Num.SaturationMode
+ Clash.Class.Num: instance GHC.Enum.Enum Clash.Class.Num.SaturationMode
+ Clash.Class.Num: instance GHC.Show.Show Clash.Class.Num.SaturationMode
Files
- CHANGELOG.md +15/−3
- clash-prelude.cabal +12/−7
- src/Clash/Class/AutoReg/Internal.hs +7/−1
- src/Clash/Class/Num.hs +11/−13
- src/Clash/Examples.hs +2/−2
- src/Clash/Explicit/Signal.hs +12/−11
- src/Clash/Signal.hs +6/−6
- src/Clash/Signal/Internal.hs +1/−1
- src/Clash/Sized/Fixed.hs +44/−16
- src/Clash/Sized/Internal/BitVector.hs +7/−2
- src/Clash/Sized/Internal/Index.hs +21/−10
- src/Clash/Sized/Internal/Signed.hs +5/−0
- tests/Clash/Tests/BitVector.hs +62/−12
- tests/Clash/Tests/Fixed.hs +165/−0
- tests/Clash/Tests/Signal.hs +11/−1
- tests/unittests.hs +4/−2
CHANGELOG.md view
@@ -1,5 +1,19 @@ # Changelog for the Clash project +## 1.2.5 *November 9th 2020*+Fixed:+ * The normalizeType function now fully normalizes types which require calls to+reduceTypeFamily [#1469](https://github.com/clash-lang/clash-compiler/issues/1469)+ * `flogBaseSNat`, `clogBaseSNat` and `logBaseSNat` primitives are now implemented correctly.Previously these primitives would be left unevaluated causing issues as demonstrated in [#1479](https://github.com/clash-lang/clash-compiler/issues/1469)+ * Specializing on functions with type family arguments no longer fails [#1477](https://github.com/clash-lang/clash-compiler/issues/1477)+ * `satSucc`, `satPred` correctly handle "small types" such as `Index 1`.+ * `msb` no longer fails on values larger than 64 bits+ * `undefined` can now be used as a reset value of `autoReg@Maybe` [#1507](https://github.com/clash-lang/clash-compiler/issues/1507)+ * Signal's `fmap` is now less strict, preventing infinite loops in very specific situations. See [#1521](https://github.com/clash-lang/clash-compiler/issues/1521)+ * Clash now uses correct function names in manifest and sdc files [#1533](https://github.com/clash-lang/clash-compiler/issues/1533)+ * Clash no longer produces erroneous HDL in very specific cases [#1536](https://github.com/clash-lang/clash-compiler/issues/1536)+ * Usage of `fold` inside other HO primitives (e.g., `map`) no longer fails [#1524](https://github.com/clash-lang/clash-compiler/issues/1524)+ ## 1.2.4 *July 28th 2020* * Changed: * Relaxed upper bound versions of `aeson` and `dlist`, in preparation for the new Stack LTS.@@ -16,7 +30,7 @@ * `instance Text.Printf(Unsigned)` * Fixed:- * Clash renders incorrect VHDL when GHCs Worker/Wrapper transformation is enabled [#1402](https://github.com/clash-lang/clash-compiler/issues/14020)+ * Clash renders incorrect VHDL when GHCs Worker/Wrapper transformation is enabled [#1402](https://github.com/clash-lang/clash-compiler/issues/1402) * Minor faults in generated HDL when using annotations from `Clash.Annotations.SynthesisAttributes` * Cabal installed through Snap (`clash.cabal`) can now access the internet to fetch pacakges. [#1411]https://github.com/clash-lang/clash-compiler/issues/1411 * Generated QSys file for `altpll` incompatible with Quartus CLI (did work in Quartus GUI)@@ -387,5 +401,3 @@ * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-prelude/CHANGELOG.md * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-lib/CHANGELOG.md * https://github.com/clash-lang/clash-compiler/blob/3649a2962415ea8ca2d6f7f5e673b4c14de26b4f/clash-ghc/CHANGELOG.md--
clash-prelude.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 2.2 Name: clash-prelude-Version: 1.2.4+Version: 1.2.5 Synopsis: CAES Language for Synchronous Hardware - Prelude library Description: Clash is a functional hardware description language that borrows both its@@ -309,7 +309,7 @@ base >= 4.11 && < 5, bifunctors >= 5.4.0 && < 6.0, binary >= 0.8.5 && < 0.11,- bytestring >= 0.10.8 && < 0.11,+ bytestring >= 0.10.8 && < 0.12, constraints >= 0.9 && < 1.0, containers >= 0.4.0 && < 0.7, data-binary-ieee754 >= 0.4.4 && < 0.6,@@ -329,12 +329,12 @@ reflection >= 2 && < 2.2, singletons >= 1.0 && < 3.0, template-haskell >= 2.12.0.0 && < 2.17,- th-abstraction >= 0.2.10 && < 0.4.0,+ th-abstraction >= 0.2.10 && < 0.5.0, th-lift >= 0.7.0 && < 0.9, th-orphans >= 0.13.1 && < 1.0, text >= 0.11.3.1 && < 1.3,- text-show >= 3.8 && < 3.9,- time >= 1.8 && < 1.11,+ text-show >= 3.8 && < 3.10,+ time >= 1.8 && < 1.12, transformers >= 0.5.2.0 && < 0.6, type-errors >= 0.2.0.0 && < 0.3, uniplate >= 1.6.12 && < 1.7,@@ -374,11 +374,15 @@ clash-prelude, ghc-typelits-knownnat,+ ghc-typelits-natnormalise,+ ghc-typelits-extra, base,+ hedgehog, hint >= 0.7 && < 0.10, quickcheck-classes-base >= 0.6 && < 1.0,- tasty >= 1.2 && < 1.4,+ tasty >= 1.2 && < 1.5,+ tasty-hedgehog, tasty-hunit, tasty-quickcheck, template-haskell@@ -389,10 +393,11 @@ Clash.Tests.BitVector Clash.Tests.DerivingDataRepr Clash.Tests.DerivingDataReprTypes+ Clash.Tests.Fixed+ Clash.Tests.NFDataX Clash.Tests.Signal Clash.Tests.Signed Clash.Tests.SizedNum- Clash.Tests.NFDataX Clash.Tests.TopEntityGeneration Clash.Tests.Unsigned
src/Clash/Class/AutoReg/Internal.hs view
@@ -111,6 +111,7 @@ -> Signal dom a -> Signal dom a autoReg = register+ {-# INLINE autoReg #-} instance AutoReg () instance AutoReg Bool@@ -157,6 +158,7 @@ createMaybe t v = case t of True -> Just v False -> Nothing+ {-# INLINE autoReg #-} instance (KnownNat n, AutoReg a) => AutoReg (Vec n a) where autoReg@@ -170,10 +172,12 @@ where go :: forall (i :: Nat). SNat i -> a -> Signal dom a -> Signal dom a go SNat = suffixNameFromNatP @i . autoReg clk rst en+ {-# INLINE autoReg #-} instance (KnownNat d, AutoReg a) => AutoReg (RTree d a) where autoReg clk rst en initVal xs = bundle $ (autoReg clk rst en) <$> lazyT initVal <*> unbundle xs+ {-# INLINE autoReg #-} -- | Decompose an applied type into its individual components. For example, this:@@ -328,7 +332,9 @@ autoRegDec <- funD 'autoReg [clause argsP (normalB body) decls] ctx <- calculateRequiredContext conInfo- return [InstanceD Nothing ctx (AppT (ConT ''AutoReg) ty) [autoRegDec]]+ return [InstanceD Nothing ctx (AppT (ConT ''AutoReg) ty)+ [ autoRegDec+ , PragmaD (InlineP 'autoReg Inline FunLike AllPhases) ]] -- Calculate the required constraint to call autoReg on all the fields of a -- given constructor
src/Clash/Class/Num.hs view
@@ -20,8 +20,6 @@ , boundedAdd , boundedSub , boundedMul- , satSucc- , satPred ) where @@ -54,7 +52,7 @@ | SatSymmetric -- ^ Become 'maxBound' on overflow, and (@'minBound' + 1@) on -- underflow for signed numbers, and 'minBound' for unsigned -- numbers.- deriving Eq+ deriving (Show, Eq, Enum, Bounded) -- | 'Num' operators in which overflow and underflow behavior can be specified -- using 'SaturationMode'.@@ -65,16 +63,16 @@ satSub :: SaturationMode -> a -> a -> a -- | Multiplication with parameterizable over- and underflow behavior satMul :: SaturationMode -> a -> a -> a---- | Get successor of (or in other words, add 1 to) given number-satSucc :: SaturatingNum a => SaturationMode -> a -> a-satSucc s n = satAdd s n 1-{-# INLINE satSucc #-}---- | Get predecessor of (or in other words, subtract 1 from) given number-satPred :: SaturatingNum a => SaturationMode -> a -> a-satPred s n = satSub s n 1-{-# INLINE satPred #-}+ -- | Get successor of (or in other words, add 1 to) given number+ satSucc :: SaturationMode -> a -> a+ -- Default method suitable for types that can represent the number 1+ satSucc s n = satAdd s n 1+ {-# INLINE satSucc #-}+ -- | Get predecessor of (or in other words, subtract 1 from) given number+ satPred :: SaturationMode -> a -> a+ -- Default method suitable for types that can represent the number 1+ satPred s n = satSub s n 1+ {-# INLINE satPred #-} -- | Addition that clips to 'maxBound' on overflow, and 'minBound' on underflow boundedAdd :: SaturatingNum a => a -> a -> a
src/Clash/Examples.hs view
@@ -295,7 +295,7 @@ , _rx_d1 :: Bit , _rx_d2 :: Bit , _rx_busy :: Bool- }+ } deriving (Generic, NFDataX) makeLenses ''RxReg @@ -347,7 +347,7 @@ , _tx_over_run :: Bool , _tx_out :: Bit , _tx_cnt :: Unsigned 4- }+ } deriving (Generic, NFDataX) makeLenses ''TxReg
src/Clash/Explicit/Signal.hs view
@@ -563,6 +563,7 @@ -> Enable dom enable e0 e1 = toEnable (fromEnable e0 .&&. e1)+{-# INLINE enable #-} -- | Special version of 'delay' that doesn't take enable signals of any kind. -- Initial value will be undefined.@@ -572,8 +573,8 @@ => Clock dom -> Signal dom a -> Signal dom a-dflipflop clk i =- delay+dflipflop = \clk i ->+ delay# clk (toEnable (pure True)) (deepErrorX "First value of dflipflop undefined")@@ -616,8 +617,8 @@ -- ^ Initial value -> Signal dom (Maybe a) -> Signal dom a-delayMaybe clk gen dflt i =- delayEn clk gen dflt (isJust <$> i) (fromJustX <$> i)+delayMaybe = \clk gen dflt i ->+ delay# clk (enable gen (isJust <$> i)) dflt (fromJustX <$> i) {-# INLINE delayMaybe #-} -- | Version of 'delay' that only updates when its third argument is asserted.@@ -639,8 +640,8 @@ -- ^ Enable -> Signal dom a -> Signal dom a-delayEn clk gen dflt en i =- delay clk (enable gen en) dflt i+delayEn = \clk gen dflt en i ->+ delay# clk (enable gen en) dflt i {-# INLINE delayEn #-} -- | \"@'register' clk rst i s@\" delays the values in 'Signal' /s/ for one@@ -662,7 +663,7 @@ -- will also be the initial value. -> Signal dom a -> Signal dom a-register clk rst gen initial i =+register = \clk rst gen initial i -> register# clk rst gen initial initial i {-# INLINE register #-} @@ -701,8 +702,8 @@ -- will also be the initial value. -> Signal dom (Maybe a) -> Signal dom a-regMaybe clk rst en initial iM =- register clk rst (enable en (fmap isJust iM)) initial (fmap fromJustX iM)+regMaybe = \clk rst en initial iM ->+ register# clk rst (enable en (fmap isJust iM)) initial initial (fmap fromJustX iM) {-# INLINE regMaybe #-} -- | Version of 'register' that only updates its content when its fourth@@ -736,8 +737,8 @@ -- ^ Enable signal -> Signal dom a -> Signal dom a-regEn clk rst gen initial en i =- register clk rst (enable gen en) initial i+regEn = \clk rst gen initial en i ->+ register# clk rst (enable gen en) initial initial i {-# INLINE regEn #-} -- * Simulation functions
src/Clash/Signal.hs view
@@ -1308,7 +1308,7 @@ -> Signal dom a -- ^ Signal to delay -> Signal dom a-delay dflt i =+delay = \dflt i -> delay# (fromLabel @(HiddenClockName dom)) (fromLabel @(HiddenEnableName dom))@@ -1331,7 +1331,7 @@ -- ^ Initial value -> Signal dom (Maybe a) -> Signal dom a-delayMaybe dflt i =+delayMaybe = \dflt i -> E.delayMaybe (fromLabel @(HiddenClockName dom)) (fromLabel @(HiddenEnableName dom))@@ -1356,7 +1356,7 @@ -- ^ Enable -> Signal dom a -> Signal dom a-delayEn dflt en i =+delayEn = \dflt en i -> E.delayEn (fromLabel @(HiddenClockName dom)) (fromLabel @(HiddenEnableName dom))@@ -1380,7 +1380,7 @@ -- initial value. -> Signal dom a -> Signal dom a-register i s =+register = \i s -> E.register (fromLabel @(HiddenClockName dom)) (fromLabel @(HiddenResetName dom))@@ -1421,7 +1421,7 @@ -- initial value. -> Signal dom (Maybe a) -> Signal dom a-regMaybe initial iM =+regMaybe = \initial iM -> E.regMaybe (fromLabel @(HiddenClockName dom)) (fromLabel @(HiddenResetName dom))@@ -1456,7 +1456,7 @@ -> Signal dom Bool -> Signal dom a -> Signal dom a-regEn initial en i =+regEn = \initial en i -> E.regEn (fromLabel @(HiddenClockName dom)) (fromLabel @(HiddenResetName dom))
src/Clash/Signal/Internal.hs view
@@ -661,7 +661,7 @@ where -- See -fstrict-mapSignal documentation in clash-prelude.cabal theSeq = if fStrictMapSignal then seqX else flip const- go (a :- as) = f a :- (a `theSeq` go as)+ go ~(xs@(a :- as)) = f a :- (a `theSeq` (xs `seq` go as)) {-# NOINLINE mapSignal# #-} {-# ANN mapSignal# hasBlackBox #-}
src/Clash/Sized/Fixed.hs view
@@ -134,7 +134,7 @@ SaturationMode (..), boundedAdd, boundedSub, boundedMul) import Clash.Class.Resize (Resize (..))-import Clash.Promoted.Nat (SNat)+import Clash.Promoted.Nat (SNat, natToNum, natToInteger) import Clash.Prelude.BitIndex (msb, split) import Clash.Prelude.BitReduction (reduceAnd, reduceOr) import Clash.Sized.BitVector (BitVector, (++#))@@ -453,15 +453,15 @@ type AResult (Fixed rep int1 frac1) (Fixed rep int2 frac2) = Fixed rep (1 + Max int1 int2) (Max frac1 frac2) add (Fixed f1) (Fixed f2) =- let sh1 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac1)) :: Int+ let sh1 = natToNum @(Max frac1 frac2) - natToNum @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+ sh2 = natToNum @(Max frac1 frac2) - natToNum @frac2 :: Int f2R = shiftL (resize f2) sh2 :: rep ((1 + Max int1 int2) + (Max frac1 frac2)) in Fixed (f1R + f2R) sub (Fixed f1) (Fixed f2) =- let sh1 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac1)) :: Int+ let sh1 = natToNum @(Max frac1 frac2) - natToNum @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+ sh2 = natToNum @(Max frac1 frac2) - natToNum @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) =@@ -522,7 +522,7 @@ | a == 0 = 0 | a < 0 = -1 | otherwise = 1- fromInteger i = let fSH = fromInteger (natVal (Proxy @frac))+ fromInteger i = let fSH = natToNum @frac res = i `shiftL` fSH rMax = toInteger (maxBound :: rep (int + frac)) rMin = toInteger (minBound :: rep (int + frac))@@ -615,11 +615,11 @@ where fMin = minBound :: rep (int2 + frac2) fMax = maxBound :: rep (int2 + frac2)- argSZ = natVal (Proxy @(int1 + frac1))- resSZ = natVal (Proxy @(int2 + frac2))+ argSZ = natToInteger @(int1 + frac1)+ resSZ = natToInteger @(int2 + frac2) - argFracSZ = fromInteger (natVal (Proxy @frac1))- resFracSZ = fromInteger (natVal (Proxy @frac2))+ argFracSZ = natToNum @frac1+ resFracSZ = natToNum @frac2 -- All size and frac comparisons and related if-then-else statements should -- be optimized away by the compiler@@ -706,7 +706,7 @@ then rMin else truncated truncated = truncate shifted :: Integer- shifted = a * (2 ^ (natVal (Proxy @frac)))+ shifted = a * (2 ^ (natToInteger @frac)) -- | Convert, at run-time, a 'Double' to a 'Fixed'-point. --@@ -878,7 +878,7 @@ then rMin else truncated truncated = truncate shifted :: Integer- shifted = a * (2 ^ (natVal (Proxy @frac)))+ shifted = a * (2 ^ (natToInteger @frac)) instance NumFixedC rep int frac => SaturatingNum (Fixed rep int frac) where satAdd w (Fixed a) (Fixed b) = Fixed (satAdd w a b)@@ -886,13 +886,13 @@ satMul SatWrap (Fixed a) (Fixed b) = let res = a `mul` b- sh = fromInteger (natVal (Proxy @frac))+ sh = natToNum @frac res' = shiftR res sh in Fixed (resize res') satMul SatBound (Fixed a) (Fixed b) = let res = a `mul` b- sh = fromInteger (natVal (Proxy @frac))+ sh = natToNum @frac (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac)) in case isSigned a of True -> let overflow = complement (reduceOr (pack (msb rR) ++# pack rL)) .|.@@ -908,7 +908,7 @@ satMul SatZero (Fixed a) (Fixed b) = let res = a `mul` b- sh = fromInteger (natVal (Proxy @frac))+ sh = natToNum @frac (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac)) in case isSigned a of True -> let overflow = complement (reduceOr (pack (msb rR) ++# pack rL)) .|.@@ -922,7 +922,7 @@ satMul SatSymmetric (Fixed a) (Fixed b) = let res = a `mul` b- sh = fromInteger (natVal (Proxy @frac))+ sh = natToNum @frac (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac)) in case isSigned a of True -> let overflow = complement (reduceOr (pack (msb rR) ++# pack rL)) .|.@@ -935,6 +935,34 @@ False -> case rL of 0 -> unpack (resize (shiftR rR sh)) _ -> maxBound++ satSucc satMode f@(Fixed fRep) =+ let sh = natToNum @frac+ in case natToInteger @int of+ 0 -> case satMode of+ SatWrap -> f+ SatZero -> 0+ _ -> maxBound+ _ -> if isSigned fRep+ then satSub satMode f $ Fixed $ fromInteger $ (-1) `shiftL` sh+ else satAdd satMode f $ Fixed $ fromInteger $ 1 `shiftL` sh+ {-# INLINE satSucc #-}++ satPred satMode f@(Fixed fRep) =+ let sh = natToNum @frac+ symBound = if isSigned fRep+ then Fixed $ succ minBound+ else minBound+ in case natVal (Proxy @int) of+ 0 -> case satMode of+ SatWrap -> f+ SatBound -> minBound+ SatZero -> 0+ SatSymmetric -> symBound+ _ -> if isSigned fRep+ then satAdd satMode f $ Fixed $ fromInteger $ (-1) `shiftL` sh+ else satSub satMode f $ Fixed $ fromInteger $ 1 `shiftL` sh+ {-# INLINE satPred #-} -- | Constraint for the 'divide' function type DivideC rep int1 frac1 int2 frac2
src/Clash/Sized/Internal/BitVector.hs view
@@ -134,7 +134,7 @@ import GHC.Generics (Generic) import Data.Maybe (fromMaybe) import GHC.Exts- (Word#, Word (W#), eqWord#, int2Word#, uncheckedShiftRL#)+ ((>#), Word#, Word (W#), eqWord#, int2Word#, isTrue#, uncheckedShiftRL#) import qualified GHC.Exts import GHC.Integer.GMP.Internals (Integer (..), bigNatToWord, shiftRBigNat) import GHC.Natural@@ -169,6 +169,8 @@ import {-# SOURCE #-} qualified Clash.Sized.Internal.Index as I import qualified Data.List as L +#include "MachDeps.h"+ {- $setup >>> :set -XTemplateHaskell >>> :set -XBinaryLiterals@@ -736,7 +738,10 @@ (msbN v) where !(S# i#) = natVal (Proxy @n)- msbN (NatS# w) = W# (w `uncheckedShiftRL#` (i# GHC.Exts.-# 1#))+ msbN (NatS# w) =+ if isTrue# (i# ># WORD_SIZE_IN_BITS#)+ then W# 0##+ else W# (w `uncheckedShiftRL#` (i# GHC.Exts.-# 1#)) msbN (NatJ# bn) = W# (bigNatToWord (shiftRBigNat bn (i# GHC.Exts.-# 1#))) {-# NOINLINE lsb# #-}
src/Clash/Sized/Internal/Index.hs view
@@ -71,7 +71,6 @@ import Data.Bits (Bits (..), FiniteBits (..)) import Data.Data (Data) import Data.Default.Class (Default (..))-import Data.Proxy (Proxy (..)) import Text.Read (Read (..), ReadPrec) import Text.Printf (PrintfArg (..)) import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE)@@ -261,7 +260,7 @@ fromInteger_INLINE :: forall n . (HasCallStack, KnownNat n) => Integer -> Index n fromInteger_INLINE i = bound `seq` if i > (-1) && i < bound then I i else err where- bound = natVal (Proxy @n)+ bound = natToInteger @n err = errorX ("Clash.Sized.Index: result " ++ show i ++ " is out of bounds: [0.." ++ show (bound - 1) ++ "]") @@ -290,23 +289,23 @@ instance (KnownNat n, 1 <= n) => SaturatingNum (Index n) where satAdd SatWrap !a !b =- case snatToNum @Integer (SNat @n) of+ case natToInteger @n of 1 -> fromInteger# 0 _ -> leToPlusKN @1 @n $ case plus# a b of- z | let m = fromInteger# (natVal (Proxy @ n))+ z | let m = fromInteger# (natToInteger @n) , z >= m -> resize# (z - m) z -> resize# z satAdd SatZero a b = leToPlusKN @1 @n $ case plus# a b of- z | let m = fromInteger# (natVal (Proxy @ (n - 1)))+ z | let m = fromInteger# (natToInteger @(n - 1)) , z > m -> fromInteger# 0 z -> resize# z satAdd _ a b = leToPlusKN @1 @n $ case plus# a b of- z | let m = fromInteger# (natVal (Proxy @ (n - 1)))+ z | let m = fromInteger# (natToInteger @(n - 1)) , z > m -> maxBound# z -> resize# z @@ -321,24 +320,36 @@ else a -# b satMul SatWrap !a !b =- case snatToNum @Integer (SNat @n) of+ case natToInteger @n of 1 -> fromInteger# 0 _ -> leToPlusKN @1 @n $ case times# a b of- z -> let m = fromInteger# (natVal (Proxy @ n))+ z -> let m = fromInteger# (natToInteger @n) in resize# (z `mod` m) satMul SatZero a b = leToPlusKN @1 @n $ case times# a b of- z | let m = fromInteger# (natVal (Proxy @ (n - 1)))+ z | let m = fromInteger# (natToInteger @(n - 1)) , z > m -> fromInteger# 0 z -> resize# z satMul _ a b = leToPlusKN @1 @n $ case times# a b of- z | let m = fromInteger# (natVal (Proxy @ (n - 1)))+ z | let m = fromInteger# (natToInteger @(n - 1)) , z > m -> maxBound# z -> resize# z++ satSucc satMode !a =+ case natToInteger @n of+ 1 -> fromInteger# 0+ _ -> satAdd satMode a $ fromInteger# 1+ {-# INLINE satSucc #-}++ satPred satMode !a =+ case natToInteger @n of+ 1 -> fromInteger# 0+ _ -> satSub satMode a $ fromInteger# 1+ {-# INLINE satPred #-} instance KnownNat n => Real (Index n) where toRational = toRational . toInteger#
src/Clash/Sized/Internal/Signed.hs view
@@ -661,6 +661,11 @@ 0 -> maxBound# _ -> minBoundSym# + satSucc satMode a = satSub satMode a $ fromInteger# (-1)+ {-# INLINE satSucc #-}+ satPred satMode a = satAdd satMode a $ fromInteger# (-1)+ {-# INLINE satPred #-}+ minBoundSym# :: KnownNat n => Signed n minBoundSym# = minBound# +# fromInteger# 1
tests/Clash/Tests/BitVector.hs view
@@ -1,19 +1,51 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} -module Clash.Tests.BitVector where+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-} +module Clash.Tests.BitVector (tests, main) where++import qualified Hedgehog as H+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+ import Data.Proxy import GHC.TypeNats (KnownNat, SomeNat (..), natVal, someNatVal) import Test.Tasty import Test.Tasty.HUnit-import Test.Tasty.QuickCheck -import Clash.Prelude (bitPattern)+import qualified Test.Tasty.Hedgehog as H+import qualified Test.Tasty.QuickCheck as Q++import Clash.Prelude+ (Bit, high, low, bitPattern, type (<=), type (-), natToInteger, liftA2, msb) import Clash.Sized.Internal.BitVector (BitVector (..)) import Clash.Tests.SizedNum +-- | Generates a BitVector either with the MSB set or not, and checks whether+-- 'msb' agrees with it.+msbTest :: forall n. (1 <= n, KnownNat n) => H.Property+msbTest = H.property $ do+ (bv, b) <- H.forAll msbGen+ b H.=== msb bv+ where+ msbGen :: H.Gen (BitVector n, Bit)+ msbGen = Gen.choice+ [ liftA2 (,) msbSetGen (Gen.constant high)+ , liftA2 (,) msbUnsetGen (Gen.constant low) ]++ msbSetGen :: H.Gen (BitVector n)+ msbSetGen = Gen.integral (Range.linear (2^natToInteger @(n-1)) maxBound)++ msbUnsetGen :: H.Gen (BitVector n)+ msbUnsetGen = Gen.integral (Range.linear 0 (pred (2^natToInteger @(n-1))))+ test1 :: BitVector 8 -> Int test1 = \case@@ -25,7 +57,7 @@ _ -> 5 -- To keep exhaustiveness checker happy tests :: TestTree-tests = localOption (QuickCheckMaxRatio 2) $ testGroup "All"+tests = localOption (Q.QuickCheckMaxRatio 2) $ testGroup "All" [ testGroup "bitPattern" [ testCase "case0-0" $ test1 0b00000000 @?= 0@@ -39,19 +71,19 @@ , testCase "case3-2" $ test1 0b11010110 @?= 4 ] , testGroup "BitVector 1" $- testProperty "fromInteger"+ Q.testProperty "fromInteger" (fromIntegerProp (Proxy :: Proxy 1)) : map lawsToTest (laws1 (Proxy :: Proxy (BitVector 1))) , testGroup "BitVector 21" $- testProperty "fromInteger"+ Q.testProperty "fromInteger" (fromIntegerProp (Proxy :: Proxy 21)) : map lawsToTest (laws (Proxy :: Proxy (BitVector 21))) , testGroup "BitVector 83" $- testProperty "fromInteger"+ Q.testProperty "fromInteger" (fromIntegerProp (Proxy :: Proxy 83)) : map lawsToTest (laws (Proxy :: Proxy (BitVector 83))) , testGroup "Random BitVector"- [ testProperty "fromInteger" fromIntegerRandomProp ]+ [ Q.testProperty "fromInteger" fromIntegerRandomProp ] , testGroup "Enum" [ testCase "[4,3..]" $ [4,3..] @?= [4,3,2,1,0 :: BitVector 8] , testCase "[4,2..]" $ [4,2..] @?= [4,2,0 :: BitVector 8]@@ -63,14 +95,32 @@ [ testCase "maxBound :: BitVector 0" $ maxBound @(BitVector 0) @?= 0 , testCase "minBound :: BitVector 0" $ minBound @(BitVector 0) @?= 0 ]+ , testGroup "MSB"+ [ H.testProperty "msb @(BitVector 1)" (msbTest @1)+ , H.testProperty "msb @(BitVector 2)" (msbTest @2)+ , H.testProperty "msb @(BitVector 3)" (msbTest @3)+ , H.testProperty "msb @(BitVector 37)" (msbTest @37)+ , H.testProperty "msb @(BitVector 64)" (msbTest @64)+ , H.testProperty "msb @(BitVector 128)" (msbTest @128)+ , H.testProperty "msb @(BitVector 129)" (msbTest @129)+ ] ] -fromIntegerProp :: forall m. KnownNat m => Proxy m -> Integer -> Property-fromIntegerProp p n = unsafeToNatural m === fromInteger (n `mod` (2 ^ toInteger (natVal p)))+fromIntegerProp :: forall m. KnownNat m => Proxy m -> Integer -> Q.Property+fromIntegerProp p n = unsafeToNatural m Q.=== fromInteger (n `mod` (2 ^ toInteger (natVal p))) where m :: BitVector m m = fromInteger n -fromIntegerRandomProp :: Positive Integer -> Integer -> Property-fromIntegerRandomProp (Positive m) n = m > 1 ==> case someNatVal (fromInteger m) of+fromIntegerRandomProp :: Q.Positive Integer -> Integer -> Q.Property+fromIntegerRandomProp (Q.Positive m) n = m > 1 Q.==> case someNatVal (fromInteger m) of SomeNat p -> fromIntegerProp p n++-- Run with:+--+-- ./repld p:tests -T Clash.Tests.BitVector.main+--+-- Add -W if you want to run tests in spite of warnings+--+main :: IO ()+main = defaultMain tests
+ tests/Clash/Tests/Fixed.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Extra.Solver #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-}+{-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-}++module Clash.Tests.Fixed (tests) where++import Test.Tasty+import Test.Tasty.Hedgehog++import Clash.Class.Num+import Clash.Sized.Fixed (SFixed, UFixed)++import GHC.TypeLits (KnownNat)++import Hedgehog+import qualified Hedgehog.Range as Range+import qualified Hedgehog.Gen as Gen++-- Saturate a number to be within certain bounds according to SaturationMode.+saturate+ :: RealFrac a+ => a -- minBound+ -> a -- maxBound+ -> a -- repInt: the repetition interval of wrapping behaviour.+ -> SaturationMode+ -> a -> a+saturate minB _ repInt SatWrap x =+ let offs = x - minB+ offsW = minB + (offs - repInt * fromIntegral (floor @_ @Integer+ (offs / repInt)))+ in offsW+saturate minB maxB _ SatBound x+ | x < minB = minB+ | x > maxB = maxB+ | otherwise = x+saturate minB maxB _ SatZero x+ | x < minB = 0+ | x > maxB = 0+ | otherwise = x+saturate minB maxB _ SatSymmetric x+ | x < minB = if minB < 0 then (-maxB) else minB+ | x > maxB = maxB+ | otherwise = x++-- Saturate to bounds of type b.+--+-- It assumes the following values for the repetition interval:+-- - 2*(-minBound) when minBound < 0+-- - floor maxBound + 1 otherwise+-- This is correct for at least:+-- - Unsigned: maxBound @(Unsigned 4) == 15, behaves as modulo 16+-- - Signed: minBound @(Signed 4) == -8, behaves as shifted modulo 16+-- - UFixed: maxBound @(UFixed 4 2) == 15.75, behaves as modulo 16+-- - SFixed: minBound @(SFixed 4 m) == -8.0, behaves as shifted modulo 16+saturateToBounded+ :: forall b+ . (Bounded b, Real b)+ => SaturationMode+ -> Rational+ -> Rational+saturateToBounded satMode x =+ let repInt = if (minBound @b) < 0+ then 2 * negate (toRational (minBound @b))+ else 1 + toRational (floor @_ @Integer $ toRational $+ maxBound @b)+ in saturate (toRational (minBound @b)) (toRational (maxBound @b)) repInt+ satMode x+++satSuccProperty+ :: forall a+ . (SaturatingNum a, Real a, Show a)+ => Gen a+ -> Property+satSuccProperty genA = property $ do+ satMode <- forAll Gen.enumBounded+ a <- forAll genA+ toRational (satSucc satMode a) === (saturateToBounded @a satMode)+ (toRational a + 1)++satPredProperty+ :: forall a+ . (SaturatingNum a, Real a, Show a)+ => Gen a+ -> Property+satPredProperty genA = property $ do+ satMode <- forAll Gen.enumBounded+ a <- forAll genA+ toRational (satPred satMode a) === (saturateToBounded @a satMode)+ (toRational a - 1)++saturatingNumLaws+ :: (SaturatingNum a, Real a, Show a)+ => Gen a+ -> [TestTree]+saturatingNumLaws genA =+ [ testProperty "satSucc" $ satSuccProperty genA+ , testProperty "satPred" $ satPredProperty genA+ ]++testSaturationLaws+ :: (SaturatingNum a, Real a, Show a)+ => String+ -> Gen a+ -> TestTree+testSaturationLaws typeName genA = testGroup typeName (saturatingNumLaws genA)++-- | Generates a bounded fractional with a bias towards extreme values:+--+-- 10%: uniform [minBound, minBound + 1]+-- 10%: uniform [maxBound - 1, maxBound]+-- 5%: 0.0+-- 75%: uniform [minBound, maxBound]+--+genBoundedFractional :: forall a. (Real a, Fractional a, Bounded a) => Gen a+genBoundedFractional = Gen.frequency+ [ (10, fmap (fromRational . toRational)+ $ Gen.double+ $ fmap fromRational+ $ Range.linearFrac+ (toRational (minBound @a))+ (toRational (minBound @a) + 1))+ , (10, fmap (fromRational . toRational)+ $ Gen.double+ $ fmap fromRational+ $ Range.linearFrac+ (toRational (maxBound @a) - 1)+ (toRational (maxBound @a)))+ , (5, pure 0.0)+ , (75, fmap (fromRational . toRational)+ $ Gen.double+ $ fmap fromRational+ $ Range.linearFrac+ (toRational (minBound @a))+ (toRational (maxBound @a))) ]++genSFixed :: forall a b. (KnownNat a, KnownNat b) => Gen (SFixed a b)+genSFixed = genBoundedFractional++genUFixed :: forall a b. (KnownNat a, KnownNat b) => Gen (UFixed a b)+genUFixed = genBoundedFractional++tests :: TestTree+tests = testGroup "SaturatingNum"+ [ testSaturationLaws "SFixed 0 0" (genSFixed @0 @0)+ , testSaturationLaws "SFixed 0 1" (genSFixed @0 @1)+ , testSaturationLaws "SFixed 1 0" (genSFixed @1 @0)+ , testSaturationLaws "SFixed 1 1" (genSFixed @1 @1)+ , testSaturationLaws "SFixed 1 2" (genSFixed @1 @2)+ , testSaturationLaws "SFixed 2 1" (genSFixed @2 @1)+ , testSaturationLaws "SFixed 2 2" (genSFixed @2 @2)+ , testSaturationLaws "SFixed 128 128" (genSFixed @128 @128)++ , testSaturationLaws "UFixed 0 0" (genUFixed @0 @0)+ , testSaturationLaws "UFixed 0 1" (genUFixed @0 @1)+ , testSaturationLaws "UFixed 1 0" (genUFixed @1 @0)+ , testSaturationLaws "UFixed 1 1" (genUFixed @1 @1)+ , testSaturationLaws "UFixed 1 2" (genUFixed @1 @2)+ , testSaturationLaws "UFixed 2 1" (genUFixed @2 @1)+ , testSaturationLaws "UFixed 2 2" (genUFixed @2 @2)+ , testSaturationLaws "UFixed 128 128" (genUFixed @128 @128)+ ]
tests/Clash/Tests/Signal.hs view
@@ -13,8 +13,11 @@ module Clash.Tests.Signal where -import Clash.Signal+import Clash.Signal hiding (sample)+import Clash.Signal.Internal (sample) +import Control.Applicative (liftA2)+import Control.Exception (evaluate) import Data.List (isInfixOf) import Test.Tasty import Test.Tasty.HUnit@@ -155,6 +158,13 @@ , testCase "test5nok_0" (acte "withSpecificReset resetGen test5") #endif+ , testCase "T1521" $+ let+ f (_, b) = (b, b)+ s = f <$> liftA2 (,) (fst <$> s) (pure 'a')+ ((a,_):_) = sample @(Signal System) s+ in+ evaluate a >> pure () ] ]
tests/unittests.hs view
@@ -6,9 +6,10 @@ import qualified Clash.Tests.BitPack import qualified Clash.Tests.BitVector import qualified Clash.Tests.DerivingDataRepr+import qualified Clash.Tests.Fixed+import qualified Clash.Tests.NFDataX import qualified Clash.Tests.Signal import qualified Clash.Tests.Signed-import qualified Clash.Tests.NFDataX import qualified Clash.Tests.TopEntityGeneration import qualified Clash.Tests.Unsigned @@ -18,9 +19,10 @@ , Clash.Tests.BitPack.tests , Clash.Tests.BitVector.tests , Clash.Tests.DerivingDataRepr.tests+ , Clash.Tests.Fixed.tests+ , Clash.Tests.NFDataX.tests , Clash.Tests.Signal.tests , Clash.Tests.Signed.tests- , Clash.Tests.NFDataX.tests , Clash.Tests.TopEntityGeneration.tests , Clash.Tests.Unsigned.tests ]