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.

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