Use Int instead of Int# in toEnum / fromEnum prims (#2127)

* Add test for #2126

* Use Int instead of Int# in toEnum / fromEnum prims

In the primitives for conversion to / from Enum introduced in 0613f21,
the definitions are converting to / from Int# instead of Int as the
type of the functions demands. This is not correct, and means that
conversion to the enum type will never fire (as the argument is always
a boxed int instead of an unboxed int), and the conversion from the
enum type to Int will result in an ill-typed expression being output
which can lead to

    case 1# of
      I# x -> ...

which are obviously bogus.

Author: Alex McKenna

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

@@ -1925,7 +1925,7 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
 
 -- Enum
   "Clash.Sized.Internal.BitVector.toEnum##"
-    | [i] <- intLiterals' args
+    | [i] <- intCLiterals' args
     -> let Bit msk val = BitVector.toEnum## (fromInteger i)
        in reduce (mkBitLit ty (toInteger msk) (toInteger val))
 
@@ -2140,7 +2140,8 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
 
   "Clash.Sized.Internal.BitVector.fromEnum#"
     | Just (_, kn) <- extractKnownNat tcm tys
-    , Just val <- reifyNat kn (liftBitVector2Int (toInteger . BitVector.fromEnum#) args)
+    , let resTy = getResultTy tcm ty tys
+    , Just val <- reifyNat kn (liftBitVector2CInt tcm resTy (toInteger . BitVector.fromEnum#) args)
     -> reduce val
 
 -- Bounded
@@ -2317,13 +2318,14 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
 
 -- Enum
   "Clash.Sized.Internal.Index.toEnum#"
-    | [i] <- intLiterals' args
+    | [i] <- intCLiterals' args
     , Just (nTy, mb) <- extractKnownNat tcm tys
     -> reduce (mkIndexLit ty nTy mb i)
 
   "Clash.Sized.Internal.Index.fromEnum#"
     | [i] <- indexLiterals' args
-    -> reduce (integerToIntLiteral i)
+    -> let resTy = getResultTy tcm ty tys
+        in reduce (mkIntCLit tcm i resTy)
 
 -- Bounded
   "Clash.Sized.Internal.Index.maxBound#"
@@ -2433,13 +2435,14 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
 
 -- Enum
   "Clash.Sized.Internal.Signed.toEnum#"
-    | [i] <- intLiterals' args
+    | [i] <- intCLiterals' args
     , Just (litTy, mb) <- extractKnownNat tcm tys
     -> reduce (mkSignedLit ty litTy mb i)
 
   "Clash.Sized.Internal.Signed.fromEnum#"
     | [i] <- signedLiterals' args
-    -> reduce (integerToIntLiteral i)
+    -> let resTy = getResultTy tcm ty tys
+        in reduce (mkIntCLit tcm i resTy)
 
 -- Bounded
   "Clash.Sized.Internal.Signed.minBound#"
@@ -2650,13 +2653,14 @@ ghcPrimStep tcm isSubj pInfo tys args mach = case primName pInfo of
 
 -- Enum
   "Clash.Sized.Internal.Unsigned.toEnum#"
-    | [i] <- intLiterals' args
+    | [i] <- intCLiterals' args
     , Just (litTy, mb) <- extractKnownNat tcm tys
     -> reduce (mkUnsignedLit ty litTy mb i)
 
   "Clash.Sized.Internal.Unsigned.fromEnum#"
     | [i] <- unsignedLiterals' args
-    -> reduce (integerToIntLiteral i)
+    -> let resTy = getResultTy tcm ty tys
+        in reduce (mkIntCLit tcm i resTy)
 
 -- Bounded
   "Clash.Sized.Internal.Unsigned.minBound#"
@@ -4047,6 +4051,9 @@ intLiterals = pairOf intLiteral
 intLiterals' :: [Value] -> [Integer]
 intLiterals' = listOf intLiteral
 
+intCLiterals' :: [Value] -> [Integer]
+intCLiterals' = listOf intCLiteral
+
 intLiteral :: Value -> Maybe Integer
 intLiteral x = case x of
   Lit (IntLiteral i) -> Just i
@@ -4182,6 +4189,14 @@ bitVectorLitIntLit tcm tys args
   | otherwise
   = Nothing
 
+mkIntCLit :: TyConMap -> Integer -> Type -> Term
+mkIntCLit tcm lit resTy =
+  App (Data intDc) (Literal (IntLiteral lit))
+ where
+  (_, tyView -> TyConApp intTcNm []) = splitFunForallTy resTy
+  Just intTc = lookupUniqMap intTcNm tcm
+  [intDc] = tyConDataCons intTc
+
 mkFloatCLit :: TyConMap -> Word32 -> Type -> Term
 mkFloatCLit tcm lit resTy =
   App (Data floatDc) (Literal (FloatLiteral lit))
@@ -4468,22 +4483,24 @@ liftInteger2BitVector
   -> [Value]
   -> (Proxy n -> Maybe Term)
 liftInteger2BitVector f resTyInfo args _p
-  | [i] <- intLiterals' args
+  | [i] <- intCLiterals' args
   = let BV msk val = f i
      in Just (mkBitVectorLit' resTyInfo (toInteger msk) (toInteger val))
 
   | otherwise
   = Nothing
 
-liftBitVector2Int
+liftBitVector2CInt
   :: KnownNat n
-  => (BitVector n -> Integer)
+  => TyConMap
+  -> Type
+  -> (BitVector n -> Integer)
   -> [Value]
   -> (Proxy n -> Maybe Term)
-liftBitVector2Int f args _p
+liftBitVector2CInt tcm resTy f args _p
   | [i] <- bitVectorLiterals' args
   = let val = f (toBV i)
-     in Just $ integerToIntLiteral val
+     in Just $ mkIntCLit tcm val resTy
   | otherwise
   = Nothing
 

tests/Main.hs

@@ -567,6 +567,7 @@ runClashTest = defaultMain $ clashTestRoot
             , buildTargets=BuildSpecific["top_bit", "top_bitvector", "top_index", "top_signed", "top_unsigned"]
             }
         , runTest "T2046B" def{clashFlags=["-Werror"]}
+        , runTest "T2046C" def{hdlSim=False,clashFlags=["-Werror"],buildTargets=BuildSpecific["topEntity"]}
         , runTest "T2097" def{hdlSim=False}
         ] <>
         if compiledWith == Cabal then

tests/shouldwork/Issues/T2046B.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE ViewPatterns #-}
-
 module T2046B where
 
 import Clash.Prelude

tests/shouldwork/Issues/T2046BType.hs

@@ -9,3 +9,12 @@ type T2046B =
   , (BitVector 1, BitVector 2)
   , Bit
   )
+
+type T2046C =
+  ( (Int, Int)
+  , (Int, Int)
+  , (Int, Int)
+  , (Int, Int)
+  , Int
+  )
+

tests/shouldwork/Issues/T2046C.hs

@@ -0,0 +1,21 @@
+module T2046C where
+
+import Clash.Prelude
+import T2046BType
+
+inBit :: (Enum a) => a -> Bool
+inBit x = case fromEnum x of
+        0 -> True
+        1 -> True
+        _ -> False
+
+topEntity :: Bool
+topEntity =
+  let ((a,b),(c,d),(e,f),(g,h),i) = ((0,1),(0,1),(0,1),(0,1),0) :: T2046B
+   in and [ inBit a, inBit b
+          , inBit c, inBit d
+          , inBit e, inBit f
+          , inBit g, inBit h
+          , inBit i
+          ]
+