[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Arm: Make ppr methods easier to use by not requiring NCGConfig
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Sep 29 15:34:18 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
de5164c8 by Andreas Klebinger at 2023-09-29T11:34:04-04:00
Arm: Make ppr methods easier to use by not requiring NCGConfig
- - - - -
fcb3e181 by Andreas Klebinger at 2023-09-29T11:34:04-04:00
AArch64: Fix broken conditional jumps for offsets >= 1MB
Rewrite conditional jump instructions with offsets >= 1MB to use unconditional jumps
to avoid overflowing the immediate.
Fixes #23746
- - - - -
10 changed files:
- compiler/GHC/CmmToAsm.hs
- compiler/GHC/CmmToAsm/AArch64.hs
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/AArch64/Cond.hs
- compiler/GHC/CmmToAsm/AArch64/Instr.hs
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs
- compiler/GHC/CmmToAsm/BlockLayout.hs
- compiler/GHC/CmmToAsm/Monad.hs
- compiler/GHC/CmmToAsm/PPC/Instr.hs
- compiler/GHC/CmmToAsm/X86.hs
Changes:
=====================================
compiler/GHC/CmmToAsm.hs
=====================================
@@ -655,13 +655,14 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
text "cfg not in lockstep") ()
---- sequence blocks
- let sequenced :: [NatCmmDecl statics instr]
- sequenced =
- checkLayout shorted $
- {-# SCC "sequenceBlocks" #-}
- map (BlockLayout.sequenceTop
- ncgImpl optimizedCFG)
- shorted
+ -- sequenced :: [NatCmmDecl statics instr]
+ let (sequenced, us_seq) =
+ {-# SCC "sequenceBlocks" #-}
+ initUs usAlloc $ mapM (BlockLayout.sequenceTop
+ ncgImpl optimizedCFG)
+ shorted
+
+ massert (checkLayout shorted sequenced)
let branchOpt :: [NatCmmDecl statics instr]
branchOpt =
@@ -684,7 +685,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
addUnwind acc proc =
acc `mapUnion` computeUnwinding config ncgImpl proc
- return ( usAlloc
+ return ( us_seq
, fileIds'
, branchOpt
, lastMinuteImports ++ imports
@@ -704,10 +705,10 @@ maybeDumpCfg logger (Just cfg) msg proc_name
-- | Make sure all blocks we want the layout algorithm to place have been placed.
checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
- -> [NatCmmDecl statics instr]
+ -> Bool
checkLayout procsUnsequenced procsSequenced =
assertPpr (setNull diff) (text "Block sequencing dropped blocks:" <> ppr diff)
- procsSequenced
+ True
where
blocks1 = foldl' (setUnion) setEmpty $
map getBlockIds procsUnsequenced :: LabelSet
=====================================
compiler/GHC/CmmToAsm/AArch64.hs
=====================================
@@ -34,9 +34,9 @@ ncgAArch64 config
,maxSpillSlots = AArch64.maxSpillSlots config
,allocatableRegs = AArch64.allocatableRegs platform
,ncgAllocMoreStack = AArch64.allocMoreStack platform
- ,ncgMakeFarBranches = const id
+ ,ncgMakeFarBranches = AArch64.makeFarBranches
,extractUnwindPoints = const []
- ,invertCondBranches = \_ _ -> id
+ ,invertCondBranches = \_ _ blocks -> blocks
}
where
platform = ncgPlatform config
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -7,6 +7,7 @@
module GHC.CmmToAsm.AArch64.CodeGen (
cmmTopCodeGen
, generateJumpTableForInstr
+ , makeFarBranches
)
where
@@ -43,9 +44,11 @@ import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Cmm.CLabel
import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Graph
import GHC.Types.Tickish ( GenTickish(..) )
import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
+import GHC.Types.Unique.Supply
-- The rest:
import GHC.Data.OrdList
@@ -61,6 +64,9 @@ import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
+import GHC.Utils.Monad (mapAccumLM)
+
+import GHC.Cmm.Dataflow.Collections
-- Note [General layout of an NCG]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -161,15 +167,17 @@ basicBlockCodeGen block = do
let
(top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
- mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
- = ([], BasicBlock id instrs : blocks, statics)
- mkBlocks (LDATA sec dat) (instrs,blocks,statics)
- = (instrs, blocks, CmmData sec dat:statics)
- mkBlocks instr (instrs,blocks,statics)
- = (instr:instrs, blocks, statics)
return (BasicBlock id top : other_blocks, statics)
-
+mkBlocks :: Instr
+ -> ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
+ -> ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
+mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
+ = ([], BasicBlock id instrs : blocks, statics)
+mkBlocks (LDATA sec dat) (instrs,blocks,statics)
+ = (instrs, blocks, CmmData sec dat:statics)
+mkBlocks instr (instrs,blocks,statics)
+ = (instr:instrs, blocks, statics)
-- -----------------------------------------------------------------------------
-- | Utilities
ann :: SDoc -> Instr -> Instr
@@ -1217,6 +1225,7 @@ assignReg_FltCode = assignReg_IntCode
-- -----------------------------------------------------------------------------
-- Jumps
+
genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
genJump expr@(CmmLit (CmmLabel lbl))
= return $ unitOL (annExpr expr (J (TLabel lbl)))
@@ -1302,6 +1311,22 @@ genCondJump bid expr = do
_ -> pprPanic "AArch64.genCondJump:case mop: " (text $ show expr)
_ -> pprPanic "AArch64.genCondJump: " (text $ show expr)
+-- A conditional jump with at least +/-128M jump range
+genCondFarJump :: MonadUnique m => Cond -> Target -> m InstrBlock
+genCondFarJump cond far_target = do
+ skip_lbl_id <- newBlockId
+ jmp_lbl_id <- newBlockId
+
+ -- TODO: We can improve this by inverting the condition
+ -- but it's not quite trivial since we don't know if we
+ -- need to consider float orderings.
+ -- So we take the hit of the additional jump in the false
+ -- case for now.
+ return $ toOL [ BCOND cond (TBlock jmp_lbl_id)
+ , B (TBlock skip_lbl_id)
+ , NEWBLOCK jmp_lbl_id
+ , B far_target
+ , NEWBLOCK skip_lbl_id]
genCondBranch
:: BlockId -- the source of the jump
@@ -1816,3 +1841,163 @@ genCCall target dest_regs arg_regs bid = do
let dst = getRegisterReg platform (CmmLocal dest_reg)
let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)
return (code, Nothing)
+
+{- Note [AArch64 far jumps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+AArch conditional jump instructions can only encode an offset of +/-1MB
+which is usually enough but can be exceeded in edge cases. In these cases
+we will replace:
+
+ b.cond <cond> foo
+
+with the sequence:
+
+ b.cond <cond> <lbl_true>
+ b <lbl_false>
+ <lbl_true>:
+ b foo
+ <lbl_false>:
+
+Note the encoding of the `b` instruction still limits jumps to
++/-128M offsets, but that seems like an acceptable limitation.
+
+Since AArch64 instructions are all of equal length we can reasonably estimate jumps
+in range by counting the instructions between a jump and its target label.
+
+We make some simplifications in the name of performance which can result in overestimating
+jump <-> label offsets:
+
+* To avoid having to recalculate the label offsets once we replaced a jump we simply
+ assume all jumps will be expanded to a three instruction far jump sequence.
+* For labels associated with a info table we assume the info table is 64byte large.
+ Most info tables are smaller than that but it means we don't have to distinguish
+ between multiple types of info tables.
+
+In terms of implementation we walk the instruction stream at least once calculating
+label offsets, and if we determine during this that the functions body is big enough
+to potentially contain out of range jumps we walk the instructions a second time, replacing
+out of range jumps with the sequence of instructions described above.
+
+-}
+
+-- See Note [AArch64 far jumps]
+data BlockInRange = InRange | NotInRange Target
+
+-- See Note [AArch64 far jumps]
+makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr]
+ -> UniqSM [NatBasicBlock Instr]
+makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do
+ -- All offsets/positions are counted in multiples of 4 bytes (the size of AArch64 instructions)
+ -- That is an offset of 1 represents a 4-byte/one instruction offset.
+ let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks
+ if func_size < max_jump_dist
+ then pure basic_blocks
+ else do
+ (_,blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks
+ pure $ concat blocks
+ -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks
+
+ where
+ -- 2^18, 19 bit immediate with one bit is reserved for the sign
+ max_jump_dist = 2^(18::Int) - 1 :: Int
+ -- Currently all inline info tables fit into 64 bytes.
+ max_info_size = 16 :: Int
+ long_bc_jump_size = 3 :: Int
+ long_bz_jump_size = 4 :: Int
+
+ -- Replace out of range conditional jumps with unconditional jumps.
+ replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqSM (Int, [GenBasicBlock Instr])
+ replace_blk !m !pos (BasicBlock lbl instrs) = do
+ -- Account for a potential info table before the label.
+ let !block_pos = pos + infoTblSize_maybe lbl
+ (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs
+ let instrs'' = concat instrs'
+ -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.
+ let (top, split_blocks, no_data) = foldr mkBlocks ([],[],[]) instrs''
+ -- There should be no data in the instruction stream at this point
+ massert (null no_data)
+
+ let final_blocks = BasicBlock lbl top : split_blocks
+ pure (pos', final_blocks)
+
+ replace_jump :: LabelMap Int -> Int -> Instr -> UniqSM (Int, [Instr])
+ replace_jump !m !pos instr = do
+ case instr of
+ ANN ann instr -> do
+ (idx,instr':instrs') <- replace_jump m pos instr
+ pure (idx, ANN ann instr':instrs')
+ BCOND cond t
+ -> case target_in_range m t pos of
+ InRange -> pure (pos+long_bc_jump_size,[instr])
+ NotInRange far_target -> do
+ jmp_code <- genCondFarJump cond far_target
+ pure (pos+long_bc_jump_size, fromOL jmp_code)
+ CBZ op t -> long_zero_jump op t EQ
+ CBNZ op t -> long_zero_jump op t NE
+ instr
+ | isMetaInstr instr -> pure (pos,[instr])
+ | otherwise -> pure (pos+1, [instr])
+
+ where
+ -- cmp_op: EQ = CBZ, NEQ = CBNZ
+ long_zero_jump op t cmp_op =
+ case target_in_range m t pos of
+ InRange -> pure (pos+long_bz_jump_size,[instr])
+ NotInRange far_target -> do
+ jmp_code <- genCondFarJump cmp_op far_target
+ -- TODO: Fix zero reg so we can use it here
+ pure (pos + long_bz_jump_size, CMP op (OpImm (ImmInt 0)) : fromOL jmp_code)
+
+
+ target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange
+ target_in_range m target src =
+ case target of
+ (TReg{}) -> InRange
+ (TBlock bid) -> block_in_range m src bid
+ (TLabel clbl)
+ | Just bid <- maybeLocalBlockLabel clbl
+ -> block_in_range m src bid
+ | otherwise
+ -- Maybe we should be pessimistic here, for now just fixing intra proc jumps
+ -> InRange
+
+ block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange
+ block_in_range m src_pos dest_lbl =
+ case mapLookup dest_lbl m of
+ Nothing ->
+ pprTrace "not in range" (ppr dest_lbl) $
+ NotInRange (TBlock dest_lbl)
+ Just dest_pos -> if abs (dest_pos - src_pos) < max_jump_dist
+ then InRange
+ else NotInRange (TBlock dest_lbl)
+
+ calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int)
+ calc_lbl_positions (pos, m) (BasicBlock lbl instrs)
+ = let !pos' = pos + infoTblSize_maybe lbl
+ in foldl' instr_pos (pos',mapInsert lbl pos' m) instrs
+
+ instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)
+ instr_pos (pos, m) instr =
+ case instr of
+ ANN _ann instr -> instr_pos (pos, m) instr
+ NEWBLOCK _bid -> panic "mkFarBranched - unexpected NEWBLOCK" -- At this point there should be no NEWBLOCK
+ -- in the instruction stream
+ -- (pos, mapInsert bid pos m)
+ COMMENT{} -> (pos, m)
+ instr
+ | Just jump_size <- is_expandable_jump instr -> (pos+jump_size, m)
+ | otherwise -> (pos+1, m)
+
+ infoTblSize_maybe bid =
+ case mapLookup bid statics of
+ Nothing -> 0 :: Int
+ Just _info_static -> max_info_size
+
+ -- These jumps have a 19bit immediate as offset which is quite
+ -- limiting so we potentially have to expand them into
+ -- multiple instructions.
+ is_expandable_jump i = case i of
+ CBZ{} -> Just long_bz_jump_size
+ CBNZ{} -> Just long_bz_jump_size
+ BCOND{} -> Just long_bc_jump_size
+ _ -> Nothing
=====================================
compiler/GHC/CmmToAsm/AArch64/Cond.hs
=====================================
@@ -1,6 +1,6 @@
module GHC.CmmToAsm.AArch64.Cond where
-import GHC.Prelude
+import GHC.Prelude hiding (EQ)
-- https://developer.arm.com/documentation/den0024/a/the-a64-instruction-set/data-processing-instructions/conditional-instructions
@@ -60,7 +60,13 @@ data Cond
| UOGE -- b.pl
| UOGT -- b.hi
-- others
- | NEVER -- b.nv
+ -- NEVER -- b.nv
+ -- I removed never. According to the ARM spec:
+ -- > The Condition code NV exists only to provide a valid disassembly of
+ -- > the 0b1111 encoding, otherwise its behavior is identical to AL.
+ -- This can only lead to disaster. Better to not have it than someone
+ -- using it assuming it actually means never.
+
| VS -- oVerflow set
| VC -- oVerflow clear
deriving Eq
=====================================
compiler/GHC/CmmToAsm/AArch64/Instr.hs
=====================================
@@ -743,6 +743,7 @@ data Target
= TBlock BlockId
| TLabel CLabel
| TReg Reg
+ deriving (Eq, Ord)
-- Extension
=====================================
compiler/GHC/CmmToAsm/AArch64/Ppr.hs
=====================================
@@ -1,7 +1,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
-module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr) where
+module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr, pprBasicBlock) where
import GHC.Prelude hiding (EQ)
@@ -30,10 +30,14 @@ import GHC.Utils.Panic
pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
pprNatCmmDecl config (CmmData section dats) =
- pprSectionAlign config section $$ pprDatas config dats
+ let platform = ncgPlatform config
+ in
+ pprSectionAlign config section $$ pprDatas platform dats
pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
- let platform = ncgPlatform config in
+ let platform = ncgPlatform config
+ with_dwarf = ncgDwarfEnabled config
+ in
case topInfoTable proc of
Nothing ->
-- special case for code without info table:
@@ -41,7 +45,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
-- do not
-- pprProcAlignment config $$
pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed
- vcat (map (pprBasicBlock config top_info) blocks) $$
+ vcat (map (pprBasicBlock platform with_dwarf top_info) blocks) $$
(if ncgDwarfEnabled config
then line (pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':') else empty) $$
pprSizeDecl platform lbl
@@ -52,7 +56,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
(if platformHasSubsectionsViaSymbols platform
then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')
else empty) $$
- vcat (map (pprBasicBlock config top_info) blocks) $$
+ vcat (map (pprBasicBlock platform with_dwarf top_info) blocks) $$
-- above: Even the first block gets a label, because with branch-chain
-- elimination, it might be the target of a goto.
(if platformHasSubsectionsViaSymbols platform
@@ -100,13 +104,13 @@ pprSizeDecl platform lbl
then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl)
else empty
-pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr
+pprBasicBlock :: IsDoc doc => Platform -> {- dwarf enabled -} Bool -> LabelMap RawCmmStatics -> NatBasicBlock Instr
-> doc
-pprBasicBlock config info_env (BasicBlock blockid instrs)
+pprBasicBlock platform with_dwarf info_env (BasicBlock blockid instrs)
= maybe_infotable $
pprLabel platform asmLbl $$
vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$
- (if ncgDwarfEnabled config
+ (if with_dwarf
then line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':')
else empty
)
@@ -117,16 +121,15 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
f _ = True
asmLbl = blockLbl blockid
- platform = ncgPlatform config
maybe_infotable c = case mapLookup blockid info_env of
Nothing -> c
Just (CmmStaticsRaw info_lbl info) ->
-- pprAlignForSection platform Text $$
infoTableLoc $$
- vcat (map (pprData config) info) $$
+ vcat (map (pprData platform) info) $$
pprLabel platform info_lbl $$
c $$
- (if ncgDwarfEnabled config
+ (if with_dwarf
then line (pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':')
else empty)
-- Make sure the info table has the right .loc for the block
@@ -135,34 +138,31 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
(l at LOCATION{} : _) -> pprInstr platform l
_other -> empty
-pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc
+pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc
-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
-pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
+pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
| lbl == mkIndStaticInfoLabel
, let labelInd (CmmLabelOff l _) = Just l
labelInd (CmmLabel l) = Just l
labelInd _ = Nothing
, Just ind' <- labelInd ind
, alias `mayRedirectTo` ind'
- = pprGloblDecl (ncgPlatform config) alias
- $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind')
+ = pprGloblDecl platform alias
+ $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind')
-pprDatas config (CmmStaticsRaw lbl dats)
- = vcat (pprLabel platform lbl : map (pprData config) dats)
- where
- platform = ncgPlatform config
+pprDatas platform (CmmStaticsRaw lbl dats)
+ = vcat (pprLabel platform lbl : map (pprData platform) dats)
-pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc
-pprData _config (CmmString str) = line (pprString str)
-pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path)
+pprData :: IsDoc doc => Platform -> CmmStatic -> doc
+pprData _platform (CmmString str) = line (pprString str)
+pprData _platform (CmmFileEmbed path _) = line (pprFileEmbed path)
-pprData config (CmmUninitialised bytes)
- = line $ let platform = ncgPlatform config
- in if platformOS platform == OSDarwin
+pprData platform (CmmUninitialised bytes)
+ = line $ if platformOS platform == OSDarwin
then text ".space " <> int bytes
else text ".skip " <> int bytes
-pprData config (CmmStaticLit lit) = pprDataItem config lit
+pprData platform (CmmStaticLit lit) = pprDataItem platform lit
pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc
pprGloblDecl platform lbl
@@ -196,12 +196,10 @@ pprTypeDecl platform lbl
then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)
else empty
-pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc
-pprDataItem config lit
+pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc
+pprDataItem platform lit
= lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
where
- platform = ncgPlatform config
-
imm = litToImm lit
ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm]
@@ -355,7 +353,10 @@ pprInstr platform instr = case instr of
-> line (text "\t.loc" <+> int file <+> int line' <+> int col)
DELTA d -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty
-- see Note [dualLine and dualDoc] in GHC.Utils.Outputable
- NEWBLOCK _ -> panic "PprInstr: NEWBLOCK"
+ NEWBLOCK blockid -> -- This is invalid assembly. But NEWBLOCK should never be contained
+ -- in the final instruction stream. But we still want to be able to
+ -- print it for debugging purposes.
+ line (text "BLOCK " <> pprAsmLabel platform (blockLbl blockid))
LDATA _ _ -> panic "pprInstr: LDATA"
-- Pseudo Instructions -------------------------------------------------------
@@ -569,7 +570,7 @@ pprCond c = case c of
UGE -> text "hs" -- Carry set/unsigned higher or same ; Greater than or equal, or unordered
UGT -> text "hi" -- Unsigned higher ; Greater than, or unordered
- NEVER -> text "nv" -- Never
+ -- NEVER -> text "nv" -- Never
VS -> text "vs" -- Overflow ; Unordered (at least one NaN operand)
VC -> text "vc" -- No overflow ; Not unordered
=====================================
compiler/GHC/CmmToAsm/BlockLayout.hs
=====================================
@@ -49,6 +49,7 @@ import Data.STRef
import Control.Monad.ST.Strict
import Control.Monad (foldM, unless)
import GHC.Data.UnionFind
+import GHC.Types.Unique.Supply (UniqSM)
{-
Note [CFG based code layout]
@@ -794,29 +795,32 @@ sequenceTop
=> NcgImpl statics instr jumpDest
-> Maybe CFG -- ^ CFG if we have one.
-> NatCmmDecl statics instr -- ^ Function to serialize
- -> NatCmmDecl statics instr
-
-sequenceTop _ _ top@(CmmData _ _) = top
-sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks))
- = let
- config = ncgConfig ncgImpl
- platform = ncgPlatform config
-
- in CmmProc info lbl live $ ListGraph $ ncgMakeFarBranches ncgImpl info $
- if -- Chain based algorithm
- | ncgCfgBlockLayout config
- , backendMaintainsCfg platform
- , Just cfg <- edgeWeights
- -> {-# SCC layoutBlocks #-} sequenceChain info cfg blocks
-
- -- Old algorithm without edge weights
- | ncgCfgWeightlessLayout config
- || not (backendMaintainsCfg platform)
- -> {-# SCC layoutBlocks #-} sequenceBlocks Nothing info blocks
-
- -- Old algorithm with edge weights (if any)
- | otherwise
- -> {-# SCC layoutBlocks #-} sequenceBlocks edgeWeights info blocks
+ -> UniqSM (NatCmmDecl statics instr)
+
+sequenceTop _ _ top@(CmmData _ _) = pure top
+sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks)) = do
+ let config = ncgConfig ncgImpl
+ platform = ncgPlatform config
+
+ seq_blocks =
+ if -- Chain based algorithm
+ | ncgCfgBlockLayout config
+ , backendMaintainsCfg platform
+ , Just cfg <- edgeWeights
+ -> {-# SCC layoutBlocks #-} sequenceChain info cfg blocks
+
+ -- Old algorithm without edge weights
+ | ncgCfgWeightlessLayout config
+ || not (backendMaintainsCfg platform)
+ -> {-# SCC layoutBlocks #-} sequenceBlocks Nothing info blocks
+
+ -- Old algorithm with edge weights (if any)
+ | otherwise
+ -> {-# SCC layoutBlocks #-} sequenceBlocks edgeWeights info blocks
+
+ far_blocks <- (ncgMakeFarBranches ncgImpl) platform info seq_blocks
+ pure $ CmmProc info lbl live $ ListGraph far_blocks
+
-- The old algorithm:
-- It is very simple (and stupid): We make a graph out of
=====================================
compiler/GHC/CmmToAsm/Monad.hs
=====================================
@@ -93,7 +93,8 @@ data NcgImpl statics instr jumpDest = NcgImpl {
-> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),
-- ^ The list of block ids records the redirected jumps to allow us to update
-- the CFG.
- ncgMakeFarBranches :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],
+ ncgMakeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock instr]
+ -> UniqSM [NatBasicBlock instr],
extractUnwindPoints :: [instr] -> [UnwindPoint],
-- ^ given the instruction sequence of a block, produce a list of
-- the block's 'UnwindPoint's
@@ -140,7 +141,7 @@ mistake would readily show up in performance tests). -}
data NatM_State
= NatM_State {
natm_us :: UniqSupply,
- natm_delta :: Int,
+ natm_delta :: Int, -- ^ Stack offset for unwinding information
natm_imports :: [(CLabel)],
natm_pic :: Maybe Reg,
natm_config :: NCGConfig,
=====================================
compiler/GHC/CmmToAsm/PPC/Instr.hs
=====================================
@@ -688,12 +688,13 @@ takeRegRegMoveInstr _ = Nothing
-- big, we have to work around this limitation.
makeFarBranches
- :: LabelMap RawCmmStatics
+ :: Platform
+ -> LabelMap RawCmmStatics
-> [NatBasicBlock Instr]
- -> [NatBasicBlock Instr]
-makeFarBranches info_env blocks
- | NE.last blockAddresses < nearLimit = blocks
- | otherwise = zipWith handleBlock blockAddressList blocks
+ -> UniqSM [NatBasicBlock Instr]
+makeFarBranches _platform info_env blocks
+ | NE.last blockAddresses < nearLimit = return blocks
+ | otherwise = return $ zipWith handleBlock blockAddressList blocks
where
blockAddresses = NE.scanl (+) 0 $ map blockLen blocks
blockAddressList = toList blockAddresses
=====================================
compiler/GHC/CmmToAsm/X86.hs
=====================================
@@ -38,7 +38,7 @@ ncgX86_64 config = NcgImpl
, maxSpillSlots = X86.maxSpillSlots config
, allocatableRegs = X86.allocatableRegs platform
, ncgAllocMoreStack = X86.allocMoreStack platform
- , ncgMakeFarBranches = const id
+ , ncgMakeFarBranches = \_p _i bs -> pure bs
, extractUnwindPoints = X86.extractUnwindPoints
, invertCondBranches = X86.invertCondBranches
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/941475edc96e8b3f8280fdbf444573fb11c42329...fcb3e181a2e30c54c01a7c2ae89014d16b5079f0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/941475edc96e8b3f8280fdbf444573fb11c42329...fcb3e181a2e30c54c01a7c2ae89014d16b5079f0
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230929/59fedc9f/attachment-0001.html>
More information about the ghc-commits
mailing list