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.

(cherry picked from commit 35bbc251b5b0b1292b1335ad2aed349e8a5b79d1)

2 files changed, 19 insertions, 0 deletions

diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs
index 03035b1198..3b7295f9f1 100644
--- a/compiler/GHC/Cmm/Lint.hs
+++ b/compiler/GHC/Cmm/Lint.hs
@@ -98,6 +98,7 @@ lintCmmExpr (CmmLoad expr rep _alignment) = 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 7ab59d3a1e..497bff26ad 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