Skip to content

Commit 4f99788

Browse files
rowanG077rowanG077
committed
Unpack no longer warns
FIXED: Clash no longer gives `Dubious primitive instantiation warning` when using `unpack` [#2386](#2386).
1 parent 8d6a861 commit 4f99788

File tree

5 files changed

+545
-40
lines changed

5 files changed

+545
-40
lines changed

‎changelog/2023-01-04T14_23_01+01_00_fix_2386

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
FIXED: Clash no longer gives `Dubious primitive instantiation warning`
2+
when using `unpack` [#2386](https://github.com/clash-lang/clash-compiler/issues/2386).

‎clash-ghc/src-ghc/Clash/GHC/Evaluator/Primitive.hs

Lines changed: 269 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,8 @@
22
Copyright : (C) 2013-2016, University of Twente,
33
2016-2017, Myrtle Software Ltd,
44
2017-2022, Google Inc.,
5-
2017-2022, QBayLogic B.V.
5+
2017-2023, QBayLogic B.V.
6+
2023, LumiGuide Fietsdetectie B.V.
67
License : BSD2 (see the file LICENSE)
78
Maintainer : QBayLogic B.V. <[email protected]>
89
-}
@@ -2202,6 +2203,136 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
22022203
-> reduce (boolToBoolLiteral tcm ty (s1 == s2))
22032204
| otherwise -> error (show args)
22042205

2206+
"Clash.Class.BitPack.Internal.packInt8#" -- :: Int8 -> BitVector 8
2207+
| [DC _ [Left arg]] <- args
2208+
, eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
2209+
#if MIN_VERSION_base(4,16,0)
2210+
, mach2@Machine{mStack=[],mTerm=Literal (Int8Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2211+
#else
2212+
, mach2@Machine{mStack=[],mTerm=Literal (IntLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2213+
#endif
2214+
-> let resTyInfo = extractTySizeInfo tcm ty tys
2215+
in Just $ mach2
2216+
{ mStack = mStack mach
2217+
, mTerm = mkBitVectorLit' resTyInfo 0 i
2218+
}
2219+
| otherwise -> error (show args)
2220+
2221+
"Clash.Class.BitPack.Internal.packInt16#" -- :: Int16 -> BitVector 16
2222+
| [DC _ [Left arg]] <- args
2223+
, eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
2224+
#if MIN_VERSION_base(4,16,0)
2225+
, mach2@Machine{mStack=[],mTerm=Literal (Int16Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2226+
#else
2227+
, mach2@Machine{mStack=[],mTerm=Literal (IntLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2228+
#endif
2229+
-> let resTyInfo = extractTySizeInfo tcm ty tys
2230+
in Just $ mach2
2231+
{ mStack = mStack mach
2232+
, mTerm = mkBitVectorLit' resTyInfo 0 i
2233+
}
2234+
| otherwise -> error (show args)
2235+
2236+
"Clash.Class.BitPack.Internal.packInt32#" -- :: Int32 -> BitVector 32
2237+
| [DC _ [Left arg]] <- args
2238+
, eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
2239+
#if MIN_VERSION_base(4,16,0)
2240+
, mach2@Machine{mStack=[],mTerm=Literal (Int32Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2241+
#else
2242+
, mach2@Machine{mStack=[],mTerm=Literal (IntLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2243+
#endif
2244+
-> let resTyInfo = extractTySizeInfo tcm ty tys
2245+
in Just $ mach2
2246+
{ mStack = mStack mach
2247+
, mTerm = mkBitVectorLit' resTyInfo 0 i
2248+
}
2249+
| otherwise -> error (show args)
2250+
2251+
"Clash.Class.BitPack.Internal.packInt64#" -- :: Int64 -> BitVector 64
2252+
| [DC _ [Left arg]] <- args
2253+
, eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
2254+
#if MIN_VERSION_base(4,16,0)
2255+
, mach2@Machine{mStack=[],mTerm=Literal (Int64Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2256+
#else
2257+
, mach2@Machine{mStack=[],mTerm=Literal (IntLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2258+
#endif
2259+
-> let resTyInfo = extractTySizeInfo tcm ty tys
2260+
in Just $ mach2
2261+
{ mStack = mStack mach
2262+
, mTerm = mkBitVectorLit' resTyInfo 0 i
2263+
}
2264+
| otherwise -> error (show args)
2265+
2266+
"Clash.Class.BitPack.Internal.packWord#" -- :: Word -> BitVector WORD_SIZE_IN_BITS
2267+
| [DC _ [Left arg]] <- args
2268+
, eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
2269+
, mach2@Machine{mStack=[],mTerm=Literal (WordLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2270+
-> let resTyInfo = extractTySizeInfo tcm ty tys
2271+
in Just $ mach2
2272+
{ mStack = mStack mach
2273+
, mTerm = mkBitVectorLit' resTyInfo 0 i
2274+
}
2275+
| otherwise -> error (show args)
2276+
2277+
"Clash.Class.BitPack.Internal.packWord8#" -- :: Word8 -> BitVector 8
2278+
| [DC _ [Left arg]] <- args
2279+
, eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
2280+
#if MIN_VERSION_base(4,16,0)
2281+
, mach2@Machine{mStack=[],mTerm=Literal (Word8Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2282+
#else
2283+
, mach2@Machine{mStack=[],mTerm=Literal (WordLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2284+
#endif
2285+
-> let resTyInfo = extractTySizeInfo tcm ty tys
2286+
in Just $ mach2
2287+
{ mStack = mStack mach
2288+
, mTerm = mkBitVectorLit' resTyInfo 0 i
2289+
}
2290+
| otherwise -> error (show args)
2291+
2292+
"Clash.Class.BitPack.Internal.packWord16#" -- :: Word16 -> BitVector 16
2293+
| [DC _ [Left arg]] <- args
2294+
, eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
2295+
#if MIN_VERSION_base(4,16,0)
2296+
, mach2@Machine{mStack=[],mTerm=Literal (Word16Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2297+
#else
2298+
, mach2@Machine{mStack=[],mTerm=Literal (WordLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2299+
#endif
2300+
-> let resTyInfo = extractTySizeInfo tcm ty tys
2301+
in Just $ mach2
2302+
{ mStack = mStack mach
2303+
, mTerm = mkBitVectorLit' resTyInfo 0 i
2304+
}
2305+
| otherwise -> error (show args)
2306+
2307+
"Clash.Class.BitPack.Internal.packWord32#" -- :: Word32 -> BitVector 32
2308+
| [DC _ [Left arg]] <- args
2309+
, eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
2310+
#if MIN_VERSION_base(4,16,0)
2311+
, mach2@Machine{mStack=[],mTerm=Literal (Word32Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2312+
#else
2313+
, mach2@Machine{mStack=[],mTerm=Literal (WordLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2314+
#endif
2315+
-> let resTyInfo = extractTySizeInfo tcm ty tys
2316+
in Just $ mach2
2317+
{ mStack = mStack mach
2318+
, mTerm = mkBitVectorLit' resTyInfo 0 i
2319+
}
2320+
| otherwise -> error (show args)
2321+
2322+
"Clash.Class.BitPack.Internal.packWord64#" -- :: Word64 -> BitVector 64
2323+
| [DC _ [Left arg]] <- args
2324+
, eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
2325+
#if MIN_VERSION_base(4,16,0)
2326+
, mach2@Machine{mStack=[],mTerm=Literal (Word64Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2327+
#else
2328+
, mach2@Machine{mStack=[],mTerm=Literal (WordLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2329+
#endif
2330+
-> let resTyInfo = extractTySizeInfo tcm ty tys
2331+
in Just $ mach2
2332+
{ mStack = mStack mach
2333+
, mTerm = mkBitVectorLit' resTyInfo 0 i
2334+
}
2335+
| otherwise -> error (show args)
22052336

22062337
"Clash.Class.BitPack.Internal.packDouble#" -- :: Double -> BitVector 64
22072338
| [DC _ [Left arg]] <- args
@@ -2223,6 +2354,124 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
22232354
, mTerm = mkBitVectorLit' resTyInfo 0 (toInteger $ (pack :: Word32 -> BitVector 32) i)
22242355
}
22252356

2357+
"Clash.Class.BitPack.Internal.packCUShort#" -- :: CUShort -> BitVector 16
2358+
| [DC _ [Left arg]] <- args
2359+
, eval <- Evaluator ghcStep ghcUnwind ghcPrimStep ghcPrimUnwind
2360+
#if MIN_VERSION_base(4,16,0)
2361+
, mach2@Machine{mStack=[],mTerm=Literal (Word16Literal i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2362+
#else
2363+
, mach2@Machine{mStack=[],mTerm=Literal (WordLiteral i)} <- whnf eval tcm True (setTerm arg $ stackClear mach)
2364+
#endif
2365+
-> let resTyInfo = extractTySizeInfo tcm ty tys
2366+
in Just $ mach2
2367+
{ mStack = mStack mach
2368+
, mTerm = mkBitVectorLit' resTyInfo 0 i
2369+
}
2370+
| otherwise -> error (show args)
2371+
2372+
"Clash.Class.BitPack.Internal.unpackInt8#" -- BitVector 8 -> Int8
2373+
| [i] <- bitVectorLiterals' args
2374+
-> let resTy = getResultTy tcm ty tys
2375+
val = toInteger (unpack (toBV i) :: Signed 8)
2376+
#if MIN_VERSION_base(4,16,0)
2377+
proj = Int8Literal
2378+
#else
2379+
proj = IntLiteral
2380+
#endif
2381+
in reduce (mkIntCLit tcm proj val resTy)
2382+
| otherwise -> error (show args)
2383+
2384+
"Clash.Class.BitPack.Internal.unpackInt16#" -- BitVector 16 -> Int16
2385+
| [i] <- bitVectorLiterals' args
2386+
-> let resTy = getResultTy tcm ty tys
2387+
val = toInteger (unpack (toBV i) :: Signed 16)
2388+
#if MIN_VERSION_base(4,16,0)
2389+
proj = Int16Literal
2390+
#else
2391+
proj = IntLiteral
2392+
#endif
2393+
in reduce (mkIntCLit tcm proj val resTy)
2394+
| otherwise -> error (show args)
2395+
2396+
"Clash.Class.BitPack.Internal.unpackInt32#" -- BitVector 32 -> Int32
2397+
| [i] <- bitVectorLiterals' args
2398+
-> let resTy = getResultTy tcm ty tys
2399+
val = toInteger (unpack (toBV i) :: Signed 32)
2400+
#if MIN_VERSION_base(4,16,0)
2401+
proj = Int32Literal
2402+
#else
2403+
proj = IntLiteral
2404+
#endif
2405+
in reduce (mkIntCLit tcm proj val resTy)
2406+
| otherwise -> error (show args)
2407+
2408+
"Clash.Class.BitPack.Internal.unpackInt64#" -- BitVector 64 -> Int64
2409+
| [i] <- bitVectorLiterals' args
2410+
-> let resTy = getResultTy tcm ty tys
2411+
val = toInteger (unpack (toBV i) :: Signed 64)
2412+
#if MIN_VERSION_base(4,16,0)
2413+
proj = Int64Literal
2414+
#else
2415+
proj = IntLiteral
2416+
#endif
2417+
in reduce (mkIntCLit tcm proj val resTy)
2418+
| otherwise -> error (show args)
2419+
2420+
"Clash.Class.BitPack.Internal.unpackWord#" -- BitVector WORD_SIZE_IN_BITS -> Word
2421+
| [i] <- bitVectorLiterals' args
2422+
-> let resTy = getResultTy tcm ty tys
2423+
val = toInteger (unpack (toBV i) :: Unsigned 64)
2424+
in reduce (mkIntCLit tcm WordLiteral val resTy)
2425+
| otherwise -> error (show args)
2426+
2427+
"Clash.Class.BitPack.Internal.unpackWord8#" -- BitVector 8 -> Word8
2428+
| [i] <- bitVectorLiterals' args
2429+
-> let resTy = getResultTy tcm ty tys
2430+
val = toInteger (unpack (toBV i) :: Unsigned 8)
2431+
#if MIN_VERSION_base(4,16,0)
2432+
proj = Word8Literal
2433+
#else
2434+
proj = WordLiteral
2435+
#endif
2436+
in reduce (mkIntCLit tcm proj val resTy)
2437+
| otherwise -> error (show args)
2438+
2439+
"Clash.Class.BitPack.Internal.unpackWord16#" -- BitVector 16 -> Word16
2440+
| [i] <- bitVectorLiterals' args
2441+
-> let resTy = getResultTy tcm ty tys
2442+
val = toInteger (unpack (toBV i) :: Unsigned 16)
2443+
#if MIN_VERSION_base(4,16,0)
2444+
proj = Word16Literal
2445+
#else
2446+
proj = WordLiteral
2447+
#endif
2448+
in reduce (mkIntCLit tcm proj val resTy)
2449+
| otherwise -> error (show args)
2450+
2451+
"Clash.Class.BitPack.Internal.unpackWord32#" -- BitVector 32 -> Word32
2452+
| [i] <- bitVectorLiterals' args
2453+
-> let resTy = getResultTy tcm ty tys
2454+
val = toInteger (unpack (toBV i) :: Unsigned 32)
2455+
#if MIN_VERSION_base(4,16,0)
2456+
proj = Word32Literal
2457+
#else
2458+
proj = WordLiteral
2459+
#endif
2460+
in reduce (mkIntCLit tcm proj val resTy)
2461+
| otherwise -> error (show args)
2462+
2463+
"Clash.Class.BitPack.Internal.unpackWord64#" -- BitVector 64 -> Word64
2464+
| [i] <- bitVectorLiterals' args
2465+
-> let resTy = getResultTy tcm ty tys
2466+
val = toInteger (unpack (toBV i) :: Unsigned 64)
2467+
#if MIN_VERSION_base(4,16,0)
2468+
proj = Word64Literal
2469+
#else
2470+
proj = WordLiteral
2471+
#endif
2472+
in reduce (mkIntCLit tcm proj val resTy)
2473+
| otherwise -> error (show args)
2474+
22262475
"Clash.Class.BitPack.Internal.unpackFloat#"
22272476
| [i] <- bitVectorLiterals' args
22282477
-> let resTy = getResultTy tcm ty tys
@@ -2235,6 +2484,18 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
22352484
val = unpack (toBV i :: BitVector 64)
22362485
in reduce (mkDoubleCLit tcm val resTy)
22372486

2487+
"Clash.Class.BitPack.Internal.unpackCUShort#"
2488+
| [i] <- bitVectorLiterals' args
2489+
-> let resTy = getResultTy tcm ty tys
2490+
val = toInteger (unpack (toBV i) :: Unsigned 16)
2491+
#if MIN_VERSION_base(4,16,0)
2492+
proj = Word16Literal
2493+
#else
2494+
proj = WordLiteral
2495+
#endif
2496+
in reduce (mkIntCLit tcm proj val resTy)
2497+
| otherwise -> error (show args)
2498+
22382499
"Clash.Class.BitPack.Internal.xToBV"
22392500
| isSubj
22402501
, Just (nTy, kn) <- extractKnownNat tcm tys
@@ -2793,7 +3054,7 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
27933054
"Clash.Sized.Internal.Index.fromEnum#"
27943055
| [i] <- indexLiterals' args
27953056
-> let resTy = getResultTy tcm ty tys
2796-
in reduce (mkIntCLit tcm i resTy)
3057+
in reduce (mkIntCLit tcm IntLiteral i resTy)
27973058

27983059
-- Bounded
27993060
"Clash.Sized.Internal.Index.maxBound#"
@@ -2910,7 +3171,7 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
29103171
"Clash.Sized.Internal.Signed.fromEnum#"
29113172
| [i] <- signedLiterals' args
29123173
-> let resTy = getResultTy tcm ty tys
2913-
in reduce (mkIntCLit tcm i resTy)
3174+
in reduce (mkIntCLit tcm IntLiteral i resTy)
29143175

29153176
-- Bounded
29163177
"Clash.Sized.Internal.Signed.minBound#"
@@ -3128,7 +3389,7 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
31283389
"Clash.Sized.Internal.Unsigned.fromEnum#"
31293390
| [i] <- unsignedLiterals' args
31303391
-> let resTy = getResultTy tcm ty tys
3131-
in reduce (mkIntCLit tcm i resTy)
3392+
in reduce (mkIntCLit tcm IntLiteral i resTy)
31323393

31333394
-- Bounded
31343395
"Clash.Sized.Internal.Unsigned.minBound#"
@@ -4709,9 +4970,9 @@ bitVectorLitIntLit tcm tys args
47094970
| otherwise
47104971
= Nothing
47114972

4712-
mkIntCLit :: TyConMap -> Integer -> Type -> Term
4713-
mkIntCLit tcm lit resTy =
4714-
App (Data intDc) (Literal (IntLiteral lit))
4973+
mkIntCLit :: TyConMap -> (Integer -> Literal) -> Integer -> Type -> Term
4974+
mkIntCLit tcm proj lit resTy =
4975+
App (Data intDc) (Literal (proj lit))
47154976
where
47164977
(_, tyView -> TyConApp intTcNm []) = splitFunForallTy resTy
47174978
Just intTc = UniqMap.lookup intTcNm tcm
@@ -5045,7 +5306,7 @@ liftBitVector2CInt
50455306
liftBitVector2CInt tcm resTy f args _p
50465307
| [i] <- bitVectorLiterals' args
50475308
= let val = f (toBV i)
5048-
in Just $ mkIntCLit tcm val resTy
5309+
in Just $ mkIntCLit tcm IntLiteral val resTy
50495310
| otherwise
50505311
= Nothing
50515312

0 commit comments

Comments
 (0)