Rules for sized conversion primops (#19769)

Metric Decrease:
    T12545

11 files changed, 337 insertions, 28 deletions

diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index a1ada95b5f..0f17bbc64a 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -558,13 +558,10 @@ primOpRules nm = \case
    Int32ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
    Int64ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
    IntToInt8Op    -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit
-                                       , semiInversePrimOp Int8ToIntOp
                                        , narrowSubsumesAnd IntAndOp IntToInt8Op 8 ]
    IntToInt16Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt16Lit
-                                       , semiInversePrimOp Int16ToIntOp
                                        , narrowSubsumesAnd IntAndOp IntToInt16Op 16 ]
    IntToInt32Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit
-                                       , semiInversePrimOp Int32ToIntOp
                                        , narrowSubsumesAnd IntAndOp IntToInt32Op 32 ]
    IntToInt64Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit ]
 
@@ -580,37 +577,24 @@ primOpRules nm = \case
    Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit ]
 
    WordToWord8Op  -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit
-                                       , semiInversePrimOp Word8ToWordOp
                                        , narrowSubsumesAnd WordAndOp WordToWord8Op 8 ]
    WordToWord16Op -> mkPrimOpRule nm 1 [ liftLit narrowWord16Lit
-                                       , semiInversePrimOp Word16ToWordOp
                                        , narrowSubsumesAnd WordAndOp WordToWord16Op 16 ]
    WordToWord32Op -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit
-                                       , semiInversePrimOp Word32ToWordOp
                                        , narrowSubsumesAnd WordAndOp WordToWord32Op 32 ]
    WordToWord64Op -> mkPrimOpRule nm 1 [ liftLit narrowWord64Lit ]
 
-   Word8ToInt8Op  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt8)
-                                       , semiInversePrimOp Int8ToWord8Op ]
-   Int8ToWord8Op  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord8)
-                                       , semiInversePrimOp Word8ToInt8Op ]
-   Word16ToInt16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt16)
-                                       , semiInversePrimOp Int16ToWord16Op ]
-   Int16ToWord16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord16)
-                                       , semiInversePrimOp Word16ToInt16Op ]
-   Word32ToInt32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt32)
-                                       , semiInversePrimOp Int32ToWord32Op ]
-   Int32ToWord32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord32)
-                                       , semiInversePrimOp Word32ToInt32Op ]
-   Word64ToInt64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt64)
-                                       , semiInversePrimOp Int64ToWord64Op ]
-   Int64ToWord64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord64)
-                                       , semiInversePrimOp Word64ToInt64Op ]
-
-   WordToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt)
-                                       , semiInversePrimOp IntToWordOp ]
-   IntToWordOp    -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord)
-                                       , semiInversePrimOp WordToIntOp ]
+   Word8ToInt8Op  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt8) ]
+   Int8ToWord8Op  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord8) ]
+   Word16ToInt16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt16) ]
+   Int16ToWord16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord16) ]
+   Word32ToInt32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt32) ]
+   Int32ToWord32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord32) ]
+   Word64ToInt64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt64) ]
+   Int64ToWord64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord64) ]
+
+   WordToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt) ]
+   IntToWordOp    -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord) ]
 
    Narrow8IntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt8)
                                        , subsumedByPrimOp Narrow8IntOp
diff --git a/libraries/ghc-prim/GHC/Prim/Ext.hs b/libraries/ghc-prim/GHC/Prim/Ext.hs
index 5ef6ff4ab0..e581e66dd7 100644
--- a/libraries/ghc-prim/GHC/Prim/Ext.hs
+++ b/libraries/ghc-prim/GHC/Prim/Ext.hs
@@ -5,6 +5,8 @@
 {-# LANGUAGE GHCForeignImportPrim #-}
 {-# LANGUAGE UnliftedFFITypes #-}
 
+{-# OPTIONS_GHC -Wno-orphans -Wno-inline-rule-shadowing #-}
+
 -- We need platform defines (tests for mingw32 below).
 #include "ghcplatform.h"
 #include "MachDeps.h"
@@ -103,3 +105,147 @@ foreign import prim "stg_asyncDoProczh" asyncDoProc#
 foreign import prim "stg_getThreadAllocationCounterzh" getThreadAllocationCounter#
   :: State# RealWorld
   -> (# State# RealWorld, INT64 #)
+
+------------------------------------------------------------------------
+-- Rules for primops that don't need to be built-in
+------------------------------------------------------------------------
+
+-- All these rules are used to remove useless casts:
+--
+--  1. passing through a type with at least the same bit size:
+--    e.g. Int8# -> Int# -> Int8#
+--         ==> id
+--
+--  2. passing through a (un)signed type of the same bit size:
+--    e.g. Word# -> Int# -> Word#
+--         ==> id
+--
+--  3. one of the previous cases with signedness change:
+--    e.g. Int8# -> Int# -> Word# -> Word8#
+--         ==> Int8# -> Word8#
+--
+
+
+-- case 1:
+-- ~~~~~~~
+
+{-# RULES
+
+"Int8# -> Int# -> Int8#"
+  forall x . intToInt8# (int8ToInt# x) = x
+
+"Int16# -> Int# -> Int16#"
+  forall x . intToInt16# (int16ToInt# x) = x
+
+"Int32# -> Int# -> Int32#"
+  forall x . intToInt32# (int32ToInt# x) = x
+
+
+"Word8# -> Word# -> Word8#"
+  forall x . wordToWord8# (word8ToWord# x) = x
+
+"Word16# -> Word# -> Word16#"
+  forall x . wordToWord16# (word16ToWord# x) = x
+
+"Word32# -> Word# -> Word32#"
+  forall x . wordToWord32# (word32ToWord# x) = x
+
+
+"Int# -> Int64# -> Int#"
+  forall x . int64ToInt# (intToInt64# x) = x
+
+"Word# -> Word64# -> Word#"
+  forall x . word64ToWord# (wordToWord64# x) = x
+
+#-}
+
+#if WORD_SIZE_IN_BITS == 64
+{-# RULES
+
+"Int64# -> Int# -> Int64#"
+  forall x . intToInt64# (int64ToInt# x) = x
+
+"Word64# -> Word# -> Word64#"
+  forall x . wordToWord64# (word64ToWord# x) = x
+
+#-}
+#endif
+
+
+-- case 2:
+-- ~~~~~~~
+
+{-# RULES
+
+"Word# -> Int# -> Word#"
+  forall x . int2Word# (word2Int# x) = x
+
+"Int# -> Word# -> Int#"
+  forall x . word2Int# (int2Word# x) = x
+
+"Int8# -> Word8# -> Int8#"
+  forall x . word8ToInt8# (int8ToWord8# x) = x
+
+"Word8# -> Int8# -> Word8#"
+  forall x . int8ToWord8# (word8ToInt8# x) = x
+
+"Int16# -> Word16# -> Int16#"
+  forall x . word16ToInt16# (int16ToWord16# x) = x
+
+"Word16# -> Int16# -> Word16#"
+  forall x . int16ToWord16# (word16ToInt16# x) = x
+
+"Int32# -> Word32# -> Int32#"
+  forall x . word32ToInt32# (int32ToWord32# x) = x
+
+"Word32# -> Int32# -> Word32#"
+  forall x . int32ToWord32# (word32ToInt32# x) = x
+
+"Int64# -> Word64# -> Int64#"
+  forall x . word64ToInt64# (int64ToWord64# x) = x
+
+"Word64# -> Int64# -> Word64#"
+  forall x . int64ToWord64# (word64ToInt64# x) = x
+
+#-}
+
+-- case 3:
+-- ~~~~~~~
+
+{-# RULES
+
+"Int8# -> Int# -> Word# -> Word8#"
+  forall x . wordToWord8# (int2Word# (int8ToInt# x)) = int8ToWord8# x
+
+"Int16# -> Int# -> Word# -> Word16#"
+  forall x . wordToWord16# (int2Word# (int16ToInt# x)) = int16ToWord16# x
+
+"Int32# -> Int# -> Word# -> Word32#"
+  forall x . wordToWord32# (int2Word# (int32ToInt# x)) = int32ToWord32# x
+
+"Word8# -> Word# -> Int# -> Int8#"
+  forall x . intToInt8# (word2Int# (word8ToWord# x)) = word8ToInt8# x
+
+"Word16# -> Word# -> Int# -> Int16#"
+  forall x . intToInt16# (word2Int# (word16ToWord# x)) = word16ToInt16# x
+
+"Word32# -> Word# -> Int# -> Int32#"
+  forall x . intToInt32# (word2Int# (word32ToWord# x)) = word32ToInt32# x
+
+"Word# -> Word64# -> Int64# -> Int#"
+  forall x. int64ToInt# (word64ToInt64# (wordToWord64# x)) = word2Int# x
+
+"Int# -> Int64# -> Word64# -> Word#"
+  forall x. word64ToWord# (int64ToWord64# (intToInt64# x)) = int2Word# x
+
+#-}
+
+#if WORD_SIZE_IN_BITS == 64
+{-# RULES
+"Int64# -> Int# -> Word# -> Word64#"
+  forall x . wordToWord64# (int2Word# (int64ToInt# x)) = int64ToWord64# x
+
+"Word64# -> Word# -> Int# -> Int64#"
+  forall x . intToInt64# (word2Int# (word64ToWord# x)) = word64ToInt64# x
+#-}
+#endif
diff --git a/testsuite/tests/numeric/should_compile/T19769.hs b/testsuite/tests/numeric/should_compile/T19769.hs
new file mode 100644
index 0000000000..b301c1d415
--- /dev/null
+++ b/testsuite/tests/numeric/should_compile/T19769.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE MagicHash #-}
+
+module T19769 where
+
+import GHC.Exts
+
+wi8 :: Word8# -> Int8#
+wi8 x = intToInt8# (word2Int# (word8ToWord# x))
+
+wi16 :: Word16# -> Int16#
+wi16 x = intToInt16# (word2Int# (word16ToWord# x))
+
+wi32 :: Word32# -> Int32#
+wi32 x = intToInt32# (word2Int# (word32ToWord# x))
+
+wi64 :: Word64# -> Int64#
+wi64 x = intToInt64# (word2Int# (word64ToWord# x))
+
+iw8 :: Int8# -> Word8#
+iw8 x = wordToWord8# (int2Word# (int8ToInt# x))
+
+iw16 :: Int16# -> Word16#
+iw16 x = wordToWord16# (int2Word# (int16ToInt# x))
+
+iw32:: Int32# -> Word32#
+iw32 x = wordToWord32# (int2Word# (int32ToInt# x))
+
+iw64:: Int64# -> Word64#
+iw64 x = wordToWord64# (int2Word# (int64ToInt# x))
+
+i8 :: Int8# -> Int8#
+i8 x = intToInt8# (int8ToInt# x)
+
+i16 :: Int16# -> Int16#
+i16 x = intToInt16# (int16ToInt# x)
+
+i32 :: Int32# -> Int32#
+i32 x = intToInt32# (int32ToInt# x)
+
+i64 :: Int64# -> Int64#
+i64 x = intToInt64# (int64ToInt# x)
+
+w8 :: Word8# -> Word8#
+w8 x = wordToWord8# (word8ToWord# x)
+
+w16 :: Word16# -> Word16#
+w16 x = wordToWord16# (word16ToWord# x)
+
+w32 :: Word32# -> Word32#
+w32 x = wordToWord32# (word32ToWord# x)
+
+w64 :: Word64# -> Word64#
+w64 x = wordToWord64# (word64ToWord# x)
+
+
+w :: Word# -> Word#
+w x = word64ToWord# (wordToWord64# x)
+
+i :: Int# -> Int#
+i x = int64ToInt# (intToInt64# x)
+
+wiw64 :: Word64# -> Word64#
+wiw64 x = int64ToWord64# (word64ToInt64# x)
+
+iwi64 :: Int64# -> Int64#
+iwi64 x = word64ToInt64# (int64ToWord64# x)
+
+ww64i :: Word# -> Int#
+ww64i x = int64ToInt# (word64ToInt64# (wordToWord64# x))
+
+ii64w :: Int# -> Word#
+ii64w x = word64ToWord# (int64ToWord64# (intToInt64# x))
diff --git a/testsuite/tests/numeric/should_compile/T19769.stderr-ws-32 b/testsuite/tests/numeric/should_compile/T19769.stderr-ws-32
new file mode 100644
index 0000000000..21e9fa465c
--- /dev/null
+++ b/testsuite/tests/numeric/should_compile/T19769.stderr-ws-32
@@ -0,0 +1,51 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 68, types: 58, coercions: 0, joins: 0/0}
+
+wi8 = word8ToInt8#
+
+wi16 = word16ToInt16#
+
+wi32 = word32ToInt32#
+
+wi64 = \ x -> intToInt64# (word2Int# (word64ToWord# x))
+
+iw8 = int8ToWord8#
+
+iw16 = int16ToWord16#
+
+iw32 = int32ToWord32#
+
+iw64 = \ x -> wordToWord64# (int2Word# (int64ToInt# x))
+
+i8 = \ x -> x
+
+i16 = \ x -> x
+
+i32 = \ x -> x
+
+i64 = \ x -> intToInt64# (int64ToInt# x)
+
+w8 = \ x -> x
+
+w16 = \ x -> x
+
+w32 = \ x -> x
+
+w64 = \ x -> wordToWord64# (word64ToWord# x)
+
+w = \ x -> x
+
+i = \ x -> x
+
+wiw64 = \ x -> x
+
+iwi64 = \ x -> x
+
+ww64i = word2Int#
+
+ii64w = int2Word#
+
+
+
diff --git a/testsuite/tests/numeric/should_compile/T19769.stderr-ws-64 b/testsuite/tests/numeric/should_compile/T19769.stderr-ws-64
new file mode 100644
index 0000000000..c5620bbf4b
--- /dev/null
+++ b/testsuite/tests/numeric/should_compile/T19769.stderr-ws-64
@@ -0,0 +1,51 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 54, types: 54, coercions: 0, joins: 0/0}
+
+wi8 = word8ToInt8#
+
+wi16 = word16ToInt16#
+
+wi32 = word32ToInt32#
+
+wi64 = word64ToInt64#
+
+iw8 = int8ToWord8#
+
+iw16 = int16ToWord16#
+
+iw32 = int32ToWord32#
+
+iw64 = int64ToWord64#
+
+i8 = \ x -> x
+
+i16 = \ x -> x
+
+i32 = \ x -> x
+
+i64 = \ x -> x
+
+w8 = \ x -> x
+
+w16 = \ x -> x
+
+w32 = \ x -> x
+
+w64 = \ x -> x
+
+w = \ x -> x
+
+i = \ x -> x
+
+wiw64 = w64
+
+iwi64 = i64
+
+ww64i = word2Int#
+
+ii64w = int2Word#
+
+
+
diff --git a/testsuite/tests/numeric/should_compile/T19892.stderr b/testsuite/tests/numeric/should_compile/T19892.stderr
index a82ea9d9d2..499cc9ece9 100644
--- a/testsuite/tests/numeric/should_compile/T19892.stderr
+++ b/testsuite/tests/numeric/should_compile/T19892.stderr
@@ -1,4 +1,4 @@
 Rule fired: Int# -> Integer -> Word# (GHC.Num.Integer)
-Rule fired: int2Word# (BUILTIN)
+Rule fired: Word# -> Int# -> Word# (GHC.Prim.Ext)
 Rule fired: Int# -> Integer -> Int# (GHC.Num.Integer)
 Rule fired: Word# -> Natural -> Word# (GHC.Num.Natural)
diff --git a/testsuite/tests/numeric/should_compile/all.T b/testsuite/tests/numeric/should_compile/all.T
index db6867efeb..5e8259a8fd 100644
--- a/testsuite/tests/numeric/should_compile/all.T
+++ b/testsuite/tests/numeric/should_compile/all.T
@@ -14,3 +14,4 @@ test('T20062', [ grep_errmsg(r'integer') ], compile, ['-ddump-simpl -O -dsuppres
 test('T20245', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds'])
 test('T20376', normal, compile, ['-ddump-simpl -O -dsuppress-all -dsuppress-uniques -dno-typeable-binds'])
 test('T20374', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])
+test('T19769', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])
diff --git a/testsuite/tests/plugins/plugins09.stdout b/testsuite/tests/plugins/plugins09.stdout
index 263fc4bb89..f32fbe4a09 100644
--- a/testsuite/tests/plugins/plugins09.stdout
+++ b/testsuite/tests/plugins/plugins09.stdout
@@ -2,6 +2,7 @@ parsePlugin(a,b)
 interfacePlugin: Prelude
 interfacePlugin: GHC.Base
 interfacePlugin: GHC.Float
+interfacePlugin: GHC.Prim.Ext
 typeCheckPlugin (rn)
 interfacePlugin: GHC.Prim
 typeCheckPlugin (tc)
diff --git a/testsuite/tests/plugins/plugins10.stdout b/testsuite/tests/plugins/plugins10.stdout
index 9433853494..f9aa7f19b6 100644
--- a/testsuite/tests/plugins/plugins10.stdout
+++ b/testsuite/tests/plugins/plugins10.stdout
@@ -4,6 +4,7 @@ interfacePlugin: Language.Haskell.TH
 interfacePlugin: Language.Haskell.TH.Quote
 interfacePlugin: GHC.Base
 interfacePlugin: GHC.Float
+interfacePlugin: GHC.Prim.Ext
 interfacePlugin: Language.Haskell.TH.Syntax
 typeCheckPlugin (rn)
 interfacePlugin: GHC.Prim
diff --git a/testsuite/tests/plugins/plugins11.stdout b/testsuite/tests/plugins/plugins11.stdout
index 83f4c1f185..0a9c0dcb88 100644
--- a/testsuite/tests/plugins/plugins11.stdout
+++ b/testsuite/tests/plugins/plugins11.stdout
@@ -2,6 +2,7 @@ parsePlugin()
 interfacePlugin: Prelude
 interfacePlugin: GHC.Base
 interfacePlugin: GHC.Float
+interfacePlugin: GHC.Prim.Ext
 typeCheckPlugin (rn)
 interfacePlugin: GHC.Prim
 typeCheckPlugin (tc)
diff --git a/testsuite/tests/plugins/static-plugins.stdout b/testsuite/tests/plugins/static-plugins.stdout
index fceea0882a..3f7387fc4c 100644
--- a/testsuite/tests/plugins/static-plugins.stdout
+++ b/testsuite/tests/plugins/static-plugins.stdout
@@ -3,6 +3,7 @@ parsePlugin()
 interfacePlugin: Prelude
 interfacePlugin: GHC.Base
 interfacePlugin: GHC.Float
+interfacePlugin: GHC.Prim.Ext
 interfacePlugin: System.IO
 typeCheckPlugin (rn)
 interfacePlugin: GHC.Prim