Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

unpack no longer warns #2397

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open

unpack no longer warns #2397

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
ec016d4
Unpack no longer warns
rowanG077 Jan 4, 2023
9ae8ee2
Add `ShowX` instance for `CUShort`.
rowanG077 Jan 4, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions changelog/2023-01-04T14_23_01+01_00_fix_2386
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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).
1 change: 1 addition & 0 deletions changelog/2023-01-04T14_23_01+01_00_showx_cushort
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
ADDED: Add `Clash.XException.ShowX` instance for `Foreign.C.Types.CUShort`.
257 changes: 249 additions & 8 deletions clash-ghc/src-ghc/Clash/GHC/Evaluator/Primitive.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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. <[email protected]>
-}
Expand Down Expand Up @@ -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)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Suggested change
, mach2@Machine{mStack=[],mTerm=Literal (Int8Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
, mach2@Machine{mStack=[],mTerm=Literal (Int8Literal i)} <-
whnf eval tcm True (setTerm arg $ stackClear mach)

Keeps the line limit sensible

#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
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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#"
Expand Down Expand Up @@ -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#"
Expand Down Expand Up @@ -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#"
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down
Loading