summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJohn Ericson <git@JohnEricson.me>2019-10-19 18:59:48 -0400
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-04-10 05:31:49 -0400
commitc363108e13f4b198b77cea870cb8d9e76c8a7e55 (patch)
treed3d59270b516b8625210ae210ac54369897b7faf
parenteb1a86bbbb622c557fadf2fb33188c6724c7eaab (diff)
downloadhaskell-c363108e13f4b198b77cea870cb8d9e76c8a7e55.tar.gz
Add missing relational constant folding for sized numeric types
-rw-r--r--compiler/GHC/Core/Opt/ConstantFold.hs78
-rw-r--r--testsuite/tests/primops/should_run/NonNativeSwitch.hs47
-rw-r--r--testsuite/tests/primops/should_run/NonNativeSwitch.stdout3
-rw-r--r--testsuite/tests/primops/should_run/all.T1
4 files changed, 118 insertions, 11 deletions
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 237a87d6c4..e7f834268d 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -520,18 +520,83 @@ primOpRules nm = \case
, semiInversePrimOp DoubleNegOp ]
DoubleDecode_Int64Op -> mkPrimOpRule nm 1 [ unaryLit doubleDecodeOp ]
- -- Relational operators
+ -- Relational operators, equality
+
+ Int8EqOp -> mkRelOpRule nm (==) [ litEq True ]
+ Int8NeOp -> mkRelOpRule nm (/=) [ litEq False ]
+
+ Int16EqOp -> mkRelOpRule nm (==) [ litEq True ]
+ Int16NeOp -> mkRelOpRule nm (/=) [ litEq False ]
+
+ Int32EqOp -> mkRelOpRule nm (==) [ litEq True ]
+ Int32NeOp -> mkRelOpRule nm (/=) [ litEq False ]
IntEqOp -> mkRelOpRule nm (==) [ litEq True ]
IntNeOp -> mkRelOpRule nm (/=) [ litEq False ]
+
+ Word8EqOp -> mkRelOpRule nm (==) [ litEq True ]
+ Word8NeOp -> mkRelOpRule nm (/=) [ litEq False ]
+
+ Word16EqOp -> mkRelOpRule nm (==) [ litEq True ]
+ Word16NeOp -> mkRelOpRule nm (/=) [ litEq False ]
+
+ Word32EqOp -> mkRelOpRule nm (==) [ litEq True ]
+ Word32NeOp -> mkRelOpRule nm (/=) [ litEq False ]
+
+ WordEqOp -> mkRelOpRule nm (==) [ litEq True ]
+ WordNeOp -> mkRelOpRule nm (/=) [ litEq False ]
+
CharEqOp -> mkRelOpRule nm (==) [ litEq True ]
CharNeOp -> mkRelOpRule nm (/=) [ litEq False ]
+ FloatEqOp -> mkFloatingRelOpRule nm (==)
+ FloatNeOp -> mkFloatingRelOpRule nm (/=)
+
+ DoubleEqOp -> mkFloatingRelOpRule nm (==)
+ DoubleNeOp -> mkFloatingRelOpRule nm (/=)
+
+ -- Relational operators, ordering
+
+ Int8GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
+ Int8GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
+ Int8LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
+ Int8LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
+
+ Int16GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
+ Int16GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
+ Int16LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
+ Int16LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
+
+ Int32GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
+ Int32GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
+ Int32LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
+ Int32LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
+
IntGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
IntGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
IntLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
IntLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
+ Word8GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
+ Word8GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
+ Word8LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
+ Word8LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
+
+ Word16GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
+ Word16GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
+ Word16LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
+ Word16LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
+
+ Word32GtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
+ Word32GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
+ Word32LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
+ Word32LtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
+
+ WordGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
+ WordGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
+ WordLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
+ WordLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
+
CharGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
CharGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
CharLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
@@ -541,22 +606,13 @@ primOpRules nm = \case
FloatGeOp -> mkFloatingRelOpRule nm (>=)
FloatLeOp -> mkFloatingRelOpRule nm (<=)
FloatLtOp -> mkFloatingRelOpRule nm (<)
- FloatEqOp -> mkFloatingRelOpRule nm (==)
- FloatNeOp -> mkFloatingRelOpRule nm (/=)
DoubleGtOp -> mkFloatingRelOpRule nm (>)
DoubleGeOp -> mkFloatingRelOpRule nm (>=)
DoubleLeOp -> mkFloatingRelOpRule nm (<=)
DoubleLtOp -> mkFloatingRelOpRule nm (<)
- DoubleEqOp -> mkFloatingRelOpRule nm (==)
- DoubleNeOp -> mkFloatingRelOpRule nm (/=)
- WordGtOp -> mkRelOpRule nm (>) [ boundsCmp Gt ]
- WordGeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]
- WordLeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]
- WordLtOp -> mkRelOpRule nm (<) [ boundsCmp Lt ]
- WordEqOp -> mkRelOpRule nm (==) [ litEq True ]
- WordNeOp -> mkRelOpRule nm (/=) [ litEq False ]
+ -- Misc
AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ]
diff --git a/testsuite/tests/primops/should_run/NonNativeSwitch.hs b/testsuite/tests/primops/should_run/NonNativeSwitch.hs
new file mode 100644
index 0000000000..eae37d949d
--- /dev/null
+++ b/testsuite/tests/primops/should_run/NonNativeSwitch.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import GHC.Exts
+import GHC.Word (Word8(..), Word16(..), Word32(..))
+
+-- We expect these ifs to be rewritten into core switches. Then they
+-- will become C-- switches possibly after ifs again. Either way, C--
+-- switches only supported native comparisons before, so this tests that
+-- non-native ones work.
+
+main :: IO ()
+main = do
+ let W8# five = 5
+ switch8 five
+ let W16# five = 5
+ switch16 five
+ let W32# five = 5
+ switch32 five
+
+{-# NOINLINE switch8 #-}
+switch8 :: Word8# -> IO ()
+switch8 n =
+ if isTrue# (n `eqWord8#` three)
+ then putStrLn "Word8 is 3"
+ else putStrLn "Word8 is not 3"
+ where
+ W8# three = 3
+
+{-# NOINLINE switch16 #-}
+switch16 :: Word16# -> IO ()
+switch16 n =
+ if isTrue# (n `eqWord16#` three)
+ then putStrLn "Word16 is 3"
+ else putStrLn "Word16 is not 3"
+ where
+ W16# three = 3
+
+{-# NOINLINE switch32 #-}
+switch32 :: Word32# -> IO ()
+switch32 n =
+ if isTrue# (n `eqWord32#` three)
+ then putStrLn "Word32 is 3"
+ else putStrLn "Word32 is not 3"
+ where
+ W32# three = 3
diff --git a/testsuite/tests/primops/should_run/NonNativeSwitch.stdout b/testsuite/tests/primops/should_run/NonNativeSwitch.stdout
new file mode 100644
index 0000000000..45d7461794
--- /dev/null
+++ b/testsuite/tests/primops/should_run/NonNativeSwitch.stdout
@@ -0,0 +1,3 @@
+Word8 is not 3
+Word16 is not 3
+Word32 is not 3
diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T
index dbb82fd11e..954cc30ef9 100644
--- a/testsuite/tests/primops/should_run/all.T
+++ b/testsuite/tests/primops/should_run/all.T
@@ -36,3 +36,4 @@ test('ShrinkSmallMutableArrayA', normal, compile_and_run, [''])
test('ShrinkSmallMutableArrayB', normal, compile_and_run, [''])
test('T14664', normal, compile_and_run, [''])
test('CStringLength', normal, compile_and_run, ['-O2'])
+test('NonNativeSwitch', normal, compile_and_run, ['-O2'])