Fix #19931

The issue was the renderer for x86 addressing modes assumes native size
registers, but we were passing in a possibly-smaller index in
conjunction with a native-sized base pointer.

The easist thing to do is just extend the register first.

I also changed the other NGC backends implementing jump tables
accordingly. On one hand, I think PowerPC and Sparc don't have the small
sub-registers anyways so there is less to worry about. On the other
hand, to the extent that's true the zero extension can become a no-op.

I should give credit where it's due: @hsyl20 really did all the work for
me in
https://gitlab.haskell.org/ghc/ghc/-/merge_requests/4717#note_355874,
but I was daft and missed the "Oops" and so ended up spending a silly
amount of time putting it all back together myself.

The unregisterised backend change is a bit different, because here we
are translating the actual case not a jump table, and the fix is to
handle right-sized literals not addressing modes. But it makes sense to
include here too because it's the same change in the subsequent commit
that exposes both bugs.

7 files changed, 69 insertions, 9 deletions

diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
index 8ee20e06f5..67bc3d9bdb 100644
--- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
@@ -2086,7 +2086,7 @@ genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
 genSwitch config expr targets
   | OSAIX <- platformOS platform
   = do
-        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)
+        (reg,e_code) <- getSomeReg indexExpr
         let fmt = archWordFormat $ target32Bit platform
             sha = if target32Bit platform then 2 else 3
         tmp <- getNewRegNat fmt
@@ -2103,7 +2103,7 @@ genSwitch config expr targets
 
   | (ncgPIC config) || (not $ target32Bit platform)
   = do
-        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)
+        (reg,e_code) <- getSomeReg indexExpr
         let fmt = archWordFormat $ target32Bit platform
             sha = if target32Bit platform then 2 else 3
         tmp <- getNewRegNat fmt
@@ -2120,7 +2120,7 @@ genSwitch config expr targets
         return code
   | otherwise
   = do
-        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)
+        (reg,e_code) <- getSomeReg indexExpr
         let fmt = archWordFormat $ target32Bit platform
             sha = if target32Bit platform then 2 else 3
         tmp <- getNewRegNat fmt
@@ -2134,6 +2134,12 @@ genSwitch config expr targets
                     ]
         return code
   where
+    indexExpr = cmmOffset platform exprWidened offset
+    -- We widen to a native-width register to santize the high bits
+    exprWidened = CmmMachOp
+      (MO_UU_Conv (cmmExprWidth platform expr)
+                  (platformWordWidth platform))
+      [expr]
     (offset, ids) = switchTargetsToTable targets
     platform      = ncgPlatform config
 
diff --git a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
index 56f764560c..aeaaf1c9d3 100644
--- a/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/SPARC/CodeGen.hs
@@ -313,7 +313,7 @@ genSwitch config expr targets
         = error "MachCodeGen: sparc genSwitch PIC not finished\n"
 
         | otherwise
-        = do    (e_reg, e_code) <- getSomeReg (cmmOffset (ncgPlatform config) expr offset)
+        = do    (e_reg, e_code) <- getSomeReg indexExpr
 
                 base_reg        <- getNewRegNat II32
                 offset_reg      <- getNewRegNat II32
@@ -334,7 +334,15 @@ genSwitch config expr targets
                         , LD      II32 (AddrRegReg base_reg offset_reg) dst
                         , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label
                         , NOP ]
-  where (offset, ids) = switchTargetsToTable targets
+  where
+    indexExpr = cmmOffset platform exprWidened offset
+    -- We widen to a native-width register to santize the high bits
+    exprWidened = CmmMachOp
+      (MO_UU_Conv (cmmExprWidth platform expr)
+                  (platformWordWidth platform))
+      [expr]
+    (offset, ids) = switchTargetsToTable targets
+    platform = ncgPlatform config
 
 generateJumpTableForInstr :: Platform -> Instr
                           -> Maybe (NatCmmDecl RawCmmStatics Instr)
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
index ff25a2e53f..5e7c261cbb 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -3476,9 +3476,16 @@ genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock
 genSwitch expr targets = do
   config <- getConfig
   let platform = ncgPlatform config
+      -- We widen to a native-width register because we cannot use arbitry sizes
+      -- in x86 addressing modes.
+      exprWidened = CmmMachOp
+        (MO_UU_Conv (cmmExprWidth platform expr)
+                    (platformWordWidth platform))
+        [expr]
+      indexExpr = cmmOffset platform exprWidened offset
   if ncgPIC config
   then do
-        (reg,e_code) <- getNonClobberedReg (cmmOffset platform expr offset)
+        (reg,e_code) <- getNonClobberedReg indexExpr
            -- getNonClobberedReg because it needs to survive across t_code
         lbl <- getNewLabelNat
         let is32bit = target32Bit platform
@@ -3519,7 +3526,7 @@ genSwitch expr targets = do
                                JMP_TBL (OpReg tableReg) ids rosection lbl
                        ]
   else do
-        (reg,e_code) <- getSomeReg (cmmOffset platform expr offset)
+        (reg,e_code) <- getSomeReg indexExpr
         lbl <- getNewLabelNat
         let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))
             code = e_code `appOL` toOL [
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index 8349393f0d..f662f7d996 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -341,15 +341,17 @@ pprSwitch platform e ids
   where
     (pairs, mbdef) = switchTargetsFallThrough ids
 
+    rep = typeWidth (cmmExprType platform e)
+
     -- fall through case
     caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
         where
         do_fallthrough ix =
-                 hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon ,
+                 hsep [ text "case" , pprHexVal platform ix rep <> colon ,
                         text "/* fall through */" ]
 
         final_branch ix =
-                hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon ,
+                hsep [ text "case" , pprHexVal platform ix rep <> colon ,
                        text "goto" , (pprBlockId ident) <> semi ]
 
     caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"
diff --git a/testsuite/tests/numeric/should_run/T19931.hs b/testsuite/tests/numeric/should_run/T19931.hs
new file mode 100644
index 0000000000..1ab9002d2e
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T19931.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.Types
+import GHC.Num
+
+data T = T Word8#
+
+instance Num T where
+  fromInteger i = T (wordToWord8# (integerToWord# i))
+
+instance Eq T where
+  (==) (T a) (T b) = isTrue# (a `eqWord8#` b)
+  (/=) (T a) (T b) = isTrue# (a `neWord8#` b)
+
+main :: IO ()
+main = do
+  let !addr = "\0\1\2\3\4\5\6\7\8"#
+
+  w8 <- IO (\s -> case readWord8OffAddr# (plusAddr# addr 5#) 0# s of
+                      (# s', w8 #) -> (# s', T w8 #))
+  -- w8 must be small enough for one of the branch to be taken.
+  -- we need several alternatives for a jump table to be used
+  print $ case w8 of
+      0 -> 1000
+      1 -> 1001
+      2 -> 1002
+      3 -> 1003
+      4 -> 1004
+      5 -> 1005
+      6 -> 1006
+      _ -> 1010
diff --git a/testsuite/tests/numeric/should_run/T19931.stdout b/testsuite/tests/numeric/should_run/T19931.stdout
new file mode 100644
index 0000000000..49bc2728c7
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T19931.stdout
@@ -0,0 +1 @@
+1005
diff --git a/testsuite/tests/numeric/should_run/all.T b/testsuite/tests/numeric/should_run/all.T
index 028677e52d..1123984bdd 100644
--- a/testsuite/tests/numeric/should_run/all.T
+++ b/testsuite/tests/numeric/should_run/all.T
@@ -74,5 +74,6 @@ test('T18499', normal, compile_and_run, [''])
 test('T18509', normal, compile_and_run, [''])
 test('T18515', normal, compile_and_run, [''])
 test('T18604', normal, compile_and_run, [''])
+test('T19931', normal, compile_and_run, ['-O2'])
 
 test('IntegerToFloat', normal, compile_and_run, [''])