From 0fe2b410ac0d8951f07ffcc9f3c6c97bc312df48 Mon Sep 17 00:00:00 2001
From: Andreas Klebinger <klebinger.andreas@gmx.at>
Date: Fri, 5 Apr 2024 14:53:39 +0200
Subject: [PATCH] NCG: Fix a bug where we errounously removed a required jump
instruction.
Add a new method to the Instruction class to check if we can eliminate a
jump in favour of fallthrough control flow.
Fixes #24507
---
compiler/GHC/CmmToAsm/AArch64.hs | 1 +
compiler/GHC/CmmToAsm/AArch64/Instr.hs | 6 ++++
compiler/GHC/CmmToAsm/BlockLayout.hs | 5 ++-
compiler/GHC/CmmToAsm/Instr.hs | 8 ++++-
compiler/GHC/CmmToAsm/Monad.hs | 26 ++++++++++++++
compiler/GHC/CmmToAsm/PPC.hs | 1 +
compiler/GHC/CmmToAsm/PPC/Instr.hs | 8 +++++
compiler/GHC/CmmToAsm/Reg/Liveness.hs | 5 +++
compiler/GHC/CmmToAsm/X86.hs | 1 +
compiler/GHC/CmmToAsm/X86/Instr.hs | 12 +++++++
testsuite/tests/codeGen/should_run/T24507.hs | 15 ++++++++
.../tests/codeGen/should_run/T24507.stdout | 7 ++++
.../tests/codeGen/should_run/T24507_cmm.cmm | 35 +++++++++++++++++++
13 files changed, 126 insertions(+), 4 deletions(-)
create mode 100644 testsuite/tests/codeGen/should_run/T24507.hs
create mode 100644 testsuite/tests/codeGen/should_run/T24507.stdout
create mode 100644 testsuite/tests/codeGen/should_run/T24507_cmm.cmm
diff --git a/compiler/GHC/CmmToAsm/AArch64.hs b/compiler/GHC/CmmToAsm/AArch64.hs
index 1977aeb1a7ec..66b6ba1f60a4 100644
--- a/compiler/GHC/CmmToAsm/AArch64.hs
+++ b/compiler/GHC/CmmToAsm/AArch64.hs
@@ -47,6 +47,7 @@ instance Instruction AArch64.Instr where
patchRegsOfInstr = AArch64.patchRegsOfInstr
isJumpishInstr = AArch64.isJumpishInstr
jumpDestsOfInstr = AArch64.jumpDestsOfInstr
+ canFallthroughTo = AArch64.canFallthroughTo
patchJumpInstr = AArch64.patchJumpInstr
mkSpillInstr = AArch64.mkSpillInstr
mkLoadInstr = AArch64.mkLoadInstr
diff --git a/compiler/GHC/CmmToAsm/AArch64/Instr.hs b/compiler/GHC/CmmToAsm/AArch64/Instr.hs
index 2fd595d76e47..6d4dad4f774b 100644
--- a/compiler/GHC/CmmToAsm/AArch64/Instr.hs
+++ b/compiler/GHC/CmmToAsm/AArch64/Instr.hs
@@ -317,6 +317,12 @@ jumpDestsOfInstr (BL t _ _) = [ id | TBlock id <- [t]]
jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]]
jumpDestsOfInstr _ = []
+canFallthroughTo :: Instr -> BlockId -> Bool
+canFallthroughTo (ANN _ i) bid = canFallthroughTo i bid
+canFallthroughTo (J (TBlock target)) bid = bid == target
+canFallthroughTo (B (TBlock target)) bid = bid == target
+canFallthroughTo _ _ = False
+
-- | Change the destination of this jump instruction.
-- Used in the linear allocator when adding fixup blocks for join
-- points.
diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs
index 052d4ae3c288..6488c3c24935 100644
--- a/compiler/GHC/CmmToAsm/BlockLayout.hs
+++ b/compiler/GHC/CmmToAsm/BlockLayout.hs
@@ -771,10 +771,9 @@ dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]
dropJumps _ [] = []
dropJumps info (BasicBlock lbl ins:todo)
| Just ins <- nonEmpty ins --This can happen because of shortcutting
- , [dest] <- jumpDestsOfInstr (NE.last ins)
, BasicBlock nextLbl _ : _ <- todo
- , not (mapMember dest info)
- , nextLbl == dest
+ , canFallthroughTo (NE.last ins) nextLbl
+ , not (mapMember nextLbl info)
= BasicBlock lbl (NE.init ins) : dropJumps info todo
| otherwise
= BasicBlock lbl ins : dropJumps info todo
diff --git a/compiler/GHC/CmmToAsm/Instr.hs b/compiler/GHC/CmmToAsm/Instr.hs
index aa8f538e07ee..448173a68254 100644
--- a/compiler/GHC/CmmToAsm/Instr.hs
+++ b/compiler/GHC/CmmToAsm/Instr.hs
@@ -71,11 +71,17 @@ class Instruction instr where
:: instr -> Bool
- -- | Give the possible destinations of this jump instruction.
+ -- | Give the possible *local block* destinations of this jump instruction.
-- Must be defined for all jumpish instructions.
jumpDestsOfInstr
:: instr -> [BlockId]
+ -- | Check if the instr always transfers control flow
+ -- to the given block. Used by code layout to eliminate
+ -- jumps that can be replaced by fall through.
+ canFallthroughTo
+ :: instr -> BlockId -> Bool
+
-- | Change the destination of this jump instruction.
-- Used in the linear allocator when adding fixup blocks for join
diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs
index 38bbca79fcce..2499259b1e42 100644
--- a/compiler/GHC/CmmToAsm/Monad.hs
+++ b/compiler/GHC/CmmToAsm/Monad.hs
@@ -78,8 +78,15 @@ data NcgImpl statics instr jumpDest = NcgImpl {
cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
getJumpDestBlockId :: jumpDest -> Maybe BlockId,
+ -- | Does this jump always jump to a single destination and is shortcutable?
+ --
+ -- We use this to determine shortcutable instructions - See Note [What is shortcutting]
+ -- Note that if we return a destination here we *most* support the relevant shortcutting in
+ -- shortcutStatics for jump tables and shortcutJump for the instructions itself.
canShortcut :: instr -> Maybe jumpDest,
+ -- | Replace references to blockIds with other destinations - used to update jump tables.
shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics,
+ -- | Change the jump destination(s) of an instruction.
shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
-- | 'Module' is only for printing internal labels. See Note [Internal proc
-- labels] in CLabel.
@@ -105,6 +112,25 @@ data NcgImpl statics instr jumpDest = NcgImpl {
-- when possible.
}
+{- Note [supporting shortcutting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For the concept of shortcutting see Note [What is shortcutting].
+
+In order to support shortcutting across multiple backends uniformly we
+use canShortcut, shortcutStatics and shortcutJump.
+
+canShortcut tells us if the backend support shortcutting of a instruction
+and if so what destination we should retarget instruction to instead.
+
+shortcutStatics exists to allow us to update jump destinations in jump tables.
+
+shortcutJump updates the instructions itself.
+
+A backend can opt out of those by always returning Nothing for canShortcut
+and implementing shortcutStatics/shortcutJump as \_ x -> x
+
+-}
+
{- Note [pprNatCmmDeclS and pprNatCmmDeclH]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Each NcgImpl provides two implementations of its CmmDecl printer, pprNatCmmDeclS
diff --git a/compiler/GHC/CmmToAsm/PPC.hs b/compiler/GHC/CmmToAsm/PPC.hs
index 40a629907ffb..60e5767a45e0 100644
--- a/compiler/GHC/CmmToAsm/PPC.hs
+++ b/compiler/GHC/CmmToAsm/PPC.hs
@@ -46,6 +46,7 @@ instance Instruction PPC.Instr where
patchRegsOfInstr = PPC.patchRegsOfInstr
isJumpishInstr = PPC.isJumpishInstr
jumpDestsOfInstr = PPC.jumpDestsOfInstr
+ canFallthroughTo = PPC.canFallthroughTo
patchJumpInstr = PPC.patchJumpInstr
mkSpillInstr = PPC.mkSpillInstr
mkLoadInstr = PPC.mkLoadInstr
diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs
index c0783ae29368..a1ee6f8dae7f 100644
--- a/compiler/GHC/CmmToAsm/PPC/Instr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs
@@ -22,6 +22,7 @@ module GHC.CmmToAsm.PPC.Instr
, patchJumpInstr
, patchRegsOfInstr
, jumpDestsOfInstr
+ , canFallthroughTo
, takeRegRegMoveInstr
, takeDeltaInstr
, mkRegRegMoveInstr
@@ -509,6 +510,13 @@ isJumpishInstr instr
JMP{} -> True
_ -> False
+canFallthroughTo :: Instr -> BlockId -> Bool
+canFallthroughTo instr bid
+ = case instr of
+ BCC _ target _ -> target == bid
+ BCCFAR _ target _ -> target == bid
+ _ -> False
+
-- | Checks whether this instruction is a jump/branch instruction.
-- One that can change the flow of control in a way that the
diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
index 0a0aa247a41f..bb1bc0b451c2 100644
--- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs
+++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
@@ -126,6 +126,11 @@ instance Instruction instr => Instruction (InstrSR instr) where
Instr instr -> isJumpishInstr instr
_ -> False
+ canFallthroughTo i bid
+ = case i of
+ Instr instr -> canFallthroughTo instr bid
+ _ -> False
+
jumpDestsOfInstr i
= case i of
Instr instr -> jumpDestsOfInstr instr
diff --git a/compiler/GHC/CmmToAsm/X86.hs b/compiler/GHC/CmmToAsm/X86.hs
index a13fa2e4656d..835edee7aa0e 100644
--- a/compiler/GHC/CmmToAsm/X86.hs
+++ b/compiler/GHC/CmmToAsm/X86.hs
@@ -51,6 +51,7 @@ instance Instruction X86.Instr where
patchRegsOfInstr = X86.patchRegsOfInstr
isJumpishInstr = X86.isJumpishInstr
jumpDestsOfInstr = X86.jumpDestsOfInstr
+ canFallthroughTo = X86.canFallthroughTo
patchJumpInstr = X86.patchJumpInstr
mkSpillInstr = X86.mkSpillInstr
mkLoadInstr = X86.mkLoadInstr
diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs
index 8cdf26f40e0f..679849123ecc 100644
--- a/compiler/GHC/CmmToAsm/X86/Instr.hs
+++ b/compiler/GHC/CmmToAsm/X86/Instr.hs
@@ -31,6 +31,7 @@ module GHC.CmmToAsm.X86.Instr
, mkSpillInstr
, mkRegRegMoveInstr
, jumpDestsOfInstr
+ , canFallthroughTo
, patchRegsOfInstr
, patchJumpInstr
, isMetaInstr
@@ -669,6 +670,17 @@ isJumpishInstr instr
CALL{} -> True
_ -> False
+canFallthroughTo :: Instr -> BlockId -> Bool
+canFallthroughTo insn bid
+ = case insn of
+ JXX _ target -> bid == target
+ JMP_TBL _ targets _ _ -> all isTargetBid targets
+ _ -> False
+ where
+ isTargetBid target = case target of
+ Nothing -> True
+ Just (DestBlockId target) -> target == bid
+ _ -> False
jumpDestsOfInstr
:: Instr
diff --git a/testsuite/tests/codeGen/should_run/T24507.hs b/testsuite/tests/codeGen/should_run/T24507.hs
new file mode 100644
index 000000000000..31fd42a52c8b
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T24507.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module Main where
+
+import GHC.Exts
+
+foreign import prim "foo" foo :: Int# -> Int#
+
+main = do
+
+ let f x = case x of I# x' -> case foo x' of x -> print (I# x)
+ mapM_ f [1..7]
\ No newline at end of file
diff --git a/testsuite/tests/codeGen/should_run/T24507.stdout b/testsuite/tests/codeGen/should_run/T24507.stdout
new file mode 100644
index 000000000000..f4b0843eecbe
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T24507.stdout
@@ -0,0 +1,7 @@
+1
+2
+2
+2
+2
+2
+2
diff --git a/testsuite/tests/codeGen/should_run/T24507_cmm.cmm b/testsuite/tests/codeGen/should_run/T24507_cmm.cmm
new file mode 100644
index 000000000000..28db7bf7f674
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T24507_cmm.cmm
@@ -0,0 +1,35 @@
+#include "Cmm.h"
+
+bar() {
+ return (2);
+}
+
+foo(W_ x) {
+
+ switch(x) {
+ case 1: goto a;
+ case 2: goto b;
+ case 3: goto c;
+ case 4: goto d;
+ case 5: goto e;
+ case 6: goto f;
+ case 7: goto g;
+ }
+ return (1);
+
+ a:
+ return (1);
+ b:
+ jump bar();
+ c:
+ jump bar();
+ d:
+ jump bar();
+ e:
+ jump bar();
+ f:
+ jump bar();
+ g:
+ jump bar();
+
+}
--
GitLab