Commit c1bd07cd authored by Andreas Klebinger's avatar Andreas Klebinger Committed by Marge Bot

Fix #17334 where NCG did not properly update the CFG.

Statements can change the basic block in which instructions
are placed during instruction selection.

We have to keep track of this switch of the current basic block
as we need this information in order to properly update the CFG.

This commit implements this change and fixes #17334.

We do so by having stmtToInstr return the new block id
if a statement changed the basic block.
parent 5ab1a28d
Pipeline #11315 passed with stages
in 438 minutes and 58 seconds
......@@ -558,7 +558,6 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
(cmmTopCodeGen ncgImpl)
fileIds dbgMap opt_cmm cmmCfg
dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code"
(vcat $ map (pprNatCmmDecl ncgImpl) native)
......@@ -679,12 +678,13 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)
let cfgWithFixupBlks =
addNodesBetween nativeCfgWeights cfgRegAllocUpdates
(\cfg -> addNodesBetween cfg cfgRegAllocUpdates) <$> livenessCfg
-- Insert stack update blocks
let postRegCFG =
foldl' (\m (from,to) -> addImmediateSuccessor from to m )
cfgWithFixupBlks stack_updt_blks
pure (foldl' (\m (from,to) -> addImmediateSuccessor from to m ))
<*> cfgWithFixupBlks
<*> pure stack_updt_blks
---- generate jump tables
let tabled =
......@@ -701,12 +701,13 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
{-# SCC "shortcutBranches" #-}
shortcutBranches dflags ncgImpl tabled postRegCFG
let optimizedCFG =
optimizeCFG (cfgWeightInfo dflags) cmm postShortCFG
let optimizedCFG :: Maybe CFG
optimizedCFG =
optimizeCFG (cfgWeightInfo dflags) cmm <$!> postShortCFG
dumpIfSet_dyn dflags
Opt_D_dump_cfg_weights "CFG Final Weights"
( pprEdgeWeights optimizedCFG )
maybe (return ())
(dumpIfSet_dyn dflags Opt_D_dump_cfg_weights "CFG Final Weights" . pprEdgeWeights)
optimizedCFG
--TODO: Partially check validity of the cfg.
let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks
......@@ -716,7 +717,8 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
(gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do
let blocks = concatMap getBlks shorted
let labels = setFromList $ fmap blockId blocks :: LabelSet
return $! seq (sanityCheckCfg optimizedCFG labels $
let cfg = fromJust optimizedCFG
return $! seq (sanityCheckCfg cfg labels $
text "cfg not in lockstep") ()
---- sequence blocks
......@@ -734,7 +736,9 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
{-# SCC "invertCondBranches" #-}
map invert sequenced
where
invertConds = (invertCondBranches ncgImpl) optimizedCFG
invertConds :: LabelMap CmmStatics -> [NatBasicBlock instr]
-> [NatBasicBlock instr]
invertConds = invertCondBranches ncgImpl optimizedCFG
invert top@CmmData {} = top
invert (CmmProc info lbl live (ListGraph blocks)) =
CmmProc info lbl live (ListGraph $ invertConds info blocks)
......@@ -884,13 +888,13 @@ shortcutBranches
:: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags
-> NcgImpl statics instr jumpDest
-> [NatCmmDecl statics instr]
-> CFG
-> ([NatCmmDecl statics instr],CFG)
-> Maybe CFG
-> ([NatCmmDecl statics instr],Maybe CFG)
shortcutBranches dflags ncgImpl tops weights
| gopt Opt_AsmShortcutting dflags
= ( map (apply_mapping ncgImpl mapping) tops'
, shortcutWeightMap weights mappingBid )
, shortcutWeightMap mappingBid <$!> weights )
| otherwise
= (tops, weights)
where
......
......@@ -638,8 +638,9 @@ dropJumps info ((BasicBlock lbl ins):todo)
sequenceTop
:: (Instruction instr, Outputable instr)
=> DynFlags --Use new layout code
-> NcgImpl statics instr jumpDest -> CFG
=> DynFlags -- Determine which layout algo to use
-> NcgImpl statics instr jumpDest
-> Maybe CFG -- ^ CFG if we have one.
-> NatCmmDecl statics instr -> NatCmmDecl statics instr
sequenceTop _ _ _ top@(CmmData _ _) = top
......@@ -647,20 +648,17 @@ sequenceTop dflags ncgImpl edgeWeights
(CmmProc info lbl live (ListGraph blocks))
| (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg dflags
--Use chain based algorithm
, Just cfg <- edgeWeights
= CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
sequenceChain info edgeWeights blocks )
sequenceChain info cfg blocks )
| otherwise
--Use old algorithm
= CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
sequenceBlocks cfg info blocks)
= let cfg = if dontUseCfg then Nothing else edgeWeights
in CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
sequenceBlocks cfg info blocks)
where
cfg
| (gopt Opt_WeightlessBlocklayout dflags) ||
(not $ backendMaintainsCfg dflags)
-- Don't make use of cfg in the old algorithm
= Nothing
-- Use cfg in the old algorithm
| otherwise = Just edgeWeights
dontUseCfg = gopt Opt_WeightlessBlocklayout dflags ||
(not $ backendMaintainsCfg dflags)
-- The old algorithm:
-- It is very simple (and stupid): We make a graph out of
......
......@@ -224,8 +224,8 @@ This function (shortcutWeightMap) takes the same mapping and
applies the mapping to the CFG in the way layed out above.
-}
shortcutWeightMap :: CFG -> LabelMap (Maybe BlockId) -> CFG
shortcutWeightMap cfg cuts =
shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG
shortcutWeightMap cuts cfg =
foldl' applyMapping cfg $ mapToList cuts
where
-- takes the tuple (B,C) from the notation in [Updating the CFG during shortcutting]
......@@ -422,7 +422,8 @@ addNodesBetween m updates =
| otherwise
= pprPanic "Can't find weight for edge that should have one" (
text "triple" <+> ppr (from,between,old) $$
text "updates" <+> ppr updates )
text "updates" <+> ppr updates $$
text "cfg:" <+> ppr m )
updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG
updateWeight m (from,between,old,edgeInfo)
= addEdge from between edgeInfo .
......
......@@ -88,7 +88,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
-- the block's 'UnwindPoint's
-- See Note [What is this unwinding business?] in Debug
-- and Note [Unwinding information in the NCG] in this module.
invertCondBranches :: CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]
invertCondBranches :: Maybe CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]
-> [NatBasicBlock instr]
-- ^ Turn the sequence of `jcc l1; jmp l2` into `jncc l2; <block_l1>`
-- when possible.
......
This diff is collapsed.
-- Reproducer for T17334
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}
module T17334 where
import Control.Monad.ST
import Data.Bits
import Data.Kind
import GHC.Exts
import GHC.ST (ST(..))
reverseInPlace :: UMVector s Bit -> ST s ()
reverseInPlace xs = loop 0
where
len = 4
loop !i
| i' < j = do
let w = 1
k = 2
x <- return 1
y <- return 2
writeWord xs i (meld w (reversePartialWord w y) x)
loop i'
where
!j = 5
!i' = i + wordSize
newtype Bit = Bit { unBit :: Bool }
instance Unbox Bit
data instance UMVector s Bit = BitMVec !Int !Int !(MutableByteArray s)
data instance UVector Bit = BitVec !Int !Int !ByteArray
-- {-# NOINLINE writeWord #-}
writeWord :: UMVector s Bit -> Int -> Word -> ST s ()
writeWord !(BitMVec _ 0 _) _ _ = pure ()
writeWord !(BitMVec off len' arr@(MutableByteArray mba)) !i' !x@(W# x#) = do
let len = 5
lenMod = 6
i = 7
nMod = 8
loIx@(I# loIx#) = 9
do
let W# andMask# = hiMask lenMod
W# orMask# = x .&. loMask lenMod
primitive $ \state ->
let !(# state', _ #) = fetchAndIntArray# mba loIx# (word2Int# andMask#) state in
let !(# state'', _ #) = fetchOrIntArray# mba loIx# (word2Int# orMask#) state' in
(# state'', () #)
instance GMVector UMVector Bit where
{-# INLINE basicLength #-}
basicLength (BitMVec _ n _) = n
instance GVector UVector Bit where
wordSize :: Int
wordSize = 10
lgWordSize :: Int
lgWordSize = 11
modWordSize :: Int -> Int
modWordSize x = 12
mask :: Int -> Word
mask b = 13
meld :: Int -> Word -> Word -> Word
meld b lo hi = 14
{-# INLINE meld #-}
reverseWord :: Word -> Word
reverseWord x0 = 15
reversePartialWord :: Int -> Word -> Word
reversePartialWord n w = 16
loMask :: Int -> Word
loMask n = 17
hiMask :: Int -> Word
hiMask n = 18
class GMVector v a where
basicLength :: v s a -> Int
type family GMutable (v :: Type -> Type) :: Type -> Type -> Type
class GMVector (GMutable v) a => GVector v a
data family UMVector s a
data family UVector a
class (GVector UVector a, GMVector UMVector a) => Unbox a
type instance GMutable UVector = UMVector
data ByteArray = ByteArray ByteArray#
data MutableByteArray s = MutableByteArray (MutableByteArray# s)
readByteArray
:: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> m a
{-# INLINE readByteArray #-}
readByteArray (MutableByteArray arr#) (I# i#)
= primitive (readByteArray# arr# i#)
writeByteArray
:: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> a -> m ()
{-# INLINE writeByteArray #-}
writeByteArray (MutableByteArray arr#) (I# i#) x
= primitive_ (writeByteArray# arr# i# x)
class Prim a where
readByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #)
writeByteArray# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s
instance Prim Word where
readByteArray# arr# i# s# = case readWordArray# arr# i# s# of
(# s1#, x# #) -> (# s1#, W# x# #)
writeByteArray# arr# i# (W# x#) s# = writeWordArray# arr# i# x# s#
class Monad m => PrimMonad m where
type PrimState m
primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
instance PrimMonad (ST s) where
type PrimState (ST s) = s
primitive = ST
{-# INLINE primitive #-}
primitive_ :: PrimMonad m
=> (State# (PrimState m) -> State# (PrimState m)) -> m ()
{-# INLINE primitive_ #-}
primitive_ f = primitive (\s# ->
case f s# of
s'# -> (# s'#, () #))
......@@ -61,3 +61,9 @@ test('T15155l', when(unregisterised(), skip),
makefile_test, [])
test('T16449_1', normal, compile, [''])
# Verify that we keep the CFG in sync on x86
test('T17334', [ unless(have_ncg() and (arch('x86_64') or arch('i386')), skip)
, only_ways(['normal'])
], compile, ['-O'])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment