summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2021-11-08 09:30:46 -0500
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-12-02 18:13:30 -0500
commit35bbc251b5b0b1292b1335ad2aed349e8a5b79d1 (patch)
treec1e7bb029966a4c89dcd733ed5942f8c8d60b6c7
parent78b78ac463b0b8aad688edcea3c4af447854b929 (diff)
downloadhaskell-35bbc251b5b0b1292b1335ad2aed349e8a5b79d1.tar.gz
cmm: Disallow shifts larger than shiftee
Previously primops.txt.pp stipulated that the word-size shift primops were only defined for shift offsets in [0, word_size). However, there was no further guidance for the definition of Cmm's sub-word size shift MachOps. Here we fix this by explicitly disallowing (checked in many cases by CmmLint) shift operations where the shift offset is larger than the shiftee. This is consistent with LLVM's shift operations, avoiding the miscompilation noted in #20637.
-rw-r--r--compiler/GHC/Cmm/Lint.hs17
-rw-r--r--compiler/GHC/Cmm/MachOp.hs2
2 files changed, 19 insertions, 0 deletions
diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs
index 7225a64141..82d7b56d14 100644
--- a/compiler/GHC/Cmm/Lint.hs
+++ b/compiler/GHC/Cmm/Lint.hs
@@ -98,6 +98,7 @@ lintCmmExpr (CmmLoad expr rep) = do
lintCmmExpr expr@(CmmMachOp op args) = do
platform <- getPlatform
tys <- mapM lintCmmExpr args
+ lintShiftOp op (zip args tys)
if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op
then cmmCheckMachOp op args tys
else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op)
@@ -110,6 +111,22 @@ lintCmmExpr expr =
do platform <- getPlatform
return (cmmExprType platform expr)
+-- | Check for obviously out-of-bounds shift operations
+lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()
+lintShiftOp op [(_, arg_ty), (CmmLit (CmmInt n _), _)]
+ | isShiftOp op
+ , n >= fromIntegral (widthInBits (typeWidth arg_ty))
+ = cmmLintErr (text "Shift operation" <+> pprMachOp op
+ <+> text "has out-of-range offset" <+> ppr n
+ <> text ". This will result in undefined behavior")
+lintShiftOp _ _ = return ()
+
+isShiftOp :: MachOp -> Bool
+isShiftOp (MO_Shl _) = True
+isShiftOp (MO_U_Shr _) = True
+isShiftOp (MO_S_Shr _) = True
+isShiftOp _ = False
+
-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs
index 7004fece51..cd2d331a58 100644
--- a/compiler/GHC/Cmm/MachOp.hs
+++ b/compiler/GHC/Cmm/MachOp.hs
@@ -102,6 +102,8 @@ data MachOp
| MO_Or Width
| MO_Xor Width
| MO_Not Width
+
+ -- Shifts. The shift amount must be in [0,widthInBits).
| MO_Shl Width
| MO_U_Shr Width -- unsigned shift right
| MO_S_Shr Width -- signed shift right