diff --git a/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs --- a/GHC/Cmm/Lexer.hs +++ b/GHC/Cmm/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 13 "_build/source-dist/ghc-9.4.7-src/ghc-9.4.7/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 13 "_build/source-dist/ghc-9.4.8-src/ghc-9.4.8/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer ( CmmToken(..), cmmlex, ) where @@ -385,7 +385,7 @@ , (0,alex_action_20) ] -{-# LINE 133 "_build/source-dist/ghc-9.4.7-src/ghc-9.4.7/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 133 "_build/source-dist/ghc-9.4.8-src/ghc-9.4.8/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken = CmmT_SpecChar Char | CmmT_DotDot diff --git a/GHC/CmmToAsm.hs b/GHC/CmmToAsm.hs --- a/GHC/CmmToAsm.hs +++ b/GHC/CmmToAsm.hs @@ -130,6 +130,7 @@ import GHC.Utils.BufHandle import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic +import GHC.Utils.Panic.Plain ( massert ) import GHC.Utils.Error import GHC.Utils.Exception (evaluate) import GHC.Utils.Constants (debugIsOn) @@ -648,14 +649,15 @@ 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 = {-# SCC "invertCondBranches" #-} @@ -677,7 +679,7 @@ addUnwind acc proc = acc `mapUnion` computeUnwinding config ncgImpl proc - return ( usAlloc + return ( us_seq , fileIds' , branchOpt , lastMinuteImports ++ imports @@ -697,10 +699,10 @@ -- | 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) (ppr "Block sequencing dropped blocks:" <> ppr diff) - procsSequenced + assertPpr (setNull diff) (text "Block sequencing dropped blocks:" <> ppr diff) + True where blocks1 = foldl' (setUnion) setEmpty $ map getBlockIds procsUnsequenced :: LabelSet diff --git a/GHC/CmmToAsm/AArch64.hs b/GHC/CmmToAsm/AArch64.hs --- a/GHC/CmmToAsm/AArch64.hs +++ b/GHC/CmmToAsm/AArch64.hs @@ -32,9 +32,9 @@ ,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 diff --git a/GHC/CmmToAsm/AArch64/CodeGen.hs b/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -6,6 +6,7 @@ module GHC.CmmToAsm.AArch64.CodeGen ( cmmTopCodeGen , generateJumpTableForInstr + , makeFarBranches ) where @@ -42,9 +43,11 @@ 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 @@ -59,7 +62,10 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Monad (mapAccumLM) +import GHC.Cmm.Dataflow.Collections + -- Note [General layout of an NCG] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @cmmTopCodeGen@ will be our main entry point to code gen. Here we'll get @@ -158,15 +164,17 @@ 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 @@ -1168,6 +1176,7 @@ -- ----------------------------------------------------------------------------- -- Jumps + genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock genJump expr@(CmmLit (CmmLabel lbl)) = return $ unitOL (annExpr expr (J (TLabel lbl))) @@ -1253,7 +1262,23 @@ _ -> 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 -> BlockId -- the true branch target @@ -1743,3 +1768,163 @@ 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 foo + +with the sequence: + + b.cond + b + : + b foo + : + +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 + massertPpr (null no_data) $ text "There should be no data in the instruction stream" + + 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 diff --git a/GHC/CmmToAsm/AArch64/Cond.hs b/GHC/CmmToAsm/AArch64/Cond.hs --- a/GHC/CmmToAsm/AArch64/Cond.hs +++ b/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 @@ | 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 diff --git a/GHC/CmmToAsm/AArch64/Instr.hs b/GHC/CmmToAsm/AArch64/Instr.hs --- a/GHC/CmmToAsm/AArch64/Instr.hs +++ b/GHC/CmmToAsm/AArch64/Instr.hs @@ -713,6 +713,7 @@ = TBlock BlockId | TLabel CLabel | TReg Reg + deriving (Eq, Ord) -- Extension diff --git a/GHC/CmmToAsm/AArch64/Ppr.hs b/GHC/CmmToAsm/AArch64/Ppr.hs --- a/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/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) @@ -364,7 +364,10 @@ LOCATION file line col _name -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col DELTA d -> asmComment $ text ("\tdelta = " ++ show d) - 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. + text "BLOCK " <> pprLabel platform (blockLbl blockid) LDATA _ _ -> panic "pprInstr: LDATA" -- Pseudo Instructions ------------------------------------------------------- @@ -560,7 +563,7 @@ 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 diff --git a/GHC/CmmToAsm/BlockLayout.hs b/GHC/CmmToAsm/BlockLayout.hs --- a/GHC/CmmToAsm/BlockLayout.hs +++ b/GHC/CmmToAsm/BlockLayout.hs @@ -48,6 +48,7 @@ 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] @@ -797,29 +798,32 @@ => NcgImpl statics instr jumpDest -> Maybe CFG -- ^ CFG if we have one. -> NatCmmDecl statics instr -- ^ Function to serialize - -> NatCmmDecl statics instr + -> UniqSM (NatCmmDecl statics instr) -sequenceTop _ _ top@(CmmData _ _) = top -sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks)) - = let - config = ncgConfig ncgImpl - platform = ncgPlatform config +sequenceTop _ _ top@(CmmData _ _) = pure top +sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks)) = do + 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 + 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 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 + -- 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 diff --git a/GHC/CmmToAsm/Monad.hs b/GHC/CmmToAsm/Monad.hs --- a/GHC/CmmToAsm/Monad.hs +++ b/GHC/CmmToAsm/Monad.hs @@ -92,7 +92,8 @@ -> 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 @@ -107,7 +108,7 @@ 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, diff --git a/GHC/CmmToAsm/PPC/Instr.hs b/GHC/CmmToAsm/PPC/Instr.hs --- a/GHC/CmmToAsm/PPC/Instr.hs +++ b/GHC/CmmToAsm/PPC/Instr.hs @@ -675,12 +675,13 @@ -- big, we have to work around this limitation. makeFarBranches - :: LabelMap RawCmmStatics - -> [NatBasicBlock Instr] + :: Platform + -> LabelMap RawCmmStatics -> [NatBasicBlock Instr] -makeFarBranches info_env blocks - | last blockAddresses < nearLimit = blocks - | otherwise = zipWith handleBlock blockAddresses blocks + -> UniqSM [NatBasicBlock Instr] +makeFarBranches _platform info_env blocks + | last blockAddresses < nearLimit = return blocks + | otherwise = return $ zipWith handleBlock blockAddresses blocks where blockAddresses = scanl (+) 0 $ map blockLen blocks blockLen (BasicBlock _ instrs) = length instrs diff --git a/GHC/CmmToAsm/Ppr.hs b/GHC/CmmToAsm/Ppr.hs --- a/GHC/CmmToAsm/Ppr.hs +++ b/GHC/CmmToAsm/Ppr.hs @@ -242,6 +242,11 @@ OtherSection _ -> panic "PprBase.pprGNUSectionHeader: unknown section type" flags = case t of + Text + | OSMinGW32 <- platformOS platform, splitSections + -> text ",\"xr\"" + | splitSections + -> text ",\"ax\"," <> sectionType platform "progbits" CString | OSMinGW32 <- platformOS platform -> empty diff --git a/GHC/CmmToAsm/X86.hs b/GHC/CmmToAsm/X86.hs --- a/GHC/CmmToAsm/X86.hs +++ b/GHC/CmmToAsm/X86.hs @@ -37,7 +37,7 @@ , 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 } diff --git a/GHC/Driver/Pipeline.hs b/GHC/Driver/Pipeline.hs --- a/GHC/Driver/Pipeline.hs +++ b/GHC/Driver/Pipeline.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} - +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -122,6 +122,7 @@ import Data.Time ( getCurrentTime ) import GHC.Iface.Recomp +import GHC.Types.Unique.DSet -- Simpler type synonym for actions in the pipeline monad type P m = TPipelineClass TPhase m @@ -472,8 +473,18 @@ -- next, check libraries. XXX this only checks Haskell libraries, -- not extra_libraries or -l things from the command line. + -- pkg_deps is just the direct dependencies so take the transitive closure here + -- to decide if we need to relink or not. + let pkg_hslibs acc uid + | uid `elementOfUniqDSet` acc = acc + | Just c <- lookupUnitId unit_state uid = + foldl' @[] pkg_hslibs (addOneToUniqDSet acc uid) (unitDepends c) + | otherwise = acc + + all_pkg_deps = foldl' @[] pkg_hslibs emptyUniqDSet pkg_deps + let pkg_hslibs = [ (collectLibraryDirs (ways dflags) [c], lib) - | Just c <- map (lookupUnitId unit_state) pkg_deps, + | Just c <- map (lookupUnitId unit_state) (uniqDSetToList all_pkg_deps), lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ] pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs diff --git a/GHC/Parser/HaddockLex.hs b/GHC/Parser/HaddockLex.hs --- a/GHC/Parser/HaddockLex.hs +++ b/GHC/Parser/HaddockLex.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 1 "_build/source-dist/ghc-9.4.7-src/ghc-9.4.7/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 1 "_build/source-dist/ghc-9.4.8-src/ghc-9.4.8/compiler/GHC/Parser/HaddockLex.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -110,7 +110,7 @@ , (0,alex_action_1) ] -{-# LINE 87 "_build/source-dist/ghc-9.4.7-src/ghc-9.4.7/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 87 "_build/source-dist/ghc-9.4.8-src/ghc-9.4.8/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput { alexInput_position :: !RealSrcLoc , alexInput_string :: !ByteString diff --git a/GHC/Parser/Lexer.hs b/GHC/Parser/Lexer.hs --- a/GHC/Parser/Lexer.hs +++ b/GHC/Parser/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 43 "_build/source-dist/ghc-9.4.7-src/ghc-9.4.7/compiler/GHC/Parser/Lexer.x" #-} +{-# LINE 43 "_build/source-dist/ghc-9.4.8-src/ghc-9.4.8/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} @@ -609,7 +609,7 @@ , (0,alex_action_84) ] -{-# LINE 700 "_build/source-dist/ghc-9.4.7-src/ghc-9.4.7/compiler/GHC/Parser/Lexer.x" #-} +{-# LINE 700 "_build/source-dist/ghc-9.4.8-src/ghc-9.4.8/compiler/GHC/Parser/Lexer.x" #-} -- ----------------------------------------------------------------------------- -- The token type diff --git a/GHC/Stg/InferTags/Rewrite.hs b/GHC/Stg/InferTags/Rewrite.hs --- a/GHC/Stg/InferTags/Rewrite.hs +++ b/GHC/Stg/InferTags/Rewrite.hs @@ -366,7 +366,10 @@ fvs <- fvArgs args -- lcls <- getFVs -- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls) - return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) + + -- We mark the closure updatable to retain sharing in the case that + -- conExpr is an infinite recursive data type. See #23783. + return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) rewriteRhs _binding (StgRhsClosure fvs ccs flag args body) = do withBinders NotTopLevel args $ withClosureLcls fvs $ diff --git a/GHC/StgToCmm/CgUtils.hs b/GHC/StgToCmm/CgUtils.hs --- a/GHC/StgToCmm/CgUtils.hs +++ b/GHC/StgToCmm/CgUtils.hs @@ -173,15 +173,18 @@ BaseReg -> baseAddr _other -> CmmLoad baseAddr (globalRegType platform reg) NaturallyAligned - CmmRegOff (CmmGlobal reg) offset -> + CmmRegOff greg@(CmmGlobal reg) offset -> -- RegOf leaves are just a shorthand form. If the reg maps -- to a real reg, we keep the shorthand, otherwise, we just -- expand it and defer to the above code. + -- NB: to ensure type correctness we need to ensure the Add + -- as well as the Int need to be of the same size as the + -- register. case reg `elem` activeStgRegs platform of True -> expr - False -> CmmMachOp (MO_Add (wordWidth platform)) [ - fixExpr (CmmReg (CmmGlobal reg)), + False -> CmmMachOp (MO_Add (cmmRegWidth platform greg)) [ + fixExpr (CmmReg greg), CmmLit (CmmInt (fromIntegral offset) - (wordWidth platform))] + (cmmRegWidth platform greg))] other_expr -> other_expr diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc -Version: 9.4.7 +Version: 9.4.8 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team @@ -91,9 +91,9 @@ transformers == 0.5.*, exceptions == 0.10.*, stm, - ghc-boot == 9.4.7, - ghc-heap == 9.4.7, - ghci == 9.4.7 + ghc-boot == 9.4.8, + ghc-heap == 9.4.8, + ghci == 9.4.8 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.13