diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 - - diff --git a/clash-prelude.cabal b/clash-prelude.cabal --- a/clash-prelude.cabal +++ b/clash-prelude.cabal @@ -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 diff --git a/src/Clash/Class/AutoReg/Internal.hs b/src/Clash/Class/AutoReg/Internal.hs --- a/src/Clash/Class/AutoReg/Internal.hs +++ b/src/Clash/Class/AutoReg/Internal.hs @@ -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 diff --git a/src/Clash/Class/Num.hs b/src/Clash/Class/Num.hs --- a/src/Clash/Class/Num.hs +++ b/src/Clash/Class/Num.hs @@ -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 diff --git a/src/Clash/Examples.hs b/src/Clash/Examples.hs --- a/src/Clash/Examples.hs +++ b/src/Clash/Examples.hs @@ -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 diff --git a/src/Clash/Explicit/Signal.hs b/src/Clash/Explicit/Signal.hs --- a/src/Clash/Explicit/Signal.hs +++ b/src/Clash/Explicit/Signal.hs @@ -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 diff --git a/src/Clash/Signal.hs b/src/Clash/Signal.hs --- a/src/Clash/Signal.hs +++ b/src/Clash/Signal.hs @@ -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)) diff --git a/src/Clash/Signal/Internal.hs b/src/Clash/Signal/Internal.hs --- a/src/Clash/Signal/Internal.hs +++ b/src/Clash/Signal/Internal.hs @@ -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 #-} diff --git a/src/Clash/Sized/Fixed.hs b/src/Clash/Sized/Fixed.hs --- a/src/Clash/Sized/Fixed.hs +++ b/src/Clash/Sized/Fixed.hs @@ -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 diff --git a/src/Clash/Sized/Internal/BitVector.hs b/src/Clash/Sized/Internal/BitVector.hs --- a/src/Clash/Sized/Internal/BitVector.hs +++ b/src/Clash/Sized/Internal/BitVector.hs @@ -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# #-} diff --git a/src/Clash/Sized/Internal/Index.hs b/src/Clash/Sized/Internal/Index.hs --- a/src/Clash/Sized/Internal/Index.hs +++ b/src/Clash/Sized/Internal/Index.hs @@ -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# diff --git a/src/Clash/Sized/Internal/Signed.hs b/src/Clash/Sized/Internal/Signed.hs --- a/src/Clash/Sized/Internal/Signed.hs +++ b/src/Clash/Sized/Internal/Signed.hs @@ -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 diff --git a/tests/Clash/Tests/BitVector.hs b/tests/Clash/Tests/BitVector.hs --- a/tests/Clash/Tests/BitVector.hs +++ b/tests/Clash/Tests/BitVector.hs @@ -1,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 diff --git a/tests/Clash/Tests/Fixed.hs b/tests/Clash/Tests/Fixed.hs new file mode 100644 --- /dev/null +++ b/tests/Clash/Tests/Fixed.hs @@ -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) + ] diff --git a/tests/Clash/Tests/Signal.hs b/tests/Clash/Tests/Signal.hs --- a/tests/Clash/Tests/Signal.hs +++ b/tests/Clash/Tests/Signal.hs @@ -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 () ] ] diff --git a/tests/unittests.hs b/tests/unittests.hs --- a/tests/unittests.hs +++ b/tests/unittests.hs @@ -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 ]