diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,33 @@ # Changelog for the Clash project +## 1.6.4 *Aug 30th 2022* +Fixed: + + * Input validation of the used arguments in blackboxes is now complete. [#2184](https://github.com/clash-lang/clash-compiler/pull/2184) + * `Clash.Annotations.BitRepresentation.Deriving.deriveAnnotation` no longer has quadratic complexity in the size of the constructors and fields. [#2209](https://github.com/clash-lang/clash-compiler/pull/2209) + * Fully resolve type synonyms when deriving bit representations. [#2209](https://github.com/clash-lang/clash-compiler/pull/2209) + * Disregard ticks when determining whether terms are shared. Fixes [#2233](https://github.com/clash-lang/clash-compiler/issues/2233). + * The blackbox parser will make sure it fully parses its input, and report an error when it can't. [#2237](https://github.com/clash-lang/clash-compiler/issues/2237) + * Wrap ~ARG[n] in parentheses. Fixes [#2213](https://github.com/clash-lang/clash-compiler/issues/2213) + * The VHDL shift primitives no longer generate bound check failures. Fixes [#2215](https://github.com/clash-lang/clash-compiler/issues/2215) + * Evaluator fails impredicative type instantiation of error values [#2272](https://github.com/clash-lang/clash-compiler/issues/2272) + * Fix out of bound errors in toEnum/fromSLV for sum types [#2220](https://github.com/clash-lang/clash-compiler/issues/2220) + * Netlist generation fails for certain uses of GADTs [#2289](https://github.com/clash-lang/clash-compiler/issues/2289) + * The documentation for `ANN TestBench` had it backwards; it now correctly indicates the annotation is on the test bench, not the device under test. [#1750](https://github.com/clash-lang/clash-compiler/issues/1750) + +Fixes with minor changes: + + * `reduceXor` now produces a result if the argument has undefined bits instead of throwing an `XException` (the result is an undefined bit). `reduceAnd` and `reduceOr` already always produced a result. [#2244](https://github.com/clash-lang/clash-compiler/pull/2244) + +Added: + + * Support for symbols in types while deriving bit representations. [#2209](https://github.com/clash-lang/clash-compiler/pull/2209) + * Support for promoted data types while deriving bit representations. [#2209](https://github.com/clash-lang/clash-compiler/pull/2209) + * `scanlPar` and `scanrPar` in Clash's Prelude, as well as the `RTree` versions `tscanl` and `tscanr`. These variants of `scanl1` and `scanr1` compile to a binary tree of operations, with a depth of `O(log(n))` (`n` being the length of the vector) rather than a depth of `n` for `scanl1` and `scanr1`. [#2177](https://github.com/clash-lang/clash-compiler/pull/2177) + * The GADT constructors for `RTree` (`RLeaf` and `RBranch`) are now exported directly in addition to the patterns `LR` and `BR`. [#2177](https://github.com/clash-lang/clash-compiler/pull/2177) + * Added the `~ISSCALAR` template which can be used to check if an argument is rendered to a scalar in HDL. [#2184](https://github.com/clash-lang/clash-compiler/pull/2184) + * Added support for records and infix constructors when using `Clash.Annotations.BitRepresentation.Deriving.deriveAnnotation`. [#2191](https://github.com/clash-lang/clash-compiler/pull/2191) + * Clash now contains instances for `ShowX`, `NFDataX` and `BitPack` on the newtypes from the Data.Functor modules (`Identity`, `Const`, `Compose`, `Product` and `Sum`). [#2218](https://github.com/clash-lang/clash-compiler/issues/2218) + ## 1.6.3 *Apr 7th 2022* Fixed: * Handle `~ISUNDEFINED` hole in black boxes for `BitVector` and for product types. This means that with `-fclash-aggressive-x-optimization-blackboxes`, resets are now omitted for _undefined_ reset values of such types as well. [#2117](https://github.com/clash-lang/clash-compiler/issues/2117) 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.6.3 +Version: 1.6.4 Synopsis: Clash: a functional hardware description language - Prelude library Description: Clash is a functional hardware description language that borrows both its @@ -334,7 +334,7 @@ hashable >= 1.2.1.0 && < 1.5, half >= 0.2.2.3 && < 1.0, interpolate >= 0.2 && < 0.3, - lens >= 4.10 && < 5.1.0, + lens >= 4.10 && < 5.2.0, recursion-schemes >= 5.1 && < 5.3, QuickCheck >= 2.7 && < 2.15, reflection >= 2 && < 2.2, diff --git a/doc/scanlPar.svg b/doc/scanlPar.svg new file mode 100644 --- /dev/null +++ b/doc/scanlPar.svg @@ -0,0 +1,122 @@ + + + + + + + + + + + + Canvas 1 + + + Layer 1 + + + + + + x0 + + + + + f + + + + + x1 + + + + + x2 + + + + + x3 + + + + + + + + + + + f + + + + + + + + + + + f + + + + + + + + + + + + + + + + + + + + f + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/Clash/Annotations/BitRepresentation/Deriving.hs b/src/Clash/Annotations/BitRepresentation/Deriving.hs --- a/src/Clash/Annotations/BitRepresentation/Deriving.hs +++ b/src/Clash/Annotations/BitRepresentation/Deriving.hs @@ -1,6 +1,7 @@ {-| Copyright : (C) 2018, Google Inc., 2022, QBayLogic B.V. + 2022, LUMI GUIDE FIETSDETECTIE B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -59,32 +60,35 @@ import qualified Clash.Annotations.BitRepresentation.Util as Util -import Clash.Annotations.Primitive (hasBlackBox) +import Clash.Annotations.Primitive (hasBlackBox) import Clash.Class.BitPack (BitPack, BitSize, pack, packXWith, unpack) -import Clash.Class.Resize (resize) -import Language.Haskell.TH.Compat (mkTySynInstD) -import Clash.Sized.BitVector (BitVector, low, (++#)) +import Clash.Class.Resize (resize) +import Language.Haskell.TH.Compat (mkTySynInstD) +import Clash.Sized.BitVector (BitVector, low, (++#)) import Clash.Sized.Internal.BitVector (undefined#) -import Control.DeepSeq (NFData) -import Control.Monad (forM) +import Control.Applicative (liftA3) +import Control.DeepSeq (NFData) +import Control.Monad (forM) import Data.Bits (shiftL, shiftR, complement, (.&.), (.|.), zeroBits, popCount, bit, testBit, Bits, setBit) -import Data.Data (Data) +import Data.Data (Data) +import Data.Containers.ListUtils (nubOrd) import Data.List (mapAccumL, zipWith4, sortOn, partition) -import Data.Typeable (Typeable) -import qualified Data.Map as Map -import Data.Maybe (fromMaybe) -import qualified Data.Set as Set -import Data.Proxy (Proxy(..)) -import GHC.Exts (Int(I#)) -import GHC.Generics (Generic) -import GHC.Integer.Logarithms (integerLog2#) -import GHC.TypeLits (natVal) +import Data.Typeable (Typeable) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set +import Data.Proxy (Proxy(..)) +import GHC.Exts (Int(I#)) +import GHC.Generics (Generic) +import GHC.Integer.Logarithms (integerLog2#) +import GHC.TypeLits (natVal) import Language.Haskell.TH import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Datatype (resolveTypeSynonyms) -- | Used to track constructor bits in packed derivation data BitMaskOrigin @@ -183,6 +187,10 @@ resolveCon :: NameMap -> Con -> Con resolveCon nmap (NormalC t (unzip -> (bangs, fTypes))) = NormalC t $ zip bangs $ map (resolve nmap) fTypes +resolveCon nmap (RecC t (unzip3 -> (name, bangs, fTypes))) = + RecC t $ zip3 name bangs $ map (resolve nmap) fTypes +resolveCon nmap (InfixC (leftB, leftTy) t (rightB, rightTy)) = + InfixC (leftB, resolve nmap leftTy) t (rightB, resolve nmap rightTy) resolveCon _name constr = error $ "Unexpected constructor: " ++ show constr @@ -248,12 +256,24 @@ InfixC _ nm _ -> nm _ -> error $ "No GADT support" -constrFieldSizes - :: Con - -> (Name, [Q Exp]) -constrFieldSizes con = do - (conName con, map typeSize $ fieldTypes con) +mkLet :: String -> Q Exp -> (Q Dec, Q Exp) +mkLet nm qe = do + let nm' = mkName nm + (valD (varP nm') (normalB qe) [], varE nm') +fieldSizeLets :: [[Type]] -> ([Q Dec], [[Q Exp]]) +fieldSizeLets fieldtypess = (fieldSizeDecls, fieldSizessExps) + where + nums = map show [(0 :: Int)..] + uqFieldTypes = nubOrd (concat fieldtypess) + uqFieldSizes = map typeSize uqFieldTypes + (fieldSizeDecls, szVars) = unzip $ zipWith + (\i sz -> mkLet ("_f" ++ i) sz) + nums + uqFieldSizes + tySizeMap = Map.fromList (zip uqFieldTypes szVars) + fieldSizessExps = map (map (tySizeMap Map.!)) fieldtypess + complementInteger :: Int -> Integer -> Integer complementInteger 0 _i = 0 complementInteger size i = @@ -304,59 +324,82 @@ where values = [shiftL 1 n | n <- ns] -overlapFieldAnnsL :: [[Q Exp]] -> [[Q Exp]] -overlapFieldAnnsL fieldSizess = map go fieldSizess +overlapFieldAnnsL :: [[Q Exp]] -> ([Q Dec], [[Q Exp]]) +overlapFieldAnnsL fieldSizess = ([maxDecl], resExp) where - fieldSizess' = listE $ map listE fieldSizess - constructorSizes = [| map sum $fieldSizess' |] - go fieldSizes = + (maxDecl, maxExp) = mkLet "_maxf" maxConstrSize + resExp = map go fieldSizess + fieldSizess' = listE $ map listE fieldSizess + constructorSizes = [| map (sum @[] @Int) $fieldSizess' |] + maxConstrSize = [| maximum $constructorSizes - 1 |] + go fieldsizes = snd $ mapAccumL (\start size -> ([| $start - $size |], [| bitmask $start $size |])) - [| maximum $constructorSizes - 1 |] - fieldSizes + maxExp + fieldsizes -overlapFieldAnnsR :: [[Q Exp]] -> [[Q Exp]] -overlapFieldAnnsR fieldSizess = map go fieldSizess +overlapFieldAnnsR :: [[Q Exp]] -> ([Q Dec], [[Q Exp]]) +overlapFieldAnnsR fieldSizess = (sumFieldDecl, resExp) where - fieldSizess' = listE $ map listE fieldSizess - constructorSizes = [| map sum $fieldSizess' |] - go fieldSizes = + resExp = zipWith go fieldSizess sumFieldExp + + nums = map show [(0 :: Int) ..] + + (sumFieldDecl, sumFieldExp) + = unzip $ zipWith + (\fs i -> mkLet ("_sumf" ++ i) [|sum @[] @Int $(listE fs)|]) + fieldSizess + nums + + go fieldSizes sumFieldsSize = snd $ mapAccumL (\start size -> ([| $start - $size |], [| bitmask $start $size |])) - [| maximum $constructorSizes - (maximum $constructorSizes - sum $(listE fieldSizes)) - 1 |] + [| $sumFieldsSize - 1 |] fieldSizes -wideFieldAnns :: [[Q Exp]] -> [[Q Exp]] -wideFieldAnns fieldSizess = zipWith id (map go constructorOffsets) fieldSizess +wideFieldAnns :: [[Q Exp]] -> ([Q Dec], [[Q Exp]]) +wideFieldAnns fieldSizess = (decs, resExp) where - constructorSizes = - map (AppE (VarE 'sum) <$>) (map listE fieldSizess) + decs = (dataSizeDec:constrSizeDecs) ++ constrOffsetDecs + resExp = zipWith id (map go constrOffsetsExps) fieldSizess + nums = map show [(0 :: Int) ..] - constructorOffsets :: [Q Exp] - constructorOffsets = - init $ - scanl - (\offset size -> [| $offset + $size |]) - [| 0 |] - constructorSizes + constrSizeExps :: [Q Exp] + (constrSizeDecs, constrSizeExps) + = unzip $ zipWith + (\fs i -> mkLet ("_sumf" ++ i) [|sum @[] @Int $(listE fs)|]) + fieldSizess + nums - dataSize = [| sum $(listE constructorSizes) |] + constrOffsetsExps :: [Q Exp] + (last -> constrOffsetDecs, constrOffsetsExps) = + unzip $ init $ scanl + (\(ds, offset) (size, i) -> + let e = [| $offset + $size |] + (d, ve) = mkLet ("_constroffset" ++ i) e + in (d:ds, ve) + ) + ([], [| 0 |]) + (zip constrSizeExps nums) + dataSizeExp :: Q Exp + (dataSizeDec, dataSizeExp) + = mkLet "_widedatasize" [| sum @[] @Int $(listE constrSizeExps) - 1 |] go :: Q Exp -> [Q Exp] -> [Q Exp] go offset fieldSizes = snd $ mapAccumL (\start size -> ([| $start - $size |], [| bitmask $start $size |])) - [| $dataSize - 1 - $offset |] + [| $dataSizeExp - $offset |] fieldSizes -- | Derive DataRepr' for a specific type. deriveDataRepr :: ([Int] -> [(BitMask, Value)]) -- ^ Constructor derivator - -> ([[Q Exp]] -> [[Q Exp]]) + -> ([[Q Exp]] -> ([Q Dec], [[Q Exp]]) ) -- ^ Field derivator -> Derivator deriveDataRepr constrDerivator fieldsDerivator typ = do @@ -365,34 +408,54 @@ (TyConI (DataD [] _constrName vars _kind dConstructors _clauses)) -> let varMap = Map.fromList $ zip (map tyVarBndrName vars) typeArgs in let resolvedConstructors = map (resolveCon varMap) dConstructors in do + let nums = map show [(0 :: Int)..] + let fieldtypess = map fieldTypes resolvedConstructors + let (fieldSzDecs, fieldSizess) = fieldSizeLets fieldtypess + -- Get sizes and names of all constructors - let - (constrNames, fieldSizess) = - unzip $ map constrFieldSizes resolvedConstructors + let constrNames = map conName resolvedConstructors let (constrMasks, constrValues) = unzip $ constrDerivator [0..length dConstructors - 1] - let constrSize = 1 + (msb $ maximum constrMasks) - let fieldAnns = fieldsDerivator fieldSizess - let fieldAnnsFlat = listE $ concat fieldAnns + let constrSize = 1 + (msb $ maximum @[] @Integer constrMasks) + let (fieldDecs, fieldAnns) = fieldsDerivator fieldSizess + -- extract field annotations into declarations + let mkAnnDecl i j an = mkLet ("_fa" ++ i ++ "_" ++ j) an + let + fieldAnnTup = + zipWith (\i -> zipWith (mkAnnDecl i) nums) nums fieldAnns + + let + (fieldAnnDecs, fieldAnnVars) = + (concat $ map (map fst) fieldAnnTup, map (map snd) fieldAnnTup) + + let fieldAnnsFlat = listE $ concat fieldAnnVars + let dataSize | null $ concat fieldAnns = [| 0 |] - | otherwise = [| 1 + (msb $ maximum $ $fieldAnnsFlat) |] + | otherwise = [| 1 + (msb $ maximum @[] @Integer $ $fieldAnnsFlat) |] + -- Extract data size into a declaration + let (dataSizeDec, dataSizeExp) = mkLet "_datasize" dataSize + + let decls = (dataSizeDec:fieldSzDecs) ++ fieldDecs ++ fieldAnnDecs + -- Determine at which bits various fields start let constrReprs = zipWith4 - (buildConstrRepr dataSize) + (buildConstrRepr dataSizeExp) constrNames - fieldAnns + fieldAnnVars constrMasks constrValues - [| DataReprAnn - $(liftQ $ return typ) - ($dataSize + constrSize) + resolvedType <- resolveTypeSynonyms typ + + letE decls [| DataReprAnn + $(liftQ $ return resolvedType) + ($dataSizeExp + constrSize) $(listE constrReprs) |] _ -> fail $ "Could not derive dataRepr for: " ++ show info @@ -722,8 +785,11 @@ collectDataReprs :: Q [DataReprAnn] collectDataReprs = do thisMod <- thisModule - go [thisMod] Set.empty [] + unresolved <- go [thisMod] Set.empty [] + mapM resolveTyps unresolved where + resolveTyps (DataReprAnn t s c) + = liftA3 DataReprAnn (resolveTypeSynonyms t) (pure s) (pure c) go [] _visited acc = return acc go (x:xs) visited acc | x `Set.member` visited = go xs visited acc @@ -924,8 +990,9 @@ deriveBitPack typQ = do anns <- collectDataReprs typ <- typQ + rTyp <- resolveTypeSynonyms typ - ann <- case filter (\(DataReprAnn t _ _) -> t == typ) anns of + ann <- case filter (\(DataReprAnn t _ _) -> t == rTyp) anns of [a] -> return a [] -> fail "No custom bit annotation found." _ -> fail "Overlapping bit annotations found." diff --git a/src/Clash/Annotations/BitRepresentation/Internal.hs b/src/Clash/Annotations/BitRepresentation/Internal.hs --- a/src/Clash/Annotations/BitRepresentation/Internal.hs +++ b/src/Clash/Annotations/BitRepresentation/Internal.hs @@ -1,5 +1,6 @@ {-| Copyright : (C) 2018, Google Inc. + 2022, LUMI GUIDE FIETSDETECTIE B.V. License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij -} @@ -44,6 +45,8 @@ -- ^ Qualified name of type | LitTy' Integer -- ^ Numeral literal (used in BitVector 10, for example) + | SymLitTy' Text.Text + -- ^ Symbol literal (used in for example (Signal "System" Int)) deriving (Generic, NFData, Eq, Typeable, Hashable, Ord, Show) -- | Internal version of DataRepr @@ -90,8 +93,10 @@ thTypeToType' ty = go ty where go (TH.ConT name') = ConstTy' (thToText name') + go (TH.PromotedT name') = ConstTy' (thToText name') go (TH.AppT ty1 ty2) = AppTy' (go ty1) (go ty2) go (TH.LitT (TH.NumTyLit n)) = LitTy' n + go (TH.LitT (TH.StrTyLit lit)) = SymLitTy' (Text.pack lit) go _ = error $ "Unsupported type: " ++ show ty -- | Convenience type for index built by buildCustomReprs diff --git a/src/Clash/Annotations/TH.hs b/src/Clash/Annotations/TH.hs --- a/src/Clash/Annotations/TH.hs +++ b/src/Clash/Annotations/TH.hs @@ -151,7 +151,7 @@ errorContext :: Tracked Q String errorContext = asks snd --- | Failure message with prefix in a 'Tracked' context +-- Failure message with prefix in a 'Tracked' context failMsgWithContext :: String -> Tracked Q String failMsgWithContext s = (++) (failMsg s) <$> errorContext @@ -402,7 +402,7 @@ gatherNames = para typeTreeToPorts . guardPorts --- | Build a possible failing 'PortName' tree and unwrap the 'Naming' result. +-- Build a possible failing 'PortName' tree and unwrap the 'Naming' result. buildPorts :: Type -- ^ Type to investigate diff --git a/src/Clash/Annotations/TopEntity.hs b/src/Clash/Annotations/TopEntity.hs --- a/src/Clash/Annotations/TopEntity.hs +++ b/src/Clash/Annotations/TopEntity.hs @@ -1,7 +1,7 @@ {-| Copyright : (C) 2015-2016, University of Twente, 2017 , Google Inc., - 2021 , QBayLogic B.V. + 2021-2022, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -206,21 +206,25 @@ === 'TestBench' annotation -Tell what binder is the 'TestBench' for a 'Synthesize'-annotated binder. - -So in the following example, /f/ has a 'Synthesize' annotation, and /g/ is -the HDL test bench for /f/. +Tell what binder is the test bench for a 'Synthesize'-annotated binder. @ -f :: Bool -> Bool -f = ... -{\-\# ANN f (defSyn "f") \#-\} -{\-\# ANN f (TestBench \'g) \#-\} +entityBeingTested :: ... +entityBeingTested = ... +{\-\# NOINLINE entityBeingTested \#-\} +{\-\# ANN entityBeingTested (defSyn "entityBeingTested") \#-\} -g :: Signal Bool -g = ... + +myTestBench :: Signal System Bool +myTestBench = ... entityBeingTested ... +{\-\# NOINLINE myTestBench \#-\} +{\-\# ANN myTestBench (TestBench \'entityBeingTested) \#-\} @ +The 'TestBench' annotation actually already implies a 'Synthesize' annotation on +the device under test, so the 'defSyn' in the example could have been omitted. +We recommend you supply 'defSyn' explicitly nonetheless. In any case, it will +still need the @NOINLINE@ annotation. -} {-# LANGUAGE CPP #-} @@ -266,17 +270,9 @@ } -- | Tell what binder is the 'TestBench' for a 'Synthesize'-annotated binder. -- - -- So in the following example, /f/ has a 'Synthesize' annotation, and /g/ is - -- the HDL test bench for /f/. - -- -- @ - -- f :: Bool -> Bool - -- f = ... - -- {\-\# ANN f (defSyn "f") \#-\} - -- {\-\# ANN f (TestBench \'g) \#-\} - -- - -- g :: Signal Bool - -- g = ... + -- {\-\# NOINLINE myTestBench \#-\} + -- {\-\# ANN myTestBench (TestBench \'entityBeingTested) \#-\} -- @ | TestBench TH.Name deriving (Eq,Data,Show,Generic) diff --git a/src/Clash/Class/BitPack/Internal.hs b/src/Clash/Class/BitPack/Internal.hs --- a/src/Clash/Class/BitPack/Internal.hs +++ b/src/Clash/Class/BitPack/Internal.hs @@ -1,7 +1,7 @@ {-| Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd, - 2021, QBayLogic B.V., + 2021-2022 QBayLogic B.V., 2022, Google Inc. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -31,6 +31,11 @@ wordToFloat) import Data.Complex (Complex) +import Data.Functor.Compose (Compose) +import Data.Functor.Const (Const) +import Data.Functor.Identity (Identity) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) import Data.Int import Data.Ord (Down) import Data.Word @@ -449,6 +454,12 @@ instance BitPack a => BitPack (Complex a) instance BitPack a => BitPack (Down a) +instance BitPack a => BitPack (Identity a) +instance BitPack a => BitPack (Const a b) +instance (BitPack (f a), BitPack (g a)) => BitPack (Product f g a) +instance (BitPack (f a), BitPack (g a)) => BitPack (Sum f g a) +instance BitPack (f (g a)) => BitPack (Compose f g a) + -- | Zero-extend a 'Bool'ean value to a 'BitVector' of the appropriate size. -- -- >>> boolToBV True :: BitVector 6 @@ -462,7 +473,7 @@ boolToBit :: Bool -> Bit boolToBit = bitCoerce --- | Convert a Bool to a Bit +-- | Convert a Bit to a Bool bitToBool :: Bit -> Bool bitToBool = bitCoerce diff --git a/src/Clash/Promoted/Nat.hs b/src/Clash/Promoted/Nat.hs --- a/src/Clash/Promoted/Nat.hs +++ b/src/Clash/Promoted/Nat.hs @@ -328,6 +328,8 @@ SNatLE :: forall a b . a <= b => SNatLE a b SNatGT :: forall a b . (b+1) <= a => SNatLE a b +deriving instance Show (SNatLE a b) + -- | Get an ordering relation between two SNats compareSNat :: forall a b . SNat a -> SNat b -> SNatLE a b compareSNat a b = diff --git a/src/Clash/Signal.hs b/src/Clash/Signal.hs --- a/src/Clash/Signal.hs +++ b/src/Clash/Signal.hs @@ -1304,6 +1304,7 @@ -- See Note [Going from WithSingleDomain to WithSpecificDomain] {-# INLINE andEnable #-} +#ifdef CLASH_MULTIPLE_HIDDEN {- | Merge enable signal with signal of bools by applying the boolean AND operation. @@ -1320,7 +1321,6 @@ <#hiddenclockandreset Click here to read more about hidden clocks, resets, and enables> -#ifdef CLASH_MULTIPLE_HIDDEN === __Example__ 'andSpecificEnable' can only be used when it can find the specified domain in /r/: @@ -1336,8 +1336,8 @@ reg = 'register' @@dom 5 (reg + 1) f en = 'andSpecificEnable' @@dom en reg @ -#endif -} +#endif andSpecificEnable :: forall dom r . ( HiddenEnable dom 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 @@ -847,21 +847,33 @@ sz = natVal bv maxI = (2 ^ sz) - 1 -reduceAnd# bv = V.foldl (.&.) 1 (V.bv2v bv) +reduceAnd# bv@(BV m i) = + -- If any defined bit is 0, i.e., 'm .|. i /= maxI', then the result is + -- '0' (Bit 0 0), otherwise the result is '.' (Bit 1 0). + Bit (W# (int2Word# (dataToTag# check))) 0 + where + check = m .|. i == maxI + sz = natVal bv + maxI = (2 ^ sz) - 1 + {-# NOINLINE reduceOr# #-} {-# ANN reduceOr# hasBlackBox #-} reduceOr# :: KnownNat n => BitVector n -> Bit reduceOr# (BV 0 i) = Bit 0 (W# (int2Word# (dataToTag# check))) where check = i /= 0 -reduceOr# bv = V.foldl (.|.) 0 (V.bv2v bv) +reduceOr# bv@(BV m i) | defI /= 0 = Bit 0 1 + | otherwise = Bit 1 0 + where + complementN = complementMod $ natVal bv + defI = i .&. (complementN m) {-# NOINLINE reduceXor# #-} {-# ANN reduceXor# hasBlackBox #-} reduceXor# :: KnownNat n => BitVector n -> Bit reduceXor# (BV 0 i) = Bit 0 (fromIntegral (popCount i `mod` 2)) -reduceXor# bv = undefErrorU "reduceXor" bv +reduceXor# _ = Bit 1 0 instance Default (BitVector n) where def = minBound# diff --git a/src/Clash/Sized/Internal/Unsigned.hs b/src/Clash/Sized/Internal/Unsigned.hs --- a/src/Clash/Sized/Internal/Unsigned.hs +++ b/src/Clash/Sized/Internal/Unsigned.hs @@ -194,7 +194,7 @@ -- width, use the functions in the 'Clash.Class.Resize.Resize' class. #if MIN_VERSION_base(4,15,0) data Unsigned (n :: Nat) = - -- | The constructor, 'U', and the field, 'unsafeToInteger', are not + -- | The constructor, 'U', and the field, 'unsafeToNatural', are not -- synthesizable. U { unsafeToNatural :: !Natural } #else diff --git a/src/Clash/Sized/RTree.hs b/src/Clash/Sized/RTree.hs --- a/src/Clash/Sized/RTree.hs +++ b/src/Clash/Sized/RTree.hs @@ -19,11 +19,13 @@ module Clash.Sized.RTree ( -- * 'RTree' data type - RTree (LR, BR) + RTree (LR, BR, RLeaf, RBranch) -- * Construction , treplicate , trepeat -- * Accessors + , thead + , tlast -- ** Indexing , indexTree , tindices @@ -41,6 +43,12 @@ , tfold -- ** Specialised folds , tdfold + -- ** Prefix sums (scans) + -- $scans + , scanlPar + , tscanl + , scanrPar + , tscanr -- * Conversions , v2t , t2v @@ -63,13 +71,13 @@ #if MIN_VERSION_template_haskell(2,16,0) import Language.Haskell.TH.Compat #endif -import Prelude hiding ((++), (!!)) +import Prelude hiding ((++), (!!), map) import Test.QuickCheck (Arbitrary (..), CoArbitrary (..)) import Clash.Annotations.Primitive (hasBlackBox) import Clash.Class.BitPack (BitPack (..), packXWith) -import Clash.Promoted.Nat (SNat (..), UNat (..), pow2SNat, snatToNum, - subSNat, toUNat) +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) @@ -105,26 +113,26 @@ -- * Only has elements at the leaf of the tree -- * A tree of depth /d/ has /2^d/ elements. data RTree :: Nat -> Type -> Type where - LR_ :: a -> RTree 0 a - BR_ :: RTree d a -> RTree d a -> RTree (d+1) a + RLeaf :: a -> RTree 0 a + RBranch :: RTree d a -> RTree d a -> RTree (d+1) a instance NFData a => NFData (RTree d a) where - rnf (LR_ x) = rnf x - rnf (BR_ l r ) = rnf l `seq` rnf r + rnf (RLeaf x) = rnf x + rnf (RBranch l r ) = rnf l `seq` rnf r textract :: RTree 0 a -> a -textract (LR_ x) = x -textract (BR_ _ _) = error $ "textract: nodes hold no values" +textract (RLeaf x) = x +textract (RBranch _ _) = error $ "textract: nodes hold no values" {-# NOINLINE textract #-} {-# ANN textract hasBlackBox #-} tsplit :: RTree (d+1) a -> (RTree d a,RTree d a) -tsplit (BR_ l r) = (l,r) -tsplit (LR_ _) = error $ "tsplit: leaf is atomic" +tsplit (RBranch l r) = (l,r) +tsplit (RLeaf _) = error $ "tsplit: leaf is atomic" {-# NOINLINE tsplit #-} {-# ANN tsplit hasBlackBox #-} --- | Leaf of a perfect depth tree +-- | RLeaf of a perfect depth tree -- -- >>> LR 1 -- 1 @@ -142,9 +150,9 @@ pattern LR :: a -> RTree 0 a pattern LR x <- (textract -> x) where - LR x = LR_ x + LR x = RLeaf x --- | Branch of a perfect depth tree +-- | RBranch of a perfect depth tree -- -- >>> BR (LR 1) (LR 2) -- <1,2> @@ -162,7 +170,7 @@ 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 + BR l r = RBranch l r instance (KnownNat d, Eq a) => Eq (RTree d a) where (==) t1 t2 = (==) (t2v t1) (t2v t2) @@ -171,15 +179,15 @@ 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)) + showsPrec _ (RLeaf a) = shows a + showsPrec _ (RBranch 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)) + go _ (RLeaf a) = showsX a + go _ (RBranch l r) = \s -> '<':showsX l (',':showsX r ('>':s)) instance KnownNat d => Functor (RTree d) where fmap = tmap @@ -215,8 +223,8 @@ 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) |] + lift (RLeaf a) = [| RLeaf a |] + lift (RBranch t1 t2) = [| RBranch $(lift t1) $(lift t2) |] #if MIN_VERSION_template_haskell(2,16,0) liftTyped = liftTypedFromUntyped #endif @@ -234,14 +242,14 @@ rnfX t = if isLeft (isX t) then () else go t where go :: RTree d a -> () - go (LR_ x) = rnfX x - go (BR_ l r) = rnfX l `seq` rnfX r + go (RLeaf x) = rnfX x + go (RBranch l r) = rnfX l `seq` rnfX r hasUndefined t = if isLeft (isX t) then True else go t where go :: RTree d a -> Bool - go (LR_ x) = hasUndefined x - go (BR_ l r) = hasUndefined l || hasUndefined r + go (RLeaf x) = hasUndefined x + go (RBranch l r) = hasUndefined l || hasUndefined r ensureSpine = fmap ensureSpine . lazyT @@ -370,8 +378,8 @@ 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 + go _ (RLeaf a) = f a + go sn (RBranch l r) = let sn' = sn `subSNat` d1 in g sn' (go sn' l) (go sn' r) {-# NOINLINE tdfold #-} {-# ANN tdfold hasBlackBox #-} @@ -439,9 +447,7 @@ -- | Convert a vector with /2^d/ elements to a tree of depth /d/. -- --- >>> (1:>2:>3:>4:>Nil) --- 1 :> 2 :> 3 :> 4 :> Nil --- >>> v2t (1:>2:>3:>4:>Nil) +-- >>> 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) @@ -537,3 +543,126 @@ => RTree d a -> RTree d a lazyT = tzipWith (flip const) (trepeat ()) + +-- | Extract the first element of a tree +-- +-- The first element is defined to be the bottom-left leaf. +-- +-- >>> thead $ BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4)) +-- 1 +thead :: RTree n a -> a +thead (RLeaf x) = x +thead (RBranch x _) = thead x + +-- | Extract the last element of a tree +-- +-- The last element is defined to be the bottom-right leaf. +-- +-- >>> tlast $ BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4)) +-- 4 +tlast :: RTree n a -> a +tlast (RLeaf x) = x +tlast (RBranch _ y) = tlast y + +{- $scans #scans# + +Scans (`Clash.Sized.Vector.scanl`, `Clash.Sized.Vector.scanr`) are similar to +folds (`Clash.Sized.Vector.foldl`, `Clash.Sized.Vector.foldr`) but return a list +of successive reduced values. When the binary reduction operator @f@ is +associative, the scan functions in this module can be characterized as follows: + +> tscanl f [x1, x2, x3, ...] == [x1, x1 `f` x2, x1 `f` x2 `f` x3, ...] + +> tscanr f [..., xn2, xn1, xn] == [..., xn2 `f` xn1 `f` xn, xn1 `f` xn, xn] + +The scan functions in this module provide a different trade-off between circuit +size and logic depth than the default `Clash.Sized.Vector.scanl` and +`Clash.Sized.Vector.scanr` functions. When \(n\) is the number of elements, +circuit size is \(\mathcal{O}(n \cdot \log n)\), but logic depth is \(\mathcal{O}(\log n)\). +This means the resource usage will likely increase, but the maximum clock +frequency also increases due to the reduced logic depth. The exact amount of +instantiations of @f@ given a tree of depth /d/ is: + +> work 0 = 0 +> work d = 2 ^ (d - 1) + 2 * work (d - 1) + +-} + +-- | `tscanl` applied to `Vec` +-- +-- >>> scanlPar (+) (1 :> 2 :> 3 :> 4 :> Nil) +-- 1 :> 3 :> 6 :> 10 :> Nil +scanlPar :: + KnownNat n => + -- | Must be associative + (a -> a -> a) -> + Vec (2^n) a -> + Vec (2^n) a +scanlPar op = t2v . tscanl op . v2t +{-# INLINE scanlPar #-} + +-- | `tscanr` applied to `Vec` +-- +-- >>> scanrPar (+) (1 :> 2 :> 3 :> 4 :> Nil) +-- 10 :> 9 :> 7 :> 4 :> Nil +scanrPar :: + KnownNat n => + -- | Must be associative + (a -> a -> a) -> + Vec (2^n) a -> + Vec (2^n) a +scanrPar op = t2v . tscanr op . v2t +{-# INLINE scanrPar #-} + +-- | Low-depth left scan +-- +-- `tscanl` is similar to `Clash.Sized.Vector.foldl`, but returns a tree of +-- successive reduced values from the left: +-- +-- > tscanl f [x1, x2, x3, ...] == [x1, x1 `f` x2, x1 `f` x2 `f` x3, ...] +-- +-- >>> tscanl (+) (v2t (1 :> 2 :> 3 :> 4 :> Nil)) +-- <<1,3>,<6,10>> +-- +-- <> +tscanl :: + forall a n. + KnownNat n => + -- | Must be associative + (a -> a -> a) -> + RTree n a -> + RTree n a +tscanl op tr = + case tr of + RLeaf x -> LR x + RBranch x y -> + let + x' = tscanl op x + y' = tscanl op y + l = tlast x' + in BR x' (fmap (l `op`) y') + +-- | Low-depth right scan +-- +-- `tscanr` is similar to `Clash.Sized.Vector.foldr`, but returns a tree of +-- successive reduced values from the left: +-- +-- > tscanr f [..., xn2, xn1, xn] == [..., xn2 `f` xn1 `f` xn, xn1 `f` xn, xn] +-- +-- >>> tscanr (+) (v2t (1 :> 2 :> 3 :> 4 :> Nil)) +-- <<10,9>,<7,4>> +tscanr :: + forall a n. + KnownNat n => + (a -> a -> a) -> + RTree n a -> + RTree n a +tscanr op tr = + case tr of + RLeaf x -> LR x + RBranch x y -> + let + x' = tscanr op x + y' = tscanr op y + l = thead y' + in BR (fmap (l `op`) x') y' diff --git a/src/Clash/Sized/Vector.hs b/src/Clash/Sized/Vector.hs --- a/src/Clash/Sized/Vector.hs +++ b/src/Clash/Sized/Vector.hs @@ -1102,9 +1102,12 @@ -- -- <> -- --- __NB__: +-- * __NB__: -- --- > last (scanl f z xs) == foldl f z xs +-- > last (scanl f z xs) == foldl f z xs +-- +-- * For a different trade-off between circuit size and logic depth for +-- associative operators, see "Clash.Sized.RTree#scans" scanl :: (b -> a -> b) -> b -> Vec n a -> Vec (n + 1) b scanl f z xs = ws where @@ -1137,9 +1140,12 @@ -- -- <> -- --- __NB__: +-- * __NB__: -- --- > head (scanr f z xs) == foldr f z xs +-- > head (scanr f z xs) == foldr f z xs +-- +-- * For a different trade-off between circuit size and logic depth for +-- associative operators, see "Clash.Sized.RTree#scans" scanr :: (a -> b -> b) -> b -> Vec n a -> Vec (n + 1) b scanr f z xs = ws where diff --git a/src/Clash/Tutorial.hs b/src/Clash/Tutorial.hs --- a/src/Clash/Tutorial.hs +++ b/src/Clash/Tutorial.hs @@ -3,6 +3,7 @@ 2017-2019, Myrtle Software Ltd 2017 , QBayLogic, Google Inc., 2021 , QBayLogic B.V. + 2022 , LUMI GUIDE FIETSDETECTIE B.V. Licence : Creative Commons 4.0 (CC BY 4.0) (https://creativecommons.org/licenses/by/4.0/) Maintainer: QBayLogic B.V. @@ -1247,11 +1248,15 @@ * @~IF \ ~THEN \ ~ELSE \ ~FI@: renders the @\@ part when @\@ evaluates to /0/, and renders the @\@ in all other cases. Valid @\@s are @~LENGTH[\]@, @~SIZE[\]@, + @~CMPLE[\][\]@, @~DEPTH[\]@, @~VIVADO@, @~IW64@, @~ISLIT[N]@, @~ISVAR[N]@, @~ISACTIVEENABLE[N]@, @~ISSYNC[N]@, and @~AND[\,\,..]@. * @~VIVADO@: /1/ when Clash compiler is invoked with the @-fclash-xilinx@ or @-fclash-vivado@ flag. To be used with in an @~IF .. ~THEN .. ~ELSE .. ~FI@ statement. +* @~CMPLE[\][\]@: /1/ when @\ \<= \@, otherwise /0/ +* @~IW64@: /1/ when Int/Word/Integer types are represented with 64 bits in HDL. + /0/ when they're represented by 32 bits. * @~TOBV[\][\]@: create conversion code that so that the expression in @\@ is converted to a bit vector (@std_logic_vector@). The @\@ hole indicates the type of the expression and must be either @@ -1261,7 +1266,7 @@ is converted to type indicated by @\@. The @\@ hole must be either @~TYP[N]@, @~TYPO@, or @~TYPEL[\]@. * @~INCLUDENAME[N]@: the generated name of the @N@'th included component. -* @~FILEPATH[\]@: The argument mentioned in @\@ is a file which +* @~FILE[\]@: The argument mentioned in @\@ is a file which must be copied to the location of the generated HDL. * @~GENERATE@: Verilog: create a /generate/ statement, except when already in a /generate/ context. @@ -1270,13 +1275,16 @@ * @~ISLIT[N]@: Is the @(N+1)@'th argument to the function a literal. * @~ISVAR[N]@: Is the @(N+1)@'th argument to the function explicitly not a literal. +* @~ISSCALAR[N]@: Is the @(N+1)@'th argument to the function a scalar. Note + that this means different things for different HDLs. In (System)Verilog only + @Bit@ and @Bool@ are considered scalar. In VHDL, in addition to those two, + enumeration types and integers are considered scalar. * @~TAG[N]@: Name of given domain. Errors when called on an argument which is not a 'KnownDomain', 'Reset', or 'Clock'. * @~PERIOD[N]@: Clock period of given domain. Errors when called on an argument which is not a 'KnownDomain' or 'KnownConf'. * @~ISACTIVEENABLE[N]@: Is the @(N+1)@'th argument a an Enable line NOT set to a constant True. Can be used instead of deprecated (and removed) template tag - @~ISGATED@. Errors when called on an argument which is not a signal of bools. * @~ISSYNC[N]@: Does synthesis domain at the @(N+1)@'th argument have synchronous resets. Errors when called on an argument which is not a 'KnownDomain' or 'KnownConf'. * @~ISINITDEFINED[N]@: Does synthesis domain at the @(N+1)@'th argument have defined initial @@ -1286,6 +1294,7 @@ argument which is not a 'KnownDomain' or 'KnownConf'. * @~AND[\,\,..]@: Logically /and/ the conditions in the @\@'s * @~VAR[\][N]@: Like @~ARG[N]@ but binds the argument to a variable named NAME. + The @\@ can be left blank, then clash will come up with a (unique) name. * @~VARS[N]@: VHDL: Return the variables at the @(N+1)@'th argument. * @~NAME[N]@: Render the @(N+1)@'th string literal argument as an identifier instead of a string literal. Fails when the @(N+1)@'th argument is not a diff --git a/src/Clash/XException.hs b/src/Clash/XException.hs --- a/src/Clash/XException.hs +++ b/src/Clash/XException.hs @@ -53,6 +53,11 @@ import Data.Complex (Complex) import Data.Either (isLeft) import Data.Foldable (toList) +import Data.Functor.Compose (Compose) +import Data.Functor.Const (Const) +import Data.Functor.Identity (Identity) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) import Data.Int (Int8, Int16, Int32, Int64) import Data.Ord (Down (Down)) import Data.Ratio (Ratio, numerator, denominator) @@ -369,6 +374,11 @@ printX x = putStrLn $ showX x instance ShowX () +instance ShowX a => ShowX (Identity a) +instance ShowX a => ShowX (Const a b) +instance (ShowX (f a), ShowX (g a)) => ShowX (Product f g a) +instance (ShowX (f a), ShowX (g a)) => ShowX (Sum f g a) +instance (ShowX (f (g a))) => ShowX (Compose f g a) instance {-# OVERLAPPABLE #-} ShowX a => ShowX [a] where showsPrecX _ = showListX @@ -532,6 +542,11 @@ instance NFDataX a => NFDataX [a] instance (NFDataX a, NFDataX b) => NFDataX (Either a b) instance NFDataX a => NFDataX (Maybe a) +instance NFDataX a => NFDataX (Identity a) +instance NFDataX a => NFDataX (Const a b) +instance (NFDataX (f a), NFDataX (g a)) => NFDataX (Product f g a) +instance (NFDataX (f a), NFDataX (g a)) => NFDataX (Sum f g a) +instance (NFDataX (f (g a))) => NFDataX (Compose f g a) instance NFDataX Char where deepErrorX = errorX diff --git a/tests/Clash/Tests/DerivingDataRepr.hs b/tests/Clash/Tests/DerivingDataRepr.hs --- a/tests/Clash/Tests/DerivingDataRepr.hs +++ b/tests/Clash/Tests/DerivingDataRepr.hs @@ -10,17 +10,17 @@ import Prelude ((=<<), ($)) import Clash.Annotations.BitRepresentation import Clash.Annotations.BitRepresentation.Deriving -import Clash.Tests.DerivingDataReprTypes (Train(..), RGB(..)) +import Clash.Tests.DerivingDataReprTypes (Train(..), RGB(..), Headphones(..), EarCup(..)) import Data.Maybe (Maybe(..)) --------------------------------------------------------- ------------ DERIVING SIMPLE REPRESENTATIONS ------------ --------------------------------------------------------- -oneHotOverlapRepr :: DataReprAnn -oneHotOverlapRepr = $( (simpleDerivator OneHot OverlapL) =<< [t| Train |] ) +oneHotOverlapLRepr :: DataReprAnn +oneHotOverlapLRepr = $( (simpleDerivator OneHot OverlapL) =<< [t| Train |] ) -oneHotOverlapRepr' :: DataReprAnn -oneHotOverlapRepr' = +oneHotOverlapLRepr' :: DataReprAnn +oneHotOverlapLRepr' = DataReprAnn $(liftQ [t| Train |]) 8 @@ -30,6 +30,43 @@ , ConstrRepr 'Toy 128 128 [] ] +oneHotOverlapRRepr :: DataReprAnn +oneHotOverlapRRepr = $( (simpleDerivator OneHot OverlapR) =<< [t| Train |] ) + +oneHotOverlapRRepr' :: DataReprAnn +oneHotOverlapRRepr' = + DataReprAnn + $(liftQ [t| Train |]) + 8 + [ ConstrRepr 'Passenger 16 16 [0b0011] + , ConstrRepr 'Freight 32 32 [0b1100, 0b0011] + , ConstrRepr 'Maintenance 64 64 [] + , ConstrRepr 'Toy 128 128 [] + ] + +oneHotOverlapReprRec :: DataReprAnn +oneHotOverlapReprRec = $( (simpleDerivator OneHot OverlapL) =<< [t| Headphones |] ) + +oneHotOverlapReprRec' :: DataReprAnn +oneHotOverlapReprRec' = + DataReprAnn + $(liftQ [t| Headphones |]) + 4 + [ ConstrRepr 'InEar 4 4 [0b10] + , ConstrRepr 'OverEar 8 8 [0b11] + ] + +oneHotOverlapReprInfix :: DataReprAnn +oneHotOverlapReprInfix = $( (simpleDerivator OneHot OverlapL) =<< [t| EarCup |] ) + +oneHotOverlapReprInfix' :: DataReprAnn +oneHotOverlapReprInfix' = + DataReprAnn + $(liftQ [t| EarCup |]) + 5 + [ ConstrRepr '(:<>:) 16 16 [0b1100,0b0011] ] + + oneHotWideRepr :: DataReprAnn oneHotWideRepr = $( (simpleDerivator OneHot Wide) =<< [t| Train |] ) @@ -109,10 +146,13 @@ -- MAIN tests :: TestTree tests = testGroup "DerivingDataRepr" - [ testCase "OneHotOverlap" $ oneHotOverlapRepr @?= oneHotOverlapRepr' - , testCase "OneHotWide" $ oneHotWideRepr @?= oneHotWideRepr' - , testCase "BinaryOverlap" $ countOverlapRepr @?= countOverlapRepr' - , testCase "BinaryWide" $ countWideRepr @?= countWideRepr' - , testCase "Packed" $ packedRepr @?= packedRepr' - , testCase "PackedMaybe" $ packedMaybeRGB @?= packedMaybeRGB' + [ testCase "OneHotOverlapL" $ oneHotOverlapLRepr @?= oneHotOverlapLRepr' + , testCase "OneHotOverlapR" $ oneHotOverlapRRepr @?= oneHotOverlapRRepr' + , testCase "OneHotOverlapRec" $ oneHotOverlapReprRec @?= oneHotOverlapReprRec' + , testCase "OneHotOverlapInfix" $ oneHotOverlapReprInfix @?= oneHotOverlapReprInfix' + , testCase "OneHotWide" $ oneHotWideRepr @?= oneHotWideRepr' + , testCase "BinaryOverlap" $ countOverlapRepr @?= countOverlapRepr' + , testCase "BinaryWide" $ countWideRepr @?= countWideRepr' + , testCase "Packed" $ packedRepr @?= packedRepr' + , testCase "PackedMaybe" $ packedMaybeRGB @?= packedMaybeRGB' ] diff --git a/tests/Clash/Tests/DerivingDataReprTypes.hs b/tests/Clash/Tests/DerivingDataReprTypes.hs --- a/tests/Clash/Tests/DerivingDataReprTypes.hs +++ b/tests/Clash/Tests/DerivingDataReprTypes.hs @@ -29,3 +29,11 @@ deriveDefaultAnnotation [t| RGB |] deriveBitPack [t| RGB |] + +data Headphones + = InEar + { _wireless :: Bool } + | OverEar + { _impedance :: SmallInt } + +data EarCup = SmallInt :<>: SmallInt