Unpack no longer warns

FIXED: Clash no longer gives `Dubious primitive instantiation warning` when using `unpack` [#2386](#2386).
clash-lang · Jan 4, 2023 · 6bdbd9c · 6bdbd9c
1 parent 8d6a861
commit 6bdbd9c
Show file tree

Hide file tree

Showing 5 changed files with 500 additions and 40 deletions.
diff --git a/changelog/2023-01-04T14_23_01+01_00_fix_2386 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/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. <[email protected]>
 -}
@@ -2202,6 +2203,136 @@ 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_ghc(8,8,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
+              }
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.packInt16#" -- :: Int16 -> BitVector 16
+    | [DC _ [Left arg]] <- args
+      , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
+#if MIN_VERSION_ghc(8,8,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
+              }
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.packInt32#" -- :: Int32 -> BitVector 32
+    | [DC _ [Left arg]] <- args
+      , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
+#if MIN_VERSION_ghc(8,8,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
+              }
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.packInt64#" -- :: Int64 -> BitVector 64
+    | [DC _ [Left arg]] <- args
+      , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
+#if MIN_VERSION_ghc(8,8,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
+              }
+    | otherwise -> error (show args)
+
+  "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
+              }
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.packWord8#" -- :: Word8 -> BitVector 8
+    | [DC _ [Left arg]] <- args
+      , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
+#if MIN_VERSION_ghc(8,8,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
+              }
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.packWord16#" -- :: Word16 -> BitVector 16
+    | [DC _ [Left arg]] <- args
+      , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
+#if MIN_VERSION_ghc(8,8,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
+              }
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.packWord32#" -- :: Word32 -> BitVector 32
+    | [DC _ [Left arg]] <- args
+      , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
+#if MIN_VERSION_ghc(8,8,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
+              }
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.packWord64#" -- :: Word64 -> BitVector 64
+    | [DC _ [Left arg]] <- args
+      , eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
+#if MIN_VERSION_ghc(8,8,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
+              }
+    | otherwise -> error (show args)
 
   "Clash.Class.BitPack.Internal.packDouble#" -- :: Double -> BitVector 64
     | [DC _ [Left arg]] <- args
@@ -2223,6 +2354,84 @@ 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_ghc(8,8,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
+              }
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.unpackInt8#" -- BitVector 8 -> Int8
+    | [i] <- bitVectorLiterals' args
+    -> let resTy = getResultTy tcm ty tys
+           val = toInteger (unpack (toBV i) :: Signed 8)
+        in reduce (mkIntCLit tcm Int8Literal val resTy)
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.unpackInt16#" -- BitVector 16 -> Int16
+    | [i] <- bitVectorLiterals' args
+    -> let resTy = getResultTy tcm ty tys
+           val = toInteger (unpack (toBV i) :: Signed 16)
+        in reduce (mkIntCLit tcm Int16Literal val resTy)
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.unpackInt32#" -- BitVector 32 -> Int32
+    | [i] <- bitVectorLiterals' args
+    -> let resTy = getResultTy tcm ty tys
+           val = toInteger (unpack (toBV i) :: Signed 32)
+        in reduce (mkIntCLit tcm Int32Literal val resTy)
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.unpackInt64#" -- BitVector 64 -> Int64
+    | [i] <- bitVectorLiterals' args
+    -> let resTy = getResultTy tcm ty tys
+           val = toInteger (unpack (toBV i) :: Signed 64)
+        in reduce (mkIntCLit tcm Int64Literal val resTy)
+    | otherwise -> error (show args)
+
+  "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)
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.unpackWord8#" -- BitVector 8 -> Word8
+    | [i] <- bitVectorLiterals' args
+    -> let resTy = getResultTy tcm ty tys
+           val = toInteger (unpack (toBV i) :: Unsigned 8)
+        in reduce (mkIntCLit tcm Word8Literal val resTy)
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.unpackWord16#" -- BitVector 16 -> Word16
+    | [i] <- bitVectorLiterals' args
+    -> let resTy = getResultTy tcm ty tys
+           val = toInteger (unpack (toBV i) :: Unsigned 16)
+        in reduce (mkIntCLit tcm Word16Literal val resTy)
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.unpackWord32#" -- BitVector 32 -> Word32
+    | [i] <- bitVectorLiterals' args
+    -> let resTy = getResultTy tcm ty tys
+           val = toInteger (unpack (toBV i) :: Unsigned 32)
+        in reduce (mkIntCLit tcm Word32Literal val resTy)
+    | otherwise -> error (show args)
+
+  "Clash.Class.BitPack.Internal.unpackWord64#" -- BitVector 64 -> Word64
+    | [i] <- bitVectorLiterals' args
+    -> let resTy = getResultTy tcm ty tys
+           val = toInteger (unpack (toBV i) :: Unsigned 64)
+        in reduce (mkIntCLit tcm Word64Literal val resTy)
+    | otherwise -> error (show args)
+
   "Clash.Class.BitPack.Internal.unpackFloat#"
     | [i] <- bitVectorLiterals' args
     -> let resTy = getResultTy tcm ty tys
@@ -2235,6 +2444,13 @@ 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)
+        in reduce (mkIntCLit tcm Word16Literal val resTy)
+    | otherwise -> error (show args)
+
   "Clash.Class.BitPack.Internal.xToBV"
     | isSubj
     , Just (nTy, kn) <- extractKnownNat tcm tys
@@ -2793,7 +3009,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 +3126,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 +3344,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 +4925,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 +5261,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
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).