diff --git a/changelog/2025-10-05T10_12_05+02_00_add_product_sum_info b/changelog/2025-10-05T10_12_05+02_00_add_product_sum_info new file mode 100644 index 0000000000..98c76f09a5 --- /dev/null +++ b/changelog/2025-10-05T10_12_05+02_00_add_product_sum_info @@ -0,0 +1 @@ +ADDED `IsProductType` and `IsSumType` indicators to `BitPack` diff --git a/clash-prelude/src/Clash/Class/BitPack/Internal.hs b/clash-prelude/src/Clash/Class/BitPack/Internal.hs index 0c36140bb8..006103ac4c 100644 --- a/clash-prelude/src/Clash/Class/BitPack/Internal.hs +++ b/clash-prelude/src/Clash/Class/BitPack/Internal.hs @@ -39,6 +39,7 @@ import Data.Functor.Sum (Sum) import Data.Int import Data.Ord (Down) import Data.Proxy (Proxy) +import Data.Type.Bool (type (||)) import Data.Word import Foreign.C.Types (CUShort) import GHC.Generics @@ -109,6 +110,15 @@ class KnownNat (BitSize a) => BitPack a where -- > deriving (Generic, BitPack) type BitSize a :: Nat type BitSize a = (CLog 2 (GConstructorCount (Rep a))) + (GFieldSize (Rep a)) + + -- | Is 'True' for product types. + type IsProductType a :: Bool + type IsProductType a = GIsProductType (Rep a) + + -- | Is 'True' for sum types. + type IsSumType a :: Bool + type IsSumType a = GIsSumType (Rep a) + -- | Convert element of type @a@ to a 'BitVector' -- -- >>> pack (-5 :: Signed 6) @@ -234,71 +244,99 @@ bitCoerceMap f = bitCoerce . f . bitCoerce instance BitPack Bool where type BitSize Bool = 1 + type IsProductType Bool = False + type IsSumType Bool = False pack = let go b = if b then 1 else 0 in packXWith go unpack = checkUnpackUndef $ \bv -> if bv == 1 then True else False instance KnownNat n => BitPack (BitVector n) where type BitSize (BitVector n) = n + type IsProductType (BitVector n) = False + type IsSumType (BitVector n) = False pack = packXWith id unpack v = v instance BitPack Bit where type BitSize Bit = 1 + type IsProductType Bit = False + type IsSumType Bit = False pack = packXWith pack# unpack = unpack# instance BitPack Int where type BitSize Int = WORD_SIZE_IN_BITS + type IsProductType Int = False + type IsSumType Int = False pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral instance BitPack Int8 where type BitSize Int8 = 8 + type IsProductType Int8 = False + type IsSumType Int8 = False pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral instance BitPack Int16 where type BitSize Int16 = 16 + type IsProductType Int16 = False + type IsSumType Int16 = False pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral instance BitPack Int32 where type BitSize Int32 = 32 + type IsProductType Int32 = False + type IsSumType Int32 = False pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral instance BitPack Int64 where type BitSize Int64 = 64 + type IsProductType Int64 = False + type IsSumType Int64 = False pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral instance BitPack Word where type BitSize Word = WORD_SIZE_IN_BITS + type IsProductType Word = False + type IsSumType Word = False pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral instance BitPack Word8 where type BitSize Word8 = 8 + type IsProductType Word8 = False + type IsSumType Word8 = False pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral instance BitPack Word16 where type BitSize Word16 = 16 + type IsProductType Word16 = False + type IsSumType Word16 = False pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral instance BitPack Word32 where type BitSize Word32 = 32 + type IsProductType Word32 = False + type IsSumType Word32 = False pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral instance BitPack Word64 where type BitSize Word64 = 64 + type IsProductType Word64 = False + type IsSumType Word64 = False pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral instance BitPack Float where type BitSize Float = 32 + type IsProductType Float = False + type IsSumType Float = False pack = packXWith packFloat# unpack = checkUnpackUndef unpackFloat# @@ -316,6 +354,8 @@ unpackFloat# (unsafeToNatural -> w) = wordToFloat (fromIntegral w) instance BitPack Double where type BitSize Double = 64 + type IsProductType Double = False + type IsSumType Double = False pack = packXWith packDouble# unpack = checkUnpackUndef unpackDouble# @@ -333,21 +373,29 @@ unpackDouble# (unsafeToNatural -> w) = wordToDouble (fromIntegral w) instance BitPack CUShort where type BitSize CUShort = 16 + type IsProductType CUShort = False + type IsSumType CUShort = False pack = packXWith fromIntegral unpack = checkUnpackUndef fromIntegral instance BitPack Half where type BitSize Half = 16 + type IsProductType Half = False + type IsSumType Half = False pack (Half x) = pack x unpack = checkUnpackUndef $ \x -> Half (unpack x) instance BitPack () where type BitSize () = 0 + type IsProductType () = False + type IsSumType () = False pack _ = minBound unpack _ = () instance BitPack Char where type BitSize Char = 21 + type IsProductType Char = False + type IsSumType Char = False pack = packXWith packChar# unpack = checkUnpackUndef unpackChar# @@ -369,6 +417,8 @@ unpackChar# = chr . fromIntegral -- GHC imposed limit is either 62 or 64 depending on the GHC version. instance (BitPack a, BitPack b) => BitPack (a,b) where type BitSize (a,b) = BitSize a + BitSize b + type IsProductType (a,b) = True + type IsSumType (a,b) = IsSumType a || IsSumType b pack = let go (a,b) = pack a ++# pack b in packXWith go unpack ab = let (a,b) = split# ab in (unpack a, unpack b) @@ -381,6 +431,12 @@ class GBitPack f where -- are needed to represent the constructor. type GConstructorCount f :: Nat + -- | Is 'True' for product types. + type GIsProductType f :: Bool + + -- | Is 'True' for sum types. + type GIsSumType f :: Bool + -- | Pack fields of a type. Caller should pack and prepend the constructor bits. gPackFields :: Int @@ -404,6 +460,8 @@ class GBitPack f where instance GBitPack a => GBitPack (M1 m d a) where type GFieldSize (M1 m d a) = GFieldSize a type GConstructorCount (M1 m d a) = GConstructorCount a + type GIsProductType (M1 m d a) = GIsProductType a + type GIsSumType (M1 m d a) = GIsSumType a gPackFields cc (M1 m1) = gPackFields cc m1 gUnpack c cc b = M1 (gUnpack c cc b) @@ -416,6 +474,8 @@ instance ( KnownNat (GFieldSize g) ) => GBitPack (f :+: g) where type GFieldSize (f :+: g) = Max (GFieldSize f) (GFieldSize g) type GConstructorCount (f :+: g) = GConstructorCount f + GConstructorCount g + type GIsProductType (f :+: g) = GIsProductType f || GIsProductType g + type GIsSumType (f :+: g) = True gPackFields cc (L1 l) = let (sc, packed) = gPackFields cc l in @@ -443,6 +503,8 @@ instance ( KnownNat (GFieldSize g) instance (KnownNat (GFieldSize g), KnownNat (GFieldSize f), GBitPack f, GBitPack g) => GBitPack (f :*: g) where type GFieldSize (f :*: g) = GFieldSize f + GFieldSize g type GConstructorCount (f :*: g) = 1 + type GIsProductType (f :*: g) = True + type GIsSumType (f :*: g) = GIsSumType f || GIsSumType g gPackFields cc fg = (cc, packXWith go fg) @@ -460,6 +522,8 @@ instance (KnownNat (GFieldSize g), KnownNat (GFieldSize f), GBitPack f, GBitPack instance BitPack c => GBitPack (K1 i c) where type GFieldSize (K1 i c) = BitSize c type GConstructorCount (K1 i c) = 1 + type GIsProductType (K1 i c) = IsProductType c + type GIsSumType (K1 i c) = IsSumType c gPackFields cc (K1 i) = (cc, pack i) gUnpack _c _cc b = K1 (unpack b) @@ -467,6 +531,8 @@ instance BitPack c => GBitPack (K1 i c) where instance GBitPack U1 where type GFieldSize U1 = 0 type GConstructorCount U1 = 1 + type GIsProductType U1 = False + type GIsSumType U1 = False gPackFields cc U1 = (cc, 0) gUnpack _c _cc _b = U1 @@ -517,4 +583,5 @@ bitToBool :: Bit -> Bool bitToBool = bitCoerce -- Derive the BitPack instance for tuples of size 3 to maxTupleSize -deriveBitPackTuples ''BitPack ''BitSize 'pack 'unpack +deriveBitPackTuples ''BitPack ''BitSize ''IsProductType ''IsSumType + 'pack 'unpack diff --git a/clash-prelude/src/Clash/Class/BitPack/Internal/TH.hs b/clash-prelude/src/Clash/Class/BitPack/Internal/TH.hs index d5817d763f..19f1aecca6 100644 --- a/clash-prelude/src/Clash/Class/BitPack/Internal/TH.hs +++ b/clash-prelude/src/Clash/Class/BitPack/Internal/TH.hs @@ -1,5 +1,5 @@ {-| -Copyright : (C) 2019-2024, QBayLogic B.V. +Copyright : (C) 2019-2025, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -8,14 +8,15 @@ Maintainer : QBayLogic B.V. module Clash.Class.BitPack.Internal.TH where -import Clash.CPP (maxTupleSize) +import Clash.CPP (maxTupleSize) import Language.Haskell.TH.Compat (mkTySynInstD,mkTupE) -import Control.Monad (replicateM) +import Control.Monad (replicateM) #if !MIN_VERSION_base(4,20,0) -import Data.List (foldl') +import Data.List (foldl') #endif -import GHC.TypeLits (KnownNat) +import GHC.TypeLits (KnownNat) import Language.Haskell.TH +import Language.Haskell.TH.Syntax (trueName) -- | Contruct all the tuple (starting at size 3) instances for BitPack. deriveBitPackTuples @@ -24,15 +25,23 @@ deriveBitPackTuples -> Name -- ^ BitSize -> Name + -- ^ IsProductType + -> Name + -- ^ IsSumType + -> Name -- ^ pack -> Name -- ^ unpack -> DecsQ -deriveBitPackTuples bitPackName bitSizeName packName unpackName = do - let bitPack = ConT bitPackName - bitSize = ConT bitSizeName - knownNat = ConT ''KnownNat - plus = ConT $ mkName "+" +deriveBitPackTuples bitPackName bitSizeName isProductTypeName isSumTypeName + packName unpackName = do + let bitPack = ConT bitPackName + bitSize = ConT bitSizeName + isSumType = ConT isSumTypeName + knownNat = ConT ''KnownNat + typeTrue = ConT trueName + plus = ConT $ mkName "+" + typeOr = ConT $ mkName "||" allNames <- replicateM maxTupleSize (newName "a") retupName <- newName "retup" @@ -62,6 +71,16 @@ deriveBitPackTuples bitPackName bitSizeName packName unpackName = do $ plus `AppT` (bitSize `AppT` v) `AppT` (bitSize `AppT` foldl AppT (TupleT $ tupleNum - 1) vs) + -- Associated type IsProductType + isProductTypeType = + mkTySynInstD isProductTypeName [tuple (v:vs)] typeTrue + + -- Associated type IsSumType + isSumTypeType = + mkTySynInstD isSumTypeName [tuple (v:vs)] + $ typeOr `AppT` (isSumType `AppT` v) `AppT` + (isSumType `AppT` foldl AppT (TupleT $ tupleNum - 1) vs) + pack = FunD packName @@ -107,4 +126,5 @@ deriveBitPackTuples bitPackName bitSizeName packName unpackName = do [] ] - in InstanceD Nothing context instTy [bitSizeType, pack, unpack] + in InstanceD Nothing context instTy + [bitSizeType, isProductTypeType, isSumTypeType, pack, unpack] diff --git a/clash-prelude/src/Clash/Num/Overflowing.hs b/clash-prelude/src/Clash/Num/Overflowing.hs index 005e17fa98..4105d9eebb 100644 --- a/clash-prelude/src/Clash/Num/Overflowing.hs +++ b/clash-prelude/src/Clash/Num/Overflowing.hs @@ -1,5 +1,5 @@ {-| -Copyright : (C) 2021-2022, QBayLogic B.V. +Copyright : (C) 2021-2025, QBayLogic B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -65,6 +65,8 @@ instance (Ord a) => Ord (Overflowing a) where instance (BitPack a, KnownNat (BitSize a + 1)) => BitPack (Overflowing a) where type BitSize (Overflowing a) = BitSize a + 1 + type IsProductType (Overflowing a) = IsProductType a + type IsSumType (Overflowing a) = IsSumType a -- Default instance, no explicit implementations. instance (Parity a) => Parity (Overflowing a) where diff --git a/clash-prelude/src/Clash/Sized/Fixed.hs b/clash-prelude/src/Clash/Sized/Fixed.hs index 227fef26cd..86056f9f1b 100644 --- a/clash-prelude/src/Clash/Sized/Fixed.hs +++ b/clash-prelude/src/Clash/Sized/Fixed.hs @@ -549,6 +549,8 @@ instance (NumFixedC rep int frac) => Num (Fixed rep int frac) where instance (BitPack (rep (int + frac)), KnownNat (BitSize (rep (int + frac)))) => BitPack (Fixed rep int frac) where type BitSize (Fixed rep int frac) = BitSize (rep (int + frac)) + type IsProductType (Fixed rep int frac) = False + type IsSumType (Fixed rep int frac) = False pack (Fixed fRep) = pack fRep unpack bv = Fixed (unpack bv) diff --git a/clash-prelude/src/Clash/Sized/Internal/Index.hs b/clash-prelude/src/Clash/Sized/Internal/Index.hs index 3a7a7a3b08..ee1e530311 100644 --- a/clash-prelude/src/Clash/Sized/Internal/Index.hs +++ b/clash-prelude/src/Clash/Sized/Internal/Index.hs @@ -179,6 +179,8 @@ instance NFData (Index n) where instance (KnownNat n, 1 <= n) => BitPack (Index n) where type BitSize (Index n) = CLog 2 n + type IsProductType (Index n) = False + type IsSumType (Index n) = False pack = packXWith pack# unpack = unpack# diff --git a/clash-prelude/src/Clash/Sized/Internal/Signed.hs b/clash-prelude/src/Clash/Sized/Internal/Signed.hs index 8bb92e3387..b36a6106e1 100644 --- a/clash-prelude/src/Clash/Sized/Internal/Signed.hs +++ b/clash-prelude/src/Clash/Sized/Internal/Signed.hs @@ -222,6 +222,8 @@ instance KnownNat n => Read (Signed n) where instance KnownNat n => BitPack (Signed n) where type BitSize (Signed n) = n + type IsProductType (Signed n) = False + type IsSumType (Signed n) = False pack = packXWith pack# unpack = unpack# diff --git a/clash-prelude/src/Clash/Sized/Internal/Unsigned.hs b/clash-prelude/src/Clash/Sized/Internal/Unsigned.hs index 05e5200a49..9ce7b677c8 100644 --- a/clash-prelude/src/Clash/Sized/Internal/Unsigned.hs +++ b/clash-prelude/src/Clash/Sized/Internal/Unsigned.hs @@ -242,6 +242,8 @@ instance KnownNat n => Read (Unsigned n) where instance KnownNat n => BitPack (Unsigned n) where type BitSize (Unsigned n) = n + type IsProductType (Unsigned n) = False + type IsSumType (Unsigned n) = False pack = packXWith pack# unpack = unpack# diff --git a/clash-prelude/src/Clash/Sized/Vector.hs b/clash-prelude/src/Clash/Sized/Vector.hs index d2d4fa8bdc..25c226fe81 100644 --- a/clash-prelude/src/Clash/Sized/Vector.hs +++ b/clash-prelude/src/Clash/Sized/Vector.hs @@ -2711,6 +2711,8 @@ smapWithBounds f xs = reverse instance (KnownNat n, BitPack a) => BitPack (Vec n a) where type BitSize (Vec n a) = n * (BitSize a) + type IsProductType (Vec n a) = True + type IsSumType (Vec n a) = IsSumType a pack = packXWith (concatBitVector# . map pack) unpack = map unpack . unconcatBitVector#