ghc-lib 9.6.5.20240423 → 9.6.6.20240701

raw patch · 18 files changed

+224/−144 lines, 18 filesdep ~ghc-lib-parserPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/GHC/ByteCode/Instr.hs +1/−1
• compiler/GHC/CmmToAsm/AArch64.hs +1/−0
• compiler/GHC/CmmToAsm/AArch64/Instr.hs +6/−0
• compiler/GHC/CmmToAsm/BlockLayout.hs +2/−3
• compiler/GHC/CmmToAsm/Instr.hs +7/−1
• compiler/GHC/CmmToAsm/Monad.hs +26/−0
• compiler/GHC/CmmToAsm/PPC.hs +1/−0
• compiler/GHC/CmmToAsm/PPC/CodeGen.hs +1/−1
• compiler/GHC/CmmToAsm/PPC/Instr.hs +8/−0
• compiler/GHC/CmmToAsm/Reg/Liveness.hs +5/−0
• compiler/GHC/CmmToAsm/X86.hs +1/−0
• compiler/GHC/CmmToAsm/X86/Instr.hs +12/−0
• compiler/GHC/CoreToStg.hs +33/−34
• compiler/GHC/Driver/Make.hs +100/−90
• compiler/GHC/Driver/Pipeline/Execute.hs +12/−8
• compiler/GHC/StgToCmm/Prim.hs +2/−2
• compiler/GHC/ThToHs.hs +2/−1
• ghc-lib.cabal +4/−3

@@ -82,7 +82,7 @@    | PUSH16_W !Word16    | PUSH32_W !Word16 -   -- Push a ptr  (these all map to PUSH_G really)+   -- Push a (heap) ptr  (these all map to PUSH_G really)    | PUSH_G       Name    | PUSH_PRIMOP  PrimOp    | PUSH_BCO     (ProtoBCO Name)

@@ -47,6 +47,7 @@         patchRegsOfInstr        = AArch64.patchRegsOfInstr         isJumpishInstr          = AArch64.isJumpishInstr         jumpDestsOfInstr        = AArch64.jumpDestsOfInstr+        canFallthroughTo        = AArch64.canFallthroughTo         patchJumpInstr          = AArch64.patchJumpInstr         mkSpillInstr            = AArch64.mkSpillInstr         mkLoadInstr             = AArch64.mkLoadInstr

@@ -324,6 +324,12 @@ 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.

@@ -777,10 +777,9 @@ 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

@@ -71,10 +71,16 @@                 :: 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.

@@ -79,8 +79,15 @@     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 @@     -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@     -- 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -46,6 +46,7 @@    patchRegsOfInstr    = PPC.patchRegsOfInstr    isJumpishInstr      = PPC.isJumpishInstr    jumpDestsOfInstr    = PPC.jumpDestsOfInstr+   canFallthroughTo    = PPC.canFallthroughTo    patchJumpInstr      = PPC.patchJumpInstr    mkSpillInstr        = PPC.mkSpillInstr    mkLoadInstr         = PPC.mkLoadInstr

@@ -1752,7 +1752,7 @@                                 _ -> panic "genCall': unknown calling conv."          argReps = map (cmmExprType platform) args-        (argHints, _) = foreignTargetHints target+        (_, argHints) = foreignTargetHints target          roundTo a x | x `mod` a == 0 = x                     | otherwise = x + a - (x `mod` a)

@@ -22,6 +22,7 @@    , patchJumpInstr    , patchRegsOfInstr    , jumpDestsOfInstr+   , canFallthroughTo    , takeRegRegMoveInstr    , takeDeltaInstr    , mkRegRegMoveInstr@@ -498,6 +499,13 @@     BL{}        -> True     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.

@@ -133,6 +133,11 @@                 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

@@ -51,6 +51,7 @@    patchRegsOfInstr        = X86.patchRegsOfInstr    isJumpishInstr          = X86.isJumpishInstr    jumpDestsOfInstr        = X86.jumpDestsOfInstr+   canFallthroughTo        = X86.canFallthroughTo    patchJumpInstr          = X86.patchJumpInstr    mkSpillInstr            = X86.mkSpillInstr    mkLoadInstr             = X86.mkLoadInstr

@@ -30,6 +30,7 @@    , mkSpillInstr    , mkRegRegMoveInstr    , jumpDestsOfInstr+   , canFallthroughTo    , patchRegsOfInstr    , patchJumpInstr    , isMetaInstr@@ -642,6 +643,17 @@         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

@@ -19,8 +19,7 @@ import GHC.Prelude  import GHC.Core-import GHC.Core.Utils   ( exprType, findDefault, isJoinBind-                        , exprIsTickedString_maybe )+import GHC.Core.Utils import GHC.Core.Opt.Arity   ( manifestArity ) import GHC.Core.Type import GHC.Core.TyCon@@ -49,7 +48,7 @@ import GHC.Data.FastString import GHC.Platform        ( Platform ) import GHC.Platform.Ways-import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )+import GHC.Builtin.PrimOps  import GHC.Utils.Outputable import GHC.Utils.Monad@@ -574,6 +573,19 @@ -- This is the guy that turns applications into A-normal form -- --------------------------------------------------------------------------- +getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg+-- A (non-erased) trivial CoreArg corresponds to an atomic StgArg.+-- CoreArgs may not immediately look trivial, e.g., `case e of {}` or+-- `case unsafeequalityProof of UnsafeRefl -> e` might intervene.+-- Good thing we can just call `trivial_expr_fold` here.+getStgArgFromTrivialArg e+  | Just s <- exprIsTickedString_maybe e -- This case is just for backport to GHC 9.8,+  = StgLitArg (LitString s)              -- where we used to treat strings as valid StgArgs+  | otherwise+  = trivial_expr_fold StgVarArg StgLitArg panic panic e+  where+    panic = pprPanic "getStgArgFromTrivialArg" (ppr e)+ coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish]) coreToStgArgs []   = return ([], [])@@ -586,42 +598,29 @@   = do { (args', ts) <- coreToStgArgs args        ; return (StgVarArg coercionTokenId : args', ts) } -coreToStgArgs (Tick t e : args)-  = assert (not (tickishIsCode t)) $-    do { (args', ts) <- coreToStgArgs (e : args)-       ; let !t' = coreToStgTick (exprType e) t-       ; return (args', t':ts) }- coreToStgArgs (arg : args) = do         -- Non-type argument     (stg_args, ticks) <- coreToStgArgs args-    arg' <- coreToStgExpr arg-    let-        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'-        stg_arg = case arg'' of-           StgApp v []                  -> StgVarArg v-           StgConApp con _ [] _         -> StgVarArg (dataConWorkId con)-           StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op)-           StgLit lit                   -> StgLitArg lit-           _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'')--        -- WARNING: what if we have an argument like (v `cast` co)-        --          where 'co' changes the representation type?-        --          (This really only happens if co is unsafe.)-        -- Then all the getArgAmode stuff in CgBindery will set the-        -- cg_rep of the CgIdInfo based on the type of v, rather-        -- than the type of 'co'.-        -- This matters particularly when the function is a primop-        -- or foreign call.-        -- Wanted: a better solution than this hacky warning-+    -- We know that `arg` must be trivial, but it may contain Ticks.+    -- Example from test case `decodeMyStack`:+    --   $ @... ((src<decodeMyStack.hs:18:26-28> Data.Tuple.snd) @Int @[..])+    -- Note that unfortunately the Tick is not at the top.+    -- So we'll traverse the expression twice:+    --   * Once with `stripTicksT` (which collects *all* ticks from the expression)+    --   * and another time with `getStgArgFromTrivialArg`.+    -- Since the argument is trivial, the only place the Tick can occur is+    -- somehow wrapping a variable (give or take type args, as above).     platform <- getPlatform-    let-        arg_rep = typePrimRep (exprType arg)-        stg_arg_rep = typePrimRep (stgArgType stg_arg)+    let arg_ty = exprType arg+        ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg)+        arg' = getStgArgFromTrivialArg arg+        arg_rep = typePrimRep arg_ty+        stg_arg_rep = typePrimRep (stgArgType arg')         bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) -    warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $-     return (stg_arg : stg_args, ticks ++ aticks)+    massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg)+    warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) (return ())++    return (arg' : stg_args, ticks' ++ ticks)  coreToStgTick :: Type -- type of the ticked expression               -> CoreTickish

@@ -149,6 +149,7 @@ import GHC.Rename.Names import GHC.Utils.Constants import GHC.Types.Unique.DFM (udfmRestrictKeysSet)+import GHC.Types.Unique.Map import qualified Data.IntSet as I import GHC.Types.Unique @@ -307,16 +308,16 @@  -- Note [Missing home modules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Sometimes user doesn't want GHC to pick up modules, not explicitly listed--- in a command line. For example, cabal may want to enable this warning--- when building a library, so that GHC warns user about modules, not listed--- neither in `exposed-modules`, nor in `other-modules`.+-- Sometimes we don't want GHC to process modules that weren't specified as+-- explicit targets. For example, cabal may want to enable this warning+-- when building a library, so that GHC warns the user about modules listed+-- neither in `exposed-modules` nor in `other-modules`. ----- Here "home module" means a module, that doesn't come from an other package.+-- Here "home module" means a module that doesn't come from another package. -- -- For example, if GHC is invoked with modules "A" and "B" as targets, -- but "A" imports some other module "C", then GHC will issue a warning--- about module "C" not being listed in a command line.+-- about module "C" not being listed in the command line. -- -- The warning in enabled by `-Wmissing-home-modules`. See #13129 warnMissingHomeModules ::  DynFlags -> [Target] -> ModuleGraph -> DriverMessages@@ -327,8 +328,6 @@   where     diag_opts = initDiagOpts dflags -    is_known_module mod = any (is_my_target mod) targets-     -- We need to be careful to handle the case where (possibly     -- path-qualified) filenames (aka 'TargetFile') rather than module     -- names are being passed on the GHC command-line.@@ -337,28 +336,30 @@     -- `ghc --make -isrc-exe Main` are supposed to be equivalent.     -- Note also that we can't always infer the associated module name     -- directly from the filename argument.  See #13727.-    is_my_target mod target =-      let tuid = targetUnitId target-      in case targetId target of-          TargetModule name-            -> moduleName (ms_mod mod) == name-                && tuid == ms_unitid mod-          TargetFile target_file _-            | Just mod_file <- ml_hs_file (ms_location mod)-            ->-             augmentByWorkingDirectory dflags target_file == mod_file ||+    is_known_module mod =+      (Map.lookup (moduleName (ms_mod mod)) mod_targets == Just (ms_unitid mod))+      ||+      maybe False is_file_target (ml_hs_file (ms_location mod)) -             --  Don't warn on B.hs-boot if B.hs is specified (#16551)-             addBootSuffix target_file == mod_file ||+    is_file_target file = Set.member (withoutExt file) file_targets -             --  We can get a file target even if a module name was-             --  originally specified in a command line because it can-             --  be converted in guessTarget (by appending .hs/.lhs).-             --  So let's convert it back and compare with module name-             mkModuleName (fst $ splitExtension target_file)-              == moduleName (ms_mod mod)-          _ -> False+    file_targets = Set.fromList (mapMaybe file_target targets) +    file_target Target {targetId} =+      case targetId of+        TargetModule _ -> Nothing+        TargetFile file _ ->+          Just (withoutExt (augmentByWorkingDirectory dflags file))++    mod_targets = Map.fromList (mod_target <$> targets)++    mod_target Target {targetUnitId, targetId} =+      case targetId of+        TargetModule name -> (name, targetUnitId)+        TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId)++    withoutExt = fst . splitExtension+     missing = map (moduleName . ms_mod) $       filter (not . is_known_module) $         (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)@@ -1544,8 +1545,8 @@        let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549            root_map = mkRootMap rootSummariesOk        checkDuplicates root_map-       (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)-       let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)+       (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map)+       let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env)        let unit_env = hsc_unit_env hsc_env        let tmpfs    = hsc_tmpfs    hsc_env @@ -1639,19 +1640,19 @@          -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit         loopSummaries :: [ModSummary]-              -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId),+              -> (M.Map NodeKey ModuleGraphNode,                     DownsweepCache)-              -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)+              -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache)         loopSummaries [] done = return done-        loopSummaries (ms:next) (done, pkgs, summarised)+        loopSummaries (ms:next) (done, summarised)           | Just {} <- M.lookup k done-          = loopSummaries next (done, pkgs, summarised)+          = loopSummaries next (done, summarised)           -- Didn't work out what the imports mean yet, now do that.           | otherwise = do-             (final_deps, pkgs1, done', summarised') <- loopImports (calcDeps ms) done summarised+             (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised              -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.-             (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'-             loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', pkgs1 `Set.union` pkgs, summarised'')+             (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'+             loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', summarised'')           where             k = NodeKey_Module (msKey ms) @@ -1669,18 +1670,17 @@                         -- Visited set; the range is a list because                         -- the roots can have the same module names                         -- if allow_dup_roots is True-             -> IO ([NodeKey], Set.Set (UnitId, UnitId),-+             -> IO ([NodeKey],                   M.Map NodeKey ModuleGraphNode, DownsweepCache)                         -- The result is the completed NodeMap-        loopImports [] done summarised = return ([], Set.empty, done, summarised)+        loopImports [] done summarised = return ([], done, summarised)         loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised           | Just summs <- M.lookup cache_key summarised           = case summs of               [Right ms] -> do                 let nk = NodeKey_Module (msKey ms)-                (rest, pkgs, summarised', done') <- loopImports ss done summarised-                return (nk: rest, pkgs, summarised', done')+                (rest, summarised', done') <- loopImports ss done summarised+                return (nk: rest, summarised', done')               [Left _err] ->                 loopImports ss done summarised               _errs ->  do@@ -1692,69 +1692,79 @@                                        Nothing excl_mods                case mb_s of                    NotThere -> loopImports ss done summarised-                   External uid -> do-                    (other_deps, pkgs, done', summarised') <- loopImports ss done summarised-                    return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised')+                   External _ -> do+                    (other_deps, done', summarised') <- loopImports ss done summarised+                    return (other_deps, done', summarised')                    FoundInstantiation iud -> do-                    (other_deps, pkgs, done', summarised') <- loopImports ss done summarised-                    return (NodeKey_Unit iud : other_deps, pkgs, done', summarised')+                    (other_deps, done', summarised') <- loopImports ss done summarised+                    return (NodeKey_Unit iud : other_deps, done', summarised')                    FoundHomeWithError (_uid, e) ->  loopImports ss done (Map.insert cache_key [(Left e)] summarised)                    FoundHome s -> do-                     (done', pkgs1, summarised') <--                       loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised)-                     (other_deps, pkgs2, final_done, final_summarised) <- loopImports ss done' summarised'+                     (done', summarised') <-+                       loopSummaries [s] (done, Map.insert cache_key [Right s] summarised)+                     (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'                       -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.-                     return (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised)+                     return (NodeKey_Module (msKey s) : other_deps, final_done, final_summarised)           where             cache_key = (home_uid, mb_pkg, unLoc <$> gwib)             home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)             GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib             wanted_mod = L loc mod --- This function checks then important property that if both p and q are home units+-- | This function checks then important property that if both p and q are home units -- then any dependency of p, which transitively depends on q is also a home unit.-checkHomeUnitsClosed ::  UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]--- Fast path, trivially closed.-checkHomeUnitsClosed ue home_id_set home_imp_ids-  | Set.size home_id_set == 1 = []-  | otherwise =-  let res = foldMap loop home_imp_ids-  -- Now check whether everything which transitively depends on a home_unit is actually a home_unit-  -- These units are the ones which we need to load as home packages but failed to do for some reason,-  -- it's a bug in the tool invoking GHC.-      bad_unit_ids = Set.difference res home_id_set-  in if Set.null bad_unit_ids-        then []-        else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]-+--+-- See Note [Multiple Home Units], section 'Closure Property'.+checkHomeUnitsClosed ::  UnitEnv -> [DriverMessages]+checkHomeUnitsClosed ue+    | Set.null bad_unit_ids = []+    | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]   where+    home_id_set = unitEnv_keys $ ue_home_unit_graph ue+    bad_unit_ids = upwards_closure Set.\\ home_id_set     rootLoc = mkGeneralSrcSpan (fsLit "<command line>")-    -- TODO: This could repeat quite a bit of work but I struggled to write this function.-    -- Which units transitively depend on a home unit-    loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit-    loop (from_uid, uid) =-      let us = ue_findHomeUnitEnv from_uid ue in-      let um = unitInfoMap (homeUnitEnv_units us) in-      case Map.lookup uid um of-        Nothing -> pprPanic "uid not found" (ppr uid)-        Just ui ->-          let depends = unitDepends ui-              home_depends = Set.fromList depends `Set.intersection` home_id_set-              other_depends = Set.fromList depends `Set.difference` home_id_set-          in-            -- Case 1: The unit directly depends on a home_id-            if not (null home_depends)-              then-                let res = foldMap (loop . (from_uid,)) other_depends-                in Set.insert uid res-             -- Case 2: Check the rest of the dependencies, and then see if any of them depended on-              else-                let res = foldMap (loop . (from_uid,)) other_depends-                in-                  if not (Set.null res)-                    then Set.insert uid res-                    else res++    graph :: Graph (Node UnitId UnitId)+    graph = graphFromEdgedVerticesUniq graphNodes++    -- downwards closure of graph+    downwards_closure+      = graphFromEdgedVerticesUniq [ DigraphNode uid uid (Set.toList deps)+                                   | (uid, deps) <- M.toList (allReachable graph node_key)]++    inverse_closure = transposeG downwards_closure++    upwards_closure = Set.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]++    all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)+    all_unit_direct_deps+      = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue+      where+        go rest this this_uis =+           plusUniqMap_C Set.union+             (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))+             rest+           where+             external_depends = mapUniqMap (Set.fromList . unitDepends)+                              $ listToUniqMap $ Map.toList+                              $ unitInfoMap this_units+             this_units = homeUnitEnv_units this_uis+             this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]++    graphNodes :: [Node UnitId UnitId]+    graphNodes = go Set.empty home_id_set+      where+        go done todo+          = case Set.minView todo of+              Nothing -> []+              Just (uid, todo')+                | Set.member uid done -> go done todo'+                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of+                    Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))+                    Just depends ->+                      let todo'' = (depends Set.\\ done) `Set.union` todo'+                      in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''  -- | Update the every ModSummary that is depended on -- by a module that needs template haskell. We enable codegen to

@@ -1094,14 +1094,18 @@ The command used for object linking is set using the -pgmlm and -optlm command-line options. -Sadly, the LLD linker that we use on Windows does not support the `-r` flag-needed to support object merging (see #21068). For this reason on Windows we do-not support GHCi objects.  To deal with foreign stubs we build a static archive-of all of a module's object files instead merging them. Consequently, we can-end up producing `.o` files which are in fact static archives. However,-toolchains generally don't have a problem with this as they use file headers,-not the filename, to determine the nature of inputs.+However, `ld -r` is broken in some cases: + * The LLD linker that we use on Windows does not support the `-r`+   flag needed to support object merging (see #21068). For this reason+   on Windows we do not support GHCi objects.++In these cases, we bundle a module's own object file with its foreign+stub's object file, instead of merging them. Consequently, we can end+up producing `.o` files which are in fact static archives. This can+only work if `ar -L` is supported, so the archive `.o` files can be+properly added to the final static library.+ Note that this has somewhat non-obvious consequences when producing initializers and finalizers. See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.@@ -1126,7 +1130,7 @@ -- | See Note [Object merging]. joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO () joinObjectFiles hsc_env o_files output_fn-  | can_merge_objs && not dashLSupported = do+  | can_merge_objs = do   let toolSettings' = toolSettings dflags       ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'       ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (

@@ -2026,8 +2026,8 @@                    -> CmmType  -- ^ index type                    -> AlignmentSpec alignmentFromTypes ty idx_ty-  | typeWidth ty < typeWidth idx_ty = NaturallyAligned-  | otherwise                       = Unaligned+  | typeWidth ty <= typeWidth idx_ty = NaturallyAligned+  | otherwise                        = Unaligned  doIndexOffAddrOp :: Maybe MachOp                  -> CmmType

@@ -1442,7 +1442,8 @@                             ; return                                    $ ListPat noAnn ps'} cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t-                            ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') }+                            ; let pp = parenthesizePat sigPrec p'+                            ; return $ SigPat noAnn pp (mkHsPatSigType noAnn t') } cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p                             ; return $ ViewPat noAnn e' p'} 

@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-version: 9.6.5.20240423+version: 9.6.6.20240701 license: BSD-3-Clause license-file: LICENSE category: Development@@ -53,13 +53,14 @@     manual: True     description: Pass -DTHREADED_RTS to the C toolchain library-    default-language:   Haskell2010+    default-language: Haskell2010     exposed: False     include-dirs:         rts/include         ghc-lib/stage0/lib         ghc-lib/stage0/compiler/build         compiler+    ghc-options: -fno-safe-haskell     if flag(threaded-rts)         ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS         cc-options: -DTHREADED_RTS@@ -90,7 +91,7 @@         stm,         rts,         hpc >= 0.6 && < 0.8,-        ghc-lib-parser == 9.6.5.20240423+        ghc-lib-parser == 9.6.6.20240701     build-tool-depends: alex:alex >= 3.1, happy:happy > 1.20     other-extensions:         BangPatterns