diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs --- a/compiler/GHC/ByteCode/Instr.hs +++ b/compiler/GHC/ByteCode/Instr.hs @@ -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) diff --git a/compiler/GHC/CmmToAsm/AArch64.hs b/compiler/GHC/CmmToAsm/AArch64.hs --- a/compiler/GHC/CmmToAsm/AArch64.hs +++ b/compiler/GHC/CmmToAsm/AArch64.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/AArch64/Instr.hs b/compiler/GHC/CmmToAsm/AArch64/Instr.hs --- a/compiler/GHC/CmmToAsm/AArch64/Instr.hs +++ b/compiler/GHC/CmmToAsm/AArch64/Instr.hs @@ -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. diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs --- a/compiler/GHC/CmmToAsm/BlockLayout.hs +++ b/compiler/GHC/CmmToAsm/BlockLayout.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/Instr.hs b/compiler/GHC/CmmToAsm/Instr.hs --- a/compiler/GHC/CmmToAsm/Instr.hs +++ b/compiler/GHC/CmmToAsm/Instr.hs @@ -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. diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs --- a/compiler/GHC/CmmToAsm/Monad.hs +++ b/compiler/GHC/CmmToAsm/Monad.hs @@ -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; \@ -- 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/CmmToAsm/PPC.hs b/compiler/GHC/CmmToAsm/PPC.hs --- a/compiler/GHC/CmmToAsm/PPC.hs +++ b/compiler/GHC/CmmToAsm/PPC.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -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) diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs --- a/compiler/GHC/CmmToAsm/PPC/Instr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Instr.hs @@ -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. diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs --- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs +++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/X86.hs b/compiler/GHC/CmmToAsm/X86.hs --- a/compiler/GHC/CmmToAsm/X86.hs +++ b/compiler/GHC/CmmToAsm/X86.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -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 diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -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 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 diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -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 "") - -- 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 diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -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) ( diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -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 diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -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'} diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -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