diff --git a/changelog/2023-01-04T14_23_01+01_00_fix_2386 b/changelog/2023-01-04T14_23_01+01_00_fix_2386 new file mode 100644 index 0000000000..573f07119a --- /dev/null +++ b/changelog/2023-01-04T14_23_01+01_00_fix_2386 @@ -0,0 +1,2 @@ +FIXED: Clash no longer gives `Dubious primitive instantiation warning` +when using `unpack` [#2386](https://github.com/clash-lang/clash-compiler/issues/2386). diff --git a/changelog/2023-01-04T14_23_01+01_00_showx_cushort b/changelog/2023-01-04T14_23_01+01_00_showx_cushort new file mode 100644 index 0000000000..b71e72faea --- /dev/null +++ b/changelog/2023-01-04T14_23_01+01_00_showx_cushort @@ -0,0 +1 @@ +ADDED: Add `Clash.XException.ShowX` instance for `Foreign.C.Types.CUShort`. diff --git a/clash-ghc/src-ghc/Clash/GHC/Evaluator/Primitive.hs b/clash-ghc/src-ghc/Clash/GHC/Evaluator/Primitive.hs index 5bbfb0fb33..2527e8deb2 100644 --- a/clash-ghc/src-ghc/Clash/GHC/Evaluator/Primitive.hs +++ b/clash-ghc/src-ghc/Clash/GHC/Evaluator/Primitive.hs @@ -2,7 +2,8 @@ Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017-2022, Google Inc., - 2017-2022, QBayLogic B.V. + 2017-2023, QBayLogic B.V. + 2023, LumiGuide Fietsdetectie B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -2202,6 +2203,127 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of -> reduce (boolToBoolLiteral tcm ty (s1 == s2)) | otherwise -> error (show args) + "Clash.Class.BitPack.Internal.packInt8#" -- :: Int8 -> BitVector 8 + | [DC _ [Left arg]] <- args + , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind +#if MIN_VERSION_base(4,16,0) + , mach2@Machine{mStack=[],mTerm=Literal (Int8Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#else + , mach2@Machine{mStack=[],mTerm=Literal (IntLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#endif + -> let resTyInfo = extractTySizeInfo tcm ty tys + in Just $ mach2 + { mStack = mStack mach + , mTerm = mkBitVectorLit' resTyInfo 0 i + } + + "Clash.Class.BitPack.Internal.packInt16#" -- :: Int16 -> BitVector 16 + | [DC _ [Left arg]] <- args + , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind +#if MIN_VERSION_base(4,16,0) + , mach2@Machine{mStack=[],mTerm=Literal (Int16Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#else + , mach2@Machine{mStack=[],mTerm=Literal (IntLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#endif + -> let resTyInfo = extractTySizeInfo tcm ty tys + in Just $ mach2 + { mStack = mStack mach + , mTerm = mkBitVectorLit' resTyInfo 0 i + } + + "Clash.Class.BitPack.Internal.packInt32#" -- :: Int32 -> BitVector 32 + | [DC _ [Left arg]] <- args + , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind +#if MIN_VERSION_base(4,16,0) + , mach2@Machine{mStack=[],mTerm=Literal (Int32Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#else + , mach2@Machine{mStack=[],mTerm=Literal (IntLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#endif + -> let resTyInfo = extractTySizeInfo tcm ty tys + in Just $ mach2 + { mStack = mStack mach + , mTerm = mkBitVectorLit' resTyInfo 0 i + } + + "Clash.Class.BitPack.Internal.packInt64#" -- :: Int64 -> BitVector 64 + | [DC _ [Left arg]] <- args + , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind +#if MIN_VERSION_base(4,16,0) + , mach2@Machine{mStack=[],mTerm=Literal (Int64Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#else + , mach2@Machine{mStack=[],mTerm=Literal (IntLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#endif + -> let resTyInfo = extractTySizeInfo tcm ty tys + in Just $ mach2 + { mStack = mStack mach + , mTerm = mkBitVectorLit' resTyInfo 0 i + } + + "Clash.Class.BitPack.Internal.packWord#" -- :: Word -> BitVector WORD_SIZE_IN_BITS + | [DC _ [Left arg]] <- args + , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind + , mach2@Machine{mStack=[],mTerm=Literal (WordLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) + -> let resTyInfo = extractTySizeInfo tcm ty tys + in Just $ mach2 + { mStack = mStack mach + , mTerm = mkBitVectorLit' resTyInfo 0 i + } + + "Clash.Class.BitPack.Internal.packWord8#" -- :: Word8 -> BitVector 8 + | [DC _ [Left arg]] <- args + , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind +#if MIN_VERSION_base(4,16,0) + , mach2@Machine{mStack=[],mTerm=Literal (Word8Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#else + , mach2@Machine{mStack=[],mTerm=Literal (WordLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#endif + -> let resTyInfo = extractTySizeInfo tcm ty tys + in Just $ mach2 + { mStack = mStack mach + , mTerm = mkBitVectorLit' resTyInfo 0 i + } + + "Clash.Class.BitPack.Internal.packWord16#" -- :: Word16 -> BitVector 16 + | [DC _ [Left arg]] <- args + , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind +#if MIN_VERSION_base(4,16,0) + , mach2@Machine{mStack=[],mTerm=Literal (Word16Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#else + , mach2@Machine{mStack=[],mTerm=Literal (WordLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#endif + -> let resTyInfo = extractTySizeInfo tcm ty tys + in Just $ mach2 + { mStack = mStack mach + , mTerm = mkBitVectorLit' resTyInfo 0 i + } + + "Clash.Class.BitPack.Internal.packWord32#" -- :: Word32 -> BitVector 32 + | [DC _ [Left arg]] <- args + , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind +#if MIN_VERSION_base(4,16,0) + , mach2@Machine{mStack=[],mTerm=Literal (Word32Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#else + , mach2@Machine{mStack=[],mTerm=Literal (WordLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#endif + -> let resTyInfo = extractTySizeInfo tcm ty tys + in Just $ mach2 + { mStack = mStack mach + , mTerm = mkBitVectorLit' resTyInfo 0 i + } + + "Clash.Class.BitPack.Internal.packWord64#" -- :: Word64 -> BitVector 64 + | [DC _ [Left arg]] <- args + , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind +#if MIN_VERSION_base(4,16,0) + , mach2@Machine{mStack=[],mTerm=Literal (Word64Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#else + , mach2@Machine{mStack=[],mTerm=Literal (WordLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#endif + -> let resTyInfo = extractTySizeInfo tcm ty tys + in Just $ mach2 + { mStack = mStack mach + , mTerm = mkBitVectorLit' resTyInfo 0 i + } "Clash.Class.BitPack.Internal.packDouble#" -- :: Double -> BitVector 64 | [DC _ [Left arg]] <- args @@ -2223,6 +2345,114 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of , mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Word32 -> BitVector 32) i) } + "Clash.Class.BitPack.Internal.packCUShort#" -- :: CUShort -> BitVector 16 + | [DC _ [Left arg]] <- args + , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind +#if MIN_VERSION_base(4,16,0) + , mach2@Machine{mStack=[],mTerm=Literal (Word16Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#else + , mach2@Machine{mStack=[],mTerm=Literal (WordLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach) +#endif + -> let resTyInfo = extractTySizeInfo tcm ty tys + in Just $ mach2 + { mStack = mStack mach + , mTerm = mkBitVectorLit' resTyInfo 0 i + } + + "Clash.Class.BitPack.Internal.unpackInt8#" -- BitVector 8 -> Int8 + | [i] <- bitVectorLiterals' args + -> let resTy = getResultTy tcm ty tys + val = toInteger (unpack (toBV i) :: Signed 8) +#if MIN_VERSION_base(4,16,0) + proj = Int8Literal +#else + proj = IntLiteral +#endif + in reduce (mkIntCLit tcm proj val resTy) + + "Clash.Class.BitPack.Internal.unpackInt16#" -- BitVector 16 -> Int16 + | [i] <- bitVectorLiterals' args + -> let resTy = getResultTy tcm ty tys + val = toInteger (unpack (toBV i) :: Signed 16) +#if MIN_VERSION_base(4,16,0) + proj = Int16Literal +#else + proj = IntLiteral +#endif + in reduce (mkIntCLit tcm proj val resTy) + + "Clash.Class.BitPack.Internal.unpackInt32#" -- BitVector 32 -> Int32 + | [i] <- bitVectorLiterals' args + -> let resTy = getResultTy tcm ty tys + val = toInteger (unpack (toBV i) :: Signed 32) +#if MIN_VERSION_base(4,16,0) + proj = Int32Literal +#else + proj = IntLiteral +#endif + in reduce (mkIntCLit tcm proj val resTy) + + "Clash.Class.BitPack.Internal.unpackInt64#" -- BitVector 64 -> Int64 + | [i] <- bitVectorLiterals' args + -> let resTy = getResultTy tcm ty tys + val = toInteger (unpack (toBV i) :: Signed 64) +#if MIN_VERSION_base(4,16,0) + proj = Int64Literal +#else + proj = IntLiteral +#endif + in reduce (mkIntCLit tcm proj val resTy) + + "Clash.Class.BitPack.Internal.unpackWord#" -- BitVector WORD_SIZE_IN_BITS -> Word + | [i] <- bitVectorLiterals' args + -> let resTy = getResultTy tcm ty tys + val = toInteger (unpack (toBV i) :: Unsigned 64) + in reduce (mkIntCLit tcm WordLiteral val resTy) + + "Clash.Class.BitPack.Internal.unpackWord8#" -- BitVector 8 -> Word8 + | [i] <- bitVectorLiterals' args + -> let resTy = getResultTy tcm ty tys + val = toInteger (unpack (toBV i) :: Unsigned 8) +#if MIN_VERSION_base(4,16,0) + proj = Word8Literal +#else + proj = WordLiteral +#endif + in reduce (mkIntCLit tcm proj val resTy) + + "Clash.Class.BitPack.Internal.unpackWord16#" -- BitVector 16 -> Word16 + | [i] <- bitVectorLiterals' args + -> let resTy = getResultTy tcm ty tys + val = toInteger (unpack (toBV i) :: Unsigned 16) +#if MIN_VERSION_base(4,16,0) + proj = Word16Literal +#else + proj = WordLiteral +#endif + in reduce (mkIntCLit tcm proj val resTy) + + "Clash.Class.BitPack.Internal.unpackWord32#" -- BitVector 32 -> Word32 + | [i] <- bitVectorLiterals' args + -> let resTy = getResultTy tcm ty tys + val = toInteger (unpack (toBV i) :: Unsigned 32) +#if MIN_VERSION_base(4,16,0) + proj = Word32Literal +#else + proj = WordLiteral +#endif + in reduce (mkIntCLit tcm proj val resTy) + + "Clash.Class.BitPack.Internal.unpackWord64#" -- BitVector 64 -> Word64 + | [i] <- bitVectorLiterals' args + -> let resTy = getResultTy tcm ty tys + val = toInteger (unpack (toBV i) :: Unsigned 64) +#if MIN_VERSION_base(4,16,0) + proj = Word64Literal +#else + proj = WordLiteral +#endif + in reduce (mkIntCLit tcm proj val resTy) + "Clash.Class.BitPack.Internal.unpackFloat#" | [i] <- bitVectorLiterals' args -> let resTy = getResultTy tcm ty tys @@ -2235,6 +2465,17 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of val = unpack (toBV i :: BitVector 64) in reduce (mkDoubleCLit tcm val resTy) + "Clash.Class.BitPack.Internal.unpackCUShort#" + | [i] <- bitVectorLiterals' args + -> let resTy = getResultTy tcm ty tys + val = toInteger (unpack (toBV i) :: Unsigned 16) +#if MIN_VERSION_base(4,16,0) + proj = Word16Literal +#else + proj = WordLiteral +#endif + in reduce (mkIntCLit tcm proj val resTy) + "Clash.Class.BitPack.Internal.xToBV" | isSubj , Just (nTy, kn) <- extractKnownNat tcm tys @@ -2793,7 +3034,7 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of "Clash.Sized.Internal.Index.fromEnum#" | [i] <- indexLiterals' args -> let resTy = getResultTy tcm ty tys - in reduce (mkIntCLit tcm i resTy) + in reduce (mkIntCLit tcm IntLiteral i resTy) -- Bounded "Clash.Sized.Internal.Index.maxBound#" @@ -2910,7 +3151,7 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of "Clash.Sized.Internal.Signed.fromEnum#" | [i] <- signedLiterals' args -> let resTy = getResultTy tcm ty tys - in reduce (mkIntCLit tcm i resTy) + in reduce (mkIntCLit tcm IntLiteral i resTy) -- Bounded "Clash.Sized.Internal.Signed.minBound#" @@ -3128,7 +3369,7 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of "Clash.Sized.Internal.Unsigned.fromEnum#" | [i] <- unsignedLiterals' args -> let resTy = getResultTy tcm ty tys - in reduce (mkIntCLit tcm i resTy) + in reduce (mkIntCLit tcm IntLiteral i resTy) -- Bounded "Clash.Sized.Internal.Unsigned.minBound#" @@ -4709,9 +4950,9 @@ bitVectorLitIntLit tcm tys args | otherwise = Nothing -mkIntCLit :: TyConMap -> Integer -> Type -> Term -mkIntCLit tcm lit resTy = - App (Data intDc) (Literal (IntLiteral lit)) +mkIntCLit :: TyConMap -> (Integer -> Literal) -> Integer -> Type -> Term +mkIntCLit tcm proj lit resTy = + App (Data intDc) (Literal (proj lit)) where (_, tyView -> TyConApp intTcNm []) = splitFunForallTy resTy Just intTc = UniqMap.lookup intTcNm tcm @@ -5045,7 +5286,7 @@ liftBitVector2CInt liftBitVector2CInt tcm resTy f args _p | [i] <- bitVectorLiterals' args = let val = f (toBV i) - in Just $ mkIntCLit tcm val resTy + in Just $ mkIntCLit tcm IntLiteral val resTy | otherwise = Nothing diff --git a/clash-lib/prims/common/Clash_Class_BitPack.primitives.yaml b/clash-lib/prims/common/Clash_Class_BitPack.primitives.yaml index 354221505c..8257616dd5 100644 --- a/clash-lib/prims/common/Clash_Class_BitPack.primitives.yaml +++ b/clash-lib/prims/common/Clash_Class_BitPack.primitives.yaml @@ -1,15 +1,71 @@ - BlackBox: - name: Clash.Class.BitPack.Internal.packFloat# + name: Clash.Class.BitPack.Internal.packInt8# kind: Expression - type: 'packFloat# :: Float - -> BitVector 32' + type: 'packInt8# :: Int8 + -> Bitvector 8' template: ~ARG[0] workInfo: Never - BlackBox: - name: Clash.Class.BitPack.Internal.unpackFloat# + name: Clash.Class.BitPack.Internal.packInt16# kind: Expression - type: 'packFloat# :: BitVector - 32 -> Float' + type: 'packInt16# :: Int16 + -> Bitvector 16' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.packInt32# + kind: Expression + type: 'packInt32# :: Int32 + -> Bitvector 32' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.packInt64# + kind: Expression + type: 'packInt64# :: Int64 + -> Bitvector 64' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.packWord# + kind: Expression + type: 'packWord# :: Word + -> Bitvector WORD_SIZE_IN_BITS' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.packWord8# + kind: Expression + type: 'packWord8# :: Word8 + -> Bitvector 8' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.packWord16# + kind: Expression + type: 'packWord16# :: Word16 + -> Bitvector 16' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.packWord32# + kind: Expression + type: 'packWord32# :: Word32 + -> Bitvector 32' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.packWord64# + kind: Expression + type: 'packWord64# :: Word64 + -> Bitvector 64' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.packFloat# + kind: Expression + type: 'packFloat# :: Float + -> BitVector 32' template: ~ARG[0] workInfo: Never - BlackBox: @@ -19,13 +75,97 @@ -> BitVector 64' template: ~ARG[0] workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.packCUShort# + kind: Expression + type: 'packCUShort# :: CUShort + -> Bitvector 16' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.unpackInt8# + kind: Expression + type: 'unpackInt8# :: Bitvector + 8 -> Int8' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.unpackInt16# + kind: Expression + type: 'unpackInt16# :: Bitvector + 16 -> Int16' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.unpackInt32# + kind: Expression + type: 'unpackInt32# :: Bitvector + 32 -> Int32' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.unpackInt64# + kind: Expression + type: 'unpackInt64# :: Bitvector + 64 -> Int64' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.unpackWord# + kind: Expression + type: 'unpackWord# :: Bitvector + WORD_SIZE_IN_BITS -> Word' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.unpackWord8# + kind: Expression + type: 'unpackWord8# :: Bitvector + 8 -> Word8' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.unpackWord16# + kind: Expression + type: 'unpackWord16# :: Bitvector + 16 -> Word16' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.unpackWord32# + kind: Expression + type: 'unpackWord32# :: Bitvector + 32 -> Word32' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.unpackWord64# + kind: Expression + type: 'unpackWord64# :: Bitvector + 64 -> Word64' + template: ~ARG[0] + workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.unpackFloat# + kind: Expression + type: 'unpackFloat# :: BitVector + 32 -> Float' + template: ~ARG[0] + workInfo: Never - BlackBox: name: Clash.Class.BitPack.Internal.unpackDouble# kind: Expression - type: 'packFloat# :: BitVector + type: 'unpackDouble# :: BitVector 64 -> Double' template: ~ARG[0] workInfo: Never +- BlackBox: + name: Clash.Class.BitPack.Internal.unpackCUShort# + kind: Expression + type: 'unpackCUShort# :: Bitvector 16 + -> CUShort' + template: ~ARG[0] + workInfo: Never - BlackBox: name: Clash.Class.BitPack.Internal.xToBV kind: Expression diff --git a/clash-lib/src/Clash/Netlist/BlackBox.hs b/clash-lib/src/Clash/Netlist/BlackBox.hs index 9e4bfa3057..1965109c2b 100644 --- a/clash-lib/src/Clash/Netlist/BlackBox.hs +++ b/clash-lib/src/Clash/Netlist/BlackBox.hs @@ -3,8 +3,9 @@ Copyright : (C) 2012-2016, University of Twente, 2016-2017, Myrtle Software Ltd, 2017 , Google Inc., - 2021-2022, QBayLogic B.V. + 2021-2023, QBayLogic B.V. 2022 , Google Inc. + 2023, LumiGuide Fietsdetectie B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. @@ -302,7 +303,7 @@ mkArgument bbName bndr nArg e = do return ((N.Literal (Just (Signed 64,64)) (N.NumLit i),hwTy,True),[]) (C.Literal (Word64Literal i), [],_) -> return ((N.Literal (Just (Unsigned 64,64)) (N.NumLit i),hwTy,True),[]) -#if MIN_VERSION_base(4,16,0) +#if MIN_VERSION_base(4,13,0) (C.Literal (Int8Literal i), [],_) -> return ((N.Literal (Just (Signed 8,8)) (N.NumLit i),hwTy,True),[]) (C.Literal (Int16Literal i), [],_) -> diff --git a/clash-prelude/src/Clash/Class/BitPack/Internal.hs b/clash-prelude/src/Clash/Class/BitPack/Internal.hs index 60309ef6ee..36785e3535 100644 --- a/clash-prelude/src/Clash/Class/BitPack/Internal.hs +++ b/clash-prelude/src/Clash/Class/BitPack/Internal.hs @@ -1,8 +1,9 @@ {-| Copyright : (C) 2013-2016, University of Twente, 2016-2017, Myrtle Software Ltd, - 2021-2022 QBayLogic B.V., + 2021-2023 QBayLogic B.V., 2022, Google Inc. + 2023, LumiGuide Fietsdetectie B.V. License : BSD2 (see the file LICENSE) Maintainer : QBayLogic B.V. -} @@ -243,53 +244,143 @@ instance BitPack Bit where instance BitPack Int where type BitSize Int = WORD_SIZE_IN_BITS - pack = packXWith fromIntegral - unpack = checkUnpackUndef fromIntegral + pack = packXWith toEnum + unpack = checkUnpackUndef fromEnum instance BitPack Int8 where type BitSize Int8 = 8 - pack = packXWith fromIntegral - unpack = checkUnpackUndef fromIntegral + pack = packXWith packInt8# + unpack = checkUnpackUndef unpackInt8# + +packInt8# :: Int8 -> BitVector 8 +packInt8# = fromIntegral +{-# NOINLINE packInt8# #-} +{-# ANN packInt8# hasBlackBox #-} + +unpackInt8# :: BitVector 8 -> Int8 +unpackInt8# = fromIntegral +{-# NOINLINE unpackInt8# #-} +{-# ANN unpackInt8# hasBlackBox #-} instance BitPack Int16 where type BitSize Int16 = 16 - pack = packXWith fromIntegral - unpack = checkUnpackUndef fromIntegral + pack = packXWith packInt16# + unpack = checkUnpackUndef unpackInt16# + +packInt16# :: Int16 -> BitVector 16 +packInt16# = fromIntegral +{-# NOINLINE packInt16# #-} +{-# ANN packInt16# hasBlackBox #-} + +unpackInt16# :: BitVector 16 -> Int16 +unpackInt16# = fromIntegral +{-# NOINLINE unpackInt16# #-} +{-# ANN unpackInt16# hasBlackBox #-} instance BitPack Int32 where type BitSize Int32 = 32 - pack = packXWith fromIntegral - unpack = checkUnpackUndef fromIntegral + pack = packXWith packInt32# + unpack = checkUnpackUndef unpackInt32# + +packInt32# :: Int32 -> BitVector 32 +packInt32# = fromIntegral +{-# NOINLINE packInt32# #-} +{-# ANN packInt32# hasBlackBox #-} + +unpackInt32# :: BitVector 32 -> Int32 +unpackInt32# = fromIntegral +{-# NOINLINE unpackInt32# #-} +{-# ANN unpackInt32# hasBlackBox #-} instance BitPack Int64 where type BitSize Int64 = 64 - pack = packXWith fromIntegral - unpack = checkUnpackUndef fromIntegral + pack = packXWith packInt64# + unpack = checkUnpackUndef unpackInt64# + +packInt64# :: Int64 -> BitVector 64 +packInt64# = fromIntegral +{-# NOINLINE packInt64# #-} +{-# ANN packInt64# hasBlackBox #-} + +unpackInt64# :: BitVector 64 -> Int64 +unpackInt64# = fromIntegral +{-# NOINLINE unpackInt64# #-} +{-# ANN unpackInt64# hasBlackBox #-} instance BitPack Word where type BitSize Word = WORD_SIZE_IN_BITS - pack = packXWith fromIntegral - unpack = checkUnpackUndef fromIntegral + pack = packXWith packWord# + unpack = checkUnpackUndef unpackWord# + +packWord# :: Word -> BitVector WORD_SIZE_IN_BITS +packWord# = fromIntegral +{-# NOINLINE packWord# #-} +{-# ANN packWord# hasBlackBox #-} + +unpackWord# :: BitVector WORD_SIZE_IN_BITS -> Word +unpackWord# = fromIntegral +{-# NOINLINE unpackWord# #-} +{-# ANN unpackWord# hasBlackBox #-} instance BitPack Word8 where type BitSize Word8 = 8 - pack = packXWith fromIntegral - unpack = checkUnpackUndef fromIntegral + pack = packXWith packWord8# + unpack = checkUnpackUndef unpackWord8# + +packWord8# :: Word8 -> BitVector 8 +packWord8# = fromIntegral +{-# NOINLINE packWord8# #-} +{-# ANN packWord8# hasBlackBox #-} + +unpackWord8# :: BitVector 8 -> Word8 +unpackWord8# = fromIntegral +{-# NOINLINE unpackWord8# #-} +{-# ANN unpackWord8# hasBlackBox #-} instance BitPack Word16 where type BitSize Word16 = 16 - pack = packXWith fromIntegral - unpack = checkUnpackUndef fromIntegral + pack = packXWith packWord16# + unpack = checkUnpackUndef unpackWord16# + +packWord16# :: Word16 -> BitVector 16 +packWord16# = fromIntegral +{-# NOINLINE packWord16# #-} +{-# ANN packWord16# hasBlackBox #-} + +unpackWord16# :: BitVector 16 -> Word16 +unpackWord16# = fromIntegral +{-# NOINLINE unpackWord16# #-} +{-# ANN unpackWord16# hasBlackBox #-} instance BitPack Word32 where type BitSize Word32 = 32 - pack = packXWith fromIntegral - unpack = checkUnpackUndef fromIntegral + pack = packXWith packWord32# + unpack = checkUnpackUndef unpackWord32# + +packWord32# :: Word32 -> BitVector 32 +packWord32# = fromIntegral +{-# NOINLINE packWord32# #-} +{-# ANN packWord32# hasBlackBox #-} + +unpackWord32# :: BitVector 32 -> Word32 +unpackWord32# = fromIntegral +{-# NOINLINE unpackWord32# #-} +{-# ANN unpackWord32# hasBlackBox #-} instance BitPack Word64 where type BitSize Word64 = 64 - pack = packXWith fromIntegral - unpack = checkUnpackUndef fromIntegral + pack = packXWith packWord64# + unpack = checkUnpackUndef unpackWord64# + +packWord64# :: Word64 -> BitVector 64 +packWord64# = fromIntegral +{-# NOINLINE packWord64# #-} +{-# ANN packWord64# hasBlackBox #-} + +unpackWord64# :: BitVector 64 -> Word64 +unpackWord64# = fromIntegral +{-# NOINLINE unpackWord64# #-} +{-# ANN unpackWord64# hasBlackBox #-} instance BitPack Float where type BitSize Float = 32 @@ -323,8 +414,18 @@ unpackDouble# (unsafeToNatural -> w) = wordToDouble (fromIntegral w) instance BitPack CUShort where type BitSize CUShort = 16 - pack = packXWith fromIntegral - unpack = checkUnpackUndef fromIntegral + pack = packXWith packCUShort# + unpack = checkUnpackUndef unpackCUShort# + +packCUShort# :: CUShort -> BitVector 16 +packCUShort# = fromIntegral +{-# NOINLINE packCUShort# #-} +{-# ANN packCUShort# hasBlackBox #-} + +unpackCUShort# :: BitVector 16 -> CUShort +unpackCUShort# = fromIntegral +{-# NOINLINE unpackCUShort# #-} +{-# ANN unpackCUShort# hasBlackBox #-} instance BitPack Half where type BitSize Half = 16 diff --git a/clash-prelude/src/Clash/XException.hs b/clash-prelude/src/Clash/XException.hs index 260a0fe7fa..a019b5143c 100644 --- a/clash-prelude/src/Clash/XException.hs +++ b/clash-prelude/src/Clash/XException.hs @@ -440,6 +440,9 @@ instance ShowX Word32 where instance ShowX Word64 where showsPrecX = showsPrecXWith showsPrec +instance ShowX CUShort where + showsPrecX = showsPrecXWith showsPrec + instance ShowX a => ShowX (Maybe a) instance ShowX a => ShowX (Ratio a) where diff --git a/tests/Main.hs b/tests/Main.hs index 9dffa51d49..0cca73d159 100755 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -416,6 +416,8 @@ runClashTest = defaultMain $ clashTestRoot , runTest "ReduceOne" def , runTest "ExtendingNumZero" def , runTest "AppendZero" def + , runTest "PackGHCNums" def + , runTest "UnpackGHCNums" def , runTest "GenericBitPack" def{clashFlags=["-fconstraint-solver-iterations=15"]} , runTest "UnpackUndefined" def{hdlSim=[]} ] diff --git a/tests/shouldwork/BitVector/BitPackGHCNumsConstants.hs b/tests/shouldwork/BitVector/BitPackGHCNumsConstants.hs new file mode 100644 index 0000000000..0be9bbc714 --- /dev/null +++ b/tests/shouldwork/BitVector/BitPackGHCNumsConstants.hs @@ -0,0 +1,40 @@ +module BitPackGHCNums where + +import Clash.Prelude +import Clash.Explicit.Testbench +import Data.Int +import Data.Word +import Foreign.C.Types + +i :: Int +i = 421 + +i8 :: Int8 +i8 = -123 + +i16 :: Int16 +i16 = 9685 + +i32 :: Int32 +i32 = -74275825 + +i64 :: Int64 +i64 = -4814814284 + +w :: Word +w = 87558 + +w8 :: Word8 +w8 = 213 + +w16 :: Word16 +w16 = 8585 + +w32 :: Word32 +w32 = 5485 + +w64 :: Word64 +w64 = 12303342142421 + +cu :: CUShort +cu = 41995 diff --git a/tests/shouldwork/BitVector/PackGHCNums.hs b/tests/shouldwork/BitVector/PackGHCNums.hs new file mode 100644 index 0000000000..e29fcdc6cc --- /dev/null +++ b/tests/shouldwork/BitVector/PackGHCNums.hs @@ -0,0 +1,100 @@ +module PackGHCNums where + +import BitPackGHCNumsConstants + +import Clash.Prelude +import Clash.Explicit.Testbench + +import Data.Int +import Data.Word +import Foreign.C.Types + +topEntity + :: ( Int + , Int8 + , Int16 + , Int32 + , Int64 + , Word + , Word8 + , Word16 + , Word32 + , Word64 + , CUShort + ) + -> BitVector 768 +topEntity (a, b, c, d, e, f, g, h, i, j, k) = + packed ++# packed + where + packed = + pack $ + ( pack a + , pack b + , pack c + , pack d + , pack e + , pack f + , pack g + , pack h + , pack i + , pack j + , pack k + ) +{-# NOINLINE topEntity #-} + +testBench :: Signal System Bool +testBench = done + where + testInput = + stimuliGenerator + clk + rst + ( ( i + , i8 + , i16 + , i32 + , i64 + , w + , w8 + , w16 + , w32 + , w64 + , cu + ) :> Nil) + + expectedOutput = + outputVerifier' + clk + rst + -- This used to be one big tuple. We split it up so we can get away with + -- -DMAX_TUPLE_SIZE=12, which considerably improves compilation speed of + -- clash-prelude + (pack ( ( $(lift (pack i)) + , $(lift (pack i8)) + , $(lift (pack i16)) + , $(lift (pack i32)) + , $(lift (pack i64)) + , $(lift (pack w)) + , $(lift (pack w8)) + , $(lift (pack w16)) + , $(lift (pack w32)) + , $(lift (pack w64)) + , $(lift (pack cu)) + ) + , ( $(bLit "0000000000000000000000000000000000000000000000000000000110100101") + , $(bLit "10000101") + , $(bLit "0010010111010101") + , $(bLit "11111011100100101010010000001111") + , $(bLit "1111111111111111111111111111111011100001000000111100001110110100") + , $(bLit "0000000000000000000000000000000000000000000000010101011000000110") + , $(bLit "11010101") + , $(bLit "0010000110001001") + , $(bLit "00000000000000000001010101101101") + , $(bLit "0000000000000000000010110011000010011000010101101000001111010101") + , $(bLit "1010010000001011") + ) + ) :> Nil) + + done = expectedOutput (topEntity <$> testInput) + clk = tbSystemClockGen (not <$> done) + rst = systemResetGen diff --git a/tests/shouldwork/BitVector/UnpackGHCNums.hs b/tests/shouldwork/BitVector/UnpackGHCNums.hs new file mode 100644 index 0000000000..f515aa472b --- /dev/null +++ b/tests/shouldwork/BitVector/UnpackGHCNums.hs @@ -0,0 +1,106 @@ +module UnpackGHCNums where + +import BitPackGHCNumsConstants + +import Clash.Prelude +import Clash.Explicit.Testbench + +import Data.Int +import Data.Word +import Foreign.C.Types + +topEntity + :: BitVector 768 + -> ( ( Int + , Int8 + , Int16 + , Int32 + , Int64 + , Word + , Word8 + , Word16 + , Word32 + , Word64 + , CUShort + ) + , ( Int + , Int8 + , Int16 + , Int32 + , Int64 + , Word + , Word8 + , Word16 + , Word32 + , Word64 + , CUShort + ) + ) +topEntity packed = (unpack left, unpack right) + where + (left, right) = split packed +{-# NOINLINE topEntity #-} + +testBench :: Signal System Bool +testBench = done + where + -- This used to be one big tuple. We split it up so we can get away with + -- -DMAX_TUPLE_SIZE=12, which considerably improves compilation speed of + -- clash-prelude + input = pack + ( ( $(lift (pack i)) + , $(lift (pack i8)) + , $(lift (pack i16)) + , $(lift (pack i32)) + , $(lift (pack i64)) + , $(lift (pack w)) + , $(lift (pack w8)) + , $(lift (pack w16)) + , $(lift (pack w32)) + , $(lift (pack w64)) + , $(lift (pack cu)) + ) + , ( $(bLit "0000000000000000000000000000000000000000000000000000000110100101") + , $(bLit "10000101") + , $(bLit "0010010111010101") + , $(bLit "11111011100100101010010000001111") + , $(bLit "1111111111111111111111111111111011100001000000111100001110110100") + , $(bLit "0000000000000000000000000000000000000000000000010101011000000110") + , $(bLit "11010101") + , $(bLit "0010000110001001") + , $(bLit "00000000000000000001010101101101") + , $(bLit "0000000000000000000010110011000010011000010101101000001111010101") + , $(bLit "1010010000001011") + ) + ) + + nums = ( i + , i8 + , i16 + , i32 + , i64 + , w + , w8 + , w16 + , w32 + , w64 + , cu + ) + + expected = (nums, nums) + + testInput = + stimuliGenerator + clk + rst + (input :> Nil) + + expectedOutput = + outputVerifier' + clk + rst + (expected :> Nil) + + done = expectedOutput (topEntity <$> testInput) + clk = tbSystemClockGen (not <$> done) + rst = systemResetGen