diff options
| author | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2020-08-21 00:39:20 +0200 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2020-08-24 21:35:48 -0400 |
| commit | 5ccf44c6f0e27e83bf2828f0834bb790b1834929 (patch) | |
| tree | 38700e4ee3492a1d5f844edec0bffaced8b6bb0f | |
| parent | 1f6824a168c5ffebb9ef44b7933a667b7b813893 (diff) | |
| download | haskell-5ccf44c6f0e27e83bf2828f0834bb790b1834929.tar.gz | |
Fix types in silly shifts (#18589)
Patch written by Simon. I have only added a testcase.
(cherry picked from commit 364258e0ad25bc95e69745554f5ca831ce80baf8)
| -rw-r--r-- | compiler/GHC/Core/Opt/ConstantFold.hs | 22 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T18589.hs | 12 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
3 files changed, 26 insertions, 9 deletions
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index e6d23f3d0a..3e0932bb50 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -140,11 +140,11 @@ primOpRules nm = \case , inversePrimOp NotIOp ] IntNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp , inversePrimOp IntNegOp ] - ISllOp -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) + ISllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const Bits.shiftL) , rightIdentityPlatform zeroi ] - ISraOp -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR) + ISraOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const Bits.shiftR) , rightIdentityPlatform zeroi ] - ISrlOp -> mkPrimOpRule nm 2 [ shiftRule shiftRightLogical + ISrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumInt shiftRightLogical , rightIdentityPlatform zeroi ] -- Word operations @@ -186,8 +186,8 @@ primOpRules nm = \case , equalArgs >> retLit zerow ] NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp , inversePrimOp NotOp ] - SllOp -> mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ] - SrlOp -> mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ] + SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const Bits.shiftL) ] + SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogical ] -- coercions Word2IntOp -> mkPrimOpRule nm 1 [ liftLitPlatform word2IntLit @@ -474,12 +474,14 @@ wordOpC2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) = wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2) wordOpC2 _ _ _ _ = Nothing -shiftRule :: (Platform -> Integer -> Int -> Integer) -> RuleM CoreExpr +shiftRule :: LitNumType -- Type of the result, either LitNumInt or LitNumWord + -> (Platform -> Integer -> Int -> Integer) + -> RuleM CoreExpr -- Shifts take an Int; hence third arg of op is Int -- Used for shift primops --- ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word# +-- ISllOp, ISraOp, ISrlOp :: Int# -> Int# -> Int# -- SllOp, SrlOp :: Word# -> Int# -> Word# -shiftRule shift_op +shiftRule lit_num_ty shift_op = do { platform <- getPlatform ; [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs ; case e1 of @@ -487,7 +489,9 @@ shiftRule shift_op -> return e1 -- See Note [Guarding against silly shifts] | shift_len < 0 || shift_len > toInteger (platformWordSizeInBits platform) - -> return $ Lit $ mkLitNumberWrap platform LitNumInt 0 + -> return $ Lit $ mkLitNumberWrap platform lit_num_ty 0 + -- Be sure to use lit_num_ty here, so we get a correctly typed zero + -- of type Int# or Word# resp. See #18589 -- Do the shift at type Integer, but shift length is Int Lit (LitNumber nt x) diff --git a/testsuite/tests/simplCore/should_compile/T18589.hs b/testsuite/tests/simplCore/should_compile/T18589.hs new file mode 100644 index 0000000000..c892bc844e --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T18589.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE MagicHash #-} +module T18589 where + +import GHC.Prim + +-- See Note [Guarding against silly shifts] +-- Make sure that a silly shift is optimized correctly +f1 x = uncheckedIShiftL# x -1# +f2 x = uncheckedIShiftRA# x -1# +f3 x = uncheckedIShiftRL# x -1# +f4 x = uncheckedShiftL# x -1# +f5 x = uncheckedShiftRL# x -1# diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 0abd79858b..d32f72c603 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -332,3 +332,4 @@ test('T18328', [ only_ways(['optasm']), grep_errmsg(r'Arity=') ], compile, ['-dd test('T18347', normal, compile, ['-dcore-lint -O']) test('T18355', [ grep_errmsg(r'OneShot') ], compile, ['-O -ddump-simpl -dsuppress-uniques']) test('T18399', normal, compile, ['-dcore-lint -O']) +test('T18589', normal, compile, ['-dcore-lint -O']) |